From 8a0fe14b2ed1a032f2bbe67355a5597b76bae104 Mon Sep 17 00:00:00 2001
From: Finley McIlwaine <finleymcilwaine@gmail.com>
Date: Thu, 8 Jun 2023 11:18:59 -0600
Subject: [PATCH] hi-haddock squashed
---
.github/workflows/ci.yml | 2 +-
CHANGES.md | 14 +
cabal.project | 8 +-
doc/cheatsheet/haddocks.md | 5 +-
doc/invoking.rst | 85 +-
doc/markup.rst | 13 +-
haddock-api/haddock-api.cabal | 13 +-
haddock-api/src/Documentation/Haddock.hs | 1 -
haddock-api/src/Haddock.hs | 109 +-
haddock-api/src/Haddock/Backends/Hoogle.hs | 161 ++-
.../src/Haddock/Backends/Hyperlinker.hs | 7 +-
.../Haddock/Backends/Hyperlinker/Renderer.hs | 4 +-
.../src/Haddock/Backends/Hyperlinker/Utils.hs | 2 +-
haddock-api/src/Haddock/Backends/LaTeX.hs | 63 +-
haddock-api/src/Haddock/Backends/Xhtml.hs | 100 +-
.../src/Haddock/Backends/Xhtml/Decl.hs | 44 +-
.../src/Haddock/Backends/Xhtml/Layout.hs | 11 +-
.../src/Haddock/Backends/Xhtml/Names.hs | 18 +-
.../src/Haddock/Backends/Xhtml/Utils.hs | 18 +-
haddock-api/src/Haddock/Convert.hs | 212 ++-
haddock-api/src/Haddock/GhcUtils.hs | 67 +-
haddock-api/src/Haddock/Interface.hs | 400 +++---
.../src/Haddock/Interface/AttachInstances.hs | 257 +++-
haddock-api/src/Haddock/Interface/Create.hs | 1271 ++++++-----------
.../src/Haddock/Interface/LexParseRn.hs | 286 ++--
haddock-api/src/Haddock/Interface/Rename.hs | 434 +++---
.../src/Haddock/Interface/RenameType.hs | 217 +++
.../src/Haddock/Interface/Specialize.hs | 407 ------
haddock-api/src/Haddock/InterfaceFile.hs | 25 +-
haddock-api/src/Haddock/Options.hs | 48 +-
haddock-api/src/Haddock/Syb.hs | 113 --
haddock-api/src/Haddock/Types.hs | 564 +++++---
haddock-library/haddock-library.cabal | 4 +-
.../src/Documentation/Haddock/Doc.hs | 15 +-
haddock-test/haddock-test.cabal | 4 +-
haddock.cabal | 11 +-
hoogle-test/ref/Bug722/test.txt | 2 +-
hoogle-test/ref/Bug806/test.txt | 8 +-
hoogle-test/ref/Bug825/test.txt | 2 +-
hoogle-test/ref/Bug992/test.txt | 4 +-
hoogle-test/ref/classes/test.txt | 2 +-
hoogle-test/ref/type-sigs/test.txt | 12 +-
hoogle-test/src/Bug722/Bug722.hs | 4 +-
hoogle-test/src/Bug806/Bug806.hs | 7 +-
hoogle-test/src/Bug992/Bug992.hs | 4 +-
html-test/ref/Bug1004.html | 509 ++++++-
html-test/ref/Bug1033.html | 74 +-
html-test/ref/Bug1035.html | 2 +-
html-test/ref/Bug1050.html | 16 +-
html-test/ref/Bug294.html | 6 +-
html-test/ref/Bug466.html | 108 +-
html-test/ref/Bug548.html | 436 +++++-
html-test/ref/Bug574.html | 2 +-
html-test/ref/Bug613.html | 12 +-
html-test/ref/Bug679.html | 2 +-
html-test/ref/Bug8.html | 2 +-
html-test/ref/Bug85.html | 18 +-
html-test/ref/Bug923.html | 86 +-
html-test/ref/Bug973.html | 8 +-
html-test/ref/BundledPatterns.html | 30 +-
html-test/ref/BundledPatterns2.html | 18 +-
html-test/ref/ConstructorPatternExport.html | 2 +-
html-test/ref/DefaultAssociatedTypes.html | 10 +-
html-test/ref/DefaultSignatures.html | 14 +-
html-test/ref/DeprecatedTypeFamily.html | 24 +-
html-test/ref/FunArgs.html | 14 +-
html-test/ref/GADTRecords.html | 30 +-
html-test/ref/Identifiers.html | 6 +-
html-test/ref/Instances.html | 306 ++--
html-test/ref/LinearTypes.html | 12 +-
html-test/ref/Operators.html | 28 +-
html-test/ref/PatternSyns.html | 20 +-
html-test/ref/PromotedTypes.html | 54 +-
html-test/ref/QuasiExpr.html | 2 +-
html-test/ref/QuasiQuote.html | 2 +-
.../ref/SpuriousSuperclassConstraints.html | 6 +-
html-test/ref/TH.html | 2 +-
html-test/ref/TH2.html | 2 +-
html-test/ref/Test.html | 130 +-
html-test/ref/Threaded.html | 2 +-
html-test/ref/Ticket112.html | 2 +-
html-test/ref/TypeFamilies.html | 424 ++++--
html-test/ref/TypeFamilies3.html | 2 +-
html-test/ref/TypeOperators.html | 38 +-
html-test/src/Bug294.hs | 14 +-
html-test/src/Bug466.hs | 4 +-
html-test/src/{Bug745.hs => Bug574.hs} | 0
html-test/src/Bug647.hs | 6 +-
html-test/src/Bug85.hs | 6 +-
html-test/src/Bug923.hs | 4 +-
html-test/src/{Bug975.hs => Bug973.hs} | 0
html-test/src/BundledPatterns.hs | 6 +-
html-test/src/ConstructorPatternExport.hs | 4 +-
html-test/src/DefaultAssociatedTypes.hs | 4 +-
html-test/src/DeprecatedTypeFamily.hs | 6 +-
html-test/src/FunArgs.hs | 2 +-
html-test/src/Operators.hs | 4 +-
html-test/src/PatternSyns.hs | 4 +-
html-test/src/PromotedTypes.hs | 8 +-
.../src/SpuriousSuperclassConstraints.hs | 3 +-
html-test/src/TypeFamilies.hs | 8 +-
hypsrc-test/Main.hs | 7 +-
.../DefaultSignatures/DefaultSignatures.tex | 9 +-
latex-test/ref/LinearTypes/LinearTypes.tex | 2 +-
.../ref/TypeFamilies3/TypeFamilies3.tex | 2 +-
105 files changed, 4543 insertions(+), 3079 deletions(-)
create mode 100644 haddock-api/src/Haddock/Interface/RenameType.hs
delete mode 100644 haddock-api/src/Haddock/Interface/Specialize.hs
delete mode 100644 haddock-api/src/Haddock/Syb.hs
rename html-test/src/{Bug745.hs => Bug574.hs} (100%)
rename html-test/src/{Bug975.hs => Bug973.hs} (100%)
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
index dafcdc74d8..4c3c94ebdb 100644
--- a/.github/workflows/ci.yml
+++ b/.github/workflows/ci.yml
@@ -53,4 +53,4 @@ jobs:
cabal build all
- name: Test
- run: cabal test all
+ run: cabal test --test-show-details=direct --test-options="--haddock-stdout=/dev/stdout" all
diff --git a/CHANGES.md b/CHANGES.md
index b0600381f0..55f28c2e58 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,3 +1,17 @@
+## Changes in 2.28.0
+ * `hi-haddock` is integrated, which means docstrings are no longer extracted
+ through typchecked module results. Instead, docstrings are taken from Haskell
+ interface (`.hi`) files.
+
+ * Support qualified and unqualified names in `--ignore-link-symbol`.
+
+ * Add `--trace-args` flag which prints arguments to standard output. This is
+ useful for examining arguments passed when Haddock is invoked through `cabal
+ haddock`, as `cabal` uses temporary response files to pass arguments to
+ Haddock.
+
+ * Avoid recompilation due to changes in optimization flags.
+
## Changes in 2.24.0
* Reify oversaturated data family instances correctly (#1103)
diff --git a/cabal.project b/cabal.project
index e89a2cd531..28290fd794 100644
--- a/cabal.project
+++ b/cabal.project
@@ -1,11 +1,11 @@
-with-compiler: ghc-9.4
+with-compiler: ghc-9.7
packages: ./
./haddock-api
./haddock-library
./haddock-test
-with-compiler: ghc-9.4
+test-show-details: direct
allow-newer:
ghc-paths:Cabal,
@@ -14,10 +14,10 @@ allow-newer:
tree-diff:time
package haddock-library
- tests: False
+ tests: False
package haddock-api
tests: False
-- Pinning the index-state helps to make reasonably CI deterministic
-index-state: 2022-08-05T20:43:48Z
+index-state: 2023-05-22T15:14:29Z
diff --git a/doc/cheatsheet/haddocks.md b/doc/cheatsheet/haddocks.md
index 5ee285b3ac..1b4f851808 100644
--- a/doc/cheatsheet/haddocks.md
+++ b/doc/cheatsheet/haddocks.md
@@ -109,14 +109,13 @@ definitions with "[thing]"
Omit this module from the docs
{-# OPTIONS_HADDOCK prune #-}
Omit definitions without docs
-{-# OPTIONS_HADDOCK ignore-exports #-}
- Treat this module as though all
- top-level items are exported
{-# OPTIONS_HADDOCK not-home #-}
Do not treat this module as the
"home" of identifiers it exports
{-# OPTIONS_HADDOCK show-extensions #-}
Show all enabled LANGUAGE extensions
+{-# OPTIONS_HADDOCK print-explicit-runtime-reps #-}
+ Show all `RuntimeRep` type variables
```
# Grid tables
diff --git a/doc/invoking.rst b/doc/invoking.rst
index 4b7f987cc7..0069f08112 100644
--- a/doc/invoking.rst
+++ b/doc/invoking.rst
@@ -179,7 +179,7 @@ The following options are available:
* Every entity should span exactly one line. ::
newtype ReaderT r (m :: * -> *) a :: * -> (* -> *) -> * -> *
-
+
The one exception to this rule is classes. The body of a class
is split up with one class member per line, an opening brace on
the line of the header, and a closing brace on a new line after
@@ -190,7 +190,7 @@ The following options are available:
type family Baz a;
type Baz a = [(a, a)];
}
-
+
* Entites that are exported only indirectly (for instance data
constructors visible via a ``ReaderT(..)`` export) have their names
wrapped in square brackets. ::
@@ -257,10 +257,6 @@ The following options are available:
name. Note that for the per-entity URLs this is the name of the
*exporting* module.
- - The string ``%F`` or ``%{FILE}`` is replaced by the original
- source file name. Note that for the per-entity URLs this is the
- name of the *defining* module.
-
- The string ``%N`` or ``%{NAME}`` is replaced by the name of the
exported value or type. This is only valid for the
:option:`--source-entity` option.
@@ -275,9 +271,6 @@ The following options are available:
- The string ``%%`` is replaced by ``%``.
- For example, if your sources are online under some directory, you
- would say ``haddock --source-base=url/ --source-module=url/%F``
-
If you have html versions of your sources online with anchors for
each type and function name, you would say
``haddock --source-base=url/ --source-module=url/%M.html --source-entity=url/%M.html#%N``
@@ -288,11 +281,6 @@ The following options are available:
characters in a file name). To replace it with a character c use
``%{MODULE/./c}``.
- Similarly, for the ``%{FILE}`` substitution you may want to replace
- the ``/`` character in the file names with some other character
- (especially for links to colourised entity source code with a shared
- css file). To replace it with a character c use ``%{FILE///c}``/
-
One example of a tool that can generate syntax-highlighted HTML from
your source code, complete with anchors suitable for use from
haddock, is
@@ -485,13 +473,6 @@ The following options are available:
:option:`-i` or :option:`--read-interface`). This is used to generate a single
contents and/or index for multiple sets of Haddock documentation.
-.. option:: --ignore-all-exports
-
- Causes Haddock to behave as if every module has the
- ``ignore-exports`` attribute (:ref:`module-attrs`). This might be useful for
- generating implementation documentation rather than interface
- documentation, for example.
-
.. option:: --hide <module>
Causes Haddock to behave as if module module has the ``hide``
@@ -554,6 +535,13 @@ The following options are available:
Print extra information about any undocumented entities.
+.. option:: --trace-args
+
+ Make Haddock print the arguments it receives to standard output. This is
+ useful for examining arguments when invoking through ``cabal haddock``, as
+ ``cabal`` uses temporary `response files
+ <https://gcc.gnu.org/wiki/Response_Files>`_ to pass arguments to Haddock.
+
Using literate or pre-processed source
--------------------------------------
@@ -561,3 +549,58 @@ Since Haddock uses GHC internally, both plain and literate Haskell
sources are accepted without the need for the user to do anything. To
use the C pre-processor, however, the user must pass the ``-cpp``
option to GHC using :option:`--optghc`.
+
+Avoiding recompilation
+----------------------
+
+With the advent of "hi-haddock", Haddock now produces documentation from ``.hi``
+(Haskell interface) files and ``.hie`` (``.hi`` extended) files [#]_, rather
+than typechecked module results. This means that as long as the necessary
+``.hi`` and ``.hie`` files are available (i.e. produced by your build process),
+recompilation can be avoided during documentation generation.
+
+.. [#] Note that ``.hie`` files are only necessary to build documentation which
+ includes hyperlinked source files `like this one
+ <https://hackage.haskell.org/package/base-4.18.0.0/docs/src/GHC.Base.html>`_,
+ while ``.hi`` files are required for all Haddock documentation flavors.
+
+The first step is to ensure that your build process is producing ``.hi`` files
+that contain Haddock docstrings. This requires that you somehow provide the
+``-fwrite-interface`` and ``-haddock`` flags to GHC. If you intend to generate
+documentation that includes hyperlinked source files, you should also provide
+the ``-fwrite-ide-info`` flag to GHC. You may specify the directory in which GHC
+should write the ``.hi`` and ``.hie`` files by providing the
+``-hidir=/path/to/hidir`` and ``-hiedir=/path/to/hiedir`` flags to GHC. If you
+are building your application with ``cabal build``, the default location is in
+``dist-newstyle/build/<arch>-<os>/ghc-<ghc-version>/<component>-0.1.0/build``.
+
+The next step is to ensure that the flags which Haddock passes to GHC will not
+trigger recompilation. Unfortunately, this is not very easy to do if you are
+invoking Haddock through ``cabal haddock``. Upon ``cabal haddock``, Cabal passes
+a ``--optghc="-optP-D__HADDOCK_VERSION__=NNNN"`` (where ``NNNN`` is the Haddock
+version number) flag to Haddock, which forwards the ``-optP=...`` flag to GHC
+and triggers a recompilation (unless the existing build results were also
+created by a ``cabal haddock``). Additionally, Cabal passes a
+``--optghc="-stubdir=<temp directory>"`` flag to Haddock, which forwards the
+``-stubdir=<temp directory>`` flag to GHC and triggers a recompilation since
+``-stubdir`` adds a global include directory. Moreover, since the ``stubdir``
+that Cabal passes is a temporary directory, a recompilation is triggered even
+for immediately successive invocations. To avoid recompilations due to these
+flags, one must manually extract the arguments passed to Haddock by Cabal and
+remove the ``--optghc="-optP-D__HADDOCK_VERSION__=NNNN"`` and
+``--optghc="-stubdir=<temp directory>"`` flags. This can be achieved using the
+:option:`--trace-args` flag by invoking ``cabal haddock`` with
+``--haddock-option="--trace-args"`` and copying the traced arguments to a script
+which makes an equivalent call to Haddock without the aformentioned flags.
+
+In addition to the above, Cabal passes a temporary directory as ``-hidir`` to
+Haddock by default. Obviously, this also triggers a recompilation for every
+invocation of ``cabal haddock``, since it will never find the necessary
+interface files in that temporary directory. To remedy this, pass a
+``--optghc="-hidir=/path/to/hidir"`` flag to Haddock, where ``/path/to/hidir``
+is the path to the directory in which your build process is writing ``.hi``
+files.
+
+Following the steps above will allow you to take full advantage of "hi-haddock"
+and generate Haddock documentation from existing build results without requiring
+any further compilation.
diff --git a/doc/markup.rst b/doc/markup.rst
index c584ccf232..a00caba66a 100644
--- a/doc/markup.rst
+++ b/doc/markup.rst
@@ -755,7 +755,7 @@ specified in a comma-separated list in an
``{-# OPTIONS_HADDOCK ... #-}`` pragma at the top of the module, either
before or after the module description. For example: ::
- {-# OPTIONS_HADDOCK hide, prune, ignore-exports #-}
+ {-# OPTIONS_HADDOCK hide, prune #-}
-- |Module description
module A where
@@ -774,11 +774,6 @@ The following attributes are currently understood by Haddock:
Omit definitions that have no documentation annotations from the
generated documentation.
-``ignore-exports``
- Ignore the export list. Generate documentation as if the module had
- no export list - i.e. all the top-level declarations are exported,
- and section headings may be given in the body of the module.
-
``not-home``
Indicates that the current module should not be considered to be the
home module for each entity it exports, unless that entity is not
@@ -793,6 +788,12 @@ The following attributes are currently understood by Haddock:
be rendered, including those implied by their more powerful
versions.
+``print-explicit-runtime-reps``
+ Print type variables that have kind ``RuntimeRep``. By default, these
+ are defaulted to ``LiftedRep`` so that end users don't have to see the
+ underlying levity polymorphism. This flag is analogous to GHC's
+ ``-fprint-explicit-runtime-reps`` flag.
+
.. _markup:
Markup
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 97892103e4..85dc6cca7d 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: haddock-api
-version: 2.27.0
+version: 2.28.0
synopsis: A documentation-generation tool for Haskell libraries
description: Haddock is a documentation-generation tool for Haskell
libraries
@@ -13,7 +13,7 @@ bug-reports: https://github.com/haskell/haddock/issues
copyright: (c) Simon Marlow, David Waern
category: Documentation
build-type: Simple
-tested-with: GHC==9.4.*
+tested-with: GHC==9.6.*
extra-source-files:
CHANGES.md
@@ -45,7 +45,7 @@ library
-- this package typically supports only single major versions
build-depends: base ^>= 4.16.0
, ghc ^>= 9.7
- , ghc-paths ^>= 0.1.0.9
+ , ghc-paths ^>= 0.1.0.12
, haddock-library ^>= 1.11
, xhtml ^>= 3000.2.2
, parsec ^>= 3.1.13.0
@@ -85,12 +85,12 @@ library
Haddock
Haddock.Interface
Haddock.Interface.Rename
+ Haddock.Interface.RenameType
Haddock.Interface.Create
Haddock.Interface.AttachInstances
Haddock.Interface.Json
Haddock.Interface.LexParseRn
Haddock.Interface.ParseModuleHeader
- Haddock.Interface.Specialize
Haddock.Parser
Haddock.Utils
Haddock.Utils.Json
@@ -120,7 +120,6 @@ library
Haddock.InterfaceFile
Haddock.Options
Haddock.GhcUtils
- Haddock.Syb
Haddock.Convert
Paths_haddock_api
@@ -163,12 +162,10 @@ test-suite spec
Haddock.Interface.LexParseRn
Haddock.Interface.ParseModuleHeader
Haddock.Interface.Rename
- Haddock.Interface.Specialize
Haddock.InterfaceFile
Haddock.ModuleTree
Haddock.Options
Haddock.Parser
- Haddock.Syb
Haddock.Types
Haddock.Utils
Haddock.Utils.Json
@@ -180,7 +177,7 @@ test-suite spec
Haddock.Backends.Hyperlinker.Parser
Haddock.Backends.Hyperlinker.Types
- build-depends: ghc ^>= 9.4
+ build-depends: ghc ^>= 9.7
, ghc-paths ^>= 0.1.0.12
, haddock-library ^>= 1.11
, xhtml ^>= 3000.2.2
diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs
index 1aa666cef5..d14cdaa29b 100644
--- a/haddock-api/src/Documentation/Haddock.hs
+++ b/haddock-api/src/Documentation/Haddock.hs
@@ -43,7 +43,6 @@ module Documentation.Haddock (
DocMarkupH(..),
Documentation(..),
ArgMap,
- AliasMap,
WarningMap,
DocMap,
HaddockModInfo(..),
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index ca22d895fc..dd5fddf3db 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -1,10 +1,10 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
@@ -46,6 +46,7 @@ import Haddock.Options
import Haddock.Utils
import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir)
+import Control.DeepSeq (force)
import Control.Monad hiding (forM_)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Bifunctor (second)
@@ -55,9 +56,9 @@ import Data.List (find, isPrefixOf, nub)
import Control.Exception
import Data.Maybe
import Data.IORef
-import Data.Map (Map)
+import Data.Map.Strict (Map)
import Data.Version (makeVersion)
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
import System.IO
import System.Exit
import System.FilePath
@@ -73,9 +74,10 @@ import System.Directory (doesDirectoryExist, getTemporaryDirectory)
import Text.ParserCombinators.ReadP (readP_to_S)
import GHC hiding (verbosity)
import GHC.Settings.Config
-import GHC.Driver.Session hiding (projectVersion, verbosity)
import GHC.Driver.Config.Logger (initLogFlags)
import GHC.Driver.Env
+import GHC.Driver.Session hiding (projectVersion, verbosity)
+import qualified GHC.Driver.Session as DynFlags (DynFlags(..))
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Types.Name.Cache
@@ -156,22 +158,30 @@ haddockWithGhc ghc args = handleTopExceptions $ do
-- or which exits with an error or help message.
(flags, files) <- parseHaddockOpts args
shortcutFlags flags
+
+ -- If argument tracing is enabled, print the arguments we were given
+ when (Flag_TraceArgs `elem` flags) $ do
+ putStrLn $ "haddock received arguments:"
+ mapM_ (putStrLn . (" " ++)) args
+
qual <- rightOrThrowE (qualification flags)
sinceQual <- rightOrThrowE (sinceQualification flags)
- -- inject dynamic-too into flags before we proceed
+ -- Inject dynamic-too into ghc options if the ghc we are using was built with
+ -- dynamic linking
flags'' <- ghc flags $ do
df <- getDynFlags
case lookup "GHC Dynamic" (compilerInfo df) of
Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags
_ -> return flags
+ -- Inject `-j` into ghc options, if given to Haddock
flags' <- pure $ case optParCount flags'' of
Nothing -> flags''
Just Nothing -> Flag_OptGhc "-j" : flags''
Just (Just n) -> Flag_OptGhc ("-j" ++ show n) : flags''
- -- bypass the interface version check
+ -- Whether or not to bypass the interface version check
let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
-- Create a temporary directory and redirect GHC output there (unless user
@@ -183,24 +193,26 @@ haddockWithGhc ghc args = handleTopExceptions $ do
let withDir | Flag_NoTmpCompDir `elem` flags = id
| otherwise = withTempOutputDir
+ -- Output warnings about potential misuse of some flags
unless (Flag_NoWarnings `elem` flags) $ do
hypSrcWarnings flags
- forM_ (warnings args) $ \warning -> do
- hPutStrLn stderr warning
+ mapM_ (hPutStrLn stderr) (optGhcWarnings args)
when noChecks $
hPutStrLn stderr noCheckWarning
ghc flags' $ withDir $ do
dflags <- getDynFlags
logger <- getLogger
- unit_state <- hsc_units <$> getSession
+ !unit_state <- hsc_units <$> getSession
+ -- If any --show-interface was used, show the given interfaces
forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
name_cache <- freshNameCache
mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), Visible, path)] noChecks
forM_ mIfaceFile $ \(_,_,_, ifaceFile) -> do
putMsg logger $ renderJson (jsonInterfaceFile ifaceFile)
+ -- If we were given source files to generate documentation from, do it
if not (null files) then do
(packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
let packageInfo = PackageInfo { piPackageName =
@@ -220,6 +232,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do
-- Render the interfaces.
liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages ifaces
+ -- If we were not given any input files, error if documentation was
+ -- requested
else do
when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
throwE "No input file(s)."
@@ -241,8 +255,8 @@ withTempOutputDir action = do
withTempDir dir action
-- | Create warnings about potential misuse of -optghc
-warnings :: [String] -> [String]
-warnings = map format . filter (isPrefixOf "-optghc")
+optGhcWarnings :: [String] -> [String]
+optGhcWarnings = map format . filter (isPrefixOf "-optghc")
where
format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"]
@@ -267,12 +281,14 @@ withGhc flags action = do
readPackagesAndProcessModules :: [Flag] -> [String]
-> Ghc ([(DocPaths, Visibility, FilePath, InterfaceFile)], [Interface], LinkEnv)
readPackagesAndProcessModules flags files = do
- -- Get packages supplied with --read-interface.
+ -- Whether or not we bypass the interface file version check
let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
+
+ -- Read package dependency interface files supplied with --read-interface
name_cache <- hsc_NC <$> getSession
packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
- -- Create the interfaces -- this is the core part of Haddock.
+ -- Create the interfaces for the given modules -- this is the core part of Haddock
let ifaceFiles = map (\(_, _, _, ifaceFile) -> ifaceFile) packages
(ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles
@@ -414,17 +430,17 @@ render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = d
unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) }
reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do
- let warn = hPutStrLn stderr . ("Warning: " ++)
+ let warn' = hPutStrLn stderr . ("Warning: " ++)
case readP_to_S parseHoleyModule mod_str of
[(m, "")]
| Just iface <- Map.lookup m installedMap
-> return [iface]
| otherwise
- -> warn ("Cannot find reexported module '" ++ mod_str ++ "'") >> return []
- _ -> warn ("Cannot parse reexported module flag '" ++ mod_str ++ "'") >> return [])
+ -> warn' ("Cannot find reexported module '" ++ mod_str ++ "'") >> return []
+ _ -> warn' ("Cannot parse reexported module flag '" ++ mod_str ++ "'") >> return [])
libDir <- getHaddockLibDir flags
- prologue <- getPrologue dflags' flags
+ !prologue <- force <$> getPrologue dflags' flags
themes <- getThemes libDir flags >>= either bye return
let withQuickjump = Flag_QuickJumpIndex `elem` flags
@@ -550,20 +566,25 @@ 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
- logger <- getLogger
- dynflags' <- parseGhcFlags logger =<< getSessionDynFlags
-
- -- We disable pattern match warnings because than can be very
- -- expensive to check
- let dynflags'' = unsetPatternMatchWarnings $
- updOptLevel 0 dynflags'
- -- ignore the following return-value, which is a list of packages
- -- that may need to be re-linked: Haddock doesn't do any
- -- dynamic or static linking at all!
- _ <- setSessionDynFlags dynflags''
- ghcActs dynflags''
- where
+ logger <- getLogger
+
+ -- Set default GHC verbosity to 1. This is better for hi-haddock since -v0
+ -- creates an awkward silence during the load operation
+ default_dflags <- getSessionDynFlags >>= \dflags ->
+ pure dflags { DynFlags.verbosity = 1 }
+
+ dynflags' <- parseGhcFlags logger default_dflags
+
+ -- Disable pattern match warnings because they can be very expensive to
+ -- check, set optimization level to 0 for fastest compilation.
+ let dynflags'' = unsetPatternMatchWarnings $ updOptLevel 0 dynflags'
+ -- ignore the following return-value, which is a list of packages
+ -- that may need to be re-linked: Haddock doesn't do any
+ -- dynamic or static linking at all!
+ _ <- setSessionDynFlags dynflags''
+ ghcActs dynflags''
+ where
-- ignore sublists of flags that start with "+RTS" and end in "-RTS"
--
-- See https://github.com/haskell/haddock/issues/666
@@ -574,13 +595,21 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
go _ func False = func False
go arg func True = arg : func True
-
parseGhcFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
parseGhcFlags logger dynflags = do
-- TODO: handle warnings?
- let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock]
- | otherwise = [Opt_Haddock]
+ let extra_opts =
+ [ -- Include docstrings in .hi files.
+ Opt_Haddock
+
+ -- Do not recompile because of changes to optimization flags
+ , Opt_IgnoreOptimChanges
+ ]
+ -- Write .hie files if we need them for hyperlinked src
+ ++ if needHieFiles
+ then [Opt_WriteHie] -- Generate .hie-files
+ else []
dynflags' = (foldl' gopt_set dynflags extra_opts)
{ backend = noBackend
, ghcMode = CompManager
@@ -733,36 +762,40 @@ shortcutFlags flags = do
-- | Generate some warnings about potential misuse of @--hyperlinked-source@.
hypSrcWarnings :: [Flag] -> IO ()
hypSrcWarnings flags = do
-
when (hypSrc && any isSourceUrlFlag flags) $
hPutStrLn stderr $ concat
[ "Warning: "
, "--source-* options are ignored when "
, "--hyperlinked-source is enabled."
]
-
when (not hypSrc && any isSourceCssFlag flags) $
hPutStrLn stderr $ concat
[ "Warning: "
, "source CSS file is specified but "
, "--hyperlinked-source is disabled."
]
-
where
+ hypSrc :: Bool
hypSrc = Flag_HyperlinkedSource `elem` flags
+
+ isSourceUrlFlag :: Flag -> Bool
isSourceUrlFlag (Flag_SourceBaseURL _) = True
isSourceUrlFlag (Flag_SourceModuleURL _) = True
isSourceUrlFlag (Flag_SourceEntityURL _) = True
isSourceUrlFlag (Flag_SourceLEntityURL _) = True
isSourceUrlFlag _ = False
+
+ isSourceCssFlag :: Flag -> Bool
isSourceCssFlag (Flag_SourceCss _) = True
isSourceCssFlag _ = False
updateHTMLXRefs :: [(FilePath, InterfaceFile)] -> IO ()
updateHTMLXRefs packages = do
- writeIORef html_xrefs_ref (Map.fromList mapping)
- writeIORef html_xrefs_ref' (Map.fromList mapping')
+ let !modMap = force $ Map.fromList mapping
+ !modNameMap = force $ Map.fromList mapping'
+ writeIORef html_xrefs_ref modMap
+ writeIORef html_xrefs_ref' modNameMap
where
mapping = [ (instMod iface, html) | (html, ifaces) <- packages
, iface <- ifInstalledIfaces ifaces ]
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 7f00efc758..44bdb214e0 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.Hoogle
@@ -15,32 +15,36 @@
-- http://www.haskell.org/hoogle/
-----------------------------------------------------------------------------
module Haddock.Backends.Hoogle (
+ -- * Main entry point to Hoogle output generation
ppHoogle
+
+ -- * Utilities for generating Hoogle output during interface creation
+ , ppExportD
) where
-import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), TopLevelFlag(..) )
-import GHC.Types.SourceText
-import GHC.Core.InstEnv (ClsInst(..))
import Documentation.Haddock.Markup
import Haddock.GhcUtils
import Haddock.Types hiding (Version)
import Haddock.Utils hiding (out)
import GHC
+import GHC.Core.InstEnv
import GHC.Driver.Ppr
+import GHC.Plugins (TopLevelFlag(..))
+import GHC.Types.SourceText
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Unit.State
-import GHC.Hs.Decls (ppDataDefnHeader, pp_vanilla_decl_head)
import Data.Char
import Data.Foldable (toList)
-import Data.List (dropWhileEnd, intercalate, isPrefixOf)
+import Data.List (intercalate, isPrefixOf)
import Data.Maybe
import Data.Version
import System.Directory
import System.FilePath
+
prefix :: [String]
prefix = ["-- Hoogle documentation, generated by Haddock"
,"-- See Hoogle, http://www.haskell.org/hoogle/"
@@ -56,7 +60,8 @@ ppHoogle dflags unit_state package version synopsis prologue ifaces odir = do
docWith dflags' (drop 2 $ dropWhile (/= ':') synopsis) prologue ++
["@package " ++ package] ++
["@version " ++ showVersion version
- | not (null (versionBranch version)) ] ++
+ | not (null (versionBranch version))
+ ] ++
concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i]
createDirectoryIfMissing True odir
writeUtf8File (odir </> filename) (unlines contents)
@@ -65,9 +70,14 @@ ppModule :: DynFlags -> UnitState -> Interface -> [String]
ppModule dflags unit_state iface =
"" : ppDocumentation dflags (ifaceDoc iface) ++
["module " ++ moduleString (ifaceMod iface)] ++
- concatMap (ppExport dflags) (ifaceExportItems iface) ++
+ concatMap ppExportItem (ifaceRnExportItems $ iface) ++
concatMap (ppInstance dflags unit_state) (ifaceInstances iface)
+-- | If the export item is an 'ExportDecl', get the attached Hoogle textual
+-- database entries for that export declaration.
+ppExportItem :: ExportItem DocNameI -> [String]
+ppExportItem (ExportDecl RnExportD { rnExpDHoogle = o }) = o
+ppExportItem _ = []
---------------------------------------------------------------------
-- Utility functions
@@ -97,19 +107,23 @@ dropHsDocTy = drop_sig_ty
outHsSigType :: DynFlags -> HsSigType GhcRn -> String
outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy
-
dropComment :: String -> String
dropComment (' ':'-':'-':' ':_) = []
dropComment (x:xs) = x : dropComment xs
dropComment [] = []
-
outWith :: Outputable a => (SDoc -> String) -> a -> [Char]
-outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr
- where
- f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs
- f (x:xs) = x : f xs
- f [] = []
+outWith p =
+ f
+ . unwords
+ . map (dropWhile isSpace)
+ . lines
+ . p
+ . ppr
+ where
+ f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs
+ f (x:xs) = x : f xs
+ f [] = []
out :: Outputable a => DynFlags -> a -> String
out dflags = outWith $ showSDoc dflags
@@ -124,28 +138,37 @@ commaSeparate dflags = showSDoc dflags . interpp'SP
---------------------------------------------------------------------
-- How to print each export
-ppExport :: DynFlags -> ExportItem GhcRn -> [String]
-ppExport dflags ExportDecl { expItemDecl = L _ decl
- , expItemPats = bundledPats
- , expItemMbDoc = mbDoc
- , expItemSubDocs = subdocs
- , expItemFixities = fixities
- } = concat [ ppDocumentation dflags dc ++ f d
- | (d, (dc, _)) <- (decl, mbDoc) : bundledPats
- ] ++
- ppFixities
- where
- f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs
- f (TyClD _ d@SynDecl{}) = ppSynonym dflags d
- f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs
- f (TyClD _ (FamDecl _ d)) = ppFam dflags d
- f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ]
- f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ]
- f (SigD _ sig) = ppSig dflags sig
- f _ = []
-
- ppFixities = concatMap (ppFixity dflags) fixities
-ppExport _ _ = []
+ppExportD :: DynFlags -> ExportD GhcRn -> [String]
+ppExportD dflags
+ ExportD
+ { expDDecl = L _ decl
+ , expDPats = bundledPats
+ , expDMbDoc = mbDoc
+ , expDSubDocs = subdocs
+ , expDFixities = fixities
+ }
+ = concat
+ [ ppDocumentation dflags' dc ++ f d
+ | (d, (dc, _)) <- (decl, mbDoc) : bundledPats
+ ] ++ ppFixities
+ where
+ -- Since Hoogle is line based, we want to avoid breaking long lines.
+ dflags' :: DynFlags
+ dflags' = dflags{ pprCols = maxBound }
+
+ f :: HsDecl GhcRn -> [String]
+ f (TyClD _ d@DataDecl{}) = ppData dflags' d subdocs
+ f (TyClD _ d@SynDecl{}) = ppSynonym dflags' d
+ f (TyClD _ d@ClassDecl{}) = ppClass dflags' d subdocs
+ f (TyClD _ (FamDecl _ d)) = ppFam dflags' d
+ f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags' [name] typ]
+ f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags' [name] typ]
+ f (SigD _ sig) = ppSig dflags' sig
+ f _ = []
+
+ ppFixities :: [String]
+ ppFixities = concatMap (ppFixity dflags') fixities
+
ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppSigWithDoc dflags sig subdocs = case sig of
@@ -165,34 +188,53 @@ pp_sig dflags names (L _ typ) =
where
prettyNames = intercalate ", " $ map (out dflags) names
+
+
-- note: does not yet output documentation for class methods
ppClass :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppClass dflags decl subdocs =
- (out dflags decl{tcdSigs=[], tcdATs=[], tcdATDefs=[], tcdMeths=emptyLHsBinds}
- ++ ppTyFams) : ppMethods
- where
-
- ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl
- ppSig' = flip (ppSigWithDoc dflags) subdocs
+ (ppDecl ++ ppTyFams) : ppMethods
+ where
+ ppDecl :: String
+ ppDecl =
+ out dflags
+ decl
+ { tcdSigs = []
+ , tcdATs = []
+ , tcdATDefs = []
+ , tcdMeths = emptyLHsBinds
+ }
+
+ ppMethods :: [String]
+ ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl
+
+ ppSig' = flip (ppSigWithDoc dflags) subdocs
+
+ add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVars decl)
+
+ ppTyFams :: String
+ ppTyFams
+ | null $ tcdATs decl = ""
+ | otherwise = (" " ++) . showSDoc dflags . whereWrapper $ concat
+ [ map pprTyFam (tcdATs decl)
+ , map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl)
+ ]
- add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVars decl)
+ pprTyFam :: LFamilyDecl GhcRn -> SDoc
+ pprTyFam (L _ at) = vcat' $ map text $
+ mkSubdocN dflags
+ (fdLName at)
+ subdocs
+ -- Associated type families should not be printed as top-level
+ -- (avoid printing the `family` keyword)
+ (ppFam dflags at{fdTopLevel = NotTopLevel})
- ppTyFams
- | null $ tcdATs decl = ""
- | otherwise = (" " ++) . showSDoc dflags . whereWrapper $ concat
- [ map pprTyFam (tcdATs decl)
- , map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl)
- ]
+ whereWrapper elems = vcat'
+ [ text "where" <+> lbrace
+ , nest 4 . vcat . map (Outputable.<> semi) $ elems
+ , rbrace
+ ]
- pprTyFam :: LFamilyDecl GhcRn -> SDoc
- pprTyFam (L _ at) = vcat' $ map text $
- mkSubdocN dflags (fdLName at) subdocs (ppFam dflags at)
-
- whereWrapper elems = vcat'
- [ text "where" <+> lbrace
- , nest 4 . vcat . map (Outputable.<> semi) $ elems
- , rbrace
- ]
ppFam :: DynFlags -> FamilyDecl GhcRn -> [String]
ppFam dflags decl@(FamilyDecl { fdInfo = info })
@@ -223,7 +265,6 @@ ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]
ppData dflags decl@DataDecl { tcdLName = name, tcdTyVars = tvs, tcdFixity = fixity, tcdDataDefn = defn } subdocs
= out dflags (ppDataDefnHeader (pp_vanilla_decl_head name tvs fixity) defn) :
concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn)
- where
ppData _ _ _ = panic "ppData"
-- | for constructors, and named-fields...
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 9316da6dc3..84ccaf60e2 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module Haddock.Backends.Hyperlinker
@@ -54,8 +55,7 @@ ppHyperlinkedSource verbosity outdir libdir mstyle pretty srcs' ifaces = do
-- | Generate hyperlinked source for particular interface.
ppHyperlinkedModuleSource :: Verbosity -> FilePath -> Bool -> SrcMaps -> Interface -> IO ()
-ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile iface of
- Just hfp -> do
+ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
-- Parse the GHC-produced HIE file
nc <- freshNameCache
HieFile { hie_hs_file = file
@@ -63,7 +63,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile
, hie_types = types
, hie_hs_src = rawSrc
} <- hie_file_result
- <$> (readHieFile nc hfp)
+ <$> (readHieFile nc iface.ifaceHieFile )
-- Get the AST and tokens corresponding to the source file we want
let fileFs = mkFastString file
@@ -89,7 +89,6 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile
-- Produce and write out the hyperlinked sources
writeUtf8File path . renderToString pretty . render' fullAst $ tokens
- Nothing -> return ()
where
df = ifaceDynFlags iface
render' = render (Just srcCssFile) (Just highlightScript) srcs
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 7fa5a443a2..fa162b23dc 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -262,7 +262,7 @@ hyperlink (srcs, srcs') ident = case ident of
Just (SrcExternal path) ->
let hyperlinkUrl = makeHyperlinkUrl path </> hypSrcModuleNameUrl mdl name
in Html.anchor content !
- [ Html.href $ spliceURL Nothing (Just mdl) (Just name) Nothing hyperlinkUrl ]
+ [ Html.href $ spliceURL (Just mdl) (Just name) Nothing hyperlinkUrl ]
Nothing -> content
where
mdl = nameModule name
@@ -274,7 +274,7 @@ hyperlink (srcs, srcs') ident = case ident of
Just (SrcExternal path) ->
let hyperlinkUrl = makeHyperlinkUrl path </> hypSrcModuleUrl' moduleName
in Html.anchor content !
- [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing hyperlinkUrl ]
+ [ Html.href $ spliceURL' (Just moduleName) Nothing Nothing hyperlinkUrl ]
Nothing -> content
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index 5311787324..35650feb3f 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -39,7 +39,7 @@ hypSrcModuleFile m = moduleNameString (moduleName m) <.> "html"
hypSrcModuleFile' :: ModuleName -> FilePath
hypSrcModuleFile' mdl = spliceURL'
- Nothing (Just mdl) Nothing Nothing moduleFormat
+ (Just mdl) Nothing Nothing moduleFormat
hypSrcModuleUrl :: Module -> String
hypSrcModuleUrl = hypSrcModuleFile
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 4e2a41c4b8..42bcab4e32 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -18,6 +18,7 @@ module Haddock.Backends.LaTeX (
) where
import Documentation.Haddock.Markup
+import Haddock.Doc (combineDocumentation)
import Haddock.Types
import Haddock.Utils
import Haddock.GhcUtils
@@ -26,7 +27,7 @@ import qualified GHC.Utils.Ppr as Pretty
import GHC hiding (fromMaybeContext )
import GHC.Types.Name.Occurrence
-import GHC.Types.Name ( nameOccName )
+import GHC.Types.Name ( nameOccName, getOccString, tidyNameOcc )
import GHC.Types.Name.Reader ( rdrNameOcc )
import GHC.Core.Type ( Specificity(..) )
import GHC.Data.FastString ( unpackFS )
@@ -42,10 +43,6 @@ import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Foldable ( toList )
import Prelude hiding ((<>))
-import Haddock.Doc (combineDocumentation)
-
--- import Debug.Trace
-
{- SAMPLE OUTPUT
\haddockmoduleheading{\texttt{Data.List}}
@@ -180,12 +177,28 @@ ppLaTeXModule _title odir iface = do
-- | Prints out an entry in a module export list.
exportListItem :: ExportItem DocNameI -> LaTeX
-exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }
+exportListItem
+ ( ExportDecl
+ ( RnExportD
+ { rnExpDExpD =
+ ( ExportD
+ { expDDecl = decl
+ , expDSubDocs = subdocs
+ }
+ )
+ }
+ )
+ )
= let (leader, names) = declNames decl
+ go (n,_)
+ | isDefaultMethodOcc (occName n) = Nothing
+ | otherwise = Just $ ppDocBinder n
+
in sep (punctuate comma [ leader <+> ppDocBinder name | name <- names ]) <>
case subdocs of
[] -> empty
- _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs)))
+ _ -> parens (sep (punctuate comma (mapMaybe go subdocs)))
+
exportListItem (ExportNoDecl y [])
= ppDocBinder y
exportListItem (ExportNoDecl y subs)
@@ -215,9 +228,18 @@ processExports (e : es) =
isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI)
-isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t))
- , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
- | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t))
+isSimpleSig
+ ( ExportDecl
+ ( RnExportD
+ { rnExpDExpD =
+ ExportD
+ { expDDecl = L _ (SigD _ (TypeSig _ lnames t))
+ , expDMbDoc = (Documentation Nothing Nothing, argDocs)
+ }
+ }
+ )
+ )
+ | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t))
isSimpleSig _ = Nothing
@@ -229,7 +251,7 @@ isExportModule _ = Nothing
processExport :: ExportItem DocNameI -> LaTeX
processExport (ExportGroup lev _id0 doc)
= ppDocGroup lev (docToLaTeX doc)
-processExport (ExportDecl decl pats doc subdocs insts fixities _splice)
+processExport (ExportDecl (RnExportD (ExportD decl pats doc subdocs insts fixities _splice) _))
= ppDecl decl pats doc insts subdocs fixities
processExport (ExportNoDecl y [])
= ppDocName y
@@ -292,13 +314,9 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print
-> LaTeX
ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
- TyClD _ d@FamDecl {} -> ppFamDecl False doc instances d unicode
- TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode
- TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode
--- Family instances happen via FamInst now
--- TyClD _ d@TySynonym{}
--- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
--- Family instances happen via FamInst now
+ TyClD _ d@FamDecl {} -> ppFamDecl False doc instances d unicode
+ TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode
+ TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode
TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode
SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode
SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
@@ -656,11 +674,18 @@ ppClassDecl instances doc subdocs
| L _ (ClassOpSig _ is_def lnames typ) <- lsigs
, let doc | is_def = noDocForDecl
| otherwise = lookupAnySubdoc (head names) subdocs
- names = map unLoc lnames
+ names = map (cleanName . unLoc) lnames
leader = if is_def then Just (keyword "default") else Nothing
]
-- N.B. taking just the first name is ok. Signatures with multiple
-- names are expanded so that each name gets its own signature.
+ -- Get rid of the ugly '$dm' prefix on default method names
+ cleanName n
+ | isDefaultMethodOcc (occName n)
+ , '$':'d':'m':occStr <- getOccString n
+ = setName (tidyNameOcc (getName n) (mkOccName varName occStr)) n
+ | otherwise = n
+
instancesBit = ppDocInstances unicode instances
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 06e3f3d8f0..597f0e88be 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -11,7 +11,12 @@
-- Stability : experimental
-- Portability : portable
-----------------------------------------------------------------------------
-{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, TypeApplications #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE BangPatterns #-}
+
module Haddock.Backends.Xhtml (
ppHtml, copyHtmlBits,
ppHtmlIndex, ppHtmlContents,
@@ -41,18 +46,19 @@ import Haddock.GhcUtils
import Control.Monad ( when, unless )
import qualified Data.ByteString.Builder as Builder
+import Control.DeepSeq (force)
import Data.Bifunctor ( bimap )
import Data.Char ( toUpper, isSpace )
import Data.Either ( partitionEithers )
-import Data.Foldable ( traverse_)
+import Data.Foldable ( traverse_, foldl')
import Data.List ( sortBy, isPrefixOf, intersperse )
import Data.Maybe
import System.Directory
import System.FilePath hiding ( (</>) )
import qualified System.IO as IO
import qualified System.FilePath as FilePath
-import Data.Map ( Map )
-import qualified Data.Map as Map hiding ( Map )
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
import qualified Data.Set as Set hiding ( Set )
import Data.Ord ( comparing )
@@ -179,8 +185,7 @@ srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
srcButton (Just src_base_url, _, _, _) Nothing =
Just (anchor ! [href src_base_url] << "Source")
srcButton (_, Just src_module_url, _, _) (Just iface) =
- let url = spliceURL (Just $ ifaceOrigFilename iface)
- (Just $ ifaceMod iface) Nothing Nothing src_module_url
+ let url = spliceURL (Just $ ifaceMod iface) Nothing Nothing src_module_url
in Just (anchor ! [href url] << "Source")
srcButton _ _ =
Nothing
@@ -191,7 +196,7 @@ wikiButton (Just wiki_base_url, _, _) Nothing =
Just (anchor ! [href wiki_base_url] << "User Comments")
wikiButton (_, Just wiki_module_url, _) (Just mdl) =
- let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url
+ let url = spliceURL (Just mdl) Nothing Nothing wiki_module_url
in Just (anchor ! [href url] << "User Comments")
wikiButton _ _ =
@@ -356,7 +361,7 @@ ppPrologue pkg qual title (Just doc) =
ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html
ppSignatureTrees _ _ tss | all (null . snd) tss = mempty
-ppSignatureTrees pkg qual [(info, ts)] =
+ppSignatureTrees pkg qual [(info, ts)] =
divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts)
ppSignatureTrees pkg qual tss =
divModuleList <<
@@ -427,8 +432,6 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) =
mkNodeList pkg qual (s:ss) p ts
)
-
-
--------------------------------------------------------------------------------
-- * Generate the index
--------------------------------------------------------------------------------
@@ -504,8 +507,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins
fromInterface iface =
mkIndex mdl qual `mapMaybe` ifaceRnExportItems iface
where
- aliases = ifaceModuleAliases iface
- qual = makeModuleQual qual_opt aliases mdl
+ qual = makeModuleQual qual_opt mdl
mdl = ifaceMod iface
mkIndex :: Module -> Qualification -> ExportItem DocNameI -> Maybe JsonIndexEntry
@@ -522,11 +524,11 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins
names = exportName item ++ exportSubs item
exportSubs :: ExportItem DocNameI -> [IdP DocNameI]
- exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs
+ exportSubs (ExportDecl (RnExportD { rnExpDExpD = ExportD { expDSubDocs } })) = map fst expDSubDocs
exportSubs _ = []
exportName :: ExportItem DocNameI -> [IdP DocNameI]
- exportName ExportDecl { expItemDecl } = getMainDeclBinderI (unLoc expItemDecl)
+ exportName (ExportDecl (RnExportD { rnExpDExpD = ExportD { expDDecl } })) = getMainDeclBinderI (unLoc expDDecl)
exportName ExportNoDecl { expItemName } = [expItemName]
exportName _ = []
@@ -538,7 +540,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces ins
-- update link using relative path to output directory
fixLink :: FilePath
-> JsonIndexEntry -> JsonIndexEntry
- fixLink ifaceFile jie =
+ fixLink ifaceFile jie =
jie { jieLink = makeRelative odir (takeDirectory ifaceFile)
FilePath.</> jieLink jie }
@@ -623,14 +625,34 @@ ppHtmlIndex odir doctitle _maybe_package themes
-- that export that entity. Each of the modules exports the entity
-- in a visible or invisible way (hence the Bool).
full_index :: Map String (Map GHC.Name [(Module,Bool)])
- full_index = Map.fromListWith (flip (Map.unionWith (++)))
- (concatMap getIfaceIndex ifaces)
+ full_index = foldl' f Map.empty ifaces
+ where
+ f :: Map String (Map Name [(Module, Bool)])
+ -> InstalledInterface
+ -> Map String (Map Name [(Module, Bool)])
+ f !idx iface =
+ Map.unionWith
+ (Map.unionWith (\a b -> let !x = force $ a ++ b in x))
+ idx
+ (getIfaceIndex iface)
+
+ getIfaceIndex :: InstalledInterface -> Map String (Map Name [(Module, Bool)])
getIfaceIndex iface =
- [ (getOccString name
- , Map.fromList [(name, [(mdl, name `Set.member` visible)])])
- | name <- instExports iface ]
+ foldl' f Map.empty (instExports iface)
where
+ f :: Map String (Map Name [(Module, Bool)])
+ -> Name
+ -> Map String (Map Name [(Module, Bool)])
+ f !idx name =
+ let !vis = name `Set.member` visible
+ in
+ Map.insertWith
+ (Map.unionWith (++))
+ (getOccString name)
+ (Map.singleton name [(mdl, vis)])
+ idx
+
mdl = instMod iface
visible = Set.fromList (instVisibleExports iface)
@@ -682,7 +704,6 @@ ppHtmlModule odir doctitle themes
unicode pkg qual debug iface = do
let
mdl = ifaceMod iface
- aliases = ifaceModuleAliases iface
mdl_str = moduleString mdl
mdl_str_annot = mdl_str ++ if ifaceIsSig iface
then " (signature)"
@@ -694,7 +715,7 @@ ppHtmlModule odir doctitle themes
")"
| otherwise
= toHtml mdl_str
- real_qual = makeModuleQual qual aliases mdl
+ real_qual = makeModuleQual qual mdl
html =
headHtml mdl_str_annot themes maybe_mathjax_url maybe_base_url +++
bodyHtml doctitle (Just iface)
@@ -722,7 +743,17 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual
-- todo: if something has only sub-docs, or fn-args-docs, should
-- it be measured here and thus prevent omitting the synopsis?
- has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning
+ has_doc
+ ( ExportDecl
+ ( RnExportD
+ { rnExpDExpD =
+ ExportD
+ { expDMbDoc =
+ ( Documentation mDoc mWarn, _ )
+ }
+ }
+ )
+ ) = isJust mDoc || isJust mWarn
has_doc (ExportNoDecl _ _) = False
has_doc (ExportModule _) = False
has_doc _ = True
@@ -816,11 +847,28 @@ numberSectionHeadings = go 1
processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification
-> ExportItem DocNameI -> Maybe Html
-processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances
+processExport _ _ _ _ _
+ ( ExportDecl
+ ( RnExportD
+ { rnExpDExpD =
+ ExportD
+ { expDDecl = L _ (InstD {})
+ }
+ }
+ )
+ )
+ = Nothing -- Hide empty instances
+processExport summary links unicode pkg qual
+ ( ExportDecl
+ ( RnExportD
+ { rnExpDExpD =
+ ExportD decl pats doc subdocs insts fixities splice
+ }
+ )
+ )
+ = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual
processExport summary _ _ pkg qual (ExportGroup lev id0 doc)
= nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc)
-processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice)
- = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual
processExport summary _ _ _ qual (ExportNoDecl y [])
= processDeclOneLiner summary $ ppDocName qual Prefix True y
processExport summary _ _ _ qual (ExportNoDecl y subs)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index d6e5a6c825..7346520794 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -320,24 +320,6 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod
, []
)
-
--- | Print a pseudo family declaration
-ppPseudoFamDecl :: LinksInfo -> Splice
- -> PseudoFamilyDecl DocNameI -- ^ this decl
- -> Unicode -> Qualification -> Html
-ppPseudoFamDecl links splice
- (PseudoFamilyDecl { pfdInfo = info
- , pfdKindSig = L _ kindSig
- , pfdTyVars = tvs
- , pfdLName = L loc name })
- unicode qual =
- topDeclElem links (locA loc) splice [name] leader
- where
- leader = hsep [ ppFamilyLeader True info
- , ppAppNameTypes name (map unLoc tvs) unicode qual
- , ppResultSig kindSig unicode qual
- ]
-
-- | Print the LHS of a type\/data family declaration
ppFamHeader :: Bool -- ^ is a summary
-> Bool -- ^ is an associated type
@@ -601,12 +583,12 @@ ppClassDecl summary links instances fixities loc d subdocs
ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default")
d' [n] t [] splice unicode pkg qual
- lookupDM name = Map.lookup (getOccString name) defaultMethods
+ lookupDM name = Map.lookup (occNameString $ mkDefaultMethodOcc $ getOccName name) defaultMethods
defaultMethods = Map.fromList
[ (nameStr, (typ, doc))
| ClassOpSig _ True lnames typ <- sigs
, name <- map unLoc lnames
- , let doc = noDocForDecl -- TODO: get docs for method defaults
+ , let doc = lookupAnySubdoc name subdocs
nameStr = getOccString name
]
@@ -619,7 +601,8 @@ ppClassDecl summary links instances fixities loc d subdocs
-- Minimal complete definition = the only shown method
Var (L _ n) : _ | [getName n] ==
- [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns]
+ [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns]
+
-> noHtml
-- Minimal complete definition = nothing
@@ -687,7 +670,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) m
)
where
sigs = ppInstanceSigs links splice unicode qual clsiSigs
- ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys
+ ats = ppInstanceAssocTys links splice unicode qual orphan clsiAssocTys
TypeInst rhs ->
( subInstHead iid ptype
, mdoc
@@ -712,11 +695,20 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) m
typ = ppAppNameTypes ihdClsName ihdTypes unicode qual
-ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification
- -> [PseudoFamilyDecl DocNameI]
+ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification -> Bool
+ -> [DocInstance DocNameI]
-> [Html]
-ppInstanceAssocTys links splice unicode qual =
- map (\pseudo -> ppPseudoFamDecl links splice pseudo unicode qual)
+ppInstanceAssocTys links splice unicode qual orphan insts =
+ maybeToList $
+ subTableSrc Nothing qual links True $
+ zipWith mkInstHead
+ insts
+ [1..]
+ where
+ mkInstHead (inst, doc, name, mdl) no =
+ (ppInstHead links splice unicode qual doc (OriginFamily (unLoc name)) orphan no inst mdl
+ , mdl
+ , name)
ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 575249adf9..41afe5a0d4 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -37,6 +37,7 @@ module Haddock.Backends.Xhtml.Layout (
subMethods,
subDefaults,
subMinimal,
+ subTableSrc,
topDeclElem, declElem,
) where
@@ -50,7 +51,6 @@ import qualified Data.Map as Map
import Text.XHtml hiding ( name, title, quote )
import Data.Maybe (fromMaybe)
-import GHC.Data.FastString ( unpackFS )
import GHC hiding (anchor)
import GHC.Types.Name (nameOccName)
@@ -294,15 +294,13 @@ links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice mdl' docName@(D
| otherwise = maybe lineUrl Just nameUrl in
case mUrl of
Nothing -> noHtml
- Just url -> let url' = spliceURL (Just fname) (Just origMod)
- (Just n) (Just loc) url
+ Just url -> let url' = spliceURL (Just origMod) (Just n) (Just loc) url
in anchor ! [href url', theclass "link"] << "Source"
wikiLink =
case maybe_wiki_url of
Nothing -> noHtml
- Just url -> let url' = spliceURL (Just fname) (Just mdl)
- (Just n) (Just loc) url
+ Just url -> let url' = spliceURL (Just mdl) (Just n) (Just loc) url
in anchor ! [href url', theclass "link"] << "Comments"
-- For source links, we want to point to the original module,
@@ -313,7 +311,4 @@ links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice mdl' docName@(D
origMod = fromMaybe (nameModule n) mdl'
origPkg = moduleUnit origMod
- fname = case loc of
- RealSrcSpan l _ -> unpackFS (srcSpanFile l)
- UnhelpfulSpan _ -> error "links: UnhelpfulSpan"
links _ _ _ _ _ = noHtml
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index 6dfc60fae6..09b5b603e0 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -24,7 +24,6 @@ import Haddock.Types
import Haddock.Utils
import Text.XHtml hiding ( name, p, quote )
-import qualified Data.Map as M
import Data.List ( stripPrefix )
import GHC hiding (LexicalFixity(..), anchor)
@@ -105,11 +104,6 @@ ppQualifyName qual notation name mdl =
Just _ -> ppFullQualName notation mdl name
-- some other module, D.x -> D.x
Nothing -> ppFullQualName notation mdl name
- AliasedQual aliases localmdl ->
- case (moduleString mdl == moduleString localmdl,
- M.lookup mdl aliases) of
- (False, Just alias) -> ppQualName notation alias name
- _ -> ppName notation name
ppFullQualName :: Notation -> Module -> Name -> Html
@@ -117,11 +111,6 @@ ppFullQualName notation mdl name = wrapInfix notation (getOccName name) qname
where
qname = toHtml $ moduleString mdl ++ '.' : getOccString name
-ppQualName :: Notation -> ModuleName -> Name -> Html
-ppQualName notation mdlName name = wrapInfix notation (getOccName name) qname
- where
- qname = toHtml $ moduleNameString mdlName ++ '.' : getOccString name
-
ppName :: Notation -> Name -> Html
ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccString name)
@@ -148,14 +137,11 @@ ppBinder' notation n = wrapInfix notation n $ ppOccName n
wrapInfix :: Notation -> OccName -> Html -> Html
wrapInfix notation n = case notation of
- Infix | is_star_kind -> id
- | not is_sym -> quote
- Prefix | is_star_kind -> id
- | is_sym -> parens
+ Infix | not is_sym -> quote
+ Prefix | is_sym -> parens
_ -> id
where
is_sym = isSymOcc n
- is_star_kind = isTcOcc n && occNameString n == "*"
linkId :: Module -> Maybe Name -> Html -> Html
linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) True
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index c50a73bf39..7f8be25a6a 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -34,8 +34,6 @@ module Haddock.Backends.Xhtml.Utils (
import Haddock.Utils
-import Data.Maybe
-
import Text.XHtml hiding ( name, title, p, quote )
import qualified Text.XHtml as XHtml
@@ -49,19 +47,18 @@ import GHC.Types.Name ( getOccString, nameOccName, isValOcc )
-- Used to generate URL for customized external paths, usually provided with
-- @--source-module@, @--source-entity@ and related command-line arguments.
--
--- >>> spliceURL Nothing mmod mname Nothing "output/%{MODULE}.hs#%{NAME}"
+-- >>> spliceURL mmod mname Nothing "output/%{MODULE}.hs#%{NAME}"
-- "output/Foo.hs#foo"
-spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->
+spliceURL :: Maybe Module -> Maybe GHC.Name ->
Maybe SrcSpan -> String -> String
-spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod)
+spliceURL mmod = spliceURL' (moduleName <$> mmod)
-- | Same as 'spliceURL' but takes 'ModuleName' instead of 'Module'.
-spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name ->
+spliceURL' :: Maybe ModuleName -> Maybe GHC.Name ->
Maybe SrcSpan -> String -> String
-spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run
+spliceURL' maybe_mod maybe_name maybe_loc = run
where
- file = fromMaybe "" maybe_file
mdl = case maybe_mod of
Nothing -> ""
Just m -> moduleNameString m
@@ -82,23 +79,18 @@ spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run
run "" = ""
run ('%':'M':rest) = mdl ++ run rest
- run ('%':'F':rest) = file ++ run rest
run ('%':'N':rest) = name ++ run rest
run ('%':'K':rest) = kind ++ run rest
run ('%':'L':rest) = line ++ run rest
run ('%':'%':rest) = '%' : run rest
run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest
- run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest
run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest
run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest
run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) =
map (\x -> if x == '.' then c else x) mdl ++ run rest
- run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) =
- map (\x -> if x == '/' then c else x) file ++ run rest
-
run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest
run (c:rest) = c : run rest
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 4992609872..436504a823 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -1,4 +1,8 @@
-{-# LANGUAGE CPP, PatternGuards, TypeFamilies #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE BangPatterns #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Convert
@@ -19,6 +23,7 @@ module Haddock.Convert (
PrintRuntimeReps(..),
) where
+import Control.DeepSeq (force)
import GHC.Data.Bag ( emptyBag )
import GHC.Types.Basic ( TupleSort(..), DefMethSpec(..), TopLevelFlag(..) )
import GHC.Types.SourceText (SourceText(..))
@@ -37,6 +42,8 @@ import GHC.Core.TyCo.Compare( eqTypes )
import GHC.Hs
import GHC.Types.TyThing
import GHC.Types.Name
+import GHC.Unit.Types
+import GHC.Types.Id ( setIdType, idType )
import GHC.Types.Name.Set ( emptyNameSet )
import GHC.Types.Name.Reader ( mkVarUnqual )
import GHC.Builtin.Types.Prim ( alphaTyVars )
@@ -48,7 +55,6 @@ import GHC.Types.Unique ( getUnique )
import GHC.Utils.Misc ( chkAppend, dropList, equalLength
, filterByList, filterOut )
import GHC.Utils.Panic.Plain ( assert )
-import GHC.Types.FieldLabel
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.SrcLoc
@@ -56,8 +62,8 @@ import GHC.Types.SrcLoc
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Haddock.Types
-import Haddock.Interface.Specialize
import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars, mkEmptySigType )
+import Haddock.Interface.RenameType
import Data.Either (lefts, rights)
import Data.Maybe ( catMaybes, mapMaybe, maybeToList )
@@ -73,7 +79,7 @@ data PrintRuntimeReps = ShowRuntimeRep | HideRuntimeRep deriving Show
tyThingToLHsDecl
:: PrintRuntimeReps
-> TyThing
- -> Either ErrMsg ([ErrMsg], (HsDecl GhcRn))
+ -> Either String ([String], (HsDecl GhcRn))
tyThingToLHsDecl prr t = case t of
-- ids (functions and zero-argument a.k.a. CAFs) get a type signature.
-- Including built-in functions like seq.
@@ -89,7 +95,7 @@ tyThingToLHsDecl prr t = case t of
-- later in the file (also it's used for class associated-types too.)
ATyCon tc
| Just cl <- tyConClass_maybe tc -- classes are just a little tedious
- -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (FamilyDecl a)
+ -> let extractFamilyDecl :: TyClDecl a -> Either String (FamilyDecl a)
extractFamilyDecl (FamDecl _ d) = return d
extractFamilyDecl _ =
Left "tyThingToLHsDecl: impossible associated tycon"
@@ -117,7 +123,7 @@ tyThingToLHsDecl prr t = case t of
extractAtItem
:: ClassATItem
- -> Either ErrMsg (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))
+ -> Either String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))
extractAtItem (ATI at_tc def) = do
tyDecl <- synifyTyCon prr Nothing at_tc
famDecl <- extractFamilyDecl tyDecl
@@ -129,24 +135,32 @@ tyThingToLHsDecl prr t = case t of
vs = tyConVisibleTyVars (classTyCon cl)
in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl
- { tcdCtxt = Just $ synifyCtx (classSCTheta cl)
- , tcdLayout = NoLayoutInfo
- , tcdLName = synifyNameN cl
- , tcdTyVars = synifyTyVars vs
- , tcdFixity = synifyFixity cl
- , tcdFDs = map (\ (l,r) -> noLocA
- (FunDep noAnn (map (noLocA . getName) l) (map (noLocA . getName) r)) ) $
- snd $ classTvsFds cl
- , tcdSigs = noLocA (MinimalSig (noAnn, NoSourceText) . noLocA . fmap noLocA $ classMinimalDef cl) :
- [ noLocA tcdSig
- | clsOp <- classOpItems cl
- , tcdSig <- synifyTcIdSig vs clsOp ]
- , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
- -- class associated-types are a subset of TyCon:
- , tcdATs = atFamDecls
- , tcdATDefs = catMaybes atDefFamDecls
- , tcdDocs = [] --we don't have any docs at this point
- , tcdCExt = emptyNameSet }
+ { -- This should not always be `Just`, since `Just` of an empty
+ -- context causes pretty printing to print `()` for the
+ -- context
+ tcdCtxt =
+ case classSCTheta cl of
+ [] -> Nothing
+ th -> Just $ synifyCtx th
+
+ , tcdLayout = NoLayoutInfo
+ , tcdLName = synifyNameN cl
+ , tcdTyVars = synifyTyVars vs
+ , tcdFixity = synifyFixity cl
+ , tcdFDs = map (\ (l,r) -> noLocA
+ (FunDep noAnn (map (noLocA . getName) l) (map (noLocA . getName) r)) ) $
+ snd $ classTvsFds cl
+ , tcdSigs = noLocA (MinimalSig (noAnn, NoSourceText) . noLocA . fmap noLocA $ classMinimalDef cl) :
+ [ noLocA tcdSig
+ | clsOp <- classOpItems cl
+ , tcdSig <- synifyTcIdSig vs clsOp ]
+ , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
+ -- class associated-types are a subset of TyCon:
+ , tcdATs = atFamDecls
+ , tcdATDefs = catMaybes atDefFamDecls
+ , tcdDocs = [] --we don't have any docs at this point
+ , tcdCExt = emptyNameSet
+ }
| otherwise
-> synifyTyCon prr Nothing tc >>= allOK . TyClD noExtField
@@ -182,7 +196,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
where
args_poly = tyConArgsPolyKinded tc
-synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn)
+synifyAxiom :: CoAxiom br -> Either String (HsDecl GhcRn)
synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
| isOpenTypeFamilyTyCon tc
, Just branch <- coAxiomSingleBranch_maybe ax
@@ -202,7 +216,7 @@ synifyTyCon
:: PrintRuntimeReps
-> Maybe (CoAxiom br) -- ^ RHS of type synonym
-> TyCon -- ^ type constructor to convert
- -> Either ErrMsg (TyClDecl GhcRn)
+ -> Either String (TyClDecl GhcRn)
synifyTyCon prr _coax tc
| isPrimTyCon tc
= return $
@@ -253,35 +267,56 @@ synifyTyCon _prr _coax tc
where
resultVar = tyConFamilyResVar_maybe tc
mkFamDecl i = return $ FamDecl noExtField $
- FamilyDecl { fdExt = noAnn
- , fdInfo = i
- , fdTopLevel = TopLevel
- , fdLName = synifyNameN tc
- , fdTyVars = synifyTyVars (tyConVisibleTyVars tc)
- , fdFixity = synifyFixity tc
- , fdResultSig =
- synifyFamilyResultSig resultVar (tyConResKind tc)
- , fdInjectivityAnn =
- synifyInjectivityAnn resultVar (tyConTyVars tc)
- (tyConInjectivityInfo tc)
- }
+ FamilyDecl
+ { fdExt = noAnn
+ , fdInfo = i
+ , fdTopLevel = TopLevel
+ , fdLName = synifyNameN tc
+ , fdTyVars = synifyTyVars (tyConVisibleTyVars tc)
+ , fdFixity = synifyFixity tc
+ , fdResultSig = synifyFamilyResultSig resultVar (tyConResKind tc)
+ , fdInjectivityAnn =
+ synifyInjectivityAnn
+ resultVar
+ (tyConTyVars tc)
+ (tyConInjectivityInfo tc)
+ }
synifyTyCon _prr coax tc
+ -- type synonyms
| Just ty <- synTyConRhs_maybe tc
= return $ SynDecl { tcdSExt = emptyNameSet
, tcdLName = synifyNameN tc
, tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, tcdFixity = synifyFixity tc
- , tcdRhs = synifyType WithinType [] ty }
- | otherwise = do
+ , tcdRhs = synifyType WithinType [] ty
+ }
+
-- (closed) newtype and data
- let alg_ctx = synifyCtx (tyConStupidTheta tc)
+ | otherwise = do
+ let -- This should not always be `Just`, since `Just` of an empty
+ -- context causes pretty printing to print `()` for the context
+ alg_ctx =
+ case tyConStupidTheta tc of
+ [] -> Nothing
+ th -> Just $ synifyCtx th
+
+ -- Data families are named according to their CoAxioms, not their TyCons
name = case coax of
- Just a -> synifyNameN a -- Data families are named according to their
- -- CoAxioms, not their TyCons
+ Just a -> synifyNameN a
_ -> synifyNameN tc
+
+ -- For a data declaration:
+ -- data Vec :: Nat -> Type -> Type where
+ -- GHC will still report visible tyvars with default names 'a' and 'b'.
+ -- Since 'Nat' is not inhabited by lifted types, 'a' will be given a kind
+ -- signature (due to the logic in 'synify_ty_var'). Similarly, 'Vec'
+ -- constructs lifted types and will therefore not be given a result kind
+ -- signature. Thus, the generated documentation for 'Vec' will look like:
+ -- data Vec (a :: Nat) b where
tyvars = synifyTyVars (tyConVisibleTyVars tc)
kindSig = synifyDataTyConReturnKind tc
+
-- The data constructors.
--
-- Any data-constructors not exported from the module that *defines* the
@@ -299,9 +334,15 @@ synifyTyCon _prr coax tc
-- in prefix position), since, otherwise, the logic (at best) gets much more
-- complicated. (would use dataConIsInfix.)
use_gadt_syntax = isGadtSyntaxTyCon tc
- consRaw <- case partitionEithers $ synifyDataCon use_gadt_syntax <$> tyConDataCons tc of
- ([], consRaw) -> Right consRaw
+
+ consRaw <-
+ case partitionEithers
+ $ synifyDataCon use_gadt_syntax
+ <$> tyConDataCons tc
+ of
+ ([], cs) -> Right cs
(errs, _) -> Left (unlines errs)
+
cons <- case (isNewTyCon tc, consRaw) of
(False, cons) -> Right (DataTypeCons False cons)
(True, [con]) -> Right (NewTypeCon con)
@@ -310,7 +351,7 @@ synifyTyCon _prr coax tc
let -- "deriving" doesn't affect the signature, no need to specify any.
alg_deriv = []
defn = HsDataDefn { dd_ext = noExtField
- , dd_ctxt = Just alg_ctx
+ , dd_ctxt = alg_ctx
, dd_cType = Nothing
, dd_kindSig = kindSig
, dd_cons = cons
@@ -342,25 +383,24 @@ synifyDataTyConReturnKind tc
synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity
-> Maybe (LInjectivityAnn GhcRn)
-synifyInjectivityAnn Nothing _ _ = Nothing
-synifyInjectivityAnn _ _ NotInjective = Nothing
synifyInjectivityAnn (Just lhs) tvs (Injective inj) =
let rhs = map (noLocA . tyVarName) (filterByList inj tvs)
in Just $ noLocA $ InjectivityAnn noAnn (noLocA lhs) rhs
+synifyInjectivityAnn _ _ _ = Nothing
synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn
-synifyFamilyResultSig Nothing kind
- | isLiftedTypeKind kind = noLocA $ NoSig noExtField
- | otherwise = noLocA $ KindSig noExtField (synifyKindSig kind)
+synifyFamilyResultSig Nothing kind
+ | isLiftedTypeKind kind
+ = noLocA $ NoSig noExtField
+ | otherwise
+ = noLocA $ KindSig noExtField (synifyKindSig kind)
synifyFamilyResultSig (Just name) kind =
- noLocA $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA name) (synifyKindSig kind))
-
--- User beware: it is your responsibility to pass True (use_gadt_syntax)
--- for any constructor that would be misrepresented by omitting its
--- result-type.
--- But you might want pass False in simple enough cases,
--- if you think it looks better.
-synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl GhcRn)
+ noLocA $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA name) (synifyKindSig kind))
+
+-- User beware: it is your responsibility to pass True (use_gadt_syntax) for any
+-- constructor that would be misrepresented by omitting its result-type. But you
+-- might want pass False in simple enough cases, if you think it looks better.
+synifyDataCon :: Bool -> DataCon -> Either String (LConDecl GhcRn)
synifyDataCon use_gadt_syntax dc =
let
-- dataConIsInfix allegedly tells us whether it was declared with
@@ -395,7 +435,7 @@ synifyDataCon use_gadt_syntax dc =
ConDeclField noAnn [noLocA $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ field_label $ flLabel fl)] synTy
Nothing
- mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn)
+ mk_h98_arg_tys :: Either String (HsConDeclH98Details GhcRn)
mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
(True,True) -> Left "synifyDataCon: contradiction!"
(True,False) -> return $ RecCon (noLocA field_tys)
@@ -434,7 +474,7 @@ synifyDataCon use_gadt_syntax dc =
, con_doc = Nothing }
synifyNameN :: NamedThing n => n -> LocatedN Name
-synifyNameN n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n)
+synifyNameN n = L (noAnnSrcSpan $! srcLocSpan (getSrcLoc n)) (getName n)
-- synifyName :: NamedThing n => n -> LocatedA Name
-- synifyName n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n)
@@ -452,8 +492,9 @@ synifyIdSig
-> [TyVar] -- ^ free variables in the type to convert
-> Id -- ^ the 'Id' from which to get the type signature
-> Sig GhcRn
-synifyIdSig prr s vs i = TypeSig noAnn [synifyNameN i] (synifySigWcType s vs t)
+synifyIdSig prr s vs i = TypeSig noAnn [n] (synifySigWcType s vs t)
where
+ !n = force $ synifyNameN i
t = defaultType prr (varType i)
-- | Turn a 'ClassOpItem' into a list of signatures. The list returned is going
@@ -469,7 +510,7 @@ synifyTcIdSig vs (i, dm) =
defSig t = synifySigType ImplicitizeForAll vs t
synifyCtx :: [PredType] -> LHsContext GhcRn
-synifyCtx ts = noLocA ( map (synifyType WithinType []) ts)
+synifyCtx ts = noLocA (map (synifyType WithinType []) ts)
synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
@@ -489,9 +530,10 @@ synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv
-- signatures (even if they don't have the lifted type kind).
synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn
synify_ty_var no_kinds flag tv
- | isLiftedTypeKind kind || tv `elemVarSet` no_kinds
- = noLocA (UserTyVar noAnn flag (noLocA name))
- | otherwise = noLocA (KindedTyVar noAnn flag (noLocA name) (synifyKindSig kind))
+ | isLiftedTypeKind kind || tv `elemVarSet` no_kinds
+ = noLocA (UserTyVar noAnn flag (noLocA name))
+ | otherwise
+ = noLocA (KindedTyVar noAnn flag (noLocA name) (synifyKindSig kind))
where
kind = tyVarKind tv
name = getName tv
@@ -556,7 +598,7 @@ synifySigType s vs ty = mkEmptySigType (synifyType s vs ty)
synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn
-- Ditto (see synifySigType)
-synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (synifyType s vs ty))
+synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (rename (map getName vs) $ synifyType s vs ty))
synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn
-- Ditto (see synifySigType)
@@ -586,6 +628,7 @@ synifyType _ vs (TyConApp tc tys)
, rep `hasKey` boxedRepDataConKey
, lev `hasKey` liftedDataConKey
= noLocA (HsTyVar noAnn NotPromoted (noLocA liftedTypeKindTyConName))
+
-- Use non-prefix tuple syntax where possible, because it looks nicer.
| Just sort <- tyConTuple_maybe tc
, tyConArity tc == tys_len
@@ -595,16 +638,22 @@ synifyType _ vs (TyConApp tc tys)
ConstraintTuple -> HsBoxedOrConstraintTuple
UnboxedTuple -> HsUnboxedTuple)
(map (synifyType WithinType vs) vis_tys)
- | isUnboxedSumTyCon tc = noLocA $ HsSumTy noAnn (map (synifyType WithinType vs) vis_tys)
+
+ | isUnboxedSumTyCon tc
+ = noLocA $ HsSumTy noAnn (map (synifyType WithinType vs) vis_tys)
+
| Just dc <- isPromotedDataCon_maybe tc
, isTupleDataCon dc
, dataConSourceArity dc == length vis_tys
= noLocA $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys)
+
-- ditto for lists
- | getName tc == listTyConName, [ty] <- vis_tys =
- noLocA $ HsListTy noAnn (synifyType WithinType vs ty)
+ | getName tc == listTyConName, [ty] <- vis_tys
+ = noLocA $ HsListTy noAnn (synifyType WithinType vs ty)
+
| tc == promotedNilDataCon, [] <- vis_tys
= noLocA $ HsExplicitListTy noExtField IsPromoted []
+
| tc == promotedConsDataCon
, [ty1, ty2] <- vis_tys
= let hTy = synifyType WithinType vs ty1
@@ -613,11 +662,13 @@ synifyType _ vs (TyConApp tc tys)
-> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy')
| otherwise
-> noLocA $ HsOpTy noAnn IsPromoted hTy (noLocA $ getName tc) tTy
+
-- ditto for implicit parameter tycons
| tc `hasKey` ipClassKey
, [name, ty] <- tys
, Just x <- isStrLitTy name
= noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType vs ty)
+
-- and equalities
| tc `hasKey` eqTyConKey
, [ty1, ty2] <- tys
@@ -626,6 +677,7 @@ synifyType _ vs (TyConApp tc tys)
(synifyType WithinType vs ty1)
(noLocA eqTyConName)
(synifyType WithinType vs ty2)
+
-- and infix type operators
| isSymOcc (nameOccName (getName tc))
, ty1:ty2:tys_rest <- vis_tys
@@ -635,12 +687,13 @@ synifyType _ vs (TyConApp tc tys)
(noLocA $ getName tc)
(synifyType WithinType vs ty2))
tys_rest
+
-- Most TyCons:
| otherwise
= mk_app_tys (HsTyVar noAnn prom $ noLocA (getName tc))
vis_tys
where
- prom = if isPromotedDataCon tc then IsPromoted else NotPromoted
+ !prom = if isPromotedDataCon tc then IsPromoted else NotPromoted
mk_app_tys ty_app ty_args =
foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2)
(noLocA ty_app)
@@ -843,18 +896,18 @@ stripKindSig :: LHsType GhcRn -> LHsType GhcRn
stripKindSig (L _ (HsKindSig _ t _)) = t
stripKindSig t = t
-synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn
-synifyInstHead (vs, preds, cls, types) = specializeInstHead $ InstHead
+synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)] -> InstHead GhcRn
+synifyInstHead (vs, preds, cls, types) associated_families = InstHead
{ ihdClsName = getName cls
, ihdTypes = map unLoc annot_ts
, ihdInstType = ClassInst
{ clsiCtx = map (unLoc . synifyType WithinType []) preds
, clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon)
- , clsiSigs = map synifyClsIdSig $ classMethods cls
- , clsiAssocTys = do
- (Right (FamDecl _ fam)) <- map (synifyTyCon HideRuntimeRep Nothing)
- (classATs cls)
- pure $ mkPseudoFamilyDecl fam
+ , clsiSigs = map synifyClsIdSig $ specialized_class_methods
+ , clsiAssocTys = [ (f_inst, f_doc, f_name, f_mod)
+ | (f_i, opaque, f_doc, f_name, f_mod) <- associated_families
+ , Right f_inst <- [synifyFamInst f_i opaque]
+ ]
}
}
where
@@ -864,9 +917,10 @@ synifyInstHead (vs, preds, cls, types) = specializeInstHead $ InstHead
annot_ts = zipWith3 annotHsType args_poly ts ts'
args_poly = tyConArgsPolyKinded cls_tycon
synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs
+ specialized_class_methods = [ setIdType m (piResultTys (idType m) types) | m <- classMethods cls ]
-- Convert a family instance, this could be a type family or data family
-synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn)
+synifyFamInst :: FamInst -> Bool -> Either String (InstHead GhcRn)
synifyFamInst fi opaque = do
ityp' <- ityp fam_flavor
return InstHead
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 3a63c5a676..3fab1a1355 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -9,6 +9,7 @@
{-# LANGUAGE MonadComprehensions #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
-- |
@@ -27,27 +28,29 @@ module Haddock.GhcUtils where
import Control.Arrow
import Data.Char ( isSpace )
-import Data.Foldable ( toList )
+import Data.Foldable ( toList, foldl' )
import Data.List.NonEmpty ( NonEmpty )
import Data.Maybe ( mapMaybe, fromMaybe )
+import qualified Data.Set as Set
import Haddock.Types( DocName, DocNameI, XRecCond )
+import GHC
+import GHC.Builtin.Names
+import GHC.Data.FastString
+import GHC.Driver.Ppr (showPpr )
+import GHC.Driver.Session
+import GHC.Types.Name
import GHC.Utils.FV as FV
import GHC.Utils.Outputable ( Outputable )
import GHC.Utils.Panic ( panic )
-import GHC.Driver.Ppr (showPpr )
-import GHC.Types.Name
-import GHC.Unit.Module
-import GHC
-import GHC.Driver.Session
import GHC.Types.SrcLoc ( advanceSrcLoc )
import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder
, tyVarKind, updateTyVarKind, isInvisibleForAllTyFlag )
import GHC.Types.Var.Set ( VarSet, emptyVarSet )
import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )
import GHC.Core.TyCo.Rep ( Type(..) )
-import GHC.Core.Type ( isRuntimeRepVar )
+import GHC.Core.Type ( isRuntimeRepVar, binderVar )
import GHC.Builtin.Types( liftedRepTy )
import GHC.Data.StringBuffer ( StringBuffer )
@@ -57,7 +60,7 @@ import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
-import GHC.HsToCore.Docs
+import GHC.HsToCore.Docs hiding (sigNameNoLoc)
moduleString :: Module -> String
moduleString = moduleNameString . moduleName
@@ -99,7 +102,16 @@ ifTrueJust True = Just
ifTrueJust False = const Nothing
sigName :: LSig GhcRn -> [IdP GhcRn]
-sigName (L _ sig) = sigNameNoLoc emptyOccEnv sig
+sigName (L _ sig) = sigNameNoLoc' emptyOccEnv sig
+
+sigNameNoLoc' :: forall pass w. UnXRec pass => w -> Sig pass -> [IdP pass]
+sigNameNoLoc' _ (TypeSig _ ns _) = map (unXRec @pass) ns
+sigNameNoLoc' _ (ClassOpSig _ _ ns _) = map (unXRec @pass) ns
+sigNameNoLoc' _ (PatSynSig _ ns _) = map (unXRec @pass) ns
+sigNameNoLoc' _ (SpecSig _ n _ _) = [unXRec @pass n]
+sigNameNoLoc' _ (InlineSig _ n _) = [unXRec @pass n]
+sigNameNoLoc' _ (FixSig _ (FixitySig _ ns _)) = map (unXRec @pass) ns
+sigNameNoLoc' _ _ = []
-- | Was this signature given by the user?
isUserLSig :: forall p. UnXRec p => LSig p -> Bool
@@ -112,6 +124,12 @@ isClassD _ = False
pretty :: Outputable a => DynFlags -> a -> String
pretty = showPpr
+dataListModule :: Module
+dataListModule = mkBaseModule (fsLit "Data.List")
+
+dataTupleModule :: Module
+dataTupleModule = mkBaseModule (fsLit "Data.Tuple")
+
-- ---------------------------------------------------------------------
-- These functions are duplicated from the GHC API, as they must be
@@ -196,7 +214,7 @@ getMainDeclBinderI (ValD _ d) =
case collectHsBindBinders CollNoDictBinders d of
[] -> []
(name:_) -> [name]
-getMainDeclBinderI (SigD _ d) = sigNameNoLoc emptyOccEnv d
+getMainDeclBinderI (SigD _ d) = sigNameNoLoc' emptyOccEnv d
getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = []
getMainDeclBinderI _ = []
@@ -339,7 +357,7 @@ reparenTypePrec = go
where
-- Shorter name for 'reparenType'
- go :: XParTy a ~ EpAnn AnnParen => Precedence -> HsType a -> HsType a
+ go :: Precedence -> HsType a -> HsType a
go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty)
go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)
go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys)
@@ -359,7 +377,6 @@ reparenTypePrec = go
p' _ = PREC_TOP -- parens will get added anyways later...
ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt
in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty)
- -- = paren p PREC_FUN $ HsQualTy x (fmap (mapXRec @a (map reparenLType)) ctxt) (reparenLType ty)
go p (HsFunTy x w ty1 ty2)
= paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2)
go p (HsAppTy x fun_ty arg_ty)
@@ -377,12 +394,11 @@ reparenTypePrec = go
go _ t@XHsType{} = t
-- Located variant of 'go'
- goL :: XParTy a ~ EpAnn AnnParen => Precedence -> LHsType a -> LHsType a
+ goL :: Precedence -> LHsType a -> LHsType a
goL ctxt_prec = mapXRec @a (go ctxt_prec)
-- Optionally wrap a type in parens
- paren :: XParTy a ~ EpAnn AnnParen
- => Precedence -- Precedence of context
+ paren :: Precedence -- Precedence of context
-> Precedence -- Precedence of top-level operator
-> HsType a -> HsType a -- Wrap in parens if (ctxt >= op)
paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noAnn . wrapXRec @a
@@ -650,6 +666,27 @@ tryCppLine !loc !buf = spanSpace (S.prevChar buf '\n' == '\n') loc buf
(c , b') -> spanCppLine (advanceSrcLoc l c) b'
+-------------------------------------------------------------------------------
+-- * Names in a 'Type'
+-------------------------------------------------------------------------------
+
+-- | Given a 'Type', return a set of 'Name's coming from the 'TyCon's within
+-- the type.
+typeNames :: Type -> Set.Set Name
+typeNames ty = go ty Set.empty
+ where
+ go :: Type -> Set.Set Name -> Set.Set Name
+ go t acc =
+ case t of
+ TyVarTy {} -> acc
+ AppTy t1 t2 -> go t2 $ go t1 acc
+ FunTy _ _ t1 t2 -> go t2 $ go t1 acc
+ TyConApp tcon args -> foldl' (\s t' -> go t' s) (Set.insert (getName tcon) acc) args
+ ForAllTy bndr t' -> go t' $ go (tyVarKind (binderVar bndr)) acc
+ LitTy _ -> acc
+ CastTy t' _ -> go t' acc
+ CoercionTy {} -> acc
+
-------------------------------------------------------------------------------
-- * Free variables of a 'Type'
-------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 279aed8ffe..cd94add63c 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -1,4 +1,8 @@
-{-# LANGUAGE CPP, OverloadedStrings, BangPatterns, NamedFieldPuns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TupleSections #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface
@@ -29,42 +33,49 @@
-- using this environment.
-----------------------------------------------------------------------------
module Haddock.Interface (
- plugin
- , processModules
+ processModules
) where
import Haddock.GhcUtils (moduleString, pretty)
import Haddock.Interface.AttachInstances (attachInstances)
-import Haddock.Interface.Create (createInterface1, runIfM)
+import Haddock.Interface.Create (createInterface1)
import Haddock.Interface.Rename (renameInterface)
import Haddock.InterfaceFile (InterfaceFile, ifInstalledIfaces, ifLinkEnv)
import Haddock.Options hiding (verbosity)
-import Haddock.Types (DocOption (..), Documentation (..), ExportItem (..), IfaceMap, InstIfaceMap, Interface, LinkEnv,
- expItemDecl, expItemMbDoc, ifaceDoc, ifaceExportItems, ifaceExports, ifaceHaddockCoverage,
- ifaceInstances, ifaceMod, ifaceOptions, ifaceVisibleExports, instMod, runWriter, throwE)
+import Haddock.Types
import Haddock.Utils (Verbosity (..), normal, out, verbose)
-import Control.Monad (unless, when)
-import Control.Monad.IO.Class (MonadIO)
-import Data.IORef (atomicModifyIORef', newIORef, readIORef)
-import Data.List (foldl', isPrefixOf, nub)
-import Text.Printf (printf)
-import qualified Data.Map as Map
+import Control.Monad
+import Data.List (foldl', isPrefixOf)
+import Data.Traversable (for)
+import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
+import Debug.Trace (traceMarkerIO)
+import System.Exit (exitFailure ) -- TODO use Haddock's die
+import Text.Printf
-import GHC hiding (verbosity)
+import GHC hiding (verbosity, SuccessFlag(..))
+import GHC.Data.FastString (unpackFS)
import GHC.Data.Graph.Directed
+import GHC.Data.Maybe
import GHC.Driver.Env
-import GHC.Driver.Monad (modifySession, withTimingM)
+import GHC.Driver.Monad
+import GHC.Driver.Make
+import GHC.Driver.Main
+import GHC.Core.InstEnv
import GHC.Driver.Session hiding (verbosity)
import GHC.HsToCore.Docs (getMainDeclBinder)
-import GHC.Plugins
-import GHC.Tc.Types (TcGblEnv (..), TcM)
-import GHC.Tc.Utils.Env (tcLookupGlobal)
-import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv)
-import GHC.Unit.Module.Graph
+import GHC.Types.Error (mkUnknownDiagnostic)
+import GHC.Types.Name.Occurrence (emptyOccEnv)
+import GHC.Unit.Module.Graph (ModuleGraphNode (..))
+import GHC.Unit.Module.ModDetails
+import GHC.Unit.Module.ModSummary (isBootSummary)
+import GHC.Utils.Outputable ((<+>), pprModuleName)
import GHC.Utils.Error (withTiming)
+import GHC.Unit.Home.ModInfo
+import GHC.Tc.Utils.Env (lookupGlobal_maybe)
+import GHC.Utils.Outputable (Outputable)
#if defined(mingw32_HOST_OS)
import System.IO
@@ -89,243 +100,165 @@ processModules verbosity modules flags extIfaces = do
liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure
#endif
- out verbosity verbose "Creating interfaces..."
- let
- instIfaceMap :: InstIfaceMap
- instIfaceMap = Map.fromList
- [ (instMod iface, iface)
- | ext <- extIfaces
- , iface <- ifInstalledIfaces ext
- ]
+ dflags <- getDynFlags
- (interfaces, ms) <- createIfaces verbosity modules flags instIfaceMap
+ -- Map from a module to a corresponding installed interface
+ let instIfaceMap :: InstIfaceMap
+ instIfaceMap = Map.fromList
+ [ (instMod iface, iface)
+ | ext <- extIfaces
+ , iface <- ifInstalledIfaces ext
+ ]
+
+ interfaces <- createIfaces verbosity modules flags instIfaceMap
let exportedNames =
Set.unions $ map (Set.fromList . ifaceExports) $
filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces
mods = Set.fromList $ map ifaceMod interfaces
- out verbosity verbose "Attaching instances..."
+
interfaces' <- {-# SCC attachInstances #-}
withTimingM "attachInstances" (const ()) $ do
- attachInstances (exportedNames, mods) interfaces instIfaceMap ms
+ attachInstances (exportedNames, mods) interfaces instIfaceMap
- out verbosity verbose "Building cross-linking environment..."
-- Combine the link envs of the external packages into one
let extLinks = Map.unions (map ifLinkEnv extIfaces)
homeLinks = buildHomeLinks interfaces' -- Build the environment for the home
-- package
links = homeLinks `Map.union` extLinks
- out verbosity verbose "Renaming interfaces..."
let warnings = Flag_NoWarnings `notElem` flags
- dflags <- getDynFlags
- let (interfaces'', msgs) =
- runWriter $ mapM (renameInterface dflags (ignoredSymbols flags) links warnings) interfaces'
- liftIO $ mapM_ putStrLn msgs
+ ignoredSymbolSet = ignoredSymbols flags
- return (interfaces'', homeLinks)
+ interfaces'' <-
+ withTimingM "renameAllInterfaces" (const ()) $
+ for interfaces' $ \i -> do
+ withTimingM ("renameInterface: " <+> pprModuleName (moduleName (ifaceMod i))) (const ()) $
+ renameInterface dflags ignoredSymbolSet links warnings (Flag_Hoogle `elem` flags) i
+ return (interfaces'', homeLinks)
--------------------------------------------------------------------------------
-- * Module typechecking and Interface creation
--------------------------------------------------------------------------------
-
-createIfaces :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet)
+createIfaces
+ :: Verbosity
+ -- ^ Verbosity requested by the caller
+ -> [String]
+ -- ^ List of modules provided as arguments to Haddock (still in FilePath
+ -- format)
+ -> [Flag]
+ -- ^ Command line flags which Hadddock was invoked with
+ -> InstIfaceMap
+ -- ^ Map from module to corresponding installed interface file
+ -> Ghc [Interface]
+ -- ^ Resulting interfaces
createIfaces verbosity modules flags instIfaceMap = do
- (haddockPlugin, getIfaces, getModules) <- liftIO $ plugin
- verbosity flags instIfaceMap
-
- let
- installHaddockPlugin :: HscEnv -> HscEnv
- installHaddockPlugin hsc_env =
- let
- old_plugins = hsc_plugins hsc_env
- new_plugins = old_plugins { staticPlugins = haddockPlugin : staticPlugins old_plugins }
- hsc_env' = hsc_env { hsc_plugins = new_plugins }
- in hscUpdateFlags (flip gopt_set Opt_PluginTrustworthy) hsc_env'
-
- -- Note that we would rather use withTempSession but as long as we
- -- have the separate attachInstances step we need to keep the session
- -- alive to be able to find all the instances.
- modifySession installHaddockPlugin
-
targets <- mapM (\filePath -> guessTarget filePath Nothing Nothing) modules
setTargets targets
-
- loadOk <- withTimingM "load" (const ()) $
- {-# SCC load #-} GHC.load LoadAllTargets
-
- case loadOk of
- Failed ->
- throwE "Cannot typecheck modules"
- Succeeded -> do
- modGraph <- GHC.getModuleGraph
- ifaceMap <- liftIO getIfaces
- moduleSet <- liftIO getModules
-
- let
- -- We topologically sort the module graph including boot files,
- -- so it should be acylic (hopefully we failed much earlier if this is not the case)
- -- We then filter out boot modules from the resultant topological sort
- --
- -- We do it this way to make 'buildHomeLinks' a bit more stable
- -- 'buildHomeLinks' depends on the topological order of its input in order
- -- to construct its result. In particular, modules closer to the bottom of
- -- the dependency chain are to be prefered for link destinations.
- --
- -- If there are cycles in the graph, then this order is indeterminate
- -- (the nodes in the cycle can be ordered in any way).
- -- While 'topSortModuleGraph' does guarantee stability for equivalent
- -- module graphs, seemingly small changes in the ModuleGraph can have
- -- big impacts on the `LinkEnv` constructed.
- --
- -- For example, suppose
- -- G1 = A.hs -> B.hs -> C.hs (where '->' denotes an import).
- --
- -- Then suppose C.hs is changed to have a cyclic dependency on A
- --
- -- G2 = A.hs -> B.hs -> C.hs -> A.hs-boot
- --
- -- For G1, `C.hs` is preferred for link destinations. However, for G2,
- -- the topologically sorted order not taking into account boot files (so
- -- C -> A) is completely indeterminate.
- -- Using boot files to resolve cycles, we end up with the original order
- -- [C, B, A] (in decreasing order of preference for links)
- --
- -- This exact case came up in testing for the 'base' package, where there
- -- is a big module cycle involving 'Prelude' on windows, but the cycle doesn't
- -- include 'Prelude' on non-windows platforms. This lead to drastically different
- -- LinkEnv's (and failing haddockHtmlTests) across the platforms
- --
- -- In effect, for haddock users this behaviour (using boot files to eliminate cycles)
- -- means that {-# SOURCE #-} imports no longer count towards re-ordering
- -- the preference of modules for linking.
- --
- -- i.e. if module A imports B, then B is preferred over A,
- -- but if module A {-# SOURCE #-} imports B, then we can't say the same.
- --
- go (AcyclicSCC (ModuleNode _ ms))
- | NotBoot <- isBootSummary ms = [ms]
- | otherwise = []
- go (AcyclicSCC _) = []
- go (CyclicSCC _) = error "haddock: module graph cyclic even with boot files"
-
- ifaces :: [Interface]
- ifaces =
- [ Map.findWithDefault
- (error "haddock:iface")
- (ms_mod ms)
- ifaceMap
- | ms <- concatMap go $ topSortModuleGraph False modGraph Nothing
- ]
-
- return (ifaces, moduleSet)
-
-
--- | A `Plugin` that hooks into GHC's compilation pipeline to generate Haddock
--- interfaces. Due to the plugin nature we benefit from GHC's capabilities to
--- parallelize the compilation process.
-plugin
- :: MonadIO m
- => Verbosity
- -> [Flag]
- -> InstIfaceMap
- -> m
- (
- StaticPlugin -- the plugin to install with GHC
- , m IfaceMap -- get the processed interfaces
- , m ModuleSet -- get the loaded modules
- )
-plugin verbosity flags instIfaceMap = liftIO $ do
- ifaceMapRef <- newIORef Map.empty
- moduleSetRef <- newIORef emptyModuleSet
-
+ (_errs, modGraph) <- depanalE [] False
+
+ liftIO $ traceMarkerIO "Load started"
+ -- Create (if necessary) and load .hi-files.
+ success <- withTimingM "load'" (const ()) $
+ load' noIfaceCache LoadAllTargets mkUnknownDiagnostic (Just batchMsg) modGraph
+ when (failed success) $ do
+ out verbosity normal "load' failed"
+ liftIO exitFailure
+ liftIO $ traceMarkerIO "Load ended"
+
+ -- We topologically sort the module graph including boot files,
+ -- so it should be acylic (hopefully we failed much earlier if this is not the case)
+ -- We then filter out boot modules from the resultant topological sort
+ --
+ -- We do it this way to make 'buildHomeLinks' a bit more stable
+ -- 'buildHomeLinks' depends on the topological order of its input in order
+ -- to construct its result. In particular, modules closer to the bottom of
+ -- the dependency chain are to be prefered for link destinations.
+ --
+ -- If there are cycles in the graph, then this order is indeterminate
+ -- (the nodes in the cycle can be ordered in any way).
+ -- While 'topSortModuleGraph' does guarantee stability for equivalent
+ -- module graphs, seemingly small changes in the ModuleGraph can have
+ -- big impacts on the `LinkEnv` constructed.
+ --
+ -- For example, suppose
+ -- G1 = A.hs -> B.hs -> C.hs (where '->' denotes an import).
+ --
+ -- Then suppose C.hs is changed to have a cyclic dependency on A
+ --
+ -- G2 = A.hs -> B.hs -> C.hs -> A.hs-boot
+ --
+ -- For G1, `C.hs` is preferred for link destinations. However, for G2,
+ -- the topologically sorted order not taking into account boot files (so
+ -- C -> A) is completely indeterminate.
+ -- Using boot files to resolve cycles, we end up with the original order
+ -- [C, B, A] (in decreasing order of preference for links)
+ --
+ -- This exact case came up in testing for the 'base' package, where there
+ -- is a big module cycle involving 'Prelude' on windows, but the cycle doesn't
+ -- include 'Prelude' on non-windows platforms. This lead to drastically different
+ -- LinkEnv's (and failing haddockHtmlTests) across the platforms
+ --
+ -- In effect, for haddock users this behaviour (using boot files to eliminate cycles)
+ -- means that {-# SOURCE #-} imports no longer count towards re-ordering
+ -- the preference of modules for linking.
+ --
+ -- i.e. if module A imports B, then B is preferred over A,
+ -- but if module A {-# SOURCE #-} imports B, then we can't say the same.
+ --
let
- processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM ()
- processTypeCheckedResult mod_summary tc_gbl_env
- -- Don't do anything for hs-boot modules
- | IsBoot <- isBootSummary mod_summary =
- pure ()
- | otherwise = do
- hsc_env <- getTopEnv
- ifaces <- liftIO $ readIORef ifaceMapRef
- (iface, modules) <- withTiming (hsc_logger hsc_env)
- "processModule" (const ()) $
- processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env
-
- liftIO $ do
- atomicModifyIORef' ifaceMapRef $ \xs ->
- (Map.insert (ms_mod mod_summary) iface xs, ())
-
- atomicModifyIORef' moduleSetRef $ \xs ->
- (modules `unionModuleSet` xs, ())
-
- staticPlugin :: StaticPlugin
- staticPlugin = StaticPlugin
- {
- spPlugin = PluginWithArgs
- {
- paPlugin = defaultPlugin
- {
- renamedResultAction = keepRenamedSource
- , typeCheckResultAction = \_ mod_summary tc_gbl_env -> setGblEnv tc_gbl_env $ do
- processTypeCheckedResult mod_summary tc_gbl_env
- pure tc_gbl_env
-
- }
- , paArguments = []
- }
- }
-
- pure
- ( staticPlugin
- , liftIO (readIORef ifaceMapRef)
- , liftIO (readIORef moduleSetRef)
- )
-
-
-processModule1
- :: Verbosity
- -> [Flag]
- -> IfaceMap
- -> InstIfaceMap
- -> HscEnv
- -> ModSummary
- -> TcGblEnv
- -> TcM (Interface, ModuleSet)
-processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env = do
- out verbosity verbose "Creating interface..."
+ go (AcyclicSCC (ModuleNode _ ms))
+ | NotBoot <- isBootSummary ms = [ms]
+ | otherwise = []
+ go (AcyclicSCC _) = []
+ go (CyclicSCC _) = error "haddock: module graph cyclic even with boot files"
+
+ -- Visit modules in that order
+ sortedMods = concatMap go $ topSortModuleGraph False modGraph Nothing
+ out verbosity normal "Haddock coverage:"
+ (ifaces, _) <- foldM f ([], Map.empty) sortedMods
+ return (reverse ifaces)
+ where
+ f (ifaces, ifaceMap) modSummary = do
+ x <- {-# SCC processModule #-}
+ withTimingM "processModule" (const ()) $ do
+ processModule verbosity modSummary flags ifaceMap instIfaceMap
+ return $ case x of
+ Just iface -> ( iface:ifaces
+ , Map.insert (ifaceMod iface) iface ifaceMap )
+ Nothing -> ( ifaces
+ , ifaceMap ) -- Boot modules don't generate ifaces.
+
+dropErr :: MaybeErr e a -> Maybe a
+dropErr (Succeeded a) = Just a
+dropErr (Failed _) = Nothing
+
+processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)
+processModule verbosity modSummary flags ifaceMap instIfaceMap = do
+ out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modSummary) ++ "..."
+
+ hsc_env <- getSession
+ dflags <- getDynFlags
+ let hmi = case lookupHpt (hsc_HPT hsc_env) (moduleName $ ms_mod modSummary) of
+ Nothing -> error "processModule: All modules should be loaded into the HPT by this point"
+ Just x -> x
+ mod_iface = hm_iface hmi
+ unit_state = hsc_units hsc_env
- let
- TcGblEnv { tcg_rdr_env } = tc_gbl_env
+ cls_insts = instEnvElts . md_insts $ hm_details hmi
- unit_state = hsc_units hsc_env
+ fam_insts = md_fam_insts $ hm_details hmi
- (!interface, messages) <- do
+ insts = (cls_insts, fam_insts)
+
+ !interface <- do
logger <- getLogger
{-# SCC createInterface #-}
- withTiming logger "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
- createInterface1 flags unit_state mod_summary tc_gbl_env
- ifaces inst_ifaces
-
- -- We need to keep track of which modules were somehow in scope so that when
- -- Haddock later looks for instances, it also looks in these modules too.
- --
- -- See https://github.com/haskell/haddock/issues/469.
- let
- mods :: ModuleSet
- !mods = mkModuleSet
- [ nameModule name
- | gre <- globalRdrEnvElts tcg_rdr_env
- , let name = greName gre
- , nameIsFromExternalPackage (hsc_home_unit hsc_env) name
- , isTcOcc (nameOccName name) -- Types and classes only
- , unQualOK gre -- In scope unqualified
- ]
-
- liftIO $ mapM_ putStrLn (nub messages)
- dflags <- getDynFlags
+ withTiming logger "createInterface" (const ()) $
+ runIfM (liftIO . fmap dropErr . lookupGlobal_maybe hsc_env) $
+ createInterface1 flags unit_state modSummary mod_iface ifaceMap instIfaceMap insts
let
(haddockable, haddocked) =
@@ -349,9 +282,10 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
undocumentedExports :: [String]
undocumentedExports =
[ formatName (locA s) n
- | ExportDecl { expItemDecl = L s n
- , expItemMbDoc = (Documentation Nothing _, _)
- } <- ifaceExportItems interface
+ | ExportDecl ExportD
+ { expDDecl = L s n
+ , expDMbDoc = (Documentation Nothing _, _)
+ } <- ifaceExportItems interface
]
where
formatName :: SrcSpan -> HsDecl GhcRn -> String
@@ -376,7 +310,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
unless header $ out verbosity normal " Module header"
mapM_ (out verbosity normal . (" " ++)) undocumentedExports
- pure (interface, mods)
+ return (Just interface)
--------------------------------------------------------------------------------
@@ -396,10 +330,12 @@ buildHomeLinks :: [Interface] -> LinkEnv
buildHomeLinks ifaces = foldl' upd Map.empty (reverse ifaces)
where
upd old_env iface
- | OptHide `elem` ifaceOptions iface = old_env
+ | OptHide `elem` ifaceOptions iface =
+ old_env
| OptNotHome `elem` ifaceOptions iface =
- foldl' keep_old old_env exported_names
- | otherwise = foldl' keep_new old_env exported_names
+ foldl' keep_old old_env exported_names
+ | otherwise =
+ foldl' keep_new old_env exported_names
where
exported_names = ifaceVisibleExports iface ++ map getName (ifaceInstances iface)
mdl = ifaceMod iface
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 4dca31b33f..9120d293cc 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -1,6 +1,15 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.AttachInstances
@@ -13,19 +22,24 @@
-- Stability : experimental
-- Portability : portable
-----------------------------------------------------------------------------
-module Haddock.Interface.AttachInstances (attachInstances) where
+module Haddock.Interface.AttachInstances (attachInstances, instHead) where
-import Haddock.Types
import Haddock.Convert
+import Haddock.GhcUtils (typeNames)
+import Haddock.Types
import Control.Applicative ((<|>))
import Control.Arrow hiding ((<+>))
+import Control.DeepSeq (force)
+import Data.Foldable (foldl')
import Data.List (sortBy)
+import qualified Data.Sequence as Seq
import Data.Ord (comparing)
import Data.Maybe ( maybeToList, mapMaybe, fromMaybe )
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
+import Data.Foldable (toList)
import GHC.Data.FastString (unpackFS)
import GHC.Core.Class
@@ -33,9 +47,12 @@ import GHC.Core (isOrphan)
import GHC.Core.FamInstEnv
import GHC
import GHC.Core.InstEnv
-import GHC.Unit.Module.Env ( ModuleSet, moduleSetElts )
+import GHC.Unit.Module.Env ( moduleSetElts, mkModuleSet )
+import GHC.Unit.State
import GHC.Types.Name
+import GHC.Types.Name.Set
import GHC.Types.Name.Env
+import GHC.Types.Unique.Map
import GHC.Utils.Outputable (text, sep, (<+>))
import GHC.Types.SrcLoc
import GHC.Core.TyCon
@@ -43,30 +60,86 @@ import GHC.Core.TyCo.Rep
import GHC.Builtin.Types( unrestrictedFunTyConName )
import GHC.Types.Var hiding (varName)
import GHC.HsToCore.Docs
+import GHC.Driver.Env.Types
+import GHC.Unit.Env
+import GHC.Core.Coercion.Axiom
+import GHC.Tc.Utils.Monad
+import GHC.Tc.Utils.Env
+import GHC.Tc.Instance.Family
+import GHC.Iface.Load
+import GHC.Core.TyCo.Compare (eqType)
+import GHC.Core.Coercion
type ExportedNames = Set.Set Name
type Modules = Set.Set Module
type ExportInfo = (ExportedNames, Modules)
-- Also attaches fixities
-attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> ModuleSet -> Ghc [Interface]
-attachInstances expInfo ifaces instIfaceMap mods = do
- (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces) mods'
- mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces
+attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]
+attachInstances expInfo ifaces instIfaceMap = do
+
+ -- We need to keep load modules in which we will look for instances. We've
+ -- somewhat arbitrarily decided to load all modules which are available -
+ -- either directly or from a re-export.
+ --
+ -- See https://github.com/haskell/haddock/issues/469.
+ env <- getSession
+ let mod_to_pkg_conf = moduleNameProvidersMap $ ue_units $ hsc_unit_env env
+ mods = mkModuleSet [ m
+ | mod_map <- nonDetEltsUniqMap mod_to_pkg_conf
+ , ( m
+ , ModOrigin { fromOrigUnit = fromOrig
+ , fromExposedReexport = reExp
+ }
+ ) <- nonDetUniqMapToList mod_map
+ , fromOrig == Just True || not (null reExp)
+ ]
+ mods_to_load = moduleSetElts mods
+ mods_visible = mkModuleSet $ map ifaceMod ifaces
+
+ (_msgs, mb_index) <- do
+ hsc_env <- getSession
+ liftIO $ runTcInteractive hsc_env $ do
+ let doc = text "Need interface for haddock"
+ initIfaceTcRn $ mapM_ (loadSysInterface doc) mods_to_load
+ cls_env@InstEnvs{ie_global, ie_local} <- tcGetInstEnvs
+ fam_env@(pkg_fie, home_fie) <- tcGetFamInstEnvs
+ -- We use Data.Sequence.Seq because we are creating left associated
+ -- mappends.
+ -- cls_index and fam_index below are adapted from GHC.Tc.Module.lookupInsts
+ let cls_index = Map.fromListWith mappend
+ [ (n, Seq.singleton ispec)
+ | ispec <- instEnvElts ie_local ++ instEnvElts ie_global
+ , instIsVisible mods_visible ispec
+ , n <- nameSetElemsStable $ orphNamesOfClsInst ispec
+ ]
+ fam_index = Map.fromListWith mappend
+ [ (n, Seq.singleton fispec)
+ | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
+ , n <- nameSetElemsStable $ orphNamesOfFamInst fispec
+ ]
+ instance_map = mkNameEnv $
+ [ (nm, (toList clss, toList fams))
+ | (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend
+ (fmap (,Seq.empty) cls_index)
+ (fmap (Seq.empty,) fam_index)
+ ]
+ pure $ (cls_env{ie_visible = mods_visible}, fam_env, instance_map)
+
+ let empty_index = (InstEnvs emptyInstEnv emptyInstEnv mods_visible, emptyFamInstEnvs, emptyNameEnv)
+ mapM (attach $ fromMaybe empty_index mb_index) ifaces
where
- mods' = Just (moduleSetElts mods)
-
-- TODO: take an IfaceMap as input
ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]
- attach index iface = do
+ attach (cls_insts, fam_insts, inst_map) iface = do
let getInstDoc = findInstDoc iface ifaceMap instIfaceMap
getFixity = findFixity iface ifaceMap instIfaceMap
- newItems <- mapM (attachToExportItem index expInfo getInstDoc getFixity)
+ newItems <- mapM (attachToExportItem cls_insts fam_insts inst_map expInfo getInstDoc getFixity)
(ifaceExportItems iface)
- let orphanInstances = attachOrphanInstances expInfo getInstDoc (ifaceInstances iface)
+ let orphanInstances = attachOrphanInstances expInfo getInstDoc (ifaceInstances iface) fam_insts
return $ iface { ifaceExportItems = newItems
, ifaceOrphanInstances = orphanInstances
}
@@ -75,50 +148,61 @@ attachOrphanInstances
:: ExportInfo
-> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance
-> [ClsInst] -- ^ a list of orphan instances
+ -> FamInstEnvs -- ^ all the family instances (that we know of)
-> [DocInstance GhcRn]
-attachOrphanInstances expInfo getInstDoc cls_instances =
- [ (synifyInstHead i, getInstDoc n, (L (getSrcSpan n) n), Nothing)
+attachOrphanInstances expInfo getInstDoc cls_instances fam_index =
+ [ (synifyInstHead i famInsts, getInstDoc n, (L (getSrcSpan n) n), nameModule_maybe n)
| let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
- , not $ isInstanceHidden expInfo cls tys
+ , not $ isInstanceHidden expInfo (getName cls) tys
+ , let famInsts = getFamInsts expInfo fam_index getInstDoc cls tys
]
-
attachToExportItem
- :: NameEnv ([ClsInst], [FamInst]) -- ^ all instances (that we know of)
+ :: InstEnvs -- ^ all class instances (that we know of)
+ -> FamInstEnvs -- ^ all the family instances (that we know of)
+ -> NameEnv ([ClsInst], [FamInst]) -- ^ all instances again, but for looking up instances for data families
-> ExportInfo
-> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance
-> (Name -> Maybe Fixity) -- ^ how to lookup a fixity
-> ExportItem GhcRn
-> Ghc (ExportItem GhcRn)
-attachToExportItem index expInfo getInstDoc getFixity export =
+attachToExportItem cls_index fam_index index expInfo getInstDoc getFixity export =
case attachFixities export of
- e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do
+ ExportDecl e@(ExportD { expDDecl = L eSpan (TyClD _ d) }) -> do
insts <-
- let mb_instances = lookupNameEnv index (tcdName d)
- cls_instances = maybeToList mb_instances >>= fst
- fam_instances = maybeToList mb_instances >>= snd
+ let nm = tcdName d
+ (cls_instances, fam_instances) = case d of
+ -- For type classes we can be more efficient by looking up the class in the inst map
+ ClassDecl{} -> (classNameInstances cls_index nm, familyNameInstances fam_index nm)
+ -- Otherwise, we have to filter through all the instances to see if they mention this
+ -- name. See GHCi :info implementation
+ _ -> fromMaybe ([],[]) $ lookupNameEnv index nm
+
fam_insts = [ ( synFamInst
, getInstDoc n
, spanNameE n synFamInst (L (locA eSpan) (tcdName d))
- , nameModule_maybe n
+ , mb_mdl
)
| i <- sortBy (comparing instFam) fam_instances
, let n = getName i
, not $ isNameHidden expInfo (fi_fam i)
, not $ any (isTypeHidden expInfo) (fi_tys i)
, let opaque = isTypeHidden expInfo (fi_rhs i)
- , let synFamInst = synifyFamInst i opaque
+ synFamInst = synifyFamInst i opaque
+ !mb_mdl = force $ nameModule_maybe n
]
cls_insts = [ ( synClsInst
, getInstDoc n
, spanName n synClsInst (L (locA eSpan) (tcdName d))
- , nameModule_maybe n
+ , mb_mdl
)
| let is = [ (instanceSig i, getName i) | i <- cls_instances ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
- , not $ isInstanceHidden expInfo cls tys
- , let synClsInst = synifyInstHead i
+ , not $ isInstanceHidden expInfo (getName cls) tys
+ , let synClsInst = synifyInstHead i famInsts
+ famInsts = getFamInsts expInfo fam_index getInstDoc cls tys
+ !mb_mdl = force $ nameModule_maybe n
]
-- fam_insts but with failing type fams filtered out
cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ]
@@ -127,22 +211,39 @@ attachToExportItem index expInfo getInstDoc getFixity export =
let mkBug = (text "haddock-bug:" <+>) . text
putMsgM (sep $ map mkBug famInstErrs)
return $ cls_insts ++ cleanFamInsts
- return $ e { expItemInstances = insts }
+ return $ ExportDecl e { expDInstances = insts }
e -> return e
where
- attachFixities e@ExportDecl{ expItemDecl = L _ d
- , expItemPats = patsyns
- , expItemSubDocs = subDocs
- } = e { expItemFixities =
- nubByName fst $ expItemFixities e ++
- [ (n',f) | n <- getMainDeclBinder emptyOccEnv d
- , n' <- n : (map fst subDocs ++ patsyn_names)
- , f <- maybeToList (getFixity n')
- ] }
+ attachFixities
+ ( ExportDecl
+ ( e@ExportD
+ { expDDecl = L _ d
+ , expDPats = patsyns
+ , expDSubDocs = subDocs
+ }
+ )
+ )
+ = ExportDecl e
+ { expDFixities = fixities
+ }
where
+ fixities :: [(Name, Fixity)]
+ !fixities = force . Map.toList $ foldl' f Map.empty all_names
+
+ f :: Map.Map Name Fixity -> Name -> Map.Map Name Fixity
+ f !fs n = Map.alter (<|> getFixity n) n fs
+
+ patsyn_names :: [Name]
patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns
+ all_names :: [Name]
+ all_names =
+ getMainDeclBinder emptyOccEnv d
+ ++ map fst subDocs
+ ++ patsyn_names
+
attachFixities e = e
+
-- spanName: attach the location to the name that is the same file as the instance location
spanName s (InstHead { ihdClsName = clsn }) (L instL instn) =
let s1 = getSrcSpan s
@@ -156,6 +257,44 @@ attachToExportItem index expInfo getInstDoc getFixity export =
let L l r = spanName s ok linst
in L l (Right r)
+substAgrees :: [(TyVar,Type)] -> [(TyVar,Type)] -> Bool
+substAgrees xs ys = go xs
+ where
+ go [] = True
+ go ((v,t1) : zs) = case lookup v ys of
+ Nothing -> go zs
+ Just t2 -> eqType t1 t2 && go zs
+
+getFamInsts
+ :: ExportInfo
+ -> FamInstEnvs -- ^ all the family instances (that we know of)
+ -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance
+ -> Class -> [Type]
+ -> [(FamInst, Bool, Maybe (MDoc Name), Located Name, Maybe Module)]
+getFamInsts expInfo fam_index getInstDoc cls tys =
+ [ (f_i, opaque, getInstDoc f_n, L (getSrcSpan f_n) f_n, nameModule_maybe f_n)
+ | fam <- classATs cls
+ , let vars = tyConTyVars fam
+ tv_env = zip (classTyVars cls) tys
+ m_instantiation = mapM (\v -> lookup v tv_env) vars
+ , f_i <- case m_instantiation of
+ -- If we have a complete instantation, we can just lookup in the family environment
+ Just instantiation -> map fim_instance $ lookupFamInstEnv fam_index fam instantiation
+ -- If we don't have a complete instantation, we need to look over all possible instances
+ -- for the family and filter out the ones that don't agree with the typeclass instance
+ Nothing -> [ f_i
+ | f_i <- familyInstances fam_index fam
+ , let co_tvs = tyConTyVars fam
+ (_, lhs, _) = etaExpandCoAxBranch $ coAxiomSingleBranch $ fi_axiom f_i
+ , substAgrees (zip co_tvs lhs) tv_env
+ ]
+ , let ax = fi_axiom f_i
+ f_n = co_ax_name ax
+ , not $ isNameHidden expInfo (fi_fam f_i)
+ , not $ any (isTypeHidden expInfo) (fi_tys f_i)
+ , let opaque = isTypeHidden expInfo (fi_rhs f_i)
+ ]
+
-- | Lookup the doc associated with a certain instance
findInstDoc :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe (MDoc Name)
findInstDoc iface ifaceMap instIfaceMap = \name ->
@@ -175,27 +314,6 @@ findFixity iface ifaceMap instIfaceMap = \name ->
-- Collecting and sorting instances
--------------------------------------------------------------------------------
--- | Stable name for stable comparisons. GHC's `Name` uses unstable
--- ordering based on their `Unique`'s.
-newtype SName = SName Name
-
-instance Eq SName where
- SName n1 == SName n2 = n1 `stableNameCmp` n2 == EQ
-
-instance Ord SName where
- SName n1 `compare` SName n2 = n1 `stableNameCmp` n2
-
--- | Simplified type for sorting types, ignoring qualification (not visible
--- in Haddock output) and unifying special tycons with normal ones.
--- For the benefit of the user (looks nice and predictable) and the
--- tests (which prefer output to be deterministic).
-data SimpleType = SimpleType SName [SimpleType]
- | SimpleIntTyLit Integer
- | SimpleStringTyLit String
- | SimpleCharTyLit Char
- deriving (Eq,Ord)
-
-
instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], SName, [SimpleType])
instHead (_, _, cls, args)
= (map argCount args, SName (className cls), map simplify args)
@@ -248,30 +366,21 @@ isNameHidden (names, modules) name =
-- | We say that an instance is «hidden» iff its class or any (part)
-- of its type(s) is hidden.
-isInstanceHidden :: ExportInfo -> Class -> [Type] -> Bool
-isInstanceHidden expInfo cls tys =
+isInstanceHidden :: ExportInfo -> Name -> [Type] -> Bool
+isInstanceHidden expInfo cls tyNames =
instClassHidden || instTypeHidden
where
instClassHidden :: Bool
- instClassHidden = isNameHidden expInfo $ getName cls
+ instClassHidden = isNameHidden expInfo cls
instTypeHidden :: Bool
- instTypeHidden = any (isTypeHidden expInfo) tys
+ instTypeHidden = any (isTypeHidden expInfo) tyNames
isTypeHidden :: ExportInfo -> Type -> Bool
isTypeHidden expInfo = typeHidden
where
typeHidden :: Type -> Bool
- typeHidden t =
- case t of
- TyVarTy {} -> False
- AppTy t1 t2 -> typeHidden t1 || typeHidden t2
- FunTy _ _ t1 t2 -> typeHidden t1 || typeHidden t2
- TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args
- ForAllTy bndr ty -> typeHidden (tyVarKind (binderVar bndr)) || typeHidden ty
- LitTy _ -> False
- CastTy ty _ -> typeHidden ty
- CoercionTy {} -> False
+ typeHidden t = any nameHidden $ typeNames t
nameHidden :: Name -> Bool
nameHidden = isNameHidden expInfo
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index d6c7bb6972..9571dea652 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
@@ -9,6 +10,7 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wwarn #-}
@@ -30,121 +32,60 @@
-----------------------------------------------------------------------------
module Haddock.Interface.Create (IfM, runIfM, createInterface1) where
-import Documentation.Haddock.Doc (metaDocAppend)
import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl)
-import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes,
- mkEmptySigType, moduleString, parents,
- pretty, restrictTo, sigName, unL)
+import Haddock.GhcUtils
import Haddock.Interface.LexParseRn
import Haddock.Options (Flag (..), modulePackageInfo)
-import Haddock.Types hiding (liftErrMsg)
+import Haddock.Types
import Haddock.Utils (replace)
+import Documentation.Haddock.Doc
-import Control.Applicative ((<|>))
-import Control.Monad.Reader (MonadReader (..), ReaderT, asks, runReaderT)
-import Control.Monad.Writer.Strict hiding (tell)
-import Data.Bitraversable (bitraverse)
-import Data.Foldable (toList)
-import Data.List (find, foldl')
-import qualified Data.IntMap as IM
+import Control.DeepSeq
+import Control.Monad.State.Strict
+import Data.Foldable
import Data.IntMap (IntMap)
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe, maybeToList)
+import qualified Data.IntMap as IM
+import qualified Data.List.NonEmpty as NE
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (catMaybes, isJust, mapMaybe, maybeToList)
import Data.Traversable (for)
import GHC hiding (lookupName)
-import GHC.Core.Class (ClassMinimalDef, classMinimalDef)
+import qualified GHC.Types.Unique.Map as UniqMap
import GHC.Core.ConLike (ConLike (..))
-import GHC.Data.FastString (unpackFS)
-import GHC.Driver.Ppr (showSDoc)
-import GHC.HsToCore.Docs hiding (mkMaps, unionArgMaps)
-import GHC.IORef (readIORef)
-import GHC.Stack (HasCallStack)
-import GHC.Tc.Types hiding (IfM)
-import GHC.Tc.Utils.Monad (finalSafeMode)
+import GHC.Data.FastString (unpackFS, bytesFS)
+import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Types.Avail
-import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName,
- nameIsLocalOrFrom, nameOccName, emptyOccEnv)
-import GHC.Types.Name.Env (lookupNameEnv)
-import GHC.Types.Name.Reader (GlobalRdrEnv, FieldsOrSelectors(..), WhichGREs(..),
- greName, lookupGRE_OccName)
-import GHC.Types.Name.Set (elemNameSet, mkNameSet)
-import GHC.Types.SourceFile (HscSource (..))
-import GHC.Types.SourceText (SourceText (..), sl_fs)
-import GHC.Unit.Types
+import GHC.Types.Basic
+import GHC.Types.Name
+import GHC.Types.Name.Set
import qualified GHC.Types.SrcLoc as SrcLoc
-import qualified GHC.Unit.Module as Module
-import GHC.Unit.Module.ModSummary (msHsFilePath)
-import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits)
+import GHC.Unit.State (PackageName (..), UnitState)
import qualified GHC.Utils.Outputable as O
import GHC.Utils.Panic (pprPanic)
import GHC.Unit.Module.Warnings
-import GHC.Types.Unique.Map
-
-newtype IfEnv m = IfEnv
- {
- -- | Lookup names in the environment.
- ife_lookup_name :: Name -> m (Maybe TyThing)
- }
-
-
--- | A monad in which we create Haddock interfaces. Not to be confused with
--- `GHC.Tc.Types.IfM` which is used to write GHC interfaces.
---
--- In the past `createInterface` was running in the `Ghc` monad but proved hard
--- to sustain as soon as we moved over for Haddock to be a plugin. Also abstracting
--- over the Ghc specific clarifies where side effects happen.
-newtype IfM m a = IfM { unIfM :: ReaderT (IfEnv m) (WriterT [ErrMsg] m) a }
-
-
-deriving newtype instance Functor m => Functor (IfM m)
-deriving newtype instance Applicative m => Applicative (IfM m)
-deriving newtype instance Monad m => Monad (IfM m)
-deriving newtype instance MonadIO m => MonadIO (IfM m)
-deriving newtype instance Monad m => MonadReader (IfEnv m) (IfM m)
-deriving newtype instance Monad m => MonadWriter [ErrMsg] (IfM m)
-
-
--- | Run an `IfM` action.
-runIfM
- -- | Lookup a global name in the current session. Used in cases
- -- where declarations don't
- :: (Name -> m (Maybe TyThing))
- -- | The action to run.
- -> IfM m a
- -- | Result and accumulated error/warning messages.
- -> m (a, [ErrMsg])
-runIfM lookup_name action = do
- let
- if_env = IfEnv
- {
- ife_lookup_name = lookup_name
- }
- runWriterT (runReaderT (unIfM action) if_env)
-
-
-liftErrMsg :: Monad m => ErrMsgM a -> IfM m a
-liftErrMsg action = do
- writer (runWriter action)
-
-
-lookupName :: Monad m => Name -> IfM m (Maybe TyThing)
-lookupName name = IfM $ do
- lookup_name <- asks ife_lookup_name
- lift $ lift (lookup_name name)
-
+import GHC.Driver.Ppr
+import GHC.Unit.Module.ModIface
+import GHC.Builtin.Names
+import GHC.Builtin.Types
+import GHC.Builtin.Types.Prim
+import GHC.Types.SafeHaskell
+import Control.Arrow ((&&&))
+import GHC.Iface.Syntax
+import GHC.Types.SourceText
createInterface1
:: MonadIO m
=> [Flag]
-> UnitState
-> ModSummary
- -> TcGblEnv
+ -> ModIface
-> IfaceMap
-> InstIfaceMap
+ -> ([ClsInst],[FamInst])
-> IfM m Interface
-createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
+createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instances, fam_instances) = do
let
ModSummary
@@ -159,32 +100,14 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
}
} = mod_sum
- TcGblEnv
- {
- tcg_mod
- , tcg_src
- , tcg_semantic_mod
- , tcg_rdr_env
- , tcg_exports
- , tcg_insts
- , tcg_fam_insts
- , tcg_warns
-
- -- Renamed source
- , tcg_rn_imports
- , tcg_rn_exports
- , tcg_rn_decls
-
- , tcg_th_docs
- , tcg_doc_hdr
- } = tc_gbl_env
-
- dflags = ms_hspp_opts
-
- is_sig = tcg_src == HsigFile
+ dflags = ms_hspp_opts
+ mdl = mi_module mod_iface
+ sem_mdl = mi_semantic_module mod_iface
+ is_sig = isJust (mi_sig_of mod_iface)
+ safety = getSafeMode (mi_trust mod_iface)
(pkg_name_fs, _) =
- modulePackageInfo unit_state flags (Just tcg_mod)
+ modulePackageInfo unit_state flags (Just mdl)
pkg_name :: Maybe Package
pkg_name =
@@ -193,258 +116,217 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
in
fmap unpack pkg_name_fs
- fixities :: FixMap
- fixities = case tcg_rn_decls of
- Nothing -> mempty
- Just dx -> mkFixMap dx
+ warnings = mi_warns mod_iface
- -- Locations of all the TH splices
- loc_splices :: [SrcSpan]
- loc_splices = case tcg_rn_decls of
- Nothing -> []
- Just HsGroup { hs_splcds } -> [ locA loc | L loc _ <- hs_splcds ]
+ -- See Note [Exporting built-in items]
+ special_exports
+ | mdl == gHC_TYPES = listAvail <> eqAvail
+ | mdl == gHC_PRIM = funAvail
+ | mdl == pRELUDE = listAvail <> funAvail
+ | mdl == dataTupleModule = tupsAvail
+ | mdl == dataListModule = listAvail
+ | otherwise = []
+ !exportedNames = concatMap availNames
+ (special_exports <> mi_exports mod_iface)
- decls <- case tcg_rn_decls of
- Nothing -> do
- tell [ "Warning: Renamed source is not available" ]
- pure []
- Just dx ->
- pure (topDecls dx)
+ fixities :: FixMap
+ fixities = mkFixMap exportedNames (mi_fixities mod_iface)
+
+ -- This is used for looking up the Name of a default method
+ -- from its OccName. See Note [default method Name] in GHC.Iface.Recomp
+ def_meths_env = mkOccEnv def_meths
+ def_meths = [ (nameOccName nm, nm)
+ | (_, IfaceId { ifName = nm }) <- mi_decls mod_iface
+ , let occ = nameOccName nm
+ , isDefaultMethodOcc occ
+ ]
+ mod_iface_docs <- case mi_docs mod_iface of
+ Just docs -> pure docs
+ Nothing -> do
+ warn $ showPpr dflags mdl ++ " has no docs in its .hi file"
+ pure emptyDocs
-- Derive final options to use for haddocking this module
- doc_opts <- liftErrMsg $ mkDocOpts (haddockOptions ms_hspp_opts) flags tcg_mod
-
- let
- -- All elements of an explicit export list, if present
- export_list :: Maybe [(IE GhcRn, Avails)]
- export_list
- | OptIgnoreExports `elem` doc_opts =
- Nothing
- | Just rn_exports <- tcg_rn_exports =
- Just [ (ie, avail) | (L _ ie, avail) <- rn_exports ]
- | otherwise =
- Nothing
-
- -- All the exported Names of this module.
- exported_names :: [Name]
- exported_names =
- concatMap availNames tcg_exports
-
- -- Module imports of the form `import X`. Note that there is
- -- a) no qualification and
- -- b) no import list
- imported_modules :: Map ModuleName [ModuleName]
- imported_modules
- | Just{} <- export_list =
- unrestrictedModuleImports (map unLoc tcg_rn_imports)
- | otherwise =
- M.empty
-
- -- TyThings that have instances defined in this module
- local_instances :: [Name]
- local_instances =
- [ name
- | name <- map getName tcg_insts ++ map getName tcg_fam_insts
- , nameIsLocalOrFrom tcg_semantic_mod name
- ]
-
- -- Infer module safety
- safety <- liftIO (finalSafeMode ms_hspp_opts tc_gbl_env)
-
- -- The docs added via Template Haskell's putDoc
- thDocs@ExtractedTHDocs { ethd_mod_header = thMbDocStr } <-
- liftIO $ extractTHDocs <$> readIORef tcg_th_docs
-
- -- Process the top-level module header documentation.
- (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name
- tcg_rdr_env safety (fmap hsDocString thMbDocStr <|> (hsDocString . unLoc <$> tcg_doc_hdr))
-
- -- Warnings on declarations in this module
- decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names)
-
- -- Warning on the module header
- mod_warning <- liftErrMsg (moduleWarning dflags tcg_rdr_env tcg_warns)
+ doc_opts <- mkDocOpts (docs_haddock_opts mod_iface_docs) flags mdl
+
+ let prr | OptPrintRuntimeRep `elem` doc_opts = ShowRuntimeRep
+ | otherwise = HideRuntimeRep
+
+ (!info, header_doc) <-
+ processModuleHeader dflags pkg_name safety
+ (docs_language mod_iface_docs)
+ (docs_extensions mod_iface_docs)
+ (docs_mod_hdr mod_iface_docs)
+ mod_warning <- moduleWarning dflags warnings
+
+ (docMap :: DocMap Name) <- do
+ let docsDecls = Map.fromList $ UniqMap.nonDetUniqMapToList mod_iface_docs.docs_decls
+ traverse (processDocStringsParas dflags pkg_name) docsDecls
+
+ (argMap :: Map Name (Map Int (MDoc Name))) <- do
+ let docsArgs = Map.fromList $ UniqMap.nonDetUniqMapToList mod_iface_docs.docs_args
+ (result :: Map Name (IntMap (MDoc Name))) <-
+ traverse (traverse (processDocStringParas dflags pkg_name)) docsArgs
+ let result2 = Map.map (\intMap -> Map.fromList $ IM.assocs intMap) result
+ pure $ result2
+
+ warningMap <- mkWarningMap dflags warnings exportedNames
+
+ let local_instances = filter (nameIsLocalOrFrom sem_mdl)
+ $ map getName instances
+ ++ map getName fam_instances
+ instanceMap = Map.fromList [(l, n) | n <- local_instances, RealSrcSpan l _ <- [getSrcSpan n] ]
+
+ -- See Note [Exporting built-in items]
+ let builtinTys = DsiSectionHeading 1 (WithHsDocIdentifiers (mkGeneratedHsDocString "Builtin syntax") [])
+ bonus_ds mods
+ | mdl == gHC_TYPES = [ DsiExports (listAvail <> eqAvail) ] <> mods
+ | mdl == gHC_PRIM = [ builtinTys, DsiExports funAvail ] <> mods
+ | mdl == pRELUDE = let (hs, rest) = splitAt 2 mods
+ in hs <> [ DsiExports (listAvail <> funAvail) ] <> rest
+ | mdl == dataTupleModule = mods <> [ DsiExports tupsAvail ]
+ | mdl == dataListModule = [ DsiExports listAvail ] <> mods
+ | otherwise = mods
let
-- Warnings in this module and transitive warnings from dependent modules
- warnings :: Map Name (Doc Name)
- warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces))
-
- maps@(!docs, !arg_docs, !decl_map, _) <-
- liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls thDocs)
-
- export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod
- warnings tcg_rdr_env exported_names (map fst decls) maps fixities
- imported_modules loc_splices export_list tcg_exports inst_ifaces dflags
+ transitiveWarnings :: Map Name (Doc Name)
+ transitiveWarnings = Map.unions (warningMap : map ifaceWarningMap (Map.elems ifaces))
+
+ export_items <- mkExportItems
+ prr
+ ifaces
+ pkg_name
+ mdl
+ transitiveWarnings
+ docMap
+ argMap
+ fixities
+ (docs_named_chunks mod_iface_docs)
+ (bonus_ds $ docs_structure mod_iface_docs)
+ inst_ifaces
+ dflags
+ def_meths_env
let
visible_names :: [Name]
- visible_names = mkVisibleNames maps export_items doc_opts
+ visible_names = mkVisibleNames instanceMap export_items doc_opts
-- Measure haddock documentation coverage.
pruned_export_items :: [ExportItem GhcRn]
pruned_export_items = pruneExportItems export_items
!haddockable = 1 + length export_items -- module + exports
- !haddocked = (if isJust tcg_doc_hdr then 1 else 0) + length pruned_export_items
+ !haddocked = (if isJust header_doc then 1 else 0) + length pruned_export_items
coverage :: (Int, Int)
!coverage = (haddockable, haddocked)
- aliases :: Map Module ModuleName
- aliases = mkAliasMap unit_state tcg_rn_imports
-
return $! Interface
{
- ifaceMod = tcg_mod
+ ifaceMod = mdl
, ifaceIsSig = is_sig
- , ifaceOrigFilename = msHsFilePath mod_sum
- , ifaceHieFile = Just ml_hie_file
+ , ifaceHieFile = ml_hie_file
, ifaceInfo = info
, ifaceDoc = Documentation header_doc mod_warning
, ifaceRnDoc = Documentation Nothing Nothing
, ifaceOptions = doc_opts
- , ifaceDocMap = docs
- , ifaceArgMap = arg_docs
- , ifaceRnDocMap = M.empty
- , ifaceRnArgMap = M.empty
+ , ifaceDocMap = docMap
+ , ifaceArgMap = argMap
, ifaceExportItems = if OptPrune `elem` doc_opts then
pruned_export_items else export_items
, ifaceRnExportItems = []
- , ifaceExports = exported_names
+ , ifaceExports = exportedNames
, ifaceVisibleExports = visible_names
- , ifaceDeclMap = decl_map
, ifaceFixMap = fixities
- , ifaceModuleAliases = aliases
- , ifaceInstances = tcg_insts
- , ifaceFamInstances = tcg_fam_insts
+ , ifaceInstances = instances
, ifaceOrphanInstances = [] -- Filled in attachInstances
- , ifaceRnOrphanInstances = [] -- Filled in attachInstances
+ , ifaceRnOrphanInstances = [] -- Filled in renameInterfaceRn
, ifaceHaddockCoverage = coverage
- , ifaceWarningMap = warnings
+ , ifaceWarningMap = warningMap
, ifaceDynFlags = dflags
+ , ifaceDefMeths = def_meths
}
-
-
--- | Given all of the @import M as N@ declarations in a package,
--- create a mapping from the module identity of M, to an alias N
--- (if there are multiple aliases, we pick the last one.) This
--- will go in 'ifaceModuleAliases'.
-mkAliasMap :: UnitState -> [LImportDecl GhcRn] -> M.Map Module ModuleName
-mkAliasMap state impDecls =
- M.fromList $
- mapMaybe (\(SrcLoc.L _ impDecl) -> do
- SrcLoc.L _ alias <- ideclAs impDecl
- return
- (lookupModuleDyn state
- -- TODO: This is supremely dodgy, because in general the
- -- UnitId isn't going to look anything like the package
- -- qualifier (even with old versions of GHC, the
- -- IPID would be p-0.1, but a package qualifier never
- -- has a version number it. (Is it possible that in
- -- Haddock-land, the UnitIds never have version numbers?
- -- I, ezyang, have not quite understand Haddock's package
- -- identifier model.)
- --
- -- Additionally, this is simulating some logic GHC already
- -- has for deciding how to qualify names when it outputs
- -- them to the user. We should reuse that information;
- -- or at least reuse the renamed imports, which know what
- -- they import!
- (ideclPkgQual impDecl)
- (case ideclName impDecl of SrcLoc.L _ name -> name),
- alias))
- impDecls
-
--- We want to know which modules are imported without any qualification. This
--- way we can display module reexports more compactly. This mapping also looks
--- through aliases:
---
--- module M (module X) where
--- import M1 as X
--- import M2 as X
---
--- With our mapping we know that we can display exported modules M1 and M2.
---
-unrestrictedModuleImports :: [ImportDecl GhcRn] -> M.Map ModuleName [ModuleName]
-unrestrictedModuleImports idecls =
- M.map (map (unLoc . ideclName))
- $ M.filter (all isInteresting) impModMap
where
- impModMap =
- M.fromListWith (++) (concatMap moduleMapping idecls)
-
- moduleMapping idecl =
- concat [ [ (unLoc (ideclName idecl), [idecl]) ]
- , [ (unLoc mod_name, [idecl])
- | Just mod_name <- [ideclAs idecl]
- ]
- ]
-
- isInteresting idecl =
- case ideclImportList idecl of
- -- i) no subset selected
- Nothing -> True
- -- ii) an import with a hiding clause
- -- without any names
- Just (EverythingBut, L _ []) -> True
- -- iii) any other case of qualification
- _ -> False
-
--- Similar to GHC.lookupModule
--- ezyang: Not really...
-lookupModuleDyn ::
- UnitState -> PkgQual -> ModuleName -> Module
-lookupModuleDyn state pkg_qual mdlName = case pkg_qual of
- OtherPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName
- ThisPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName
- NoPkgQual -> case lookupModuleInAllUnits state mdlName of
- (m,_):_ -> m
- [] -> Module.mkModule Module.mainUnit mdlName
-
+ -- Note [Exporting built-in items]
+ --
+ -- Some items do not show up in their modules exports simply because Haskell
+ -- lacks the concrete syntax to represent such an export. We'd still like
+ -- these to show up in docs, so we manually patch on some extra exports for a
+ -- small number of modules:
+ --
+ -- * "GHC.Prim" should export @(->)@
+ -- * "GHC.Types" should export @[]([], (:))@ and @(~)@
+ -- * "Prelude" should export @(->)@ and @[]([], (:))@
+ -- * "Data.Tuple" should export tuples up to arity 15 (that is the number
+ -- that Haskell98 guarantees exist and that is also the point at which
+ -- GHC stops providing instances)
+ --
+ listAvail = [ AvailTC listTyConName
+ [listTyConName, nilDataConName, consDataConName] ]
+ funAvail = [ AvailTC fUNTyConName [fUNTyConName] ]
+ eqAvail = [ AvailTC eqTyConName [eqTyConName] ]
+ tupsAvail = [ AvailTC tyName [tyName, datName]
+ | i<-[0..15]
+ , let tyName = tupleTyConName BoxedTuple i
+ , let datName = getName $ tupleDataCon Boxed i
+ ]
-------------------------------------------------------------------------------
-- Warnings
-------------------------------------------------------------------------------
-mkWarningMap :: DynFlags -> Warnings a -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
-mkWarningMap dflags warnings gre exps = case warnings of
- NoWarnings -> pure M.empty
- WarnAll _ -> pure M.empty
- WarnSome ws ->
- let ws' = [ (n, w)
- | (occ, w) <- ws
- , elt <- lookupGRE_OccName (IncludeFields WantNormal) gre occ
- , let n = greName elt
- , n `elem` exps ]
- in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws'
-
-moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings a -> ErrMsgM (Maybe (Doc Name))
-moduleWarning _ _ NoWarnings = pure Nothing
-moduleWarning _ _ (WarnSome _) = pure Nothing
-moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w
-
-parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt a -> ErrMsgM (Doc Name)
-parseWarning dflags gre w = case w of
- DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg)
- WarningTxt _ _ msg -> format "Warning: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg)
+mkWarningMap
+ :: MonadIO m
+ => DynFlags
+ -> Warnings GhcRn
+ -> [Name]
+ -> IfM m WarningMap
+mkWarningMap dflags warnings exps =
+ case warnings of
+ WarnSome ws ->
+ let expsOccEnv = mkOccEnv [(nameOccName n, n) | n <- exps]
+ ws' = flip mapMaybe ws $ \(occ, w) ->
+ -- Ensure we also look in the record field namespace. If the OccName
+ -- resolves to multiple GREs, take the first.
+ case lookupOccEnv_WithFields expsOccEnv occ of
+ (n : _) -> Just (n, w)
+ [] -> Nothing
+ in Map.fromList <$> traverse (traverse (parseWarning dflags)) ws'
+ _ -> pure Map.empty
+
+moduleWarning
+ :: MonadIO m
+ => DynFlags
+ -> Warnings GhcRn
+ -> IfM m (Maybe (Doc Name))
+moduleWarning dflags (WarnAll w) = Just <$> parseWarning dflags w
+moduleWarning _ _ = pure Nothing
+
+parseWarning
+ :: MonadIO m
+ => DynFlags
+ -> WarningTxt GhcRn
+ -> IfM m (Doc Name)
+parseWarning dflags w = case w of
+ DeprecatedTxt _ msg -> format "Deprecated: " (map (dstToDoc . unLoc) msg)
+ WarningTxt _ _ msg -> format "Warning: " (map (dstToDoc . unLoc) msg)
where
+ dstToDoc (WithHsDocIdentifiers st ids) = WithHsDocIdentifiers (stToDoc st) ids
+ stToDoc (StringLiteral _ fs _) = GeneratedDocString $ HsDocStringChunk (bytesFS fs)
format x bs = DocWarning . DocParagraph . DocAppend (DocString x)
- <$> processDocStringFromString dflags gre bs
-
-
+ <$> foldrM (\doc rest -> docAppend <$> processDocString dflags doc <*> pure rest) DocEmpty bs
-------------------------------------------------------------------------------
-- Doc options
--
-- Haddock options that are embedded in the source file
-------------------------------------------------------------------------------
-
-mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption]
+mkDocOpts :: MonadIO m => Maybe String -> [Flag] -> Module -> IfM m [DocOption]
mkDocOpts mbOpts flags mdl = do
opts <- case mbOpts of
Just opts -> case words $ replace ',' ' ' opts of
- [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return []
+ [] -> warn "No option supplied to DOC_OPTION/doc_option" >> return []
xs -> fmap catMaybes (mapM parseOption xs)
Nothing -> return []
pure (foldl go opts flags)
@@ -455,168 +337,28 @@ mkDocOpts mbOpts flags mdl = do
go os m | m == Flag_HideModule mdlStr = OptHide : os
| m == Flag_ShowModule mdlStr = filter (/= OptHide) os
| m == Flag_ShowAllModules = filter (/= OptHide) os
- | m == Flag_IgnoreAllExports = OptIgnoreExports : os
- | m == Flag_ShowExtensions mdlStr = OptIgnoreExports : os
+ | m == Flag_ShowExtensions mdlStr = OptShowExtensions : os
| otherwise = os
-parseOption :: String -> ErrMsgM (Maybe DocOption)
-parseOption "hide" = return (Just OptHide)
-parseOption "prune" = return (Just OptPrune)
-parseOption "ignore-exports" = return (Just OptIgnoreExports)
-parseOption "not-home" = return (Just OptNotHome)
-parseOption "show-extensions" = return (Just OptShowExtensions)
-parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
-
-
---------------------------------------------------------------------------------
--- Maps
---------------------------------------------------------------------------------
-
-
-type Maps = (DocMap Name, ArgMap Name, DeclMap, InstMap)
-
--- | Create 'Maps' by looping through the declarations. For each declaration,
--- find its names, its subordinates, and its doc strings. Process doc strings
--- into 'Doc's.
-mkMaps :: DynFlags
- -> Maybe Package -- this package
- -> GlobalRdrEnv
- -> [Name]
- -> [(LHsDecl GhcRn, [HsDoc GhcRn])]
- -> ExtractedTHDocs -- ^ Template Haskell putDoc docs
- -> ErrMsgM Maps
-mkMaps dflags pkgName gre instances decls thDocs = do
- (a, b, c) <- unzip3 <$> traverse mappings decls
- (th_a, th_b) <- thMappings
- pure ( th_a `M.union` f' (map (nubByName fst) a)
- , fmap intmap2mapint $
- th_b `unionArgMaps` (f (filterMapping (not . IM.null) b))
- , f (filterMapping (not . null) c)
- , instanceMap
- )
- where
- f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
- f = M.fromListWith (<>) . concat
-
- f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name)
- f' = M.fromListWith metaDocAppend . concat
-
- filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]]
- filterMapping p = map (filter (p . snd))
-
- -- Convert IntMap -> IntMap
- -- TODO: should ArgMap eventually be switched over to IntMap?
- intmap2mapint = M.fromList . IM.toList
-
- -- | Extract the mappings from template haskell.
- -- No DeclMap/InstMap is needed since we already have access to the
- -- doc strings
- thMappings :: ErrMsgM (Map Name (MDoc Name), Map Name (IntMap (MDoc Name)))
- thMappings = do
- let ExtractedTHDocs
- _
- declDocs
- argDocs
- instDocs = thDocs
- ds2mdoc :: (HsDoc GhcRn) -> ErrMsgM (MDoc Name)
- ds2mdoc = processDocStringParas dflags pkgName gre . hsDocString
-
- let cvt = M.fromList . nonDetUniqMapToList
-
- declDocs' <- mapM ds2mdoc (cvt declDocs)
- argDocs' <- mapM (mapM ds2mdoc) (cvt argDocs)
- instDocs' <- mapM ds2mdoc (cvt instDocs)
- return (declDocs' <> instDocs', argDocs')
-
-
- mappings :: (LHsDecl GhcRn, [HsDoc GhcRn])
- -> ErrMsgM ( [(Name, MDoc Name)]
- , [(Name, IntMap (MDoc Name))]
- , [(Name, [LHsDecl GhcRn])]
- )
- mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), hs_docStrs) = do
- let docStrs = map hsDocString hs_docStrs
- declDoc :: [HsDocString] -> IntMap HsDocString
- -> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name))
- declDoc strs m = do
- doc' <- processDocStrings dflags pkgName gre strs
- m' <- traverse (processDocStringParas dflags pkgName gre) m
- pure (doc', m')
-
- (doc, args) <- declDoc docStrs (fmap hsDocString (declTypeDocs decl))
-
- let
- subs :: [(Name, [HsDocString], IntMap HsDocString)]
- subs = map (\(n, ds, im) -> (n, map hsDocString ds, fmap hsDocString im))
- $ subordinates emptyOccEnv instanceMap decl
-
- (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs
-
- let
- ns = names l decl
- subNs = [ n | (n, _, _) <- subs ]
- dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
- am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
- cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
-
- seqList ns `seq`
- seqList subNs `seq`
- doc `seq`
- seqList subDocs `seq`
- seqList subArgs `seq`
- pure (dm, am, cm)
- mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = pure ([], [], [])
-
- instanceMap :: Map RealSrcSpan Name
- instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ]
-
- names :: RealSrcSpan -> HsDecl GhcRn -> [Name]
- names _ (InstD _ d) = maybeToList (SrcLoc.lookupSrcSpan loc instanceMap) -- See note [2].
- where loc = case d of
- -- The CoAx's loc is the whole line, but only for TFs. The
- -- workaround is to dig into the family instance declaration and
- -- get the identifier with the right location.
- TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d')
- _ -> getInstLoc d
- names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
- names _ decl = getMainDeclBinder emptyOccEnv decl
-
--- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two
--- maps with values for the same key merge the inner map as well.
--- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.
-
-unionArgMaps :: forall b . Map Name (IntMap b)
- -> Map Name (IntMap b)
- -> Map Name (IntMap b)
-unionArgMaps a b = M.foldrWithKey go b a
- where
- go :: Name -> IntMap b
- -> Map Name (IntMap b) -> Map Name (IntMap b)
- go n newArgMap acc
- | Just oldArgMap <- M.lookup n acc =
- M.insert n (newArgMap `IM.union` oldArgMap) acc
- | otherwise = M.insert n newArgMap acc
-
--- Note [2]:
-------------
--- We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried
--- inside them. That should work for normal user-written instances (from
--- looking at GHC sources). We can assume that commented instances are
--- user-written. This lets us relate Names (from ClsInsts) to comments
--- (associated with InstDecls and DerivDecls).
+parseOption :: MonadIO m => String -> IfM m (Maybe DocOption)
+parseOption "hide" = return (Just OptHide)
+parseOption "prune" = return (Just OptPrune)
+parseOption "not-home" = return (Just OptNotHome)
+parseOption "show-extensions" = return (Just OptShowExtensions)
+parseOption "print-explicit-runtime-reps" = return (Just OptPrintRuntimeRep)
+parseOption other = warn ("Unrecognised option: " ++ other) >> return Nothing
--------------------------------------------------------------------------------
-- Declarations
--------------------------------------------------------------------------------
-
-
-- | Extract a map of fixity declarations only
-mkFixMap :: HsGroup GhcRn -> FixMap
-mkFixMap group_ =
- M.fromList [ (n,f)
- | L _ (FixitySig _ ns f) <- hsGroupTopLevelFixitySigs group_,
- L _ n <- ns ]
+mkFixMap :: [Name] -> [(OccName, Fixity)] -> FixMap
+mkFixMap exps occFixs =
+ Map.fromList $ flip mapMaybe occFixs $ \(occ, fix_) ->
+ (,fix_) <$> lookupOccEnv expsOccEnv occ
+ where
+ expsOccEnv = mkOccEnv (map (nameOccName &&& id) exps)
-- | Build the list of items that will become the documentation, from the
@@ -626,171 +368,161 @@ mkFixMap group_ =
-- We create the export items even if the module is hidden, since they
-- might be useful when creating the export items for other modules.
mkExportItems
- :: Monad m
- => Bool -- is it a signature
+ :: MonadIO m
+ => PrintRuntimeReps
-> IfaceMap
-> Maybe Package -- this package
-> Module -- this module
- -> Module -- semantic module
-> WarningMap
- -> GlobalRdrEnv
- -> [Name] -- exported names (orig)
- -> [LHsDecl GhcRn] -- renamed source declarations
- -> Maps
+ -> DocMap Name
+ -> ArgMap Name
-> FixMap
- -> M.Map ModuleName [ModuleName]
- -> [SrcSpan] -- splice locations
- -> Maybe [(IE GhcRn, Avails)]
- -> Avails -- exported stuff from this module
+ -> Map String (HsDoc GhcRn) -- named chunks
+ -> DocStructure
-> InstIfaceMap
-> DynFlags
+ -> OccEnv Name
-> IfM m [ExportItem GhcRn]
mkExportItems
- is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls
- maps fixMap unrestricted_imp_mods splices exportList allExports
- instIfaceMap dflags =
- case exportList of
- Nothing ->
- fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre
- exportedNames decls maps fixMap splices instIfaceMap dflags
- allExports
- Just exports -> fmap concat $ mapM lookupExport exports
+ prr modMap pkgName thisMod warnings docMap argMap fixMap namedChunks dsItems
+ instIfaceMap dflags defMeths =
+ concat <$> traverse lookupExport dsItems
where
- lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do
- doc <- processDocString dflags gre (hsDocString . unLoc $ docStr)
- return [ExportGroup lev "" doc]
-
- lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do
- doc <- processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr)
- return [ExportDoc doc]
-
- lookupExport (IEDocNamed _ str, _) = liftErrMsg $
- findNamedDoc str [ unL d | d <- decls ] >>= \case
- Nothing -> return []
- Just docStr -> do
- doc <- processDocStringParas dflags pkgName gre docStr
- return [ExportDoc doc]
-
- lookupExport (IEModuleContents _ (L _ mod_name), _)
- -- only consider exporting a module if we are sure we
- -- are really exporting the whole module and not some
- -- subset. We also look through module aliases here.
- | Just mods <- M.lookup mod_name unrestricted_imp_mods
- , not (null mods)
- = concat <$> traverse (moduleExport thisMod dflags modMap instIfaceMap) mods
-
- lookupExport (_, avails) =
- concat <$> traverse availExport (nubAvails avails)
-
+ lookupExport :: MonadIO m => DocStructureItem -> IfM m [ExportItem GhcRn]
+ lookupExport = \case
+ DsiSectionHeading lev hsDoc' -> do
+ doc <- processDocString dflags hsDoc'
+ pure [ExportGroup lev "" doc]
+ DsiDocChunk hsDoc' -> do
+ doc <- processDocStringParas dflags pkgName hsDoc'
+ pure [ExportDoc doc]
+ DsiNamedChunkRef ref -> do
+ case Map.lookup ref namedChunks of
+ Nothing -> do
+ warn $ "Cannot find documentation for: $" ++ ref
+ pure []
+ Just hsDoc' -> do
+ doc <- processDocStringParas dflags pkgName hsDoc'
+ pure [ExportDoc doc]
+ DsiExports avails ->
+ -- TODO: We probably don't need nubAvails here.
+ -- mkDocStructureFromExportList already uses it.
+ concat <$> traverse availExport (nubAvails avails)
+ DsiModExport mod_names avails -> do
+ -- only consider exporting a module if we are sure we are really
+ -- exporting the whole module and not some subset.
+ (unrestricted_mods, remaining_avails) <- unrestrictedModExports dflags thisMod modMap instIfaceMap avails (NE.toList mod_names)
+ avail_exps <- concat <$> traverse availExport remaining_avails
+ pure (map ExportModule unrestricted_mods ++ avail_exps)
+
+ availExport :: MonadIO m => AvailInfo -> IfM m [ExportItem GhcRn]
availExport avail =
- availExportItem is_sig modMap thisMod semMod warnings exportedNames
- maps fixMap splices instIfaceMap dflags avail
-
-
--- Extract the minimal complete definition of a Name, if one exists
-minimalDef :: Monad m => Name -> IfM m (Maybe ClassMinimalDef)
-minimalDef n = do
- mty <- lookupName n
- case mty of
- Just (ATyCon (tyConClass_maybe -> Just c)) ->
- return . Just $ classMinimalDef c
- _ ->
- return Nothing
+ availExportItem prr modMap thisMod warnings
+ docMap argMap fixMap instIfaceMap dflags avail defMeths
+
+unrestrictedModExports
+ :: MonadIO m
+ => DynFlags
+ -> Module -- ^ Current Module
+ -> IfaceMap -- ^ Already created interfaces
+ -> InstIfaceMap -- ^ Interfaces in other packages
+ -> Avails
+ -> [ModuleName] -- ^ Modules to be exported
+ -> IfM m ([Module], Avails)
+ -- ^ ( modules exported without restriction
+ -- , remaining exports not included in any
+ -- of these modules
+ -- )
+unrestrictedModExports dflags thisMod ifaceMap instIfaceMap avails mod_names = do
+ mods_and_exports <- fmap catMaybes $ for mod_names $ \mod_name -> do
+ let m_local = mkModule (moduleUnit thisMod) mod_name
+ case Map.lookup m_local ifaceMap of
+ -- First lookup locally
+ Just iface -> pure $ Just (ifaceMod iface, mkNameSet (ifaceExports iface))
+ Nothing ->
+ case Map.lookup mod_name instIfaceMap' of
+ Just iface -> pure $ Just (instMod iface, mkNameSet (instExports iface))
+ Nothing -> do
+ warn $
+ "Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
+ "documentation for exported module: " ++ pretty dflags mod_name
+ pure Nothing
+ let unrestricted = filter everythingVisible mods_and_exports
+ mod_exps = unionNameSets (map snd unrestricted)
+ remaining = nubAvails (filterAvails (\n -> not (n `elemNameSet` mod_exps)) avails)
+ pure (map fst unrestricted, remaining)
+ where
+ instIfaceMap' = Map.mapKeys moduleName instIfaceMap
+ all_names = availsToNameSet avails
+ -- Is everything in this (supposedly re-exported) module visible?
+ everythingVisible :: (Module, NameSet) -> Bool
+ everythingVisible (mdl, exps)
+ | not (exps `isSubsetOf` all_names) = False
+ | Just iface <- Map.lookup mdl ifaceMap = OptHide `notElem` ifaceOptions iface
+ | Just iface <- Map.lookup (moduleName mdl) instIfaceMap' = OptHide `notElem` instOptions iface
+ | otherwise = True
+
+ -- TODO: Add a utility based on IntMap.isSubmapOfBy
+ isSubsetOf :: NameSet -> NameSet -> Bool
+ isSubsetOf a b = nameSetAll (`elemNameSet` b) a
availExportItem
- :: forall m
- . Monad m
- => Bool -- is it a signature
+ :: forall m. MonadIO m
+ => PrintRuntimeReps
-> IfaceMap
-> Module -- this module
- -> Module -- semantic module
-> WarningMap
- -> [Name] -- exported names (orig)
- -> Maps
+ -> Map Name (MDoc Name) -- docs (keyed by 'Name's)
+ -> ArgMap Name -- docs for arguments (keyed by 'Name's)
-> FixMap
- -> [SrcSpan] -- splice locations
-> InstIfaceMap
-> DynFlags
-> AvailInfo
+ -> OccEnv Name -- Default methods
-> IfM m [ExportItem GhcRn]
-availExportItem is_sig modMap thisMod semMod warnings exportedNames
- (docMap, argMap, declMap, _) fixMap splices instIfaceMap
- dflags availInfo = declWith availInfo
+availExportItem
+ prr modMap thisMod warnings docMap argMap fixMap instIfaceMap dflags
+ availInfo defMeths
+ =
+ declWith availInfo
where
declWith :: AvailInfo -> IfM m [ ExportItem GhcRn ]
declWith avail = do
let t = availName avail
- r <- findDecl avail
- case r of
- ([L l' (ValD _ _)], (doc, _)) -> do
- let l = locA l'
- -- Top-level binding without type signature
- export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
- return [export]
- (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
- let declNames = getMainDeclBinder emptyOccEnv (unL decl)
- in case () of
- _
- -- We should not show a subordinate by itself if any of its
- -- parents is also exported. See note [1].
- | t `notElem` declNames,
- Just p <- find isExported (parents t $ unL decl) ->
- do liftErrMsg $ tell [
- "Warning: " ++ moduleString thisMod ++ ": " ++
- pretty dflags (nameOccName t) ++ " is exported separately but " ++
- "will be documented under " ++ pretty dflags (nameOccName p) ++
- ". Consider exporting it together with its parent(s)" ++
- " for code clarity." ]
- return []
-
- -- normal case
- | otherwise -> case decl of
- -- A single signature might refer to many names, but we
- -- create an export item for a single name only. So we
- -- modify the signature to contain only that single name.
- L loc (SigD _ sig) ->
- -- fromJust is safe since we already checked in guards
- -- that 't' is a name declared in this declaration.
- let newDecl = L loc . SigD noExtField . fromJust $ filterSigNames (== t) sig
- in availExportDecl avail newDecl docs_
-
- L loc (TyClD _ ClassDecl {..}) -> do
- mdef <- minimalDef t
- let sig = maybeToList $ fmap (noLocA . MinimalSig (noAnn, NoSourceText) . noLocA . fmap noLocA) mdef
- availExportDecl avail
- (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_
-
- _ -> availExportDecl avail decl docs_
-
- -- Declaration from another package
- ([], _) -> do
- mayDecl <- hiDecl dflags t
- case mayDecl of
- Nothing -> return [ ExportNoDecl t [] ]
- Just decl ->
- -- We try to get the subs and docs
- -- from the installed .haddock file for that package.
- -- TODO: This needs to be more sophisticated to deal
- -- with signature inheritance
- case M.lookup (nameModule t) instIfaceMap of
- Nothing -> do
- liftErrMsg $ tell
- ["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
- let subs_ = availNoDocs avail
- availExportDecl avail decl (noDocForDecl, subs_)
- Just iface ->
- availExportDecl avail decl (lookupDocs avail warnings (instDocMap iface) (instArgMap iface))
-
- _ -> return []
+ mayDecl <- hiDecl dflags prr t
+ case mayDecl of
+ Nothing -> return [ ExportNoDecl t [] ]
+ Just decl -> do
+ availExportDecl avail decl =<< do
+ -- Find docs for decl
+ let tmod = nameModule t
+ if tmod == thisMod
+ then pure (lookupDocs avail warnings docMap argMap defMeths)
+ else case Map.lookup tmod modMap of
+ Just iface ->
+ pure (lookupDocs avail warnings (ifaceDocMap iface) (ifaceArgMap iface) (mkOccEnv (ifaceDefMeths iface)))
+ Nothing ->
+ -- We try to get the subs and docs
+ -- from the installed .haddock file for that package.
+ -- TODO: This needs to be more sophisticated to deal
+ -- with signature inheritance
+ case Map.lookup (nameModule t) instIfaceMap of
+ Nothing -> do
+ warn $
+ "Warning: " ++ pretty dflags thisMod ++
+ ": Couldn't find .haddock for export " ++ pretty dflags t
+ let subs_ = availNoDocs avail
+ pure (noDocForDecl, subs_)
+ Just instIface ->
+ pure (lookupDocs avail warnings (instDocMap instIface) (instArgMap instIface) (mkOccEnv (instDefMeths instIface)))
-- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails
availDecl :: Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn)
- availDecl declName parentDecl =
- case extractDecl declMap declName parentDecl of
+ availDecl declName parentDecl = extractDecl prr dflags declName parentDecl >>= \case
Right d -> pure d
Left err -> do
- synifiedDeclOpt <- hiDecl dflags declName
+ synifiedDeclOpt <- hiDecl dflags prr declName
case synifiedDeclOpt of
Just synifiedDecl -> pure synifiedDecl
Nothing -> pprPanic "availExportItem" (O.text err)
@@ -807,70 +539,49 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
bundledPatSyns <- findBundledPatterns avail
let
- patSynNames =
+ !patSynNames = force $
concatMap (getMainDeclBinder emptyOccEnv . fst) bundledPatSyns
- fixities =
+ !doc' = force doc
+ !subs' = force subs
+
+ !restrictToNames = force $ fmap fst subs'
+
+ !fixities = force
[ (n, f)
- | n <- availName avail : fmap fst subs ++ patSynNames
- , Just f <- [M.lookup n fixMap]
+ | n <- availName avail : fmap fst subs' ++ patSynNames
+ , Just f <- [Map.lookup n fixMap]
]
- return [ ExportDecl {
- expItemDecl = restrictTo (fmap fst subs) extractedDecl
- , expItemPats = bundledPatSyns
- , expItemMbDoc = doc
- , expItemSubDocs = subs
- , expItemInstances = []
- , expItemFixities = fixities
- , expItemSpliced = False
- }
- ]
+ return
+ [ ExportDecl ExportD
+ { expDDecl = restrictTo restrictToNames extractedDecl
+ , expDPats = bundledPatSyns
+ , expDMbDoc = doc'
+ , expDSubDocs = subs'
+ , expDInstances = []
+ , expDFixities = fixities
+ , expDSpliced = False
+ }
+ ]
| otherwise = for subs $ \(sub, sub_doc) -> do
extractedDecl <- availDecl sub decl
- return ( ExportDecl {
- expItemDecl = extractedDecl
- , expItemPats = []
- , expItemMbDoc = sub_doc
- , expItemSubDocs = []
- , expItemInstances = []
- , expItemFixities = [ (sub, f) | Just f <- [M.lookup sub fixMap] ]
- , expItemSpliced = False
- } )
-
- exportedNameSet = mkNameSet exportedNames
- isExported n = elemNameSet n exportedNameSet
-
- findDecl :: AvailInfo -> IfM m ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)]))
- findDecl avail
- | m == semMod =
- case M.lookup n declMap of
- Just ds -> return (ds, lookupDocs avail warnings docMap argMap)
- Nothing
- | is_sig -> do
- -- OK, so it wasn't in the local declaration map. It could
- -- have been inherited from a signature. Reconstitute it
- -- from the type.
- mb_r <- hiDecl dflags n
- case mb_r of
- Nothing -> return ([], (noDocForDecl, availNoDocs avail))
- -- TODO: If we try harder, we might be able to find
- -- a Haddock! Look in the Haddocks for each thing in
- -- requirementContext (unitState)
- Just decl -> return ([decl], (noDocForDecl, availNoDocs avail))
- | otherwise ->
- return ([], (noDocForDecl, availNoDocs avail))
- | Just iface <- M.lookup (semToIdMod (moduleUnit thisMod) m) modMap
- , Just ds <- M.lookup n (ifaceDeclMap iface) =
- return (ds, lookupDocs avail warnings
- (ifaceDocMap iface)
- (ifaceArgMap iface))
- | otherwise = return ([], (noDocForDecl, availNoDocs avail))
- where
- n = availName avail
- m = nameModule n
+ let
+ !fixities = force [ (sub, f) | Just f <- [Map.lookup sub fixMap] ]
+ !subDoc = force sub_doc
+
+ return $
+ ExportDecl ExportD
+ { expDDecl = extractedDecl
+ , expDPats = []
+ , expDMbDoc = subDoc
+ , expDSubDocs = []
+ , expDInstances = []
+ , expDFixities = fixities
+ , expDSpliced = False
+ }
findBundledPatterns :: AvailInfo -> IfM m [(HsDecl GhcRn, DocForDecl Name)]
findBundledPatterns avail = do
@@ -880,9 +591,9 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
Just (AConLike PatSynCon{}) -> do
export_items <- declWith (Avail name)
pure [ (unLoc patsyn_decl, patsyn_doc)
- | ExportDecl {
- expItemDecl = patsyn_decl
- , expItemMbDoc = patsyn_doc
+ | ExportDecl ExportD
+ { expDDecl = patsyn_decl
+ , expDMbDoc = patsyn_doc
} <- export_items
]
_ -> pure []
@@ -898,93 +609,54 @@ availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)]
availNoDocs avail =
zip (availSubordinates avail) (repeat noDocForDecl)
--- | Given a 'Module' from a 'Name', convert it into a 'Module' that
--- we can actually find in the 'IfaceMap'.
-semToIdMod :: Unit -> Module -> Module
-semToIdMod this_uid m
- | Module.isHoleModule m = mkModule this_uid (moduleName m)
- | otherwise = m
-
-hiDecl :: Monad m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn))
-hiDecl dflags t = do
+hiDecl
+ :: MonadIO m
+ => DynFlags
+ -> PrintRuntimeReps
+ -> Name
+ -> IfM m (Maybe (LHsDecl GhcRn))
+hiDecl dflags prr t = do
mayTyThing <- lookupName t
case mayTyThing of
Nothing -> do
- liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
+ warn $ "Warning: Not found in environment: " ++ pretty dflags t
return Nothing
- Just x -> case tyThingToLHsDecl ShowRuntimeRep x of
- Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing
- Right (m, t') -> liftErrMsg (tell $ map bugWarn m)
- >> return (Just $ noLocA t')
+ Just x -> case tyThingToLHsDecl prr x of
+ Left m -> (warn $ bugWarn m) >> return Nothing
+ Right (m, t') -> mapM (warn . bugWarn) m >> return (Just $ L (noAnnSrcSpan (nameSrcSpan t)) t')
where
warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<>
O.comma O.<+> O.quotes (O.ppr t) O.<+>
O.text "-- Please report this on Haddock issue tracker!"
bugWarn = showSDoc dflags . warnLine
--- | This function is called for top-level bindings without type signatures.
--- It gets the type signature from GHC and that means it's not going to
--- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the
--- declaration and use it instead - 'nLoc' here.
-hiValExportItem
- :: Monad m => DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool
- -> Maybe Fixity -> IfM m (ExportItem GhcRn)
-hiValExportItem dflags name nLoc doc splice fixity = do
- mayDecl <- hiDecl dflags name
- case mayDecl of
- Nothing -> return (ExportNoDecl name [])
- Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice)
- where
- fixSpan (L (SrcSpanAnn a l) t) = L (SrcSpanAnn a (SrcLoc.combineSrcSpans l nLoc)) t
- fixities = case fixity of
- Just f -> [(name, f)]
- Nothing -> []
-
-
-- | Lookup docs for a declaration from maps.
-lookupDocs :: AvailInfo -> WarningMap -> DocMap Name -> ArgMap Name
- -> (DocForDecl Name, [(Name, DocForDecl Name)])
-lookupDocs avail warnings docMap argMap =
- let n = availName avail in
- let lookupArgDoc x = M.findWithDefault M.empty x argMap in
- let doc = (lookupDoc n, lookupArgDoc n) in
- let subDocs = [ (s, (lookupDoc s, lookupArgDoc s))
- | s <- availSubordinates avail
- ] in
- (doc, subDocs)
+lookupDocs
+ :: AvailInfo
+ -> WarningMap
+ -> Map Name (MDoc Name)
+ -> ArgMap Name
+ -> OccEnv Name
+ -> (DocForDecl Name, [(Name, DocForDecl Name)])
+lookupDocs avail warningMap docMap argMap def_meths_env =
+ let
+ n = availName avail
+ lookupArgDoc x = Map.findWithDefault Map.empty x argMap
+ doc = (lookupDoc n, lookupArgDoc n)
+ subs = availSubordinates avail
+ def_meths = [ (meth, (lookupDoc meth, lookupArgDoc meth))
+ | s <- subs
+ , let dmOcc = mkDefaultMethodOcc (nameOccName s)
+ , Just meth <- [lookupOccEnv def_meths_env dmOcc]]
+ subDocs = [ (s, (lookupDoc s, lookupArgDoc s))
+ | s <- subs
+ ] ++ def_meths
+ in
+ (doc, subDocs)
where
- lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings)
+ lookupDoc name = Documentation (Map.lookup name docMap) (Map.lookup name warningMap)
--- | Export the given module as `ExportModule`. We are not concerned with the
--- single export items of the given module.
-moduleExport
- :: Monad m
- => Module -- ^ Module A (identity, NOT semantic)
- -> DynFlags -- ^ The flags used when typechecking A
- -> IfaceMap -- ^ Already created interfaces
- -> InstIfaceMap -- ^ Interfaces in other packages
- -> ModuleName -- ^ The exported module
- -> IfM m [ExportItem GhcRn] -- ^ Resulting export items
-moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
- -- NB: we constructed the identity module when looking up in
- -- the IfaceMap.
- case M.lookup m ifaceMap of
- Just iface
- | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)
- | otherwise -> return [ ExportModule m ]
-
- Nothing -> -- We have to try to find it in the installed interfaces
- -- (external packages).
- case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of
- Just iface -> return [ ExportModule (instMod iface) ]
- Nothing -> do
- liftErrMsg $ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
- "documentation for exported module: " ++ pretty dflags expMod]
- return []
- where
- m = mkModule (moduleUnit thisMod) expMod -- Identity module!
-
-- Note [1]:
------------
-- It is unnecessary to document a subordinate by itself at the top level if
@@ -1002,55 +674,6 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
-- (For more information, see Trac #69)
--- | Simplified variant of 'mkExportItems', where we can assume that
--- every locally defined declaration is exported; thus, we just
--- zip through the renamed declarations.
-
-fullModuleContents
- :: Monad m
- => Bool -- is it a signature
- -> IfaceMap
- -> Maybe Package -- this package
- -> Module -- this module
- -> Module -- semantic module
- -> WarningMap
- -> GlobalRdrEnv -- ^ The renaming environment
- -> [Name] -- exported names (orig)
- -> [LHsDecl GhcRn] -- renamed source declarations
- -> Maps
- -> FixMap
- -> [SrcSpan] -- splice locations
- -> InstIfaceMap
- -> DynFlags
- -> Avails
- -> IfM m [ExportItem GhcRn]
-fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames
- decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do
- let availEnv = availsToNameEnv (nubAvails avails)
- (concat . concat) `fmap` (for decls $ \decl -> do
- case decl of
- (L _ (DocD _ (DocGroup lev docStr))) -> do
- doc <- liftErrMsg (processDocString dflags gre (hsDocString . unLoc $ docStr))
- return [[ExportGroup lev "" doc]]
- (L _ (DocD _ (DocCommentNamed _ docStr))) -> do
- doc <- liftErrMsg (processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr))
- return [[ExportDoc doc]]
- (L _ (ValD _ valDecl))
- | name:_ <- collectHsBindBinders CollNoDictBinders valDecl
- , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
- -> return []
- _ ->
- for (getMainDeclBinder emptyOccEnv (unLoc decl)) $ \nm -> do
- case lookupNameEnv availEnv nm of
- Just avail ->
- availExportItem is_sig modMap thisMod
- semMod warnings exportedNames maps fixMap
- splices instIfaceMap dflags avail
- Nothing -> pure [])
- where
- isSigD (L _ SigD{}) = True
- isSigD _ = False
-
-- | Sometimes the declaration we want to export is not the "main" declaration:
-- it might be an individual record selector or a class method. In these
-- cases we have to extract the required declaration (and somehow cobble
@@ -1059,13 +682,14 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
-- This function looks through the declarations in this module to try to find
-- the one with the right name.
extractDecl
- :: HasCallStack
- => DeclMap -- ^ all declarations in the file
+ :: MonadIO m
+ => PrintRuntimeReps
+ -> DynFlags
-> Name -- ^ name of the declaration to extract
-> LHsDecl GhcRn -- ^ parent declaration
- -> Either ErrMsg (LHsDecl GhcRn)
-extractDecl declMap name decl
- | name `elem` getMainDeclBinder emptyOccEnv (unLoc decl) = pure decl
+ -> IfM m (Either String (LHsDecl GhcRn))
+extractDecl prr dflags name decl
+ | name `elem` getMainDeclBinder emptyOccEnv (unLoc decl) = pure $ Right decl
| otherwise =
case unLoc decl of
TyClD _ d@ClassDecl { tcdLName = L _ clsNm
@@ -1090,17 +714,19 @@ extractDecl declMap name decl
in case (matchesMethod, matchesAssociatedType) of
([s0], _) -> let tyvar_names = tyClDeclTyVars d
L pos sig = addClassContext clsNm tyvar_names s0
- in pure (L pos (SigD noExtField sig))
- (_, [L pos fam_decl]) -> pure (L pos (TyClD noExtField (FamDecl noExtField fam_decl)))
+ in pure (Right $ L pos (SigD noExtField sig))
+ (_, [L pos fam_decl]) -> pure (Right $ L pos (TyClD noExtField (FamDecl noExtField fam_decl)))
- ([], [])
- | Just (famInstDecl:_) <- M.lookup name declMap
- -> extractDecl declMap name famInstDecl
- _ -> Left (concat [ "Ambiguous decl for ", getOccString name
+ ([], []) -> do
+ famInstDeclOpt <- hiDecl dflags prr name
+ case famInstDeclOpt of
+ Nothing -> pure $ Left (concat [ "Ambiguous decl for ", getOccString name
+ , " in class ", getOccString clsNm ])
+ Just famInstDecl -> extractDecl prr dflags name famInstDecl
+ _ -> pure $ Left (concat [ "Ambiguous decl for ", getOccString name
, " in class ", getOccString clsNm ])
-
TyClD _ d@DataDecl { tcdLName = L _ dataNm
- , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do
+ , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> pure $ do
let ty_args = lHsQTyVarsToTypes (tyClDeclTyVars d)
lsig <- if isDataConName name
then extractPatternSyn name dataNm ty_args (toList dataCons)
@@ -1108,13 +734,16 @@ extractDecl declMap name decl
pure (SigD noExtField <$> lsig)
TyClD _ FamDecl {}
- | isValName name
- , Just (famInst:_) <- M.lookup name declMap
- -> extractDecl declMap name famInst
+ | isValName name -> do
+ famInstOpt <- hiDecl dflags prr name
+ case famInstOpt of
+ Just famInst -> extractDecl prr dflags name famInst
+ Nothing -> pure $ Left ("extractDecl: Unhandled decl for " ++ getOccString name)
+
InstD _ (DataFamInstD _ (DataFamInstDecl
(FamEqn { feqn_tycon = L _ n
, feqn_pats = tys
- , feqn_rhs = defn }))) ->
+ , feqn_rhs = defn }))) -> pure $
if isDataConName name
then fmap (SigD noExtField) <$> extractPatternSyn name n tys (toList $ dd_cons defn)
else fmap (SigD noExtField) <$> extractRecSel name n tys (toList $ dd_cons defn)
@@ -1124,8 +753,8 @@ extractDecl declMap name decl
, name `elem` map unLoc (concatMap (toList . getConNames . unLoc) (dd_cons dd))
]
in case matches of
- [d0] -> extractDecl declMap name (noLocA (InstD noExtField (DataFamInstD noExtField d0)))
- _ -> Left "internal: extractDecl (ClsInstD)"
+ [d0] -> extractDecl prr dflags name (noLocA (InstD noExtField (DataFamInstD noExtField d0)))
+ _ -> pure $ Left "internal: extractDecl (ClsInstD)"
| otherwise ->
let matches = [ d' | L _ d'@(DataFamInstDecl d )
<- insts
@@ -1136,13 +765,14 @@ extractDecl declMap name decl
, foExt n == name
]
in case matches of
- [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0)
- _ -> Left "internal: extractDecl (ClsInstD)"
- _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name)
+ [d0] -> extractDecl prr dflags name (noLocA . InstD noExtField $ DataFamInstD noExtField d0)
+ _ -> pure $ Left "internal: extractDecl (ClsInstD)"
+ _ -> pure $ Left ("extractDecl: Unhandled decl for " ++ getOccString name)
-extractPatternSyn :: Name -> Name
+extractPatternSyn :: Name
+ -> Name
-> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]
- -> Either ErrMsg (LSig GhcRn)
+ -> Either String (LSig GhcRn)
extractPatternSyn nm t tvs cons =
case filter matches cons of
[] -> Left . O.showSDocOneLine O.defaultSDocContext $
@@ -1182,7 +812,7 @@ extractPatternSyn nm t tvs cons =
mkAppTyArg f (HsArgPar _) = HsParTy noAnn f
extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]
- -> Either ErrMsg (LSig GhcRn)
+ -> Either String (LSig GhcRn)
extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
@@ -1207,20 +837,20 @@ extractRecSel nm t tvs (L _ con : rest) =
pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]
pruneExportItems = filter hasDoc
where
- hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d
+ hasDoc (ExportDecl ExportD {expDMbDoc = (Documentation d _, _)}) = isJust d
hasDoc _ = True
-mkVisibleNames :: Maps -> [ExportItem GhcRn] -> [DocOption] -> [Name]
-mkVisibleNames (_, _, _, instMap) exports opts
+mkVisibleNames :: InstMap -> [ExportItem GhcRn] -> [DocOption] -> [Name]
+mkVisibleNames instMap exports opts
| OptHide `elem` opts = []
| otherwise = let ns = concatMap exportName exports
in seqList ns `seq` ns
where
- exportName e@ExportDecl {} = name ++ subs ++ patsyns
- where subs = map fst (expItemSubDocs e)
- patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expItemPats e)
- name = case unLoc $ expItemDecl e of
+ exportName (ExportDecl e@ExportD{}) = name ++ subs ++ patsyns
+ where subs = map fst (expDSubDocs e)
+ patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expDPats e)
+ name = case unLoc $ expDDecl e of
InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap
decl -> getMainDeclBinder emptyOccEnv decl
exportName ExportNoDecl {} = [] -- we don't count these as visible, since
@@ -1230,16 +860,3 @@ mkVisibleNames (_, _, _, instMap) exports opts
seqList :: [a] -> ()
seqList [] = ()
seqList (x : xs) = x `seq` seqList xs
-
--- | Find a stand-alone documentation comment by its name.
-findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString)
-findNamedDoc name = search
- where
- search [] = do
- tell ["Cannot find documentation for: $" ++ name]
- return Nothing
- search (DocD _ (DocCommentNamed name' doc) : rest)
- | name == name' = return (Just (hsDocString . unLoc $ doc))
-
- | otherwise = search rest
- search (_other_decl : rest) = search rest
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 3079aee73b..43b3ab50e7 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -1,7 +1,7 @@
-{-# OPTIONS_GHC -Wwarn #-}
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.LexParseRn
@@ -15,77 +15,98 @@
-----------------------------------------------------------------------------
module Haddock.Interface.LexParseRn
( processDocString
- , processDocStringFromString
, processDocStringParas
- , processDocStrings
+ , processDocStringsParas
, processModuleHeader
) where
import Control.Arrow
import Control.Monad
+import Control.Monad.State.Strict
import Data.Functor
import Data.List ((\\), maximumBy)
import Data.Ord
-import Documentation.Haddock.Doc (metaDocConcat)
-import GHC.Driver.Session (languageExtensions)
-import qualified GHC.LanguageExtensions as LangExt
+import qualified Data.Set as Set
import GHC
+import GHC.Data.EnumSet as EnumSet
+import GHC.Data.FastString ( unpackFS )
+import GHC.Driver.Ppr ( showPpr, showSDoc )
+import GHC.Driver.Session
+import GHC.Parser.PostProcess
+import GHC.Types.Avail
+import GHC.Types.Name
+import GHC.Types.Name.Reader
+import GHC.Types.Name.Set
+import GHC.Utils.Misc ((<||>))
+import GHC.Utils.Outputable (Outputable)
import Haddock.Interface.ParseModuleHeader
import Haddock.Parser
import Haddock.Types
-import GHC.Types.Name
-import GHC.Types.Avail ( availName )
-import GHC.Parser.PostProcess
-import GHC.Driver.Ppr ( showPpr, showSDoc )
-import GHC.Types.Name.Reader
-import GHC.Data.EnumSet as EnumSet
+import qualified GHC.LanguageExtensions as LangExt
+
+processDocStringsParas
+ :: MonadIO m
+ => DynFlags
+ -> Maybe Package
+ -> [HsDoc GhcRn]
+ -> IfM m (MDoc Name)
+processDocStringsParas dflags pkg hdss =
+ overDocF (rename dflags $ hsDocRenamer hds) $ parseParas dflags pkg (renderHsDocStrings $ hsDocString hds)
+ where
+ hds :: WithHsDocIdentifiers [HsDocString] GhcRn
+ hds = WithHsDocIdentifiers (map hsDocString hdss) (concatMap hsDocIdentifiers hdss)
+
+processDocStringParas
+ :: MonadIO m
+ => DynFlags
+ -> Maybe Package
+ -> (HsDoc GhcRn)
+ -> IfM m (MDoc Name)
+processDocStringParas dflags pkg hds =
+ overDocF (rename dflags $ hsDocRenamer hds) $ parseParas dflags pkg (renderHsDocString $ hsDocString hds)
-processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString]
- -> ErrMsgM (Maybe (MDoc Name))
-processDocStrings dflags pkg gre strs = do
- mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags pkg gre) strs
- case mdoc of
- -- We check that we don't have any version info to render instead
- -- of just checking if there is no comment: there may not be a
- -- comment but we still want to pass through any meta data.
- MetaDoc { _meta = Meta Nothing Nothing, _doc = DocEmpty } -> pure Nothing
- x -> pure (Just x)
-
-processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)
-processDocStringParas dflags pkg gre hds =
- overDocF (rename dflags gre) $ parseParas dflags pkg (renderHsDocString hds)
-
-processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name)
-processDocString dflags gre hds =
- processDocStringFromString dflags gre (renderHsDocString hds)
-
-processDocStringFromString :: DynFlags -> GlobalRdrEnv -> String -> ErrMsgM (Doc Name)
-processDocStringFromString dflags gre hds =
- rename dflags gre $ parseString dflags hds
-
-processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe HsDocString
- -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name))
-processModuleHeader dflags pkgName gre safety mayStr = do
+processDocString
+ :: MonadIO m
+ => DynFlags
+ -> (HsDoc GhcRn)
+ -> IfM m (Doc Name)
+processDocString dflags hds =
+ rename dflags (hsDocRenamer hds) $ parseString dflags (renderHsDocString $ hsDocString hds)
+
+processModuleHeader
+ :: MonadIO m
+ => DynFlags
+ -> Maybe Package
+ -> SafeHaskellMode
+ -> Maybe Language
+ -> EnumSet LangExt.Extension
+ -> Maybe (HsDoc GhcRn)
+ -> IfM m (HaddockModInfo Name, Maybe (MDoc Name))
+processModuleHeader dflags pkgName safety mayLang extSet mayStr = do
(hmi, doc) <-
case mayStr of
Nothing -> return failure
- Just hds -> do
- let str = renderHsDocString hds
+ Just hsDoc -> do
+ let str = renderHsDocString $ hsDocString hsDoc
(hmi, doc) = parseModuleHeader dflags pkgName str
+ renamer = hsDocRenamer hsDoc
!descr <- case hmi_description hmi of
- Just hmi_descr -> Just <$> rename dflags gre hmi_descr
+ Just hmi_descr -> Just <$> rename dflags renamer hmi_descr
Nothing -> pure Nothing
let hmi' = hmi { hmi_description = descr }
- doc' <- overDocF (rename dflags gre) doc
+ doc' <- overDocF (rename dflags renamer) doc
return (hmi', Just doc')
let flags :: [LangExt.Extension]
-- We remove the flags implied by the language setting and we display the language instead
- flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags)
- return (hmi { hmi_safety = Just $ showPpr dflags safety
- , hmi_language = language dflags
- , hmi_extensions = flags
- } , doc)
+ flags = EnumSet.toList extSet \\ languageExtensions mayLang
+ return
+ (hmi { hmi_safety = Just $ showPpr dflags safety
+ , hmi_language = language dflags
+ , hmi_extensions = flags
+ }
+ , doc
+ )
where
failure = (emptyHaddockModInfo, Nothing)
@@ -100,64 +121,48 @@ traverseSnd f = traverse (\(x, a) ->
-- fallbacks in case we can't locate the identifiers.
--
-- See the comments in the source for implementation commentary.
-rename :: DynFlags -> GlobalRdrEnv -> Doc NsRdrName -> ErrMsgM (Doc Name)
-rename dflags gre = rn
+rename
+ :: MonadIO m
+ => DynFlags
+ -> Renamer
+ -> Doc NsRdrName
+ -> IfM m (Doc Name)
+rename dflags renamer = rn
where
+ rn :: MonadIO m => Doc NsRdrName -> IfM m (Doc Name)
rn d = case d of
DocAppend a b -> DocAppend <$> rn a <*> rn b
- DocParagraph doc -> DocParagraph <$> rn doc
+ DocParagraph p -> DocParagraph <$> rn p
DocIdentifier i -> do
let NsRdrName ns x = unwrap i
occ = rdrNameOcc x
- isValueName = isDataOcc occ || isVarOcc occ || isFieldOcc occ
-
- let valueNsChoices | isValueName = [x]
- | otherwise = [] -- is this ever possible?
- typeNsChoices | isValueName = [setRdrNameSpace x tcName]
- | otherwise = [x]
-
+ let valueNsChoices | isDataOcc occ = isDataConNameSpace
+ | otherwise = isTermVarOrFieldNameSpace
+ typeNsChoices | isDataOcc occ = isTcClsNameSpace
+ | otherwise = isTvNameSpace
-- Generate the choices for the possible kind of thing this
-- is. We narrow down the possibilities with the namespace (if
-- there is one).
let choices = case ns of
Value -> valueNsChoices
Type -> typeNsChoices
- None -> valueNsChoices ++ typeNsChoices
-
- -- Lookup any GlobalRdrElts that match the choices.
- case concatMap (\c -> lookupGRE_RdrName (IncludeFields WantNormal) gre c) choices of
- -- We found no names in the env so we start guessing.
- [] ->
- case choices of
- -- The only way this can happen is if a value namespace was
- -- specified on something that cannot be a value.
- [] -> invalidValue dflags i
-
- -- There was nothing in the environment so we need to
- -- pick some default from what's available to us. We
- -- diverge here from the old way where we would default
- -- to type constructors as we're much more likely to
- -- actually want anchors to regular definitions than
- -- type constructor names (such as in #253). So now we
- -- only get type constructor links if they are actually
- -- in scope.
- a:_ -> outOfScope dflags ns (i $> a)
-
- -- There is only one name in the environment that matches so
- -- use it.
- [a] -> pure $ DocIdentifier (i $> greName a)
-
+ None -> valueNsChoices <||> typeNsChoices
+ case renamer (showPpr dflags x) choices of
+ [] -> case ns of
+ Type -> outOfScope dflags ns (i $> setRdrNameSpace x tcName)
+ _ -> outOfScope dflags ns (i $> x)
+ [a] -> pure (DocIdentifier $ i $> a)
-- There are multiple names available.
- gres -> ambiguous dflags i gres
+ names -> ambiguous dflags i names
- DocWarning doc -> DocWarning <$> rn doc
- DocEmphasis doc -> DocEmphasis <$> rn doc
- DocBold doc -> DocBold <$> rn doc
- DocMonospaced doc -> DocMonospaced <$> rn doc
+ DocWarning dw -> DocWarning <$> rn dw
+ DocEmphasis de -> DocEmphasis <$> rn de
+ DocBold db -> DocBold <$> rn db
+ DocMonospaced dm -> DocMonospaced <$> rn dm
DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs
DocOrderedList docs -> DocOrderedList <$> traverseSnd rn docs
DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list
- DocCodeBlock doc -> DocCodeBlock <$> rn doc
+ DocCodeBlock dcb -> DocCodeBlock <$> rn dcb
DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
DocModule (ModLink m l) -> DocModule . ModLink m <$> traverse rn l
DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l
@@ -176,27 +181,36 @@ rename dflags gre = rn
-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently
-- we simply monospace the identifier in most cases except when the
-- identifier is qualified: if the identifier is qualified then we can
--- still try to guess and generate anchors across modules but the
+-- still try to guess and generate anchors accross modules but the
-- users shouldn't rely on this doing the right thing. See tickets
-- #253 and #375 on the confusion this causes depending on which
-- default we pick in 'rename'.
-outOfScope :: DynFlags -> Namespace -> Wrap RdrName -> ErrMsgM (Doc a)
+outOfScope :: MonadIO m => DynFlags -> Namespace -> Wrap RdrName -> IfM m (Doc a)
outOfScope dflags ns x =
- case unwrap x of
- Unqual occ -> warnAndMonospace (x $> occ)
- Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ)))
- Orig _ occ -> warnAndMonospace (x $> occ)
- Exact name -> warnAndMonospace (x $> name) -- Shouldn't happen since x is out of scope
+ case unwrap x of
+ Unqual occ -> warnAndMonospace (x $> occ)
+ Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ)))
+ Orig _ occ -> warnAndMonospace (x $> occ)
+ Exact name -> warnAndMonospace (x $> name) -- Shouldn't happen since x is out of scope
where
- prefix = case ns of
- Value -> "the value "
- Type -> "the type "
- None -> ""
+ prefix =
+ case ns of
+ Value -> "the value "
+ Type -> "the type "
+ None -> ""
+ warnAndMonospace :: (MonadIO m, Outputable a) => Wrap a -> IfM m (DocH mod id)
warnAndMonospace a = do
let a' = showWrapped (showPpr dflags) a
- tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++
- " If you qualify the identifier, haddock can try to link it anyway."]
+
+ -- If we have already warned for this identifier, don't warn again
+ firstWarn <- Set.notMember a' <$> gets ifeOutOfScopeNames
+ when firstWarn $ do
+ warn $
+ "Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++
+ " If you qualify the identifier, haddock can try to link it anyway."
+ modify' (\env -> env { ifeOutOfScopeNames = Set.insert a' (ifeOutOfScopeNames env) })
+
pure (monospaced a')
monospaced = DocMonospaced . DocString
@@ -205,43 +219,51 @@ outOfScope dflags ns x =
-- Prefers local names primarily and type constructors or class names secondarily.
--
-- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class.
-ambiguous :: DynFlags
- -> Wrap NsRdrName
- -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above.
- -> ErrMsgM (Doc Name)
-ambiguous dflags x gres = do
- let noChildren = map availName (gresToAvailInfo gres)
- dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren
- msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++
- concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map greName gres) ++
- " You may be able to disambiguate the identifier by qualifying it or\n" ++
- " by specifying the type/value namespace explicitly.\n" ++
- " Defaulting to the one defined " ++ defnLoc dflt
- -- TODO: Once we have a syntax for namespace qualification (#667) we may also
- -- want to emit a warning when an identifier is a data constructor for a type
- -- of the same name, but not the only constructor.
- -- For example, for @data D = C | D@, someone may want to reference the @D@
- -- constructor.
- when (length noChildren > 1) $ tell [msg]
- pure (DocIdentifier (x $> dflt))
+ambiguous
+ :: MonadIO m
+ => DynFlags
+ -> Wrap NsRdrName
+ -> [Name] -- ^ More than one @gre@s sharing the same `RdrName` above.
+ -> IfM m (Doc Name)
+ambiguous dflags x names = do
+ let noChildren = map availName (nubAvails (map Avail names))
+ dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren
+ nameStr = showNsRdrName dflags x
+ msg = "Warning: " ++ nameStr ++ " is ambiguous. It is defined\n" ++
+ concatMap (\n -> " * " ++ defnLoc n ++ "\n") names ++
+ " You may be able to disambiguate the identifier by qualifying it or\n" ++
+ " by specifying the type/value namespace explicitly.\n" ++
+ " Defaulting to the one defined " ++ defnLoc dflt
+
+ -- TODO: Once we have a syntax for namespace qualification (#667) we may also
+ -- want to emit a warning when an identifier is a data constructor for a type
+ -- of the same name, but not the only constructor.
+ -- For example, for @data D = C | D@, someone may want to reference the @D@
+ -- constructor.
+
+ -- If we have already warned for this name, do not warn again
+ firstWarn <- Set.notMember nameStr <$> gets ifeAmbiguousNames
+ when (length noChildren > 1 && firstWarn) $ do
+ warn msg
+ modify' (\env -> env { ifeAmbiguousNames = Set.insert nameStr (ifeAmbiguousNames env) })
+
+ pure (DocIdentifier (x $> dflt))
where
isLocalName (nameSrcLoc -> RealSrcLoc {}) = True
isLocalName _ = False
defnLoc = showSDoc dflags . pprNameDefnLoc
--- | Handle value-namespaced names that cannot be for values.
---
--- Emits a warning that the value-namespace is invalid on a non-value identifier.
-invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a)
-invalidValue dflags x = do
- tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++
- " namespaced as such. Did you mean to specify a type namespace\n" ++
- " instead?"]
- pure (DocMonospaced (DocString (showNsRdrName dflags x)))
-
-- | Printable representation of a wrapped and namespaced name
showNsRdrName :: DynFlags -> Wrap NsRdrName -> String
showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident
where
ident = showWrapped (showPpr dflags . rdrName)
prefix = renderNs . namespace . unwrap
+
+hsDocRenamer :: WithHsDocIdentifiers a GhcRn -> Renamer
+hsDocRenamer hsDoc = \s cands -> nameSetElemsStable $ filterNameSet (nameMatches s cands) env
+ where
+ !env = hsDocIds hsDoc
+ nameMatches s ok_ns n =
+ let occ = occName n
+ in ok_ns (occNameSpace occ) && s == unpackFS (occNameFS occ)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 8feecee3fb..c23c689129 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -1,6 +1,9 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.Rename
@@ -17,6 +20,7 @@ module Haddock.Interface.Rename (renameInterface) where
import Data.Traversable (mapM)
+import Haddock.Backends.Hoogle (ppExportD)
import Haddock.GhcUtils
import Haddock.Types
@@ -27,13 +31,14 @@ import GHC.Types.Name.Reader (RdrName(Exact))
import GHC.Builtin.Types (eqTyCon_RDR)
import Control.Applicative
-import Control.Arrow ( first )
+import Control.DeepSeq (force)
import Control.Monad hiding (mapM)
-import Data.List (intercalate)
-import qualified Data.Map as Map hiding ( Map )
+import Control.Monad.Reader
+import Control.Monad.Writer.CPS
+import Data.Foldable (traverse_)
+import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Prelude hiding (mapM)
-import GHC.HsToCore.Docs
import GHC.Types.Basic ( TopLevelFlag(..) )
-- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to
@@ -44,164 +49,249 @@ import GHC.Types.Basic ( TopLevelFlag(..) )
--
-- The renamed output gets written into fields in the Haddock interface record
-- that were previously left empty.
-renameInterface :: DynFlags -> [String] -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
-renameInterface _dflags ignoredSymbols renamingEnv warnings iface =
-
- -- first create the local env, where every name exported by this module
- -- is mapped to itself, and everything else comes from the global renaming
- -- env
- let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface)
- where fn env name = Map.insert name (ifaceMod iface) env
-
- -- rename names in the exported declarations to point to things that
- -- are closer to, or maybe even exported by, the current module.
- (renamedExportItems, missingNames1)
- = runRnFM localEnv (renameExportItems (ifaceExportItems iface))
-
- (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface))
-
- (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface))
-
- (renamedOrphanInstances, missingNames4)
- = runRnFM localEnv (mapM renameDocInstance (ifaceOrphanInstances iface))
-
- (finalModuleDoc, missingNames5)
- = runRnFM localEnv (renameDocumentation (ifaceDoc iface))
-
- -- combine the missing names and filter out the built-ins, which would
- -- otherwise always be missing.
- missingNames = nubByName id $ filter isExternalName -- XXX: isExternalName filters out too much
- (missingNames1 ++ missingNames2 ++ missingNames3
- ++ missingNames4 ++ missingNames5)
-
- -- Filter out certain built in type constructors using their string
- -- representation.
- --
- -- Note that since the renamed AST represents equality constraints as
- -- @HasOpTy t1 eqTyCon_RDR t2@ (and _not_ as @HsEqTy t1 t2@), we need to
- -- manually filter out 'eqTyCon_RDR' (aka @~@).
-
- qualifiedName n = (moduleNameString $ moduleName $ nameModule n) <> "." <> getOccString n
-
- ignoreSet = Set.fromList ignoredSymbols
-
- strings = [ qualifiedName n
-
- | n <- missingNames
- , not (qualifiedName n `Set.member` ignoreSet)
- , not (isSystemName n)
- , not (isBuiltInSyntax n)
- , Exact n /= eqTyCon_RDR
- ]
-
- in do
- -- report things that we couldn't link to. Only do this for non-hidden
- -- modules.
- unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $
- tell ["Warning: " ++ moduleString (ifaceMod iface) ++
- ": could not find link destinations for:\n"++
- intercalate "\n\t- " ("" : strings) ]
-
- return $ iface { ifaceRnDoc = finalModuleDoc,
- ifaceRnDocMap = rnDocMap,
- ifaceRnArgMap = rnArgMap,
- ifaceRnExportItems = renamedExportItems,
- ifaceRnOrphanInstances = renamedOrphanInstances}
-
+renameInterface
+ :: DynFlags
+ -- ^ GHC session dyn flags
+ -> Map.Map (Maybe String) (Set.Set String)
+ -- ^ Ignored symbols. A map from module names to unqualified names. Module
+ -- 'Just M' mapping to name 'f' means that link warnings should not be
+ -- generated for occurances of specifically 'M.f'. Module 'Nothing' mapping to
+ -- name 'f' means that link warnings should not be generated for any 'f'.
+ -> LinkEnv
+ -- ^ Link environment. A map from 'Name' to 'Module', where name 'n' maps to
+ -- module 'M' if 'M' is the preferred link destination for name 'n'.
+ -> Bool
+ -- ^ Are warnings enabled?
+ -> Bool
+ -- ^ Is Hoogle output enabled?
+ -> Interface
+ -- ^ The interface we are renaming.
+ -> Ghc Interface
+ -- ^ The renamed interface. Note that there is nothing really special about
+ -- this being in the 'Ghc' monad. This could very easily be any 'MonadIO' or
+ -- even pure, depending on the link warnings are reported.
+renameInterface dflags ignoreSet renamingEnv warnings hoogle iface = do
+ let (iface', warnedNames) =
+ runRnM
+ dflags
+ mdl
+ localLinkEnv
+ warnName
+ (hoogle && not (OptHide `elem` ifaceOptions iface))
+ (renameInterfaceRn iface)
+ reportMissingLinks mdl warnedNames
+ return iface'
+ where
+ -- The current module
+ mdl :: Module
+ mdl = ifaceMod iface
+
+ -- The local link environment, where every name exported by this module is
+ -- mapped to the module itself, and everything else comes from the global
+ -- renaming env
+ localLinkEnv :: LinkEnv
+ localLinkEnv = foldr f renamingEnv (ifaceVisibleExports iface)
+ where f name !env = Map.insert name mdl env
+
+ -- The function used to determine whether we should warn about a name
+ -- which we do not find in the renaming environment
+ warnName name =
+ -- Warnings must be enabled
+ warnings
+
+ -- Current module must not be hidden from Haddock
+ && not (OptHide `elem` ifaceOptions iface)
+
+ -- Must be an external name that is not built-in syntax, not a type
+ -- variable, and not '~'
+ && isExternalName name
+ && not (isBuiltInSyntax name)
+ && not (isTyVarName name)
+ && Exact name /= eqTyCon_RDR
+
+ -- Must not be in the set of ignored symbols for the module or the
+ -- unqualified ignored symbols
+ && not (getOccString name `Set.member` ignoreSet')
+ where
+ -- The set of ignored symbols within the module this name is located
+ -- in unioned with the set of globally ignored symbols
+ ignoreSet' :: Set.Set String
+ ignoreSet' =
+ Set.union
+ (Map.findWithDefault Set.empty (Just $ modString name) ignoreSet)
+ (Map.findWithDefault Set.empty Nothing ignoreSet)
+
+ modString :: Name -> String
+ modString = moduleString . nameModule
+
+-- | Output warning messages indicating that the renamer could not find link
+-- destinations for the names in the given set as they occur in the given
+-- module.
+reportMissingLinks :: Module -> Set.Set Name -> Ghc ()
+reportMissingLinks mdl names
+ | Set.null names = return ()
+ | otherwise =
+ liftIO $ do
+ putStrLn $ "Warning: " ++ moduleString mdl ++ ": could not find link destinations for: "
+ traverse_ (putStrLn . ("\t- " ++) . qualifiedName) names
+ where
+ qualifiedName :: Name -> String
+ qualifiedName name = moduleString (nameModule name) ++ "." ++ getOccString name
--------------------------------------------------------------------------------
-- Monad for renaming
--------------------------------------------------------------------------------
+-- | A renaming monad which provides 'MonadReader' access to a renaming
+-- environment, and 'MonadWriter' access to a 'Set' of names for which link
+-- warnings should be generated, based on the renaming environment.
+newtype RnM a = RnM { unRnM :: ReaderT RnMEnv (Writer (Set.Set Name)) a }
+ deriving newtype (Functor, Applicative, Monad, MonadReader RnMEnv, MonadWriter (Set.Set Name))
--- | The monad does two things for us: it passes around the environment for
--- renaming, and it returns a list of names which couldn't be found in
--- the environment.
-newtype RnM a =
- RnM { unRn :: (Name -> (Bool, DocName))
- -- Name lookup function. The 'Bool' indicates that if the name
- -- was \"found\" in the environment.
+-- | The renaming monad environment. Stores the linking environment (mapping
+-- names to modules), the link warning predicate, and the current module.
+data RnMEnv = RnMEnv
+ { -- | The linking environment (map from names to modules)
+ rnLinkEnv :: LinkEnv
- -> (a, [Name] -> [Name])
- -- Value returned, as well as a difference list of the names not
- -- found
- }
+ -- | Link warning predicate (whether failing to find a link destination
+ -- for a given name should result in a warning)
+ , rnWarnName :: (Name -> Bool)
-instance Monad RnM where
- m >>= k = RnM $ \lkp -> let (a, out1) = unRn m lkp
- (b, out2) = unRn (k a) lkp
- in (b, out1 . out2)
+ -- | The current module
+ , rnModuleString :: String
-instance Functor RnM where
- fmap f (RnM lkp) = RnM (first f . lkp)
+ -- | Should Hoogle output be generated for this module?
+ , rnHoogleOutput :: Bool
-instance Applicative RnM where
- pure a = RnM (const (a, id))
- mf <*> mx = RnM $ \lkp -> let (f, out1) = unRn mf lkp
- (x, out2) = unRn mx lkp
- in (f x, out1 . out2)
+ -- | GHC Session DynFlags, necessary for Hoogle output generation
+ , rnDynFlags :: DynFlags
+ }
--- | Look up a 'Name' in the renaming environment.
-lookupRn :: Name -> RnM DocName
-lookupRn name = RnM $ \lkp ->
- case lkp name of
- (False,maps_to) -> (maps_to, (name :))
- (True, maps_to) -> (maps_to, id)
-
--- | Look up a 'Name' in the renaming environment, but don't warn if you don't
--- find the name. Prefer to use 'lookupRn' whenever possible.
-lookupRnNoWarn :: Name -> RnM DocName
-lookupRnNoWarn name = RnM $ \lkp -> (snd (lkp name), id)
-
--- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function.
--- Returns the renamed value along with a list of `Name`'s that could not be
--- renamed because they weren't in the environment.
-runRnFM :: LinkEnv -> RnM a -> (a, [Name])
-runRnFM env rn = let (x, dlist) = unRn rn lkp in (x, dlist [])
+-- | Run the renamer action in a renaming environment built using the given
+-- module, link env, and link warning predicate. Returns the renamed value along
+-- with a set of 'Name's that were not renamed and should be warned for (i.e.
+-- they satisfied the link warning predicate).
+runRnM :: DynFlags -> Module -> LinkEnv -> (Name -> Bool) -> Bool -> RnM a -> (a, Set.Set Name)
+runRnM dflags mdl linkEnv warnName hoogleOutput rn =
+ runWriter $ runReaderT (unRnM rn) rnEnv
where
- lkp n | isTyVarName n = (True, Undocumented n)
- | otherwise = case Map.lookup n env of
- Nothing -> (False, Undocumented n)
- Just mdl -> (True, Documented n mdl)
-
+ rnEnv :: RnMEnv
+ rnEnv = RnMEnv
+ { rnLinkEnv = linkEnv
+ , rnWarnName = warnName
+ , rnModuleString = moduleString mdl
+ , rnHoogleOutput = hoogleOutput
+ , rnDynFlags = dflags
+ }
--------------------------------------------------------------------------------
-- Renaming
--------------------------------------------------------------------------------
+-- | Rename an `Interface` in the renaming environment.
+renameInterfaceRn :: Interface -> RnM Interface
+renameInterfaceRn iface = do
+ exportItems <- renameExportItems (ifaceExportItems iface)
+ orphans <- mapM renameDocInstance (ifaceOrphanInstances iface)
+ finalModDoc <- renameDocumentation (ifaceDoc iface)
+ pure $! iface
+ { ifaceRnDoc = finalModDoc
+
+ -- The un-renamed export items are not used after renaming
+ , ifaceRnExportItems = exportItems
+ , ifaceExportItems = []
+
+ -- The un-renamed orphan instances are not used after renaming
+ , ifaceRnOrphanInstances = orphans
+ , ifaceOrphanInstances = []
+ }
-rename :: Name -> RnM DocName
-rename = lookupRn
-
-
-renameL :: GenLocated l Name -> RnM (GenLocated l DocName)
-renameL = mapM rename
-
+-- | Lookup a 'Name' in the renaming environment.
+lookupRn :: Name -> RnM DocName
+lookupRn name = RnM $ do
+ linkEnv <- asks rnLinkEnv
+ case Map.lookup name linkEnv of
+ Nothing -> return $ Undocumented name
+ Just mdl -> return $ Documented name mdl
+
+-- | Rename a 'Name' in the renaming environment. This is very similar to
+-- 'lookupRn', but tracks any names not found in the renaming environment if the
+-- `rnWarnName` predicate is true.
+renameName :: Name -> RnM DocName
+renameName name = do
+ warnName <- asks rnWarnName
+ docName <- lookupRn name
+ case docName of
+ Undocumented _ -> do
+ when (warnName name) $
+ tell $ Set.singleton name
+ return docName
+ _ -> return docName
+
+-- | Rename a located 'Name' in the current renaming environment.
+renameNameL :: GenLocated l Name -> RnM (GenLocated l DocName)
+renameNameL = mapM renameName
+
+-- | Rename a list of export items in the current renaming environment.
renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI]
renameExportItems = mapM renameExportItem
+-- | Rename an 'ExportItem' in the current renaming environment.
+renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI)
+renameExportItem item = case item of
+ ExportModule mdl -> return (ExportModule mdl)
+ ExportGroup lev id_ doc -> do
+ doc' <- renameDoc doc
+ return (ExportGroup lev id_ doc')
+ ExportDecl ed@(ExportD decl pats doc subs instances fixities splice) -> do
+ -- If Hoogle output should be generated, generate it
+ RnMEnv{..} <- ask
+ let !hoogleOut = force $
+ if rnHoogleOutput then
+ ppExportD rnDynFlags ed
+ else
+ []
+
+ decl' <- renameLDecl decl
+ pats' <- renamePats pats
+ doc' <- renameDocForDecl doc
+ subs' <- mapM renameSub subs
+ instances' <- forM instances renameDocInstance
+ fixities' <- forM fixities $ \(name, fixity) -> do
+ name' <- lookupRn name
+ return (name', fixity)
+
+ return $
+ ExportDecl RnExportD
+ { rnExpDExpD = ExportD decl' pats' doc' subs' instances' fixities' splice
+ , rnExpDHoogle = hoogleOut
+ }
+ ExportNoDecl x subs -> do
+ x' <- lookupRn x
+ subs' <- mapM lookupRn subs
+ return (ExportNoDecl x' subs')
+ ExportDoc doc -> do
+ doc' <- renameDoc doc
+ return (ExportDoc doc')
renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName)
renameDocForDecl (doc, fnArgsDoc) =
(,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc
-
renameDocumentation :: Documentation Name -> RnM (Documentation DocName)
renameDocumentation (Documentation mDoc mWarning) =
Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning
-
renameLDocHsSyn :: Located (WithHsDocIdentifiers HsDocString a) -> RnM (Located (WithHsDocIdentifiers HsDocString b))
renameLDocHsSyn (L l doc) = return (L l (WithHsDocIdentifiers (hsDocString doc) []))
-
renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName))
-renameDoc = traverse (traverse rename)
+renameDoc = traverse (traverse renameName)
renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
renameFnArgsDoc = mapM renameDoc
-
renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI)
renameLType = mapM renameType
@@ -236,8 +326,8 @@ renameFamilyResultSig (L loc (TyVarSig _ bndr))
renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI)
renameInjectivityAnn (L loc (InjectivityAnn _ lhs rhs))
- = do { lhs' <- renameL lhs
- ; rhs' <- mapM renameL rhs
+ = do { lhs' <- renameNameL lhs
+ ; rhs' <- mapM renameNameL rhs
; return (L loc (InjectivityAnn noExtField lhs' rhs')) }
renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
@@ -263,7 +353,7 @@ renameType t = case t of
ltype' <- renameLType ltype
return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' })
- HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< rename n
+ HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< renameName n
HsBangTy _ b ltype -> return . HsBangTy noAnn b =<< renameLType ltype
HsStarTy _ isUni -> return (HsStarTy noAnn isUni)
@@ -291,7 +381,7 @@ renameType t = case t of
HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts
HsOpTy _ prom a (L loc op) b -> do
- op' <- rename op
+ op' <- renameName op
a' <- renameLType a
b' <- renameLType b
return (HsOpTy noAnn prom a' (L loc op') b')
@@ -351,11 +441,11 @@ renameHsForAllTelescope tele = case tele of
renameLTyVarBndr :: (flag -> RnM flag') -> LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag' DocNameI)
renameLTyVarBndr rn_flag (L loc (UserTyVar _ fl (L l n)))
= do { fl' <- rn_flag fl
- ; n' <- rename n
+ ; n' <- renameName n
; return (L loc (UserTyVar noExtField fl' (L l n'))) }
renameLTyVarBndr rn_flag (L loc (KindedTyVar _ fl (L lv n) kind))
= do { fl' <- rn_flag fl
- ; n' <- rename n
+ ; n' <- renameName n
; kind' <- renameLKind kind
; return (L loc (KindedTyVar noExtField fl' (L lv n') kind')) }
@@ -366,14 +456,14 @@ renameLContext (L loc context) = do
renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI)
renameInstHead InstHead {..} = do
- cname <- rename ihdClsName
+ cname <- renameName ihdClsName
types <- mapM renameType ihdTypes
itype <- case ihdInstType of
ClassInst { .. } -> ClassInst
<$> mapM renameType clsiCtx
<*> renameLHsQTyVars clsiTyVars
<*> mapM renameSig clsiSigs
- <*> mapM renamePseudoFamilyDecl clsiAssocTys
+ <*> mapM renameDocInstance clsiAssocTys
TypeInst ts -> TypeInst <$> traverse renameType ts
DataInst dd -> DataInst <$> renameTyClD dd
return InstHead
@@ -421,14 +511,14 @@ renameTyClD d = case d of
return (FamDecl { tcdFExt = noExtField, tcdFam = decl' })
SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do
- lname' <- renameL lname
+ lname' <- renameNameL lname
tyvars' <- renameLHsQTyVars tyvars
rhs' <- renameLType rhs
return (SynDecl { tcdSExt = noExtField, tcdLName = lname', tcdTyVars = tyvars'
, tcdFixity = fixity, tcdRhs = rhs' })
DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do
- lname' <- renameL lname
+ lname' <- renameNameL lname
tyvars' <- renameLHsQTyVars tyvars
defn' <- renameDataDefn defn
return (DataDecl { tcdDExt = noExtField, tcdLName = lname', tcdTyVars = tyvars'
@@ -438,7 +528,7 @@ renameTyClD d = case d of
, tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity
, tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
lcontext' <- traverse renameLContext lcontext
- lname' <- renameL lname
+ lname' <- renameNameL lname
ltyvars' <- renameLHsQTyVars ltyvars
lfundeps' <- mapM renameLFunDep lfundeps
lsigs' <- mapM renameLSig lsigs
@@ -455,8 +545,8 @@ renameTyClD d = case d of
where
renameLFunDep :: LHsFunDep GhcRn -> RnM (LHsFunDep DocNameI)
renameLFunDep (L loc (FunDep _ xs ys)) = do
- xs' <- mapM rename (map unLoc xs)
- ys' <- mapM rename (map unLoc ys)
+ xs' <- mapM renameName (map unLoc xs)
+ ys' <- mapM renameName (map unLoc ys)
return (L (locA loc) (FunDep noExtField (map noLocA xs') (map noLocA ys')))
renameLSig (L loc sig) = return . L (locA loc) =<< renameSig sig
@@ -473,7 +563,7 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
, fdResultSig = result
, fdInjectivityAnn = injectivity }) = do
info' <- renameFamilyInfo info
- lname' <- renameL lname
+ lname' <- renameNameL lname
ltyvars' <- renameLHsQTyVars ltyvars
result' <- renameFamilyResultSig result
injectivity' <- renameMaybeInjectivityAnn injectivity
@@ -485,15 +575,6 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
, fdInjectivityAnn = injectivity' })
-renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn
- -> RnM (PseudoFamilyDecl DocNameI)
-renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl
- <$> renameFamilyInfo pfdInfo
- <*> renameL pfdLName
- <*> mapM renameLType pfdTyVars
- <*> renameFamilyResultSig pfdKindSig
-
-
renameFamilyInfo :: FamilyInfo GhcRn -> RnM (FamilyInfo DocNameI)
renameFamilyInfo DataFamily = return DataFamily
renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
@@ -518,7 +599,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
, con_mb_cxt = lcontext, con_args = details
, con_doc = mbldoc
, con_forall = forall_ }) = do
- lname' <- renameL lname
+ lname' <- renameNameL lname
ltyvars' <- mapM (renameLTyVarBndr return) ltyvars
lcontext' <- traverse renameLContext lcontext
details' <- renameH98Details details
@@ -533,7 +614,7 @@ renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs
, con_mb_cxt = lcontext, con_g_args = details
, con_res_ty = res_ty
, con_doc = mbldoc } = do
- lnames' <- mapM renameL lnames
+ lnames' <- mapM renameNameL lnames
bndrs' <- mapM renameOuterTyVarBndrs bndrs
lcontext' <- traverse renameLContext lcontext
details' <- renameGADTDetails details
@@ -576,28 +657,28 @@ renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
renameLFieldOcc (L l (FieldOcc sel lbl)) = do
- sel' <- rename sel
+ sel' <- renameName sel
return $ L l (FieldOcc sel' lbl)
renameSig :: Sig GhcRn -> RnM (Sig DocNameI)
renameSig sig = case sig of
TypeSig _ lnames ltype -> do
- lnames' <- mapM renameL lnames
+ lnames' <- mapM renameNameL lnames
ltype' <- renameLSigWcType ltype
return (TypeSig noExtField lnames' ltype')
ClassOpSig _ is_default lnames sig_ty -> do
- lnames' <- mapM renameL lnames
+ lnames' <- mapM renameNameL lnames
ltype' <- renameLSigType sig_ty
return (ClassOpSig noExtField is_default lnames' ltype')
PatSynSig _ lnames sig_ty -> do
- lnames' <- mapM renameL lnames
+ lnames' <- mapM renameNameL lnames
sig_ty' <- renameLSigType sig_ty
return $ PatSynSig noExtField lnames' sig_ty'
FixSig _ (FixitySig _ lnames fixity) -> do
- lnames' <- mapM renameL lnames
+ lnames' <- mapM renameNameL lnames
return $ FixSig noExtField (FixitySig noExtField lnames' fixity)
MinimalSig _ (L l s) -> do
- s' <- traverse (traverse lookupRnNoWarn) s
+ s' <- traverse (traverse lookupRn) s
return $ MinimalSig noExtField (L l s')
-- we have filtered out all other kinds of signatures in Interface.Create
_ -> error "expected TypeSig"
@@ -605,11 +686,11 @@ renameSig sig = case sig of
renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI)
renameForD (ForeignImport _ lname ltype x) = do
- lname' <- renameL lname
+ lname' <- renameNameL lname
ltype' <- renameLSigType ltype
return (ForeignImport noExtField lname' ltype' (renameForI x))
renameForD (ForeignExport _ lname ltype x) = do
- lname' <- renameL lname
+ lname' <- renameNameL lname
ltype' <- renameLSigType ltype
return (ForeignExport noExtField lname' ltype' (renameForE x))
@@ -670,7 +751,7 @@ renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI)
renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
, feqn_pats = pats, feqn_fixity = fixity
, feqn_rhs = rhs })
- = do { tc' <- renameL tc
+ = do { tc' <- renameNameL tc
; bndrs' <- renameOuterTyVarBndrs bndrs
; pats' <- mapM renameLTypeArg pats
; rhs' <- renameLType rhs
@@ -695,7 +776,7 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
, feqn_pats = pats, feqn_fixity = fixity
, feqn_rhs = defn })
- = do { tc' <- renameL tc
+ = do { tc' <- renameNameL tc
; bndrs' <- renameOuterTyVarBndrs bndrs
; pats' <- mapM renameLTypeArg pats
; defn' <- renameDataDefn defn
@@ -724,37 +805,12 @@ renameWc rn_thing (HsWC { hswc_body = thing })
renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI)
renameDocInstance (inst, idoc, L l n, m) = do
inst' <- renameInstHead inst
- n' <- rename n
+ n' <- renameName n
idoc' <- mapM renameDoc idoc
return (inst', idoc', L l n', m)
-renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI)
-renameExportItem item = case item of
- ExportModule mdl -> return (ExportModule mdl)
- ExportGroup lev id_ doc -> do
- doc' <- renameDoc doc
- return (ExportGroup lev id_ doc')
- ExportDecl decl pats doc subs instances fixities splice -> do
- decl' <- renameLDecl decl
- pats' <- renamePats pats
- doc' <- renameDocForDecl doc
- subs' <- mapM renameSub subs
- instances' <- forM instances renameDocInstance
- fixities' <- forM fixities $ \(name, fixity) -> do
- name' <- lookupRn name
- return (name', fixity)
- return (ExportDecl decl' pats' doc' subs' instances' fixities' splice)
- ExportNoDecl x subs -> do
- x' <- lookupRn x
- subs' <- mapM lookupRn subs
- return (ExportNoDecl x' subs')
- ExportDoc doc -> do
- doc' <- renameDoc doc
- return (ExportDoc doc')
-
-
renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName)
renameSub (n,doc) = do
- n' <- rename n
+ n' <- renameName n
doc' <- renameDocForDecl doc
return (n', doc')
diff --git a/haddock-api/src/Haddock/Interface/RenameType.hs b/haddock-api/src/Haddock/Interface/RenameType.hs
new file mode 100644
index 0000000000..81524ff328
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/RenameType.hs
@@ -0,0 +1,217 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
+module Haddock.Interface.RenameType
+ ( rename
+ ) where
+
+
+import Haddock.Types
+
+import GHC
+import GHC.Types.Name
+import GHC.Data.FastString
+
+import Control.Monad.Trans.State
+
+import qualified Data.List as List
+import Data.Maybe
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+-- | Haskell AST type representation.
+--
+-- This type is used for renaming (more below), essentially the ambiguous (!)
+-- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well,
+-- it was 'OccName' before, but turned out that 'OccName' sometimes also
+-- contains namespace information, differentiating visually same types.
+--
+-- And 'FastString' is used because it is /visual/ part of 'OccName' - it is
+-- not converted to 'String' or alike to avoid new allocations. Additionally,
+-- since it is stored mostly in 'Set', fast comparison of 'FastString' is also
+-- quite nice.
+newtype NameRep
+ = NameRep FastString
+ deriving (Eq)
+
+instance Ord NameRep where
+ compare (NameRep fs1) (NameRep fs2) = uniqCompareFS fs1 fs2
+
+
+getNameRep :: NamedThing name => name -> NameRep
+getNameRep = NameRep . getOccFS
+
+nameRepString :: NameRep -> String
+nameRepString (NameRep fs) = unpackFS fs
+
+stringNameRep :: String -> NameRep
+stringNameRep = NameRep . mkFastString
+
+setInternalNameRep :: SetName name => NameRep -> name -> name
+setInternalNameRep (NameRep fs) = setInternalOccName (mkVarOccFS fs)
+
+setInternalOccName :: SetName name => OccName -> name -> name
+setInternalOccName occ name =
+ setName nname' name
+ where
+ nname = getName name
+ nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
+
+-- | Make given type visually unambiguous.
+--
+-- After applying 'specialize' method, some free type variables may become
+-- visually ambiguous - for example, having @a -> b@ and specializing @a@ to
+-- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to
+-- different type variable than latter one. Applying 'rename' function
+-- will fix that type to be visually unambiguous again (making it something
+-- like @(a -> b0) -> b@).
+rename :: [Name] -> LHsType GhcRn -> LHsType GhcRn
+rename [] typ = typ
+rename fv typ = evalState (traverse renameType typ) env
+ where
+ env = RenameEnv
+ { rneHeadFVs = Map.fromList $ map mkPair fv
+ , rneCtx = Map.empty
+ }
+ mkPair name = (getNameRep name, name)
+
+-- | Renaming monad.
+type Rename name = State (RenameEnv name)
+
+data RenameEnv name = RenameEnv
+ { rneHeadFVs :: Map NameRep Name
+ , rneCtx :: Map Name name
+ }
+
+
+renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
+renameType (HsForAllTy x tele lt) =
+ HsForAllTy x
+ <$> renameForAllTelescope tele
+ <*> renameLType lt
+renameType (HsQualTy x lctxt lt) =
+ HsQualTy x
+ <$> renameLContext lctxt
+ <*> renameLType lt
+renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name
+renameType t@(HsStarTy _ _) = pure t
+renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la
+renameType (HsAppKindTy x lt tk lk) = HsAppKindTy x <$> renameLType lt <*> pure tk <*> renameLKind lk
+renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType la <*> renameLType lr
+renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
+renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
+renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt
+renameType (HsOpTy x f la lop lb) =
+ HsOpTy x <$> pure f <*> renameLType la <*> locatedN renameName lop <*> renameLType lb
+renameType (HsParTy x lt) = HsParTy x <$> renameLType lt
+renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt
+renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk
+renameType t@(HsSpliceTy _ _) = pure t
+renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc
+renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt
+renameType t@(HsRecTy _ _) = pure t
+renameType t@(XHsType _) = pure t
+renameType (HsExplicitListTy x ip ltys) =
+ HsExplicitListTy x ip <$> renameLTypes ltys
+renameType (HsExplicitTupleTy x ltys) =
+ HsExplicitTupleTy x <$> renameLTypes ltys
+renameType t@(HsTyLit _ _) = pure t
+renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
+
+renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)
+renameHsArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p
+renameHsArrow mult = pure mult
+
+
+renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
+renameLType = located renameType
+
+renameLKind :: LHsKind GhcRn -> Rename (IdP GhcRn) (LHsKind GhcRn)
+renameLKind = renameLType
+
+renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
+renameLTypes = mapM renameLType
+
+renameLContext :: LHsContext GhcRn -> Rename (IdP GhcRn) (LHsContext GhcRn)
+renameLContext (L l ctxt) = do
+ ctxt' <- renameContext ctxt
+ return (L l ctxt')
+
+renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
+renameContext = renameLTypes
+
+renameForAllTelescope :: HsForAllTelescope GhcRn
+ -> Rename (IdP GhcRn) (HsForAllTelescope GhcRn)
+renameForAllTelescope (HsForAllVis x bndrs) =
+ HsForAllVis x <$> mapM renameLBinder bndrs
+renameForAllTelescope (HsForAllInvis x bndrs) =
+ HsForAllInvis x <$> mapM renameLBinder bndrs
+
+renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn)
+renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> locatedN renameName lname
+renameBinder (KindedTyVar x fl lname lkind) =
+ KindedTyVar x fl <$> locatedN renameName lname <*> located renameType lkind
+
+renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn)
+renameLBinder = located renameBinder
+
+-- | Core renaming logic.
+renameName :: SetName name => name -> Rename name name
+renameName name = do
+ RenameEnv { .. } <- get
+ case Map.lookup (getName name) rneCtx of
+ Nothing
+ | Just headTv <- Map.lookup (getNameRep name) rneHeadFVs
+ , headTv /= getName name -> freshName name
+ Just name' -> return name'
+ _ -> return name
+
+
+-- | Generate fresh occurrence name, put it into context and return.
+freshName :: SetName name => name -> Rename name name
+freshName name = do
+ taken <- takenNames
+ let name' = setInternalNameRep (findFreshName taken rep) name
+ modify $ \rne -> rne
+ { rneCtx = Map.insert (getName name) name' (rneCtx rne) }
+ return name'
+ where
+ nname = getName name
+ rep = getNameRep nname
+
+
+takenNames :: NamedThing name => Rename name (Set NameRep)
+takenNames = do
+ RenameEnv { .. } <- get
+ return $ Set.unions [headReps rneHeadFVs, ctxElems rneCtx]
+ where
+ headReps = Set.fromList . Map.keys
+ ctxElems = Set.fromList . map getNameRep . Map.elems
+
+
+findFreshName :: Set NameRep -> NameRep -> NameRep
+findFreshName taken =
+ fromJust . List.find isFresh . alternativeNames
+ where
+ isFresh = not . flip Set.member taken
+
+
+alternativeNames :: NameRep -> [NameRep]
+alternativeNames name =
+ [ stringNameRep $ str ++ show i | i :: Int <- [0..] ]
+ where
+ str = nameRepString name
+
+
+located :: Functor f => (a -> f b) -> GenLocated l a -> f (GenLocated l b)
+located f (L loc e) = L loc <$> f e
+
+locatedN :: Functor f => (a -> f b) -> LocatedN a -> f (LocatedN b)
+locatedN f (L loc e) = L loc <$> f e
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
deleted file mode 100644
index f79ec317eb..0000000000
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ /dev/null
@@ -1,407 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE GADTs #-}
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
-module Haddock.Interface.Specialize
- ( specializeInstHead
- ) where
-
-
-import Haddock.GhcUtils ( hsTyVarBndrName )
-import Haddock.Syb
-import Haddock.Types
-
-import GHC
-import GHC.Types.Name
-import GHC.Data.FastString
-import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )
-
-import Control.Monad
-import Control.Monad.Trans.State
-
-import Data.Data
-import qualified Data.List as List
-import Data.Maybe
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Set (Set)
-import qualified Data.Set as Set
-
--- | Instantiate all occurrences of given names with corresponding types.
-specialize :: Data a => [(Name, HsType GhcRn)] -> a -> a
-specialize specs = go spec_map0
- where
- go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x
- go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map
-
- strip_kind_sig :: HsType GhcRn -> HsType GhcRn
- strip_kind_sig (HsKindSig _ (L _ t) _) = t
- strip_kind_sig typ = typ
-
- specialize_ty_var :: Map Name (HsType GhcRn) -> HsType GhcRn -> HsType GhcRn
- specialize_ty_var spec_map (HsTyVar _ _ (L _ name'))
- | Just t <- Map.lookup name' spec_map = t
- specialize_ty_var _ typ = typ
-
- -- This is a tricky recursive definition. By adding in the specializations
- -- one by one, we should avoid infinite loops.
- spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty specs
-
-{-# SPECIALIZE specialize :: [(Name, HsType GhcRn)] -> HsType GhcRn -> HsType GhcRn #-}
-
--- | Instantiate given binders with corresponding types.
---
--- Again, it is just a convenience function around 'specialize'. Note that
--- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: Data a => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a
-specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs
- where
- bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs
-
-
-
-specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn]
- -> PseudoFamilyDecl GhcRn
- -> PseudoFamilyDecl GhcRn
-specializePseudoFamilyDecl bndrs typs decl =
- decl {pfdTyVars = map (fmap (specializeTyVarBndrs bndrs typs)) (pfdTyVars decl)}
-
-specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
- -> Sig GhcRn
- -> Sig GhcRn
-specializeSig bndrs typs (TypeSig _ lnames typ) =
- TypeSig noAnn lnames (typ {hswc_body = noLocA typ'})
- where
- true_type :: HsSigType GhcRn
- true_type = unLoc (dropWildCards typ)
- typ' :: HsSigType GhcRn
- typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type
- fv = foldr Set.union Set.empty . map freeVariablesType $ typs
-specializeSig _ _ sig = sig
-
-
--- | Make all details of instance head (signatures, associated types)
--- specialized to that particular instance type.
-specializeInstHead :: InstHead GhcRn -> InstHead GhcRn
-specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
- ihd { ihdInstType = instType' }
- where
- instType' = clsi
- { clsiSigs = map specializeSig' clsiSigs
- , clsiAssocTys = map specializeFamilyDecl' clsiAssocTys
- }
- specializeSig' = specializeSig clsiTyVars ihdTypes
- specializeFamilyDecl' = specializePseudoFamilyDecl clsiTyVars ihdTypes
-specializeInstHead ihd = ihd
-
-
--- | Make given type use tuple and list literals where appropriate.
---
--- After applying 'specialize' function some terms may not use idiomatic list
--- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This
--- can be fixed using 'sugar' function, that will turn such types into @[a]@
--- and @(a, b, c)@.
-sugar :: HsType GhcRn -> HsType GhcRn
-sugar = sugarOperators . sugarTuples . sugarLists
-
-sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
-sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp)
- | getName name == listTyConName = HsListTy noAnn ltyp
-sugarLists typ = typ
-
-
-sugarTuples :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
-sugarTuples typ =
- aux [] typ
- where
- aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp
- aux apps (HsParTy _ (L _ typ')) = aux apps typ'
- aux apps (HsTyVar _ _ (L _ name))
- | isBuiltInSyntax name' && suitable = HsTupleTy noAnn HsBoxedOrConstraintTuple apps
- where
- name' = getName name
- strName = getOccString name
- suitable = case parseTupleArity strName of
- Just arity -> arity == length apps
- Nothing -> False
- aux _ _ = typ
-
-
-sugarOperators :: HsType GhcRn -> HsType GhcRn
-sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ prom (L l name))) la)) lb)
- | isSymOcc $ getOccName name' = mkHsOpTy prom la (L l name) lb
- | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) la lb
- where
- name' = getName name
-sugarOperators typ = typ
-
-
--- | Compute arity of given tuple operator.
---
--- >>> parseTupleArity "(,,)"
--- Just 3
---
--- >>> parseTupleArity "(,,,,)"
--- Just 5
---
--- >>> parseTupleArity "abc"
--- Nothing
---
--- >>> parseTupleArity "()"
--- Nothing
-parseTupleArity :: String -> Maybe Int
-parseTupleArity ('(':commas) = do
- n <- parseCommas commas
- guard $ n /= 0
- return $ n + 1
- where
- parseCommas (',':rest) = (+ 1) <$> parseCommas rest
- parseCommas ")" = Just 0
- parseCommas _ = Nothing
-parseTupleArity _ = Nothing
-
-
--- | Haskell AST type representation.
---
--- This type is used for renaming (more below), essentially the ambiguous (!)
--- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well,
--- it was 'OccName' before, but turned out that 'OccName' sometimes also
--- contains namespace information, differentiating visually same types.
---
--- And 'FastString' is used because it is /visual/ part of 'OccName' - it is
--- not converted to 'String' or alike to avoid new allocations. Additionally,
--- since it is stored mostly in 'Set', fast comparison of 'FastString' is also
--- quite nice.
-newtype NameRep
- = NameRep FastString
- deriving (Eq)
-
-instance Ord NameRep where
- compare (NameRep fs1) (NameRep fs2) = uniqCompareFS fs1 fs2
-
-
-getNameRep :: NamedThing name => name -> NameRep
-getNameRep = NameRep . getOccFS
-
-nameRepString :: NameRep -> String
-nameRepString (NameRep fs) = unpackFS fs
-
-stringNameRep :: String -> NameRep
-stringNameRep = NameRep . mkFastString
-
-setInternalNameRep :: SetName name => NameRep -> name -> name
-setInternalNameRep (NameRep fs) = setInternalOccName (mkVarOccFS fs)
-
-setInternalOccName :: SetName name => OccName -> name -> name
-setInternalOccName occ name =
- setName nname' name
- where
- nname = getName name
- nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
-
-
--- | Compute set of free variables of a given 'HsType'.
-freeVariablesType :: HsType GhcRn -> Set Name
-freeVariablesType =
- everythingWithState Set.empty Set.union
- (mkQ (\ctx -> (Set.empty, ctx)) queryType)
-
--- | Compute set of free variables of a given 'HsType'.
-freeVariablesSigType :: HsSigType GhcRn -> Set Name
-freeVariablesSigType =
- everythingWithState Set.empty Set.union
- (mkQ (\ctx -> (Set.empty, ctx)) queryType `extQ` querySigType)
-
-queryType :: HsType GhcRn -> Set Name -> (Set Name, Set Name)
-queryType term ctx = case term of
- HsForAllTy _ tele _ ->
- (Set.empty, Set.union ctx (teleNames tele))
- HsTyVar _ _ (L _ name)
- | getName name `Set.member` ctx -> (Set.empty, ctx)
- | otherwise -> (Set.singleton $ getName name, ctx)
- _ -> (Set.empty, ctx)
- where
- teleNames :: HsForAllTelescope GhcRn -> Set Name
- teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs
- teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs
-
-querySigType :: HsSigType GhcRn -> Set Name -> (Set Name, Set Name)
-querySigType (HsSig { sig_bndrs = outer_bndrs }) ctx =
- (Set.empty, Set.union ctx (bndrsNames (hsOuterExplicitBndrs outer_bndrs)))
-
-bndrsNames :: [LHsTyVarBndr flag GhcRn] -> Set Name
-bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
-
-
--- | Make given type visually unambiguous.
---
--- After applying 'specialize' method, some free type variables may become
--- visually ambiguous - for example, having @a -> b@ and specializing @a@ to
--- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to
--- different type variable than latter one. Applying 'rename' function
--- will fix that type to be visually unambiguous again (making it something
--- like @(a -> b0) -> b@).
-rename :: Set Name -> HsSigType GhcRn -> HsSigType GhcRn
-rename fv typ = evalState (renameSigType typ) env
- where
- env = RenameEnv
- { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv
- , rneSigFVs = Set.map getNameRep $ freeVariablesSigType typ
- , rneCtx = Map.empty
- }
- mkPair name = (getNameRep name, name)
-
--- | Renaming monad.
-type Rename name = State (RenameEnv name)
-
-data RenameEnv name = RenameEnv
- { rneHeadFVs :: Map NameRep Name
- , rneSigFVs :: Set NameRep
- , rneCtx :: Map Name name
- }
-
-
-renameSigType :: HsSigType GhcRn -> Rename (IdP GhcRn) (HsSigType GhcRn)
-renameSigType (HsSig x bndrs body) =
- HsSig x <$> renameOuterTyVarBndrs bndrs <*> renameLType body
-
-renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn
- -> Rename (IdP GhcRn) (HsOuterTyVarBndrs flag GhcRn)
-renameOuterTyVarBndrs (HsOuterImplicit imp_tvs) =
- HsOuterImplicit <$> mapM renameName imp_tvs
-renameOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
- HsOuterExplicit x <$> mapM renameLBinder exp_bndrs
-
-renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
-renameType (HsForAllTy x tele lt) =
- HsForAllTy x
- <$> renameForAllTelescope tele
- <*> renameLType lt
-renameType (HsQualTy x lctxt lt) =
- HsQualTy x
- <$> renameLContext lctxt
- <*> renameLType lt
-renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name
-renameType t@(HsStarTy _ _) = pure t
-renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la
-renameType (HsAppKindTy x lt at lk) = HsAppKindTy x <$> renameLType lt <*> pure at <*> renameLKind lk
-renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType la <*> renameLType lr
-renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
-renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
-renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt
-renameType (HsOpTy x prom la lop lb) =
- HsOpTy x prom <$> renameLType la <*> locatedN renameName lop <*> renameLType lb
-renameType (HsParTy x lt) = HsParTy x <$> renameLType lt
-renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt
-renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk
-renameType t@(HsSpliceTy _ _) = pure t
-renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc
-renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt
-renameType t@(HsRecTy _ _) = pure t
-renameType t@(XHsType _) = pure t
-renameType (HsExplicitListTy x ip ltys) =
- HsExplicitListTy x ip <$> renameLTypes ltys
-renameType (HsExplicitTupleTy x ltys) =
- HsExplicitTupleTy x <$> renameLTypes ltys
-renameType t@(HsTyLit _ _) = pure t
-renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
-
-renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)
-renameHsArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p
-renameHsArrow mult = pure mult
-
-
-renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
-renameLType = located renameType
-
-renameLKind :: LHsKind GhcRn -> Rename (IdP GhcRn) (LHsKind GhcRn)
-renameLKind = renameLType
-
-renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
-renameLTypes = mapM renameLType
-
-renameLContext :: LHsContext GhcRn -> Rename (IdP GhcRn) (LHsContext GhcRn)
-renameLContext (L l ctxt) = do
- ctxt' <- renameContext ctxt
- return (L l ctxt')
-
-renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
-renameContext = renameLTypes
-
-renameForAllTelescope :: HsForAllTelescope GhcRn
- -> Rename (IdP GhcRn) (HsForAllTelescope GhcRn)
-renameForAllTelescope (HsForAllVis x bndrs) =
- HsForAllVis x <$> mapM renameLBinder bndrs
-renameForAllTelescope (HsForAllInvis x bndrs) =
- HsForAllInvis x <$> mapM renameLBinder bndrs
-
-renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn)
-renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> locatedN renameName lname
-renameBinder (KindedTyVar x fl lname lkind) =
- KindedTyVar x fl <$> locatedN renameName lname <*> located renameType lkind
-
-renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn)
-renameLBinder = located renameBinder
-
--- | Core renaming logic.
-renameName :: SetName name => name -> Rename name name
-renameName name = do
- RenameEnv { .. } <- get
- case Map.lookup (getName name) rneCtx of
- Nothing
- | Just headTv <- Map.lookup (getNameRep name) rneHeadFVs
- , headTv /= getName name -> freshName name
- Just name' -> return name'
- _ -> return name
-
-
--- | Generate fresh occurrence name, put it into context and return.
-freshName :: SetName name => name -> Rename name name
-freshName name = do
- taken <- takenNames
- let name' = setInternalNameRep (findFreshName taken rep) name
- modify $ \rne -> rne
- { rneCtx = Map.insert (getName name) name' (rneCtx rne) }
- return name'
- where
- nname = getName name
- rep = getNameRep nname
-
-
-takenNames :: NamedThing name => Rename name (Set NameRep)
-takenNames = do
- RenameEnv { .. } <- get
- return $ Set.unions [headReps rneHeadFVs, rneSigFVs, ctxElems rneCtx]
- where
- headReps = Set.fromList . Map.keys
- ctxElems = Set.fromList . map getNameRep . Map.elems
-
-
-findFreshName :: Set NameRep -> NameRep -> NameRep
-findFreshName taken =
- fromJust . List.find isFresh . alternativeNames
- where
- isFresh = not . flip Set.member taken
-
-
-alternativeNames :: NameRep -> [NameRep]
-alternativeNames name =
- [ stringNameRep $ str ++ show i | i :: Int <- [0..] ]
- where
- str = nameRepString name
-
-
-located :: Functor f => (a -> f b) -> GenLocated l a -> f (GenLocated l b)
-located f (L loc e) = L loc <$> f e
-
-locatedN :: Functor f => (a -> f b) -> LocatedN a -> f (LocatedN b)
-locatedN f (L loc e) = L loc <$> f e
-
-
-tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn
-tyVarName (UserTyVar _ _ name) = unLoc name
-tyVarName (KindedTyVar _ _ (L _ name) _) = name
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index c7613e89fc..a2aaa1ee65 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -75,7 +77,7 @@ mkPackageInterfaces :: Visibility -> InterfaceFile -> PackageInterfaces
mkPackageInterfaces piVisibility
InterfaceFile { ifPackageInfo
, ifInstalledIfaces
- } =
+ } =
PackageInterfaces { piPackageInfo = ifPackageInfo
, piVisibility
, piInstalledInterfaces = ifInstalledIfaces
@@ -210,8 +212,7 @@ readInterfaceFile :: NameCache
-> IO (Either String InterfaceFile)
readInterfaceFile name_cache filename bypass_checks = do
bh <- readBinMem filename
-
- magic <- get bh
+ magic <- get bh
if magic /= binaryInterfaceMagic
then return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename
else do
@@ -310,12 +311,13 @@ putInterfaceFile_ bh (InterfaceFile env info ifaces) = do
put_ bh ifaces
instance Binary InstalledInterface where
- put_ bh (InstalledInterface modu is_sig info docMap argMap
+ put_ bh (InstalledInterface modu is_sig info docMap argMap defMeths
exps visExps opts fixMap) = do
put_ bh modu
put_ bh is_sig
put_ bh info
lazyPut bh (docMap, argMap)
+ put_ bh defMeths
put_ bh exps
put_ bh visExps
put_ bh opts
@@ -326,13 +328,13 @@ instance Binary InstalledInterface where
is_sig <- get bh
info <- get bh
~(docMap, argMap) <- lazyGet bh
+ defMeths <- get bh
exps <- get bh
visExps <- get bh
opts <- get bh
fixMap <- get bh
- return (InstalledInterface modu is_sig info docMap argMap
- exps visExps opts fixMap)
-
+ return (InstalledInterface modu is_sig info
+ docMap argMap defMeths exps visExps opts fixMap)
instance Binary DocOption where
put_ bh OptHide = do
@@ -345,6 +347,8 @@ instance Binary DocOption where
putByte bh 3
put_ bh OptShowExtensions = do
putByte bh 4
+ put_ bh OptPrintRuntimeRep = do
+ putByte bh 5
get bh = do
h <- getByte bh
case h of
@@ -358,8 +362,9 @@ instance Binary DocOption where
return OptNotHome
4 -> do
return OptShowExtensions
- _ -> fail "invalid binary data found"
-
+ 5 -> do
+ return OptPrintRuntimeRep
+ n -> fail $ "invalid binary data found: " <> show n
instance Binary Example where
put_ bh (Example expression result) = do
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 78bfe1a1f9..a912eb8c91 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -45,6 +45,11 @@ module Haddock.Options (
import qualified Data.Char as Char
+import Data.List (dropWhileEnd)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
import Data.Version
import Control.Applicative
import GHC.Data.FastString
@@ -115,6 +120,7 @@ data Flag
| Flag_SinceQualification String
| Flag_IgnoreLinkSymbol String
| Flag_ParCount (Maybe Int)
+ | Flag_TraceArgs
deriving (Eq, Show)
@@ -232,7 +238,9 @@ options backwardsCompat =
Option [] ["ignore-link-symbol"] (ReqArg Flag_IgnoreLinkSymbol "SYMBOL")
"name of a symbol which does not trigger a warning in case of link issue",
Option ['j'] [] (OptArg (\count -> Flag_ParCount (fmap read count)) "n")
- "load modules in parallel"
+ "load modules in parallel",
+ Option [] ["trace-args"] (NoArg Flag_TraceArgs)
+ "print the arguments provided for this invocation to stdout"
]
@@ -332,7 +340,6 @@ qualification flags =
["full"] -> Right OptFullQual
["local"] -> Right OptLocalQual
["relative"] -> Right OptRelativeQual
- ["aliased"] -> Right OptAliasedQual
[arg] -> Left $ "unknown qualification type " ++ show arg
_:_ -> Left "qualification option given multiple times"
@@ -353,8 +360,41 @@ verbosity flags =
Left e -> throwE e
Right v -> v
-ignoredSymbols :: [Flag] -> [String]
-ignoredSymbols flags = [ symbol | Flag_IgnoreLinkSymbol symbol <- flags ]
+-- | Get the ignored symbols from the given flags. These are the symbols for
+-- which no link warnings will be generated if their link destinations cannot be
+-- determined.
+--
+-- Symbols may be provided as qualified or unqualified names (e.g.
+-- 'Data.Map.dropWhileEnd' or 'dropWhileEnd', resp). If qualified, no link
+-- warnings will be produced for occurances of that name when it is imported
+-- from that module. If unqualified, no link warnings will be produced for any
+-- occurances of that name from any module.
+ignoredSymbols :: [Flag] -> Map (Maybe String) (Set String)
+ignoredSymbols flags =
+ foldr addToMap Map.empty [ splitSymbol symbol | Flag_IgnoreLinkSymbol symbol <- flags ]
+ where
+ -- Split a symbol into its module name and unqualified name, producing
+ -- 'Nothing' for the module name if the given symbol is already unqualified
+ splitSymbol :: String -> (Maybe String, String)
+ splitSymbol s =
+ -- Drop the longest suffix not containing a '.' character
+ case dropWhileEnd (/= '.') s of
+
+ -- If the longest suffix is empty, there was no '.'.
+ -- Assume it is an unqualified name (no module string).
+ "" -> (Nothing, s)
+
+ -- If the longest suffix is not empty, there was a '.'.
+ -- Assume it is a qualified name. `s'` will be the module string followed
+ -- by the last '.', e.g. "Data.List.", so take `init s'` as the module
+ -- string. Drop the length of `s'` from the original string `s` to
+ -- obtain to the unqualified name.
+ s' -> (Just $ init s', drop (length s') s)
+
+ -- Add a (module name, name) pair to the map from modules to their ignored
+ -- symbols
+ addToMap :: (Maybe String, String) -> Map (Maybe String) (Set String) -> Map (Maybe String) (Set String)
+ addToMap (m, name) symbs = Map.insertWith (Set.union) m (Set.singleton name) symbs
ghcFlags :: [Flag] -> [String]
ghcFlags flags = [ option | Flag_OptGhc option <- flags ]
diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs
deleted file mode 100644
index fc946c8e5f..0000000000
--- a/haddock-api/src/Haddock/Syb.hs
+++ /dev/null
@@ -1,113 +0,0 @@
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Haddock.Syb
- ( everything, everythingButType, everythingWithState
- , everywhere, everywhereButType
- , mkT, mkQ, extQ
- , combine
- ) where
-
-
-import Data.Data
-import Control.Applicative
-import Data.Maybe
-import Data.Foldable
-
--- | Returns true if a == t.
--- requires AllowAmbiguousTypes
-isType :: forall a b. (Typeable a, Typeable b) => b -> Bool
-isType _ = isJust $ eqT @a @b
-
--- | Perform a query on each level of a tree.
---
--- This is stolen directly from SYB package and copied here to not introduce
--- additional dependencies.
-everything :: (r -> r -> r)
- -> (forall a. Data a => a -> r)
- -> (forall a. Data a => a -> r)
-everything k f x = foldl' k (f x) (gmapQ (everything k f) x)
-
--- | Variation of "everything" with an added stop condition
--- Just like 'everything', this is stolen from SYB package.
-everythingBut :: (r -> r -> r)
- -> (forall a. Data a => a -> (r, Bool))
- -> (forall a. Data a => a -> r)
-everythingBut k f x = let (v, stop) = f x
- in if stop
- then v
- else foldl' k v (gmapQ (everythingBut k f) x)
-
--- | Variation of "everything" that does not recurse into children of type t
--- requires AllowAmbiguousTypes
-everythingButType ::
- forall t r. (Typeable t)
- => (r -> r -> r)
- -> (forall a. Data a => a -> r)
- -> (forall a. Data a => a -> r)
-everythingButType k f = everythingBut k $ (,) <$> f <*> isType @t
-
--- | Perform a query with state on each level of a tree.
---
--- This is the same as 'everything' but allows for stateful computations. In
--- SYB it is called @everythingWithContext@ but I find this name somewhat
--- nicer.
-everythingWithState :: s -> (r -> r -> r)
- -> (forall a. Data a => a -> s -> (r, s))
- -> (forall a. Data a => a -> r)
-everythingWithState s k f x =
- let (r, s') = f x s
- in foldl' k r (gmapQ (everythingWithState s' k f) x)
-
--- | Apply transformation on each level of a tree.
---
--- Just like 'everything', this is stolen from SYB package.
-everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a)
-everywhere f = f . gmapT (everywhere f)
-
--- | Variation on everywhere with an extra stop condition
--- Just like 'everything', this is stolen from SYB package.
-everywhereBut :: (forall a. Data a => a -> Bool)
- -> (forall a. Data a => a -> a)
- -> (forall a. Data a => a -> a)
-everywhereBut q f x
- | q x = x
- | otherwise = f (gmapT (everywhereBut q f) x)
-
--- | Variation of "everywhere" that does not recurse into children of type t
--- requires AllowAmbiguousTypes
-everywhereButType :: forall t . (Typeable t)
- => (forall a. Data a => a -> a)
- -> (forall a. Data a => a -> a)
-everywhereButType = everywhereBut (isType @t)
-
--- | Create generic transformation.
---
--- Another function stolen from SYB package.
-mkT :: (Typeable a, Typeable b) => (b -> b) -> (a -> a)
-mkT f = case cast f of
- Just f' -> f'
- Nothing -> id
-
--- | Create generic query.
---
--- Another function stolen from SYB package.
-mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
-(r `mkQ` br) a = case cast a of
- Just b -> br b
- Nothing -> r
-
-
--- | Extend a generic query by a type-specific case.
---
--- Another function stolen from SYB package.
-extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q
-extQ f g a = maybe (f a) g (cast a)
-
--- | Combine two queries into one using alternative combinator.
-combine :: Alternative f => (forall a. Data a => a -> f r)
- -> (forall a. Data a => a -> f r)
- -> (forall a. Data a => a -> f r)
-combine f g x = f x <|> g x
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 61eb334eb8..57da9c8533 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,13 +1,21 @@
-{-# LANGUAGE CPP, DeriveDataTypeable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
@@ -30,22 +38,23 @@ module Haddock.Types (
, HsDocString, LHsDocString
, Fixity(..)
, module Documentation.Haddock.Types
-
- -- $ Reexports
- , runWriter
- , tell
) where
import Control.DeepSeq
import Control.Exception (throw)
import Control.Monad.Catch
-import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Writer.Strict (Writer, WriterT, MonadWriter(..), lift, runWriter, runWriterT)
+import Control.Monad.State.Strict
import Data.Typeable (Typeable)
import Data.Map (Map)
import Data.Data (Data)
+import qualified Data.Set as Set
import Documentation.Haddock.Types
+import qualified GHC.Data.Strict as Strict
import GHC.Types.Fixity (Fixity(..))
+import GHC.Types.Name (stableNameCmp)
+import GHC.Types.Name.Reader (RdrName(..))
+import GHC.Types.SourceText (SourceText(..))
+import GHC.Types.SrcLoc (BufSpan(..), BufPos(..))
import GHC.Types.Var (Specificity)
import GHC
@@ -64,17 +73,17 @@ type InstIfaceMap = Map Module InstalledInterface -- TODO: rename
type DocMap a = Map Name (MDoc a)
type ArgMap a = Map Name (Map Int (MDoc a))
type SubMap = Map Name [Name]
-type DeclMap = Map Name [LHsDecl GhcRn]
+type DeclMap = Map Name DeclMapEntry
type InstMap = Map RealSrcSpan Name
type FixMap = Map Name Fixity
type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
+type WarningMap = Map Name (Doc Name)
-----------------------------------------------------------------------------
--- * Interface
+-- * Interfaces and Interface creation
-----------------------------------------------------------------------------
-
-- | 'Interface' holds all information used to render a single Haddock page.
-- It represents the /interface/ of a module. The core business of Haddock
-- lies in creating this structure. Note that the record contains some fields
@@ -88,9 +97,6 @@ data Interface = Interface
-- | Is this a signature?
, ifaceIsSig :: !Bool
- -- | Original file name of the module.
- , ifaceOrigFilename :: !FilePath
-
-- | Textual information about the module.
, ifaceInfo :: !(HaddockModInfo Name)
@@ -101,63 +107,51 @@ data Interface = Interface
, ifaceRnDoc :: !(Documentation DocName)
-- | Haddock options for this module (prune, ignore-exports, etc).
- , ifaceOptions :: ![DocOption]
-
- -- | Declarations originating from the module. Excludes declarations without
- -- names (instances and stand-alone documentation comments). Includes
- -- names of subordinate declarations mapped to their parent declarations.
- , ifaceDeclMap :: !(Map Name [LHsDecl GhcRn])
+ , ifaceOptions :: [DocOption]
-- | Documentation of declarations originating from the module (including
-- subordinates).
, ifaceDocMap :: !(DocMap Name)
, ifaceArgMap :: !(ArgMap Name)
- -- | Documentation of declarations originating from the module (including
- -- subordinates).
- , ifaceRnDocMap :: !(DocMap DocName)
- , ifaceRnArgMap :: !(ArgMap DocName)
+ -- | The names of all the default methods for classes defined in this module
+ , ifaceDefMeths :: !([(OccName, Name)])
, ifaceFixMap :: !(Map Name Fixity)
- , ifaceExportItems :: ![ExportItem GhcRn]
- , ifaceRnExportItems :: ![ExportItem DocNameI]
+ , ifaceExportItems :: [ExportItem GhcRn]
+ , ifaceRnExportItems :: [ExportItem DocNameI]
-- | All names exported by the module.
- , ifaceExports :: ![Name]
+ , ifaceExports :: [Name]
-- | All \"visible\" names exported by the module.
-- A visible name is a name that will show up in the documentation of the
-- module.
- , ifaceVisibleExports :: ![Name]
-
- -- | Aliases of module imports as in @import A.B.C as C@.
- , ifaceModuleAliases :: !AliasMap
+ --
+ -- Names from modules that are entirely re-exported don't count as visible.
+ , ifaceVisibleExports :: [Name]
-- | Instances exported by the module.
- , ifaceInstances :: ![ClsInst]
- , ifaceFamInstances :: ![FamInst]
+ , ifaceInstances :: [ClsInst]
-- | Orphan instances
- , ifaceOrphanInstances :: ![DocInstance GhcRn]
- , ifaceRnOrphanInstances :: ![DocInstance DocNameI]
+ , ifaceOrphanInstances :: [DocInstance GhcRn]
+ , ifaceRnOrphanInstances :: [DocInstance DocNameI]
-- | The number of haddockable and haddocked items in the module, as a
-- tuple. Haddockable items are the exports and the module itself.
- , ifaceHaddockCoverage :: !(Int, Int)
+ , ifaceHaddockCoverage :: (Int, Int)
-- | Warnings for things defined in this module.
- , ifaceWarningMap :: !WarningMap
+ , ifaceWarningMap :: WarningMap
-- | Tokenized source code of module (available if Haddock is invoked with
-- source generation flag).
- , ifaceHieFile :: !(Maybe FilePath)
+ , ifaceHieFile :: !FilePath
, ifaceDynFlags :: !DynFlags
}
-type WarningMap = Map Name (Doc Name)
-
-
-- | A subset of the fields of 'Interface' that we store in the interface
-- files.
data InstalledInterface = InstalledInterface
@@ -177,6 +171,9 @@ data InstalledInterface = InstalledInterface
, instArgMap :: ArgMap Name
+ -- | The names of all the default methods for classes defined in this module
+ , instDefMeths :: [(OccName,Name)]
+
-- | All names exported by this module.
, instExports :: [Name]
@@ -191,56 +188,91 @@ data InstalledInterface = InstalledInterface
, instFixMap :: Map Name Fixity
}
-
-- | Convert an 'Interface' to an 'InstalledInterface'
toInstalledIface :: Interface -> InstalledInterface
toInstalledIface interface = InstalledInterface
- { instMod = ifaceMod interface
- , instIsSig = ifaceIsSig interface
- , instInfo = ifaceInfo interface
- , instDocMap = ifaceDocMap interface
- , instArgMap = ifaceArgMap interface
- , instExports = ifaceExports interface
- , instVisibleExports = ifaceVisibleExports interface
- , instOptions = ifaceOptions interface
- , instFixMap = ifaceFixMap interface
+ { instMod = interface.ifaceMod
+ , instIsSig = interface.ifaceIsSig
+ , instInfo = interface.ifaceInfo
+ , instDocMap = interface.ifaceDocMap
+ , instArgMap = interface.ifaceArgMap
+ , instExports = interface.ifaceExports
+ , instVisibleExports = interface.ifaceVisibleExports
+ , instOptions = interface.ifaceOptions
+ , instFixMap = interface.ifaceFixMap
+ , instDefMeths = interface.ifaceDefMeths
}
+-- | A monad in which we create Haddock interfaces. Not to be confused with
+-- `GHC.Tc.Types.IfM` which is used to write GHC interfaces.
+--
+-- In the past `createInterface` was running in the `Ghc` monad but proved hard
+-- to sustain as soon as we moved over for Haddock to be a plugin. Also abstracting
+-- over the Ghc specific clarifies where side effects happen.
+newtype IfM m a = IfM { unIfM :: StateT (IfEnv m) m a }
+
+deriving newtype instance Functor m => Functor (IfM m)
+deriving newtype instance (Monad m, Applicative m) => Applicative (IfM m)
+deriving newtype instance Monad m => Monad (IfM m)
+deriving newtype instance MonadIO m => MonadIO (IfM m)
+deriving newtype instance Monad m => MonadState (IfEnv m) (IfM m)
+
+-- | Interface creation environment. The name sets are used primarily during
+-- processing of doc strings to avoid emitting the same type of warning for the
+-- same name twice. This was previously done using a Writer monad and then
+-- nubbing the list of warning messages after accumulation. This new approach
+-- was implemented to avoid the nubbing of potentially large lists of strings.
+data IfEnv m = IfEnv
+ {
+ -- | Lookup names in the environment.
+ ifeLookupName :: Name -> m (Maybe TyThing)
------------------------------------------------------------------------------
--- * Export items & declarations
------------------------------------------------------------------------------
-
+ -- | Names which we have warned about for being out of scope
+ , ifeOutOfScopeNames :: !(Set.Set String)
-data ExportItem name
+ -- | Names which we have warned about for being ambiguous
+ , ifeAmbiguousNames :: !(Set.Set String)
+ }
- -- | An exported declaration.
- = ExportDecl
+-- | Run an `IfM` action.
+runIfM
+ :: (Monad m)
+ -- | Lookup a global name in the current session. Used in cases
+ -- where declarations don't
+ => (Name -> m (Maybe TyThing))
+ -- | The action to run.
+ -> IfM m a
+ -- | Result and accumulated error/warning messages.
+ -> m a
+runIfM lookup_name action = do
+ let
+ if_env = IfEnv
{
- -- | A declaration.
- expItemDecl :: !(LHsDecl name)
+ ifeLookupName = lookup_name
+ , ifeOutOfScopeNames = Set.empty
+ , ifeAmbiguousNames = Set.empty
+ }
+ evalStateT (unIfM action) if_env
- -- | Bundled patterns for a data type declaration
- , expItemPats :: ![(HsDecl name, DocForDecl (IdP name))]
+-- | Look up a name in the current environment
+lookupName :: Monad m => Name -> IfM m (Maybe TyThing)
+lookupName name = IfM $ do
+ lookup_name <- gets ifeLookupName
+ lift (lookup_name name)
- -- | Maybe a doc comment, and possibly docs for arguments (if this
- -- decl is a function or type-synonym).
- , expItemMbDoc :: !(DocForDecl (IdP name))
+-- | Very basic logging function that simply prints to stdout
+warn :: MonadIO m => String -> IfM m ()
+warn msg = liftIO $ putStrLn msg
- -- | Subordinate names, possibly with documentation.
- , expItemSubDocs :: ![(IdP name, DocForDecl (IdP name))]
+-----------------------------------------------------------------------------
+-- * Export items & declarations
+-----------------------------------------------------------------------------
- -- | Instances relevant to this declaration, possibly with
- -- documentation.
- , expItemInstances :: ![DocInstance name]
- -- | Fixity decls relevant to this declaration (including subordinates).
- , expItemFixities :: ![(IdP name, Fixity)]
+data ExportItem name
- -- | Whether the ExportItem is from a TH splice or not, for generating
- -- the appropriate type of Source link.
- , expItemSpliced :: !Bool
- }
+ -- | An exported declaration.
+ = ExportDecl (XExportDecl name)
-- | An exported entity for which we have no documentation (perhaps because it
-- resides in another package).
@@ -248,7 +280,7 @@ data ExportItem name
{ expItemName :: !(IdP name)
-- | Subordinate names.
- , expItemSubs :: ![IdP name]
+ , expItemSubs :: [IdP name]
}
-- | A section heading.
@@ -270,21 +302,105 @@ data ExportItem name
-- | A cross-reference to another module.
| ExportModule !Module
+-- | A type family mapping a name type index to types of export declarations.
+-- The pre-renaming type index ('GhcRn') is mapped to the type of export
+-- declarations which do not include Hoogle output ('ExportD'), since Hoogle output is
+-- generated during the Haddock renaming step. The post-renaming type index
+-- ('DocNameI') is mapped to the type of export declarations which do include
+-- Hoogle output ('RnExportD').
+type family XExportDecl x where
+ XExportDecl GhcRn = ExportD GhcRn
+ XExportDecl DocNameI = RnExportD
+
+-- | Represents an export declaration that Haddock has discovered to be exported
+-- from a module. The @name@ index indicated whether the declaration has been
+-- renamed such that each 'Name' points to it's optimal link destination.
+data ExportD name = ExportD
+ {
+ -- | A declaration.
+ expDDecl :: !(LHsDecl name)
+
+ -- | Bundled patterns for a data type declaration
+ , expDPats :: [(HsDecl name, DocForDecl (IdP name))]
+
+ -- | Maybe a doc comment, and possibly docs for arguments (if this
+ -- decl is a function or type-synonym).
+ , expDMbDoc :: !(DocForDecl (IdP name))
+
+ -- | Subordinate names, possibly with documentation.
+ , expDSubDocs :: [(IdP name, DocForDecl (IdP name))]
+
+ -- | Instances relevant to this declaration, possibly with
+ -- documentation.
+ , expDInstances :: [DocInstance name]
+
+ -- | Fixity decls relevant to this declaration (including subordinates).
+ , expDFixities :: [(IdP name, Fixity)]
+
+ -- | Whether the ExportD is from a TH splice or not, for generating
+ -- the appropriate type of Source link.
+ , expDSpliced :: !Bool
+ }
+
+-- | Represents export declarations that have undergone renaming such that every
+-- 'Name' in the declaration points to an optimal link destination. Since Hoogle
+-- output is also generated during the renaming step, each declaration is also
+-- attached to its Hoogle textual database entries, /if/ Hoogle output is
+-- enabled and the module is not hidden in the generated documentation using the
+-- @{-# OPTIONS_HADDOCK hide #-}@ pragma.
+data RnExportD = RnExportD
+ {
+ -- | The renamed export declaration
+ rnExpDExpD :: !(ExportD DocNameI)
+
+ -- | If Hoogle textbase (textual database) output is enabled, the text
+ -- output lines for this declaration. If Hoogle output is not enabled, the
+ -- list will be empty.
+ , rnExpDHoogle :: [String]
+ }
+
data Documentation name = Documentation
- { documentationDoc :: Maybe (MDoc name)
- , documentationWarning :: !(Maybe (Doc name))
+ { documentationDoc :: Maybe (MDoc name)
+ , documentationWarning :: Maybe (Doc name)
} deriving Functor
+instance NFData name => NFData (Documentation name) where
+ rnf (Documentation d w) = d `deepseq` w `deepseq` ()
-- | Arguments and result are indexed by Int, zero-based from the left,
-- because that's the easiest to use when recursing over types.
type FnArgsDoc name = Map Int (MDoc name)
type DocForDecl name = (Documentation name, FnArgsDoc name)
-
noDocForDecl :: DocForDecl name
noDocForDecl = (Documentation Nothing Nothing, mempty)
+-- | As we build the declaration map, we really only care to track whether we
+-- have only seen a value declaration for a 'Name', or anything else. This type
+-- is used to represent those cases. If the only declaration attached to a
+-- 'Name' is a 'ValD', we will consult the GHC interface file to determine the
+-- type of the value, and attach the 'SrcSpan' from the 'EValD' constructor to
+-- it. If we see any other type of declaration for the 'Name', we can just use
+-- it.
+--
+-- This type saves us from storing /every/ declaration we see for a given 'Name'
+-- in the map, which is unnecessary and very problematic for overall memory
+-- usage.
+data DeclMapEntry
+ = EValD !SrcSpan
+ | EOther (LHsDecl GhcRn)
+
+instance Semigroup DeclMapEntry where
+ (EValD _) <> e = e
+ e <> _ = e
+
+-- | Transform a declaration into a 'DeclMapEntry'. If it is a 'ValD'
+-- declaration, only the source location will be noted (since that is all we
+-- care to store in the 'DeclMap' due to the way top-level bindings with no type
+-- signatures are handled). Otherwise, the entire declaration will be kept.
+toDeclMapEntry :: LHsDecl GhcRn -> DeclMapEntry
+toDeclMapEntry (L l (ValD _ _)) = EValD (locA l)
+toDeclMapEntry d = EOther d
-----------------------------------------------------------------------------
-- * Cross-referencing
@@ -300,6 +416,9 @@ data NsRdrName = NsRdrName
, rdrName :: !RdrName
}
+instance NFData NsRdrName where
+ rnf (NsRdrName ns rdrN) = ns `seq` rdrN `deepseq` ()
+
-- | Extends 'Name' with cross-reference information.
data DocName
= Documented Name Module
@@ -360,6 +479,12 @@ data Wrap n
| Backticked { unwrap :: n } -- ^ add backticks around the name
deriving (Show, Functor, Foldable, Traversable)
+instance NFData n => NFData (Wrap n) where
+ rnf w = case w of
+ Unadorned n -> rnf n
+ Parenthesized n -> rnf n
+ Backticked n -> rnf n
+
-- | Useful for debugging
instance Outputable n => Outputable (Wrap n) where
ppr (Unadorned n) = ppr n
@@ -379,13 +504,42 @@ instance HasOccName DocName where
-- * Instances
-----------------------------------------------------------------------------
+-- | Stable name for stable comparisons. GHC's `Name` uses unstable
+-- ordering based on their `Unique`'s.
+newtype SName = SName Name
+ deriving newtype NFData
+
+instance Eq SName where
+ SName n1 == SName n2 = n1 `stableNameCmp` n2 == EQ
+
+instance Ord SName where
+ SName n1 `compare` SName n2 = n1 `stableNameCmp` n2
+
+-- | Simplified type for sorting types, ignoring qualification (not visible
+-- in Haddock output) and unifying special tycons with normal ones.
+-- For the benefit of the user (looks nice and predictable) and the
+-- tests (which prefer output to be deterministic).
+data SimpleType = SimpleType SName [SimpleType]
+ | SimpleIntTyLit Integer
+ | SimpleStringTyLit String
+ | SimpleCharTyLit Char
+ deriving (Eq,Ord)
+
+instance NFData SimpleType where
+ rnf st =
+ case st of
+ SimpleType sn sts -> sn `deepseq` sts `deepseq` ()
+ SimpleIntTyLit i -> rnf i
+ SimpleStringTyLit s -> rnf s
+ SimpleCharTyLit c -> rnf c
+
-- | The three types of instances
data InstType name
= ClassInst
{ clsiCtx :: [HsType name]
, clsiTyVars :: LHsQTyVars name
, clsiSigs :: [Sig name]
- , clsiAssocTys :: [PseudoFamilyDecl name]
+ , clsiAssocTys :: [DocInstance name]
}
| TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side)
| DataInst (TyClDecl name) -- ^ Data constructors
@@ -400,37 +554,6 @@ instance (OutputableBndrId p)
ppr (DataInst a) = text "DataInst" <+> ppr a
--- | Almost the same as 'FamilyDecl' except for type binders.
---
--- In order to perform type specialization for class instances, we need to
--- substitute class variables to appropriate type. However, type variables in
--- associated type are specified using 'LHsTyVarBndrs' instead of 'HsType'.
--- This makes type substitution impossible and to overcome this issue,
--- 'PseudoFamilyDecl' type is introduced.
-data PseudoFamilyDecl name = PseudoFamilyDecl
- { pfdInfo :: FamilyInfo name
- , pfdLName :: LocatedN (IdP name)
- , pfdTyVars :: [LHsType name]
- , pfdKindSig :: LFamilyResultSig name
- }
-
-
-mkPseudoFamilyDecl :: FamilyDecl GhcRn -> PseudoFamilyDecl GhcRn
-mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
- { pfdInfo = fdInfo
- , pfdLName = fdLName
- , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_explicit fdTyVars ]
- , pfdKindSig = fdResultSig
- }
- where
- mkType :: HsTyVarBndr flag GhcRn -> HsType GhcRn
- mkType (KindedTyVar _ _ (L loc name) lkind) =
- HsKindSig noAnn tvar lkind
- where
- tvar = L (na2la loc) (HsTyVar noAnn NotPromoted (L loc name))
- mkType (UserTyVar _ _ name) = HsTyVar noAnn NotPromoted name
-
-
-- | An instance head that may have documentation and a source location.
type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name), Maybe Module)
@@ -472,6 +595,12 @@ type MDoc id = MetaDoc (Wrap (ModuleName, OccName)) (Wrap id)
type DocMarkup id a = DocMarkupH (Wrap (ModuleName, OccName)) id a
+instance NFData Meta where
+ rnf (Meta v p) = v `deepseq` p `deepseq` ()
+
+instance NFData id => NFData (MDoc id) where
+ rnf (MetaDoc m d) = m `deepseq` d `deepseq` ()
+
instance (NFData a, NFData mod)
=> NFData (DocH mod a) where
rnf doc = case doc of
@@ -535,6 +664,21 @@ exampleToString :: Example -> String
exampleToString (Example expression result) =
">>> " ++ expression ++ "\n" ++ unlines result
+instance NFData name => NFData (HaddockModInfo name) where
+ rnf (HaddockModInfo{..}) =
+ hmi_description
+ `deepseq` hmi_copyright
+ `deepseq` hmi_license
+ `deepseq` hmi_maintainer
+ `deepseq` hmi_stability
+ `deepseq` hmi_portability
+ `deepseq` hmi_safety
+ `deepseq` hmi_language
+ `deepseq` hmi_extensions
+ `deepseq` ()
+
+instance NFData LangExt.Extension
+
data HaddockModInfo name = HaddockModInfo
{ hmi_description :: Maybe (Doc name)
, hmi_copyright :: Maybe String
@@ -547,7 +691,6 @@ data HaddockModInfo name = HaddockModInfo
, hmi_extensions :: [LangExt.Extension]
}
-
emptyHaddockModInfo :: HaddockModInfo a
emptyHaddockModInfo = HaddockModInfo
{ hmi_description = Nothing
@@ -575,6 +718,8 @@ data DocOption
| OptNotHome -- ^ Not the best place to get docs for things
-- exported by this module.
| OptShowExtensions -- ^ Render enabled extensions for this module.
+ | OptPrintRuntimeRep -- ^ Render runtime reps for this module (see
+ -- the GHC @-fprint-explicit-runtime-reps@ flag)
deriving (Eq, Show)
@@ -585,23 +730,12 @@ data QualOption
| OptLocalQual -- ^ Qualify all imported names fully.
| OptRelativeQual -- ^ Like local, but strip module prefix
-- from modules in the same hierarchy.
- | OptAliasedQual -- ^ Uses aliases of module names
- -- as suggested by module import renamings.
- -- However, we are unfortunately not able
- -- to maintain the original qualifications.
- -- Image a re-export of a whole module,
- -- how could the re-exported identifiers be qualified?
-
-type AliasMap = Map Module ModuleName
data Qualification
= NoQual
| FullQual
| LocalQual Module
| RelativeQual Module
- | AliasedQual AliasMap Module
- -- ^ @Module@ contains the current module.
- -- This way we can distinguish imported and local identifiers.
makeContentsQual :: QualOption -> Qualification
makeContentsQual qual =
@@ -609,12 +743,11 @@ makeContentsQual qual =
OptNoQual -> NoQual
_ -> FullQual
-makeModuleQual :: QualOption -> AliasMap -> Module -> Qualification
-makeModuleQual qual aliases mdl =
+makeModuleQual :: QualOption -> Module -> Qualification
+makeModuleQual qual mdl =
case qual of
OptLocalQual -> LocalQual mdl
OptRelativeQual -> RelativeQual mdl
- OptAliasedQual -> AliasedQual aliases mdl
OptFullQual -> FullQual
OptNoQual -> NoQual
@@ -632,19 +765,17 @@ data SinceQual
-- an external package
-----------------------------------------------------------------------------
--- * Error handling
+-- * Renaming
-----------------------------------------------------------------------------
+-- | Renames an identifier.
+-- The first input is the identifier as it occurred in the comment
+-- The second input is the possible namespaces of the identifier
+type Renamer = String -> (NameSpace -> Bool) -> [Name]
--- A monad which collects error messages, locally defined to avoid a dep on mtl
-
-
-type ErrMsg = String
-type ErrMsgM = Writer [ErrMsg]
-
-
--- Exceptions
-
+-----------------------------------------------------------------------------
+-- * Error handling
+-----------------------------------------------------------------------------
-- | Haddock's own exception type.
data HaddockException
@@ -652,7 +783,6 @@ data HaddockException
| WithContext [String] SomeException
deriving Typeable
-
instance Show HaddockException where
show (HaddockException str) = str
show (WithContext ctxts se) = unlines $ ["While " ++ ctxt ++ ":\n" | ctxt <- reverse ctxts] ++ [show se]
@@ -670,29 +800,6 @@ withExceptionContext ctxt =
) .
handle (throwM . WithContext [ctxt])
--- In "Haddock.Interface.Create", we need to gather
--- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
--- but we can't just use @GhcT ErrMsgM@ because GhcT requires the
--- transformed monad to be MonadIO.
-newtype ErrMsgGhc a = ErrMsgGhc { unErrMsgGhc :: WriterT [ErrMsg] Ghc a }
-
-
-deriving newtype instance Functor ErrMsgGhc
-deriving newtype instance Applicative ErrMsgGhc
-deriving newtype instance Monad ErrMsgGhc
-deriving newtype instance (MonadWriter [ErrMsg]) ErrMsgGhc
-deriving newtype instance MonadIO ErrMsgGhc
-
-
-runWriterGhc :: ErrMsgGhc a -> Ghc (a, [ErrMsg])
-runWriterGhc = runWriterT . unErrMsgGhc
-
-liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a
-liftGhcToErrMsgGhc = ErrMsgGhc . lift
-
-liftErrMsg :: ErrMsgM a -> ErrMsgGhc a
-liftErrMsg = writer . runWriter
-
-----------------------------------------------------------------------------
-- * Pass sensitive types
-----------------------------------------------------------------------------
@@ -850,3 +957,124 @@ type instance XCInjectivityAnn DocNameI = NoExtField
type instance XCFunDep DocNameI = NoExtField
type instance XCTyFamInstDecl DocNameI = NoExtField
+
+-----------------------------------------------------------------------------
+-- * NFData instances for GHC types
+-----------------------------------------------------------------------------
+
+instance NFData RdrName where
+ rnf (Unqual on) = rnf on
+ rnf (Qual mn on) = mn `deepseq` on `deepseq` ()
+ rnf (Orig m on) = m `deepseq` on `deepseq` ()
+ rnf (Exact n) = rnf n
+
+instance NFData SourceText where
+ rnf NoSourceText = ()
+ rnf (SourceText s) = rnf s
+
+instance NFData FixityDirection where
+ rnf InfixL = ()
+ rnf InfixR = ()
+ rnf InfixN = ()
+
+instance NFData Fixity where
+ rnf (Fixity sourceText n dir) =
+ sourceText `deepseq` n `deepseq` dir `deepseq` ()
+
+instance NFData ann => NFData (SrcSpanAnn' ann) where
+ rnf (SrcSpanAnn a ss) = a `deepseq` ss `deepseq` ()
+
+instance NFData (EpAnn NameAnn) where
+ rnf EpAnnNotUsed = ()
+ rnf (EpAnn en ann cs) = en `deepseq` ann `deepseq` cs `deepseq` ()
+
+instance NFData NameAnn where
+ rnf (NameAnn a b c d e) =
+ a
+ `deepseq` b
+ `deepseq` c
+ `deepseq` d
+ `deepseq` e
+ `deepseq` ()
+ rnf (NameAnnCommas a b c d e) =
+ a
+ `deepseq` b
+ `deepseq` c
+ `deepseq` d
+ `deepseq` e
+ `deepseq` ()
+ rnf (NameAnnBars a b c d e) =
+ a
+ `deepseq` b
+ `deepseq` c
+ `deepseq` d
+ `deepseq` e
+ `deepseq` ()
+ rnf (NameAnnOnly a b c d) =
+ a
+ `deepseq` b
+ `deepseq` c
+ `deepseq` d
+ `deepseq` ()
+ rnf (NameAnnRArrow a b) =
+ a
+ `deepseq` b
+ `deepseq` ()
+ rnf (NameAnnQuote a b c) =
+ a
+ `deepseq` b
+ `deepseq` c
+ `deepseq` ()
+ rnf (NameAnnTrailing a) = rnf a
+
+instance NFData TrailingAnn where
+ rnf (AddSemiAnn epaL) = rnf epaL
+ rnf (AddCommaAnn epaL) = rnf epaL
+ rnf (AddVbarAnn epaL) = rnf epaL
+
+instance NFData NameAdornment where
+ rnf NameParens = ()
+ rnf NameParensHash = ()
+ rnf NameBackquotes = ()
+ rnf NameSquare = ()
+
+instance NFData EpaLocation where
+ rnf (EpaSpan ss bs) = ss `seq` bs `deepseq` ()
+ rnf (EpaDelta dp lc) = dp `seq` lc `deepseq` ()
+
+instance NFData EpAnnComments where
+ rnf (EpaComments cs) = rnf cs
+ rnf (EpaCommentsBalanced cs1 cs2) = cs1 `deepseq` cs2 `deepseq` ()
+
+instance NFData EpaComment where
+ rnf (EpaComment t rss) = t `deepseq` rss `seq` ()
+
+instance NFData EpaCommentTok where
+ rnf (EpaDocComment ds) = rnf ds
+ rnf (EpaDocOptions s) = rnf s
+ rnf (EpaLineComment s) = rnf s
+ rnf (EpaBlockComment s) = rnf s
+ rnf EpaEofComment = ()
+
+
+instance NFData a => NFData (Strict.Maybe a) where
+ rnf Strict.Nothing = ()
+ rnf (Strict.Just x) = rnf x
+
+instance NFData BufSpan where
+ rnf (BufSpan p1 p2) = p1 `deepseq` p2 `deepseq` ()
+
+instance NFData BufPos where
+ rnf (BufPos n) = rnf n
+
+instance NFData Anchor where
+ rnf (Anchor ss op) = ss `seq` op `deepseq` ()
+
+instance NFData AnchorOperation where
+ rnf UnchangedAnchor = ()
+ rnf (MovedAnchor dp) = rnf dp
+
+instance NFData DeltaPos where
+ rnf (SameLine n) = rnf n
+ rnf (DifferentLine n m) = n `deepseq` m `deepseq` ()
+
diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal
index 2e015f2aae..e09713aeb4 100644
--- a/haddock-library/haddock-library.cabal
+++ b/haddock-library/haddock-library.cabal
@@ -39,7 +39,7 @@ common lib-defaults
default-language: Haskell2010
build-depends:
- , base >= 4.5 && < 4.17
+ , base >= 4.5 && < 4.19
, containers ^>= 0.4.2.1 || ^>= 0.5.0.0 || ^>= 0.6.0.1
, text ^>= 1.2.3.0 || ^>= 2.0
, parsec ^>= 3.1.13.0
@@ -87,7 +87,7 @@ test-suite spec
build-depends:
, base-compat ^>= 0.12.0
- , QuickCheck ^>= 2.11 || ^>= 2.13.2 || ^>= 2.14
+ , QuickCheck ^>= 2.11 || ^>= 2.13.2 || ^>= 2.14
, deepseq ^>= 1.3.0.0 || ^>= 1.4.0.0
-- NB: build-depends & build-tool-depends have independent
diff --git a/haddock-library/src/Documentation/Haddock/Doc.hs b/haddock-library/src/Documentation/Haddock/Doc.hs
index 297d30d61d..33988e0b73 100644
--- a/haddock-library/src/Documentation/Haddock/Doc.hs
+++ b/haddock-library/src/Documentation/Haddock/Doc.hs
@@ -1,8 +1,13 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Documentation.Haddock.Doc (docParagraph, docAppend,
- docConcat, metaDocConcat,
- metaDocAppend, emptyMetaDoc,
- metaAppend, metaConcat) where
+module Documentation.Haddock.Doc
+ ( docParagraph
+ , docAppend
+ , docConcat
+ , metaDocConcat
+ , metaDocAppend
+ , emptyMetaDoc
+ , metaAppend
+ , metaConcat
+ ) where
import Control.Applicative ((<|>), empty)
import Documentation.Haddock.Types
diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal
index 4e3bfd298f..e49e23dfc2 100644
--- a/haddock-test/haddock-test.cabal
+++ b/haddock-test/haddock-test.cabal
@@ -10,14 +10,14 @@ bug-reports: https://github.com/haskell/haddock/issues
copyright: (c) Simon Marlow, David Waern
category: Documentation
build-type: Simple
-tested-with: GHC==9.4.*
+tested-with: GHC==9.6.*
stability: experimental
library
default-language: Haskell2010
ghc-options: -Wall
hs-source-dirs: src
- build-depends: base >= 4.3 && < 4.17, bytestring, directory, process, filepath, Cabal
+ build-depends: base >= 4.3 && < 4.19, bytestring, directory, process, filepath, Cabal
exposed-modules:
Test.Haddock
diff --git a/haddock.cabal b/haddock.cabal
index c11cad6744..625ccefcab 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: haddock
-version: 2.27.0
+version: 2.28.0
synopsis: A documentation-generation tool for Haskell libraries
description:
This is Haddock, a tool for automatically generating documentation
@@ -35,7 +35,7 @@ bug-reports: https://github.com/haskell/haddock/issues
copyright: (c) Simon Marlow, David Waern
category: Documentation
build-type: Simple
-tested-with: GHC==9.4.*
+tested-with: GHC==9.6.*
extra-source-files:
CHANGES.md
@@ -68,7 +68,7 @@ executable haddock
-- haddock typically only supports a single GHC major version
build-depends:
- base ^>= 4.13.0.0 || ^>= 4.14.0.0 || ^>= 4.15.0.0 || ^>= 4.16.0.0 || ^>= 4.17.0.0 || ^>= 4.18.0.0
+ base ^>= 4.13.0.0 || ^>= 4.14.0.0 || ^>= 4.15.0.0 || ^>= 4.16.0.0 || ^>= 4.17.0.0 || ^>= 4.18.0.0 || ^>= 4.19.0.0
if flag(in-ghc-tree)
hs-source-dirs: haddock-api/src, haddock-library/src
@@ -109,7 +109,7 @@ executable haddock
Haddock.Interface.AttachInstances
Haddock.Interface.LexParseRn
Haddock.Interface.ParseModuleHeader
- Haddock.Interface.Specialize
+ Haddock.Interface.RenameType
Haddock.Parser
Haddock.Utils
Haddock.Utils.Json
@@ -139,7 +139,6 @@ executable haddock
Haddock.InterfaceFile
Haddock.Options
Haddock.GhcUtils
- Haddock.Syb
Haddock.Convert
Paths_haddock
@@ -150,7 +149,7 @@ executable haddock
else
-- in order for haddock's advertised version number to have proper meaning,
-- we pin down to a single haddock-api version.
- build-depends: haddock-api == 2.27.0
+ build-depends: haddock-api == 2.28.0
test-suite html-test
type: exitcode-stdio-1.0
diff --git a/hoogle-test/ref/Bug722/test.txt b/hoogle-test/ref/Bug722/test.txt
index 2f44ed8fb7..052c6e950f 100644
--- a/hoogle-test/ref/Bug722/test.txt
+++ b/hoogle-test/ref/Bug722/test.txt
@@ -8,7 +8,7 @@ module Bug722
class Foo a
(!@#) :: Foo a => a -> a -> a
infixl 4 !@#
-type family (&*) :: * -> * -> *
+type family (&*) :: Type -> Type -> Type
infixr 3 &*
data a :-& b
(:^&) :: a -> b -> (:-&) a b
diff --git a/hoogle-test/ref/Bug806/test.txt b/hoogle-test/ref/Bug806/test.txt
index 8abdffaef2..222f6cfdae 100644
--- a/hoogle-test/ref/Bug806/test.txt
+++ b/hoogle-test/ref/Bug806/test.txt
@@ -7,13 +7,13 @@
module Bug806
-- | <a>F1</a> docs
-type family F1 a b :: * -> *
+type family F1 a b :: Type -> Type
-- | <a>F2</a> docs
-type family F2 a b :: * -> *
+type family F2 a b :: Type -> Type
-- | <a>D</a> docs
-data family D a :: * -> *
+data family D a :: Type -> Type
v :: Int
-- | <a>C</a> docs
@@ -21,5 +21,5 @@ class C a where {
-- | <a>AT</a> docs
type AT a;
- type AT a = Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy (Proxy)))))))));
+ type AT a = Proxy Proxy Proxy Proxy Proxy Proxy Proxy Proxy Proxy Proxy :: Type -> Type;
}
diff --git a/hoogle-test/ref/Bug825/test.txt b/hoogle-test/ref/Bug825/test.txt
index a88202dcf3..a800c10baa 100644
--- a/hoogle-test/ref/Bug825/test.txt
+++ b/hoogle-test/ref/Bug825/test.txt
@@ -6,4 +6,4 @@
module Bug825
data a :~: b
-data (:~~:) a b
+data a :~~: b
diff --git a/hoogle-test/ref/Bug992/test.txt b/hoogle-test/ref/Bug992/test.txt
index 8ae145c34f..def969eadb 100644
--- a/hoogle-test/ref/Bug992/test.txt
+++ b/hoogle-test/ref/Bug992/test.txt
@@ -5,5 +5,5 @@
@version 0.0.0
module Bug992
-data K (m :: * -> *)
-K :: K (m :: * -> *)
+data K (m :: Type -> Type)
+K :: K (m :: Type -> Type)
diff --git a/hoogle-test/ref/classes/test.txt b/hoogle-test/ref/classes/test.txt
index 69f224eb2c..98ef48e98b 100644
--- a/hoogle-test/ref/classes/test.txt
+++ b/hoogle-test/ref/classes/test.txt
@@ -5,7 +5,7 @@
@version 0.0.0
module Classes
-class Foo f
+class Foo (f :: Type -> Type)
bar :: Foo f => f a -> f b -> f (a, b)
baz :: Foo f => f ()
class Quux q
diff --git a/hoogle-test/ref/type-sigs/test.txt b/hoogle-test/ref/type-sigs/test.txt
index 1209279c59..b07d623fb7 100644
--- a/hoogle-test/ref/type-sigs/test.txt
+++ b/hoogle-test/ref/type-sigs/test.txt
@@ -5,12 +5,12 @@
@version 0.0.0
module ReaderT
-newtype ReaderT r m a
-ReaderT :: (r -> m a) -> ReaderT r m a
-[runReaderT] :: ReaderT r m a -> r -> m a
+newtype ReaderT r (m :: Type -> Type) a
+ReaderT :: (r -> m a) -> ReaderT r (m :: Type -> Type) a
+[runReaderT] :: ReaderT r (m :: Type -> Type) a -> r -> m a
module ReaderTReexport
-newtype ReaderT r m a
-ReaderT :: (r -> m a) -> ReaderT r m a
-[runReaderT] :: ReaderT r m a -> r -> m a
+newtype ReaderT r (m :: Type -> Type) a
+ReaderT :: (r -> m a) -> ReaderT r (m :: Type -> Type) a
+[runReaderT] :: ReaderT r (m :: Type -> Type) a -> r -> m a
runReaderT :: ReaderT r m a -> r -> m a
diff --git a/hoogle-test/src/Bug722/Bug722.hs b/hoogle-test/src/Bug722/Bug722.hs
index ef7e9a2f3e..0a1acbd4f6 100644
--- a/hoogle-test/src/Bug722/Bug722.hs
+++ b/hoogle-test/src/Bug722/Bug722.hs
@@ -2,11 +2,13 @@
{-# LANGUAGE TypeOperators, TypeFamilies #-}
module Bug722 where
+import Data.Kind (Type)
+
class Foo a where
(!@#) :: a -> a -> a
infixl 4 !@#
-type family (&*) :: * -> * -> *
+type family (&*) :: Type -> Type -> Type
infixr 3 &*
data a :-& b = a :^& b
diff --git a/hoogle-test/src/Bug806/Bug806.hs b/hoogle-test/src/Bug806/Bug806.hs
index f2a9a0992e..2af59e0258 100644
--- a/hoogle-test/src/Bug806/Bug806.hs
+++ b/hoogle-test/src/Bug806/Bug806.hs
@@ -3,16 +3,17 @@
{-# LANGUAGE UndecidableInstances #-}
module Bug806 where
+import Data.Kind (Type)
import Data.Proxy
-- | 'F1' docs
-type family F1 a b :: * -> *
+type family F1 a b :: Type -> Type
-- | 'F2' docs
-type family F2 a b :: * -> * where
+type family F2 a b :: Type -> Type where
F2 Int b = Maybe
F2 a b = []
-- | 'D' docs
-data family D a :: * -> *
+data family D a :: Type -> Type
v :: Int
v = 42
diff --git a/hoogle-test/src/Bug992/Bug992.hs b/hoogle-test/src/Bug992/Bug992.hs
index 0b03964bac..83454c98c3 100644
--- a/hoogle-test/src/Bug992/Bug992.hs
+++ b/hoogle-test/src/Bug992/Bug992.hs
@@ -3,4 +3,6 @@
module Bug992 where
-data K (m :: * -> *) = K
+import Data.Kind (Type)
+
+data K (m :: Type -> Type) = K
diff --git a/html-test/ref/Bug1004.html b/html-test/ref/Bug1004.html
index fa8c0b14db..ae1bbadc0a 100644
--- a/html-test/ref/Bug1004.html
+++ b/html-test/ref/Bug1004.html
@@ -137,18 +137,104 @@
> <div class="subs associated-types"
><p class="caption"
>Associated Types</p
- ><p class="src"
- ><span class="keyword"
- >type</span
- > <a href="#" title="GHC.Generics"
- >Rep1</a
- > (<a href="#" title="Bug1004"
- >Product</a
- > f g) :: k -> <a href="#" title="Data.Kind"
- >Type</a
- > <a href="#" class="selflink"
- >#</a
- ></p
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Rep1_Product:Rep1:1"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="GHC.Generics"
+ >Rep1</a
+ > (<a href="#" title="Bug1004"
+ >Product</a
+ > f g :: k -> <a href="#" title="Data.Kind"
+ >Type</a
+ >)</span
+ ></td
+ ><td class="doc"
+ ><p
+ ><em
+ >Since: base-4.9.0.0</em
+ ></p
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:Rep1_Product:Rep1:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Data.Functor.Product</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="GHC.Generics"
+ >Rep1</a
+ > (<a href="#" title="Bug1004"
+ >Product</a
+ > f g :: k -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) = <a href="#" title="GHC.Generics"
+ >D1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaData</a
+ > "Product" "Data.Functor.Product" "base" '<a href="#" title="Data.Bool"
+ >False</a
+ >) (<a href="#" title="GHC.Generics"
+ >C1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaCons</a
+ > "Pair" '<a href="#" title="GHC.Generics"
+ >PrefixI</a
+ > '<a href="#" title="Data.Bool"
+ >False</a
+ >) (<a href="#" title="GHC.Generics"
+ >S1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaSel</a
+ > ('<a href="#" title="Data.Maybe"
+ >Nothing</a
+ > :: <a href="#" title="Data.Maybe"
+ >Maybe</a
+ > <a href="#" title="GHC.TypeLits"
+ >Symbol</a
+ >) '<a href="#" title="GHC.Generics"
+ >NoSourceUnpackedness</a
+ > '<a href="#" title="GHC.Generics"
+ >NoSourceStrictness</a
+ > '<a href="#" title="GHC.Generics"
+ >DecidedLazy</a
+ >) (<a href="#" title="GHC.Generics"
+ >Rec1</a
+ > f) <a href="#" title="GHC.Generics"
+ >:*:</a
+ > <a href="#" title="GHC.Generics"
+ >S1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaSel</a
+ > ('<a href="#" title="Data.Maybe"
+ >Nothing</a
+ > :: <a href="#" title="Data.Maybe"
+ >Maybe</a
+ > <a href="#" title="GHC.TypeLits"
+ >Symbol</a
+ >) '<a href="#" title="GHC.Generics"
+ >NoSourceUnpackedness</a
+ > '<a href="#" title="GHC.Generics"
+ >NoSourceStrictness</a
+ > '<a href="#" title="GHC.Generics"
+ >DecidedLazy</a
+ >) (<a href="#" title="GHC.Generics"
+ >Rec1</a
+ > g)))</div
+ ></details
+ ></td
+ ></tr
+ ></table
></div
> <div class="subs methods"
><p class="caption"
@@ -158,7 +244,7 @@
>from1</a
> :: <span class="keyword"
>forall</span
- > (a :: k0). <a href="#" title="Bug1004"
+ > (a :: k). <a href="#" title="Bug1004"
>Product</a
> f g a -> <a href="#" title="GHC.Generics"
>Rep1</a
@@ -172,7 +258,7 @@
>to1</a
> :: <span class="keyword"
>forall</span
- > (a :: k0). <a href="#" title="GHC.Generics"
+ > (a :: k). <a href="#" title="GHC.Generics"
>Rep1</a
> (<a href="#" title="Bug1004"
>Product</a
@@ -506,7 +592,160 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Eq1:5"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Foldable1:5"
+ ></span
+ > (<a href="#" title="Data.Foldable1"
+ >Foldable1</a
+ > f, <a href="#" title="Data.Foldable1"
+ >Foldable1</a
+ > g) => <a href="#" title="Data.Foldable1"
+ >Foldable1</a
+ > (<a href="#" title="Bug1004"
+ >Product</a
+ > f g)</span
+ ></td
+ ><td class="doc"
+ ><p
+ >It would be enough for either half of a product to be <code
+ ><a href="#" title="Data.Foldable1"
+ >Foldable1</a
+ ></code
+ >.
+ Other could be <code
+ ><a href="#" title="Data.Foldable"
+ >Foldable</a
+ ></code
+ >.</p
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:id:Product:Foldable1:5"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Data.Foldable1</a
+ ></p
+ > <div class="subs methods"
+ ><p class="caption"
+ >Methods</p
+ ><p class="src"
+ ><a href="#"
+ >fold1</a
+ > :: <a href="#" title="Prelude"
+ >Semigroup</a
+ > m => <a href="#" title="Bug1004"
+ >Product</a
+ > f g m -> m <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >foldMap1</a
+ > :: <a href="#" title="Prelude"
+ >Semigroup</a
+ > m => (a -> m) -> <a href="#" title="Bug1004"
+ >Product</a
+ > f g a -> m <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >foldMap1'</a
+ > :: <a href="#" title="Prelude"
+ >Semigroup</a
+ > m => (a -> m) -> <a href="#" title="Bug1004"
+ >Product</a
+ > f g a -> m <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >toNonEmpty</a
+ > :: <a href="#" title="Bug1004"
+ >Product</a
+ > f g a -> <a href="#" title="Data.List.NonEmpty"
+ >NonEmpty</a
+ > a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >maximum</a
+ > :: <a href="#" title="Data.Ord"
+ >Ord</a
+ > a => <a href="#" title="Bug1004"
+ >Product</a
+ > f g a -> a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >minimum</a
+ > :: <a href="#" title="Data.Ord"
+ >Ord</a
+ > a => <a href="#" title="Bug1004"
+ >Product</a
+ > f g a -> a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >head</a
+ > :: <a href="#" title="Bug1004"
+ >Product</a
+ > f g a -> a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >last</a
+ > :: <a href="#" title="Bug1004"
+ >Product</a
+ > f g a -> a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >foldrMap1</a
+ > :: (a -> b) -> (a -> b -> b) -> <a href="#" title="Bug1004"
+ >Product</a
+ > f g a -> b <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >foldlMap1'</a
+ > :: (a -> b) -> (b -> a -> b) -> <a href="#" title="Bug1004"
+ >Product</a
+ > f g a -> b <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >foldlMap1</a
+ > :: (a -> b) -> (b -> a -> b) -> <a href="#" title="Bug1004"
+ >Product</a
+ > f g a -> b <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >foldrMap1'</a
+ > :: (a -> b) -> (a -> b -> b) -> <a href="#" title="Bug1004"
+ >Product</a
+ > f g a -> b <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Eq1:6"
></span
> (<a href="#" title="Data.Functor.Classes"
>Eq1</a
@@ -527,7 +766,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Eq1:5"
+ ><details id="i:id:Product:Eq1:6"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -558,7 +797,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Ord1:6"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Ord1:7"
></span
> (<a href="#" title="Data.Functor.Classes"
>Ord1</a
@@ -579,7 +818,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Ord1:6"
+ ><details id="i:id:Product:Ord1:7"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -610,7 +849,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Read1:7"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Read1:8"
></span
> (<a href="#" title="Data.Functor.Classes"
>Read1</a
@@ -631,7 +870,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Read1:7"
+ ><details id="i:id:Product:Read1:8"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -710,7 +949,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Show1:8"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Show1:9"
></span
> (<a href="#" title="Data.Functor.Classes"
>Show1</a
@@ -731,7 +970,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Show1:8"
+ ><details id="i:id:Product:Show1:9"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -782,7 +1021,61 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Traversable:9"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Contravariant:10"
+ ></span
+ > (<a href="#" title="Data.Functor.Contravariant"
+ >Contravariant</a
+ > f, <a href="#" title="Data.Functor.Contravariant"
+ >Contravariant</a
+ > g) => <a href="#" title="Data.Functor.Contravariant"
+ >Contravariant</a
+ > (<a href="#" title="Bug1004"
+ >Product</a
+ > f g)</span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:id:Product:Contravariant:10"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Data.Functor.Contravariant</a
+ ></p
+ > <div class="subs methods"
+ ><p class="caption"
+ >Methods</p
+ ><p class="src"
+ ><a href="#"
+ >contramap</a
+ > :: (a' -> a) -> <a href="#" title="Bug1004"
+ >Product</a
+ > f g a -> <a href="#" title="Bug1004"
+ >Product</a
+ > f g a' <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >(>$)</a
+ > :: b -> <a href="#" title="Bug1004"
+ >Product</a
+ > f g b -> <a href="#" title="Bug1004"
+ >Product</a
+ > f g a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Traversable:11"
></span
> (<a href="#" title="Data.Traversable"
>Traversable</a
@@ -803,7 +1096,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Traversable:9"
+ ><details id="i:id:Product:Traversable:11"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -868,7 +1161,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Alternative:10"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Alternative:12"
></span
> (<a href="#" title="Control.Applicative"
>Alternative</a
@@ -889,7 +1182,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Alternative:10"
+ ><details id="i:id:Product:Alternative:12"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -946,7 +1239,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Applicative:11"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Applicative:13"
></span
> (<a href="#" title="Control.Applicative"
>Applicative</a
@@ -967,7 +1260,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Applicative:11"
+ ><details id="i:id:Product:Applicative:13"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -1040,7 +1333,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Functor:12"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Functor:14"
></span
> (<a href="#" title="Data.Functor"
>Functor</a
@@ -1061,7 +1354,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Functor:12"
+ ><details id="i:id:Product:Functor:14"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -1098,7 +1391,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Monad:13"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Monad:15"
></span
> (<a href="#" title="Control.Monad"
>Monad</a
@@ -1119,7 +1412,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Monad:13"
+ ><details id="i:id:Product:Monad:15"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -1168,7 +1461,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:MonadPlus:14"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:MonadPlus:16"
></span
> (<a href="#" title="Control.Monad"
>MonadPlus</a
@@ -1189,7 +1482,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:MonadPlus:14"
+ ><details id="i:id:Product:MonadPlus:16"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -1226,7 +1519,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Data:15"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Data:17"
></span
> (<a href="#" title="Type.Reflection"
>Typeable</a
@@ -1255,7 +1548,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Data:15"
+ ><details id="i:id:Product:Data:17"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -1472,7 +1765,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Monoid:16"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Monoid:18"
></span
> (<a href="#" title="Data.Monoid"
>Monoid</a
@@ -1493,7 +1786,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Monoid:16"
+ ><details id="i:id:Product:Monoid:18"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -1540,7 +1833,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Semigroup:17"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Semigroup:19"
></span
> (<a href="#" title="Prelude"
>Semigroup</a
@@ -1561,7 +1854,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Semigroup:17"
+ ><details id="i:id:Product:Semigroup:19"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -1614,7 +1907,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Generic:18"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Generic:20"
></span
> <a href="#" title="GHC.Generics"
>Generic</a
@@ -1627,7 +1920,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Generic:18"
+ ><details id="i:id:Product:Generic:20"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -1637,20 +1930,100 @@
> <div class="subs associated-types"
><p class="caption"
>Associated Types</p
- ><p class="src"
- ><span class="keyword"
- >type</span
- > <a href="#" title="GHC.Generics"
- >Rep</a
- > (<a href="#" title="Bug1004"
- >Product</a
- > f g a) :: <a href="#" title="Data.Kind"
- >Type</a
- > -> <a href="#" title="Data.Kind"
- >Type</a
- > <a href="#" class="selflink"
- >#</a
- ></p
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Rep_Product:Rep:1"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="GHC.Generics"
+ >Rep</a
+ > (<a href="#" title="Bug1004"
+ >Product</a
+ > f g a)</span
+ ></td
+ ><td class="doc"
+ ><p
+ ><em
+ >Since: base-4.9.0.0</em
+ ></p
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:Rep_Product:Rep:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Data.Functor.Product</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="GHC.Generics"
+ >Rep</a
+ > (<a href="#" title="Bug1004"
+ >Product</a
+ > f g a) = <a href="#" title="GHC.Generics"
+ >D1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaData</a
+ > "Product" "Data.Functor.Product" "base" '<a href="#" title="Data.Bool"
+ >False</a
+ >) (<a href="#" title="GHC.Generics"
+ >C1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaCons</a
+ > "Pair" '<a href="#" title="GHC.Generics"
+ >PrefixI</a
+ > '<a href="#" title="Data.Bool"
+ >False</a
+ >) (<a href="#" title="GHC.Generics"
+ >S1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaSel</a
+ > ('<a href="#" title="Data.Maybe"
+ >Nothing</a
+ > :: <a href="#" title="Data.Maybe"
+ >Maybe</a
+ > <a href="#" title="GHC.TypeLits"
+ >Symbol</a
+ >) '<a href="#" title="GHC.Generics"
+ >NoSourceUnpackedness</a
+ > '<a href="#" title="GHC.Generics"
+ >NoSourceStrictness</a
+ > '<a href="#" title="GHC.Generics"
+ >DecidedLazy</a
+ >) (<a href="#" title="GHC.Generics"
+ >Rec0</a
+ > (f a)) <a href="#" title="GHC.Generics"
+ >:*:</a
+ > <a href="#" title="GHC.Generics"
+ >S1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaSel</a
+ > ('<a href="#" title="Data.Maybe"
+ >Nothing</a
+ > :: <a href="#" title="Data.Maybe"
+ >Maybe</a
+ > <a href="#" title="GHC.TypeLits"
+ >Symbol</a
+ >) '<a href="#" title="GHC.Generics"
+ >NoSourceUnpackedness</a
+ > '<a href="#" title="GHC.Generics"
+ >NoSourceStrictness</a
+ > '<a href="#" title="GHC.Generics"
+ >DecidedLazy</a
+ >) (<a href="#" title="GHC.Generics"
+ >Rec0</a
+ > (g a))))</div
+ ></details
+ ></td
+ ></tr
+ ></table
></div
> <div class="subs methods"
><p class="caption"
@@ -1686,7 +2059,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Read:19"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Read:21"
></span
> (<a href="#" title="Text.Read"
>Read</a
@@ -1707,7 +2080,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Read:19"
+ ><details id="i:id:Product:Read:21"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -1766,7 +2139,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Show:20"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Show:22"
></span
> (<a href="#" title="Text.Show"
>Show</a
@@ -1787,7 +2160,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Show:20"
+ ><details id="i:id:Product:Show:22"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -1836,7 +2209,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Eq:21"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Eq:23"
></span
> (<a href="#" title="Data.Eq"
>Eq</a
@@ -1857,7 +2230,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Eq:21"
+ ><details id="i:id:Product:Eq:23"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -1898,7 +2271,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Ord:22"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Ord:24"
></span
> (<a href="#" title="Data.Ord"
>Ord</a
@@ -1919,7 +2292,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Ord:22"
+ ><details id="i:id:Product:Ord:24"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -2020,7 +2393,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Rep1:23"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Rep1:25"
></span
> <span class="keyword"
>type</span
@@ -2041,7 +2414,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Rep1:23"
+ ><details id="i:id:Product:Rep1:25"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -2116,7 +2489,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Rep:24"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Rep:26"
></span
> <span class="keyword"
>type</span
@@ -2135,7 +2508,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:Product:Rep:24"
+ ><details id="i:id:Product:Rep:26"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
diff --git a/html-test/ref/Bug1033.html b/html-test/ref/Bug1033.html
index 327739a886..ee63caae98 100644
--- a/html-test/ref/Bug1033.html
+++ b/html-test/ref/Bug1033.html
@@ -109,20 +109,66 @@
> <div class="subs associated-types"
><p class="caption"
>Associated Types</p
- ><p class="src"
- ><span class="keyword"
- >type</span
- > <a href="#" title="GHC.Generics"
- >Rep</a
- > <a href="#" title="Bug1033"
- >Foo</a
- > :: <a href="#" title="Data.Kind"
- >Type</a
- > -> <a href="#" title="Data.Kind"
- >Type</a
- > <a href="#" class="selflink"
- >#</a
- ></p
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Rep_Foo:Rep:1"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="GHC.Generics"
+ >Rep</a
+ > <a href="#" title="Bug1033"
+ >Foo</a
+ ></span
+ ></td
+ ><td class="doc"
+ ><p
+ >This does some generic foos.</p
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:Rep_Foo:Rep:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Bug1033</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="GHC.Generics"
+ >Rep</a
+ > <a href="#" title="Bug1033"
+ >Foo</a
+ > = <a href="#" title="GHC.Generics"
+ >D1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaData</a
+ > "Foo" "Bug1033" "main" '<a href="#" title="Data.Bool"
+ >False</a
+ >) (<a href="#" title="GHC.Generics"
+ >C1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaCons</a
+ > "Foo" '<a href="#" title="GHC.Generics"
+ >PrefixI</a
+ > '<a href="#" title="Data.Bool"
+ >False</a
+ >) (<a href="#" title="GHC.Generics"
+ >U1</a
+ > :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >))</div
+ ></details
+ ></td
+ ></tr
+ ></table
></div
> <div class="subs methods"
><p class="caption"
diff --git a/html-test/ref/Bug1035.html b/html-test/ref/Bug1035.html
index 9df26a9587..891e230d2c 100644
--- a/html-test/ref/Bug1035.html
+++ b/html-test/ref/Bug1035.html
@@ -138,7 +138,7 @@
><p
>A link to <code
><a href="#" title="Bug1035"
- >Foo</a
+ >Bar</a
></code
></p
></div
diff --git a/html-test/ref/Bug1050.html b/html-test/ref/Bug1050.html
index 89fa19ce30..71ec191917 100644
--- a/html-test/ref/Bug1050.html
+++ b/html-test/ref/Bug1050.html
@@ -57,15 +57,11 @@
>newtype</span
> <a id="t:T" class="def"
>T</a
- > :: (<span class="keyword"
+ > (a :: <span class="keyword"
>forall</span
> k. k -> <a href="#" title="Data.Kind"
>Type</a
- >) -> <span class="keyword"
- >forall</span
- > k. k -> <a href="#" title="Data.Kind"
- >Type</a
- > <span class="keyword"
+ >) (b :: k) <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
@@ -80,13 +76,13 @@
>MkT</a
> :: <span class="keyword"
>forall</span
- > (f :: <span class="keyword"
+ > (a :: <span class="keyword"
>forall</span
> k. k -> <a href="#" title="Data.Kind"
>Type</a
- >) k (a :: k). f a -> <a href="#" title="Bug1050"
+ >) k (b :: k). a b -> <a href="#" title="Bug1050"
>T</a
- > f a</td
+ > a b</td
><td class="doc empty"
> </td
></tr
@@ -101,7 +97,7 @@
>forall</span
> {k} {f :: <span class="keyword"
>forall</span
- > k. k -> <a href="#" title="Data.Kind"
+ > k1. k1 -> <a href="#" title="Data.Kind"
>Type</a
>} {a :: k}. f a -> <a href="#" title="Bug1050"
>T</a
diff --git a/html-test/ref/Bug294.html b/html-test/ref/Bug294.html
index c62fc6069e..ff27890727 100644
--- a/html-test/ref/Bug294.html
+++ b/html-test/ref/Bug294.html
@@ -197,7 +197,7 @@
>data family</span
> <a id="t:TP" class="def"
>TP</a
- > t :: * <a href="#" class="selflink"
+ > t <a href="#" class="selflink"
>#</a
></p
><div class="subs instances"
@@ -259,7 +259,7 @@
>data family</span
> <a id="t:DP" class="def"
>DP</a
- > t :: * <a href="#" class="selflink"
+ > t <a href="#" class="selflink"
>#</a
></p
><div class="subs instances"
@@ -321,7 +321,7 @@
>data family</span
> <a id="t:TO-39-" class="def"
>TO'</a
- > t :: * <a href="#" class="selflink"
+ > t <a href="#" class="selflink"
>#</a
></p
><div class="subs instances"
diff --git a/html-test/ref/Bug466.html b/html-test/ref/Bug466.html
index 4fab918a0e..40fa85e277 100644
--- a/html-test/ref/Bug466.html
+++ b/html-test/ref/Bug466.html
@@ -68,7 +68,9 @@
>type</span
> <a id="t:Fam" class="def"
>Fam</a
- > a :: [*] <a href="#" class="selflink"
+ > a :: [<a href="#" title="Data.Kind"
+ >Type</a
+ >] <a href="#" class="selflink"
>#</a
></p
></div
@@ -107,18 +109,46 @@
> <div class="subs associated-types"
><p class="caption"
>Associated Types</p
- ><p class="src"
- ><span class="keyword"
- >type</span
- > <a href="#" title="Bug466"
- >Fam</a
- > <a href="#" title="Bug466"
- >X</a
- > :: [<a href="#" title="Data.Kind"
- >Type</a
- >] <a href="#" class="selflink"
- >#</a
- ></p
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:D:R:FamX:Fam:1"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="Bug466"
+ >Fam</a
+ > <a href="#" title="Bug466"
+ >X</a
+ ></span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:D:R:FamX:Fam:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Bug466</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="Bug466"
+ >Fam</a
+ > <a href="#" title="Bug466"
+ >X</a
+ > = '[<a href="#" title="Data.Char"
+ >Char</a
+ >]</div
+ ></details
+ ></td
+ ></tr
+ ></table
></div
></details
></td
@@ -185,18 +215,46 @@
> <div class="subs associated-types"
><p class="caption"
>Associated Types</p
- ><p class="src"
- ><span class="keyword"
- >type</span
- > <a href="#" title="Bug466"
- >Fam</a
- > <a href="#" title="Bug466"
- >X</a
- > :: [<a href="#" title="Data.Kind"
- >Type</a
- >] <a href="#" class="selflink"
- >#</a
- ></p
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:D:R:FamX:Fam:1"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="Bug466"
+ >Fam</a
+ > <a href="#" title="Bug466"
+ >X</a
+ ></span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:D:R:FamX:Fam:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Bug466</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="Bug466"
+ >Fam</a
+ > <a href="#" title="Bug466"
+ >X</a
+ > = '[<a href="#" title="Data.Char"
+ >Char</a
+ >]</div
+ ></details
+ ></td
+ ></tr
+ ></table
></div
></details
></td
diff --git a/html-test/ref/Bug548.html b/html-test/ref/Bug548.html
index 594480c7f6..b692d66075 100644
--- a/html-test/ref/Bug548.html
+++ b/html-test/ref/Bug548.html
@@ -135,18 +135,84 @@
> <div class="subs associated-types"
><p class="caption"
>Associated Types</p
- ><p class="src"
- ><span class="keyword"
- >type</span
- > <a href="#" title="GHC.Generics"
- >Rep1</a
- > (<a href="#" title="Bug548"
- >WrappedArrow</a
- > a b) :: k -> <a href="#" title="Data.Kind"
- >Type</a
- > <a href="#" class="selflink"
- >#</a
- ></p
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Rep1_WrappedArrow:Rep1:1"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="GHC.Generics"
+ >Rep1</a
+ > (<a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >)</span
+ ></td
+ ><td class="doc"
+ ><p
+ ><em
+ >Since: base-4.7.0.0</em
+ ></p
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:Rep1_WrappedArrow:Rep1:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Control.Applicative</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="GHC.Generics"
+ >Rep1</a
+ > (<a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) = <a href="#" title="GHC.Generics"
+ >D1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaData</a
+ > "WrappedArrow" "Control.Applicative" "base" '<a href="#" title="Data.Bool"
+ >True</a
+ >) (<a href="#" title="GHC.Generics"
+ >C1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaCons</a
+ > "WrapArrow" '<a href="#" title="GHC.Generics"
+ >PrefixI</a
+ > '<a href="#" title="Data.Bool"
+ >True</a
+ >) (<a href="#" title="GHC.Generics"
+ >S1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaSel</a
+ > ('<a href="#" title="Data.Maybe"
+ >Just</a
+ > "unwrapArrow") '<a href="#" title="GHC.Generics"
+ >NoSourceUnpackedness</a
+ > '<a href="#" title="GHC.Generics"
+ >NoSourceStrictness</a
+ > '<a href="#" title="GHC.Generics"
+ >DecidedLazy</a
+ >) (<a href="#" title="GHC.Generics"
+ >Rec1</a
+ > (a b))))</div
+ ></details
+ ></td
+ ></tr
+ ></table
></div
> <div class="subs methods"
><p class="caption"
@@ -154,9 +220,7 @@
><p class="src"
><a href="#"
>from1</a
- > :: <span class="keyword"
- >forall</span
- > (a0 :: k). <a href="#" title="Bug548"
+ > :: <a href="#" title="Bug548"
>WrappedArrow</a
> a b a0 -> <a href="#" title="GHC.Generics"
>Rep1</a
@@ -168,9 +232,7 @@
><p class="src"
><a href="#"
>to1</a
- > :: <span class="keyword"
- >forall</span
- > (a0 :: k). <a href="#" title="GHC.Generics"
+ > :: <a href="#" title="GHC.Generics"
>Rep1</a
> (<a href="#" title="Bug548"
>WrappedArrow</a
@@ -412,7 +474,249 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:WrappedArrow:Generic:5"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:WrappedArrow:Data:5"
+ ></span
+ > (<a href="#" title="Type.Reflection"
+ >Typeable</a
+ > a, <a href="#" title="Type.Reflection"
+ >Typeable</a
+ > b, <a href="#" title="Type.Reflection"
+ >Typeable</a
+ > c, <a href="#" title="Data.Data"
+ >Data</a
+ > (a b c)) => <a href="#" title="Data.Data"
+ >Data</a
+ > (<a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c)</span
+ ></td
+ ><td class="doc"
+ ><p
+ ><em
+ >Since: base-4.14.0.0</em
+ ></p
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:id:WrappedArrow:Data:5"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Data.Data</a
+ ></p
+ > <div class="subs methods"
+ ><p class="caption"
+ >Methods</p
+ ><p class="src"
+ ><a href="#"
+ >gfoldl</a
+ > :: (<span class="keyword"
+ >forall</span
+ > d b0. <a href="#" title="Data.Data"
+ >Data</a
+ > d => c0 (d -> b0) -> d -> c0 b0) -> (<span class="keyword"
+ >forall</span
+ > g. g -> c0 g) -> <a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c -> c0 (<a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c) <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >gunfold</a
+ > :: (<span class="keyword"
+ >forall</span
+ > b0 r. <a href="#" title="Data.Data"
+ >Data</a
+ > b0 => c0 (b0 -> r) -> c0 r) -> (<span class="keyword"
+ >forall</span
+ > r. r -> c0 r) -> <a href="#" title="Data.Data"
+ >Constr</a
+ > -> c0 (<a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c) <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >toConstr</a
+ > :: <a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c -> <a href="#" title="Data.Data"
+ >Constr</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >dataTypeOf</a
+ > :: <a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c -> <a href="#" title="Data.Data"
+ >DataType</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >dataCast1</a
+ > :: <a href="#" title="Type.Reflection"
+ >Typeable</a
+ > t => (<span class="keyword"
+ >forall</span
+ > d. <a href="#" title="Data.Data"
+ >Data</a
+ > d => c0 (t d)) -> <a href="#" title="Data.Maybe"
+ >Maybe</a
+ > (c0 (<a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c)) <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >dataCast2</a
+ > :: <a href="#" title="Type.Reflection"
+ >Typeable</a
+ > t => (<span class="keyword"
+ >forall</span
+ > d e. (<a href="#" title="Data.Data"
+ >Data</a
+ > d, <a href="#" title="Data.Data"
+ >Data</a
+ > e) => c0 (t d e)) -> <a href="#" title="Data.Maybe"
+ >Maybe</a
+ > (c0 (<a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c)) <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >gmapT</a
+ > :: (<span class="keyword"
+ >forall</span
+ > b0. <a href="#" title="Data.Data"
+ >Data</a
+ > b0 => b0 -> b0) -> <a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c -> <a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >gmapQl</a
+ > :: (r -> r' -> r) -> r -> (<span class="keyword"
+ >forall</span
+ > d. <a href="#" title="Data.Data"
+ >Data</a
+ > d => d -> r') -> <a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c -> r <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >gmapQr</a
+ > :: <span class="keyword"
+ >forall</span
+ > r r'. (r' -> r -> r) -> r -> (<span class="keyword"
+ >forall</span
+ > d. <a href="#" title="Data.Data"
+ >Data</a
+ > d => d -> r') -> <a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c -> r <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >gmapQ</a
+ > :: (<span class="keyword"
+ >forall</span
+ > d. <a href="#" title="Data.Data"
+ >Data</a
+ > d => d -> u) -> <a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c -> [u] <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >gmapQi</a
+ > :: <a href="#" title="Data.Int"
+ >Int</a
+ > -> (<span class="keyword"
+ >forall</span
+ > d. <a href="#" title="Data.Data"
+ >Data</a
+ > d => d -> u) -> <a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c -> u <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >gmapM</a
+ > :: <a href="#" title="Control.Monad"
+ >Monad</a
+ > m => (<span class="keyword"
+ >forall</span
+ > d. <a href="#" title="Data.Data"
+ >Data</a
+ > d => d -> m d) -> <a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c -> m (<a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c) <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >gmapMp</a
+ > :: <a href="#" title="Control.Monad"
+ >MonadPlus</a
+ > m => (<span class="keyword"
+ >forall</span
+ > d. <a href="#" title="Data.Data"
+ >Data</a
+ > d => d -> m d) -> <a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c -> m (<a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c) <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><p class="src"
+ ><a href="#"
+ >gmapMo</a
+ > :: <a href="#" title="Control.Monad"
+ >MonadPlus</a
+ > m => (<span class="keyword"
+ >forall</span
+ > d. <a href="#" title="Data.Data"
+ >Data</a
+ > d => d -> m d) -> <a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c -> m (<a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c) <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:WrappedArrow:Generic:6"
></span
> <a href="#" title="GHC.Generics"
>Generic</a
@@ -425,7 +729,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:WrappedArrow:Generic:5"
+ ><details id="i:id:WrappedArrow:Generic:6"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -435,20 +739,76 @@
> <div class="subs associated-types"
><p class="caption"
>Associated Types</p
- ><p class="src"
- ><span class="keyword"
- >type</span
- > <a href="#" title="GHC.Generics"
- >Rep</a
- > (<a href="#" title="Bug548"
- >WrappedArrow</a
- > a b c) :: <a href="#" title="Data.Kind"
- >Type</a
- > -> <a href="#" title="Data.Kind"
- >Type</a
- > <a href="#" class="selflink"
- >#</a
- ></p
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:Rep_WrappedArrow:Rep:1"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="GHC.Generics"
+ >Rep</a
+ > (<a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c)</span
+ ></td
+ ><td class="doc"
+ ><p
+ ><em
+ >Since: base-4.7.0.0</em
+ ></p
+ ></td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:Rep_WrappedArrow:Rep:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Control.Applicative</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="GHC.Generics"
+ >Rep</a
+ > (<a href="#" title="Bug548"
+ >WrappedArrow</a
+ > a b c) = <a href="#" title="GHC.Generics"
+ >D1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaData</a
+ > "WrappedArrow" "Control.Applicative" "base" '<a href="#" title="Data.Bool"
+ >True</a
+ >) (<a href="#" title="GHC.Generics"
+ >C1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaCons</a
+ > "WrapArrow" '<a href="#" title="GHC.Generics"
+ >PrefixI</a
+ > '<a href="#" title="Data.Bool"
+ >True</a
+ >) (<a href="#" title="GHC.Generics"
+ >S1</a
+ > ('<a href="#" title="GHC.Generics"
+ >MetaSel</a
+ > ('<a href="#" title="Data.Maybe"
+ >Just</a
+ > "unwrapArrow") '<a href="#" title="GHC.Generics"
+ >NoSourceUnpackedness</a
+ > '<a href="#" title="GHC.Generics"
+ >NoSourceStrictness</a
+ > '<a href="#" title="GHC.Generics"
+ >DecidedLazy</a
+ >) (<a href="#" title="GHC.Generics"
+ >Rec0</a
+ > (a b c))))</div
+ ></details
+ ></td
+ ></tr
+ ></table
></div
> <div class="subs methods"
><p class="caption"
@@ -484,7 +844,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:WrappedArrow:Rep1:6"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:WrappedArrow:Rep1:7"
></span
> <span class="keyword"
>type</span
@@ -507,7 +867,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:WrappedArrow:Rep1:6"
+ ><details id="i:id:WrappedArrow:Rep1:7"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
@@ -560,7 +920,7 @@
><tr
><td class="src clearfix"
><span class="inst-left"
- ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:WrappedArrow:Rep:7"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:WrappedArrow:Rep:8"
></span
> <span class="keyword"
>type</span
@@ -579,7 +939,7 @@
></tr
><tr
><td colspan="2"
- ><details id="i:id:WrappedArrow:Rep:7"
+ ><details id="i:id:WrappedArrow:Rep:8"
><summary class="hide-when-js-enabled"
>Instance details</summary
><p
diff --git a/html-test/ref/Bug574.html b/html-test/ref/Bug574.html
index 8264bfc0e0..ae6fea1bc0 100644
--- a/html-test/ref/Bug574.html
+++ b/html-test/ref/Bug574.html
@@ -36,7 +36,7 @@
><th
>Safe Haskell</th
><td
- >Safe-Inferred</td
+ >None</td
></tr
><tr
><th
diff --git a/html-test/ref/Bug613.html b/html-test/ref/Bug613.html
index 425fc670b6..16cd5b932a 100644
--- a/html-test/ref/Bug613.html
+++ b/html-test/ref/Bug613.html
@@ -58,7 +58,11 @@
>class</span
> <a href="#"
>Functor</a
- > f <span class="keyword"
+ > (f :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) <span class="keyword"
>where</span
><ul class="subs"
><li
@@ -87,7 +91,11 @@
>class</span
> <a id="t:Functor" class="def"
>Functor</a
- > f <span class="keyword"
+ > (f :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
diff --git a/html-test/ref/Bug679.html b/html-test/ref/Bug679.html
index 50dbed5a8b..1bf2ccfdbd 100644
--- a/html-test/ref/Bug679.html
+++ b/html-test/ref/Bug679.html
@@ -36,7 +36,7 @@
><th
>Safe Haskell</th
><td
- >Safe-Inferred</td
+ >None</td
></tr
><tr
><th
diff --git a/html-test/ref/Bug8.html b/html-test/ref/Bug8.html
index e62caae38a..fda107707f 100644
--- a/html-test/ref/Bug8.html
+++ b/html-test/ref/Bug8.html
@@ -95,7 +95,7 @@
><p class="src"
><a id="v:-45--45--62-" class="def"
>(-->)</a
- > :: p -> p -> <a href="#" title="Bug8"
+ > :: p1 -> p2 -> <a href="#" title="Bug8"
>Typ</a
> <span class="fixity"
>infix 9</span
diff --git a/html-test/ref/Bug85.html b/html-test/ref/Bug85.html
index c22438c77f..714635da82 100644
--- a/html-test/ref/Bug85.html
+++ b/html-test/ref/Bug85.html
@@ -57,7 +57,11 @@
>data</span
> <a id="t:Foo" class="def"
>Foo</a
- > :: (* -> *) -> * -> * <span class="keyword"
+ > (a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) b <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
@@ -70,9 +74,15 @@
><td class="src"
><a id="v:Bar" class="def"
>Bar</a
- > :: f x -> <a href="#" title="Bug85"
+ > :: <span class="keyword"
+ >forall</span
+ > (a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) x. a x -> <a href="#" title="Bug85"
>Foo</a
- > f (f x)</td
+ > a (a x)</td
><td class="doc empty"
> </td
></tr
@@ -85,7 +95,7 @@
>data</span
> <a id="t:Baz" class="def"
>Baz</a
- > :: * <span class="keyword"
+ > <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
diff --git a/html-test/ref/Bug923.html b/html-test/ref/Bug923.html
index c8a2ba7d13..4d19f8d45f 100644
--- a/html-test/ref/Bug923.html
+++ b/html-test/ref/Bug923.html
@@ -58,17 +58,31 @@
>data</span
> <a href="#"
>T</a
- > :: (* -> (*, *)) -> * <span class="keyword"
+ > (a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> (<a href="#" title="Data.Kind"
+ >Type</a
+ >, <a href="#" title="Data.Kind"
+ >Type</a
+ >)) <span class="keyword"
>where</span
><ul class="subs"
><li
><a href="#"
>T</a
- > :: a -> <a href="#" title="Bug923"
+ > :: <span class="keyword"
+ >forall</span
+ > a1. a1 -> <a href="#" title="Bug923"
>T</a
- > ('<a href="#" title="GHC.Tuple.Prim"
+ > ('<a href="#" title="Data.Tuple"
>(,)</a
- > a)</li
+ > a1 :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> (<a href="#" title="Data.Kind"
+ >Type</a
+ >, <a href="#" title="Data.Kind"
+ >Type</a
+ >))</li
></ul
></li
></ul
@@ -83,7 +97,13 @@
>data</span
> <a id="t:T" class="def"
>T</a
- > :: (* -> (*, *)) -> * <span class="keyword"
+ > (a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> (<a href="#" title="Data.Kind"
+ >Type</a
+ >, <a href="#" title="Data.Kind"
+ >Type</a
+ >)) <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
@@ -100,11 +120,19 @@
><td class="src"
><a id="v:T" class="def"
>T</a
- > :: a -> <a href="#" title="Bug923"
+ > :: <span class="keyword"
+ >forall</span
+ > a1. a1 -> <a href="#" title="Bug923"
>T</a
- > ('<a href="#" title="GHC.Tuple.Prim"
+ > ('<a href="#" title="Data.Tuple"
>(,)</a
- > a)</td
+ > a1 :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> (<a href="#" title="Data.Kind"
+ >Type</a
+ >, <a href="#" title="Data.Kind"
+ >Type</a
+ >))</td
><td class="doc empty"
> </td
></tr
@@ -128,7 +156,7 @@
>Eq</a
> (<a href="#" title="Bug923"
>T</a
- > ('<a href="#" title="GHC.Tuple.Prim"
+ > ('<a href="#" title="Data.Tuple"
>(,)</a
> a :: <a href="#" title="Data.Kind"
>Type</a
@@ -162,13 +190,25 @@
>(==)</a
> :: <a href="#" title="Bug923"
>T</a
- > ('<a href="#" title="GHC.Tuple.Prim"
+ > ('<a href="#" title="Data.Tuple"
>(,)</a
- > a) -> <a href="#" title="Bug923"
+ > a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> (<a href="#" title="Data.Kind"
+ >Type</a
+ >, <a href="#" title="Data.Kind"
+ >Type</a
+ >)) -> <a href="#" title="Bug923"
>T</a
- > ('<a href="#" title="GHC.Tuple.Prim"
+ > ('<a href="#" title="Data.Tuple"
>(,)</a
- > a) -> <a href="#" title="Data.Bool"
+ > a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> (<a href="#" title="Data.Kind"
+ >Type</a
+ >, <a href="#" title="Data.Kind"
+ >Type</a
+ >)) -> <a href="#" title="Data.Bool"
>Bool</a
> <a href="#" class="selflink"
>#</a
@@ -178,13 +218,25 @@
>(/=)</a
> :: <a href="#" title="Bug923"
>T</a
- > ('<a href="#" title="GHC.Tuple.Prim"
+ > ('<a href="#" title="Data.Tuple"
>(,)</a
- > a) -> <a href="#" title="Bug923"
+ > a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> (<a href="#" title="Data.Kind"
+ >Type</a
+ >, <a href="#" title="Data.Kind"
+ >Type</a
+ >)) -> <a href="#" title="Bug923"
>T</a
- > ('<a href="#" title="GHC.Tuple.Prim"
+ > ('<a href="#" title="Data.Tuple"
>(,)</a
- > a) -> <a href="#" title="Data.Bool"
+ > a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> (<a href="#" title="Data.Kind"
+ >Type</a
+ >, <a href="#" title="Data.Kind"
+ >Type</a
+ >)) -> <a href="#" title="Data.Bool"
>Bool</a
> <a href="#" class="selflink"
>#</a
diff --git a/html-test/ref/Bug973.html b/html-test/ref/Bug973.html
index 8297b4f4e8..74b3a9e714 100644
--- a/html-test/ref/Bug973.html
+++ b/html-test/ref/Bug973.html
@@ -56,9 +56,7 @@
><li class="src short"
><a href="#"
>showRead</a
- > :: <span class="keyword"
- >forall</span
- > a b. (<a href="#" title="Text.Show"
+ > :: (<a href="#" title="Text.Show"
>Show</a
> a, <a href="#" title="Text.Read"
>Read</a
@@ -92,9 +90,7 @@
><table
><tr
><td class="src"
- >:: <span class="keyword"
- >forall</span
- > a b. (<a href="#" title="Text.Show"
+ >:: (<a href="#" title="Text.Show"
>Show</a
> a, <a href="#" title="Text.Read"
>Read</a
diff --git a/html-test/ref/BundledPatterns.html b/html-test/ref/BundledPatterns.html
index 94a197c2cd..93b7fe6352 100644
--- a/html-test/ref/BundledPatterns.html
+++ b/html-test/ref/BundledPatterns.html
@@ -36,7 +36,7 @@
><th
>Safe Haskell</th
><td
- >Safe-Inferred</td
+ >None</td
></tr
><tr
><th
@@ -58,17 +58,19 @@
>data</span
> <a href="#"
>Vec</a
- > :: <a href="#" title="GHC.TypeNats"
+ > (a :: <a href="#" title="GHC.TypeNats"
>Nat</a
- > -> * -> * <span class="keyword"
+ >) b <span class="keyword"
>where</span
><ul class="subs"
><li
><a href="#"
>Nil</a
- > :: <a href="#" title="BundledPatterns"
+ > :: <span class="keyword"
+ >forall</span
+ > b. <a href="#" title="BundledPatterns"
>Vec</a
- > 0 a</li
+ > 0 b</li
><li
><span class="keyword"
>pattern</span
@@ -88,9 +90,9 @@
>data</span
> <a href="#"
>RTree</a
- > :: <a href="#" title="GHC.TypeNats"
+ > (a :: <a href="#" title="GHC.TypeNats"
>Nat</a
- > -> * -> * <span class="keyword"
+ >) b <span class="keyword"
>where</span
><ul class="subs"
><li
@@ -129,9 +131,9 @@
>data</span
> <a id="t:Vec" class="def"
>Vec</a
- > :: <a href="#" title="GHC.TypeNats"
+ > (a :: <a href="#" title="GHC.TypeNats"
>Nat</a
- > -> * -> * <span class="keyword"
+ >) b <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
@@ -167,9 +169,11 @@
><td class="src"
><a id="v:Nil" class="def"
>Nil</a
- > :: <a href="#" title="BundledPatterns"
+ > :: <span class="keyword"
+ >forall</span
+ > b. <a href="#" title="BundledPatterns"
>Vec</a
- > 0 a</td
+ > 0 b</td
><td class="doc empty"
> </td
></tr
@@ -291,9 +295,9 @@
>data</span
> <a id="t:RTree" class="def"
>RTree</a
- > :: <a href="#" title="GHC.TypeNats"
+ > (a :: <a href="#" title="GHC.TypeNats"
>Nat</a
- > -> * -> * <span class="keyword"
+ >) b <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
diff --git a/html-test/ref/BundledPatterns2.html b/html-test/ref/BundledPatterns2.html
index 3b19205474..e8c099d97e 100644
--- a/html-test/ref/BundledPatterns2.html
+++ b/html-test/ref/BundledPatterns2.html
@@ -36,7 +36,7 @@
><th
>Safe Haskell</th
><td
- >Safe-Inferred</td
+ >None</td
></tr
><tr
><th
@@ -58,9 +58,9 @@
>data</span
> <a href="#"
>Vec</a
- > :: <a href="#" title="GHC.TypeNats"
+ > (a :: <a href="#" title="GHC.TypeNats"
>Nat</a
- > -> * -> * <span class="keyword"
+ >) b <span class="keyword"
>where</span
><ul class="subs"
><li
@@ -90,9 +90,9 @@
>data</span
> <a href="#"
>RTree</a
- > :: <a href="#" title="GHC.TypeNats"
+ > (a :: <a href="#" title="GHC.TypeNats"
>Nat</a
- > -> * -> * <span class="keyword"
+ >) b <span class="keyword"
>where</span
><ul class="subs"
><li
@@ -131,9 +131,9 @@
>data</span
> <a id="t:Vec" class="def"
>Vec</a
- > :: <a href="#" title="GHC.TypeNats"
+ > (a :: <a href="#" title="GHC.TypeNats"
>Nat</a
- > -> * -> * <span class="keyword"
+ >) b <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
@@ -289,9 +289,9 @@
>data</span
> <a id="t:RTree" class="def"
>RTree</a
- > :: <a href="#" title="GHC.TypeNats"
+ > (a :: <a href="#" title="GHC.TypeNats"
>Nat</a
- > -> * -> * <span class="keyword"
+ >) b <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
diff --git a/html-test/ref/ConstructorPatternExport.html b/html-test/ref/ConstructorPatternExport.html
index aa0c1a8f3d..9830ed8113 100644
--- a/html-test/ref/ConstructorPatternExport.html
+++ b/html-test/ref/ConstructorPatternExport.html
@@ -107,7 +107,7 @@
>pattern</span
> <a id="v:MyGADTCons" class="def"
>MyGADTCons</a
- > :: a -> <a href="#" title="Data.Int"
+ > :: a1 -> <a href="#" title="Data.Int"
>Int</a
> -> MyGADT (<a href="#" title="Data.Maybe"
>Maybe</a
diff --git a/html-test/ref/DefaultAssociatedTypes.html b/html-test/ref/DefaultAssociatedTypes.html
index bc4d8a001e..470f719ec7 100644
--- a/html-test/ref/DefaultAssociatedTypes.html
+++ b/html-test/ref/DefaultAssociatedTypes.html
@@ -66,11 +66,15 @@
>type</span
> <a href="#"
>Qux</a
- > a :: *</li
+ > a</li
><li
><a href="#"
>bar</a
- >, <a href="#"
+ > :: a -> <a href="#" title="Data.String"
+ >String</a
+ ></li
+ ><li
+ ><a href="#"
>baz</a
> :: a -> <a href="#" title="Data.String"
>String</a
@@ -106,7 +110,7 @@
>type</span
> <a id="t:Qux" class="def"
>Qux</a
- > a :: * <a href="#" class="selflink"
+ > a <a href="#" class="selflink"
>#</a
></p
><div class="doc"
diff --git a/html-test/ref/DefaultSignatures.html b/html-test/ref/DefaultSignatures.html
index f44cc85970..b0ba01b31c 100644
--- a/html-test/ref/DefaultSignatures.html
+++ b/html-test/ref/DefaultSignatures.html
@@ -64,7 +64,11 @@
><li
><a href="#"
>bar</a
- >, <a href="#"
+ > :: a -> <a href="#" title="Data.String"
+ >String</a
+ ></li
+ ><li
+ ><a href="#"
>baz</a
> :: a -> <a href="#" title="Data.String"
>String</a
@@ -136,6 +140,10 @@
> <a href="#" class="selflink"
>#</a
></p
+ ><div class="doc"
+ ><p
+ >Documentation for the default signature of bar.</p
+ ></div
></div
><p class="src"
><a id="v:baz" class="def"
@@ -176,6 +184,10 @@
> -> a <a href="#" class="selflink"
>#</a
></p
+ ><div class="doc"
+ ><p
+ >Documentation for the default signature of baz'.</p
+ ></div
></div
></div
></div
diff --git a/html-test/ref/DeprecatedTypeFamily.html b/html-test/ref/DeprecatedTypeFamily.html
index 4fbaeaa5e9..e923dbd225 100644
--- a/html-test/ref/DeprecatedTypeFamily.html
+++ b/html-test/ref/DeprecatedTypeFamily.html
@@ -58,13 +58,21 @@
>data family</span
> <a href="#"
>SomeTypeFamily</a
- > k :: * -> *</li
+ > k :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ ></li
><li class="src short"
><span class="keyword"
>data family</span
> <a href="#"
>SomeOtherTypeFamily</a
- > k :: * -> *</li
+ > k :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ ></li
></ul
></details
></div
@@ -77,7 +85,11 @@
>data family</span
> <a id="t:SomeTypeFamily" class="def"
>SomeTypeFamily</a
- > k :: * -> * <a href="#" class="selflink"
+ > k :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ > <a href="#" class="selflink"
>#</a
></p
><div class="doc"
@@ -95,7 +107,11 @@
>data family</span
> <a id="t:SomeOtherTypeFamily" class="def"
>SomeOtherTypeFamily</a
- > k :: * -> * <a href="#" class="selflink"
+ > k :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ > <a href="#" class="selflink"
>#</a
></p
><div class="doc"
diff --git a/html-test/ref/FunArgs.html b/html-test/ref/FunArgs.html
index 3e38a9ccfe..a0481b46ed 100644
--- a/html-test/ref/FunArgs.html
+++ b/html-test/ref/FunArgs.html
@@ -64,9 +64,7 @@
><table
><tr
><td class="src"
- >:: <span class="keyword"
- >forall</span
- > a. <a href="#" title="Data.Ord"
+ >:: <a href="#" title="Data.Ord"
>Ord</a
> a</td
><td class="doc empty"
@@ -178,9 +176,7 @@
><table
><tr
><td class="src"
- >:: <span class="keyword"
- >forall</span
- > a b c. a</td
+ >:: a</td
><td class="doc"
><p
>First argument</p
@@ -230,11 +226,9 @@
><td class="src"
>:: <span class="keyword"
>forall</span
- > a (b :: ()) d. d <a href="#" title="Data.Type.Equality"
+ > a (b :: ()) (d :: ()). d <a href="#" title="Data.Type.Equality"
>~</a
- > '<a href="#" title="GHC.Tuple.Prim"
- >()</a
- ></td
+ > '()</td
><td class="doc empty"
> </td
></tr
diff --git a/html-test/ref/GADTRecords.html b/html-test/ref/GADTRecords.html
index 834d8f6723..7f9f80f67a 100644
--- a/html-test/ref/GADTRecords.html
+++ b/html-test/ref/GADTRecords.html
@@ -64,13 +64,17 @@
><li
><a href="#"
>C1</a
- > :: <a href="#" title="GADTRecords"
+ > :: <span class="keyword"
+ >forall</span
+ > a b. <a href="#" title="GADTRecords"
>H1</a
> a b</li
><li
><a href="#"
>C2</a
- > :: <a href="#" title="Data.Ord"
+ > :: <span class="keyword"
+ >forall</span
+ > a. <a href="#" title="Data.Ord"
>Ord</a
> a => [a] -> <a href="#" title="GADTRecords"
>H1</a
@@ -88,11 +92,13 @@
><li
><a href="#"
>C4</a
- > :: {..} -> <a href="#" title="GADTRecords"
+ > :: <span class="keyword"
+ >forall</span
+ > b. {..} -> <a href="#" title="GADTRecords"
>H1</a
> <a href="#" title="Data.Int"
>Int</a
- > a</li
+ > b</li
></ul
></li
></ul
@@ -124,7 +130,9 @@
><td class="src"
><a id="v:C1" class="def"
>C1</a
- > :: <a href="#" title="GADTRecords"
+ > :: <span class="keyword"
+ >forall</span
+ > a b. <a href="#" title="GADTRecords"
>H1</a
> a b</td
><td class="doc empty"
@@ -134,7 +142,9 @@
><td class="src"
><a id="v:C2" class="def"
>C2</a
- > :: <a href="#" title="Data.Ord"
+ > :: <span class="keyword"
+ >forall</span
+ > a. <a href="#" title="Data.Ord"
>Ord</a
> a => [a] -> <a href="#" title="GADTRecords"
>H1</a
@@ -200,9 +210,11 @@
><ul
><li
><dfn class="src"
- >:: { <a id="v:field2" class="def"
+ >:: <span class="keyword"
+ >forall</span
+ > b. { <a id="v:field2" class="def"
>field2</a
- > :: a</dfn
+ > :: b</dfn
><div class="doc"
><p
>hello2 docs</p
@@ -214,7 +226,7 @@
>H1</a
> <a href="#" title="Data.Int"
>Int</a
- > a</dfn
+ > b</dfn
><div class="doc empty"
> </div
></li
diff --git a/html-test/ref/Identifiers.html b/html-test/ref/Identifiers.html
index 76487140a9..4f1ebf2a89 100644
--- a/html-test/ref/Identifiers.html
+++ b/html-test/ref/Identifiers.html
@@ -152,7 +152,7 @@
></li
><li
>Qualified: <code
- ><a href="#" title="GHC.List"
+ ><a href="#" title="Data.List"
>++</a
></code
>, <code
@@ -207,7 +207,7 @@
><li
>Qualified: <code
><code
- ><a href="#" title="GHC.List"
+ ><a href="#" title="Data.List"
>(++)</a
></code
> [1,2,3] [4,5,6]</code
@@ -245,7 +245,7 @@
><li
>Qualified: <code
>1 <code
- ><a href="#" title="Data.Foldable"
+ ><a href="#" title="Data.List"
>`elem`</a
></code
> [-3..3]</code
diff --git a/html-test/ref/Instances.html b/html-test/ref/Instances.html
index 8721a5b583..c1736aeb91 100644
--- a/html-test/ref/Instances.html
+++ b/html-test/ref/Instances.html
@@ -153,7 +153,11 @@
>class</span
> <a id="t:Foo" class="def"
>Foo</a
- > f <span class="keyword"
+ > (f :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
@@ -440,7 +444,7 @@
>Foo</a
> f) => <a href="#" title="Instances"
>Foo</a
- > (<a href="#" title="GHC.Tuple.Prim"
+ > (<a href="#" title="Data.Tuple"
>Tuple2</a
> (f a))</span
> <a href="#" class="selflink"
@@ -464,11 +468,11 @@
><p class="src"
><a href="#"
>foo</a
- > :: <a href="#" title="GHC.Tuple.Prim"
+ > :: <a href="#" title="Data.Tuple"
>Tuple2</a
> (f a) <a href="#" title="Data.Int"
>Int</a
- > -> a0 -> <a href="#" title="GHC.Tuple.Prim"
+ > -> a0 -> <a href="#" title="Data.Tuple"
>Tuple2</a
> (f a) a0 <a href="#" class="selflink"
>#</a
@@ -476,15 +480,15 @@
><p class="src"
><a href="#"
>foo'</a
- > :: <a href="#" title="GHC.Tuple.Prim"
+ > :: <a href="#" title="Data.Tuple"
>Tuple2</a
- > (f a) (<a href="#" title="GHC.Tuple.Prim"
+ > (f a) (<a href="#" title="Data.Tuple"
>Tuple2</a
> (f a) a0) -> <a href="#" title="Data.Int"
>Int</a
- > -> <a href="#" title="GHC.Tuple.Prim"
+ > -> <a href="#" title="Data.Tuple"
>Tuple2</a
- > (f a) (<a href="#" title="GHC.Tuple.Prim"
+ > (f a) (<a href="#" title="Data.Tuple"
>Tuple2</a
> (f a) <a href="#" title="Data.Int"
>Int</a
@@ -564,7 +568,7 @@
></span
> <a href="#" title="Instances"
>Foo</a
- > (<a href="#" title="GHC.Tuple.Prim"
+ > (<a href="#" title="Data.Tuple"
>Tuple3</a
> a a)</span
> <a href="#" class="selflink"
@@ -588,11 +592,11 @@
><p class="src"
><a href="#"
>foo</a
- > :: <a href="#" title="GHC.Tuple.Prim"
+ > :: <a href="#" title="Data.Tuple"
>Tuple3</a
> a a <a href="#" title="Data.Int"
>Int</a
- > -> a0 -> <a href="#" title="GHC.Tuple.Prim"
+ > -> a0 -> <a href="#" title="Data.Tuple"
>Tuple3</a
> a a a0 <a href="#" class="selflink"
>#</a
@@ -600,15 +604,15 @@
><p class="src"
><a href="#"
>foo'</a
- > :: <a href="#" title="GHC.Tuple.Prim"
+ > :: <a href="#" title="Data.Tuple"
>Tuple3</a
- > a a (<a href="#" title="GHC.Tuple.Prim"
+ > a a (<a href="#" title="Data.Tuple"
>Tuple3</a
> a a a0) -> <a href="#" title="Data.Int"
>Int</a
- > -> <a href="#" title="GHC.Tuple.Prim"
+ > -> <a href="#" title="Data.Tuple"
>Tuple3</a
- > a a (<a href="#" title="GHC.Tuple.Prim"
+ > a a (<a href="#" title="Data.Tuple"
>Tuple3</a
> a a <a href="#" title="Data.Int"
>Int</a
@@ -679,7 +683,11 @@
>Foo</a
> f => <a id="t:Bar" class="def"
>Bar</a
- > f a <span class="keyword"
+ > (f :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) a <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
@@ -1178,11 +1186,11 @@
></span
> <a href="#" title="Instances"
>Foo</a
- > (<a href="#" title="GHC.Tuple.Prim"
+ > (<a href="#" title="Data.Tuple"
>Tuple3</a
> a b) => <a href="#" title="Instances"
>Bar</a
- > (<a href="#" title="GHC.Tuple.Prim"
+ > (<a href="#" title="Data.Tuple"
>Tuple3</a
> a b) (a, b, a)</span
> <a href="#" class="selflink"
@@ -1206,9 +1214,9 @@
><p class="src"
><a href="#"
>bar</a
- > :: <a href="#" title="GHC.Tuple.Prim"
+ > :: <a href="#" title="Data.Tuple"
>Tuple3</a
- > a b (a, b, a) -> <a href="#" title="GHC.Tuple.Prim"
+ > a b (a, b, a) -> <a href="#" title="Data.Tuple"
>Tuple3</a
> a b <a href="#" title="Data.Bool"
>Bool</a
@@ -1218,15 +1226,15 @@
><p class="src"
><a href="#"
>bar'</a
- > :: <a href="#" title="GHC.Tuple.Prim"
+ > :: <a href="#" title="Data.Tuple"
>Tuple3</a
- > a b (<a href="#" title="GHC.Tuple.Prim"
+ > a b (<a href="#" title="Data.Tuple"
>Tuple3</a
- > a b (a, b, a)) -> <a href="#" title="GHC.Tuple.Prim"
+ > a b (a, b, a)) -> <a href="#" title="Data.Tuple"
>Tuple3</a
- > a b (<a href="#" title="GHC.Tuple.Prim"
+ > a b (<a href="#" title="Data.Tuple"
>Tuple3</a
- > a b (<a href="#" title="GHC.Tuple.Prim"
+ > a b (<a href="#" title="Data.Tuple"
>Tuple3</a
> a b b0)) <a href="#" class="selflink"
>#</a
@@ -1234,13 +1242,13 @@
><p class="src"
><a href="#"
>bar0</a
- > :: (<a href="#" title="GHC.Tuple.Prim"
+ > :: (<a href="#" title="Data.Tuple"
>Tuple3</a
- > a b (a, b, a), <a href="#" title="GHC.Tuple.Prim"
+ > a b (a, b, a), <a href="#" title="Data.Tuple"
>Tuple3</a
- > a b (a, b, a)) -> (<a href="#" title="GHC.Tuple.Prim"
+ > a b (a, b, a)) -> (<a href="#" title="Data.Tuple"
>Tuple3</a
- > a b b0, <a href="#" title="GHC.Tuple.Prim"
+ > a b b0, <a href="#" title="Data.Tuple"
>Tuple3</a
> a b c) <a href="#" class="selflink"
>#</a
@@ -1248,13 +1256,13 @@
><p class="src"
><a href="#"
>bar1</a
- > :: (<a href="#" title="GHC.Tuple.Prim"
+ > :: (<a href="#" title="Data.Tuple"
>Tuple3</a
- > a b (a, b, a), <a href="#" title="GHC.Tuple.Prim"
+ > a b (a, b, a), <a href="#" title="Data.Tuple"
>Tuple3</a
- > a b (a, b, a)) -> (<a href="#" title="GHC.Tuple.Prim"
+ > a b (a, b, a)) -> (<a href="#" title="Data.Tuple"
>Tuple3</a
- > a b b0, <a href="#" title="GHC.Tuple.Prim"
+ > a b b0, <a href="#" title="Data.Tuple"
>Tuple3</a
> a b c) <a href="#" class="selflink"
>#</a
@@ -1292,9 +1300,9 @@
>baz</a
> :: a -> (<span class="keyword"
>forall</span
- > a. a -> a) -> (b, <span class="keyword"
+ > a1. a1 -> a1) -> (b, <span class="keyword"
>forall</span
- > c. c -> a) -> (b, c) <a href="#" class="selflink"
+ > c1. c1 -> a) -> (b, c) <a href="#" class="selflink"
>#</a
></p
><p class="src"
@@ -1302,9 +1310,9 @@
>baz'</a
> :: b -> (<span class="keyword"
>forall</span
- > b. b -> a) -> (<span class="keyword"
+ > b1. b1 -> a) -> (<span class="keyword"
>forall</span
- > b. b -> a) -> [(b, a)] <a href="#" class="selflink"
+ > b1. b1 -> a) -> [(b, a)] <a href="#" class="selflink"
>#</a
></p
><p class="src"
@@ -1312,11 +1320,11 @@
>baz''</a
> :: b -> (<span class="keyword"
>forall</span
- > b. (<span class="keyword"
+ > b1. (<span class="keyword"
>forall</span
- > b. b -> a) -> c) -> <span class="keyword"
+ > b2. b2 -> a) -> c) -> <span class="keyword"
>forall</span
- > c. c -> b <a href="#" class="selflink"
+ > c1. c1 -> b <a href="#" class="selflink"
>#</a
></p
></div
@@ -2089,28 +2097,182 @@
> <div class="subs associated-types"
><p class="caption"
>Associated Types</p
- ><p class="src"
- ><span class="keyword"
- >type</span
- > <a href="#" title="Instances"
- >Plugh</a
- > <a href="#" title="Data.Int"
- >Int</a
- > c <a href="#" title="Data.Bool"
- >Bool</a
- > <a href="#" class="selflink"
- >#</a
- ></p
- ><p class="src"
- ><span class="keyword"
- >data</span
- > <a href="#" title="Instances"
- >Thud</a
- > <a href="#" title="Data.Int"
- >Int</a
- > c <a href="#" class="selflink"
- >#</a
- ></p
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:D:R:PlughInt-40--44--41-Bool:Plugh:1"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="Instances"
+ >Plugh</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > (a, b) <a href="#" title="Data.Bool"
+ >Bool</a
+ ></span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:D:R:PlughInt-40--44--41-Bool:Plugh:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Instances</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="Instances"
+ >Plugh</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > (a, b) <a href="#" title="Data.Bool"
+ >Bool</a
+ > = (a, [b])</div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:D:R:PlughIntListBool:Plugh:2"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="Instances"
+ >Plugh</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > [a] <a href="#" title="Data.Bool"
+ >Bool</a
+ ></span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:D:R:PlughIntListBool:Plugh:2"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Instances</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="Instances"
+ >Plugh</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > [a] <a href="#" title="Data.Bool"
+ >Bool</a
+ > = a</div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:D:R:ThudIntList0:Thud:3"
+ ></span
+ > <span class="keyword"
+ >data</span
+ > <a href="#" title="Instances"
+ >Thud</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > [a]</span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:D:R:ThudIntList0:Thud:3"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Instances</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >data</span
+ > <a href="#" title="Instances"
+ >Thud</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > [a] = <a id="v:Thuuuud" class="def"
+ >Thuuuud</a
+ > <a href="#" title="Data.Bool"
+ >Bool</a
+ ></div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:D:R:ThudIntQuux0:Thud:4"
+ ></span
+ > <span class="keyword"
+ >data</span
+ > <a href="#" title="Instances"
+ >Thud</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > (<a href="#" title="Instances"
+ >Quux</a
+ > a [a] c)</span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:D:R:ThudIntQuux0:Thud:4"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >Instances</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >data</span
+ > <a href="#" title="Instances"
+ >Thud</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > (<a href="#" title="Instances"
+ >Quux</a
+ > a [a] c) <ul class="inst"
+ ><li class="inst"
+ >= <a id="v:Thuud" class="def"
+ >Thuud</a
+ > a</li
+ ><li class="inst"
+ >| <a id="v:Thuuud" class="def"
+ >Thuuud</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ > <a href="#" title="Data.Int"
+ >Int</a
+ ></li
+ ></ul
+ ></div
+ ></details
+ ></td
+ ></tr
+ ></table
></div
> <div class="subs methods"
><p class="caption"
@@ -2160,26 +2322,6 @@
>Defined in <a href="#"
>Instances</a
></p
- > <div class="subs associated-types"
- ><p class="caption"
- >Associated Types</p
- ><p class="src"
- ><span class="keyword"
- >type</span
- > <a href="#" title="Instances"
- >Plugh</a
- > [a] c [b] <a href="#" class="selflink"
- >#</a
- ></p
- ><p class="src"
- ><span class="keyword"
- >data</span
- > <a href="#" title="Instances"
- >Thud</a
- > [a] c <a href="#" class="selflink"
- >#</a
- ></p
- ></div
> <div class="subs methods"
><p class="caption"
>Methods</p
diff --git a/html-test/ref/LinearTypes.html b/html-test/ref/LinearTypes.html
index fbece396bd..151ea84812 100644
--- a/html-test/ref/LinearTypes.html
+++ b/html-test/ref/LinearTypes.html
@@ -64,7 +64,11 @@
><li class="src short"
><a href="#"
>poly</a
- > :: a %m -> b</li
+ > :: <span class="keyword"
+ >forall</span
+ > a b (m :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >). a %m -> b</li
></ul
></details
></div
@@ -99,7 +103,11 @@
><p class="src"
><a id="v:poly" class="def"
>poly</a
- > :: a %m -> b <a href="#" class="selflink"
+ > :: <span class="keyword"
+ >forall</span
+ > a b (m :: <a href="#" title="GHC.Exts"
+ >Multiplicity</a
+ >). a %m -> b <a href="#" class="selflink"
>#</a
></p
><div class="doc"
diff --git a/html-test/ref/Operators.html b/html-test/ref/Operators.html
index 9ebbe42d06..ea67771e62 100644
--- a/html-test/ref/Operators.html
+++ b/html-test/ref/Operators.html
@@ -114,7 +114,9 @@
><li
><a href="#"
>(:<->)</a
- > :: a -> b -> a <a href="#" title="Operators"
+ > :: <span class="keyword"
+ >forall</span
+ > a b. a -> b -> a <a href="#" title="Operators"
><-></a
> b</li
></ul
@@ -144,7 +146,7 @@
>type</span
> a <a href="#"
><><</a
- > b :: *</li
+ > b</li
><li
><span class="keyword"
>data</span
@@ -154,17 +156,25 @@
><li
><a href="#"
>(>><)</a
- >, <a href="#"
+ > :: a -> b -> ()</li
+ ><li
+ ><a href="#"
>(<<>)</a
> :: a -> b -> ()</li
><li
><a href="#"
>(**>)</a
- >, <a href="#"
+ > :: a -> a -> ()</li
+ ><li
+ ><a href="#"
>(**<)</a
- >, <a href="#"
+ > :: a -> a -> ()</li
+ ><li
+ ><a href="#"
>(>**)</a
- >, <a href="#"
+ > :: a -> a -> ()</li
+ ><li
+ ><a href="#"
>(<**)</a
> :: a -> a -> ()</li
></ul
@@ -328,7 +338,9 @@
><td class="src"
><a id="v::-60--45--62-" class="def"
>(:<->)</a
- > :: a -> b -> a <a href="#" title="Operators"
+ > :: <span class="keyword"
+ >forall</span
+ > a b. a -> b -> a <a href="#" title="Operators"
><-></a
> b <span class="fixity"
>infixr 6</span
@@ -404,7 +416,7 @@
>type</span
> a <a id="t:-60--62--60-" class="def"
><><</a
- > b :: * <span class="fixity"
+ > b <span class="fixity"
>infixl 2</span
><span class="rightedge"
></span
diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html
index 54c2ce005c..66b6bfeb75 100644
--- a/html-test/ref/PatternSyns.html
+++ b/html-test/ref/PatternSyns.html
@@ -104,9 +104,7 @@
>data</span
> <a href="#"
>BlubType</a
- > = <span class="keyword"
- >forall</span
- > x.<a href="#" title="Text.Show"
+ > = <a href="#" title="Text.Show"
>Show</a
> x => <a href="#"
>BlubCtor</a
@@ -124,9 +122,9 @@
><li class="src short"
><span class="keyword"
>data</span
- > (a :: *) <a href="#"
+ > a <a href="#"
>><</a
- > b = <a href="#"
+ > (b :: k) = <a href="#"
>Empty</a
></li
><li class="src short"
@@ -266,9 +264,7 @@
><table
><tr
><td class="src"
- ><span class="keyword"
- >forall</span
- > x.<a href="#" title="Text.Show"
+ ><a href="#" title="Text.Show"
>Show</a
> x => <a id="v:BlubCtor" class="def"
>BlubCtor</a
@@ -305,17 +301,15 @@
><p class="src"
><span class="keyword"
>data</span
- > (a :: *) <a id="t:-62--60-" class="def"
+ > a <a id="t:-62--60-" class="def"
>><</a
- > b <a href="#" class="selflink"
+ > (b :: k) <a href="#" class="selflink"
>#</a
></p
><div class="doc"
><p
>Doc for (<code
- ><a href="#" title="PatternSyns"
- >><</a
- ></code
+ >><</code
>)</p
></div
><div class="subs constructors"
diff --git a/html-test/ref/PromotedTypes.html b/html-test/ref/PromotedTypes.html
index d13a6bd80f..17aea0d9cf 100644
--- a/html-test/ref/PromotedTypes.html
+++ b/html-test/ref/PromotedTypes.html
@@ -91,7 +91,9 @@
>data</span
> <a id="t:Pattern" class="def"
>Pattern</a
- > :: [*] -> * <span class="keyword"
+ > (a :: [<a href="#" title="Data.Kind"
+ >Type</a
+ >]) <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
@@ -106,7 +108,9 @@
>Nil</a
> :: <a href="#" title="PromotedTypes"
>Pattern</a
- > '[]</td
+ > ('[] :: [<a href="#" title="Data.Kind"
+ >Type</a
+ >])</td
><td class="doc empty"
> </td
></tr
@@ -114,13 +118,19 @@
><td class="src"
><a id="v:Cons" class="def"
>Cons</a
- > :: <a href="#" title="Data.Maybe"
+ > :: <span class="keyword"
+ >forall</span
+ > h (t :: [<a href="#" title="Data.Kind"
+ >Type</a
+ >]). <a href="#" title="Data.Maybe"
>Maybe</a
> h -> <a href="#" title="PromotedTypes"
>Pattern</a
> t -> <a href="#" title="PromotedTypes"
>Pattern</a
- > (h ': t)</td
+ > (h '<a href="#" title="Data.List"
+ >:</a
+ > t)</td
><td class="doc empty"
> </td
></tr
@@ -133,9 +143,11 @@
>data</span
> <a id="t:RevPattern" class="def"
>RevPattern</a
- > :: <a href="#" title="PromotedTypes"
+ > (a :: <a href="#" title="PromotedTypes"
>RevList</a
- > * -> * <span class="keyword"
+ > <a href="#" title="Data.Kind"
+ >Type</a
+ >) <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
@@ -150,9 +162,13 @@
>RevNil</a
> :: <a href="#" title="PromotedTypes"
>RevPattern</a
- > <a href="#" title="PromotedTypes"
+ > ('<a href="#" title="PromotedTypes"
>RNil</a
- ></td
+ > :: <a href="#" title="PromotedTypes"
+ >RevList</a
+ > <a href="#" title="Data.Kind"
+ >Type</a
+ >)</td
><td class="doc empty"
> </td
></tr
@@ -160,13 +176,19 @@
><td class="src"
><a id="v:RevCons" class="def"
>RevCons</a
- > :: <a href="#" title="Data.Maybe"
+ > :: <span class="keyword"
+ >forall</span
+ > h (t :: <a href="#" title="PromotedTypes"
+ >RevList</a
+ > <a href="#" title="Data.Kind"
+ >Type</a
+ >). <a href="#" title="Data.Maybe"
>Maybe</a
> h -> <a href="#" title="PromotedTypes"
>RevPattern</a
> t -> <a href="#" title="PromotedTypes"
>RevPattern</a
- > (t <a href="#" title="PromotedTypes"
+ > (t '<a href="#" title="PromotedTypes"
>:></a
> h)</td
><td class="doc empty"
@@ -181,7 +203,11 @@
>data</span
> <a id="t:Tuple" class="def"
>Tuple</a
- > :: (*, *) -> * <span class="keyword"
+ > (a :: (<a href="#" title="Data.Kind"
+ >Type</a
+ >, <a href="#" title="Data.Kind"
+ >Type</a
+ >)) <span class="keyword"
>where</span
> <a href="#" class="selflink"
>#</a
@@ -194,9 +220,11 @@
><td class="src"
><a id="v:Tuple" class="def"
>Tuple</a
- > :: a -> b -> <a href="#" title="PromotedTypes"
+ > :: <span class="keyword"
+ >forall</span
+ > a1 b. a1 -> b -> <a href="#" title="PromotedTypes"
>Tuple</a
- > '(a, b)</td
+ > '(a1, b)</td
><td class="doc empty"
> </td
></tr
diff --git a/html-test/ref/QuasiExpr.html b/html-test/ref/QuasiExpr.html
index b7660f202e..70820d486d 100644
--- a/html-test/ref/QuasiExpr.html
+++ b/html-test/ref/QuasiExpr.html
@@ -36,7 +36,7 @@
><th
>Safe Haskell</th
><td
- >Safe-Inferred</td
+ >None</td
></tr
><tr
><th
diff --git a/html-test/ref/QuasiQuote.html b/html-test/ref/QuasiQuote.html
index 210c52481b..155f27d8e8 100644
--- a/html-test/ref/QuasiQuote.html
+++ b/html-test/ref/QuasiQuote.html
@@ -36,7 +36,7 @@
><th
>Safe Haskell</th
><td
- >Safe-Inferred</td
+ >None</td
></tr
><tr
><th
diff --git a/html-test/ref/SpuriousSuperclassConstraints.html b/html-test/ref/SpuriousSuperclassConstraints.html
index cbdc89561a..8d4fe07539 100644
--- a/html-test/ref/SpuriousSuperclassConstraints.html
+++ b/html-test/ref/SpuriousSuperclassConstraints.html
@@ -83,7 +83,11 @@ Fix spurious superclass constraints bug.</pre
>data</span
> <a id="t:SomeType" class="def"
>SomeType</a
- > (f :: * -> *) a <a href="#" class="selflink"
+ > (f :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) a <a href="#" class="selflink"
>#</a
></p
><div class="subs instances"
diff --git a/html-test/ref/TH.html b/html-test/ref/TH.html
index 6019257147..06fcc70fac 100644
--- a/html-test/ref/TH.html
+++ b/html-test/ref/TH.html
@@ -36,7 +36,7 @@
><th
>Safe Haskell</th
><td
- >Safe-Inferred</td
+ >None</td
></tr
><tr
><th
diff --git a/html-test/ref/TH2.html b/html-test/ref/TH2.html
index 98f2315fdc..f9191fb414 100644
--- a/html-test/ref/TH2.html
+++ b/html-test/ref/TH2.html
@@ -36,7 +36,7 @@
><th
>Safe Haskell</th
><td
- >Safe-Inferred</td
+ >None</td
></tr
><tr
><th
diff --git a/html-test/ref/Test.html b/html-test/ref/Test.html
index a4fdb39164..7121c06918 100644
--- a/html-test/ref/Test.html
+++ b/html-test/ref/Test.html
@@ -285,7 +285,11 @@
>newtype</span
> <a href="#"
>N2</a
- > a b = <a href="#"
+ > (a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) b = <a href="#"
>N2</a
> {<ul class="subs"
><li
@@ -299,7 +303,11 @@
>newtype</span
> <a href="#"
>N3</a
- > a b = <a href="#"
+ > (a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) b = <a href="#"
>N3</a
> {<ul class="subs"
><li
@@ -319,7 +327,11 @@
>newtype</span
> <a href="#"
>N5</a
- > a b = <a href="#"
+ > (a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) b = <a href="#"
>N5</a
> {<ul class="subs"
><li
@@ -333,7 +345,11 @@
>newtype</span
> <a href="#"
>N6</a
- > a b = <a href="#"
+ > (a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) b = <a href="#"
>N6</a
> {<ul class="subs"
><li
@@ -347,7 +363,11 @@
>newtype</span
> <a href="#"
>N7</a
- > a b = <a href="#"
+ > (a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) b = <a href="#"
>N7</a
> {<ul class="subs"
><li
@@ -381,7 +401,11 @@
><li
><a href="#"
>r</a
- >, <a href="#"
+ > :: <a href="#" title="Data.Int"
+ >Int</a
+ ></li
+ ><li
+ ><a href="#"
>s</a
> :: <a href="#" title="Data.Int"
>Int</a
@@ -419,7 +443,11 @@
><li
><a href="#"
>u</a
- >, <a href="#"
+ > :: <a href="#" title="Data.Int"
+ >Int</a
+ ></li
+ ><li
+ ><a href="#"
>v</a
> :: <a href="#" title="Data.Int"
>Int</a
@@ -585,23 +613,17 @@
>Ex</a
> a<ul class="subs"
><li
- >= <span class="keyword"
- >forall</span
- > b.<a href="#" title="Test"
+ >= <a href="#" title="Test"
>C</a
> b => <a href="#"
>Ex1</a
> b</li
><li
- >| <span class="keyword"
- >forall</span
- > b. <a href="#"
+ >| <a href="#"
>Ex2</a
> b</li
><li
- >| <span class="keyword"
- >forall</span
- > b.<a href="#" title="Test"
+ >| <a href="#" title="Test"
>C</a
> a => <a href="#"
>Ex3</a
@@ -611,7 +633,7 @@
>Ex4</a
> (<span class="keyword"
>forall</span
- > a. a -> a)</li
+ > a1. a1 -> a1)</li
></ul
></li
><li class="src short"
@@ -991,7 +1013,11 @@
>newtype</span
> <a id="t:N2" class="def"
>N2</a
- > a b <a href="#" class="selflink"
+ > (a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) b <a href="#" class="selflink"
>#</a
></p
><div class="doc"
@@ -1037,7 +1063,11 @@
>newtype</span
> <a id="t:N3" class="def"
>N3</a
- > a b <a href="#" class="selflink"
+ > (a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) b <a href="#" class="selflink"
>#</a
></p
><div class="doc"
@@ -1104,7 +1134,11 @@
>newtype</span
> <a id="t:N5" class="def"
>N5</a
- > a b <a href="#" class="selflink"
+ > (a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) b <a href="#" class="selflink"
>#</a
></p
><div class="subs constructors"
@@ -1148,7 +1182,11 @@
>newtype</span
> <a id="t:N6" class="def"
>N6</a
- > a b <a href="#" class="selflink"
+ > (a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) b <a href="#" class="selflink"
>#</a
></p
><div class="subs constructors"
@@ -1192,7 +1230,11 @@
>newtype</span
> <a id="t:N7" class="def"
>N7</a
- > a b <a href="#" class="selflink"
+ > (a :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) b <a href="#" class="selflink"
>#</a
></p
><div class="doc"
@@ -1336,7 +1378,25 @@
><dfn class="src"
><a id="v:r" class="def"
>r</a
- >, <a id="v:s" class="def"
+ > :: <a href="#" title="Data.Int"
+ >Int</a
+ ></dfn
+ ><div class="doc"
+ ><p
+ >This comment applies to both <code
+ ><a href="#" title="Test"
+ >r</a
+ ></code
+ > and <code
+ ><a href="#" title="Test"
+ >s</a
+ ></code
+ ></p
+ ></div
+ ></li
+ ><li
+ ><dfn class="src"
+ ><a id="v:s" class="def"
>s</a
> :: <a href="#" title="Data.Int"
>Int</a
@@ -1410,7 +1470,15 @@
><dfn class="src"
><a id="v:u" class="def"
>u</a
- >, <a id="v:v" class="def"
+ > :: <a href="#" title="Data.Int"
+ >Int</a
+ ></dfn
+ ><div class="doc empty"
+ > </div
+ ></li
+ ><li
+ ><dfn class="src"
+ ><a id="v:v" class="def"
>v</a
> :: <a href="#" title="Data.Int"
>Int</a
@@ -2081,9 +2149,7 @@ is at the beginning of the line).</pre
><table
><tr
><td class="src"
- ><span class="keyword"
- >forall</span
- > b.<a href="#" title="Test"
+ ><a href="#" title="Test"
>C</a
> b => <a id="v:Ex1" class="def"
>Ex1</a
@@ -2093,9 +2159,7 @@ is at the beginning of the line).</pre
></tr
><tr
><td class="src"
- ><span class="keyword"
- >forall</span
- > b. <a id="v:Ex2" class="def"
+ ><a id="v:Ex2" class="def"
>Ex2</a
> b</td
><td class="doc empty"
@@ -2103,9 +2167,7 @@ is at the beginning of the line).</pre
></tr
><tr
><td class="src"
- ><span class="keyword"
- >forall</span
- > b.<a href="#" title="Test"
+ ><a href="#" title="Test"
>C</a
> a => <a id="v:Ex3" class="def"
>Ex3</a
@@ -2119,7 +2181,7 @@ is at the beginning of the line).</pre
>Ex4</a
> (<span class="keyword"
>forall</span
- > a. a -> a)</td
+ > a1. a1 -> a1)</td
><td class="doc empty"
> </td
></tr
diff --git a/html-test/ref/Threaded.html b/html-test/ref/Threaded.html
index 4a980f9434..f5ac3046aa 100644
--- a/html-test/ref/Threaded.html
+++ b/html-test/ref/Threaded.html
@@ -36,7 +36,7 @@
><th
>Safe Haskell</th
><td
- >Safe-Inferred</td
+ >None</td
></tr
><tr
><th
diff --git a/html-test/ref/Ticket112.html b/html-test/ref/Ticket112.html
index 42c9f7fb11..34998258d3 100644
--- a/html-test/ref/Ticket112.html
+++ b/html-test/ref/Ticket112.html
@@ -36,7 +36,7 @@
><th
>Safe Haskell</th
><td
- >Safe-Inferred</td
+ >None</td
></tr
><tr
><th
diff --git a/html-test/ref/TypeFamilies.html b/html-test/ref/TypeFamilies.html
index faf4137057..da57515ac9 100644
--- a/html-test/ref/TypeFamilies.html
+++ b/html-test/ref/TypeFamilies.html
@@ -108,7 +108,7 @@
>class</span
> <a href="#"
>Test</a
- > a</li
+ > (a :: k)</li
><li class="src short"
><span class="keyword"
>type family</span
@@ -120,13 +120,13 @@
>data family</span
> <a href="#"
>Bat</a
- > (a :: k) :: *</li
+ > (a :: k)</li
><li class="src short"
><span class="keyword"
>class</span
> <a href="#"
>Assoc</a
- > a <span class="keyword"
+ > (a :: k) <span class="keyword"
>where</span
><ul class="subs"
><li
@@ -134,13 +134,13 @@
>data</span
> <a href="#"
>AssocD</a
- > a :: *</li
+ > (a :: k)</li
><li
><span class="keyword"
>type</span
> <a href="#"
>AssocT</a
- > a :: *</li
+ > (a :: k)</li
></ul
></li
><li class="src short"
@@ -255,26 +255,88 @@
> <div class="subs associated-types"
><p class="caption"
>Associated Types</p
- ><p class="src"
- ><span class="keyword"
- >data</span
- > <a href="#" title="TypeFamilies"
- >AssocD</a
- > <a href="#" title="TypeFamilies"
- >X</a
- > <a href="#" class="selflink"
- >#</a
- ></p
- ><p class="src"
- ><span class="keyword"
- >type</span
- > <a href="#" title="TypeFamilies"
- >AssocT</a
- > <a href="#" title="TypeFamilies"
- >X</a
- > <a href="#" class="selflink"
- >#</a
- ></p
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:D:R:AssocDTYPEX0:AssocD:1"
+ ></span
+ > <span class="keyword"
+ >data</span
+ > <a href="#" title="TypeFamilies"
+ >AssocD</a
+ > <a href="#" title="TypeFamilies"
+ >X</a
+ ></span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:D:R:AssocDTYPEX0:AssocD:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >TypeFamilies</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >data</span
+ > <a href="#" title="TypeFamilies"
+ >AssocD</a
+ > <a href="#" title="TypeFamilies"
+ >X</a
+ > = <a id="v:AssocX" class="def"
+ >AssocX</a
+ ></div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:D:R:AssocTTYPEX:AssocT:2"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="TypeFamilies"
+ >AssocT</a
+ > <a href="#" title="TypeFamilies"
+ >X</a
+ ></span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:D:R:AssocTTYPEX:AssocT:2"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >TypeFamilies</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="TypeFamilies"
+ >AssocT</a
+ > <a href="#" title="TypeFamilies"
+ >X</a
+ > = <a href="#" title="TypeFamilies"
+ >Foo</a
+ > <a href="#" title="TypeFamilies"
+ >X</a
+ > :: <a href="#" title="Data.Kind"
+ >Type</a
+ ></div
+ ></details
+ ></td
+ ></tr
+ ></table
></div
></details
></td
@@ -715,26 +777,86 @@
> <div class="subs associated-types"
><p class="caption"
>Associated Types</p
- ><p class="src"
- ><span class="keyword"
- >data</span
- > <a href="#" title="TypeFamilies"
- >AssocD</a
- > <a href="#" title="TypeFamilies"
- >Y</a
- > <a href="#" class="selflink"
- >#</a
- ></p
- ><p class="src"
- ><span class="keyword"
- >type</span
- > <a href="#" title="TypeFamilies"
- >AssocT</a
- > <a href="#" title="TypeFamilies"
- >Y</a
- > <a href="#" class="selflink"
- >#</a
- ></p
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:D:R:AssocDTYPEY0:AssocD:1"
+ ></span
+ > <span class="keyword"
+ >data</span
+ > <a href="#" title="TypeFamilies"
+ >AssocD</a
+ > <a href="#" title="TypeFamilies"
+ >Y</a
+ ></span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:D:R:AssocDTYPEY0:AssocD:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >TypeFamilies</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >data</span
+ > <a href="#" title="TypeFamilies"
+ >AssocD</a
+ > <a href="#" title="TypeFamilies"
+ >Y</a
+ > = <a id="v:AssocY" class="def"
+ >AssocY</a
+ ></div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:D:R:AssocTTYPEY:AssocT:2"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="TypeFamilies"
+ >AssocT</a
+ > <a href="#" title="TypeFamilies"
+ >Y</a
+ ></span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:D:R:AssocTTYPEY:AssocT:2"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >TypeFamilies</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="TypeFamilies"
+ >AssocT</a
+ > <a href="#" title="TypeFamilies"
+ >Y</a
+ > = <a href="#" title="TypeFamilies"
+ >Bat</a
+ > <a href="#" title="TypeFamilies"
+ >Y</a
+ ></div
+ ></details
+ ></td
+ ></tr
+ ></table
></div
></details
></td
@@ -1135,7 +1257,7 @@
>class</span
> <a id="t:Test" class="def"
>Test</a
- > a <a href="#" class="selflink"
+ > (a :: k) <a href="#" class="selflink"
>#</a
></p
><div class="doc"
@@ -1327,7 +1449,7 @@
>data family</span
> <a id="t:Bat" class="def"
>Bat</a
- > (a :: k) :: * <a href="#" class="selflink"
+ > (a :: k) <a href="#" class="selflink"
>#</a
></p
><div class="doc"
@@ -1523,7 +1645,7 @@
>class</span
> <a id="t:Assoc" class="def"
>Assoc</a
- > a <a href="#" class="selflink"
+ > (a :: k) <a href="#" class="selflink"
>#</a
></p
><div class="doc"
@@ -1538,7 +1660,7 @@
>data</span
> <a id="t:AssocD" class="def"
>AssocD</a
- > a :: * <a href="#" class="selflink"
+ > (a :: k) <a href="#" class="selflink"
>#</a
></p
><div class="doc"
@@ -1550,7 +1672,7 @@
>type</span
> <a id="t:AssocT" class="def"
>AssocT</a
- > a :: * <a href="#" class="selflink"
+ > (a :: k) <a href="#" class="selflink"
>#</a
></p
><div class="doc"
@@ -1595,26 +1717,88 @@
> <div class="subs associated-types"
><p class="caption"
>Associated Types</p
- ><p class="src"
- ><span class="keyword"
- >data</span
- > <a href="#" title="TypeFamilies"
- >AssocD</a
- > <a href="#" title="TypeFamilies"
- >X</a
- > <a href="#" class="selflink"
- >#</a
- ></p
- ><p class="src"
- ><span class="keyword"
- >type</span
- > <a href="#" title="TypeFamilies"
- >AssocT</a
- > <a href="#" title="TypeFamilies"
- >X</a
- > <a href="#" class="selflink"
- >#</a
- ></p
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:D:R:AssocDTYPEX0:AssocD:1"
+ ></span
+ > <span class="keyword"
+ >data</span
+ > <a href="#" title="TypeFamilies"
+ >AssocD</a
+ > <a href="#" title="TypeFamilies"
+ >X</a
+ ></span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:D:R:AssocDTYPEX0:AssocD:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >TypeFamilies</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >data</span
+ > <a href="#" title="TypeFamilies"
+ >AssocD</a
+ > <a href="#" title="TypeFamilies"
+ >X</a
+ > = <a id="v:AssocX" class="def"
+ >AssocX</a
+ ></div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:D:R:AssocTTYPEX:AssocT:2"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="TypeFamilies"
+ >AssocT</a
+ > <a href="#" title="TypeFamilies"
+ >X</a
+ ></span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:D:R:AssocTTYPEX:AssocT:2"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >TypeFamilies</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="TypeFamilies"
+ >AssocT</a
+ > <a href="#" title="TypeFamilies"
+ >X</a
+ > = <a href="#" title="TypeFamilies"
+ >Foo</a
+ > <a href="#" title="TypeFamilies"
+ >X</a
+ > :: <a href="#" title="Data.Kind"
+ >Type</a
+ ></div
+ ></details
+ ></td
+ ></tr
+ ></table
></div
></details
></td
@@ -1649,26 +1833,86 @@
> <div class="subs associated-types"
><p class="caption"
>Associated Types</p
- ><p class="src"
- ><span class="keyword"
- >data</span
- > <a href="#" title="TypeFamilies"
- >AssocD</a
- > <a href="#" title="TypeFamilies"
- >Y</a
- > <a href="#" class="selflink"
- >#</a
- ></p
- ><p class="src"
- ><span class="keyword"
- >type</span
- > <a href="#" title="TypeFamilies"
- >AssocT</a
- > <a href="#" title="TypeFamilies"
- >Y</a
- > <a href="#" class="selflink"
- >#</a
- ></p
+ ><table
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:D:R:AssocDTYPEY0:AssocD:1"
+ ></span
+ > <span class="keyword"
+ >data</span
+ > <a href="#" title="TypeFamilies"
+ >AssocD</a
+ > <a href="#" title="TypeFamilies"
+ >Y</a
+ ></span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:D:R:AssocDTYPEY0:AssocD:1"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >TypeFamilies</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >data</span
+ > <a href="#" title="TypeFamilies"
+ >AssocD</a
+ > <a href="#" title="TypeFamilies"
+ >Y</a
+ > = <a id="v:AssocY" class="def"
+ >AssocY</a
+ ></div
+ ></details
+ ></td
+ ></tr
+ ><tr
+ ><td class="src clearfix"
+ ><span class="inst-left"
+ ><span class="instance details-toggle-control details-toggle" data-details-id="i:if:D:R:AssocTTYPEY:AssocT:2"
+ ></span
+ > <span class="keyword"
+ >type</span
+ > <a href="#" title="TypeFamilies"
+ >AssocT</a
+ > <a href="#" title="TypeFamilies"
+ >Y</a
+ ></span
+ ></td
+ ><td class="doc empty"
+ > </td
+ ></tr
+ ><tr
+ ><td colspan="2"
+ ><details id="i:if:D:R:AssocTTYPEY:AssocT:2"
+ ><summary class="hide-when-js-enabled"
+ >Instance details</summary
+ ><p
+ >Defined in <a href="#"
+ >TypeFamilies</a
+ ></p
+ > <div class="src"
+ ><span class="keyword"
+ >type</span
+ > <a href="#" title="TypeFamilies"
+ >AssocT</a
+ > <a href="#" title="TypeFamilies"
+ >Y</a
+ > = <a href="#" title="TypeFamilies"
+ >Bat</a
+ > <a href="#" title="TypeFamilies"
+ >Y</a
+ ></div
+ ></details
+ ></td
+ ></tr
+ ></table
></div
></details
></td
diff --git a/html-test/ref/TypeFamilies3.html b/html-test/ref/TypeFamilies3.html
index 5e2d1ea72a..81999bd2fc 100644
--- a/html-test/ref/TypeFamilies3.html
+++ b/html-test/ref/TypeFamilies3.html
@@ -112,7 +112,7 @@
><td class="src"
><a href="#" title="TypeFamilies3"
>Foo</a
- > _ = ()</td
+ > _1 = ()</td
><td class="doc empty"
> </td
></tr
diff --git a/html-test/ref/TypeOperators.html b/html-test/ref/TypeOperators.html
index f4882f1a09..46bd18df71 100644
--- a/html-test/ref/TypeOperators.html
+++ b/html-test/ref/TypeOperators.html
@@ -87,7 +87,15 @@
>newtype</span
> <a id="t:O" class="def"
>O</a
- > g f a <a href="#" class="selflink"
+ > (g :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) (f :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) a <a href="#" class="selflink"
>#</a
></p
><div class="subs constructors"
@@ -137,9 +145,19 @@
><p class="src"
><a id="v:biO" class="def"
>biO</a
- > :: (g <a href="#" title="TypeOperators"
- >`O`</a
- > f) a <a href="#" class="selflink"
+ > :: <span class="keyword"
+ >forall</span
+ > (g :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) (f :: <a href="#" title="Data.Kind"
+ >Type</a
+ > -> <a href="#" title="Data.Kind"
+ >Type</a
+ >) a. <a href="#" title="TypeOperators"
+ >O</a
+ > g f a <a href="#" class="selflink"
>#</a
></p
></div
@@ -173,9 +191,9 @@
>:-:</a
> a) <a href="#" title="TypeOperators"
><=></a
- > (a <a href="#" title="TypeOperators"
- >`Op`</a
- > a) => a <a href="#" class="selflink"
+ > <a href="#" title="TypeOperators"
+ >Op</a
+ > a a => a <a href="#" class="selflink"
>#</a
></p
></div
@@ -185,9 +203,9 @@
>y</a
> :: (a <a href="#" title="TypeOperators"
><=></a
- > a, (a <a href="#" title="TypeOperators"
- >`Op`</a
- > a) <a href="#" title="TypeOperators"
+ > a, <a href="#" title="TypeOperators"
+ >Op</a
+ > a a <a href="#" title="TypeOperators"
><=></a
> a) => a <a href="#" class="selflink"
>#</a
diff --git a/html-test/src/Bug294.hs b/html-test/src/Bug294.hs
index 922b8ee7df..4bd0bbe30e 100644
--- a/html-test/src/Bug294.hs
+++ b/html-test/src/Bug294.hs
@@ -10,11 +10,13 @@
module Bug294 ( A, problemField, problemField', gadtField
, TP(ProblemCtor), DP(ProblemCtor'), TO'(PolyCtor)) where
+import Data.Kind (Type)
+
data A
class T t where
- data TO t :: *
- data TP t :: *
+ data TO t :: Type
+ data TP t :: Type
t :: t
@@ -22,17 +24,17 @@ instance T A where
data TO A = TA { problemField :: A }
data TP A = ProblemCtor A
-data family DO t :: *
-data family DP t :: *
+data family DO t :: Type
+data family DP t :: Type
data instance DO A = DA { problemField' :: A }
data instance DP A = ProblemCtor' A
-data GADT :: * -> * where
+data GADT :: Type -> Type where
Ctor :: { gadtField :: A } -> GADT A
class T' t where
- data TO' t :: *
+ data TO' t :: Type
instance T' a where
data TO' a = PolyCtor
diff --git a/html-test/src/Bug466.hs b/html-test/src/Bug466.hs
index 697f0f7526..3f0d3acf91 100644
--- a/html-test/src/Bug466.hs
+++ b/html-test/src/Bug466.hs
@@ -2,8 +2,10 @@
{-# LANGUAGE DataKinds, TypeFamilies, StarIsType #-}
module Bug466 where
+import Data.Kind (Type)
+
class Cl a where
- type Fam a :: [*]
+ type Fam a :: [Type]
data X = X
instance Cl X where
diff --git a/html-test/src/Bug745.hs b/html-test/src/Bug574.hs
similarity index 100%
rename from html-test/src/Bug745.hs
rename to html-test/src/Bug574.hs
diff --git a/html-test/src/Bug647.hs b/html-test/src/Bug647.hs
index 7f1b9544ed..35330abc6c 100644
--- a/html-test/src/Bug647.hs
+++ b/html-test/src/Bug647.hs
@@ -2,6 +2,6 @@
module Bug647 where
class Bug647 a where
- f :: a -- ^ doc for arg1
- -> a -- ^ doc for arg2
- -> a -- ^ doc for arg3
\ No newline at end of file
+ f :: a -- ^ doc for arg1
+ -> a -- ^ doc for arg2
+ -> a -- ^ doc for arg3
\ No newline at end of file
diff --git a/html-test/src/Bug85.hs b/html-test/src/Bug85.hs
index 53979aee5f..e226c69d84 100644
--- a/html-test/src/Bug85.hs
+++ b/html-test/src/Bug85.hs
@@ -2,12 +2,14 @@
{-# LANGUAGE GADTs, KindSignatures #-}
module Bug85 where
+import Data.Kind (Type)
+
-- explicitly stated non-trivial kind
-data Foo :: (* -> *) -> * -> * where
+data Foo :: (Type -> Type) -> Type -> Type where
Bar :: f x -> Foo f (f x)
-- Just kind * but explicitly written
-data Baz :: * where
+data Baz :: Type where
Baz' :: Baz
-- No kind signature written down at all
diff --git a/html-test/src/Bug923.hs b/html-test/src/Bug923.hs
index 1d24a9f61e..68e1b15363 100644
--- a/html-test/src/Bug923.hs
+++ b/html-test/src/Bug923.hs
@@ -2,8 +2,10 @@
{-# LANGUAGE KindSignatures, FlexibleInstances, GADTs, DataKinds #-}
module Bug923 where
+import Data.Kind (Type)
+
-- | A promoted tuple type
-data T :: (* -> (*,*)) -> * where
+data T :: (Type -> (Type,Type)) -> Type where
T :: a -> T ('(,) a)
-- | A promoted tuple type in an instance
diff --git a/html-test/src/Bug975.hs b/html-test/src/Bug973.hs
similarity index 100%
rename from html-test/src/Bug975.hs
rename to html-test/src/Bug973.hs
diff --git a/html-test/src/BundledPatterns.hs b/html-test/src/BundledPatterns.hs
index 420068ac0c..6270e2cbda 100644
--- a/html-test/src/BundledPatterns.hs
+++ b/html-test/src/BundledPatterns.hs
@@ -3,6 +3,8 @@
ViewPatterns #-}
module BundledPatterns (Vec(Nil,(:>)), RTree (LR,BR)) where
+import Data.Kind (Type)
+
import GHC.TypeLits
import Prelude hiding (head, tail)
import Unsafe.Coerce
@@ -12,7 +14,7 @@ import Unsafe.Coerce
-- * Lists with their length encoded in their type
-- * 'Vec'tor elements have an __ASCENDING__ subscript starting from 0 and
-- ending at @'length' - 1@.
-data Vec :: Nat -> * -> * where
+data Vec :: Nat -> Type -> Type where
Nil :: Vec 0 a
Cons :: a -> Vec n a -> Vec (n + 1) a
@@ -58,7 +60,7 @@ tail (_ `Cons` xs) = unsafeCoerce xs
--
-- * Only has elements at the leaf of the tree
-- * A tree of depth /d/ has /2^d/ elements.
-data RTree :: Nat -> * -> * where
+data RTree :: Nat -> Type -> Type where
LR_ :: a -> RTree 0 a
BR_ :: RTree d a -> RTree d a -> RTree (d+1) a
diff --git a/html-test/src/ConstructorPatternExport.hs b/html-test/src/ConstructorPatternExport.hs
index aa2971d6f8..eb04b29c2f 100644
--- a/html-test/src/ConstructorPatternExport.hs
+++ b/html-test/src/ConstructorPatternExport.hs
@@ -12,6 +12,8 @@ module ConstructorPatternExport (
, pattern MyGADTCons
) where
+import Data.Kind (Type)
+
data Foo a = FooCons String a
data MyRec = MyRecCons { one :: Bool, two :: Int }
@@ -20,7 +22,7 @@ data MyInfix a = String :+ a
data Blub = forall b. Show b => BlubCons b
-data MyGADT :: * -> * where
+data MyGADT :: Type -> Type where
MyGADTCons :: forall a. Eq a => a -> Int -> MyGADT (Maybe String)
pattern MyGADTCons' :: () => forall a. Eq a => a -> Int -> MyGADT (Maybe String)
diff --git a/html-test/src/DefaultAssociatedTypes.hs b/html-test/src/DefaultAssociatedTypes.hs
index 68a587efcd..aeaefc88c0 100644
--- a/html-test/src/DefaultAssociatedTypes.hs
+++ b/html-test/src/DefaultAssociatedTypes.hs
@@ -3,13 +3,15 @@
module DefaultAssociatedTypes where
+import Data.Kind (Type)
+
-- | Documentation for Foo.
class Foo a where
-- | Documentation for bar and baz.
bar, baz :: a -> String
-- | Doc for Qux
- type Qux a :: *
+ type Qux a :: Type
-- | Doc for default Qux
type Qux a = [a]
diff --git a/html-test/src/DeprecatedTypeFamily.hs b/html-test/src/DeprecatedTypeFamily.hs
index 3d94cace9d..e161e101a4 100644
--- a/html-test/src/DeprecatedTypeFamily.hs
+++ b/html-test/src/DeprecatedTypeFamily.hs
@@ -2,9 +2,11 @@
{-# LANGUAGE TypeFamilies #-}
module DeprecatedTypeFamily where
+import Data.Kind (Type)
+
-- | some documentation
-data family SomeTypeFamily k :: * -> *
+data family SomeTypeFamily k :: Type -> Type
{-# DEPRECATED SomeTypeFamily "SomeTypeFamily" #-}
-data family SomeOtherTypeFamily k :: * -> *
+data family SomeOtherTypeFamily k :: Type -> Type
{-# DEPRECATED SomeOtherTypeFamily "SomeOtherTypeFamily" #-}
diff --git a/html-test/src/FunArgs.hs b/html-test/src/FunArgs.hs
index 9d7c19dc45..6c6a74e678 100644
--- a/html-test/src/FunArgs.hs
+++ b/html-test/src/FunArgs.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE Haskell2010 #-}
-{-# LANGUAGE RankNTypes, DataKinds, TypeFamilies #-}
+{-# LANGUAGE RankNTypes, DataKinds, TypeFamilies, TypeOperators #-}
module FunArgs where
f :: forall a. Ord a
diff --git a/html-test/src/Operators.hs b/html-test/src/Operators.hs
index 1d938ba6ec..49682bfc80 100644
--- a/html-test/src/Operators.hs
+++ b/html-test/src/Operators.hs
@@ -5,6 +5,8 @@
-- | Test operators with or without fixity declarations
module Operators where
+import Data.Kind (Type)
+
-- | Operator with no fixity
(+-) :: a -> a -> a
a +- _ = a
@@ -48,7 +50,7 @@ infix 9 **
class a ><> b | a -> b where
-- Dec 2015: Added @a -> b@ functional dependency to clean up ambiguity
-- See GHC #11264
- type a <>< b :: *
+ type a <>< b :: Type
data a ><< b
(>><), (<<>) :: a -> b -> ()
diff --git a/html-test/src/PatternSyns.hs b/html-test/src/PatternSyns.hs
index e0da6d6b37..5569e1ce8a 100644
--- a/html-test/src/PatternSyns.hs
+++ b/html-test/src/PatternSyns.hs
@@ -4,6 +4,8 @@
-- | Testing some pattern synonyms
module PatternSyns where
+import Data.Kind (Type)
+
-- | FooType doc
data FooType x = FooCtor x
@@ -23,7 +25,7 @@ data BlubType = forall x. Show x => BlubCtor x
pattern Blub x = BlubCtor x
-- | Doc for ('><')
-data (a :: *) >< b = Empty
+data (a :: Type) >< b = Empty
-- | Pattern for 'Empty'
pattern E = Empty
diff --git a/html-test/src/PromotedTypes.hs b/html-test/src/PromotedTypes.hs
index 624f9d5ad8..9b66a523d9 100644
--- a/html-test/src/PromotedTypes.hs
+++ b/html-test/src/PromotedTypes.hs
@@ -7,20 +7,22 @@
module PromotedTypes where
+import Data.Kind (Type)
+
data RevList a = RNil | RevList a :> a
-data Pattern :: [*] -> * where
+data Pattern :: [Type] -> Type where
Nil :: Pattern '[]
Cons :: Maybe h -> Pattern t -> Pattern (h ': t)
-- Unlike (:), (:>) does not have to be quoted on type level.
-data RevPattern :: RevList * -> * where
+data RevPattern :: RevList Type -> Type where
RevNil :: RevPattern RNil
RevCons :: Maybe h -> RevPattern t -> RevPattern (t :> h)
-data Tuple :: (*, *) -> * where
+data Tuple :: (Type, Type) -> Type where
Tuple :: a -> b -> Tuple '(a, b)
diff --git a/html-test/src/SpuriousSuperclassConstraints.hs b/html-test/src/SpuriousSuperclassConstraints.hs
index cb2049415a..968f079454 100644
--- a/html-test/src/SpuriousSuperclassConstraints.hs
+++ b/html-test/src/SpuriousSuperclassConstraints.hs
@@ -20,8 +20,9 @@
module SpuriousSuperclassConstraints where
import Control.Applicative
+import Data.Kind (Type)
-data SomeType (f :: * -> *) a
+data SomeType (f :: Type -> Type) a
instance Functor (SomeType f) where
fmap = undefined
diff --git a/html-test/src/TypeFamilies.hs b/html-test/src/TypeFamilies.hs
index d759af4fb2..18f161e325 100644
--- a/html-test/src/TypeFamilies.hs
+++ b/html-test/src/TypeFamilies.hs
@@ -4,6 +4,8 @@
-- | Doc for: module TypeFamilies
module TypeFamilies where
+import Data.Kind (Type)
+
import qualified TypeFamilies2 as TF
-- | Doc for: data X
@@ -35,7 +37,7 @@ type instance Foo X = Y
type instance Foo Y = X
-- | Doc for: data family Bat a
-data family Bat (a :: k) :: *
+data family Bat (a :: k) :: Type
-- | Doc for: data instance Bat X
data instance Bat X
@@ -53,9 +55,9 @@ data instance Bat (z :: Z) where
-- | Doc for: class Assoc a
class Assoc a where
-- | Doc for: data AssocD a
- data AssocD a :: *
+ data AssocD a :: Type
-- | Doc for: type AssocT a
- type AssocT a :: *
+ type AssocT a :: Type
-- | Doc for: instance Assoc X
instance Assoc X where
diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs
index e7afb61cdb..bea421c73c 100644
--- a/hypsrc-test/Main.hs
+++ b/hypsrc-test/Main.hs
@@ -50,5 +50,10 @@ checkIgnore file
where
isHtmlFile = (== ".html") . takeExtension
isSourceFile = (== "src") . takeDirectory
- isModuleFile = isUpper . head . takeBaseName
+ isModuleFile f
+ | c : _ <- takeBaseName f
+ , isUpper c
+ = True
+ | otherwise
+ = False
checkIgnore _ = True
diff --git a/latex-test/ref/DefaultSignatures/DefaultSignatures.tex b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex
index 162f5014d1..161320835d 100644
--- a/latex-test/ref/DefaultSignatures/DefaultSignatures.tex
+++ b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex
@@ -16,7 +16,7 @@ Documentation for Foo.\par
\haddockpremethods{}\emph{Methods}
\begin{haddockdesc}
\item[\begin{tabular}{@{}l}
-bar, baz :: a -> String
+bar :: a -> String
\end{tabular}]
{\haddockbegindoc
Documentation for bar and baz.\par}
@@ -28,6 +28,13 @@ default bar :: Show a => a -> String
\end{haddockdesc}
\begin{haddockdesc}
\item[\begin{tabular}{@{}l}
+baz :: a -> String
+\end{tabular}]
+{\haddockbegindoc
+Documentation for bar and baz.\par}
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
baz' :: String -> a
\end{tabular}]
{\haddockbegindoc
diff --git a/latex-test/ref/LinearTypes/LinearTypes.tex b/latex-test/ref/LinearTypes/LinearTypes.tex
index cb583ca837..c3fe605d05 100644
--- a/latex-test/ref/LinearTypes/LinearTypes.tex
+++ b/latex-test/ref/LinearTypes/LinearTypes.tex
@@ -23,7 +23,7 @@ Does something linear.\par}
\end{haddockdesc}
\begin{haddockdesc}
\item[\begin{tabular}{@{}l}
-poly :: a {\char '45}m -> b
+poly :: forall a b (m :: Multiplicity). a {\char '45}m -> b
\end{tabular}]
{\haddockbegindoc
Does something polymorphic.\par}
diff --git a/latex-test/ref/TypeFamilies3/TypeFamilies3.tex b/latex-test/ref/TypeFamilies3/TypeFamilies3.tex
index 38c143b0e2..6ceb36864a 100644
--- a/latex-test/ref/TypeFamilies3/TypeFamilies3.tex
+++ b/latex-test/ref/TypeFamilies3/TypeFamilies3.tex
@@ -14,7 +14,7 @@ type family Foo a where
{\haddockbegindoc
\haddockbeginargs
\haddockdecltt{Foo () = Int} \\
-\haddockdecltt{Foo {\char '137} = ()} \\
+\haddockdecltt{Foo {\char '137}1 = ()} \\
\end{tabulary}\par
A closed type family\par}
\end{haddockdesc}
--
GitLab