aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--haddock-api/haddock-api.cabal2
-rw-r--r--haddock-api/resources/html/Ocean.std-theme/ocean.css5
-rw-r--r--haddock-api/src/Haddock.hs24
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs13
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs12
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs12
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs3
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs26
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs32
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs48
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Names.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs9
-rw-r--r--haddock-api/src/Haddock/Convert.hs50
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs2
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs13
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs204
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs3
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs61
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs21
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs12
-rw-r--r--haddock-api/src/Haddock/Types.hs21
-rw-r--r--haddock-api/src/Haddock/Utils.hs4
-rw-r--r--haddock-library/haddock-library.cabal2
-rw-r--r--haddock-test/src/Test/Haddock/Config.hs2
-rw-r--r--haddock.cabal6
25 files changed, 391 insertions, 198 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 8fe4c3b1..620fd981 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -37,7 +37,7 @@ library
Haskell2010
build-depends:
- base >= 4.3 && < 4.10
+ base >= 4.3 && < 4.11
, bytestring
, filepath
, directory
diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css
index e8e4d705..29af691b 100644
--- a/haddock-api/resources/html/Ocean.std-theme/ocean.css
+++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css
@@ -88,6 +88,11 @@ pre, code, kbd, samp, tt, .src {
font-size: 182%; /* 24pt */
}
+#module-header .caption sup {
+ font-size: 70%;
+ font-weight: normal;
+}
+
.info {
font-size: 85%; /* 11pt */
}
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 28974d19..bbaea359 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -68,7 +68,6 @@ import System.Directory (doesDirectoryExist)
import GHC hiding (verbosity)
import Config
import DynFlags hiding (projectVersion, verbosity)
-import StaticFlags (discardStaticFlags)
import Packages
import Panic (handleGhcException)
import Module
@@ -410,18 +409,9 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
parseGhcFlags dynflags = do
-- TODO: handle warnings?
- -- NOTA BENE: We _MUST_ discard any static flags here, because we cannot
- -- rely on Haddock to parse them, as it only parses the DynFlags. Yet if
- -- we pass any, Haddock will fail. Since StaticFlags are global to the
- -- GHC invocation, there's also no way to reparse/save them to set them
- -- again properly.
- --
- -- This is a bit of a hack until we get rid of the rest of the remaining
- -- StaticFlags. See GHC issue #8276.
- let flags' = discardStaticFlags flags
- (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags')
+ (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags)
if not (null rest)
- then throwE ("Couldn't parse GHC options: " ++ unwords flags')
+ then throwE ("Couldn't parse GHC options: " ++ unwords flags)
else return dynflags'
-------------------------------------------------------------------------------
@@ -576,7 +566,15 @@ getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
_ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf
| otherwise -> try_size (size * 2)
-foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+# if defined(i386_HOST_ARCH)
+# define WINDOWS_CCONV stdcall
+# elif defined(x86_64_HOST_ARCH)
+# define WINDOWS_CCONV ccall
+# else
+# error Unknown mingw32 arch
+# endif
+
+foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
getExecDir = return Nothing
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 9a15c7b3..86a73c33 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.Hoogle
@@ -15,7 +16,7 @@ module Haddock.Backends.Hoogle (
ppHoogle
) where
-import BasicTypes (OverlapFlag(..), OverlapMode(..))
+import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..))
import InstEnv (ClsInst(..))
import Haddock.GhcUtils
import Haddock.Types hiding (Version)
@@ -84,7 +85,8 @@ dropHsDocTy = f
f (HsDocTy a _) = f $ unL a
f x = x
-outHsType :: OutputableBndr a => DynFlags -> HsType a -> String
+outHsType :: (OutputableBndrId a)
+ => DynFlags -> HsType a -> String
outHsType dflags = out dflags . dropHsDocTy
@@ -180,6 +182,7 @@ ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMet
tyFamEqnToSyn tfe = SynDecl
{ tcdLName = tfe_tycon tfe
, tcdTyVars = tfe_pats tfe
+ , tcdFixity = tfe_fixity tfe
, tcdRhs = tfe_rhs tfe
, tcdFVs = emptyNameSet
}
@@ -194,7 +197,7 @@ ppInstance dflags x =
-- safety information to a state where the Outputable instance
-- produces no output which means no overlap and unsafe (or [safe]
-- is generated).
- cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap mempty
+ cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText
, isSafeOverlap = False } }
ppSynonym :: DynFlags -> TyClDecl Name -> [String]
@@ -202,7 +205,7 @@ ppSynonym dflags x = [out dflags x]
ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
- = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} :
+ = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} :
concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)
where
@@ -242,7 +245,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
-- docs for con_names on why it is a list to begin with.
name = commaSeparate dflags . map unL $ getConNames con
- resType = apps $ map (reL . HsTyVar . reL) $
+ resType = apps $ map (reL . HsTyVar NotPromoted . reL) $
(tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat]
ppCtor dflags _dat subdocs con@ConDeclGADT {}
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index be17cb8b..b97f0ead 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -72,7 +72,7 @@ types =
everything (<|>) ty
where
ty term = case cast term of
- (Just (GHC.L sspan (GHC.HsTyVar name))) ->
+ (Just (GHC.L sspan (GHC.HsTyVar _ name))) ->
pure (sspan, RtkType (GHC.unLoc name))
_ -> empty
@@ -118,7 +118,7 @@ decls (group, _, _, _) = concatMap ($ group)
where
typ (GHC.L _ t) = case t of
GHC.DataDecl { tcdLName = name } -> pure . decl $ name
- GHC.SynDecl name _ _ _ -> pure . decl $ name
+ GHC.SynDecl name _ _ _ _ -> pure . decl $ name
GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
fun term = case cast term of
@@ -152,11 +152,11 @@ imports src@(_, imps, _, _) =
everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps
where
ie term = case cast term of
- (Just (GHC.IEVar v)) -> pure $ var v
- (Just (GHC.IEThingAbs t)) -> pure $ typ t
- (Just (GHC.IEThingAll t)) -> pure $ typ t
+ (Just (GHC.IEVar v)) -> pure $ var $ GHC.ieLWrappedName v
+ (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t
+ (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t
(Just (GHC.IEThingWith t _ vs _fls)) ->
- [typ t] ++ map var vs
+ [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs
_ -> empty
typ (GHC.L sspan name) = (sspan, RtkType name)
var (GHC.L sspan name) = (sspan, RtkVar name)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index e206413e..e4345602 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -31,12 +31,20 @@ chunk str@(c:_)
chunk str
| "--" `isPrefixOf` str = chunk' $ spanToNewline str
| "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str
- | otherwise = case lex str of
+ | otherwise = case lex' str of
(tok:_) -> chunk' tok
[] -> [str]
where
chunk' (c, rest) = c:(chunk rest)
+-- | A bit better lexer then the default, i.e. handles DataKinds quotes
+lex' :: ReadS String
+lex' ('\'' : '\'' : rest) = [("''", rest)]
+lex' str@('\'' : '\\' : _ : '\'' : _) = lex str
+lex' str@('\'' : _ : '\'' : _) = lex str
+lex' ('\'' : rest) = [("'", rest)]
+lex' str = lex str
+
-- | Split input to "first line" string and the rest of it.
--
-- Ideally, this should be done simply with @'break' (== '\n')@. However,
@@ -124,6 +132,8 @@ classify str
| "--" `isPrefixOf` str = TkComment
| "{-#" `isPrefixOf` str = TkPragma
| "{-" `isPrefixOf` str = TkComment
+classify "''" = TkSpecial
+classify "'" = TkSpecial
classify str@(c:_)
| isSpace c = TkSpace
| isDigit c = TkNumber
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index 5f4dbc8c..b27ec4d8 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -12,16 +12,19 @@ data Token = Token
, tkValue :: String
, tkSpan :: Span
}
+ deriving (Show)
data Position = Position
{ posRow :: !Int
, posCol :: !Int
}
+ deriving (Show)
data Span = Span
{ spStart :: Position
, spEnd :: Position
}
+ deriving (Show)
data TokenType
= TkIdentifier
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 81a23a1b..53cfccff 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -251,7 +251,7 @@ declNames :: LHsDecl DocName -> [DocName]
declNames (L _ decl) = case decl of
TyClD d -> [tcdName d]
SigD (TypeSig lnames _ ) -> map unLoc lnames
- SigD (PatSynSig lname _) -> [unLoc lname]
+ SigD (PatSynSig lnames _) -> map unLoc lnames
ForD (ForeignImport (L _ n) _ _ _) -> [n]
ForD (ForeignExport (L _ n) _ _ _) -> [n]
_ -> error "declaration not supported by declNames"
@@ -296,10 +296,11 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode
SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames)
(hsSigWcType t) unicode
- SigD (PatSynSig lname ty) ->
- ppLPatSig loc (doc, fnArgsDoc) lname ty unicode
+ SigD (PatSynSig lnames ty) ->
+ ppLPatSig loc (doc, fnArgsDoc) (map unLoc lnames) ty unicode
ForD d -> ppFor loc (doc, fnArgsDoc) d unicode
InstD _ -> empty
+ DerivD _ -> empty
_ -> error "declaration not supported by ppDecl"
where
unicode = False
@@ -354,14 +355,14 @@ ppFunSig loc doc docnames (L _ typ) unicode =
where
names = map getName docnames
-ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName
+ppLPatSig :: SrcSpan -> DocForDecl DocName -> [DocName]
-> LHsSigType DocName
-> Bool -> LaTeX
-ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode
+ppLPatSig _loc (doc, _argDocs) docnames ty unicode
= declWithDoc pref1 (documentationToLaTeX doc)
where
pref1 = hsep [ keyword "pattern"
- , ppDocBinder name
+ , hsep $ punctuate comma $ map ppDocBinder docnames
, dcolon unicode
, ppLType unicode (hsSigType ty)
]
@@ -884,6 +885,10 @@ tupleParens HsUnboxedTuple = ubxParenList
tupleParens _ = parenList
+sumParens :: [LaTeX] -> LaTeX
+sumParens = ubxparens . hsep . punctuate (text " | ")
+
+
-------------------------------------------------------------------------------
-- * Rendering of HsType
--
@@ -944,17 +949,20 @@ ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode
, ppr_mono_lty pREC_TOP ty unicode ]
ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty
-ppr_mono_ty _ (HsTyVar (L _ name)) _ = ppDocName name
+ppr_mono_ty _ (HsTyVar NotPromoted (L _ name)) _ = ppDocName name
+ppr_mono_ty _ (HsTyVar Promoted (L _ name)) _ = char '\'' <> ppDocName name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u
ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)
+ppr_mono_ty _ (HsSumTy tys) u = sumParens (map (ppLType u) tys)
ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _ (HsIParamTy (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 0958c2cd..7b5f9017 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -43,10 +43,11 @@ import System.Directory
import Data.Map ( Map )
import qualified Data.Map as Map hiding ( Map )
import qualified Data.Set as Set hiding ( Set )
+import Data.Function
import Data.Ord ( comparing )
import DynFlags (Language(..))
-import GHC hiding ( NoLink, moduleInfo )
+import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) )
import Name
import Module
@@ -263,13 +264,20 @@ ppHtmlContents dflags odir doctitle _maybe_package
themes mathjax_url maybe_index_url
maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do
let tree = mkModuleTree dflags showPkgs
- [(instMod iface, toInstalledDescription iface) | iface <- ifaces]
+ [(instMod iface, toInstalledDescription iface)
+ | iface <- ifaces
+ , not (instIsSig iface)]
+ sig_tree = mkModuleTree dflags showPkgs
+ [(instMod iface, toInstalledDescription iface)
+ | iface <- ifaces
+ , instIsSig iface]
html =
headHtml doctitle Nothing themes mathjax_url +++
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
Nothing maybe_index_url << [
ppPrologue qual doctitle prologue,
+ ppSignatureTree qual sig_tree,
ppModuleTree qual tree
]
createDirectoryIfMissing True odir
@@ -282,7 +290,13 @@ ppPrologue qual title (Just doc) =
divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc))
+ppSignatureTree :: Qualification -> [ModuleTree] -> Html
+ppSignatureTree qual ts =
+ divModuleList << (sectionName << "Signatures" +++ mkNodeList qual [] "n" ts)
+
+
ppModuleTree :: Qualification -> [ModuleTree] -> Html
+ppModuleTree _ [] = mempty
ppModuleTree qual ts =
divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts)
@@ -469,13 +483,20 @@ ppHtmlModule odir doctitle themes
mdl = ifaceMod iface
aliases = ifaceModuleAliases iface
mdl_str = moduleString mdl
+ mdl_str_annot = mdl_str ++ if ifaceIsSig iface
+ then " (signature)"
+ else ""
+ mdl_str_linked = mdl_str +++
+ " (signature" +++
+ sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) +++
+ ")"
real_qual = makeModuleQual qual aliases mdl
html =
- headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++
+ headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++
bodyHtml doctitle (Just iface)
maybe_source_url maybe_wiki_url
maybe_contents_url maybe_index_url << [
- divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),
+ divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)),
ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual
]
@@ -483,6 +504,9 @@ ppHtmlModule odir doctitle themes
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
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index fab6bf8d..2aec5272 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -34,7 +34,7 @@ import qualified Data.Map as Map
import Data.Maybe
import Text.XHtml hiding ( name, title, p, quote )
-import GHC
+import GHC hiding (LexicalFixity(..))
import GHC.Exts
import Name
import BooleanFormula
@@ -44,17 +44,18 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
-> DocForDecl DocName -> [DocInstance DocName] -> [(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
- 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@(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
+ 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@(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
(hsSigWcType lty) fixities splice unicode qual
- SigD (PatSynSig lname ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname
+ SigD (PatSynSig lnames ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
ty fixities splice unicode qual
- ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
- InstD _ -> noHtml
- _ -> error "declaration not supported by ppDecl"
+ ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
+ InstD _ -> noHtml
+ DerivD _ -> noHtml
+ _ -> error "declaration not supported by ppDecl"
ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
@@ -74,22 +75,20 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
pp_typ = ppLType unicode qual typ
ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- Located DocName -> LHsSigType DocName ->
+ [Located DocName] -> LHsSigType DocName ->
[(DocName, Fixity)] ->
Splice -> Unicode -> Qualification -> Html
-ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual
+ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode qual
| summary = pref1
- | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual)
+ | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual)
+++ docSection Nothing qual doc
where
pref1 = hsep [ keyword "pattern"
- , ppBinder summary occname
+ , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames
, dcolon unicode
, ppLType unicode qual (hsSigType typ)
]
- occname = nameOccName . getName $ name
-
ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
[DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->
Splice -> Unicode -> Qualification -> Html
@@ -645,10 +644,8 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
ppInstanceSigs links splice unicode qual sigs = do
TypeSig lnames typ <- sigs
let names = map unLoc lnames
- L loc rtyp = get_type typ
+ L loc rtyp = hsSigWcType typ
return $ ppSimpleSig links splice unicode qual loc names rtyp
- where
- get_type = hswc_body . hsib_body
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
@@ -916,6 +913,9 @@ tupleParens HsUnboxedTuple = ubxParenList
tupleParens _ = parenList
+sumParens :: [Html] -> Html
+sumParens = ubxSumList
+
--------------------------------------------------------------------------------
-- * Rendering of HsType
--------------------------------------------------------------------------------
@@ -984,19 +984,20 @@ ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual
ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual
-- 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 _ (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 n 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 "{..}"
@@ -1004,7 +1005,8 @@ ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}"
-- placeholder in the signature, which is followed by the field
-- declarations.
ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
+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"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index 5492178b..a84a55e8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -26,7 +26,7 @@ import Text.XHtml hiding ( name, title, p, quote )
import qualified Data.Map as M
import qualified Data.List as List
-import GHC
+import GHC hiding (LexicalFixity(..))
import Name
import RdrName
import FastString (unpackFS)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index 1d49807d..a8b4a4ec 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -20,7 +20,7 @@ module Haddock.Backends.Xhtml.Utils (
(<+>), (<=>), char,
keyword, punctuate,
- braces, brackets, pabrackets, parens, parenList, ubxParenList,
+ braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList,
arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,
hsep, vcat,
@@ -75,8 +75,7 @@ spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run
case span_ of
RealSrcSpan span__ ->
show $ srcSpanStartLine span__
- UnhelpfulSpan _ ->
- error "spliceURL UnhelpfulSpan"
+ UnhelpfulSpan _ -> ""
run "" = ""
run ('%':'M':rest) = mdl ++ run rest
@@ -178,6 +177,10 @@ ubxParenList :: [Html] -> Html
ubxParenList = ubxparens . hsep . punctuate comma
+ubxSumList :: [Html] -> Html
+ubxSumList = ubxparens . hsep . punctuate (toHtml " | ")
+
+
ubxparens :: Html -> Html
ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 7de840ee..01261477 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -18,7 +18,7 @@ module Haddock.Convert where
-- instance heads, which aren't TyThings, so just export everything.
import Bag ( emptyBag )
-import BasicTypes ( TupleSort(..) )
+import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..) )
import Class
import CoAxiom
import ConLike
@@ -35,10 +35,10 @@ import TcType ( tcSplitSigmaTy )
import TyCon
import Type
import TyCoRep
-import TysPrim ( alphaTyVars, unliftedTypeKindTyConName )
+import TysPrim ( alphaTyVars )
import TysWiredIn ( listTyConName, starKindTyConName, unitTy )
import PrelNames ( hasKey, eqTyConKey, ipClassKey
- , tYPETyConKey, ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey )
+ , tYPETyConKey, liftedRepDataConKey )
import Unique ( getUnique )
import Util ( filterByList, filterOut )
import Var
@@ -78,10 +78,11 @@ tyThingToLHsDecl t = case t of
{ tcdCtxt = synifyCtx (classSCTheta cl)
, tcdLName = synifyName cl
, tcdTyVars = synifyTyVars (classTyVars cl)
+ , tcdFixity = Prefix
, tcdFDs = map (\ (l,r) -> noLoc
(map (noLoc . getName) l, map (noLoc . getName) r) ) $
snd $ classTvsFds cl
- , tcdSigs = noLoc (MinimalSig mempty . noLoc . fmap noLoc $ classMinimalDef cl) :
+ , tcdSigs = noLoc (MinimalSig NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) :
map (noLoc . synifyTcIdSig DeleteTopLevelQuantification)
(classMethods cl)
, tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
@@ -102,7 +103,7 @@ tyThingToLHsDecl t = case t of
(synifySigWcType ImplicitizeForAll (dataConUserType dc)))
AConLike (PatSynCon ps) ->
- allOK . SigD $ PatSynSig (synifyName ps) (synifyPatSynSigType ps)
+ allOK . SigD $ PatSynSig [synifyName ps] (synifyPatSynSigType ps)
where
withErrs e x = return (e, x)
allOK x = return (mempty, x)
@@ -114,7 +115,9 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
hs_rhs = synifyType WithinType rhs
in TyFamEqn { tfe_tycon = name
, tfe_pats = HsIB { hsib_body = typats
- , hsib_vars = map tyVarName tkvs }
+ , hsib_vars = map tyVarName tkvs
+ , hsib_closed = True }
+ , tfe_fixity = Prefix
, tfe_rhs = hs_rhs }
synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name)
@@ -147,6 +150,8 @@ synifyTyCon _coax tc
alphaTyVars --a, b, c... which are unfortunately all kind *
, hsq_dependent = emptyNameSet }
+ , tcdFixity = Prefix
+
, tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither
-- algebraic data nor newtype:
, dd_ctxt = noLoc []
@@ -154,7 +159,7 @@ synifyTyCon _coax tc
, dd_kindSig = Just (synifyKindSig (tyConKind tc))
-- we have their kind accurately:
, dd_cons = [] -- No constructors
- , dd_derivs = Nothing }
+ , dd_derivs = noLoc [] }
, tcdDataCusk = False
, tcdFVs = placeHolderNamesTc }
@@ -181,6 +186,7 @@ synifyTyCon _coax tc
FamilyDecl { fdInfo = i
, fdLName = synifyName tc
, fdTyVars = synifyTyVars (tyConTyVars tc)
+ , fdFixity = Prefix
, fdResultSig =
synifyFamilyResultSig resultVar (tyConResKind tc)
, fdInjectivityAnn =
@@ -192,6 +198,7 @@ synifyTyCon coax tc
| Just ty <- synTyConRhs_maybe tc
= return $ SynDecl { tcdLName = synifyName tc
, tcdTyVars = synifyTyVars (tyConTyVars tc)
+ , tcdFixity = Prefix
, tcdRhs = synifyType WithinType ty
, tcdFVs = placeHolderNamesTc }
| otherwise =
@@ -225,7 +232,7 @@ synifyTyCon coax tc
consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)
cons = rights consRaw
-- "deriving" doesn't affect the signature, no need to specify any.
- alg_deriv = Nothing
+ alg_deriv = noLoc []
defn = HsDataDefn { dd_ND = alg_nd
, dd_ctxt = alg_ctx
, dd_cType = Nothing
@@ -234,7 +241,8 @@ synifyTyCon coax tc
, dd_derivs = alg_deriv }
in case lefts consRaw of
[] -> return $
- DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn
+ DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix
+ , tcdDataDefn = defn
, tcdDataCusk = False, tcdFVs = placeHolderNamesTc }
dataConErrs -> Left $ unlines dataConErrs
@@ -294,7 +302,7 @@ synifyDataCon use_gadt_syntax dc =
(False,True) -> case linear_tys of
[a,b] -> return $ InfixCon a b
_ -> Left "synifyDataCon: infix with non-2 args?"
- gadt_ty = HsIB [] (synifyType WithinType res_ty)
+ gadt_ty = HsIB [] (synifyType WithinType res_ty) False
-- finally we get synifyDataCon's result!
in hs_arg_tys >>=
\hat ->
@@ -360,24 +368,20 @@ synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty)
synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name
-- Ditto (see synifySigType)
-synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty))
+synifySigWcType s ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s ty))
synifyPatSynSigType :: PatSyn -> LHsSigType Name
-- Ditto (see synifySigType)
synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)
synifyType :: SynifyTypeState -> Type -> LHsType Name
-synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv)
+synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv)
synifyType _ (TyConApp tc tys)
-- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)
| tc `hasKey` tYPETyConKey
, [TyConApp lev []] <- tys
- , lev `hasKey` ptrRepLiftedDataConKey
- = noLoc (HsTyVar (noLoc starKindTyConName))
- | tc `hasKey` tYPETyConKey
- , [TyConApp lev []] <- tys
- , lev `hasKey` ptrRepUnliftedDataConKey
- = noLoc (HsTyVar (noLoc unliftedTypeKindTyConName))
+ , lev `hasKey` liftedRepDataConKey
+ = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName))
-- Use non-prefix tuple syntax where possible, because it looks nicer.
| Just sort <- tyConTuple_maybe tc
, tyConArity tc == length tys
@@ -393,7 +397,7 @@ synifyType _ (TyConApp tc tys)
| tc `hasKey` ipClassKey
, [name, ty] <- tys
, Just x <- isStrLitTy name
- = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty)
+ = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty)
-- and equalities
| tc `hasKey` eqTyConKey
, [ty1, ty2] <- tys
@@ -401,7 +405,7 @@ synifyType _ (TyConApp tc tys)
-- Most TyCons:
| otherwise =
foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
- (noLoc $ HsTyVar $ noLoc (getName tc))
+ (noLoc $ HsTyVar NotPromoted $ noLoc (getName tc))
(map (synifyType WithinType) $
filterOut isCoercionTy tys)
synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1
@@ -409,7 +413,7 @@ synifyType _ (AppTy t1 t2) = let
s1 = synifyType WithinType t1
s2 = synifyType WithinType t2
in noLoc $ HsAppTy s1 s2
-synifyType _ (ForAllTy (Anon t1) t2) = let
+synifyType _ (FunTy t1 t2) = let
s1 = synifyType WithinType t1
s2 = synifyType WithinType t2
in noLoc $ HsFunTy s1 s2
@@ -444,8 +448,8 @@ synifyPatSynType ps = let
in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau
synifyTyLit :: TyLit -> HsTyLit
-synifyTyLit (NumTyLit n) = HsNumTy mempty n
-synifyTyLit (StrTyLit s) = HsStrTy mempty s
+synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n
+synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s
synifyKindSig :: Kind -> LHsKind Name
synifyKindSig k = synifyType WithinType k
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 3933f8e7..c8e5ea8b 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -104,7 +104,7 @@ sigName (L _ sig) = sigNameNoLoc sig
sigNameNoLoc :: Sig name -> [name]
sigNameNoLoc (TypeSig ns _) = map unLoc ns
sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns
-sigNameNoLoc (PatSynSig n _) = [unLoc n]
+sigNameNoLoc (PatSynSig ns _) = map unLoc ns
sigNameNoLoc (SpecSig n _ _) = [unLoc n]
sigNameNoLoc (InlineSig n _) = [unLoc n]
sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index f00da3ea..d5d74819 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -169,15 +169,15 @@ instHead (_, _, cls, args)
= (map argCount args, className cls, map simplify args)
argCount :: Type -> Int
-argCount (AppTy t _) = argCount t + 1
+argCount (AppTy t _) = argCount t + 1
argCount (TyConApp _ ts) = length ts
-argCount (ForAllTy (Anon _) _ ) = 2
-argCount (ForAllTy _ t) = argCount t
-argCount (CastTy t _) = argCount t
+argCount (FunTy _ _ ) = 2
+argCount (ForAllTy _ t) = argCount t
+argCount (CastTy t _) = argCount t
argCount _ = 0
simplify :: Type -> SimpleType
-simplify (ForAllTy (Anon t1) t2) = SimpleType funTyConName [simplify t1, simplify t2]
+simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]
simplify (ForAllTy _ t) = simplify t
simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2))
where (SimpleType s ts) = simplify t1
@@ -239,8 +239,9 @@ isTypeHidden expInfo = typeHidden
case t of
TyVarTy {} -> False
AppTy t1 t2 -> typeHidden t1 || typeHidden t2
+ FunTy t1 t2 -> typeHidden t1 || typeHidden t2
TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args
- ForAllTy bndr ty -> typeHidden (binderType bndr) || typeHidden ty
+ ForAllTy bndr ty -> typeHidden (tyVarKind (binderVar bndr)) || typeHidden ty
LitTy _ -> False
CastTy ty _ -> typeHidden ty
CoercionTy {} -> False
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index cb855693..e594feae 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -11,6 +11,10 @@
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
+--
+-- This module provides a single function 'createInterface',
+-- which creates a Haddock 'Interface' from the typechecking
+-- results 'TypecheckedModule' from GHC.
-----------------------------------------------------------------------------
module Haddock.Interface.Create (createInterface) where
@@ -47,14 +51,18 @@ import Bag
import RdrName
import TcRnTypes
import FastString (concatFS)
-import BasicTypes ( StringLiteral(..) )
+import BasicTypes ( StringLiteral(..), SourceText(..) )
import qualified Outputable as O
import HsDecls ( getConDetails )
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
-- To do this, we need access to already processed modules in the topological
-- sort. That's what's in the 'IfaceMap'.
-createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface
+createInterface :: TypecheckedModule
+ -> [Flag] -- Boolean flags
+ -> IfaceMap -- Locally processed modules
+ -> InstIfaceMap -- External, already installed interfaces
+ -> ErrMsgGhc Interface
createInterface tm flags modMap instIfaceMap = do
let ms = pm_mod_summary . tm_parsed_module $ tm
@@ -62,6 +70,8 @@ createInterface tm flags modMap instIfaceMap = do
L _ hsm = parsedSource tm
!safety = modInfoSafe mi
mdl = ms_mod ms
+ sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm))
+ is_sig = ms_hsc_src ms == HsigFile
dflags = ms_hspp_opts ms
!instances = modInfoInstances mi
!fam_instances = md_fam_insts md
@@ -83,13 +93,15 @@ createInterface tm flags modMap instIfaceMap = do
| Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
| otherwise = opts0
+ -- Process the top-level module header documentation.
(!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
let declsWithDocs = topDecls group_
fixMap = mkFixMap group_
(decls, _) = unzip declsWithDocs
- localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances
- ++ map getName fam_instances
+ localInsts = filter (nameIsLocalOrFrom sem_mdl)
+ $ map getName instances
+ ++ map getName fam_instances
-- Locations of all TH splices
splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
@@ -104,7 +116,9 @@ createInterface tm flags modMap instIfaceMap = do
let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
- exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls
+ -- 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
let !visibleNames = mkVisibleNames maps exportItems opts
@@ -130,6 +144,7 @@ createInterface tm flags modMap instIfaceMap = do
return $! Interface {
ifaceMod = mdl
+ , ifaceIsSig = is_sig
, ifaceOrigFilename = msHsFilePath ms
, ifaceInfo = info
, ifaceDoc = Documentation mbDoc modWarn
@@ -156,6 +171,10 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceTokenizedSrc = tokenizedSrc
}
+-- | Given all of the @import M as N@ declarations in a package,
+-- create a mapping from the module identity of M, to an alias N
+-- (if there are multiple aliases, we pick the last one.) This
+-- will go in 'ifaceModuleAliases'.
mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
mkAliasMap dflags mRenamedSource =
case mRenamedSource of
@@ -163,16 +182,31 @@ mkAliasMap dflags mRenamedSource =
Just (_,impDecls,_,_) ->
M.fromList $
mapMaybe (\(SrcLoc.L _ impDecl) -> do
- alias <- ideclAs impDecl
+ SrcLoc.L _ alias <- ideclAs impDecl
return $
(lookupModuleDyn dflags
+ -- TODO: This is supremely dodgy, because in general the
+ -- UnitId isn't going to look anything like the package
+ -- qualifier (even with old versions of GHC, the
+ -- IPID would be p-0.1, but a package qualifier never
+ -- has a version number it. (Is it possible that in
+ -- Haddock-land, the UnitIds never have version numbers?
+ -- I, ezyang, have not quite understand Haddock's package
+ -- identifier model.)
+ --
+ -- Additionally, this is simulating some logic GHC already
+ -- has for deciding how to qualify names when it outputs
+ -- them to the user. We should reuse that information;
+ -- or at least reuse the renamed imports, which know what
+ -- they import!
(fmap Module.fsToUnitId $
fmap sl_fs $ ideclPkgQual impDecl)
(case ideclName impDecl of SrcLoc.L _ name -> name),
alias))
impDecls
--- similar to GHC.lookupModule
+-- Similar to GHC.lookupModule
+-- ezyang: Not really...
lookupModuleDyn ::
DynFlags -> Maybe UnitId -> ModuleName -> Module
lookupModuleDyn _ (Just pkgId) mdlName =
@@ -305,16 +339,16 @@ mkMaps dflags gre instances decls =
where loc = case d of
TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs
_ -> getInstLoc d
+ names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
names _ decl = getMainDeclBinder decl
-- Note [2]:
------------
--- We relate ClsInsts to InstDecls using the SrcSpans buried inside them.
--- That should work for normal user-written instances (from looking at GHC
--- sources). We can assume that commented instances are user-written.
--- This lets us relate Names (from ClsInsts) to comments (associated
--- with InstDecls).
-
+-- We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried
+-- inside them. That should work for normal user-written instances (from
+-- looking at GHC sources). We can assume that commented instances are
+-- user-written. This lets us relate Names (from ClsInsts) to comments
+-- (associated with InstDecls and DerivDecls).
--------------------------------------------------------------------------------
-- Declarations
@@ -322,6 +356,8 @@ 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 Name -> [(Name, [HsDocString], Map Int HsDocString)]
subordinates instMap decl = case decl of
InstD (ClsInstD d) -> do
@@ -338,7 +374,7 @@ subordinates instMap decl = case decl of
, name <- getMainDeclBinder d, not (isValD d)
]
dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)]
- dataSubs dd = constrs ++ fields
+ dataSubs dd = constrs ++ fields ++ derivs
where
cons = map unL $ (dd_cons dd)
constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)
@@ -347,6 +383,11 @@ subordinates instMap decl = case decl of
| RecCon flds <- map getConDetails cons
, L _ (ConDeclField ns _ doc) <- (unLoc flds)
, L _ n <- ns ]
+ derivs = [ (instName, [unL doc], M.empty)
+ | HsIB { hsib_body = L l (HsDocTy _ doc) }
+ <- concatMap (unLoc . deriv_clause_tys . unLoc) $
+ unLoc $ dd_derivs dd
+ , Just instName <- [M.lookup l instMap] ]
-- | Extract function argument docs from inside types.
typeDocs :: HsDecl Name -> Map Int HsDocString
@@ -394,12 +435,12 @@ mkFixMap group_ = M.fromList [ (n,f)
-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
ungroup :: HsGroup Name -> [LHsDecl Name]
ungroup group_ =
- mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++
+ mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++
mkDecls hs_derivds DerivD group_ ++
mkDecls hs_defds DefD group_ ++
mkDecls hs_fords ForD group_ ++
mkDecls hs_docs DocD group_ ++
- mkDecls hs_instds InstD group_ ++
+ mkDecls (tyClGroupInstDecls . hs_tyclds) InstD group_ ++
mkDecls (typesigs . hs_valds) SigD group_ ++
mkDecls (valbinds . hs_valds) ValD group_
where
@@ -433,8 +474,9 @@ filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
filterDecls = filter (isHandled . unL . fst)
where
isHandled (ForD (ForeignImport {})) = True
- isHandled (TyClD {}) = True
- isHandled (InstD {}) = True
+ isHandled (TyClD {}) = True
+ isHandled (InstD {}) = True
+ isHandled (DerivD {}) = True
isHandled (SigD d) = isUserLSig (reL d)
isHandled (ValD _) = True
-- we keep doc declarations to be able to get at named docs
@@ -484,12 +526,14 @@ collectDocs = go Nothing []
-- We create the export items even if the module is hidden, since they
-- might be useful when creating the export items for other modules.
mkExportItems
- :: IfaceMap
+ :: Bool -- is it a signature
+ -> IfaceMap
-> Module -- this module
+ -> Module -- semantic module
-> WarningMap
-> GlobalRdrEnv
-> [Name] -- exported names (orig)
- -> [LHsDecl Name]
+ -> [LHsDecl Name] -- renamed source declarations
-> Maps
-> FixMap
-> [SrcSpan] -- splice locations
@@ -498,17 +542,22 @@ mkExportItems
-> DynFlags
-> ErrMsgGhc [ExportItem Name]
mkExportItems
- modMap thisMod warnings gre exportedNames decls
+ is_sig modMap thisMod semMod warnings gre exportedNames decls
maps@(docMap, argMap, subMap, declMap, instMap) 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 x
- lookupExport (IEThingAbs (L _ t)) = declWith t
- lookupExport (IEThingAll (L _ t)) = declWith t
- lookupExport (IEThingWith (L _ t) _ _ _) = declWith t
+ 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 (IEModuleContents (L _ m)) =
+ -- TODO: We could get more accurate reporting here if IEModuleContents
+ -- also recorded the actual names that are exported here. We CAN
+ -- compute this info using @gre@ but 'moduleExports does not seem to
+ -- 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
@@ -522,8 +571,9 @@ mkExportItems
Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
- declWith t =
- case findDecl t of
+ declWith t = do
+ r <- findDecl t
+ case r of
([L l (ValD _)], (doc, _)) -> do
-- Top-level binding without type signature
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
@@ -562,7 +612,7 @@ mkExportItems
L loc (TyClD cl@ClassDecl{}) -> do
mdef <- liftGhcToErrMsgGhc $ minimalDef t
- let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef
+ let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef
return [ mkExportDecl t
(L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]
@@ -576,6 +626,8 @@ mkExportItems
Just decl ->
-- We try to get the subs and docs
-- from the installed .haddock file for that package.
+ -- TODO: This needs to be more sophisticated to deal
+ -- with signature inheritance
case M.lookup (nameModule t) instIfaceMap of
Nothing -> do
liftErrMsg $ tell
@@ -591,8 +643,7 @@ mkExportItems
mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
mkExportDecl name decl (doc, subs) = decl'
where
- decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False
- mdl = nameModule name
+ decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False
subs' = filter (isExported . fst) subs
sub_names = map fst subs'
fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]
@@ -601,16 +652,41 @@ mkExportItems
isExported = (`elem` exportedNames)
- findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
+ findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
findDecl n
- | m == thisMod, Just ds <- M.lookup n declMap =
- (ds, lookupDocs n warnings docMap argMap subMap)
- | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
- (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
- | otherwise = ([], (noDocForDecl, []))
+ | m == semMod =
+ case M.lookup n declMap of
+ Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap)
+ Nothing
+ | is_sig -> do
+ -- OK, so it wasn't in the local declaration map. It could
+ -- have been inherited from a signature. Reconstitute it
+ -- from the type.
+ mb_r <- hiDecl dflags n
+ case mb_r of
+ Nothing -> return ([], (noDocForDecl, []))
+ -- TODO: If we try harder, we might be able to find
+ -- a Haddock! Look in the Haddocks for each thing in
+ -- requirementContext (pkgState)
+ Just decl -> return ([decl], (noDocForDecl, []))
+ | otherwise ->
+ return ([], (noDocForDecl, []))
+ | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap
+ , Just ds <- M.lookup n (ifaceDeclMap iface) =
+ return (ds, lookupDocs n warnings
+ (ifaceDocMap iface)
+ (ifaceArgMap iface)
+ (ifaceSubMap iface))
+ | otherwise = return ([], (noDocForDecl, []))
where
m = nameModule n
+-- | Given a 'Module' from a 'Name', convert it into a 'Module' that
+-- we can actually find in the 'IfaceMap'.
+semToIdMod :: UnitId -> Module -> Module
+semToIdMod this_uid m
+ | Module.isHoleModule m = mkModule this_uid (moduleName m)
+ | otherwise = m
hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
hiDecl dflags t = do
@@ -673,13 +749,13 @@ lookupDocs n warnings docMap argMap subMap =
-- only return those that are.
-- 3) B is visible and all its exports are in scope, in which case we return
-- a single 'ExportModule' item.
-moduleExports :: Module -- ^ Module A
+moduleExports :: Module -- ^ Module A (identity, NOT semantic)
-> ModuleName -- ^ The real name of B, the exported module
-> DynFlags -- ^ The flags used when typechecking A
-> WarningMap
-> GlobalRdrEnv -- ^ The renaming environment used for A
-> [Name] -- ^ All the exports of A
- -> [LHsDecl Name] -- ^ All the declarations in A
+ -> [LHsDecl Name] -- ^ All the renamed declarations in A
-> IfaceMap -- ^ Already created interfaces
-> InstIfaceMap -- ^ Interfaces in other packages
-> Maps
@@ -687,8 +763,11 @@ moduleExports :: Module -- ^ Module A
-> [SrcSpan] -- ^ Locations of all TH splices
-> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices
- | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls
+ | expMod == moduleName thisMod
+ = fullModuleContents dflags warnings gre maps fixMap splices decls
| otherwise =
+ -- NB: we constructed the identity module when looking up in
+ -- the IfaceMap.
case M.lookup m ifaceMap of
Just iface
| OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)
@@ -704,7 +783,7 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
"documentation for exported module: " ++ pretty dflags expMod]
return []
where
- m = mkModule unitId expMod
+ m = mkModule unitId expMod -- Identity module!
unitId = moduleUnitId thisMod
@@ -725,8 +804,17 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa
-- (For more information, see Trac #69)
-fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan]
- -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
+-- | Simplified variant of 'mkExportItems', where we can assume that
+-- every locally defined declaration is exported; thus, we just
+-- zip through the renamed declarations.
+fullModuleContents :: DynFlags
+ -> WarningMap
+ -> GlobalRdrEnv -- ^ The renaming environment
+ -> Maps
+ -> FixMap
+ -> [SrcSpan] -- ^ Locations of all TH splices
+ -> [LHsDecl Name] -- ^ All the renamed declarations
+ -> ErrMsgGhc [ExportItem Name]
fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =
liftM catMaybes $ mapM mkExportItem (expandSig decls)
where
@@ -756,11 +844,13 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
| otherwise = return Nothing
mkExportItem decl@(L l (InstD d))
| Just name <- M.lookup (getInstLoc d) instMap =
- let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
- return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+ expInst decl l name
+ mkExportItem decl@(L l (DerivD {}))
+ | Just name <- M.lookup l instMap =
+ expInst decl l name
mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do
mdef <- liftGhcToErrMsgGhc $ minimalDef name
- let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef
+ let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef
expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name
mkExportItem decl@(L l d)
| name:_ <- getMainDeclBinder d = expDecl decl l name
@@ -772,13 +862,17 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap
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))
+
-- | Sometimes the declaration we want to export is not the "main" declaration:
-- it might be an individual record selector or a class method. In these
-- cases we have to extract the required declaration (and somehow cobble
-- together a type signature for it...).
-extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name
-extractDecl name mdl decl
+extractDecl :: Name -> LHsDecl Name -> LHsDecl Name
+extractDecl name decl
| name `elem` getMainDeclBinder (unLoc decl) = decl
| otherwise =
case unLoc decl of
@@ -800,11 +894,11 @@ extractDecl name mdl decl
O.$$ O.nest 4 (O.ppr matches))
TyClD d@DataDecl {} ->
let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))
- in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d))
+ in 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 }) ->
- SigD <$> extractRecSel name mdl n tys (dd_cons defn)
+ SigD <$> extractRecSel name n tys (dd_cons defn)
InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
let matches = [ d | L _ d <- insts
-- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
@@ -814,19 +908,19 @@ extractDecl name mdl decl
, selectorFieldOcc n == name
]
in case matches of
- [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
+ [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0)
_ -> error "internal: extractDecl (ClsInstD)"
_ -> error "internal: extractDecl"
-extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
+extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name]
-> LSig Name
-extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
+extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
-extractRecSel nm mdl t tvs (L _ con : rest) =
+extractRecSel nm t tvs (L _ con : rest) =
case getConDetails con of
RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))
- _ -> extractRecSel nm mdl t tvs rest
+ _ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]
matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
@@ -834,7 +928,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) =
data_ty
-- ResTyGADT _ ty <- con_res con = ty
| ConDeclGADT{} <- con = hsib_body $ con_type con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
-- | Keep export items with docs.
pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 4f6b2c09..608344ad 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -31,6 +31,7 @@ import Haddock.Types
import Name
import Outputable ( showPpr )
import RdrName
+import EnumSet
import RnEnv (dataTcOccs)
processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]
@@ -67,7 +68,7 @@ processModuleHeader dflags gre safety mayStr = do
let flags :: [LangExt.Extension]
-- We remove the flags implied by the language setting and we display the language instead
- flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags)
+ flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags)
return (hmi { hmi_safety = Just $ showPpr dflags safety
, hmi_language = language dflags
, hmi_extensions = flags
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 3054e2f9..b43860fb 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -179,7 +179,7 @@ renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName)
renameLSigType = renameImplicit renameLType
renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName)
-renameLSigWcType = renameImplicit (renameWc renameLType)
+renameLSigWcType = renameWc (renameImplicit renameLType)
renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
renameLKind = renameLType
@@ -219,7 +219,7 @@ renameType t = case t of
ltype' <- renameLType ltype
return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })
- HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n
+ HsTyVar ip (L l n) -> return . HsTyVar ip . L l =<< rename n
HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
HsAppTy a b -> do
@@ -238,6 +238,7 @@ renameType t = case t of
HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)
HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
+ HsSumTy ts -> HsSumTy <$> mapM renameLType ts
HsOpTy a (L loc op) b -> do
op' <- rename op
@@ -261,7 +262,7 @@ renameType t = case t of
HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a
HsCoreTy a -> pure (HsCoreTy a)
- HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b
+ HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b
HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
@@ -328,6 +329,9 @@ renameDecl decl = case decl of
InstD d -> do
d' <- renameInstD d
return (InstD d')
+ DerivD d -> do
+ d' <- renameDerivD d
+ return (DerivD d')
_ -> error "renameDecl"
renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName))
@@ -340,19 +344,19 @@ renameTyClD d = case d of
decl' <- renameFamilyDecl decl
return (FamDecl { tcdFam = decl' })
- SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do
+ SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs, tcdFVs = _fvs } -> do
lname' <- renameL lname
tyvars' <- renameLHsQTyVars tyvars
rhs' <- renameLType rhs
- return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames })
+ return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdRhs = rhs', tcdFVs = placeHolderNames })
- DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do
+ DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, tcdFVs = _fvs } -> do
lname' <- renameL lname
tyvars' <- renameLHsQTyVars tyvars
defn' <- renameDataDefn defn
- return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames })
+ return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames })
- ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars
+ ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity
, tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
lcontext' <- renameLContext lcontext
lname' <- renameL lname
@@ -363,6 +367,7 @@ renameTyClD d = case d of
at_defs' <- mapM renameLTyFamDefltEqn at_defs
-- we don't need the default methods or the already collected doc entities
return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'
+ , tcdFixity = fixity
, tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag
, tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames })
@@ -376,7 +381,9 @@ renameTyClD d = case d of
renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)
renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
- , fdTyVars = ltyvars, fdResultSig = result
+ , fdTyVars = ltyvars
+ , fdFixity = fixity
+ , fdResultSig = result
, fdInjectivityAnn = injectivity }) = do
info' <- renameFamilyInfo info
lname' <- renameL lname
@@ -384,7 +391,9 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
result' <- renameFamilyResultSig result
injectivity' <- renameMaybeInjectivityAnn injectivity
return (FamilyDecl { fdInfo = info', fdLName = lname'
- , fdTyVars = ltyvars', fdResultSig = result'
+ , fdTyVars = ltyvars'
+ , fdFixity = fixity
+ , fdResultSig = result'
, fdInjectivityAnn = injectivity' })
@@ -412,7 +421,8 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
cons' <- mapM (mapM renameCon) cons
-- I don't think we need the derivings, so we return Nothing
return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
- , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })
+ , dd_kindSig = k', dd_cons = cons'
+ , dd_derivs = noLoc [] })
renameCon :: ConDecl Name -> RnM (ConDecl DocName)
renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars
@@ -467,10 +477,10 @@ renameSig sig = case sig of
lnames' <- mapM renameL lnames
ltype' <- renameLSigType sig_ty
return (ClassOpSig is_default lnames' ltype')
- PatSynSig lname sig_ty -> do
- lname' <- renameL lname
+ PatSynSig lnames sig_ty -> do
+ lnames' <- mapM renameL lnames
sig_ty' <- renameLSigType sig_ty
- return $ PatSynSig lname' sig_ty'
+ return $ PatSynSig lnames' sig_ty'
FixSig (FixitySig lnames fixity) -> do
lnames' <- mapM renameL lnames
return $ FixSig (FixitySig lnames' fixity)
@@ -503,6 +513,15 @@ renameInstD (DataFamInstD { dfid_inst = d }) = do
d' <- renameDataFamInstD d
return (DataFamInstD { dfid_inst = d' })
+renameDerivD :: DerivDecl Name -> RnM (DerivDecl DocName)
+renameDerivD (DerivDecl { deriv_type = ty
+ , deriv_strategy = strat
+ , deriv_overlap_mode = omode }) = do
+ ty' <- renameLSigType ty
+ return (DerivDecl { deriv_type = ty'
+ , deriv_strategy = strat
+ , deriv_overlap_mode = omode })
+
renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)
renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
, cid_poly_ty =ltype, cid_tyfam_insts = lATs
@@ -523,30 +542,33 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
, tfid_fvs = placeHolderNames }) }
renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName)
-renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs }))
+renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity, tfe_rhs = rhs }))
= do { tc' <- renameL tc
; pats' <- renameImplicit (mapM renameLType) pats
; rhs' <- renameLType rhs
; return (L loc (TyFamEqn { tfe_tycon = tc'
, tfe_pats = pats'
+ , tfe_fixity = fixity
, tfe_rhs = rhs' })) }
renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName)
-renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs }))
+renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixity = fixity, tfe_rhs = rhs }))
= do { tc' <- renameL tc
; tvs' <- renameLHsQTyVars tvs
; rhs' <- renameLType rhs
; return (L loc (TyFamEqn { tfe_tycon = tc'
, tfe_pats = tvs'
+ , tfe_fixity = fixity
, tfe_rhs = rhs' })) }
renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
-renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn })
+renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fixity = fixity, dfid_defn = defn })
= do { tc' <- renameL tc
; pats' <- renameImplicit (mapM renameLType) pats
; defn' <- renameDataDefn defn
; return (DataFamInstDecl { dfid_tycon = tc'
, dfid_pats = pats'
+ , dfid_fixity = fixity
, dfid_defn = defn', dfid_fvs = placeHolderNames }) }
renameImplicit :: (in_thing -> RnM out_thing)
@@ -555,7 +577,8 @@ renameImplicit :: (in_thing -> RnM out_thing)
renameImplicit rn_thing (HsIB { hsib_body = thing })
= do { thing' <- rn_thing thing
; return (HsIB { hsib_body = thing'
- , hsib_vars = PlaceHolder }) }
+ , hsib_vars = PlaceHolder
+ , hsib_closed = PlaceHolder }) }
renameWc :: (in_thing -> RnM out_thing)
-> HsWildCardBndrs Name in_thing
@@ -563,7 +586,7 @@ renameWc :: (in_thing -> RnM out_thing)
renameWc rn_thing (HsWC { hswc_body = thing })
= do { thing' <- rn_thing thing
; return (HsWC { hswc_body = thing'
- , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) }
+ , hswc_wcs = PlaceHolder }) }
renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName)
renameDocInstance (inst, idoc, L l n) = do
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index ab719fe8..28bbf305 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -36,7 +36,7 @@ specialize :: (Eq name, Typeable name)
specialize name details =
everywhere $ mkT step
where
- step (HsTyVar (L _ name')) | name == name' = details
+ step (HsTyVar _ (L _ name')) | name == name' = details
step typ = typ
@@ -81,10 +81,10 @@ specializeSig :: forall name . (Eq name, DataId name, SetName name)
-> Sig name
-> Sig name
specializeSig bndrs typs (TypeSig lnames typ) =
- TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}})
+ TypeSig lnames (typ { hswc_body = (hswc_body typ) { hsib_body = noLoc typ'}})
where
true_type :: HsType name
- true_type = unLoc (hswc_body (hsib_body typ))
+ true_type = unLoc (hsSigWcType typ)
typ' :: HsType name
typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type
fv = foldr Set.union Set.empty . map freeVariables $ typs
@@ -123,7 +123,7 @@ sugar =
sugarLists :: NamedThing name => HsType name -> HsType name
-sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp)
+sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
| isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
where
name' = getName name
@@ -137,7 +137,7 @@ sugarTuples typ =
where
aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
aux apps (HsParTy (L _ typ')) = aux apps typ'
- aux apps (HsTyVar (L _ name))
+ aux apps (HsTyVar _ (L _ name))
| isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
where
name' = getName name
@@ -149,7 +149,7 @@ sugarTuples typ =
sugarOperators :: NamedThing name => HsType name -> HsType name
-sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar (L l name))) la)) lb)
+sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb)
| isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
| isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
where
@@ -224,7 +224,7 @@ freeVariables =
query term ctx = case cast term :: Maybe (HsType name) of
Just (HsForAllTy bndrs _) ->
(Set.empty, Set.union ctx (bndrsNames bndrs))
- Just (HsTyVar (L _ name))
+ Just (HsTyVar _ (L _ name))
| getName name `Set.member` ctx -> (Set.empty, ctx)
| otherwise -> (Set.singleton $ getNameRep name, ctx)
_ -> (Set.empty, ctx)
@@ -267,12 +267,13 @@ renameType (HsQualTy lctxt lt) =
HsQualTy
<$> located renameContext lctxt
<*> renameLType lt
-renameType (HsTyVar name) = HsTyVar <$> located renameName name
+renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name
renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
renameType (HsListTy lt) = HsListTy <$> renameLType lt
renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
+renameType (HsSumTy lt) = HsSumTy <$> mapM renameLType lt
renameType (HsOpTy la lop lb) =
HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb
renameType (HsParTy lt) = HsParTy <$> renameLType lt
@@ -284,8 +285,8 @@ renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
renameType t@(HsRecTy _) = pure t
renameType t@(HsCoreTy _) = pure t
-renameType (HsExplicitListTy ph ltys) =
- HsExplicitListTy ph <$> renameLTypes ltys
+renameType (HsExplicitListTy ip ph ltys) =
+ HsExplicitListTy ip ph <$> renameLTypes ltys
renameType (HsExplicitTupleTy phs ltys) =
HsExplicitTupleTy phs <$> renameLTypes ltys
renameType t@(HsTyLit _) = pure t
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index f45589a0..796a7ce6 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -38,6 +38,7 @@ import FastString
import GHC hiding (NoLink)
import GhcMonad (withSession)
import HscTypes
+import NameCache
import IfaceEnv
import Name
import UniqFM
@@ -81,8 +82,8 @@ binaryInterfaceMagic = 0xD0Cface
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
-#if (__GLASGOW_HASKELL__ >= 711) && (__GLASGOW_HASKELL__ < 801)
-binaryInterfaceVersion = 28
+#if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805)
+binaryInterfaceVersion = 29
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -125,6 +126,7 @@ writeInterfaceFile filename iface = do
-- put the main thing
let bh = setUserData bh0 $ newWriteState (putName bin_symtab)
+ (putName bin_symtab)
(putFastString bin_dict)
put_ bh iface
@@ -370,9 +372,10 @@ instance Binary InterfaceFile where
instance Binary InstalledInterface where
- put_ bh (InstalledInterface modu info docMap argMap
+ put_ bh (InstalledInterface modu is_sig info docMap argMap
exps visExps opts subMap fixMap) = do
put_ bh modu
+ put_ bh is_sig
put_ bh info
put_ bh docMap
put_ bh argMap
@@ -384,6 +387,7 @@ instance Binary InstalledInterface where
get bh = do
modu <- get bh
+ is_sig <- get bh
info <- get bh
docMap <- get bh
argMap <- get bh
@@ -393,7 +397,7 @@ instance Binary InstalledInterface where
subMap <- get bh
fixMap <- get bh
- return (InstalledInterface modu info docMap argMap
+ return (InstalledInterface modu is_sig info docMap argMap
exps visExps opts subMap fixMap)
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index dcc50b95..e2bbe6f8 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-}
-{-# LANGUAGE TypeFamilies, RecordWildCards #-}
+{-# 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 #-}
-----------------------------------------------------------------------------
-- |
@@ -77,6 +78,9 @@ data Interface = Interface
-- | The module behind this interface.
ifaceMod :: !Module
+ -- | Is this a signature?
+ , ifaceIsSig :: !Bool
+
-- | Original file name of the module.
, ifaceOrigFilename :: !FilePath
@@ -154,6 +158,9 @@ data InstalledInterface = InstalledInterface
-- | The module represented by this interface.
instMod :: Module
+ -- | Is this a signature?
+ , instIsSig :: Bool
+
-- | Textual information about the module.
, instInfo :: HaddockModInfo Name
@@ -183,6 +190,7 @@ data InstalledInterface = InstalledInterface
toInstalledIface :: Interface -> InstalledInterface
toInstalledIface interface = InstalledInterface
{ instMod = ifaceMod interface
+ , instIsSig = ifaceIsSig interface
, instInfo = ifaceInfo interface
, instDocMap = ifaceDocMap interface
, instArgMap = ifaceArgMap interface
@@ -343,7 +351,8 @@ data InstType name
| TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side)
| DataInst (TyClDecl name) -- ^ Data constructors
-instance OutputableBndr a => Outputable (InstType a) where
+instance (OutputableBndrId a)
+ => Outputable (InstType a) where
ppr (ClassInst { .. }) = text "ClassInst"
<+> ppr clsiCtx
<+> ppr clsiTyVars
@@ -378,8 +387,8 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
mkType (KindedTyVar (L loc name) lkind) =
HsKindSig tvar lkind
where
- tvar = L loc (HsTyVar (L loc name))
- mkType (UserTyVar name) = HsTyVar name
+ tvar = L loc (HsTyVar NotPromoted (L loc name))
+ mkType (UserTyVar name) = HsTyVar NotPromoted name
-- | An instance head that may have documentation and a source location.
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 389aa5ab..404cfcf6 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -128,7 +128,7 @@ mkMeta x = emptyMetaDoc { _doc = x }
mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name
-- Dubious, because the implicit binders are empty even
-- though the type might have free varaiables
-mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty)
+mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty)
addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name
-- Add the class context to a class-op signature
@@ -150,7 +150,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name]
lHsQTyVarsToTypes tvs
- = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv)))
+ = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv)))
| tv <- hsQTvExplicit tvs ]
--------------------------------------------------------------------------------
diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal
index 5eced02d..cabfbc67 100644
--- a/haddock-library/haddock-library.cabal
+++ b/haddock-library/haddock-library.cabal
@@ -21,7 +21,7 @@ library
default-language: Haskell2010
build-depends:
- base >= 4.5 && < 4.10
+ base >= 4.5 && < 4.11
, bytestring
, transformers
, deepseq
diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs
index dea101d8..e1e920f2 100644
--- a/haddock-test/src/Test/Haddock/Config.hs
+++ b/haddock-test/src/Test/Haddock/Config.hs
@@ -237,7 +237,7 @@ baseDependencies ghcPath = do
exitFailure
(ifArg:_) -> pure ifArg
ifaces pkgIndex name = do
- pkg <- join $ snd <$> lookupPackageName pkgIndex (PackageName name)
+ pkg <- join $ snd <$> lookupPackageName pkgIndex (mkPackageName name)
iface <$> haddockInterfaces pkg <*> haddockHTMLs pkg
iface file html = "--read-interface=" ++ html ++ "," ++ file
diff --git a/haddock.cabal b/haddock.cabal
index 49745a10..fa07ec6b 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -43,7 +43,7 @@ executable haddock
ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded
build-depends:
- base >= 4.3 && < 4.10
+ base >= 4.3 && < 4.11
if flag(in-ghc-tree)
hs-source-dirs: haddock-api/src, haddock-library/vendor/attoparsec-0.12.1.1, haddock-library/src
cpp-options: -DIN_GHC_TREE
@@ -55,8 +55,8 @@ executable haddock
array,
xhtml >= 3000.2 && < 3000.3,
Cabal >= 1.10,
- ghc-boot,
- ghc >= 7.11 && < 8.1,
+ ghc-boot == 8.3,
+ ghc == 8.3,
bytestring,
transformers