aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/CHANGES.md1
-rw-r--r--haddock-api/haddock-api.cabal75
-rw-r--r--haddock-api/resources/html/Classic.theme/xhaddock.css1
-rw-r--r--haddock-api/resources/html/Ocean.std-theme/ocean.css9
-rw-r--r--haddock-api/resources/html/haddock-util.js140
-rw-r--r--haddock-api/src/Documentation/Haddock.hs8
-rw-r--r--haddock-api/src/Haddock.hs47
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs6
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs108
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs14
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs33
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs75
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs341
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs1
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs4
-rw-r--r--haddock-api/src/Haddock/Convert.hs4
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs23
-rw-r--r--haddock-api/src/Haddock/Interface.hs12
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs16
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs384
-rw-r--r--haddock-api/src/Haddock/Interface/Json.hs109
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs81
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs12
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs186
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs14
-rw-r--r--haddock-api/src/Haddock/Options.hs6
-rw-r--r--haddock-api/src/Haddock/Syb.hs55
-rw-r--r--haddock-api/src/Haddock/Types.hs90
-rw-r--r--haddock-api/src/Haddock/Utils.hs67
29 files changed, 1038 insertions, 884 deletions
diff --git a/haddock-api/CHANGES.md b/haddock-api/CHANGES.md
new file mode 100644
index 00000000..70d575ec
--- /dev/null
+++ b/haddock-api/CHANGES.md
@@ -0,0 +1 @@
+See [`haddock`'s changelog](https://hackage.haskell.org/package/haddock/changelog).
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 6a3ef944..d86c1c69 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -1,19 +1,21 @@
name: haddock-api
-version: 2.17.3
+version: 2.18.2
synopsis: A documentation-generation tool for Haskell libraries
description: Haddock is a documentation-generation tool for Haskell
libraries
license: BSD3
license-file: LICENSE
author: Simon Marlow, David Waern
-maintainer: Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
+maintainer: Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
homepage: http://www.haskell.org/haddock/
bug-reports: https://github.com/haskell/haddock/issues
copyright: (c) Simon Marlow, David Waern
category: Documentation
build-type: Simple
-cabal-version: >= 1.10
-stability: experimental
+cabal-version: >= 2.0
+
+extra-source-files:
+ CHANGES.md
data-dir:
resources
@@ -33,30 +35,34 @@ data-files:
latex/haddock.sty
library
- default-language:
- Haskell2010
+ default-language: Haskell2010
- build-depends:
- base >= 4.3 && < 4.11
- , bytestring
- , filepath
- , directory
- , containers
- , transformers
- , deepseq
- , array
- , xhtml >= 3000.2 && < 3000.3
- , Cabal >= 1.10
- , ghc-boot
- , ghc >= 8.3 && < 8.4
+ -- this package typically supports only single major versions
+ build-depends: base >= 4.10.0
+ , Cabal ^>= 2.0.0
+ , ghc ^>= 8.3
+ , ghc-paths ^>= 0.1.0.9
+ , haddock-library ^>= 1.4.6
+ , xhtml ^>= 3000.2.2
- , ghc-paths
- , haddock-library == 1.4.*
+ -- Versions for the dependencies below are transitively pinned by
+ -- the non-reinstallable `ghc` package and hence need no version
+ -- bounds
+ build-depends: array
+ , bytestring
+ , containers
+ , deepseq
+ , directory
+ , filepath
+ , ghc-boot
+ , transformers
- hs-source-dirs:
- src
+ hs-source-dirs: src
ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2
+ ghc-options: -Wall
+ if impl(ghc >= 8.0)
+ ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances
exposed-modules:
Documentation.Haddock
@@ -67,6 +73,7 @@ library
Haddock.Interface.Rename
Haddock.Interface.Create
Haddock.Interface.AttachInstances
+ Haddock.Interface.Json
Haddock.Interface.LexParseRn
Haddock.Interface.ParseModuleHeader
Haddock.Interface.Specialize
@@ -100,6 +107,9 @@ library
Haddock.Convert
Paths_haddock_api
+ autogen-modules:
+ Paths_haddock_api
+
test-suite spec
type: exitcode-stdio-1.0
default-language: Haskell2010
@@ -110,16 +120,29 @@ test-suite spec
test
, src
+ -- NB: We only use a small subset of lib:haddock-api here, which
+ -- explains why this component has a smaller build-depends set
other-modules:
Haddock.Backends.Hyperlinker.ParserSpec
+ Haddock.Backends.Hyperlinker.Parser
+ Haddock.Backends.Hyperlinker.Types
build-depends:
+ ghc ^>= 8.2
+ , hspec ^>= 2.4.4
+ , QuickCheck ^>= 2.10
+
+ -- Versions for the dependencies below are transitively pinned by
+ -- the non-reinstallable `ghc` package and hence need no version
+ -- bounds
+ build-depends:
base
, containers
- , ghc
- , hspec
- , QuickCheck == 2.*
+
+ build-tool-depends:
+ hspec-discover:hspec-discover ^>= 2.4.4
source-repository head
type: git
+ subdir: haddock-api
location: https://github.com/haskell/haddock.git
diff --git a/haddock-api/resources/html/Classic.theme/xhaddock.css b/haddock-api/resources/html/Classic.theme/xhaddock.css
index 19dc28ec..1bf668e9 100644
--- a/haddock-api/resources/html/Classic.theme/xhaddock.css
+++ b/haddock-api/resources/html/Classic.theme/xhaddock.css
@@ -285,6 +285,7 @@ div.top h5 {
padding: 0 8px 2px 5px;
margin-right: -3px;
background-color: #f0f0f0;
+ -moz-user-select: none;
}
div.subs {
diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css
index 29af691b..8d3f91a9 100644
--- a/haddock-api/resources/html/Ocean.std-theme/ocean.css
+++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css
@@ -327,10 +327,6 @@ div#style-menu-holder {
}
#synopsis {
- display: none;
-}
-
-.no-frame #synopsis {
display: block;
position: fixed;
right: 0;
@@ -398,6 +394,7 @@ div#style-menu-holder {
background: #f0f0f0;
padding: 0 0.5em 0.2em;
margin: 0 -0.5em 0 0;
+ -moz-user-select: none;
}
#interface .src .selflink {
border-left: 1px solid #919191;
@@ -614,4 +611,8 @@ div#style-menu-holder {
float: right;
}
+:target {
+ background-color: #ffff00;
+}
+
/* @end */
diff --git a/haddock-api/resources/html/haddock-util.js b/haddock-api/resources/html/haddock-util.js
index 92d07d2a..967e2026 100644
--- a/haddock-api/resources/html/haddock-util.js
+++ b/haddock-api/resources/html/haddock-util.js
@@ -1,7 +1,7 @@
// Haddock JavaScript utilities
var rspace = /\s\s+/g,
- rtrim = /^\s+|\s+$/g;
+ rtrim = /^\s+|\s+$/g;
function spaced(s) { return (" " + s + " ").replace(rspace, " "); }
function trim(s) { return s.replace(rtrim, ""); }
@@ -52,17 +52,17 @@ function toggleSection(id)
{
var b = toggleShow(document.getElementById("section." + id));
toggleCollapser(document.getElementById("control." + id), b);
- rememberCollapsed(id, b);
+ rememberCollapsed(id);
return b;
}
var collapsed = {};
-function rememberCollapsed(id, b)
+function rememberCollapsed(id)
{
- if(b)
+ if(collapsed[id])
delete collapsed[id]
else
- collapsed[id] = null;
+ collapsed[id] = true;
var sections = [];
for(var i in collapsed)
@@ -109,136 +109,6 @@ function getCookie(name) {
return null;
}
-
-
-var max_results = 75; // 50 is not enough to search for map in the base libraries
-var shown_range = null;
-var last_search = null;
-
-function quick_search()
-{
- perform_search(false);
-}
-
-function full_search()
-{
- perform_search(true);
-}
-
-
-function perform_search(full)
-{
- var text = document.getElementById("searchbox").value.toLowerCase();
- if (text == last_search && !full) return;
- last_search = text;
-
- var table = document.getElementById("indexlist");
- var status = document.getElementById("searchmsg");
- var children = table.firstChild.childNodes;
-
- // first figure out the first node with the prefix
- var first = bisect(-1);
- var last = (first == -1 ? -1 : bisect(1));
-
- if (first == -1)
- {
- table.className = "";
- status.innerHTML = "No results found, displaying all";
- }
- else if (first == 0 && last == children.length - 1)
- {
- table.className = "";
- status.innerHTML = "";
- }
- else if (last - first >= max_results && !full)
- {
- table.className = "";
- status.innerHTML = "More than " + max_results + ", press Search to display";
- }
- else
- {
- // decide what you need to clear/show
- if (shown_range)
- setclass(shown_range[0], shown_range[1], "indexrow");
- setclass(first, last, "indexshow");
- shown_range = [first, last];
- table.className = "indexsearch";
- status.innerHTML = "";
- }
-
-
- function setclass(first, last, status)
- {
- for (var i = first; i <= last; i++)
- {
- children[i].className = status;
- }
- }
-
-
- // do a binary search, treating 0 as ...
- // return either -1 (no 0's found) or location of most far match
- function bisect(dir)
- {
- var first = 0, finish = children.length - 1;
- var mid, success = false;
-
- while (finish - first > 3)
- {
- mid = Math.floor((finish + first) / 2);
-
- var i = checkitem(mid);
- if (i == 0) i = dir;
- if (i == -1)
- finish = mid;
- else
- first = mid;
- }
- var a = (dir == 1 ? first : finish);
- var b = (dir == 1 ? finish : first);
- for (var i = b; i != a - dir; i -= dir)
- {
- if (checkitem(i) == 0) return i;
- }
- return -1;
- }
-
-
- // from an index, decide what the result is
- // 0 = match, -1 is lower, 1 is higher
- function checkitem(i)
- {
- var s = getitem(i).toLowerCase().substr(0, text.length);
- if (s == text) return 0;
- else return (s > text ? -1 : 1);
- }
-
-
- // from an index, get its string
- // this abstracts over alternates
- function getitem(i)
- {
- for ( ; i >= 0; i--)
- {
- var s = children[i].firstChild.firstChild.data;
- if (s.indexOf(' ') == -1)
- return s;
- }
- return ""; // should never be reached
- }
-}
-
-function setSynopsis(filename) {
- if (parent.window.synopsis && parent.window.synopsis.location) {
- if (parent.window.synopsis.location.replace) {
- // In Firefox this avoids adding the change to the history.
- parent.window.synopsis.location.replace(filename);
- } else {
- parent.window.synopsis.location = filename;
- }
- }
-}
-
function addMenuItem(html) {
var menu = document.getElementById("page-menu");
if (menu) {
diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs
index 1ff5cf75..10d6849a 100644
--- a/haddock-api/src/Documentation/Haddock.hs
+++ b/haddock-api/src/Documentation/Haddock.hs
@@ -16,6 +16,7 @@ module Documentation.Haddock (
-- * Interface
Interface(..),
InstalledInterface(..),
+ toInstalledIface,
createInterfaces,
processModules,
@@ -34,10 +35,12 @@ module Documentation.Haddock (
-- * Documentation comments
Doc,
+ MDoc,
DocH(..),
Example(..),
Hyperlink(..),
- DocMarkup(..),
+ DocMarkup,
+ DocMarkupH(..),
Documentation(..),
ArgMap,
AliasMap,
@@ -67,12 +70,11 @@ module Documentation.Haddock (
withGhc
) where
-
+import Documentation.Haddock.Markup (markup)
import Haddock.InterfaceFile
import Haddock.Interface
import Haddock.Types
import Haddock.Options
-import Haddock.Utils
import Haddock
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 080ff926..44dfb7b2 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -32,6 +32,7 @@ import Haddock.Backends.LaTeX
import Haddock.Backends.Hoogle
import Haddock.Backends.Hyperlinker
import Haddock.Interface
+import Haddock.Interface.Json
import Haddock.Parser
import Haddock.Types
import Haddock.Version
@@ -68,12 +69,11 @@ import System.Directory (doesDirectoryExist)
import GHC hiding (verbosity)
import Config
import DynFlags hiding (projectVersion, verbosity)
+import ErrUtils
import Packages
import Panic (handleGhcException)
import Module
import FastString
-import HscTypes
-import GhcMonad
--------------------------------------------------------------------------------
-- * Exception handling
@@ -165,6 +165,11 @@ haddockWithGhc ghc args = handleTopExceptions $ do
ghc flags' $ do
dflags <- getDynFlags
+ forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
+ mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)]
+ forM_ mIfaceFile $ \(_, ifaceFile) -> do
+ putMsg dflags (renderJson (jsonInterfaceFile ifaceFile))
+
if not (null files) then do
(packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
@@ -403,12 +408,11 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
let dynflags'' = unsetPatternMatchWarnings $
updOptLevel 0 $
gopt_unset dynflags' Opt_SplitObjs
- defaultCleanupHandler dynflags'' $ do
- -- 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''
+ -- 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
parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags
parseGhcFlags dynflags = do
@@ -442,15 +446,22 @@ getHaddockLibDir flags =
#ifdef IN_GHC_TREE
getInTreeDir
#else
- d <- getDataDir -- provided by Cabal
- doesDirectoryExist d >>= \exists -> case exists of
- True -> return d
- False -> do
- -- If directory does not exist then we are probably invoking from
- -- ./dist/build/haddock/haddock so we use ./resources as a fallback.
- doesDirectoryExist "resources" >>= \exists_ -> case exists_ of
- True -> return "resources"
- False -> die ("Haddock's resource directory (" ++ d ++ ") does not exist!\n")
+ -- if data directory does not exist we are probably
+ -- invoking from either ./haddock-api or ./
+ let res_dirs = [ getDataDir -- provided by Cabal
+ , pure "resources"
+ , pure "haddock-api/resources"
+ ]
+
+ check get_path = do
+ p <- get_path
+ exists <- doesDirectoryExist p
+ pure $ if exists then Just p else Nothing
+
+ dirs <- mapM check res_dirs
+ case [p | Just p <- dirs] of
+ (p : _) -> return p
+ _ -> die "Haddock's resource directory does not exist!\n"
#endif
fs -> return (last fs)
@@ -498,7 +509,7 @@ shortcutFlags flags = do
when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
&& Flag_Html `elem` flags) $
- throwE "-h cannot be used with --gen-index or --gen-contents"
+ throwE "-h/--html cannot be used with --gen-index or --gen-contents"
when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
&& Flag_Hoogle `elem` flags) $
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 02430deb..56f8176c 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -18,10 +18,12 @@ module Haddock.Backends.Hoogle (
import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..))
import InstEnv (ClsInst(..))
+import Documentation.Haddock.Markup
import Haddock.GhcUtils
import Haddock.Types hiding (Version)
import Haddock.Utils hiding (out)
+import HsBinds (emptyLHsBinds)
import GHC
import Outputable
import NameSet
@@ -157,7 +159,9 @@ pp_sig dflags names (L _ typ) =
-- 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=[]} ++ ppTyFams) : ppMethods
+ppClass dflags decl subdocs =
+ (out dflags decl{tcdSigs=[], tcdATs=[], tcdATDefs=[], tcdMeths=emptyLHsBinds}
+ ++ ppTyFams) : ppMethods
where
ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 1b39e5e8..759a31d4 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,21 +1,29 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
-
+{-# LANGUAGE TypeApplications #-}
module Haddock.Backends.Hyperlinker.Ast (enrich) where
-import Haddock.Syb
+import qualified Haddock.Syb as Syb
import Haddock.Backends.Hyperlinker.Types
import qualified GHC
import Control.Applicative
+import Control.Monad (guard)
import Data.Data
+import qualified Data.Map.Strict as Map
import Data.Maybe
+import Prelude hiding (span)
+
+everythingInRenamedSource :: (Alternative f, Data x)
+ => (forall a. Data a => a -> f r) -> x -> f r
+everythingInRenamedSource f = Syb.everythingButType @GHC.Name (<|>) f
-- | Add more detailed information to token stream using GHC API.
enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
@@ -25,25 +33,45 @@ enrich src =
, rtkDetails = enrichToken token detailsMap
}
where
- detailsMap = concatMap ($ src)
- [ variables
- , types
- , decls
- , binds
- , imports
- ]
+ detailsMap =
+ mkDetailsMap (concatMap ($ src)
+ [ variables
+ , types
+ , decls
+ , binds
+ , imports
+ ])
+
+type LTokenDetails = [(GHC.SrcSpan, TokenDetails)]
-- | A map containing association between source locations and "details" of
-- this location.
--
--- For the time being, it is just a list of pairs. However, looking up things
--- in such structure has linear complexity. We cannot use any hashmap-like
--- stuff because source locations are not ordered. In the future, this should
--- be replaced with interval tree data structure.
-type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
+type DetailsMap = Map.Map Position (Span, TokenDetails)
+
+mkDetailsMap :: [(GHC.SrcSpan, TokenDetails)] -> DetailsMap
+mkDetailsMap xs =
+ Map.fromListWith select_details [ (start, (token_span, token_details))
+ | (ghc_span, token_details) <- xs
+ , Just !token_span <- [ghcSrcSpanToSpan ghc_span]
+ , let start = spStart token_span
+ ]
+ where
+ -- favour token details which appear earlier in the list
+ select_details _new old = old
lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
-lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
+lookupBySpan span details = do
+ (_, (tok_span, tok_details)) <- Map.lookupLE (spStart span) details
+ guard (tok_span `containsSpan` span )
+ return tok_details
+
+ghcSrcSpanToSpan :: GHC.SrcSpan -> Maybe Span
+ghcSrcSpanToSpan (GHC.RealSrcSpan span) =
+ Just (Span { spStart = Position (GHC.srcSpanStartLine span) (GHC.srcSpanStartCol span)
+ , spEnd = Position (GHC.srcSpanEndLine span) (GHC.srcSpanEndCol span)
+ })
+ghcSrcSpanToSpan _ = Nothing
enrichToken :: Token -> DetailsMap -> Maybe TokenDetails
enrichToken (Token typ _ spn) dm
@@ -51,9 +79,9 @@ enrichToken (Token typ _ spn) dm
enrichToken _ _ = Nothing
-- | Obtain details map for variables ("normally" used identifiers).
-variables :: GHC.RenamedSource -> DetailsMap
+variables :: GHC.RenamedSource -> LTokenDetails
variables =
- everything (<|>) (var `combine` rec)
+ everythingInRenamedSource (var `Syb.combine` rec)
where
var term = case cast term of
(Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GhcRn)) ->
@@ -67,9 +95,8 @@ variables =
_ -> empty
-- | Obtain details map for types.
-types :: GHC.RenamedSource -> DetailsMap
-types =
- everything (<|>) ty
+types :: GHC.RenamedSource -> LTokenDetails
+types = everythingInRenamedSource ty
where
ty term = case cast term of
(Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) ->
@@ -81,9 +108,10 @@ types =
-- That includes both identifiers bound by pattern matching or declared using
-- ordinary assignment (in top-level declarations, let-expressions and where
-- clauses).
-binds :: GHC.RenamedSource -> DetailsMap
-binds =
- everything (<|>) (fun `combine` pat `combine` tvar)
+
+binds :: GHC.RenamedSource -> LTokenDetails
+binds = everythingInRenamedSource
+ (fun `Syb.combine` pat `Syb.combine` tvar)
where
fun term = case cast term of
(Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) ->
@@ -93,7 +121,7 @@ binds =
(Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) ->
pure (sspan, RtkBind (GHC.unLoc name))
(Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
- [(sspan, RtkVar name)] ++ everything (<|>) rec recs
+ [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs
(Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->
pure (sspan, RtkBind name)
_ -> empty
@@ -109,11 +137,11 @@ binds =
_ -> empty
-- | Obtain details map for top-level declarations.
-decls :: GHC.RenamedSource -> DetailsMap
+decls :: GHC.RenamedSource -> LTokenDetails
decls (group, _, _, _) = concatMap ($ group)
[ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
- , everything (<|>) fun . GHC.hs_valds
- , everything (<|>) (con `combine` ins)
+ , everythingInRenamedSource fun . GHC.hs_valds
+ , everythingInRenamedSource (con `Syb.combine` ins)
]
where
typ (GHC.L _ t) = case t of
@@ -127,7 +155,8 @@ decls (group, _, _, _) = concatMap ($ group)
_ -> empty
con term = case cast term of
(Just (cdcl :: GHC.ConDecl GHC.GhcRn)) ->
- map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl
+ map decl (GHC.getConNames cdcl)
+ ++ everythingInRenamedSource fld cdcl
Nothing -> empty
ins term = case cast term of
(Just ((GHC.DataFamInstD inst) :: GHC.InstDecl GHC.GhcRn))
@@ -148,9 +177,9 @@ decls (group, _, _, _) = concatMap ($ group)
--
-- This map also includes type and variable details for items in export and
-- import lists.
-imports :: GHC.RenamedSource -> DetailsMap
+imports :: GHC.RenamedSource -> LTokenDetails
imports src@(_, imps, _, _) =
- everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps
+ everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps
where
ie term = case cast term of
(Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v
@@ -165,22 +194,3 @@ imports src@(_, imps, _, _) =
let (GHC.L sspan name) = GHC.ideclName idecl
in Just (sspan, RtkModule name)
imp _ = Nothing
-
--- | Check whether token stream span matches GHC source span.
---
--- Currently, it is implemented as checking whether "our" span is contained
--- in GHC span. The reason for that is because GHC span are generally wider
--- and may spread across couple tokens. For example, @(>>=)@ consists of three
--- tokens: @(@, @>>=@, @)@, but GHC source span associated with @>>=@ variable
--- contains @(@ and @)@. Similarly, qualified identifiers like @Foo.Bar.quux@
--- are tokenized as @Foo@, @.@, @Bar@, @.@, @quux@ but GHC source span
--- associated with @quux@ contains all five elements.
-matches :: Span -> GHC.SrcSpan -> Bool
-matches tspan (GHC.RealSrcSpan aspan)
- | saspan <= stspan && etspan <= easpan = True
- where
- stspan = (posRow . spStart $ tspan, posCol . spStart $ tspan)
- etspan = (posRow . spEnd $ tspan, posCol . spEnd $ tspan)
- saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan)
- easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan)
-matches _ _ = False
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index b27ec4d8..d8ae89e4 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -10,7 +10,7 @@ import qualified Data.Map as Map
data Token = Token
{ tkType :: TokenType
, tkValue :: String
- , tkSpan :: Span
+ , tkSpan :: {-# UNPACK #-} !Span
}
deriving (Show)
@@ -18,14 +18,20 @@ data Position = Position
{ posRow :: !Int
, posCol :: !Int
}
- deriving (Show)
+ deriving (Eq, Ord, Show)
data Span = Span
- { spStart :: Position
- , spEnd :: Position
+ { spStart :: !Position
+ , spEnd :: !Position
}
deriving (Show)
+-- | Tests whether the first span "contains" the other span, meaning
+-- that it covers at least as much source code. True where spans are equal.
+containsSpan :: Span -> Span -> Bool
+containsSpan s1 s2 =
+ spStart s1 <= spStart s2 && spEnd s1 >= spEnd s2
+
data TokenType
= TkIdentifier
| TkKeyword
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 8ca9075b..d4a3012e 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -16,6 +16,7 @@ module Haddock.Backends.LaTeX (
) where
+import Documentation.Haddock.Markup
import Haddock.Types
import Haddock.Utils
import Haddock.GhcUtils
@@ -227,8 +228,8 @@ isExportModule _ = Nothing
processExport :: ExportItem DocNameI -> LaTeX
processExport (ExportGroup lev _id0 doc)
= ppDocGroup lev (docToLaTeX doc)
-processExport (ExportDecl decl doc subdocs insts fixities _splice)
- = ppDecl decl doc insts subdocs fixities
+processExport (ExportDecl decl pats doc subdocs insts fixities _splice)
+ = ppDecl decl pats doc insts subdocs fixities
processExport (ExportNoDecl y [])
= ppDocName y
processExport (ExportNoDecl y subs)
@@ -278,16 +279,17 @@ moduleBasename mdl = map (\c -> if c == '.' then '-' else c)
ppDecl :: LHsDecl DocNameI
+ -> [(HsDecl DocNameI, DocForDecl DocName)]
-> DocForDecl DocName
-> [DocInstance DocNameI]
-> [(DocName, DocForDecl DocName)]
-> [(DocName, Fixity)]
-> LaTeX
-ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
+ppDecl (L loc decl) pats (doc, fnArgsDoc) instances subdocs _fixities = case decl of
TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode
TyClD d@(DataDecl {})
- -> ppDataDecl instances subdocs loc (Just doc) d unicode
+ -> ppDataDecl pats instances subdocs loc (Just doc) d unicode
TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode
-- Family instances happen via FamInst now
-- TyClD d@(TySynonym {})
@@ -565,11 +567,11 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of
-------------------------------------------------------------------------------
-ppDataDecl :: [DocInstance DocNameI] ->
+ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -> [DocInstance DocNameI] ->
[(DocName, DocForDecl DocName)] -> SrcSpan ->
Maybe (Documentation DocName) -> TyClDecl DocNameI -> Bool ->
LaTeX
-ppDataDecl instances subdocs _loc doc dataDecl unicode
+ppDataDecl pats instances subdocs _loc doc dataDecl unicode
= declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
(if null body then Nothing else Just (vcat body))
@@ -579,10 +581,12 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
cons = dd_cons (tcdDataDefn dataDecl)
resTy = (unLoc . head) cons
- body = catMaybes [constrBit, doc >>= documentationToLaTeX]
+ body = catMaybes [constrBit,patternBit, doc >>= documentationToLaTeX]
(whereBit, leaders)
- | null cons = (empty,[])
+ | null cons
+ , null pats = (empty,[])
+ | null cons = (decltt (keyword "where"), repeat empty)
| otherwise = case resTy of
ConDeclGADT{} -> (decltt (keyword "where"), repeat empty)
_ -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
@@ -594,6 +598,19 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$
text "\\end{tabulary}\\par"
+ patternBit
+ | null cons = Nothing
+ | otherwise = Just $
+ text "\\haddockbeginconstrs" $$
+ vcat [ hsep [ keyword "pattern"
+ , hsep $ punctuate comma $ map (ppDocBinder . unLoc) lnames
+ , dcolon unicode
+ , ppLType unicode (hsSigType ty)
+ ] <-> rDoc (fmap _doc . combineDocumentation . fst $ d)
+ | (SigD (PatSynSig lnames ty),d) <- pats
+ ] $$
+ text "\\end{tabulary}\\par"
+
instancesBit = ppDocInstances unicode instances
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 4a3562ae..7fbf9bb4 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -109,8 +109,8 @@ copyHtmlBits odir libdir themes = do
return ()
-headHtml :: String -> Maybe String -> Themes -> Maybe String -> Html
-headHtml docTitle miniPage themes mathjax_url =
+headHtml :: String -> Themes -> Maybe String -> Html
+headHtml docTitle themes mathjax_url =
header << [
meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"],
thetitle << docTitle,
@@ -119,15 +119,12 @@ headHtml docTitle miniPage themes mathjax_url =
script ! [src mjUrl, thetype "text/javascript"] << noHtml,
script ! [thetype "text/javascript"]
-- NB: Within XHTML, the content of script tags needs to be
- -- a <![CDATA[ section. Will break if the miniPage name could
- -- have "]]>" in it!
- << primHtml (
- "//<![CDATA[\nwindow.onload = function () {pageLoad();"
- ++ setSynopsis ++ "};\n//]]>\n")
+ -- a <![CDATA[ section.
+ << primHtml
+ "//<![CDATA[\nwindow.onload = function () {pageLoad();};\n//]]>\n"
]
where
- setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage
- mjUrl = maybe "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url
+ mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url
srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
@@ -272,7 +269,7 @@ ppHtmlContents dflags odir doctitle _maybe_package
| iface <- ifaces
, instIsSig iface]
html =
- headHtml doctitle Nothing themes mathjax_url +++
+ headHtml doctitle themes mathjax_url +++
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
Nothing maybe_index_url << [
@@ -373,7 +370,7 @@ ppHtmlIndex odir doctitle _maybe_package themes
where
indexPage showLetters ch items =
- headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes maybe_mathjax_url +++
+ headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url +++
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
maybe_contents_url Nothing << [
@@ -495,7 +492,7 @@ ppHtmlModule odir doctitle themes
= toHtml mdl_str
real_qual = makeModuleQual qual aliases mdl
html =
- headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++
+ headHtml mdl_str_annot themes maybe_mathjax_url +++
bodyHtml doctitle (Just iface)
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url << [
@@ -505,23 +502,10 @@ ppHtmlModule odir doctitle themes
createDirectoryIfMissing True odir
writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
- ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug
signatureDocURL :: String
signatureDocURL = "https://wiki.haskell.org/Module_signature"
-ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
- -> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO ()
-ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do
- let mdl = ifaceMod iface
- html =
- headHtml (moduleString mdl) Nothing themes maybe_mathjax_url +++
- miniBody <<
- (divModuleHeader << sectionName << moduleString mdl +++
- miniSynopsis mdl iface unicode qual)
- createDirectoryIfMissing True odir
- writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html)
-
ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html
ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
@@ -573,43 +557,6 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
linksInfo = (maybe_source_url, maybe_wiki_url)
-miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html
-miniSynopsis mdl iface unicode qual =
- divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports
- where
- exports = numberSectionHeadings (ifaceRnExportItems iface)
-
-
-processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocNameI
- -> [Html]
-processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } =
- ((divTopDecl <<).(declElem <<)) <$> case decl0 of
- TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
- (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual]
- (DataDecl{}) -> [keyword "data" <+> b]
- (SynDecl{}) -> [keyword "type" <+> b]
- (ClassDecl {}) -> [keyword "class" <+> b]
- SigD (TypeSig lnames _) ->
- map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames
- _ -> []
-processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =
- [groupTag lvl << docToHtml Nothing qual (mkMeta txt)]
-processForMiniSynopsis _ _ _ _ = []
-
-
-ppNameMini :: Notation -> Module -> OccName -> Html
-ppNameMini notation mdl nm =
- anchor ! [ href (moduleNameUrl mdl nm)
- , target mainFrameName ]
- << ppBinder' notation nm
-
-
-ppTyClBinderWithVarsMini :: Module -> TyClDecl DocNameI -> Html
-ppTyClBinderWithVarsMini mdl decl =
- let n = tcdName decl
- ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above
- in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName
-
ppModuleContents :: Qualification
-> [ExportItem DocNameI]
-> Bool -- ^ Orphans sections
@@ -659,8 +606,8 @@ processExport :: Bool -> LinksInfo -> Bool -> Qualification
processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
processExport summary _ _ qual (ExportGroup lev id0 doc)
= nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc)
-processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice)
- = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual
+processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice)
+ = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode 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 2d9d7392..59ad41e4 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -41,11 +41,12 @@ import BooleanFormula
import RdrName ( rdrNameOcc )
ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI
- -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)]
+ -> [(HsDecl DocNameI, DocForDecl DocName)]
+ -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)]
-> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html
-ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
+ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual
TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
@@ -70,9 +71,9 @@ ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
Splice -> Unicode -> Qualification -> Html
ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ)
- splice unicode qual
+ splice unicode qual HideEmptyContexts
where
- pp_typ = ppLType unicode qual typ
+ pp_typ = ppLType unicode qual HideEmptyContexts typ
ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
[Located DocName] -> LHsSigType DocNameI ->
@@ -86,20 +87,20 @@ ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode
pref1 = hsep [ keyword "pattern"
, hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames
, dcolon unicode
- , ppLType unicode qual (hsSigType typ)
+ , ppPatSigType unicode qual (hsSigType typ)
]
ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
[DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->
- Splice -> Unicode -> Qualification -> Html
+ Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
- splice unicode qual =
+ splice unicode qual emptyCtxts =
ppTypeOrFunSig summary links loc docnames typ doc
( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode
, addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
, dcolon unicode
)
- splice unicode qual
+ splice unicode qual emptyCtxts
where
occnames = map (nameOccName . getName) docnames
addFixities html
@@ -109,8 +110,8 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI
-> DocForDecl DocName -> (Html, Html, Html)
- -> Splice -> Unicode -> Qualification -> Html
-ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual
+ -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts
| summary = pref1
| Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc
| otherwise = topDeclElem links loc splice docnames pref2 +++
@@ -131,14 +132,14 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
| null (unLoc lctxt)
= do_largs n leader ltype
| otherwise
- = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])
+ = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
: do_largs n (darrow unicode) ltype
do_args n leader (HsFunTy lt r)
- = (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])
+ = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, [])
: do_largs (n+1) (arrow unicode) r
do_args n leader t
- = [(leader <+> ppType unicode qual t, argDoc n, [])]
+ = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])]
ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html
ppForAll tvs unicode qual =
@@ -171,8 +172,8 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
-- | Pretty-print type variables.
-ppTyVars :: [LHsTyVarBndr DocNameI] -> [Html]
-ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs
+ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html]
+ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs
tyvarNames :: LHsQTyVars DocNameI -> [Name]
tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit
@@ -196,11 +197,11 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
splice unicode qual
= ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
(full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)
- splice unicode qual
+ splice unicode qual ShowEmptyToplevelContexts
where
hdr = hsep ([keyword "type", ppBinder summary occ]
- ++ ppTyVars (hsQTvExplicit ltyvars))
- full = hdr <+> equals <+> ppLType unicode qual ltype
+ ++ ppTyVars unicode qual (hsQTvExplicit ltyvars))
+ full = hdr <+> equals <+> ppPatSigType unicode qual ltype
occ = nameOccName . getName $ name
fixs
| summary = noHtml
@@ -219,14 +220,14 @@ ppTyName :: Name -> Html
ppTyName = ppName Prefix
-ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan
+ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan
-> [DocName] -> HsType DocNameI
-> Html
-ppSimpleSig links splice unicode qual loc names typ =
+ppSimpleSig links splice unicode qual emptyCtxts loc names typ =
topDeclElem' names $ ppTypeSig True occNames ppTyp unicode
where
topDeclElem' = topDeclElem links loc splice
- ppTyp = ppType unicode qual typ
+ ppTyp = ppType unicode qual emptyCtxts typ
occNames = map getOccName names
@@ -320,7 +321,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode
ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs
, tfe_pats = HsIB { hsib_body = ts }}
= ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
- <+> equals <+> ppType unicode qual (unLoc rhs)
+ <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
, Nothing, [] )
@@ -353,20 +354,20 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
-- | Print a type family and its variables
ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html
ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
- ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (map unLoc $ hsq_explicit tvs)
+ ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs)
-- | Print a newtype / data binder and its variables
-ppDataBinderWithVars :: Bool -> TyClDecl DocNameI -> Html
-ppDataBinderWithVars summ decl =
- ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl)
+ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html
+ppDataBinderWithVars summ unicode qual decl =
+ ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl)
--------------------------------------------------------------------------------
-- * Type applications
--------------------------------------------------------------------------------
-ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [HsTyVarBndr DocNameI] -> Html
+ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html
ppAppDocNameTyVarBndrs summ unicode qual n vs =
- ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual)
+ ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual . unLoc)
where
ppDN notation = ppBinderFixity notation summ . nameOccName . getName
ppBinderFixity Infix = ppBinderInfix
@@ -376,18 +377,9 @@ ppAppDocNameTyVarBndrs summ unicode qual n vs =
ppAppNameTypes :: DocName -> [HsType DocNameI] -> [HsType DocNameI]
-> Unicode -> Qualification -> Html
ppAppNameTypes n ks ts unicode qual =
- ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual)
+ ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts)
--- | Print an application of a 'DocName' and a list of 'Names'
-ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html
-ppAppDocNameNames summ n ns =
- ppTypeApp n [] ns ppDN ppTyName
- where
- ppDN notation = ppBinderFixity notation summ . nameOccName . getName
- ppBinderFixity Infix = ppBinderInfix
- ppBinderFixity _ = ppBinder
-
-- | General printing of type applications
ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
ppTypeApp n [] (t1:t2:rest) ppDN ppT
@@ -406,32 +398,35 @@ ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)
ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Unicode
- -> Qualification -> Html
+ -> Qualification -> HideEmptyContexts -> Html
ppLContext = ppContext . unLoc
ppLContextNoArrow = ppContextNoArrow . unLoc
-ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> Html
-ppContextNoArrow cxt unicode qual = fromMaybe noHtml $
- ppContextNoLocsMaybe (map unLoc cxt) unicode qual
+ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $
+ ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts
-ppContextNoLocs :: [HsType DocNameI] -> Unicode -> Qualification -> Html
-ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $
- ppContextNoLocsMaybe cxt unicode qual
+ppContextNoLocs :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppContextNoLocs cxt unicode qual emptyCtxts = maybe noHtml (<+> darrow unicode) $
+ ppContextNoLocsMaybe cxt unicode qual emptyCtxts
-ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> Maybe Html
-ppContextNoLocsMaybe [] _ _ = Nothing
-ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual
+ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Maybe Html
+ppContextNoLocsMaybe [] _ _ emptyCtxts =
+ case emptyCtxts of
+ HideEmptyContexts -> Nothing
+ ShowEmptyToplevelContexts -> Just (toHtml "()")
+ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual
-ppContext :: HsContext DocNameI -> Unicode -> Qualification -> Html
-ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
+ppContext :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppContext cxt unicode qual emptyCtxts = ppContextNoLocs (map unLoc cxt) unicode qual emptyCtxts
-ppHsContext :: [HsType DocNameI] -> Unicode -> Qualification-> Html
-ppHsContext [] _ _ = noHtml
+ppHsContext :: [HsType DocNameI] -> Unicode -> Qualification -> Html
+ppHsContext [] _ _ = noHtml
ppHsContext [p] unicode qual = ppCtxType unicode qual p
-ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
+ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyContexts) cxt)
-------------------------------------------------------------------------------
@@ -444,8 +439,8 @@ ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName
-> Unicode -> Qualification -> Html
ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
- <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)
- <+> ppAppDocNameNames summ n (tyvarNames tvs)
+ <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)
+ <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs)
<+> ppFds fds unicode qual
@@ -529,9 +524,8 @@ ppClassDecl summary links instances fixities loc d subdocs
, f@(n',_) <- fixities
, n == n' ]
names = map unLoc lnames ]
- -- FIXME: is taking just the first name ok? Is it possible that
- -- there are different subdocs for different names in a single
- -- type signature?
+ -- N.B. taking just the first name is ok. Signatures with multiple names
+ -- are expanded so that each name gets its own signature.
minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of
-- Miminal complete definition = every shown method
@@ -601,7 +595,7 @@ ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification
ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
case ihdInstType of
ClassInst { .. } ->
- ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ
+ ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ
, mdoc
, [subInstDetails iid ats sigs]
)
@@ -616,14 +610,14 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
where
ptype = keyword "type" <+> typ
prhs = ptype <+> maybe noHtml
- (\t -> equals <+> ppType unicode qual t) rhs
+ (\t -> equals <+> ppType unicode qual HideEmptyContexts t) rhs
DataInst dd ->
( subInstHead iid pdata
, mdoc
, [subFamInstDetails iid pdecl])
where
pdata = keyword "data" <+> typ
- pdecl = pdata <+> ppShortDataDecl False True dd unicode qual
+ pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
where
iid = instanceId origin no orphan ihd
typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
@@ -644,8 +638,10 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
ppInstanceSigs links splice unicode qual sigs = do
TypeSig lnames typ <- sigs
let names = map unLoc lnames
- L loc rtyp = hsSigWcType typ
- return $ ppSimpleSig links splice unicode qual loc names rtyp
+ L _ rtyp = hsSigWcType typ
+ -- Instance methods signatures are synified and thus don't have a useful
+ -- SrcSpan value. Use the methods name location instead.
+ return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
@@ -672,20 +668,23 @@ instanceId origin no orphan ihd = concat $
-- TODO: print contexts
-ppShortDataDecl :: Bool -> Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html
-ppShortDataDecl summary dataInst dataDecl unicode qual
+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocNameI
+ -> [(HsDecl DocNameI, DocForDecl DocName)]
+ -> Unicode -> Qualification -> Html
+ppShortDataDecl summary dataInst dataDecl pats unicode qual
- | [] <- cons = dataHeader
+ | [] <- cons
+ , [] <- pats = dataHeader
- | [lcon] <- cons, isH98,
+ | [lcon] <- cons, [] <- pats, isH98,
(cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual
= (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
- | isH98 = dataHeader
- +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons)
+ | [] <- pats, isH98 = dataHeader
+ +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons ++ pats1)
| otherwise = (dataHeader <+> keyword "where")
- +++ shortSubDecls dataInst (map doGADTConstr cons)
+ +++ shortSubDecls dataInst (map doGADTConstr cons ++ pats1)
where
dataHeader
@@ -699,16 +698,25 @@ ppShortDataDecl summary dataInst dataDecl unicode qual
ConDeclH98 {} -> True
ConDeclGADT{} -> False
+ pats1 = [ hsep [ keyword "pattern"
+ , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
+ , dcolon unicode
+ , ppPatSigType unicode qual (hsSigType typ)
+ ]
+ | (SigD (PatSynSig lnames typ),_) <- pats
+ ]
+
ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] ->
[(DocName, DocForDecl DocName)] ->
SrcSpan -> Documentation DocName -> TyClDecl DocNameI ->
+ [(HsDecl DocNameI, DocForDecl DocName)] ->
Splice -> Unicode -> Qualification -> Html
-ppDataDecl summary links instances fixities subdocs loc doc dataDecl
+ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
splice unicode qual
- | summary = ppShortDataDecl summary False dataDecl unicode qual
- | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ instancesBit
+ | summary = ppShortDataDecl summary False dataDecl pats unicode qual
+ | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ patternBit +++ instancesBit
where
docname = tcdName dataDecl
@@ -723,7 +731,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual
whereBit
- | null cons = noHtml
+ | null cons
+ , null pats = noHtml
+ | null cons = keyword "where"
| otherwise = if isH98 then noHtml else keyword "where"
constrBit = subConstructors qual
@@ -733,6 +743,17 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
(map unLoc (getConNames (unLoc c)))) fixities
]
+ patternBit = subPatterns qual
+ [ (hsep [ keyword "pattern"
+ , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
+ , dcolon unicode
+ , ppPatSigType unicode qual (hsSigType typ)
+ ] <+> ppFixities subfixs qual
+ ,combineDocumentation (fst d), [])
+ | (SigD (PatSynSig lnames typ),d) <- pats
+ , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities
+ ]
+
instancesBit = ppInstances links (OriginData docname) instances
splice unicode qual
@@ -751,17 +772,17 @@ ppShortConstrParts summary dataInst con unicode qual = case con of
ConDeclH98{} -> case con_details con of
PrefixCon args ->
(header_ unicode qual +++ hsep (ppOcc
- : map (ppLParendType unicode qual) args), noHtml, noHtml)
+ : map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml)
RecCon (L _ fields) ->
(header_ unicode qual +++ ppOcc <+> char '{',
doRecordFields fields,
char '}')
InfixCon arg1 arg2 ->
- (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,
- ppOccInfix, ppLParendType unicode qual arg2],
+ (header_ unicode qual +++ hsep [ppLParendType unicode qual HideEmptyContexts arg1,
+ ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2],
noHtml, noHtml)
- ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml)
+ ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml)
where
resTy = hsib_body (con_type con)
@@ -793,7 +814,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual
= (if null tvs then noHtml else ppForall)
+++
(if null ctxt then noHtml
- else ppContextNoArrow ctxt unicode qual
+ else ppContextNoArrow ctxt unicode qual HideEmptyContexts
<+> darrow unicode +++ toHtml " ")
where
ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs)
@@ -809,15 +830,15 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
ConDeclH98{} -> case con_details con of
PrefixCon args ->
hsep ((header_ +++ ppOcc)
- : map (ppLParendType unicode qual) args)
+ : map (ppLParendType unicode qual HideEmptyContexts) args)
<+> fixity
RecCon _ -> header_ +++ ppOcc <+> fixity
InfixCon arg1 arg2 ->
- hsep [header_ +++ ppLParendType unicode qual arg1,
+ hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1,
ppOccInfix,
- ppLParendType unicode qual arg2]
+ ppLParendType unicode qual HideEmptyContexts arg2]
<+> fixity
ConDeclGADT{} -> doGADTCon resTy
@@ -834,7 +855,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
doGADTCon :: Located (HsType DocNameI) -> Html
doGADTCon ty = ppOcc <+> dcolon unicode
-- ++AZ++ make this prepend "{..}" when it is a record style GADT
- <+> ppLType unicode qual ty
+ <+> ppLType unicode qual HideEmptyContexts ty
<+> fixity
fixity = ppFixities fixities qual
@@ -861,9 +882,12 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con)
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
-> ConDeclField DocNameI -> SubDecl
ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
- (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype,
- mbDoc,
- [])
+ ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
+ <+> dcolon unicode
+ <+> ppLType unicode qual HideEmptyContexts ltype
+ , mbDoc
+ , []
+ )
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
@@ -873,7 +897,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
ppShortField summary unicode qual (ConDeclField names ltype _)
= hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
- <+> dcolon unicode <+> ppLType unicode qual ltype
+ <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype
-- | Print the LHS of a data\/newtype declaration.
@@ -888,9 +912,9 @@ ppDataHeader summary decl@(DataDecl { tcdDataDefn =
(case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" })
<+>
-- context
- ppLContext ctxt unicode qual <+>
+ ppLContext ctxt unicode qual HideEmptyContexts <+>
-- T a b c ..., or a :+: b
- ppDataBinderWithVars summary decl
+ ppDataBinderWithVars summary unicode qual decl
<+> case ks of
Nothing -> mempty
Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x
@@ -940,19 +964,18 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
| otherwise = p
-ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification
- -> Located (HsType DocNameI) -> Html
-ppLType unicode qual y = ppType unicode qual (unLoc y)
-ppLParendType unicode qual y = ppParendType unicode qual (unLoc y)
-ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y)
+ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html
+ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y)
+ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y)
+ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y)
+ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html
+ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual HideEmptyContexts
-ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification
- -> HsType DocNameI -> Html
-ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual
-ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual
-ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual
-ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual
+ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocNameI -> Html
+ppType unicode qual emptyCtxts ty = ppr_mono_ty pREC_TOP ty unicode qual emptyCtxts
+ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual emptyCtxts
+ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts
ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html
ppHsTyVarBndr _ qual (UserTyVar (L _ name)) =
@@ -965,62 +988,85 @@ ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
ppLKind unicode qual y = ppKind unicode qual (unLoc y)
ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html
-ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
-
-ppForAllPart :: [LHsTyVarBndr DocNameI] -> Unicode -> Html
-ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
-
-ppr_mono_lty :: Int -> LHsType DocNameI -> Unicode -> Qualification -> Html
+ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts
+
+ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
+ppPatSigType unicode qual typ =
+ let emptyCtxts =
+ if hasNonEmptyContext typ && isFirstContextEmpty typ
+ then ShowEmptyToplevelContexts
+ else HideEmptyContexts
+ in ppLType unicode qual emptyCtxts typ
+ where
+ hasNonEmptyContext :: LHsType name -> Bool
+ hasNonEmptyContext t =
+ case unLoc t of
+ HsForAllTy _ s -> hasNonEmptyContext s
+ HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
+ HsFunTy _ s -> hasNonEmptyContext s
+ _ -> False
+ isFirstContextEmpty :: LHsType name -> Bool
+ isFirstContextEmpty t =
+ case unLoc t of
+ HsForAllTy _ s -> isFirstContextEmpty s
+ HsQualTy cxt _ -> null (unLoc cxt)
+ HsFunTy _ s -> isFirstContextEmpty s
+ _ -> False
+
+ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html
+ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot
+
+ppr_mono_lty :: Int -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
-ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> Html
-ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual
+ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts
= maybeParen ctxt_prec pREC_FUN $
- ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual
+ ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
-ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual
+ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts
= maybeParen ctxt_prec pREC_FUN $
- ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual
+ ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
-- UnicodeSyntax alternatives
-ppr_mono_ty _ (HsTyVar _ (L _ name)) True _
+ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ _
| getOccString (getName name) == "*" = toHtml "★"
| getOccString (getName name) == "(->)" = toHtml "(→)"
-ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty
-ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q = ppDocName q Prefix True name
-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q
-ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)
-ppr_mono_ty _ (HsSumTy tys) u q = sumParens (map (ppLType u q) tys)
-ppr_mono_ty _ (HsKindSig ty kind) u q =
- parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind)
-ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q)
-ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
-ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q =
- maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q
-ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"
-ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}"
+ppr_mono_ty _ (HsBangTy b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty
+ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e
+ppr_mono_ty _ (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys)
+ppr_mono_ty _ (HsSumTy tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys)
+ppr_mono_ty _ (HsKindSig ty kind) u q e =
+ parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind)
+ppr_mono_ty _ (HsListTy ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
+ppr_mono_ty _ (HsPArrTy ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
+ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ =
+ maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts
+ppr_mono_ty _ (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy"
+ppr_mono_ty _ (HsRecTy {}) _ _ _ = toHtml "{..}"
-- Can now legally occur in ConDeclGADT, the output here is to provide a
-- placeholder in the signature, which is followed by the field
-- declarations.
-ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
-ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q = brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
-ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys
-ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy"
+ppr_mono_ty _ (HsCoreTy {}) _ _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty _ (HsAppsTy {}) _ _ _ = error "ppr_mono_ty HsAppsTy"
-ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual _
= maybeParen ctxt_prec pREC_CTX $
- ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual
+ ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts
-ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual _
= maybeParen ctxt_prec pREC_CON $
- hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]
+ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts]
-ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _
= maybeParen ctxt_prec pREC_FUN $
- ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual
+ ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts
where
-- `(:)` is valid in type signature only as constructor to promoted list
-- and needs to be quoted in code so we explicitly quote it here too.
@@ -1029,25 +1075,24 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual
| otherwise = ppr_op'
ppr_op' = ppLDocName qual Infix op
-ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
+ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts
-- = parens (ppr_mono_lty pREC_TOP ty)
- = ppr_mono_lty ctxt_prec ty unicode qual
+ = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts
-ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual
- = ppr_mono_lty ctxt_prec ty unicode qual
+ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts
+ = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts
-ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_'
-ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n
+ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_'
+ppr_mono_ty _ (HsTyLit n) _ _ _ = ppr_tylit n
ppr_tylit :: HsTyLit -> Html
ppr_tylit (HsNumTy _ n) = toHtml (show n)
ppr_tylit (HsStrTy _ s) = toHtml (show s)
-
-ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Unicode -> Qualification -> Html
-ppr_fun_ty ctxt_prec ty1 ty2 unicode qual
- = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual
- p2 = ppr_mono_lty pREC_TOP ty2 unicode qual
+ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppr_fun_ty ctxt_prec ty1 ty2 unicode qual emptyCtxts
+ = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual HideEmptyContexts
+ p2 = ppr_mono_lty pREC_TOP ty2 unicode qual emptyCtxts
in
maybeParen ctxt_prec pREC_FUN $
hsep [p1, arrow unicode <+> p2]
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index e36f9528..18c8a0ff 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -20,6 +20,7 @@ module Haddock.Backends.Xhtml.DocMarkup (
) where
import Data.List
+import Documentation.Haddock.Markup
import Haddock.Backends.Xhtml.Names
import Haddock.Backends.Xhtml.Utils
import Haddock.Types
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 41457f72..6993c7f6 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -29,6 +29,7 @@ module Haddock.Backends.Xhtml.Layout (
subArguments,
subAssociatedTypes,
subConstructors,
+ subPatterns,
subEquations,
subFields,
subInstances, subOrphanInstances,
@@ -180,6 +181,9 @@ subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBloc
subConstructors :: Qualification -> [SubDecl] -> Html
subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual
+subPatterns :: Qualification -> [SubDecl] -> Html
+subPatterns qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable qual
+
subFields :: Qualification -> [SubDecl] -> Html
subFields qual = divSubDecls "fields" "Fields" . subDlist qual
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 2b25174c..36efb3e4 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -30,7 +30,7 @@ import Name
import NameSet ( emptyNameSet )
import RdrName ( mkVarUnqual )
import PatSyn
-import SrcLoc ( Located, noLoc, unLoc )
+import SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan )
import TcType ( tcSplitSigmaTy )
import TyCon
import Type
@@ -319,7 +319,7 @@ synifyDataCon use_gadt_syntax dc =
, con_doc = Nothing }
synifyName :: NamedThing n => n -> Located Name
-synifyName = noLoc . getName
+synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n)
synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 83e4dbd8..561c126f 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
+{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
@@ -17,17 +17,14 @@ module Haddock.GhcUtils where
import Control.Arrow
-import Data.Function
import Exception
import Outputable
import Name
+import NameSet
import Lexeme
import Module
-import RdrName (GlobalRdrEnv)
-import GhcMonad (withSession)
import HscTypes
-import UniqFM
import GHC
import Class
@@ -92,6 +89,10 @@ filterSigNames p (ClassOpSig is_default ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
filtered -> Just (ClassOpSig is_default filtered ty)
+filterSigNames p (PatSynSig ns ty) =
+ case filter (p . unLoc) ns of
+ [] -> Nothing
+ filtered -> Just (PatSynSig filtered ty)
filterSigNames _ _ = Nothing
ifTrueJust :: Bool -> name -> Maybe name
@@ -114,6 +115,7 @@ sigNameNoLoc _ = []
isUserLSig :: LSig name -> Bool
isUserLSig (L _(TypeSig {})) = True
isUserLSig (L _(ClassOpSig {})) = True
+isUserLSig (L _(PatSynSig {})) = True
isUserLSig _ = False
@@ -134,6 +136,17 @@ declATs _ = []
pretty :: Outputable a => DynFlags -> a -> String
pretty = showPpr
+nubByName :: (a -> Name) -> [a] -> [a]
+nubByName f ns = go emptyNameSet ns
+ where
+ go !_ [] = []
+ go !s (x:xs)
+ | y `elemNameSet` s = go s xs
+ | otherwise = let !s' = extendNameSet s y
+ in x : go s' xs
+ where
+ y = f x
+
-------------------------------------------------------------------------------
-- * Located
-------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 31991e25..4c7b70d7 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface
@@ -56,6 +57,13 @@ import Exception
import GHC hiding (verbosity)
import HscTypes
import FastString (unpackFS)
+import MonadUtils (liftIO)
+
+#if defined(mingw32_HOST_OS)
+import System.IO
+import GHC.IO.Encoding.CodePage (mkLocaleEncoding)
+import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))
+#endif
-- | Create 'Interface's and a link environment by typechecking the list of
-- modules using the GHC API and processing the resulting syntax trees.
@@ -68,6 +76,10 @@ processModules
-> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming
-- environment
processModules verbosity modules flags extIfaces = do
+#if defined(mingw32_HOST_OS)
+ -- Avoid internal error: <stderr>: hPutChar: invalid argument (invalid character)' non UTF-8 Windows
+ liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure
+#endif
out verbosity verbose "Creating interfaces..."
let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 1eb227b9..0e5811b1 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -19,14 +19,13 @@ import Haddock.Types
import Haddock.Convert
import Haddock.GhcUtils
+import Control.Applicative
import Control.Arrow hiding ((<+>))
import Data.List
import Data.Ord (comparing)
-import Data.Function (on)
import Data.Maybe ( maybeToList, mapMaybe, fromMaybe )
import qualified Data.Map as Map
import qualified Data.Set as Set
-import Control.Monad
import Class
import DynFlags
@@ -35,7 +34,6 @@ import ErrUtils
import FamInstEnv
import FastString
import GHC
-import GhcMonad (withSession)
import InstEnv
import MonadUtils (liftIO)
import Name
@@ -118,13 +116,17 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
return $ e { expItemInstances = insts }
e -> return e
where
- attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities =
- nubBy ((==) `on` fst) $ expItemFixities e ++
+ attachFixities e@ExportDecl{ expItemDecl = L _ d
+ , expItemPats = patsyns
+ } = e { expItemFixities =
+ nubByName fst $ expItemFixities e ++
[ (n',f) | n <- getMainDeclBinder d
- , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap]
- , n' <- n : subs
+ , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap <|> Just []]
+ , n' <- n : (subs ++ patsyn_names)
, Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
] }
+ where
+ patsyn_names = concatMap (getMainDeclBinder . fst) patsyns
attachFixities e = e
-- spanName: attach the location to the name that is the same file as the instance location
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 2b352d90..292680a7 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -20,6 +20,7 @@
module Haddock.Interface.Create (createInterface) where
import Documentation.Haddock.Doc (metaDocAppend)
+import Documentation.Haddock.Utf8 as Utf8
import Haddock.Types
import Haddock.Options
import Haddock.GhcUtils
@@ -30,6 +31,8 @@ import Haddock.Backends.Hyperlinker.Types
import Haddock.Backends.Hyperlinker.Ast as Hyperlinker
import Haddock.Backends.Hyperlinker.Parser as Hyperlinker
+import Data.Bitraversable
+import qualified Data.ByteString as BS
import qualified Data.Map as M
import Data.Map (Map)
import Data.List
@@ -37,10 +40,9 @@ import Data.Maybe
import Data.Monoid
import Data.Ord
import Control.Applicative
-import Control.Arrow (second)
-import Control.DeepSeq
+import Control.Exception (evaluate)
import Control.Monad
-import Data.Function (on)
+import Data.Traversable
import qualified Packages
import qualified Module
@@ -48,6 +50,7 @@ import qualified SrcLoc
import GHC
import HscTypes
import Name
+import NameSet
import Bag
import RdrName
import TcRnTypes
@@ -76,9 +79,12 @@ createInterface tm flags modMap instIfaceMap = do
dflags = ms_hspp_opts ms
!instances = modInfoInstances mi
!fam_instances = md_fam_insts md
- !exportedNames = modInfoExports mi
+ !exportedNames = modInfoExportsWithSelectors mi
- (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm
+ (TcGblEnv { tcg_rdr_env = gre
+ , tcg_warns = warnings
+ , tcg_patsyns = patsyns
+ }, md) = tm_internals_ tm
-- The renamed source should always be available to us, but it's best
-- to be on the safe side.
@@ -98,6 +104,27 @@ createInterface tm flags modMap instIfaceMap = do
(!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
let declsWithDocs = topDecls group_
+
+ exports0 = fmap (reverse . map unLoc) mayExports
+ exports
+ | OptIgnoreExports `elem` opts = Nothing
+ | otherwise = exports0
+
+ localBundledPatSyns :: Map Name [Name]
+ localBundledPatSyns =
+ case exports of
+ Nothing -> M.empty
+ Just ies ->
+ M.map (nubByName id) $
+ M.fromListWith (++) [ (ieWrappedName ty_name, bundled_patsyns)
+ | IEThingWith (L _ ty_name) _ exported _ <- ies
+ , let bundled_patsyns =
+ filter is_patsyn (map (ieWrappedName . unLoc) exported)
+ , not (null bundled_patsyns)
+ ]
+ where
+ is_patsyn name = elemNameSet name (mkNameSet (map getName patsyns))
+
fixMap = mkFixMap group_
(decls, _) = unzip declsWithDocs
localInsts = filter (nameIsLocalOrFrom sem_mdl)
@@ -106,21 +133,17 @@ createInterface tm flags modMap instIfaceMap = do
-- Locations of all TH splices
splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
- maps@(!docMap, !argMap, !subMap, !declMap, _) =
- mkMaps dflags gre localInsts declsWithDocs
+ warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
- let exports0 = fmap (reverse . map unLoc) mayExports
- exports
- | OptIgnoreExports `elem` opts = Nothing
- | otherwise = exports0
- warningMap = mkWarningMap dflags warnings gre exportedNames
+ maps@(!docMap, !argMap, !subMap, !declMap, _) <-
+ liftErrMsg (mkMaps dflags gre localInsts declsWithDocs)
let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
-- The MAIN functionality: compute the export items which will
-- each be the actual documentation of this module.
exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls
- maps fixMap splices exports instIfaceMap dflags
+ maps localBundledPatSyns fixMap splices exports instIfaceMap dflags
let !visibleNames = mkVisibleNames maps exportItems opts
@@ -139,37 +162,39 @@ createInterface tm flags modMap instIfaceMap = do
let !aliases =
mkAliasMap dflags $ tm_renamed_source tm
- modWarn = moduleWarning dflags gre warnings
+
+ modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
tokenizedSrc <- mkMaybeTokenizedSrc flags tm
return $! Interface {
- ifaceMod = mdl
- , ifaceIsSig = is_sig
- , ifaceOrigFilename = msHsFilePath ms
- , ifaceInfo = info
- , ifaceDoc = Documentation mbDoc modWarn
- , ifaceRnDoc = Documentation Nothing Nothing
- , ifaceOptions = opts
- , ifaceDocMap = docMap
- , ifaceArgMap = argMap
- , ifaceRnDocMap = M.empty
- , ifaceRnArgMap = M.empty
- , ifaceExportItems = prunedExportItems
- , ifaceRnExportItems = []
- , ifaceExports = exportedNames
- , ifaceVisibleExports = visibleNames
- , ifaceDeclMap = declMap
- , ifaceSubMap = subMap
- , ifaceFixMap = fixMap
- , ifaceModuleAliases = aliases
- , ifaceInstances = instances
- , ifaceFamInstances = fam_instances
+ ifaceMod = mdl
+ , ifaceIsSig = is_sig
+ , ifaceOrigFilename = msHsFilePath ms
+ , ifaceInfo = info
+ , ifaceDoc = Documentation mbDoc modWarn
+ , ifaceRnDoc = Documentation Nothing Nothing
+ , ifaceOptions = opts
+ , ifaceDocMap = docMap
+ , ifaceArgMap = argMap
+ , ifaceRnDocMap = M.empty
+ , ifaceRnArgMap = M.empty
+ , ifaceExportItems = prunedExportItems
+ , ifaceRnExportItems = []
+ , ifaceExports = exportedNames
+ , ifaceVisibleExports = visibleNames
+ , ifaceDeclMap = declMap
+ , ifaceBundledPatSynMap = localBundledPatSyns
+ , ifaceSubMap = subMap
+ , ifaceFixMap = fixMap
+ , ifaceModuleAliases = aliases
+ , ifaceInstances = instances
+ , ifaceFamInstances = fam_instances
, ifaceOrphanInstances = [] -- Filled in `attachInstances`
, ifaceRnOrphanInstances = [] -- Filled in `renameInterface`
- , ifaceHaddockCoverage = coverage
- , ifaceWarningMap = warningMap
- , ifaceTokenizedSrc = tokenizedSrc
+ , ifaceHaddockCoverage = coverage
+ , ifaceWarningMap = warningMap
+ , ifaceTokenizedSrc = tokenizedSrc
}
-- | Given all of the @import M as N@ declarations in a package,
@@ -222,27 +247,29 @@ lookupModuleDyn dflags Nothing mdlName =
-- Warnings
-------------------------------------------------------------------------------
-mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
+mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
mkWarningMap dflags warnings gre exps = case warnings of
- NoWarnings -> M.empty
- WarnAll _ -> M.empty
+ NoWarnings -> pure M.empty
+ WarnAll _ -> pure M.empty
WarnSome ws ->
- let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
+ let ws' = [ (n, w)
+ | (occ, w) <- ws
+ , elt <- lookupGlobalRdrEnv gre occ
, let n = gre_name elt, n `elem` exps ]
- in M.fromList $ map (second $ parseWarning dflags gre) ws'
+ in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws'
-moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name)
-moduleWarning _ _ NoWarnings = Nothing
-moduleWarning _ _ (WarnSome _) = Nothing
-moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> 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 -> Doc Name
-parseWarning dflags gre w = force $ case w of
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
+parseWarning dflags gre w = case w of
DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg)
WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg)
where
format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
- . processDocString dflags gre $ HsDocString xs
+ <$> processDocString dflags gre (HsDocString xs)
-------------------------------------------------------------------------------
@@ -290,10 +317,15 @@ mkMaps :: DynFlags
-> GlobalRdrEnv
-> [Name]
-> [(LHsDecl GhcRn, [HsDocString])]
- -> Maps
-mkMaps dflags gre instances decls =
- let (a, b, c, d) = unzip4 $ map mappings decls
- in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)
+ -> ErrMsgM Maps
+mkMaps dflags gre instances decls = do
+ (a, b, c, d) <- unzip4 <$> traverse mappings decls
+ pure ( f' (map (nubByName fst) a)
+ , f (filterMapping (not . M.null) b)
+ , f (filterMapping (not . null) c)
+ , f (filterMapping (not . null) d)
+ , instanceMap
+ )
where
f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
f = M.fromListWith (<>) . concat
@@ -301,36 +333,46 @@ mkMaps dflags gre instances decls =
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))
+
mappings :: (LHsDecl GhcRn, [HsDocString])
- -> ( [(Name, MDoc Name)]
- , [(Name, Map Int (MDoc Name))]
- , [(Name, [Name])]
- , [(Name, [LHsDecl GhcRn])]
- )
- mappings (ldecl, docStrs) =
+ -> ErrMsgM ( [(Name, MDoc Name)]
+ , [(Name, Map Int (MDoc Name))]
+ , [(Name, [Name])]
+ , [(Name, [LHsDecl GhcRn])]
+ )
+ mappings (ldecl, docStrs) = do
let L l decl = ldecl
declDoc :: [HsDocString] -> Map Int HsDocString
- -> (Maybe (MDoc Name), Map Int (MDoc Name))
- declDoc strs m =
- let doc' = processDocStrings dflags gre strs
- m' = M.map (processDocStringParas dflags gre) m
- in (doc', m')
- (doc, args) = declDoc docStrs (typeDocs decl)
+ -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name))
+ declDoc strs m = do
+ doc' <- processDocStrings dflags gre strs
+ m' <- traverse (processDocStringParas dflags gre) m
+ pure (doc', m')
+
+ (doc, args) <- declDoc docStrs (typeDocs decl)
+
+ let
subs :: [(Name, [HsDocString], Map Int HsDocString)]
subs = subordinates instanceMap decl
- (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs
+
+ (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
sm = [ (n, subNs) | n <- ns ]
cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
- in seqList ns `seq`
- seqList subNs `seq`
- doc `seq`
- seqList subDocs `seq`
- seqList subArgs `seq`
- (dm, am, sm, cm)
+
+ seqList ns `seq`
+ seqList subNs `seq`
+ doc `seq`
+ seqList subDocs `seq`
+ seqList subArgs `seq`
+ pure (dm, am, sm, cm)
instanceMap :: Map SrcSpan Name
instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
@@ -359,7 +401,9 @@ mkMaps dflags gre instances decls =
-- | Get all subordinate declarations inside a declaration, and their docs.
-- A subordinate declaration is something like the associate type or data
-- family of a type class.
-subordinates :: InstMap -> HsDecl GhcRn -> [(Name, [HsDocString], Map Int HsDocString)]
+subordinates :: InstMap
+ -> HsDecl GhcRn
+ -> [(Name, [HsDocString], Map Int HsDocString)]
subordinates instMap decl = case decl of
InstD (ClsInstD d) -> do
DataFamInstDecl { dfid_tycon = L l _
@@ -395,8 +439,9 @@ typeDocs :: HsDecl GhcRn -> Map Int HsDocString
typeDocs d =
let docs = go 0 in
case d of
- SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty))
- SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty))
+ SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty))
+ SigD (ClassOpSig _ _ ty) -> docs (unLoc (hsSigType ty))
+ SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty))
ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty))
TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
_ -> M.empty
@@ -536,6 +581,7 @@ mkExportItems
-> [Name] -- exported names (orig)
-> [LHsDecl GhcRn] -- renamed source declarations
-> Maps
+ -> Map Name [Name]
-> FixMap
-> [SrcSpan] -- splice locations
-> Maybe [IE GhcRn]
@@ -544,15 +590,21 @@ mkExportItems
-> ErrMsgGhc [ExportItem GhcRn]
mkExportItems
is_sig modMap thisMod semMod warnings gre exportedNames decls
- maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
+ maps@(docMap, argMap, subMap, declMap, instMap) patSynMap fixMap splices optExports instIfaceMap dflags =
case optExports of
Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
Just exports -> liftM concat $ mapM lookupExport exports
where
- lookupExport (IEVar (L _ x)) = declWith $ ieWrappedName x
- lookupExport (IEThingAbs (L _ t)) = declWith $ ieWrappedName t
- lookupExport (IEThingAll (L _ t)) = declWith $ ieWrappedName t
- lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t
+ lookupExport (IEVar (L _ x)) = declWith [] $ ieWrappedName x
+ lookupExport (IEThingAbs (L _ t)) = declWith [] $ ieWrappedName t
+ lookupExport (IEThingAll (L _ t)) = do
+ let name = ieWrappedName t
+ pats <- findBundledPatterns name
+ declWith pats name
+ lookupExport (IEThingWith (L _ t) _ _ _) = do
+ let name = ieWrappedName t
+ pats <- findBundledPatterns name
+ declWith pats name
lookupExport (IEModuleContents (L _ m)) =
-- TODO: We could get more accurate reporting here if IEModuleContents
-- also recorded the actual names that are exported here. We CAN
@@ -560,19 +612,23 @@ mkExportItems
-- do so.
-- NB: Pass in identity module, so we can look it up in index correctly
moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
- lookupExport (IEGroup lev docStr) = return $
- return . ExportGroup lev "" $ processDocString dflags gre docStr
+ lookupExport (IEGroup lev docStr) = liftErrMsg $ do
+ doc <- processDocString dflags gre docStr
+ return [ExportGroup lev "" doc]
- lookupExport (IEDoc docStr) = return $
- return . ExportDoc $ processDocStringParas dflags gre docStr
+ lookupExport (IEDoc docStr) = liftErrMsg $ do
+ doc <- processDocStringParas dflags gre docStr
+ return [ExportDoc doc]
lookupExport (IEDocNamed str) = liftErrMsg $
- findNamedDoc str [ unL d | d <- decls ] >>= return . \case
- Nothing -> []
- Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
-
- declWith :: Name -> ErrMsgGhc [ ExportItem GhcRn ]
- declWith t = do
+ findNamedDoc str [ unL d | d <- decls ] >>= \case
+ Nothing -> return []
+ Just docStr -> do
+ doc <- processDocStringParas dflags gre docStr
+ return [ExportDoc doc]
+
+ declWith :: [(HsDecl GhcRn, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem GhcRn ]
+ declWith pats t = do
r <- findDecl t
case r of
([L l (ValD _)], (doc, _)) -> do
@@ -609,15 +665,15 @@ mkExportItems
-- fromJust is safe since we already checked in guards
-- that 't' is a name declared in this declaration.
let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig
- in return [ mkExportDecl t newDecl docs_ ]
+ in return [ mkExportDecl t newDecl pats docs_ ]
L loc (TyClD cl@ClassDecl{}) -> do
mdef <- liftGhcToErrMsgGhc $ minimalDef t
let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef
return [ mkExportDecl t
- (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]
+ (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) pats docs_ ]
- _ -> return [ mkExportDecl t decl docs_ ]
+ _ -> return [ mkExportDecl t decl pats docs_ ]
-- Declaration from another package
([], _) -> do
@@ -634,24 +690,27 @@ mkExportItems
liftErrMsg $ tell
["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ]
- return [ mkExportDecl t decl (noDocForDecl, subs_) ]
+ return [ mkExportDecl t decl pats (noDocForDecl, subs_) ]
Just iface ->
- return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
+ return [ mkExportDecl t decl pats (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
_ -> return []
- mkExportDecl :: Name -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem GhcRn
- mkExportDecl name decl (doc, subs) = decl'
+ mkExportDecl :: Name -> LHsDecl GhcRn -> [(HsDecl GhcRn, DocForDecl Name)]
+ -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem GhcRn
+ mkExportDecl name decl pats (doc, subs) = decl'
where
- decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False
+ decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) pats' doc subs' [] fixities False
subs' = filter (isExported . fst) subs
+ pats' = [ d | d@(patsyn_decl, _) <- pats
+ , all isExported (getMainDeclBinder patsyn_decl) ]
sub_names = map fst subs'
- fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]
-
-
- isExported = (`elem` exportedNames)
+ pat_names = [ n | (patsyn_decl, _) <- pats', n <- getMainDeclBinder patsyn_decl]
+ fixities = [ (n, f) | n <- name:sub_names++pat_names, Just f <- [M.lookup n fixMap] ]
+ exportedNameSet = mkNameSet exportedNames
+ isExported n = elemNameSet n exportedNameSet
findDecl :: Name -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)]))
findDecl n
@@ -682,6 +741,40 @@ mkExportItems
where
m = nameModule n
+ findBundledPatterns :: Name -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)]
+ findBundledPatterns t =
+ let
+ m = nameModule t
+
+ local_bundled_patsyns =
+ M.findWithDefault [] t patSynMap
+
+ iface_bundled_patsyns
+ | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap
+ , Just patsyns <- M.lookup t (ifaceBundledPatSynMap iface)
+ = patsyns
+
+ | Just iface <- M.lookup m instIfaceMap
+ , Just patsyns <- M.lookup t (instBundledPatSynMap iface)
+ = patsyns
+
+ | otherwise
+ = []
+
+ patsyn_decls = do
+ for (local_bundled_patsyns ++ iface_bundled_patsyns) $ \patsyn_name -> do
+ -- call declWith here so we don't have to prepare the pattern synonym for
+ -- showing ourselves.
+ export_items <- declWith [] patsyn_name
+ pure [ (unLoc patsyn_decl, patsyn_doc)
+ | ExportDecl {
+ expItemDecl = patsyn_decl
+ , expItemMbDoc = patsyn_doc
+ } <- export_items
+ ]
+
+ in concat <$> patsyn_decls
+
-- | Given a 'Module' from a 'Name', convert it into a 'Module' that
-- we can actually find in the 'IfaceMap'.
semToIdMod :: UnitId -> Module -> Module
@@ -716,7 +809,7 @@ 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)
+ Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice)
where
fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t
fixities = case fixity of
@@ -817,26 +910,39 @@ fullModuleContents :: DynFlags
-> [LHsDecl GhcRn] -- ^ All the renamed declarations
-> ErrMsgGhc [ExportItem GhcRn]
fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =
- liftM catMaybes $ mapM mkExportItem (expandSig decls)
+ liftM catMaybes $ mapM mkExportItem (expandSigDecls decls)
where
-- A type signature can have multiple names, like:
-- foo, bar :: Types..
--
-- We go through the list of declarations and expand type signatures, so
-- that every type signature has exactly one name!
- expandSig :: [LHsDecl name] -> [LHsDecl name]
- expandSig = foldr f []
+ expandSigDecls :: [LHsDecl name] -> [LHsDecl name]
+ expandSigDecls = concatMap f
where
- f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
- f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names
- f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names
- f x xs = x : xs
+ f (L l (SigD sig)) = [ L l (SigD s) | s <- expandSig sig ]
+
+ -- also expand type signatures for class methods
+ f (L l (TyClD cls@ClassDecl{})) =
+ [ L l (TyClD cls { tcdSigs = concatMap expandLSig (tcdSigs cls) }) ]
+ f x = [x]
+
+ expandLSig :: LSig name -> [LSig name]
+ expandLSig (L l sig) = [ L l s | s <- expandSig sig ]
+
+ expandSig :: Sig name -> [Sig name]
+ expandSig (TypeSig names t) = [ TypeSig [n] t | n <- names ]
+ expandSig (ClassOpSig b names t) = [ ClassOpSig b [n] t | n <- names ]
+ expandSig (PatSynSig names t) = [ PatSynSig [n] t | n <- names ]
+ expandSig x = [x]
mkExportItem :: LHsDecl GhcRn -> ErrMsgGhc (Maybe (ExportItem GhcRn))
mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
- return . Just . ExportGroup lev "" $ processDocString dflags gre docStr
+ doc <- liftErrMsg (processDocString dflags gre docStr)
+ return . Just . ExportGroup lev "" $ doc
mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
- return . Just . ExportDoc $ processDocStringParas dflags gre docStr
+ doc <- liftErrMsg (processDocStringParas dflags gre docStr)
+ return . Just . ExportDoc $ doc
mkExportItem (L l (ValD d))
| name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
-- Top-level binding without type signature.
@@ -860,12 +966,12 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
fixities name subs = [ (n,f) | n <- name : map fst subs
, Just f <- [M.lookup n fixMap] ]
- expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+ expDecl decl l name = return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices))
where (doc, subs) = lookupDocs name warnings docMap argMap subMap
expInst decl l name =
let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
- return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+ return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices))
-- | Sometimes the declaration we want to export is not the "main" declaration:
@@ -895,7 +1001,9 @@ extractDecl name decl
O.$$ O.nest 4 (O.ppr matches))
TyClD d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
- in SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
+ in if isDataConName name
+ then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))
+ else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))
InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
, dfid_pats = HsIB { hsib_body = tys }
, dfid_defn = defn }) ->
@@ -913,6 +1021,36 @@ extractDecl name decl
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
+extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn
+extractPatternSyn nm t tvs cons =
+ case filter matches cons of
+ [] -> error "extractPatternSyn: constructor pattern not found"
+ con:_ -> extract <$> con
+ where
+ matches :: LConDecl GhcRn -> Bool
+ matches (L _ con) = nm `elem` (unLoc <$> getConNames con)
+ extract :: ConDecl GhcRn -> Sig GhcRn
+ extract con =
+ let args =
+ case getConDetails con of
+ PrefixCon args' -> args'
+ RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
+ InfixCon arg1 arg2 -> [arg1, arg2]
+ typ = longArrow args (data_ty con)
+ typ' =
+ case con of
+ ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ)
+ _ -> typ
+ typ'' = noLoc (HsQualTy (noLoc []) typ')
+ in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'')
+
+ longArrow :: [LHsType name] -> LHsType name -> LHsType name
+ longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs
+
+ data_ty con
+ | ConDeclGADT{} <- con = hsib_body $ con_type con
+ | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
+
extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn]
-> LSig GhcRn
extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
@@ -945,8 +1083,9 @@ mkVisibleNames (_, _, _, _, instMap) exports opts
| otherwise = let ns = concatMap exportName exports
in seqList ns `seq` ns
where
- exportName e@ExportDecl {} = name ++ subs
- where subs = map fst (expItemSubDocs e)
+ exportName e@ExportDecl {} = name ++ subs ++ patsyns
+ where subs = map fst (expItemSubDocs e)
+ patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)
name = case unLoc $ expItemDecl e of
InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap
decl -> getMainDeclBinder decl
@@ -977,10 +1116,11 @@ mkMaybeTokenizedSrc flags tm
summary = pm_mod_summary . tm_parsed_module $ tm
mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken]
-mkTokenizedSrc ms src =
- Hyperlinker.enrich src . Hyperlinker.parse <$> rawSrc
- where
- rawSrc = readFile $ msHsFilePath ms
+mkTokenizedSrc ms src = do
+ -- make sure to read the whole file at once otherwise
+ -- we run out of file descriptors (see #495)
+ rawSrc <- BS.readFile (msHsFilePath ms) >>= evaluate
+ return $ Hyperlinker.enrich src (Hyperlinker.parse (decodeUtf8 rawSrc))
-- | Find a stand-alone documentation comment by its name.
findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString)
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
new file mode 100644
index 00000000..9a569204
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE RecordWildCards #-}
+module Haddock.Interface.Json (
+ jsonInstalledInterface
+ , jsonInterfaceFile
+ , renderJson
+ ) where
+
+import BasicTypes
+import Json
+import Module
+import Name
+import Outputable
+
+import Control.Arrow
+import Data.Map (Map)
+import Data.Bifunctor
+import qualified Data.Map as Map
+
+import Haddock.Types
+import Haddock.InterfaceFile
+
+jsonInterfaceFile :: InterfaceFile -> JsonDoc
+jsonInterfaceFile InterfaceFile{..} =
+ jsonObject [ ("link_env" , jsonMap nameStableString (jsonString . moduleNameString . moduleName) ifLinkEnv)
+ , ("inst_ifaces", jsonArray (map jsonInstalledInterface ifInstalledIfaces))
+ ]
+
+jsonInstalledInterface :: InstalledInterface -> JsonDoc
+jsonInstalledInterface InstalledInterface{..} = jsonObject properties
+ where
+ properties =
+ [ ("module" , jsonModule instMod)
+ , ("is_sig" , jsonBool instIsSig)
+ , ("info" , jsonHaddockModInfo instInfo)
+ , ("doc_map" , jsonMap nameStableString jsonMDoc instDocMap)
+ , ("arg_map" , jsonMap nameStableString (jsonMap show jsonMDoc) instArgMap)
+ , ("exports" , jsonArray (map jsonName instExports))
+ , ("visible_exports" , jsonArray (map jsonName instVisibleExports))
+ , ("options" , jsonArray (map (jsonString . show) instOptions))
+ , ("sub_map" , jsonMap nameStableString (jsonArray . map jsonName) instSubMap)
+ , ("bundled_patsyns" , jsonMap nameStableString (jsonArray . map jsonName) instBundledPatSynMap)
+ , ("fix_map" , jsonMap nameStableString jsonFixity instFixMap)
+ ]
+
+jsonHaddockModInfo :: HaddockModInfo Name -> JsonDoc
+jsonHaddockModInfo HaddockModInfo{..} =
+ jsonObject [ ("description" , jsonMaybe jsonDoc hmi_description)
+ , ("copyright" , jsonMaybe jsonString hmi_copyright)
+ , ("maintainer" , jsonMaybe jsonString hmi_maintainer)
+ , ("stability" , jsonMaybe jsonString hmi_stability)
+ , ("protability" , jsonMaybe jsonString hmi_portability)
+ , ("safety" , jsonMaybe jsonString hmi_safety)
+ , ("language" , jsonMaybe (jsonString . show) hmi_language)
+ , ("extensions" , jsonArray (map (jsonString . show) hmi_extensions))
+ ]
+
+jsonMap :: (a -> String) -> (b -> JsonDoc) -> Map a b -> JsonDoc
+jsonMap f g = jsonObject . map (f *** g) . Map.toList
+
+jsonMDoc :: MDoc Name -> JsonDoc
+jsonMDoc MetaDoc{..} =
+ jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))])
+ , ("doc", jsonDoc _doc)
+ ]
+
+jsonDoc :: Doc Name -> JsonDoc
+jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc))
+
+jsonModule :: Module -> JsonDoc
+jsonModule = JSString . moduleStableString
+
+jsonName :: Name -> JsonDoc
+jsonName = JSString . nameStableString
+
+jsonFixity :: Fixity -> JsonDoc
+jsonFixity (Fixity _ prec dir) =
+ jsonObject [ ("prec" , jsonInt prec)
+ , ("direction" , jsonFixityDirection dir)
+ ]
+
+jsonFixityDirection :: FixityDirection -> JsonDoc
+jsonFixityDirection InfixL = jsonString "infixl"
+jsonFixityDirection InfixR = jsonString "infixr"
+jsonFixityDirection InfixN = jsonString "infix"
+
+renderJson :: JsonDoc -> SDoc
+renderJson = renderJSON
+
+jsonMaybe :: (a -> JsonDoc) -> Maybe a -> JsonDoc
+jsonMaybe = maybe jsonNull
+
+jsonString :: String -> JsonDoc
+jsonString = JSString
+
+jsonObject :: [(String, JsonDoc)] -> JsonDoc
+jsonObject = JSObject
+
+jsonArray :: [JsonDoc] -> JsonDoc
+jsonArray = JSArray
+
+jsonNull :: JsonDoc
+jsonNull = JSNull
+
+jsonInt :: Int -> JsonDoc
+jsonInt = JSInt
+
+jsonBool :: Bool -> JsonDoc
+jsonBool = JSBool
+
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 608344ad..75b2f223 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -35,20 +35,21 @@ import EnumSet
import RnEnv (dataTcOccs)
processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
- -> Maybe (MDoc Name)
-processDocStrings dflags gre strs =
- case metaDocConcat $ map (processDocStringParas dflags gre) strs of
+ -> ErrMsgM (Maybe (MDoc Name))
+processDocStrings dflags gre strs = do
+ mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags 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 { _version = Nothing }, _doc = DocEmpty } -> Nothing
- x -> Just x
+ MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> pure Nothing
+ x -> pure (Just x)
-processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name
+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)
processDocStringParas dflags gre (HsDocString fs) =
- overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs)
+ overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs)
-processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
+processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name)
processDocString dflags gre (HsDocString fs) =
rename dflags gre $ parseString dflags (unpackFS fs)
@@ -61,9 +62,11 @@ processModuleHeader dflags gre safety mayStr = do
Just (L _ (HsDocString fs)) -> do
let str = unpackFS fs
(hmi, doc) = parseModuleHeader dflags str
- !descr = rename dflags gre <$> hmi_description hmi
- hmi' = hmi { hmi_description = descr }
- doc' = overDoc (rename dflags gre) doc
+ !descr <- case hmi_description hmi of
+ Just hmi_descr -> Just <$> rename dflags gre hmi_descr
+ Nothing -> pure Nothing
+ let hmi' = hmi { hmi_description = descr }
+ doc' <- overDocF (rename dflags gre) doc
return (hmi', Just doc')
let flags :: [LangExt.Extension]
@@ -83,12 +86,12 @@ processModuleHeader dflags gre safety mayStr = do
-- fallbacks in case we can't locate the identifiers.
--
-- See the comments in the source for implementation commentary.
-rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
+rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name)
rename dflags gre = rn
where
rn d = case d of
- DocAppend a b -> DocAppend (rn a) (rn b)
- DocParagraph doc -> DocParagraph (rn doc)
+ DocAppend a b -> DocAppend <$> rn a <*> rn b
+ DocParagraph doc -> DocParagraph <$> rn doc
DocIdentifier x -> do
-- Generate the choices for the possible kind of thing this
-- is.
@@ -101,7 +104,7 @@ rename dflags gre = rn
-- We found no names in the env so we start guessing.
[] ->
case choices of
- [] -> DocMonospaced (DocString (showPpr dflags x))
+ [] -> pure (DocMonospaced (DocString (showPpr dflags x)))
-- 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
@@ -110,37 +113,37 @@ rename dflags gre = rn
-- type constructor names (such as in #253). So now we
-- only get type constructor links if they are actually
-- in scope.
- a:_ -> outOfScope dflags a
+ a:_ -> pure (outOfScope dflags a)
-- There is only one name in the environment that matches so
-- use it.
- [a] -> DocIdentifier a
+ [a] -> pure (DocIdentifier a)
-- But when there are multiple names available, default to
-- type constructors: somewhat awfully GHC returns the
-- values in the list positionally.
- a:b:_ | isTyConName a -> DocIdentifier a
- | otherwise -> DocIdentifier b
+ a:b:_ | isTyConName a -> pure (DocIdentifier a)
+ | otherwise -> pure (DocIdentifier b)
- DocWarning doc -> DocWarning (rn doc)
- DocEmphasis doc -> DocEmphasis (rn doc)
- DocBold doc -> DocBold (rn doc)
- DocMonospaced doc -> DocMonospaced (rn doc)
- DocUnorderedList docs -> DocUnorderedList (map rn docs)
- DocOrderedList docs -> DocOrderedList (map rn docs)
- DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]
- DocCodeBlock doc -> DocCodeBlock (rn doc)
- DocIdentifierUnchecked x -> DocIdentifierUnchecked x
- DocModule str -> DocModule str
- DocHyperlink l -> DocHyperlink l
- DocPic str -> DocPic str
- DocMathInline str -> DocMathInline str
- DocMathDisplay str -> DocMathDisplay str
- DocAName str -> DocAName str
- DocProperty p -> DocProperty p
- DocExamples e -> DocExamples e
- DocEmpty -> DocEmpty
- DocString str -> DocString str
- DocHeader (Header l t) -> DocHeader $ Header l (rn t)
+ DocWarning doc -> DocWarning <$> rn doc
+ DocEmphasis doc -> DocEmphasis <$> rn doc
+ DocBold doc -> DocBold <$> rn doc
+ DocMonospaced doc -> DocMonospaced <$> rn doc
+ DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs
+ DocOrderedList docs -> DocOrderedList <$> traverse rn docs
+ DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list
+ DocCodeBlock doc -> DocCodeBlock <$> rn doc
+ DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)
+ DocModule str -> pure (DocModule str)
+ DocHyperlink l -> pure (DocHyperlink l)
+ DocPic str -> pure (DocPic str)
+ DocMathInline str -> pure (DocMathInline str)
+ DocMathDisplay str -> pure (DocMathDisplay str)
+ DocAName str -> pure (DocAName str)
+ DocProperty p -> pure (DocProperty p)
+ DocExamples e -> pure (DocExamples e)
+ DocEmpty -> pure (DocEmpty)
+ DocString str -> pure (DocString str)
+ DocHeader (Header l t) -> DocHeader . Header l <$> rn t
-- | Wrap an identifier that's out of scope (i.e. wasn't found in
-- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 70846b31..2e9a311a 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -55,7 +55,7 @@ renameInterface dflags renamingEnv warnings iface =
-- combine the missing names and filter out the built-ins, which would
-- otherwise always be missing.
- missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much
+ missingNames = nubByName id $ filter isExternalName -- XXX: isExternalName filters out too much
(missingNames1 ++ missingNames2 ++ missingNames3
++ missingNames4 ++ missingNames5)
@@ -314,6 +314,11 @@ renameInstHead InstHead {..} = do
renameLDecl :: LHsDecl GhcRn -> RnM (LHsDecl DocNameI)
renameLDecl (L loc d) = return . L loc =<< renameDecl d
+renamePats :: [(HsDecl GhcRn, DocForDecl Name)] -> RnM [(HsDecl DocNameI, DocForDecl DocName)]
+renamePats = mapM
+ (\(d,doc) -> do { d' <- renameDecl d
+ ; doc' <- renameDocForDecl doc
+ ; return (d',doc')})
renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI)
renameDecl decl = case decl of
@@ -601,15 +606,16 @@ renameExportItem item = case item of
ExportGroup lev id_ doc -> do
doc' <- renameDoc doc
return (ExportGroup lev id_ doc')
- ExportDecl decl doc subs instances fixities splice -> do
+ 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' doc' subs' instances' fixities' splice)
+ return (ExportDecl decl' pats' doc' subs' instances' fixities' splice)
ExportNoDecl x subs -> do
x' <- lookupRn x
subs' <- mapM lookupRn subs
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index d8bdecec..0c8e89c2 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -1,9 +1,9 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
-
module Haddock.Interface.Specialize
( specializeInstHead
) where
@@ -17,7 +17,6 @@ import Name
import FastString
import Control.Monad
-import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Data.Data
@@ -28,72 +27,64 @@ import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
-
--- | Instantiate all occurrences of given name with particular type.
-specialize :: (Eq (IdP name), Typeable name)
- => Data a
- => IdP name -> HsType name -> a -> a
-specialize name details =
- everywhere $ mkT step
- where
- step (HsTyVar _ (L _ name')) | name == name' = details
- step typ = typ
-
-
-- | Instantiate all occurrences of given names with corresponding types.
---
--- It is just a convenience function wrapping 'specialize' that supports more
--- that one specialization.
-specialize' :: (Eq (IdP name), Typeable name)
+specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name))
=> Data a
=> [(IdP name, HsType name)] -> a -> a
-specialize' = flip $ foldr (uncurry specialize)
+specialize specs = go
+ where
+ go :: forall x. Data x => x -> x
+ go = everywhereButType @name $ mkT $ sugar . specialize_ty_var
+ specialize_ty_var (HsTyVar _ (L _ name'))
+ | Just t <- Map.lookup name' spec_map = t
+ specialize_ty_var typ = typ
+ -- This is a tricky recursive definition that is guaranteed to terminate
+ -- because a type binder cannot be instantiated with a type that depends
+ -- on that binder. i.e. @a -> Maybe a@ is invalid
+ spec_map = Map.fromList [ (n, go t) | (n, t) <- specs]
-- | 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 :: (Eq (IdP name), DataId name)
+specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name))
=> Data a
=> LHsQTyVars name -> [HsType name]
-> a -> a
specializeTyVarBndrs bndrs typs =
- specialize' $ zip bndrs' typs
+ specialize $ zip bndrs' typs
where
bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
bname (UserTyVar (L _ name)) = name
bname (KindedTyVar (L _ name) _) = name
-specializePseudoFamilyDecl :: (Eq (IdP name), DataId name)
+specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name))
=> LHsQTyVars name -> [HsType name]
-> PseudoFamilyDecl name
-> PseudoFamilyDecl name
specializePseudoFamilyDecl bndrs typs decl =
- decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) }
- where
- specializeTyVars = specializeTyVarBndrs bndrs typs
-
+ decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)}
-specializeSig :: forall name . (Eq (IdP name), DataId name, SetName (IdP name))
+specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))
=> LHsQTyVars name -> [HsType name]
-> Sig name
-> Sig name
specializeSig bndrs typs (TypeSig lnames typ) =
- TypeSig lnames (typ { hswc_body = (hswc_body typ) { hsib_body = noLoc typ'}})
+ TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})
where
true_type :: HsType name
true_type = unLoc (hsSigWcType typ)
typ' :: HsType name
- typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type
+ typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type
fv = foldr Set.union Set.empty . map freeVariables $ typs
specializeSig _ _ sig = sig
-- | Make all details of instance head (signatures, associated types)
-- specialized to that particular instance type.
-specializeInstHead :: (Eq (IdP name), DataId name, SetName (IdP name))
+specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))
=> InstHead name -> InstHead name
specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
ihd { ihdInstType = instType' }
@@ -115,12 +106,7 @@ specializeInstHead ihd = ihd
-- and @(a, b, c)@.
sugar :: forall name. (NamedThing (IdP name), DataId name)
=> HsType name -> HsType name
-sugar =
- everywhere $ mkT step
- where
- step :: HsType name -> HsType name
- step = sugarOperators . sugarTuples . sugarLists
-
+sugar = sugarOperators . sugarTuples . sugarLists
sugarLists :: NamedThing (IdP name) => HsType name -> HsType name
sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
@@ -217,7 +203,7 @@ setInternalOccName occ name =
-- | Compute set of free variables of given type.
freeVariables :: forall name. (NamedThing (IdP name), DataId name)
- => HsType name -> Set NameRep
+ => HsType name -> Set Name
freeVariables =
everythingWithState Set.empty Set.union query
where
@@ -226,7 +212,7 @@ freeVariables =
(Set.empty, Set.union ctx (bndrsNames bndrs))
Just (HsTyVar _ (L _ name))
| getName name `Set.member` ctx -> (Set.empty, ctx)
- | otherwise -> (Set.singleton $ getNameRep name, ctx)
+ | otherwise -> (Set.singleton $ getName name, ctx)
_ -> (Set.empty, ctx)
bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
@@ -238,33 +224,36 @@ freeVariables =
-- @(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 -> c) -> b@).
-rename :: SetName (IdP name) => Set NameRep -> HsType name -> HsType name
-rename fv typ = runReader (renameType typ) $ RenameEnv
- { rneFV = fv
- , rneCtx = Map.empty
- }
-
+-- like @(a -> b0) -> b@).
+rename :: (Eq (IdP name), DataId name, SetName (IdP name))
+ => Set Name-> HsType name -> HsType name
+rename fv typ = evalState (renameType typ) env
+ where
+ env = RenameEnv
+ { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv
+ , rneSigFVs = Set.map getNameRep $ freeVariables typ
+ , rneCtx = Map.empty
+ }
+ mkPair name = (getNameRep name, name)
-- | Renaming monad.
-type Rename name = Reader (RenameEnv name)
-
--- | Binding generation monad.
-type Rebind name = State (RenameEnv name)
+type Rename name = State (RenameEnv name)
data RenameEnv name = RenameEnv
- { rneFV :: Set NameRep
- , rneCtx :: Map Name name
- }
+ { rneHeadFVs :: Map NameRep Name
+ , rneSigFVs :: Set NameRep
+ , rneCtx :: Map Name name
+ }
-renameType :: SetName (IdP name) => HsType name -> Rename (IdP name) (HsType name)
-renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' ->
+renameType :: (Eq (IdP name), SetName (IdP name))
+ => HsType name -> Rename (IdP name) (HsType name)
+renameType (HsForAllTy bndrs lt) =
HsForAllTy
- <$> pure bndrs'
+ <$> mapM (located renameBinder) bndrs
<*> renameLType lt
renameType (HsQualTy lctxt lt) =
- HsQualTy
+ HsQualTy
<$> located renameContext lctxt
<*> renameLType lt
renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name
@@ -294,85 +283,58 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"
-renameLType :: SetName (IdP name) => LHsType name -> Rename (IdP name) (LHsType name)
+renameLType :: (Eq (IdP name), SetName (IdP name))
+ => LHsType name -> Rename (IdP name) (LHsType name)
renameLType = located renameType
-renameLTypes :: SetName (IdP name) => [LHsType name] -> Rename (IdP name) [LHsType name]
+renameLTypes :: (Eq (IdP name), SetName (IdP name))
+ => [LHsType name] -> Rename (IdP name) [LHsType name]
renameLTypes = mapM renameLType
-renameContext :: SetName (IdP name) => HsContext name -> Rename (IdP name) (HsContext name)
+renameContext :: (Eq (IdP name), SetName (IdP name))
+ => HsContext name -> Rename (IdP name) (HsContext name)
renameContext = renameLTypes
-{-
-renameLTyOp :: SetName (IdP name) => LHsTyOp name -> Rename name (LHsTyOp name)
-renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
--}
+renameBinder :: (Eq (IdP name), SetName (IdP name))
+ => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name)
+renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname
+renameBinder (KindedTyVar lname lkind) =
+ KindedTyVar <$> located renameName lname <*> located renameType lkind
-renameName :: SetName name => name -> Rename name name
+-- | Core renaming logic.
+renameName :: (Eq name, SetName name) => name -> Rename name name
renameName name = do
- RenameEnv { rneCtx = ctx } <- ask
- pure $ fromMaybe name (Map.lookup (getName name) ctx)
-
-
-rebind :: SetName (IdP name)
- => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename (IdP name) a)
- -> Rename (IdP name) a
-rebind lbndrs action = do
- (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask
- local (const env') (action lbndrs')
-
-
-rebindLTyVarBndrs :: SetName (IdP name)
- => [LHsTyVarBndr name] -> Rebind (IdP name) [LHsTyVarBndr name]
-rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs
-
-
-rebindTyVarBndr :: SetName (IdP name)
- => HsTyVarBndr name -> Rebind (IdP name) (HsTyVarBndr name)
-rebindTyVarBndr (UserTyVar (L l name)) =
- UserTyVar . L l <$> rebindName name
-rebindTyVarBndr (KindedTyVar name kinds) =
- KindedTyVar <$> located rebindName name <*> pure kinds
-
-
-rebindName :: SetName name => name -> Rebind name name
-rebindName name = do
RenameEnv { .. } <- get
- taken <- takenNames
case Map.lookup (getName name) rneCtx of
- Just name' -> pure name'
- Nothing | getNameRep name `Set.member` taken -> freshName name
- Nothing -> reuseName name
+ 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 -> Rebind name name
+freshName :: SetName name => name -> Rename name name
freshName name = do
- env@RenameEnv { .. } <- get
taken <- takenNames
let name' = setInternalNameRep (findFreshName taken rep) name
- put $ env { rneCtx = Map.insert nname name' rneCtx }
+ modify $ \rne -> rne
+ { rneCtx = Map.insert (getName name) name' (rneCtx rne) }
return name'
where
nname = getName name
rep = getNameRep nname
-reuseName :: SetName name => name -> Rebind name name
-reuseName name = do
- env@RenameEnv { .. } <- get
- put $ env { rneCtx = Map.insert (getName name) name rneCtx }
- return name
-
-
-takenNames :: NamedThing name => Rebind name (Set NameRep)
+takenNames :: NamedThing name => Rename name (Set NameRep)
takenNames = do
RenameEnv { .. } <- get
- return $ Set.union rneFV (ctxElems rneCtx)
+ return $ Set.unions [headReps rneHeadFVs, rneSigFVs, ctxElems rneCtx]
where
+ headReps = Set.fromList . Map.keys
ctxElems = Set.fromList . map getNameRep . Map.elems
@@ -384,15 +346,7 @@ findFreshName taken =
alternativeNames :: NameRep -> [NameRep]
-alternativeNames name
- | [_] <- nameRepString name = letterNames ++ alternativeNames' name
- where
- letterNames = map (stringNameRep . pure) ['a'..'z']
-alternativeNames name = alternativeNames' name
-
-
-alternativeNames' :: NameRep -> [NameRep]
-alternativeNames' name =
+alternativeNames name =
[ stringNameRep $ str ++ show i | i :: Int <- [0..] ]
where
str = nameRepString name
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 796a7ce6..dd1358d8 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805)
-binaryInterfaceVersion = 29
+binaryInterfaceVersion = 32
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -373,32 +373,32 @@ instance Binary InterfaceFile where
instance Binary InstalledInterface where
put_ bh (InstalledInterface modu is_sig info docMap argMap
- exps visExps opts subMap fixMap) = do
+ exps visExps opts subMap patSynMap fixMap) = do
put_ bh modu
put_ bh is_sig
put_ bh info
- put_ bh docMap
- put_ bh argMap
+ lazyPut bh (docMap, argMap)
put_ bh exps
put_ bh visExps
put_ bh opts
put_ bh subMap
+ put_ bh patSynMap
put_ bh fixMap
get bh = do
modu <- get bh
is_sig <- get bh
info <- get bh
- docMap <- get bh
- argMap <- get bh
+ ~(docMap, argMap) <- lazyGet bh
exps <- get bh
visExps <- get bh
opts <- get bh
subMap <- get bh
+ patSynMap <- get bh
fixMap <- get bh
return (InstalledInterface modu is_sig info docMap argMap
- exps visExps opts subMap fixMap)
+ exps visExps opts subMap patSynMap fixMap)
instance Binary DocOption where
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 0449c829..d73d1a79 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -25,6 +25,7 @@ module Haddock.Options (
sourceUrls,
wikiUrls,
optDumpInterfaceFile,
+ optShowInterfaceFile,
optLaTeXStyle,
optMathjax,
qualification,
@@ -53,6 +54,7 @@ data Flag
-- | Flag_DocBook
| Flag_ReadInterface String
| Flag_DumpInterface String
+ | Flag_ShowInterface String
| Flag_Heading String
| Flag_Html
| Flag_Hoogle
@@ -112,6 +114,8 @@ options backwardsCompat =
"read an interface from FILE",
Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE")
"write the resulting interface to FILE",
+ Option [] ["show-interface"] (ReqArg Flag_ShowInterface "FILE")
+ "print the interface in a human readable form",
-- Option ['S'] ["docbook"] (NoArg Flag_DocBook)
-- "output in DocBook XML",
Option ['h'] ["html"] (NoArg Flag_Html)
@@ -270,6 +274,8 @@ wikiUrls flags =
optDumpInterfaceFile :: [Flag] -> Maybe FilePath
optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ]
+optShowInterfaceFile :: [Flag] -> Maybe FilePath
+optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ]
optLaTeXStyle :: [Flag] -> Maybe String
optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs
index 4847e486..7e34ae8c 100644
--- a/haddock-api/src/Haddock/Syb.hs
+++ b/haddock-api/src/Haddock/Syb.hs
@@ -1,8 +1,11 @@
{-# LANGUAGE Rank2Types #-}
-
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Haddock.Syb
- ( everything, everythingWithState, everywhere
+ ( everything, everythingButType, everythingWithState
+ , everywhere, everywhereButType
, mkT
, combine
) where
@@ -10,16 +13,41 @@ module Haddock.Syb
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)
+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)
+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.
--
@@ -31,8 +59,7 @@ everythingWithState :: s -> (r -> r -> r)
-> (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)
-
+ in foldl' k r (gmapQ (everythingWithState s' k f) x)
-- | Apply transformation on each level of a tree.
--
@@ -40,6 +67,22 @@ everythingWithState s k f x =
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.
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index cb4a4bcc..3ad90912 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
- -- in module GHC.PlaceHolder
{-# OPTIONS_GHC -fno-warn-orphans #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Types
@@ -101,6 +101,9 @@ data Interface = Interface
-- names of subordinate declarations mapped to their parent declarations.
, ifaceDeclMap :: !(Map Name [LHsDecl GhcRn])
+ -- | Bundled pattern synonym declarations for specific types.
+ , ifaceBundledPatSynMap :: !(Map Name [Name])
+
-- | Documentation of declarations originating from the module (including
-- subordinates).
, ifaceDocMap :: !(DocMap Name)
@@ -156,49 +159,53 @@ type WarningMap = Map Name (Doc Name)
data InstalledInterface = InstalledInterface
{
-- | The module represented by this interface.
- instMod :: Module
+ instMod :: Module
-- | Is this a signature?
- , instIsSig :: Bool
+ , instIsSig :: Bool
-- | Textual information about the module.
- , instInfo :: HaddockModInfo Name
+ , instInfo :: HaddockModInfo Name
-- | Documentation of declarations originating from the module (including
-- subordinates).
- , instDocMap :: DocMap Name
+ , instDocMap :: DocMap Name
- , instArgMap :: ArgMap Name
+ , instArgMap :: ArgMap Name
-- | All names exported by this module.
- , instExports :: [Name]
+ , instExports :: [Name]
-- | All \"visible\" names exported by the module.
-- A visible name is a name that will show up in the documentation of the
-- module.
- , instVisibleExports :: [Name]
+ , instVisibleExports :: [Name]
-- | Haddock options for this module (prune, ignore-exports, etc).
- , instOptions :: [DocOption]
+ , instOptions :: [DocOption]
+
+ , instSubMap :: Map Name [Name]
- , instSubMap :: Map Name [Name]
- , instFixMap :: Map Name Fixity
+ , instBundledPatSynMap :: Map Name [Name]
+
+ , 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
- , instSubMap = ifaceSubMap interface
- , instFixMap = ifaceFixMap interface
+ { instMod = ifaceMod interface
+ , instIsSig = ifaceIsSig interface
+ , instInfo = ifaceInfo interface
+ , instDocMap = ifaceDocMap interface
+ , instArgMap = ifaceArgMap interface
+ , instExports = ifaceExports interface
+ , instVisibleExports = ifaceVisibleExports interface
+ , instOptions = ifaceOptions interface
+ , instSubMap = ifaceSubMap interface
+ , instBundledPatSynMap = ifaceBundledPatSynMap interface
+ , instFixMap = ifaceFixMap interface
}
@@ -215,6 +222,9 @@ data ExportItem name
-- | A declaration.
expItemDecl :: !(LHsDecl name)
+ -- | Bundled patterns for a data type declaration
+ , expItemPats :: ![(HsDecl name, DocForDecl (IdP name))]
+
-- | Maybe a doc comment, and possibly docs for arguments (if this
-- decl is a function or type-synonym).
, expItemMbDoc :: !(DocForDecl (IdP name))
@@ -427,6 +437,8 @@ type LDoc id = Located (Doc id)
type Doc id = DocH (ModuleName, OccName) id
type MDoc id = MetaDoc (ModuleName, OccName) id
+type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a
+
instance (NFData a, NFData mod)
=> NFData (DocH mod a) where
rnf doc = case doc of
@@ -454,7 +466,7 @@ instance (NFData a, NFData mod)
DocExamples a -> a `deepseq` ()
DocHeader a -> a `deepseq` ()
-#if !MIN_VERSION_GLASGOW_HASKELL(8,0,1,1)
+#if !MIN_VERSION_ghc(8,0,2)
-- These were added to GHC itself in 8.0.2
instance NFData Name where rnf x = seq x ()
instance NFData OccName where rnf x = seq x ()
@@ -478,34 +490,6 @@ exampleToString :: Example -> String
exampleToString (Example expression result) =
">>> " ++ expression ++ "\n" ++ unlines result
-
-data DocMarkup id a = Markup
- { markupEmpty :: a
- , markupString :: String -> a
- , markupParagraph :: a -> a
- , markupAppend :: a -> a -> a
- , markupIdentifier :: id -> a
- , markupIdentifierUnchecked :: (ModuleName, OccName) -> a
- , markupModule :: String -> a
- , markupWarning :: a -> a
- , markupEmphasis :: a -> a
- , markupBold :: a -> a
- , markupMonospaced :: a -> a
- , markupUnorderedList :: [a] -> a
- , markupOrderedList :: [a] -> a
- , markupDefList :: [(a,a)] -> a
- , markupCodeBlock :: a -> a
- , markupHyperlink :: Hyperlink -> a
- , markupAName :: String -> a
- , markupPic :: Picture -> a
- , markupMathInline :: String -> a
- , markupMathDisplay :: String -> a
- , markupProperty :: String -> a
- , markupExample :: [Example] -> a
- , markupHeader :: Header a -> a
- }
-
-
data HaddockModInfo name = HaddockModInfo
{ hmi_description :: Maybe (Doc name)
, hmi_copyright :: Maybe String
@@ -589,6 +573,12 @@ makeModuleQual qual aliases mdl =
OptFullQual -> FullQual
OptNoQual -> NoQual
+-- | Whether to hide empty contexts
+-- Since pattern synonyms have two contexts with different semantics, it is
+-- important to all of them, even if one of them is empty.
+data HideEmptyContexts
+ = HideEmptyContexts
+ | ShowEmptyToplevelContexts
-----------------------------------------------------------------------------
-- * Error handling
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index f5c5b743..540774dc 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -37,8 +37,6 @@ module Haddock.Utils (
html_xrefs_ref, html_xrefs_ref',
-- * Doc markup
- markup,
- idMarkup,
mkMeta,
-- * List utilities
@@ -448,71 +446,6 @@ spanWith p xs@(a:as)
| Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs)
| otherwise = ([],xs)
-
------------------------------------------------------------------------------
--- * Put here temporarily
------------------------------------------------------------------------------
-
-
-markup :: DocMarkup id a -> Doc id -> a
-markup m DocEmpty = markupEmpty m
-markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
-markup m (DocString s) = markupString m s
-markup m (DocParagraph d) = markupParagraph m (markup m d)
-markup m (DocIdentifier x) = markupIdentifier m x
-markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x
-markup m (DocModule mod0) = markupModule m mod0
-markup m (DocWarning d) = markupWarning m (markup m d)
-markup m (DocEmphasis d) = markupEmphasis m (markup m d)
-markup m (DocBold d) = markupBold m (markup m d)
-markup m (DocMonospaced d) = markupMonospaced m (markup m d)
-markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
-markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
-markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)
-markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
-markup m (DocHyperlink l) = markupHyperlink m l
-markup m (DocAName ref) = markupAName m ref
-markup m (DocPic img) = markupPic m img
-markup m (DocMathInline mathjax) = markupMathInline m mathjax
-markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax
-markup m (DocProperty p) = markupProperty m p
-markup m (DocExamples e) = markupExample m e
-markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t))
-
-
-markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)
-markupPair m (a,b) = (markup m a, markup m b)
-
-
--- | The identity markup
-idMarkup :: DocMarkup a (Doc a)
-idMarkup = Markup {
- markupEmpty = DocEmpty,
- markupString = DocString,
- markupParagraph = DocParagraph,
- markupAppend = DocAppend,
- markupIdentifier = DocIdentifier,
- markupIdentifierUnchecked = DocIdentifierUnchecked,
- markupModule = DocModule,
- markupWarning = DocWarning,
- markupEmphasis = DocEmphasis,
- markupBold = DocBold,
- markupMonospaced = DocMonospaced,
- markupUnorderedList = DocUnorderedList,
- markupOrderedList = DocOrderedList,
- markupDefList = DocDefList,
- markupCodeBlock = DocCodeBlock,
- markupHyperlink = DocHyperlink,
- markupAName = DocAName,
- markupPic = DocPic,
- markupMathInline = DocMathInline,
- markupMathDisplay = DocMathDisplay,
- markupProperty = DocProperty,
- markupExample = DocExamples,
- markupHeader = DocHeader
- }
-
-
-----------------------------------------------------------------------------
-- * System tools
-----------------------------------------------------------------------------