diff options
Diffstat (limited to 'haddock-api')
19 files changed, 370 insertions, 430 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 22eec6dc..5923ba37 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -1,10 +1,10 @@ -cabal-version: 2.0 +cabal-version: 3.0 name: haddock-api -version: 2.26.1 +version: 2.27.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries -license: BSD2 +license: BSD-2-Clause license-file: LICENSE author: Simon Marlow, David Waern maintainer: Alec Theriault <alec.theriault@gmail.com>, Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> @@ -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.2.* +tested-with: GHC==9.4.* extra-source-files: CHANGES.md @@ -44,9 +44,9 @@ library -- this package typically supports only single major versions build-depends: base ^>= 4.16.0 - , ghc ^>= 9.2 + , ghc ^>= 9.4 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.10.0 + , haddock-library ^>= 1.11 , xhtml ^>= 3000.2.2 , parsec ^>= 3.1.13.0 @@ -180,9 +180,9 @@ test-suite spec Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: ghc ^>= 9.2 + build-depends: ghc ^>= 9.4 , ghc-paths ^>= 0.1.0.12 - , haddock-library ^>= 1.10.0 + , haddock-library ^>= 1.11 , xhtml ^>= 3000.2.2 , hspec ^>= 2.9 , parsec ^>= 3.1.13.0 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..ea664bcf 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,10 +74,12 @@ 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) import GHC.Data.FastString @@ -193,9 +196,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 +225,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 +269,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 +309,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 +332,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 +437,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 +449,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 +469,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 +505,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 +523,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 +784,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..9316da6d 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,13 +21,11 @@ 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 ) -import GHC.Types.Name.Cache ( initNameCache ) -import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) -- | Generate hyperlinked source for given interfaces. @@ -58,21 +57,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 +79,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..92b727ac 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -46,7 +46,7 @@ import Haddock.Types (DocOption (..), Documentation (..), ExportItem (..), Iface import Haddock.Utils (Verbosity (..), normal, out, verbose) import Control.Monad (unless, when) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Class (MonadIO) import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.List (foldl', isPrefixOf, nub) import Text.Printf (printf) @@ -54,23 +54,16 @@ import qualified Data.Map as Map 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) -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.Types (IsBootInterface (..)) +import GHC.Unit.Module.Graph import GHC.Utils.Error (withTiming) #if defined(mingw32_HOST_OS) @@ -145,20 +138,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 +165,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 +250,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 +304,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 +355,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 +393,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..e3c4a529 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) @@ -54,9 +54,9 @@ import Data.Traversable (for) import GHC hiding (lookupName) import GHC.Core.Class (ClassMinimalDef, classMinimalDef) import GHC.Core.ConLike (ConLike (..)) -import GHC.Data.FastString (bytesFS, unpackFS) +import GHC.Data.FastString (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,15 +1130,14 @@ 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) _ -> Left "internal: extractDecl (ClsInstD)" _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: HasCallStack - => Name -> Name +extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons = @@ -1138,17 +1158,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 +1185,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 +1216,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 +1236,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..455f3314 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 @@ -52,11 +53,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 +70,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..ca6b9e74 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -132,9 +132,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 +283,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 +293,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 +311,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 +324,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..e6db49c0 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 ------------------------------------------------------------------------------- @@ -440,19 +309,6 @@ putInterfaceFile_ bh (InterfaceFile env info ifaces) = do put_ bh info put_ bh ifaces -getInterfaceFile :: BinHandle -> Word16 -> IO InterfaceFile -getInterfaceFile bh v | v <= 38 = do - env <- get bh - let info = PackageInfo (PackageName mempty) (makeVersion []) - ifaces <- get bh - return (InterfaceFile env info ifaces) -getInterfaceFile bh _ = do - env <- get bh - info <- get bh - ifaces <- get bh - return (InterfaceFile env info ifaces) - - instance Binary InstalledInterface where put_ bh (InstalledInterface modu is_sig info docMap argMap exps visExps opts fixMap) = do 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 |