aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2022-08-05 16:57:18 -0400
committerBen Gamari <ben@smart-cactus.org>2022-08-05 17:41:15 -0400
commitade67fe17e600738c815d7bcd6557a791e7aa1e1 (patch)
treeaffc0928f145f791c5b1de3db520e270f6a77754 /haddock-api/src
parent2f1711b301fea88eb1d0b40d1c04b2f0539fd882 (diff)
parent7484cf883da0ececa8b9c0e039608d6c20654116 (diff)
Merge remote-tracking branch 'origin/ghc-9.4'
Diffstat (limited to 'haddock-api/src')
-rw-r--r--haddock-api/src/Documentation/Haddock.hs2
-rw-r--r--haddock-api/src/Haddock.hs41
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs14
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs21
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs23
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs33
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs44
-rw-r--r--haddock-api/src/Haddock/Convert.hs54
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs34
-rw-r--r--haddock-api/src/Haddock/Interface.hs84
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs4
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs126
-rw-r--r--haddock-api/src/Haddock/Interface/LexParseRn.hs12
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs28
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs22
-rw-r--r--haddock-api/src/Haddock/InterfaceFile.hs179
-rw-r--r--haddock-api/src/Haddock/Parser.hs2
-rw-r--r--haddock-api/src/Haddock/Types.hs35
18 files changed, 362 insertions, 396 deletions
diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs
index cf244a5f..1aa666ce 100644
--- a/haddock-api/src/Documentation/Haddock.hs
+++ b/haddock-api/src/Documentation/Haddock.hs
@@ -52,9 +52,7 @@ module Documentation.Haddock (
-- * Interface files
InterfaceFile(..),
readInterfaceFile,
- nameCacheFromGhc,
freshNameCache,
- NameCacheAccessor,
-- * Flags and options
Flag(..),
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 7eba7b92..989ca03f 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wwarn #-}
-----------------------------------------------------------------------------
-- |
@@ -73,8 +74,11 @@ import Text.ParserCombinators.ReadP (readP_to_S)
import GHC hiding (verbosity)
import GHC.Settings.Config
import GHC.Driver.Session hiding (projectVersion, verbosity)
+import GHC.Driver.Config.Logger (initLogFlags)
import GHC.Driver.Env
import GHC.Utils.Error
+import GHC.Utils.Logger
+import GHC.Types.Name.Cache
import GHC.Unit
import GHC.Unit.State (lookupUnit)
import GHC.Utils.Panic (handleGhcException)
@@ -193,9 +197,10 @@ haddockWithGhc ghc args = handleTopExceptions $ do
unit_state <- hsc_units <$> getSession
forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
- mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), Visible, path)] noChecks
+ name_cache <- freshNameCache
+ mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), Visible, path)] noChecks
forM_ mIfaceFile $ \(_,_,_, ifaceFile) -> do
- putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile)
+ putMsg logger $ renderJson (jsonInterfaceFile ifaceFile)
if not (null files) then do
(packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
@@ -221,7 +226,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do
throwE "No input file(s)."
-- Get packages supplied with --read-interface.
- packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks
+ name_cache <- liftIO $ freshNameCache
+ packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
-- Render even though there are no input files (usually contents/index).
liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages []
@@ -264,7 +270,8 @@ readPackagesAndProcessModules :: [Flag] -> [String]
readPackagesAndProcessModules flags files = do
-- Get packages supplied with --read-interface.
let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
- packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks
+ name_cache <- hsc_NC <$> getSession
+ packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
-- Create the interfaces -- this is the core part of Haddock.
let ifaceFiles = map (\(_, _, _, ifaceFile) -> ifaceFile) packages
@@ -303,7 +310,7 @@ renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = d
-- | Render the interfaces with whatever backend is specified in the flags.
render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]
-> [(FilePath, PackageInterfaces)] -> Map Module FilePath -> IO ()
-render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap = do
+render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = do
let
packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty)
@@ -326,6 +333,7 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
dflags'
| unicode = gopt_set dflags Opt_PrintUnicodeSyntax
| otherwise = dflags
+ logger = setLogFlags log' (initLogFlags dflags')
visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
@@ -430,7 +438,7 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
$ flags
when (Flag_GenIndex `elem` flags) $ do
- withTiming logger dflags' "ppHtmlIndex" (const ()) $ do
+ withTiming logger "ppHtmlIndex" (const ()) $ do
_ <- {-# SCC ppHtmlIndex #-}
ppHtmlIndex odir title pkgStr
themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
@@ -442,7 +450,7 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
copyHtmlBits odir libDir themes withQuickjump
when (Flag_GenContents `elem` flags) $ do
- withTiming logger dflags' "ppHtmlContents" (const ()) $ do
+ withTiming logger "ppHtmlContents" (const ()) $ do
_ <- {-# SCC ppHtmlContents #-}
ppHtmlContents unit_state odir title pkgStr
themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
@@ -462,7 +470,7 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
$ packages)
when (Flag_Html `elem` flags) $ do
- withTiming logger dflags' "ppHtml" (const ()) $ do
+ withTiming logger "ppHtml" (const ()) $ do
_ <- {-# SCC ppHtml #-}
ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir
prologue
@@ -498,14 +506,14 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
]
when (Flag_LaTeX `elem` flags) $ do
- withTiming logger dflags' "ppLatex" (const ()) $ do
+ withTiming logger "ppLatex" (const ()) $ do
_ <- {-# SCC ppLatex #-}
ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
libDir
return ()
when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do
- withTiming logger dflags' "ppHyperlinkedSource" (const ()) $ do
+ withTiming logger "ppHyperlinkedSource" (const ()) $ do
_ <- {-# SCC ppHyperlinkedSource #-}
ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces
return ()
@@ -516,24 +524,22 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
-------------------------------------------------------------------------------
-readInterfaceFiles :: MonadIO m
- => NameCacheAccessor m
+readInterfaceFiles :: NameCache
-> [(DocPaths, Visibility, FilePath)]
-> Bool
- -> m [(DocPaths, Visibility, FilePath, InterfaceFile)]
+ -> IO [(DocPaths, Visibility, FilePath, InterfaceFile)]
readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
where
-- try to read an interface, warn if we can't
- tryReadIface (paths, showModules, file) =
+ tryReadIface (paths, vis, file) =
readInterfaceFile name_cache_accessor file bypass_version_check >>= \case
- Left err -> liftIO $ do
+ Left err -> do
putStrLn ("Warning: Cannot read " ++ file ++ ":")
putStrLn (" " ++ err)
putStrLn "Skipping this interface."
return Nothing
- Right f ->
- return (Just (paths, showModules, file, f ))
+ Right f -> return (Just (paths, vis, file, f))
-------------------------------------------------------------------------------
@@ -779,3 +785,4 @@ getPrologue dflags flags =
rightOrThrowE :: Either String b -> IO b
rightOrThrowE (Left msg) = throwE msg
rightOrThrowE (Right x) = pure x
+
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 9e39d98d..582c535d 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
@@ -246,11 +246,11 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2]
f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat
- [(concatMap (lookupCon dflags subdocs . noLocA . extFieldOcc . unLoc) (cd_fld_names r)) ++
- [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
+ [(concatMap (lookupCon dflags subdocs . noLocA . foExt . unLoc) (cd_fld_names r)) ++
+ [out dflags (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs]
- funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)
+ funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y)
apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
typeSig nm flds = operator nm ++ " :: " ++
@@ -279,12 +279,12 @@ ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names
name = out dflags $ map unL names
con_sig_ty = HsSig noExtField outer_bndrs theta_ty where
theta_ty = case mcxt of
- Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })
+ Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
Nothing -> tau_ty
tau_ty = foldr mkFunTy res_ty $
case args of PrefixConGADT pos_args -> map hsScaledThing pos_args
- RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds
- mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)
+ RecConGADT (L _ flds) _ -> map (cd_fld_type . unL) flds
+ mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b)
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)]
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 5bbea77b..89828e30 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -9,6 +9,7 @@ module Haddock.Backends.Hyperlinker
import Haddock.Types
import Haddock.Utils (writeUtf8File, out, verbose, Verbosity)
+import Haddock.InterfaceFile
import Haddock.Backends.Hyperlinker.Renderer
import Haddock.Backends.Hyperlinker.Parser
import Haddock.Backends.Hyperlinker.Types
@@ -20,8 +21,8 @@ import System.Directory
import System.FilePath
import GHC.Iface.Ext.Types ( pattern HiePath, HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) )
-import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..))
-import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc )
+import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result )
+import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc, srcSpanFile )
import Data.Map as M
import GHC.Data.FastString ( mkFastString )
import GHC.Unit.Module ( Module, moduleName )
@@ -58,21 +59,19 @@ ppHyperlinkedModuleSource :: Verbosity -> FilePath -> Bool -> SrcMaps -> Interfa
ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile iface of
Just hfp -> do
-- Parse the GHC-produced HIE file
- u <- mkSplitUniqSupply 'a'
- let nc = (initNameCache u [])
- ncu = NCU $ \f -> pure $ snd $ f nc
+ nc <- freshNameCache
HieFile { hie_hs_file = file
, hie_asts = HieASTs asts
, hie_types = types
, hie_hs_src = rawSrc
} <- hie_file_result
- <$> (readHieFile ncu hfp)
+ <$> (readHieFile nc hfp)
-- Get the AST and tokens corresponding to the source file we want
let fileFs = mkFastString file
mast | M.size asts == 1 = snd <$> M.lookupMin asts
| otherwise = M.lookup (HiePath (mkFastString file)) asts
- tokens = parse df file rawSrc
+ tokens' = parse df file rawSrc
ast = fromMaybe (emptyHieAst fileFs) mast
fullAst = recoverFullIfaceTypes df types ast
@@ -82,6 +81,14 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile
else out verbosity verbose $ unwords [ "couldn't find ast for"
, file, show (M.keys asts) ]
+ -- The C preprocessor can double the backslashes on tokens (see #19236),
+ -- which means the source spans will not be comparable and we will not
+ -- be able to associate the HieAST with the correct tokens.
+ --
+ -- We work around this by setting the source span of the tokens to the file
+ -- name from the HieAST
+ let tokens = fmap (\tk -> tk {tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens'
+
-- Produce and write out the hyperlinked sources
writeUtf8File path . renderToString pretty . render' fullAst $ tokens
Nothing -> return ()
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index d9a2e0cd..9f28d72a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -10,14 +10,17 @@ import Data.List ( isPrefixOf, isSuffixOf )
import qualified Data.ByteString as BS
+import GHC.Platform
import GHC.Types.SourceText
import GHC.Driver.Session
+import GHC.Driver.Config.Diagnostic
import GHC.Utils.Error ( pprLocMsgEnvelope )
import GHC.Data.FastString ( mkFastString )
-import GHC.Parser.Errors.Ppr ( pprError )
+import GHC.Parser.Errors.Ppr ()
+import qualified GHC.Types.Error as E
import GHC.Parser.Lexer as Lexer
( P(..), ParseResult(..), PState(..), Token(..)
- , initParserState, lexer, mkParserOpts, getErrorMessages)
+ , initParserState, lexer, mkParserOpts, getPsErrorMessages)
import GHC.Data.Bag ( bagToList )
import GHC.Utils.Outputable ( text, ($$) )
import GHC.Utils.Panic ( panic )
@@ -40,7 +43,7 @@ parse
parse dflags fpath bs = case unP (go False []) initState of
POk _ toks -> reverse toks
PFailed pst ->
- let err:_ = bagToList (fmap pprError (getErrorMessages pst)) in
+ let err:_ = bagToList (E.getMessages $ getPsErrorMessages pst) in
panic $ showSDoc dflags $
text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err
where
@@ -48,8 +51,10 @@ parse dflags fpath bs = case unP (go False []) initState of
initState = initParserState pflags buf start
buf = stringBufferFromByteString bs
start = mkRealSrcLoc (mkFastString fpath) 1 1
- pflags = mkParserOpts (warningFlags dflags)
- (extensionFlags dflags)
+ arch_os = platformArchOS (targetPlatform dflags)
+ pflags = mkParserOpts (extensionFlags dflags)
+ (initDiagOpts dflags)
+ (supportedLanguagesAndExtensions arch_os)
(safeImportsOn dflags)
False -- lex Haddocks as comment tokens
True -- produce comment tokens
@@ -233,6 +238,7 @@ classify tok =
ITrequires -> TkKeyword
ITinline_prag {} -> TkPragma
+ ITopaque_prag {} -> TkPragma
ITspec_prag {} -> TkPragma
ITspec_inline_prag {} -> TkPragma
ITsource_prag {} -> TkPragma
@@ -263,6 +269,7 @@ classify tok =
ITequal -> TkGlyph
ITlam -> TkGlyph
ITlcase -> TkGlyph
+ ITlcases -> TkGlyph
ITvbar -> TkGlyph
ITlarrow {} -> TkGlyph
ITrarrow {} -> TkGlyph
@@ -350,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
@@ -374,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 b045fa90..faa23d6a 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 )
@@ -843,7 +843,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
fieldPart = case con of
ConDeclGADT{con_g_args = con_args'} -> case con_args' of
-- GADT record declarations
- RecConGADT _ -> doConstrArgsWithDocs []
+ RecConGADT _ _ -> doConstrArgsWithDocs []
-- GADT prefix data constructors
PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
_ -> empty
@@ -887,12 +887,12 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
-- | Pretty-print a record field
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX
ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =
- decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
+ decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . foLabel . unLoc) names))
<+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
- mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
+ mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
-- | Pretty-print a bundled pattern synonym
@@ -983,11 +983,12 @@ ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
-ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX
-ppLContext Nothing _ = empty
-ppLContext (Just ctxt) unicode = ppContext (unLoc ctxt) unicode
-ppLContextNoArrow Nothing _ = empty
-ppLContextNoArrow (Just ctxt) unicode = ppContextNoArrow (unLoc ctxt) unicode
+ppLContext :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX
+ppLContext Nothing _ = empty
+ppLContext (Just ctxt) unicode = ppContext (unLoc ctxt) unicode
+
+ppLContextNoArrow :: LHsContext DocNameI -> Bool -> LaTeX
+ppLContextNoArrow ctxt unicode = ppContextNoArrow (unLoc ctxt) unicode
ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX
ppContextNoLocsMaybe [] _ = Nothing
@@ -1101,15 +1102,15 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode
= sep [ ppHsForAllTelescope tele unicode
, ppr_mono_lty ty unicode ]
ppr_mono_ty (HsQualTy _ ctxt ty) unicode
- = sep [ ppLContext ctxt unicode
+ = sep [ ppLContext (Just ctxt) unicode
, ppr_mono_lty ty unicode ]
ppr_mono_ty (HsFunTy _ mult ty1 ty2) u
= sep [ ppr_mono_lty ty1 u
, arr <+> ppr_mono_lty ty2 u ]
where arr = case mult of
- HsLinearArrow _ _ -> lollipop u
+ HsLinearArrow _ -> lollipop u
HsUnrestrictedArrow _ -> arrow u
- HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u
+ HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u <+> arrow u
ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty
ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
@@ -1132,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 2c3da7a9..3dea1012 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -167,7 +167,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep
leader' = leader <+> ppForAllPart unicode qual tele
do_args n leader (HsQualTy _ lctxt ltype)
- | null (fromMaybeContext lctxt)
+ | null (unLoc lctxt)
= do_largs n leader ltype
| otherwise
= (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
@@ -436,12 +436,14 @@ ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
-ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Unicode
+ppLContext :: Maybe (LHsContext DocNameI) -> Unicode
-> Qualification -> HideEmptyContexts -> Html
ppLContext Nothing u q h = ppContext [] u q h
ppLContext (Just c) u q h = ppContext (unLoc c) u q h
-ppLContextNoArrow Nothing u q h = ppContextNoArrow [] u q h
-ppLContextNoArrow (Just c) u q h = ppContextNoArrow (unLoc c) u q h
+
+ppLContextNoArrow :: LHsContext DocNameI -> Unicode
+ -> Qualification -> HideEmptyContexts -> Html
+ppLContextNoArrow c u q h = ppContextNoArrow (unLoc c) u q h
ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $
@@ -967,7 +969,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
fieldPart = case con of
ConDeclGADT{con_g_args = con_args'} -> case con_args' of
-- GADT record declarations
- RecConGADT _ -> [ doConstrArgsWithDocs [] ]
+ RecConGADT _ _ -> [ doConstrArgsWithDocs [] ]
-- GADT prefix data constructors
PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ]
_ -> []
@@ -1025,7 +1027,7 @@ ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
( hsep (punctuate comma [ ppBinder False (rdrNameOcc field)
| L _ name <- names
- , let field = (unLoc . rdrNameFieldOcc) name
+ , let field = (unLoc . foLabel) name
])
<+> dcolon unicode
<+> ppLType unicode qual HideEmptyContexts ltype
@@ -1035,12 +1037,12 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
-- Where there is more than one name, they all have the same documentation
- mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst
+ mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= combineDocumentation . fst
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
ppShortField summary unicode qual (ConDeclField _ names ltype _)
- = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))
+ = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . foLabel . unLoc) names))
<+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype
@@ -1185,13 +1187,13 @@ patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ = Sho
hasNonEmptyContext t =
case unLoc t of
HsForAllTy _ _ s -> hasNonEmptyContext s
- HsQualTy _ cxt s -> if null (fromMaybeContext cxt) then hasNonEmptyContext s else True
+ HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
HsFunTy _ _ _ s -> hasNonEmptyContext s
_ -> False
isFirstContextEmpty t =
case unLoc t of
HsForAllTy _ _ s -> isFirstContextEmpty s
- HsQualTy _ cxt _ -> null (fromMaybeContext cxt)
+ HsQualTy _ cxt _ -> null (unLoc cxt)
HsFunTy _ _ _ s -> isFirstContextEmpty s
_ -> False
@@ -1230,7 +1232,7 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode qual emptyCtxts
= ppForAllPart unicode qual tele <+> ppr_mono_lty ty unicode qual emptyCtxts
ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts
- = ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts
+ = ppLContext (Just ctxt) unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts
-- UnicodeSyntax alternatives
ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _
@@ -1248,9 +1250,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =
, arr <+> ppr_mono_lty ty2 u q e
]
where arr = case mult of
- HsLinearArrow _ _ -> lollipop u
+ HsLinearArrow _ -> lollipop u
HsUnrestrictedArrow _ -> arrow u
- HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
+ HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
ppr_mono_ty (HsTupleTy _ con tys) u q _ =
tupleParens con (map (ppLType u q HideEmptyContexts) tys)
@@ -1279,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 10180361..fd5300d2 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -19,10 +19,6 @@ module Haddock.Convert (
PrintRuntimeReps(..),
) where
-#ifndef __HLINT__
-#include "HsVersions.h"
-#endif
-
import GHC.Data.Bag ( emptyBag )
import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..), TopLevelFlag(..) )
import GHC.Types.SourceText (SourceText(..))
@@ -49,9 +45,9 @@ import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName
import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
, liftedDataConKey, boxedRepDataConKey )
import GHC.Types.Unique ( getUnique )
-import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength
+import GHC.Utils.Misc ( chkAppend, dropList, equalLength
, filterByList, filterOut )
-import GHC.Utils.Panic ( assertPanic )
+import GHC.Utils.Panic.Plain ( assert )
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.SrcLoc
@@ -128,7 +124,7 @@ tyThingToLHsDecl prr t = case t of
vs = tyConVisibleTyVars (classTyCon cl)
in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl
- { tcdCtxt = synifyCtx (classSCTheta cl)
+ { tcdCtxt = Just $ synifyCtx (classSCTheta cl)
, tcdLName = synifyNameN cl
, tcdTyVars = synifyTyVars vs
, tcdFixity = synifyFixity cl
@@ -306,7 +302,7 @@ synifyTyCon _prr coax tc
alg_deriv = []
defn = HsDataDefn { dd_ext = noExtField
, dd_ND = alg_nd
- , dd_ctxt = alg_ctx
+ , dd_ctxt = Just alg_ctx
, dd_cType = Nothing
, dd_kindSig = kindSig
, dd_cons = cons
@@ -345,14 +341,14 @@ synifyInjectivityAnn Nothing _ _ = Nothing
synifyInjectivityAnn _ _ NotInjective = Nothing
synifyInjectivityAnn (Just lhs) tvs (Injective inj) =
let rhs = map (noLocA . tyVarName) (filterByList inj tvs)
- in Just $ noLoc $ InjectivityAnn noAnn (noLocA lhs) rhs
+ in Just $ noLocA $ InjectivityAnn noAnn (noLocA lhs) rhs
synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn
synifyFamilyResultSig Nothing kind
- | isLiftedTypeKind kind = noLoc $ NoSig noExtField
- | otherwise = noLoc $ KindSig noExtField (synifyKindSig kind)
+ | isLiftedTypeKind kind = noLocA $ NoSig noExtField
+ | otherwise = noLocA $ KindSig noExtField (synifyKindSig kind)
synifyFamilyResultSig (Just name) kind =
- noLoc $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA name) (synifyKindSig kind))
+ noLocA $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA name) (synifyKindSig kind))
-- User beware: it is your responsibility to pass True (use_gadt_syntax)
-- for any constructor that would be misrepresented by omitting its
@@ -379,7 +375,7 @@ synifyDataCon use_gadt_syntax dc =
-- skip any EqTheta, use 'orig'inal syntax
ctx | null theta = Nothing
- | otherwise = synifyCtx theta
+ | otherwise = Just $ synifyCtx theta
linear_tys =
zipWith (\ty bang ->
@@ -391,7 +387,7 @@ synifyDataCon use_gadt_syntax dc =
field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys
con_decl_field fl synTy = noLocA $
- ConDeclField noAnn [noLoc $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel fl)] synTy
+ ConDeclField noAnn [noLocA $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel fl)] synTy
Nothing
mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn)
@@ -405,7 +401,7 @@ synifyDataCon use_gadt_syntax dc =
mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn
mk_gadt_arg_tys
- | use_named_field_syntax = RecConGADT (noLocA field_tys)
+ | use_named_field_syntax = RecConGADT (noLocA field_tys) noHsUniTok
| otherwise = PrefixConGADT (map hsUnrestricted linear_tys)
-- finally we get synifyDataCon's result!
@@ -466,8 +462,8 @@ synifyTcIdSig vs (i, dm) =
mainSig t = synifySigType DeleteTopLevelQuantification vs t
defSig t = synifySigType ImplicitizeForAll vs t
-synifyCtx :: [PredType] -> Maybe (LHsContext GhcRn)
-synifyCtx ts = Just (noLocA ( map (synifyType WithinType []) ts))
+synifyCtx :: [PredType] -> LHsContext GhcRn
+synifyCtx ts = noLocA ( map (synifyType WithinType []) ts)
synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
@@ -610,23 +606,25 @@ 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
, Just x <- isStrLitTy name
- = noLocA $ HsIParamTy noAnn (noLoc $ HsIPName x) (synifyType WithinType vs ty)
+ = noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType vs ty)
-- 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))
@@ -801,9 +799,9 @@ noKindTyVars _ _ = emptyVarSet
synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn
synifyMult vs t = case t of
- One -> HsLinearArrow NormalSyntax Nothing
- Many -> HsUnrestrictedArrow NormalSyntax
- ty -> HsExplicitMult NormalSyntax Nothing (synifyType WithinType vs ty)
+ One -> HsLinearArrow (HsPct1 noHsTok noHsUniTok)
+ Many -> HsUnrestrictedArrow noHsUniTok
+ ty -> HsExplicitMult noHsTok (synifyType WithinType vs ty) noHsUniTok
@@ -935,8 +933,8 @@ tcSplitForAllTysReqPreserveSynonyms :: Type -> ([ReqTVBinder], Type)
tcSplitForAllTysReqPreserveSynonyms ty =
let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isVisibleArgFlag ty
req_bndrs = mapMaybe mk_req_bndr_maybe all_bndrs in
- ASSERT( req_bndrs `equalLength` all_bndrs )
- (req_bndrs, body)
+ assert ( req_bndrs `equalLength` all_bndrs)
+ (req_bndrs, body)
where
mk_req_bndr_maybe :: TyCoVarBinder -> Maybe ReqTVBinder
mk_req_bndr_maybe (Bndr tv argf) = case argf of
@@ -948,8 +946,8 @@ tcSplitForAllTysInvisPreserveSynonyms :: Type -> ([InvisTVBinder], Type)
tcSplitForAllTysInvisPreserveSynonyms ty =
let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isInvisibleArgFlag ty
inv_bndrs = mapMaybe mk_inv_bndr_maybe all_bndrs in
- ASSERT( inv_bndrs `equalLength` all_bndrs )
- (inv_bndrs, body)
+ assert ( inv_bndrs `equalLength` all_bndrs)
+ (inv_bndrs, body)
where
mk_inv_bndr_maybe :: TyCoVarBinder -> Maybe InvisTVBinder
mk_inv_bndr_maybe (Bndr tv argf) = case argf of
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 19494c8e..6c1719dc 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE BangPatterns, FlexibleInstances #-}
{-# 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
@@ -171,17 +172,17 @@ getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs
, sig_body = theta_ty })
where
theta_ty | Just theta <- mcxt
- = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = Just theta, hst_body = tau_ty })
+ = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = theta, hst_body = tau_ty })
| otherwise
= tau_ty
-- tau_ty :: LHsType DocNameI
tau_ty = case args of
- RecConGADT flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty
+ RecConGADT flds _ -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty
PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
- mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)
+ mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b)
getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
-- Should only be called on ConDeclGADT
@@ -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 _ = []
@@ -226,12 +227,11 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
, hst_ctxt = add_ctxt ctxt, hst_body = ty })
go_ty (L loc ty)
= L loc (HsQualTy { hst_xqual = noExtField
- , hst_ctxt = add_ctxt Nothing, hst_body = L loc ty })
+ , 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 Nothing = Just $ noLocA [extra_pred]
- add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds)
+ add_ctxt (L loc preds) = L loc (extra_pred : preds)
addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine
@@ -284,14 +284,14 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
ConDeclGADT { con_g_args = con_args' } -> case con_args' of
PrefixConGADT {} -> Just d
- RecConGADT fields
+ RecConGADT fields _
| all field_avail (unLoc fields) -> Just d
| otherwise -> Just (d { con_g_args = PrefixConGADT (field_types $ unLoc fields) })
-- see above
where
field_avail :: LConDeclField GhcRn -> Bool
field_avail (L _ (ConDeclField _ fs _ _))
- = all (\f -> extFieldOcc (unLoc f) `elem` names) fs
+ = all (\f -> foExt (unLoc f) `elem` names) fs
field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ]
@@ -356,9 +356,7 @@ reparenTypePrec = go
go p (HsQualTy x ctxt ty)
= let p' [_] = PREC_CTX
p' _ = PREC_TOP -- parens will get added anyways later...
- ctxt' = case ctxt of
- Nothing -> Nothing
- Just c -> Just $ mapXRec @a (\xs -> map (goL (p' xs)) xs) c
+ ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt
in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty)
-- = paren p PREC_FUN $ HsQualTy x (fmap (mapXRec @a (map reparenLType)) ctxt) (reparenLType ty)
go p (HsFunTy x w ty1 ty2)
@@ -367,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
@@ -469,7 +467,7 @@ instance Parent (ConDecl GhcRn) where
children con =
case getRecConArgs_maybe con of
Nothing -> []
- Just flds -> map (extFieldOcc . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds)
+ Just flds -> map (foExt . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds)
instance Parent (TyClDecl GhcRn) where
children d
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 02e7ed38..19113107 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -55,12 +55,12 @@ import qualified Data.Set as Set
import GHC hiding (verbosity)
import GHC.Data.FastString (unpackFS)
-import GHC.Data.Graph.Directed (flattenSCCs)
-import GHC.Driver.Env (hsc_dflags, hsc_home_unit, hsc_logger, hsc_static_plugins, hsc_units)
+import GHC.Data.Graph.Directed
+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)
@@ -68,8 +68,8 @@ import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)
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 (ModuleGraphNode (..))
-import GHC.Unit.Module.ModSummary (emsModSummary, isBootSummary)
+import GHC.Unit.Module.Graph
+import GHC.Unit.Module.ModSummary (isBootSummary)
import GHC.Unit.Types (IsBootInterface (..))
import GHC.Utils.Error (withTiming)
@@ -145,20 +145,19 @@ createIfaces verbosity modules flags instIfaceMap = do
let
installHaddockPlugin :: HscEnv -> HscEnv
- installHaddockPlugin hsc_env = hsc_env
- {
- hsc_dflags =
- gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy
- , 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
-- alive to be able to find all the instances.
modifySession installHaddockPlugin
- targets <- mapM (\filePath -> guessTarget filePath Nothing) modules
+ targets <- mapM (\filePath -> guessTarget filePath Nothing Nothing) modules
setTargets targets
loadOk <- withTimingM "load" (const ()) $
@@ -173,13 +172,59 @@ createIfaces verbosity modules flags instIfaceMap = do
moduleSet <- liftIO getModules
let
+ -- We topologically sort the module graph including boot files,
+ -- so it should be acylic (hopefully we failed much earlier if this is not the case)
+ -- We then filter out boot modules from the resultant topological sort
+ --
+ -- We do it this way to make 'buildHomeLinks' a bit more stable
+ -- 'buildHomeLinks' depends on the topological order of its input in order
+ -- to construct its result. In particular, modules closer to the bottom of
+ -- the dependency chain are to be prefered for link destinations.
+ --
+ -- If there are cycles in the graph, then this order is indeterminate
+ -- (the nodes in the cycle can be ordered in any way).
+ -- While 'topSortModuleGraph' does guarantee stability for equivalent
+ -- module graphs, seemingly small changes in the ModuleGraph can have
+ -- big impacts on the `LinkEnv` constructed.
+ --
+ -- For example, suppose
+ -- G1 = A.hs -> B.hs -> C.hs (where '->' denotes an import).
+ --
+ -- Then suppose C.hs is changed to have a cyclic dependency on A
+ --
+ -- G2 = A.hs -> B.hs -> C.hs -> A.hs-boot
+ --
+ -- For G1, `C.hs` is preferred for link destinations. However, for G2,
+ -- the topologically sorted order not taking into account boot files (so
+ -- C -> A) is completely indeterminate.
+ -- Using boot files to resolve cycles, we end up with the original order
+ -- [C, B, A] (in decreasing order of preference for links)
+ --
+ -- This exact case came up in testing for the 'base' package, where there
+ -- is a big module cycle involving 'Prelude' on windows, but the cycle doesn't
+ -- include 'Prelude' on non-windows platforms. This lead to drastically different
+ -- LinkEnv's (and failing haddockHtmlTests) across the platforms
+ --
+ -- In effect, for haddock users this behaviour (using boot files to eliminate cycles)
+ -- means that {-# SOURCE #-} imports no longer count towards re-ordering
+ -- the preference of modules for linking.
+ --
+ -- i.e. if module A imports B, then B is preferred over A,
+ -- but if module A {-# SOURCE #-} imports B, then we can't say the same.
+ --
+ go (AcyclicSCC (ModuleNode _ ms))
+ | NotBoot <- isBootSummary ms = [ms]
+ | otherwise = []
+ go (AcyclicSCC _) = []
+ go (CyclicSCC _) = error "haddock: module graph cyclic even with boot files"
+
ifaces :: [Interface]
ifaces =
[ Map.findWithDefault
(error "haddock:iface")
- (ms_mod (emsModSummary ems))
+ (ms_mod ms)
ifaceMap
- | ModuleNode ems <- flattenSCCs $ topSortModuleGraph True modGraph Nothing
+ | ms <- concatMap go $ topSortModuleGraph False modGraph Nothing
]
return (ifaces, moduleSet)
@@ -212,7 +257,7 @@ plugin verbosity flags instIfaceMap = liftIO $ do
| otherwise = do
hsc_env <- getTopEnv
ifaces <- liftIO $ readIORef ifaceMapRef
- (iface, modules) <- withTiming (hsc_logger hsc_env) (hsc_dflags hsc_env)
+ (iface, modules) <- withTiming (hsc_logger hsc_env)
"processModule" (const ()) $
processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env
@@ -266,9 +311,8 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
(!interface, messages) <- do
logger <- getLogger
- dflags <- getDynFlags
{-# SCC createInterface #-}
- withTiming logger dflags "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
+ withTiming logger "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
createInterface1 flags unit_state mod_summary tc_gbl_env
ifaces inst_ifaces
@@ -318,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) ++ ")"
_ -> ""
@@ -356,7 +400,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env
-- The interfaces are passed in in topologically sorted order, but we start
-- by reversing the list so we can do a foldl.
buildHomeLinks :: [Interface] -> LinkEnv
-buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
+buildHomeLinks ifaces = foldl' upd Map.empty (reverse ifaces)
where
upd old_env iface
| OptHide `elem` ifaceOptions iface = old_env
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index cc9569af..4527360f 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -135,12 +135,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 17b9f367..b832128f 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -34,7 +34,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)
@@ -56,7 +56,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)
@@ -64,12 +64,13 @@ 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)
import GHC.Types.SourceFile (HscSource (..))
import GHC.Types.SourceText (SourceText (..), sl_fs)
+import GHC.Unit.Types
import qualified GHC.Types.SrcLoc as SrcLoc
import qualified GHC.Unit.Module as Module
import GHC.Unit.Module.ModSummary (msHsFilePath)
@@ -77,6 +78,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
{
@@ -253,7 +255,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)
@@ -347,8 +349,7 @@ mkAliasMap state impDecls =
-- them to the user. We should reuse that information;
-- or at least reuse the renamed imports, which know what
-- they import!
- (fmap Module.fsToUnit $
- fmap sl_fs $ ideclPkgQual impDecl)
+ (ideclPkgQual impDecl)
(case ideclName impDecl of SrcLoc.L _ name -> name),
alias))
impDecls
@@ -391,11 +392,11 @@ unrestrictedModuleImports idecls =
-- Similar to GHC.lookupModule
-- ezyang: Not really...
lookupModuleDyn ::
- UnitState -> Maybe Unit -> ModuleName -> Module
-lookupModuleDyn _ (Just pkgId) mdlName =
- Module.mkModule pkgId mdlName
-lookupModuleDyn state Nothing mdlName =
- case lookupModuleInAllUnits state mdlName of
+ UnitState -> PkgQual -> ModuleName -> Module
+lookupModuleDyn state pkg_qual mdlName = case pkg_qual of
+ OtherPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName
+ ThisPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName
+ NoPkgQual -> case lookupModuleInAllUnits state mdlName of
(m,_):_ -> m
[] -> Module.mkModule Module.mainUnit mdlName
@@ -404,7 +405,7 @@ lookupModuleDyn state Nothing mdlName =
-- 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
@@ -415,18 +416,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
-------------------------------------------------------------------------------
@@ -478,7 +479,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
@@ -511,36 +512,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
@@ -571,7 +576,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]:
------------
@@ -633,11 +654,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 $
@@ -705,7 +726,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
@@ -784,7 +805,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
let
patSynNames =
- concatMap (getMainDeclBinder . fst) bundledPatSyns
+ concatMap (getMainDeclBinder emptyOccEnv . fst) bundledPatSyns
fixities =
[ (n, f)
@@ -1006,17 +1027,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
@@ -1041,7 +1062,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
@@ -1109,7 +1130,7 @@ extractDecl declMap name decl
, Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d))
, ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
, L _ n <- ns
- , extFieldOcc n == name
+ , foExt n == name
]
in case matches of
[d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0)
@@ -1138,17 +1159,17 @@ extractPatternSyn nm t tvs cons =
InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
ConDeclGADT { con_g_args = con_args' } -> case con_args' of
PrefixConGADT args' -> map hsScaledThing args'
- RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields
+ RecConGADT (L _ fields) _ -> cd_fld_type . unLoc <$> fields
typ = longArrow args (data_ty con)
typ' =
case con of
- ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField (Just cxt) typ)
+ ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField cxt typ)
_ -> typ
- typ'' = noLocA (HsQualTy noExtField Nothing typ')
+ typ'' = noLocA (HsQualTy noExtField (noLocA []) typ')
in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'')
longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
- longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)) output inputs
+ longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y)) output inputs
data_ty con
| ConDeclGADT{} <- con = con_res_ty con
@@ -1165,12 +1186,12 @@ extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
case getRecConArgs_maybe con of
Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
- pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))
+ pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) data_ty (getBangType ty))))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
- matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds
- , L l n <- ns, extFieldOcc n == nm ]
+ matching_fields flds = [ (locA l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds
+ , L l n <- ns, foExt n == nm ]
data_ty
-- ResTyGADT _ ty <- con_res con = ty
| ConDeclGADT{} <- con = con_res_ty con
@@ -1196,10 +1217,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 _ = []
@@ -1216,6 +1237,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 d769f0cc..4e1964af 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 2833df49..6057bf75 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))
@@ -245,9 +245,10 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
renameMaybeInjectivityAnn = traverse renameInjectivityAnn
renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)
-renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u)
-renameArrow (HsLinearArrow u a) = return (HsLinearArrow u a)
-renameArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p
+renameArrow (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr)
+renameArrow (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr))
+renameArrow (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr))
+renameArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p
renameType :: HsType GhcRn -> RnM (HsType DocNameI)
renameType t = case t of
@@ -258,7 +259,7 @@ renameType t = case t of
, hst_tele = tele', hst_body = ltype' })
HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
- lcontext' <- traverse renameLContext lcontext
+ lcontext' <- renameLContext lcontext
ltype' <- renameLType ltype
return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' })
@@ -289,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
@@ -316,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
@@ -505,15 +507,15 @@ renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
, con_mb_cxt = lcontext, con_args = details
, con_doc = mbldoc
- , con_forall = forall }) = do
+ , con_forall = forall_ }) = do
lname' <- renameL lname
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_forall = forall_ -- Remove when #18311 is fixed
, con_args = details', con_doc = mbldoc' })
renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs
@@ -548,9 +550,9 @@ renameH98Details (InfixCon a b) = do
renameGADTDetails :: HsConDeclGADTDetails GhcRn
-> RnM (HsConDeclGADTDetails DocNameI)
-renameGADTDetails (RecConGADT (L l fields)) = do
+renameGADTDetails (RecConGADT (L l fields) arr) = do
fields' <- mapM renameConDeclFieldField fields
- return (RecConGADT (L (locA l) fields'))
+ return (RecConGADT (L (locA l) fields') arr)
renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps
renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 16f00fda..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,9 +133,9 @@ 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
- | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) la 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
sugarOperators typ = typ
@@ -283,7 +284,7 @@ renameType (HsForAllTy x tele lt) =
<*> renameLType lt
renameType (HsQualTy x lctxt lt) =
HsQualTy x
- <$> renameMContext lctxt
+ <$> renameLContext lctxt
<*> renameLType lt
renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name
renameType t@(HsStarTy _ _) = pure t
@@ -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
@@ -311,7 +312,7 @@ renameType t@(HsTyLit _ _) = pure t
renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)
-renameHsArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p
+renameHsArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p
renameHsArrow mult = pure mult
@@ -324,11 +325,10 @@ renameLKind = renameLType
renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameLTypes = mapM renameLType
-renameMContext :: Maybe (LHsContext GhcRn) -> Rename (IdP GhcRn) (Maybe (LHsContext GhcRn))
-renameMContext Nothing = return Nothing
-renameMContext (Just (L l ctxt)) = do
+renameLContext :: LHsContext GhcRn -> Rename (IdP GhcRn) (LHsContext GhcRn)
+renameLContext (L l ctxt) = do
ctxt' <- renameContext ctxt
- return (Just (L l ctxt'))
+ return (L l ctxt')
renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
renameContext = renameLTypes
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index fa51bcbc..f9861708 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -17,38 +17,30 @@
-----------------------------------------------------------------------------
module Haddock.InterfaceFile (
InterfaceFile(..), PackageInfo(..), ifUnitId, ifModule,
- PackageInterfaces(..), mkPackageInterfaces, ppPackageInfo, readInterfaceFile,
- nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile,
+ PackageInterfaces(..), mkPackageInterfaces, ppPackageInfo,
+ readInterfaceFile, writeInterfaceFile,
+ freshNameCache,
binaryInterfaceVersion, binaryInterfaceVersionCompatibility
) where
import Haddock.Types
-import Control.Monad
-import Control.Monad.IO.Class ( MonadIO(..) )
-import Data.Array
import Data.IORef
-import Data.List (mapAccumR)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Version
import Data.Word
import Text.ParserCombinators.ReadP (readP_to_S)
-import GHC.Iface.Binary (getSymtabName, getDictFastString)
+import GHC.Iface.Binary (getWithUserData, putSymbolTable)
import GHC.Unit.State
import GHC.Utils.Binary
import GHC.Data.FastMutInt
import GHC.Data.FastString
import GHC hiding (NoLink)
-import GHC.Driver.Monad (withSession)
-import GHC.Driver.Env
import GHC.Types.Name.Cache
-import GHC.Iface.Env
-import GHC.Types.Name
import GHC.Types.Unique.FM
-import GHC.Types.Unique.Supply
import GHC.Types.Unique
import Haddock.Options (Visibility (..))
@@ -131,12 +123,11 @@ binaryInterfaceMagic = 0xD0Cface
-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
--
binaryInterfaceVersion :: Word16
-#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)
-binaryInterfaceVersion = 39
+#if MIN_VERSION_ghc(9,4,0) && !MIN_VERSION_ghc(9,5,0)
+binaryInterfaceVersion = 41
binaryInterfaceVersionCompatibility :: [Word16]
-binaryInterfaceVersionCompatibility = [37, 38, binaryInterfaceVersion]
-#elif defined(__HLINT__)
+binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
#else
#error Unsupported GHC version
#endif
@@ -203,103 +194,31 @@ writeInterfaceFile filename iface = do
return ()
-type NameCacheAccessor m = (m NameCache, NameCache -> m ())
-
-
-nameCacheFromGhc :: forall m. GhcMonad m => NameCacheAccessor m
-nameCacheFromGhc = ( read_from_session , write_to_session )
- where
- read_from_session = do
- ref <- withSession (return . hsc_NC)
- liftIO $ readIORef ref
- write_to_session nc' = do
- ref <- withSession (return . hsc_NC)
- liftIO $ writeIORef ref nc'
-
-
-freshNameCache :: NameCacheAccessor IO
-freshNameCache = ( create_fresh_nc , \_ -> return () )
- where
- create_fresh_nc = do
- u <- mkSplitUniqSupply 'a' -- ??
- return (initNameCache u [])
-
+freshNameCache :: IO NameCache
+freshNameCache = initNameCache 'a' -- ??
+ []
-- | Read a Haddock (@.haddock@) interface file. Return either an
-- 'InterfaceFile' or an error message.
--
-- This function can be called in two ways. Within a GHC session it will
-- update the use and update the session's name cache. Outside a GHC session
--- a new empty name cache is used. The function is therefore generic in the
--- monad being used. The exact monad is whichever monad the first
--- argument, the getter and setter of the name cache, requires.
---
-readInterfaceFile :: forall m.
- MonadIO m
- => NameCacheAccessor m
+-- a new empty name cache is used.
+readInterfaceFile :: NameCache
-> FilePath
-> Bool -- ^ Disable version check. Can cause runtime crash.
- -> m (Either String InterfaceFile)
-readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do
- bh0 <- liftIO $ readBinMem filename
-
- magic <- liftIO $ get bh0
- version <- liftIO $ get bh0
-
- case () of
- _ | magic /= binaryInterfaceMagic -> return . Left $
- "Magic number mismatch: couldn't load interface file: " ++ filename
- | not bypass_checks
- , (version `notElem` binaryInterfaceVersionCompatibility) -> return . Left $
- "Interface file is of wrong version: " ++ filename
- | otherwise -> with_name_cache $ \update_nc -> do
-
- dict <- get_dictionary bh0
-
- -- read the symbol table so we are capable of reading the actual data
- bh1 <- do
- let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
- (getDictFastString dict)
- symtab <- update_nc (get_symbol_table bh1)
- return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab)
- (getDictFastString dict)
-
- -- load the actual data
- iface <- liftIO $ getInterfaceFile bh1 version
- return (Right iface)
- where
- with_name_cache :: forall a.
- ((forall n b. MonadIO n
- => (NameCache -> n (NameCache, b))
- -> n b)
- -> m a)
- -> m a
- with_name_cache act = do
- nc_var <- get_name_cache >>= (liftIO . newIORef)
- x <- act $ \f -> do
- nc <- liftIO $ readIORef nc_var
- (nc', x) <- f nc
- liftIO $ writeIORef nc_var nc'
- return x
- liftIO (readIORef nc_var) >>= set_name_cache
- return x
-
- get_dictionary bin_handle = liftIO $ do
- dict_p <- get bin_handle
- data_p <- tellBin bin_handle
- seekBin bin_handle dict_p
- dict <- getDictionary bin_handle
- seekBin bin_handle data_p
- return dict
-
- get_symbol_table bh1 theNC = liftIO $ do
- symtab_p <- get bh1
- data_p' <- tellBin bh1
- seekBin bh1 symtab_p
- (nc', symtab) <- getSymbolTable bh1 theNC
- seekBin bh1 data_p'
- return (nc', symtab)
-
+ -> IO (Either String InterfaceFile)
+readInterfaceFile name_cache filename bypass_checks = do
+ bh <- readBinMem filename
+
+ magic <- get bh
+ if magic /= binaryInterfaceMagic
+ then return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename
+ else do
+ version <- get bh
+ if not bypass_checks && (version `notElem` binaryInterfaceVersionCompatibility)
+ then return . Left $ "Interface file is of wrong version: " ++ filename
+ else Right <$> getWithUserData name_cache bh
-------------------------------------------------------------------------------
-- * Symbol table
@@ -350,56 +269,6 @@ data BinDictionary = BinDictionary {
-- indexed by FastString
}
-
-putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
-putSymbolTable bh next_off symtab = do
- put_ bh next_off
- let names = elems (array (0,next_off-1) (eltsUFM symtab))
- mapM_ (\n -> serialiseName bh n symtab) names
-
-
-getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
-getSymbolTable bh namecache = do
- sz <- get bh
- od_names <- replicateM sz (get bh)
- let arr = listArray (0,sz-1) names
- (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names
- return (namecache', arr)
-
-
-type OnDiskName = (Unit, ModuleName, OccName)
-
-
-fromOnDiskName
- :: Array Int Name
- -> NameCache
- -> OnDiskName
- -> (NameCache, Name)
-fromOnDiskName _ nc (pid, mod_name, occ) =
- let
- modu = mkModule pid mod_name
- cache = nsNames nc
- in
- case lookupOrigNameCache cache modu occ of
- Just name -> (nc, name)
- Nothing ->
- let
- us = nsUniqs nc
- u = uniqFromSupply us
- name = mkExternalName u modu occ noSrcSpan
- new_cache = extendNameCache cache modu occ name
- in
- case splitUniqSupply us of { (us',_) ->
- ( nc{ nsUniqs = us', nsNames = new_cache }, name )
- }
-
-
-serialiseName :: BinHandle -> Name -> UniqFM Name (Int,Name) -> IO ()
-serialiseName bh name _ = do
- let modu = nameModule name
- put_ bh (moduleUnit modu, moduleName modu, nameOccName name)
-
-
-------------------------------------------------------------------------------
-- * GhcBinary instances
-------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs
index a7230e25..850fdf7f 100644
--- a/haddock-api/src/Haddock/Parser.hs
+++ b/haddock-api/src/Haddock/Parser.hs
@@ -18,7 +18,7 @@ import Documentation.Haddock.Types
import Haddock.Types
import GHC.Driver.Session ( DynFlags )
-import GHC.Driver.Config
+import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Data.FastString ( fsLit )
import GHC.Parser.Lexer ( initParserState, unP, ParseResult(POk, PFailed) )
import GHC.Parser ( parseIdentifier )
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 08d74f53..6c98c830 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP, DeriveDataTypeable, 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
@@ -709,8 +711,8 @@ type instance Anno (HsTyVarBndr flag DocNameI) = SrcSpanAnnA
type instance Anno [LocatedA (HsType DocNameI)] = SrcSpanAnnC
type instance Anno (HsType DocNameI) = SrcSpanAnnA
type instance Anno (DataFamInstDecl DocNameI) = SrcSpanAnnA
-type instance Anno (DerivStrategy DocNameI) = SrcSpan
-type instance Anno (FieldOcc DocNameI) = SrcSpan
+type instance Anno (DerivStrategy DocNameI) = SrcAnn NoEpAnns
+type instance Anno (FieldOcc DocNameI) = SrcAnn NoEpAnns
type instance Anno (ConDeclField DocNameI) = SrcSpan
type instance Anno (Located (ConDeclField DocNameI)) = SrcSpan
type instance Anno [Located (ConDeclField DocNameI)] = SrcSpan
@@ -720,9 +722,9 @@ type instance Anno (TyFamInstDecl DocNameI) = SrcSpanAnnA
type instance Anno [LocatedA (TyFamInstDecl DocNameI)] = SrcSpanAnnL
type instance Anno (FamilyDecl DocNameI) = SrcSpan
type instance Anno (Sig DocNameI) = SrcSpan
-type instance Anno (InjectivityAnn DocNameI) = SrcSpan
+type instance Anno (InjectivityAnn DocNameI) = SrcAnn NoEpAnns
type instance Anno (HsDecl DocNameI) = SrcSpanAnnA
-type instance Anno (FamilyResultSig DocNameI) = SrcSpan
+type instance Anno (FamilyResultSig DocNameI) = SrcAnn NoEpAnns
type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA
type instance Anno (HsSigType DocNameI) = SrcSpanAnnA
@@ -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-22 21:52:28 +0000