aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/haddock-api.cabal11
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs1
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs8
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs10
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs16
-rw-r--r--haddock-api/src/Haddock/Convert.hs9
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs13
-rw-r--r--haddock-api/src/Haddock/Interface.hs26
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs4
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs96
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs12
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs15
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs9
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs4
-rw-r--r--haddock-api/src/Haddock/Types.hs27
16 files changed, 154 insertions, 109 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index cd02bf25..9770061c 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -1,6 +1,6 @@
cabal-version: 2.0
name: haddock-api
-version: 2.24.0
+version: 2.26.0
synopsis: A documentation-generation tool for Haskell libraries
description: Haddock is a documentation-generation tool for Haskell
libraries
@@ -13,7 +13,7 @@ bug-reports: https://github.com/haskell/haddock/issues
copyright: (c) Simon Marlow, David Waern
category: Documentation
build-type: Simple
-tested-with: GHC==9.0.*
+tested-with: GHC==9.2.*
extra-source-files:
CHANGES.md
@@ -180,11 +180,11 @@ test-suite spec
Haddock.Backends.Hyperlinker.Parser
Haddock.Backends.Hyperlinker.Types
- build-depends: ghc ^>= 9.1
+ build-depends: ghc ^>= 9.3
, ghc-paths ^>= 0.1.0.12
, haddock-library ^>= 1.9.0
, xhtml ^>= 3000.2.2
- , hspec >= 2.4.4 && < 2.8
+ , hspec ^>= 2.9
, parsec ^>= 3.1.13.0
, QuickCheck >= 2.11 && ^>= 2.14
@@ -201,10 +201,11 @@ test-suite spec
, filepath
, ghc-boot
, ghc-boot-th
+ , mtl
, transformers
build-tool-depends:
- hspec-discover:hspec-discover >= 2.4.4 && < 2.8
+ hspec-discover:hspec-discover ^>= 2.9
source-repository head
type: git
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 29c64a2d..221580cc 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -87,7 +87,7 @@ dropHsDocTy = drop_sig_ty
drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b)
drop_ty (HsListTy x a) = HsListTy x (drop_lty a)
drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b)
- drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) b (drop_lty c)
+ drop_ty (HsOpTy x p a b c) = HsOpTy x p (drop_lty a) b (drop_lty c)
drop_ty (HsParTy x a) = HsParTy x (drop_lty a)
drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b
drop_ty (HsDocTy _ a _) = drop_ty $ unL a
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 68e03fd5..89828e30 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -114,4 +114,3 @@ highlightScript = "highlight.js"
-- | Path to default CSS file.
defaultCssFile :: FilePath -> FilePath
defaultCssFile libdir = libdir </> "html" </> "solarized.css"
-
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 3929c286..9f28d72a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -238,6 +238,7 @@ classify tok =
ITrequires -> TkKeyword
ITinline_prag {} -> TkPragma
+ ITopaque_prag {} -> TkPragma
ITspec_prag {} -> TkPragma
ITspec_inline_prag {} -> TkPragma
ITsource_prag {} -> TkPragma
@@ -268,6 +269,7 @@ classify tok =
ITequal -> TkGlyph
ITlam -> TkGlyph
ITlcase -> TkGlyph
+ ITlcases -> TkGlyph
ITvbar -> TkGlyph
ITlarrow {} -> TkGlyph
ITrarrow {} -> TkGlyph
@@ -355,10 +357,7 @@ classify tok =
ITeof -> TkUnknown
ITlineComment {} -> TkComment
- ITdocCommentNext {} -> TkComment
- ITdocCommentPrev {} -> TkComment
- ITdocCommentNamed {} -> TkComment
- ITdocSection {} -> TkComment
+ ITdocComment {} -> TkComment
ITdocOptions {} -> TkComment
-- The lexer considers top-level pragmas as comments (see `pragState` in
@@ -379,6 +378,7 @@ inPragma True _ = True
inPragma False tok =
case tok of
ITinline_prag {} -> True
+ ITopaque_prag {} -> True
ITspec_prag {} -> True
ITspec_inline_prag {} -> True
ITsource_prag {} -> True
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index eb524ec7..349c6e8e 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -24,7 +24,7 @@ import Haddock.GhcUtils
import GHC.Utils.Ppr hiding (Doc, quote)
import qualified GHC.Utils.Ppr as Pretty
-import GHC.Types.Basic ( PromotionFlag(..) )
+import GHC.Types.Basic ( PromotionFlag(..), isPromoted )
import GHC hiding (fromMaybeContext )
import GHC.Types.Name.Occurrence
import GHC.Types.Name ( nameOccName )
@@ -1133,9 +1133,13 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode
ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode
= hsep [ppr_mono_lty fun_ty unicode, atSign unicode <> ppr_mono_lty arg_ki unicode]
-ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode
- = ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode
+ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode
+ = ppr_mono_lty ty1 unicode <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode
where
+ ppr_op_prom | isPromoted prom
+ = char '\'' <> ppr_op
+ | otherwise
+ = ppr_op
ppr_op | isSymOcc (getOccName op) = ppLDocName op
| otherwise = char '`' <> ppLDocName op <> char '`'
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 336f23ac..a54bb0aa 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1281,15 +1281,15 @@ ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode qual _
= hsep [ppr_mono_lty fun_ty unicode qual HideEmptyContexts
, atSign unicode <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts]
-ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _
- = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts
+ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode qual _
+ = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op_prom <+> ppr_mono_lty 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.
- ppr_op
- | (getOccString . getName . unL) op == ":" = promoQuote ppr_op'
- | otherwise = ppr_op'
- ppr_op' = ppLDocName qual Infix op
+ ppr_op_prom
+ | isPromoted prom
+ = promoQuote ppr_op
+ | otherwise
+ = ppr_op
+ ppr_op = ppLDocName qual Infix op
ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts
= parens (ppr_mono_lty ty unicode qual emptyCtxts)
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 29e0957b..ceefedf3 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -411,6 +411,7 @@ synifyDataCon use_gadt_syntax dc =
return $ noLocA $ ConDeclGADT
{ con_g_ext = noAnn
, con_names = [name]
+ , con_dcolon = noHsUniTok
, con_bndrs = noLocA outer_bndrs
, con_mb_cxt = ctx
, con_g_args = hat
@@ -606,7 +607,7 @@ synifyType _ vs (TyConApp tc tys)
tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy
-> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy')
| otherwise
- -> noLocA $ HsOpTy noExtField hTy (noLocA $ getName tc) tTy
+ -> noLocA $ HsOpTy noAnn IsPromoted hTy (noLocA $ getName tc) tTy
-- ditto for implicit parameter tycons
| tc `hasKey` ipClassKey
, [name, ty] <- tys
@@ -615,14 +616,16 @@ synifyType _ vs (TyConApp tc tys)
-- and equalities
| tc `hasKey` eqTyConKey
, [ty1, ty2] <- tys
- = noLocA $ HsOpTy noExtField
+ = noLocA $ HsOpTy noAnn
+ NotPromoted
(synifyType WithinType vs ty1)
(noLocA eqTyConName)
(synifyType WithinType vs ty2)
-- and infix type operators
| isSymOcc (nameOccName (getName tc))
, ty1:ty2:tys_rest <- vis_tys
- = mk_app_tys (HsOpTy noExtField
+ = mk_app_tys (HsOpTy noAnn
+ prom
(synifyType WithinType vs ty1)
(noLocA $ getName tc)
(synifyType WithinType vs ty2))
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 599404a0..7c1dc73b 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -95,7 +96,7 @@ ifTrueJust True = Just
ifTrueJust False = const Nothing
sigName :: LSig GhcRn -> [IdP GhcRn]
-sigName (L _ sig) = sigNameNoLoc sig
+sigName (L _ sig) = sigNameNoLoc emptyOccEnv sig
-- | Was this signature given by the user?
isUserLSig :: forall p. UnXRec p => LSig p -> Bool
@@ -114,7 +115,7 @@ pretty = showPpr
-- instantiated at DocNameI instead of (GhcPass _).
-- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _)
-hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ NoExtCon, UnXRec n)
+hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ DataConCantHappen, UnXRec n)
=> HsTyVarBndr flag n -> IdP n
hsTyVarBndrName (UserTyVar _ _ name) = unXRec @n name
hsTyVarBndrName (KindedTyVar _ _ name _) = unXRec @n name
@@ -192,7 +193,7 @@ getMainDeclBinderI (ValD _ d) =
case collectHsBindBinders CollNoDictBinders d of
[] -> []
(name:_) -> [name]
-getMainDeclBinderI (SigD _ d) = sigNameNoLoc d
+getMainDeclBinderI (SigD _ d) = sigNameNoLoc emptyOccEnv d
getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = []
getMainDeclBinderI _ = []
@@ -228,7 +229,7 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
= L loc (HsQualTy { hst_xqual = noExtField
, hst_ctxt = add_ctxt (noLocA []), hst_body = L loc ty })
- extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0)
+ extra_pred = nlHsTyConApp NotPromoted Prefix cls (lHsQTyVarsToTypes tvs0)
add_ctxt (L loc preds) = L loc (extra_pred : preds)
@@ -364,8 +365,8 @@ reparenTypePrec = go
= paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty)
go p (HsAppKindTy x fun_ty arg_ki)
= paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki)
- go p (HsOpTy x ty1 op ty2)
- = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2)
+ go p (HsOpTy x prom ty1 op ty2)
+ = paren p PREC_FUN $ HsOpTy x prom (goL PREC_OP ty1) op (goL PREC_OP ty2)
go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed
go _ t@HsTyVar{} = t
go _ t@HsStarTy{} = t
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index ba7d9d30..19113107 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -56,11 +56,11 @@ import qualified Data.Set as Set
import GHC hiding (verbosity)
import GHC.Data.FastString (unpackFS)
import GHC.Data.Graph.Directed
-import GHC.Driver.Env (hscUpdateFlags, hsc_home_unit, hsc_logger, hsc_static_plugins, hsc_units)
+import GHC.Driver.Env
import GHC.Driver.Monad (modifySession, withTimingM)
import GHC.Driver.Session hiding (verbosity)
import GHC.HsToCore.Docs (getMainDeclBinder)
-import GHC.Plugins (Outputable, Plugin (..), PluginWithArgs (..), StaticPlugin (..), defaultPlugin, keepRenamedSource)
+import GHC.Plugins
import GHC.Tc.Types (TcGblEnv (..), TcM)
import GHC.Tc.Utils.Env (tcLookupGlobal)
import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv)
@@ -69,7 +69,7 @@ import GHC.Types.Name.Occurrence (isTcOcc)
import GHC.Types.Name.Reader (globalRdrEnvElts, greMangledName, unQualOK)
import GHC.Unit.Module.Env (ModuleSet, emptyModuleSet, mkModuleSet, unionModuleSet)
import GHC.Unit.Module.Graph
-import GHC.Unit.Module.ModSummary (emsModSummary, isBootSummary)
+import GHC.Unit.Module.ModSummary (isBootSummary)
import GHC.Unit.Types (IsBootInterface (..))
import GHC.Utils.Error (withTiming)
@@ -145,10 +145,12 @@ createIfaces verbosity modules flags instIfaceMap = do
let
installHaddockPlugin :: HscEnv -> HscEnv
- installHaddockPlugin hsc_env = hscUpdateFlags (flip gopt_set Opt_PluginTrustworthy) $ hsc_env
- { hsc_static_plugins =
- haddockPlugin : hsc_static_plugins hsc_env
- }
+ installHaddockPlugin hsc_env =
+ let
+ old_plugins = hsc_plugins hsc_env
+ new_plugins = old_plugins { staticPlugins = haddockPlugin : staticPlugins old_plugins }
+ hsc_env' = hsc_env { hsc_plugins = new_plugins }
+ in hscUpdateFlags (flip gopt_set Opt_PluginTrustworthy) hsc_env'
-- Note that we would rather use withTempSession but as long as we
-- have the separate attachInstances step we need to keep the session
@@ -210,8 +212,8 @@ createIfaces verbosity modules flags instIfaceMap = do
-- i.e. if module A imports B, then B is preferred over A,
-- but if module A {-# SOURCE #-} imports B, then we can't say the same.
--
- go (AcyclicSCC (ModuleNode ems))
- | NotBoot <- isBootSummary (emsModSummary ems) = [ems]
+ go (AcyclicSCC (ModuleNode _ ms))
+ | NotBoot <- isBootSummary ms = [ms]
| otherwise = []
go (AcyclicSCC _) = []
go (CyclicSCC _) = error "haddock: module graph cyclic even with boot files"
@@ -220,9 +222,9 @@ createIfaces verbosity modules flags instIfaceMap = do
ifaces =
[ Map.findWithDefault
(error "haddock:iface")
- (ms_mod (emsModSummary ems))
+ (ms_mod ms)
ifaceMap
- | ems <- concatMap go $ topSortModuleGraph False modGraph Nothing
+ | ms <- concatMap go $ topSortModuleGraph False modGraph Nothing
]
return (ifaces, moduleSet)
@@ -360,7 +362,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
]
where
formatName :: SrcSpan -> HsDecl GhcRn -> String
- formatName loc n = p (getMainDeclBinder n) ++ case loc of
+ formatName loc n = p (getMainDeclBinder emptyOccEnv n) ++ case loc of
RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++
show (srcSpanStartLine rss) ++ ")"
_ -> ""
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index e8a79b2b..dc8afa31 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -136,12 +136,12 @@ attachToExportItem index expInfo getInstDoc getFixity export =
, expItemSubDocs = subDocs
} = e { expItemFixities =
nubByName fst $ expItemFixities e ++
- [ (n',f) | n <- getMainDeclBinder d
+ [ (n',f) | n <- getMainDeclBinder emptyOccEnv d
, n' <- n : (map fst subDocs ++ patsyn_names)
, f <- maybeToList (getFixity n')
] }
where
- patsyn_names = concatMap (getMainDeclBinder . fst) patsyns
+ patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . 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 4d746405..dbd4a9b2 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -35,7 +35,7 @@ import Documentation.Haddock.Doc (metaDocAppend)
import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl)
import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigType, moduleString, parents,
pretty, restrictTo, sigName, unL)
-import Haddock.Interface.LexParseRn (processDocString, processDocStringParas, processDocStrings, processModuleHeader)
+import Haddock.Interface.LexParseRn
import Haddock.Options (Flag (..), modulePackageInfo)
import Haddock.Types hiding (liftErrMsg)
import Haddock.Utils (replace)
@@ -57,7 +57,7 @@ import GHC.Core.Class (ClassMinimalDef, classMinimalDef)
import GHC.Core.ConLike (ConLike (..))
import GHC.Data.FastString (bytesFS, unpackFS)
import GHC.Driver.Ppr (showSDoc)
-import GHC.HsToCore.Docs hiding (mkMaps)
+import GHC.HsToCore.Docs hiding (mkMaps, unionArgMaps)
import GHC.IORef (readIORef)
import GHC.Stack (HasCallStack)
import GHC.Tc.Types hiding (IfM)
@@ -65,7 +65,7 @@ import GHC.Tc.Utils.Monad (finalSafeMode)
import GHC.Types.Avail hiding (avail)
import qualified GHC.Types.Avail as Avail
import GHC.Types.Basic (PromotionFlag (..))
-import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName)
+import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName, emptyOccEnv)
import GHC.Types.Name.Env (lookupNameEnv)
import GHC.Types.Name.Reader (GlobalRdrEnv, greMangledName, lookupGlobalRdrEnv)
import GHC.Types.Name.Set (elemNameSet, mkNameSet)
@@ -79,6 +79,7 @@ import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits)
import qualified GHC.Utils.Outputable as O
import GHC.Utils.Panic (pprPanic)
import GHC.Unit.Module.Warnings
+import GHC.Types.Unique.Map
newtype IfEnv m = IfEnv
{
@@ -255,7 +256,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
-- Process the top-level module header documentation.
(!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name
- tcg_rdr_env safety (thMbDocStr <|> (unLoc <$> tcg_doc_hdr))
+ tcg_rdr_env safety (fmap hsDocString thMbDocStr <|> (hsDocString . unLoc <$> tcg_doc_hdr))
-- Warnings on declarations in this module
decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names)
@@ -405,7 +406,7 @@ lookupModuleDyn state pkg_qual mdlName = case pkg_qual of
-- Warnings
-------------------------------------------------------------------------------
-mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
+mkWarningMap :: DynFlags -> Warnings a -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap
mkWarningMap dflags warnings gre exps = case warnings of
NoWarnings -> pure M.empty
WarnAll _ -> pure M.empty
@@ -416,18 +417,18 @@ mkWarningMap dflags warnings gre exps = case warnings of
, let n = greMangledName elt, n `elem` exps ]
in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws'
-moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings a -> ErrMsgM (Maybe (Doc Name))
moduleWarning _ _ NoWarnings = pure Nothing
moduleWarning _ _ (WarnSome _) = pure Nothing
moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w
-parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt a -> ErrMsgM (Doc Name)
parseWarning dflags gre w = case w of
- DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (bytesFS . sl_fs . unLoc) msg)
- WarningTxt _ msg -> format "Warning: " (foldMap (bytesFS . sl_fs . unLoc) msg)
+ DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg)
+ WarningTxt _ msg -> format "Warning: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg)
where
format x bs = DocWarning . DocParagraph . DocAppend (DocString x)
- <$> processDocString dflags gre (mkHsDocStringUtf8ByteString bs)
+ <$> processDocStringFromString dflags gre bs
-------------------------------------------------------------------------------
@@ -479,7 +480,7 @@ mkMaps :: DynFlags
-> Maybe Package -- this package
-> GlobalRdrEnv
-> [Name]
- -> [(LHsDecl GhcRn, [HsDocString])]
+ -> [(LHsDecl GhcRn, [HsDoc GhcRn])]
-> ExtractedTHDocs -- ^ Template Haskell putDoc docs
-> ErrMsgM Maps
mkMaps dflags pkgName gre instances decls thDocs = do
@@ -512,36 +513,40 @@ mkMaps dflags pkgName gre instances decls thDocs = do
thMappings = do
let ExtractedTHDocs
_
- (DeclDocMap declDocs)
- (ArgDocMap argDocs)
- (DeclDocMap instDocs) = thDocs
- ds2mdoc :: HsDocString -> ErrMsgM (MDoc Name)
- ds2mdoc = processDocStringParas dflags pkgName gre
-
- declDocs' <- mapM ds2mdoc declDocs
- argDocs' <- mapM (mapM ds2mdoc) argDocs
- instDocs' <- mapM ds2mdoc instDocs
+ declDocs
+ argDocs
+ instDocs = thDocs
+ ds2mdoc :: (HsDoc GhcRn) -> ErrMsgM (MDoc Name)
+ ds2mdoc = processDocStringParas dflags pkgName gre . hsDocString
+
+ let cvt = M.fromList . nonDetEltsUniqMap
+
+ declDocs' <- mapM ds2mdoc (cvt declDocs)
+ argDocs' <- mapM (mapM ds2mdoc) (cvt argDocs)
+ instDocs' <- mapM ds2mdoc (cvt instDocs)
return (declDocs' <> instDocs', argDocs')
- mappings :: (LHsDecl GhcRn, [HsDocString])
+ mappings :: (LHsDecl GhcRn, [HsDoc GhcRn])
-> ErrMsgM ( [(Name, MDoc Name)]
, [(Name, IntMap (MDoc Name))]
, [(Name, [LHsDecl GhcRn])]
)
- mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), docStrs) = do
- let declDoc :: [HsDocString] -> IntMap HsDocString
+ mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), hs_docStrs) = do
+ let docStrs = map hsDocString hs_docStrs
+ declDoc :: [HsDocString] -> IntMap HsDocString
-> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name))
declDoc strs m = do
doc' <- processDocStrings dflags pkgName gre strs
m' <- traverse (processDocStringParas dflags pkgName gre) m
pure (doc', m')
- (doc, args) <- declDoc docStrs (declTypeDocs decl)
+ (doc, args) <- declDoc docStrs (fmap hsDocString (declTypeDocs decl))
let
subs :: [(Name, [HsDocString], IntMap HsDocString)]
- subs = subordinates instanceMap decl
+ subs = map (\(n, ds, im) -> (n, map hsDocString ds, fmap hsDocString im))
+ $ subordinates emptyOccEnv instanceMap decl
(subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs
@@ -572,7 +577,23 @@ mkMaps dflags pkgName gre instances decls thDocs = do
TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d')
_ -> getInstLoc d
names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
- names _ decl = getMainDeclBinder decl
+ names _ decl = getMainDeclBinder emptyOccEnv decl
+
+-- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two
+-- maps with values for the same key merge the inner map as well.
+-- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.
+
+unionArgMaps :: forall b . Map Name (IntMap b)
+ -> Map Name (IntMap b)
+ -> Map Name (IntMap b)
+unionArgMaps a b = M.foldrWithKey go b a
+ where
+ go :: Name -> IntMap b
+ -> Map Name (IntMap b) -> Map Name (IntMap b)
+ go n newArgMap acc
+ | Just oldArgMap <- M.lookup n acc =
+ M.insert n (newArgMap `IM.union` oldArgMap) acc
+ | otherwise = M.insert n newArgMap acc
-- Note [2]:
------------
@@ -634,11 +655,11 @@ mkExportItems
Just exports -> liftM concat $ mapM lookupExport exports
where
lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do
- doc <- processDocString dflags gre docStr
+ doc <- processDocString dflags gre (hsDocString . unLoc $ docStr)
return [ExportGroup lev "" doc]
lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do
- doc <- processDocStringParas dflags pkgName gre docStr
+ doc <- processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr)
return [ExportDoc doc]
lookupExport (IEDocNamed _ str, _) = liftErrMsg $
@@ -706,7 +727,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
return [export]
(ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
- let declNames = getMainDeclBinder (unL decl)
+ let declNames = getMainDeclBinder emptyOccEnv (unL decl)
in case () of
_
-- We should not show a subordinate by itself if any of its
@@ -785,7 +806,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
let
patSynNames =
- concatMap (getMainDeclBinder . fst) bundledPatSyns
+ concatMap (getMainDeclBinder emptyOccEnv . fst) bundledPatSyns
fixities =
[ (n, f)
@@ -1007,17 +1028,17 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
(concat . concat) `fmap` (for decls $ \decl -> do
case decl of
(L _ (DocD _ (DocGroup lev docStr))) -> do
- doc <- liftErrMsg (processDocString dflags gre docStr)
+ doc <- liftErrMsg (processDocString dflags gre (hsDocString . unLoc $ docStr))
return [[ExportGroup lev "" doc]]
(L _ (DocD _ (DocCommentNamed _ docStr))) -> do
- doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr)
+ doc <- liftErrMsg (processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr))
return [[ExportDoc doc]]
(L _ (ValD _ valDecl))
| name:_ <- collectHsBindBinders CollNoDictBinders valDecl
, Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
-> return []
_ ->
- for (getMainDeclBinder (unLoc decl)) $ \nm -> do
+ for (getMainDeclBinder emptyOccEnv (unLoc decl)) $ \nm -> do
case lookupNameEnv availEnv nm of
Just avail ->
availExportItem is_sig modMap thisMod
@@ -1042,7 +1063,7 @@ extractDecl
-> LHsDecl GhcRn -- ^ parent declaration
-> Either ErrMsg (LHsDecl GhcRn)
extractDecl declMap name decl
- | name `elem` getMainDeclBinder (unLoc decl) = pure decl
+ | name `elem` getMainDeclBinder emptyOccEnv (unLoc decl) = pure decl
| otherwise =
case unLoc decl of
TyClD _ d@ClassDecl { tcdLName = L _ clsNm
@@ -1197,10 +1218,10 @@ mkVisibleNames (_, _, _, instMap) exports opts
where
exportName e@ExportDecl {} = name ++ subs ++ patsyns
where subs = map fst (expItemSubDocs e)
- patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)
+ patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expItemPats e)
name = case unLoc $ expItemDecl e of
InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap
- decl -> getMainDeclBinder decl
+ decl -> getMainDeclBinder emptyOccEnv decl
exportName ExportNoDecl {} = [] -- we don't count these as visible, since
-- we don't want links to go to them.
exportName _ = []
@@ -1217,6 +1238,7 @@ findNamedDoc name = search
tell ["Cannot find documentation for: $" ++ name]
return Nothing
search (DocD _ (DocCommentNamed name' doc) : rest)
- | name == name' = return (Just doc)
+ | name == name' = return (Just (hsDocString . unLoc $ doc))
+
| otherwise = search rest
search (_other_decl : rest) = search rest
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index a827cf66..f3b57792 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -15,6 +15,7 @@
-----------------------------------------------------------------------------
module Haddock.Interface.LexParseRn
( processDocString
+ , processDocStringFromString
, processDocStringParas
, processDocStrings
, processModuleHeader
@@ -38,6 +39,7 @@ import GHC.Parser.PostProcess
import GHC.Driver.Ppr ( showPpr, showSDoc )
import GHC.Types.Name.Reader
import GHC.Data.EnumSet as EnumSet
+import GHC.Utils.Trace
processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString]
-> ErrMsgM (Maybe (MDoc Name))
@@ -52,11 +54,15 @@ processDocStrings dflags pkg gre strs = do
processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name)
processDocStringParas dflags pkg gre hds =
- overDocF (rename dflags gre) $ parseParas dflags pkg (unpackHDS hds)
+ overDocF (rename dflags gre) $ parseParas dflags pkg (renderHsDocString hds)
processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name)
processDocString dflags gre hds =
- rename dflags gre $ parseString dflags (unpackHDS hds)
+ processDocStringFromString dflags gre (renderHsDocString hds)
+
+processDocStringFromString :: DynFlags -> GlobalRdrEnv -> String -> ErrMsgM (Doc Name)
+processDocStringFromString dflags gre hds =
+ rename dflags gre $ parseString dflags hds
processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe HsDocString
-> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name))
@@ -65,7 +71,7 @@ processModuleHeader dflags pkgName gre safety mayStr = do
case mayStr of
Nothing -> return failure
Just hds -> do
- let str = unpackHDS hds
+ let str = renderHsDocString hds
(hmi, doc) = parseModuleHeader dflags pkgName str
!descr <- case hmi_description hmi of
Just hmi_descr -> Just <$> rename dflags gre hmi_descr
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 98c39859..cbc7e58f 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -191,8 +191,8 @@ renameDocumentation (Documentation mDoc mWarning) =
Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning
-renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
-renameLDocHsSyn = return
+renameLDocHsSyn :: Located (WithHsDocIdentifiers HsDocString a) -> RnM (Located (WithHsDocIdentifiers HsDocString b))
+renameLDocHsSyn (L l doc) = return (L l (WithHsDocIdentifiers (hsDocString doc) []))
renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName))
@@ -290,11 +290,11 @@ renameType t = case t of
HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts
HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts
- HsOpTy _ a (L loc op) b -> do
+ HsOpTy _ prom a (L loc op) b -> do
op' <- rename op
a' <- renameLType a
b' <- renameLType b
- return (HsOpTy noAnn a' (L loc op') b')
+ return (HsOpTy noAnn prom a' (L loc op') b')
HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty
@@ -317,6 +317,7 @@ renameType t = case t of
HsSpliceTy _ s -> renameHsSpliceTy s
HsWildCardTy _ -> pure (HsWildCardTy noAnn)
+
renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI)
renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do
bndrs' <- renameOuterTyVarBndrs bndrs
@@ -511,13 +512,14 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
ltyvars' <- mapM renameLTyVarBndr ltyvars
lcontext' <- traverse renameLContext lcontext
details' <- renameH98Details details
- mbldoc' <- mapM renameLDocHsSyn mbldoc
+ mbldoc' <- mapM (renameLDocHsSyn) mbldoc
return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars'
, con_mb_cxt = lcontext'
, con_forall = forall_ -- Remove when #18311 is fixed
, con_args = details', con_doc = mbldoc' })
renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs
+ , con_dcolon = dcol
, con_mb_cxt = lcontext, con_g_args = details
, con_res_ty = res_ty
, con_doc = mbldoc } = do
@@ -528,7 +530,8 @@ renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs
res_ty' <- renameLType res_ty
mbldoc' <- mapM renameLDocHsSyn mbldoc
return (ConDeclGADT
- { con_g_ext = noExtField, con_names = lnames', con_bndrs = bndrs'
+ { con_g_ext = noExtField, con_names = lnames'
+ , con_dcolon = dcol, con_bndrs = bndrs'
, con_mb_cxt = lcontext', con_g_args = details'
, con_res_ty = res_ty', con_doc = mbldoc' })
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 399e5d0d..d1164858 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -16,6 +16,7 @@ import Haddock.Syb
import Haddock.Types
import GHC
+import GHC.Types.Basic ( PromotionFlag(..) )
import GHC.Types.Name
import GHC.Data.FastString
import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )
@@ -132,8 +133,8 @@ sugarTuples typ =
sugarOperators :: HsType GhcRn -> HsType GhcRn
-sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)
- | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
+sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ prom (L l name))) la)) lb)
+ | isSymOcc $ getOccName name' = mkHsOpTy prom la (L l name) lb
| unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) la lb
where
name' = getName name
@@ -293,8 +294,8 @@ renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType l
renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt
-renameType (HsOpTy x la lop lb) =
- HsOpTy x <$> renameLType la <*> locatedN renameName lop <*> renameLType lb
+renameType (HsOpTy x prom la lop lb) =
+ HsOpTy x prom <$> renameLType la <*> locatedN renameName lop <*> renameLType lb
renameType (HsParTy x lt) = HsParTy x <$> renameLType lt
renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt
renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 9c4308a6..aabb904a 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -85,8 +85,8 @@ binaryInterfaceMagic = 0xD0Cface
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
-#if MIN_VERSION_ghc(9,3,0) && !MIN_VERSION_ghc(9,4,0)
-binaryInterfaceVersion = 39
+#if MIN_VERSION_ghc(9,5,0) && !MIN_VERSION_ghc(9,6,0)
+binaryInterfaceVersion = 41
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 05375185..7d00c5ec 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
+{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PartialTypeSignatures #-}
@@ -319,7 +320,8 @@ type instance NoGhcTc DocNameI = DocNameI
type instance IdP DocNameI = DocName
instance CollectPass DocNameI where
- collectXXPat _ _ ext = noExtCon ext
+ collectXXPat _ ext = dataConCantHappen ext
+ collectXXHsBindsLR ext = dataConCantHappen ext
instance NamedThing DocName where
getName (Documented name _) = name
@@ -760,11 +762,11 @@ type instance XXType DocNameI = HsCoreTy
type instance XHsForAllVis DocNameI = NoExtField
type instance XHsForAllInvis DocNameI = NoExtField
-type instance XXHsForAllTelescope DocNameI = NoExtCon
+type instance XXHsForAllTelescope DocNameI = DataConCantHappen
type instance XUserTyVar DocNameI = NoExtField
type instance XKindedTyVar DocNameI = NoExtField
-type instance XXTyVarBndr DocNameI = NoExtCon
+type instance XXTyVarBndr DocNameI = DataConCantHappen
type instance XCFieldOcc DocNameI = DocName
type instance XXFieldOcc DocNameI = NoExtField
@@ -780,7 +782,7 @@ type instance XForeignExport DocNameI = NoExtField
type instance XForeignImport DocNameI = NoExtField
type instance XConDeclGADT DocNameI = NoExtField
type instance XConDeclH98 DocNameI = NoExtField
-type instance XXConDecl DocNameI = NoExtCon
+type instance XXConDecl DocNameI = DataConCantHappen
type instance XDerivD DocNameI = NoExtField
type instance XInstD DocNameI = NoExtField
@@ -791,10 +793,10 @@ type instance XTyClD DocNameI = NoExtField
type instance XNoSig DocNameI = NoExtField
type instance XCKindSig DocNameI = NoExtField
type instance XTyVarSig DocNameI = NoExtField
-type instance XXFamilyResultSig DocNameI = NoExtCon
+type instance XXFamilyResultSig DocNameI = DataConCantHappen
type instance XCFamEqn DocNameI _ = NoExtField
-type instance XXFamEqn DocNameI _ = NoExtCon
+type instance XXFamEqn DocNameI _ = DataConCantHappen
type instance XCClsInstDecl DocNameI = NoExtField
type instance XCDerivDecl DocNameI = NoExtField
@@ -811,23 +813,24 @@ type instance XClassDecl DocNameI = NoExtField
type instance XDataDecl DocNameI = NoExtField
type instance XSynDecl DocNameI = NoExtField
type instance XFamDecl DocNameI = NoExtField
-type instance XXFamilyDecl DocNameI = NoExtCon
-type instance XXTyClDecl DocNameI = NoExtCon
+type instance XXFamilyDecl DocNameI = DataConCantHappen
+type instance XXTyClDecl DocNameI = DataConCantHappen
type instance XHsWC DocNameI _ = NoExtField
type instance XHsOuterExplicit DocNameI _ = NoExtField
type instance XHsOuterImplicit DocNameI = NoExtField
-type instance XXHsOuterTyVarBndrs DocNameI = NoExtCon
+type instance XXHsOuterTyVarBndrs DocNameI = DataConCantHappen
type instance XHsSig DocNameI = NoExtField
-type instance XXHsSigType DocNameI = NoExtCon
+type instance XXHsSigType DocNameI = DataConCantHappen
type instance XHsQTvs DocNameI = NoExtField
type instance XConDeclField DocNameI = NoExtField
-type instance XXConDeclField DocNameI = NoExtCon
+type instance XXConDeclField DocNameI = DataConCantHappen
-type instance XXPat DocNameI = NoExtCon
+type instance XXPat DocNameI = DataConCantHappen
+type instance XXHsBindsLR DocNameI a = DataConCantHappen
type instance XCInjectivityAnn DocNameI = NoExtField
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 15:06:16 +0000