[Git][ghc/ghc][master] haddock: Use the more precise SDocContext instead of DynFlags
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Jun 22 14:44:10 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
5759133f by Hécate Kleidukos at 2024-06-22T10:42:49-04:00
haddock: Use the more precise SDocContext instead of DynFlags
The pervasive usage of DynFlags (the parsed command-line options passed
to ghc) blurs the border between different components of Haddock, and
especially those that focus solely on printing text on the screen.
In order to improve the understanding of the real dependencies of a
function, the pretty-printer options are made concrete earlier in the
pipeline instead of late when pretty-printing happens.
This also has the advantage of clarifying which functions actually
require DynFlags for purposes other than pretty-printing, thus making
the interactions between Haddock and GHC more understandable when
exploring the code base.
See Henry, Ericson, Young. "Modularizing GHC".
https://hsyl20.fr/home/files/papers/2022-ghc-modularity.pdf. 2022
- - - - -
12 changed files:
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Parser.hs
- utils/haddock/haddock-api/src/Haddock/Utils/Json/Parser.hs
Changes:
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
=====================================
@@ -44,6 +44,7 @@ import Data.List (intercalate, isPrefixOf)
import Data.Maybe
import Data.Version
+import qualified GHC.Driver.DynFlags as DynFlags
import System.Directory
import System.FilePath
@@ -59,24 +60,25 @@ ppHoogle dflags unit_state package version synopsis prologue ifaces odir = do
let
-- Since Hoogle is line based, we want to avoid breaking long lines.
dflags' = dflags{pprCols = maxBound}
+ sDocContext = DynFlags.initSDocContext dflags' Outputable.defaultUserStyle
filename = package ++ ".txt"
contents =
prefix
- ++ docWith dflags' (drop 2 $ dropWhile (/= ':') synopsis) prologue
+ ++ docWith sDocContext (drop 2 $ dropWhile (/= ':') synopsis) prologue
++ ["@package " ++ package]
++ [ "@version " ++ showVersion version
| not (null (versionBranch version))
]
- ++ concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i]
+ ++ concat [ppModule dflags' sDocContext unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i]
createDirectoryIfMissing True odir
writeUtf8File (odir </> filename) (unlines contents)
-ppModule :: DynFlags -> UnitState -> Interface -> [String]
-ppModule dflags unit_state iface =
+ppModule :: DynFlags -> SDocContext -> UnitState -> Interface -> [String]
+ppModule dflags sDocContext unit_state iface =
""
- : ppDocumentation dflags (ifaceDoc iface)
+ : ppDocumentation sDocContext (ifaceDoc iface)
++ ["module " ++ moduleString (ifaceMod iface)]
- ++ concatMap ppExportItem (ifaceRnExportItems $ iface)
+ ++ concatMap ppExportItem (ifaceRnExportItems iface)
++ concatMap (ppInstance dflags unit_state) (ifaceInstances iface)
-- | If the export item is an 'ExportDecl', get the attached Hoogle textual
@@ -110,8 +112,8 @@ dropHsDocTy = drop_sig_ty
drop_ty (HsDocTy _ a _) = drop_ty $ unL a
drop_ty x = x
-outHsSigType :: DynFlags -> HsSigType GhcRn -> String
-outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy
+outHsSigType :: SDocContext -> HsSigType GhcRn -> String
+outHsSigType sDocContext = out sDocContext . reparenSigType . dropHsDocTy
dropComment :: String -> String
dropComment (' ' : '-' : '-' : ' ' : _) = []
@@ -131,15 +133,15 @@ outWith p =
f (x : xs) = x : f xs
f [] = []
-out :: Outputable a => DynFlags -> a -> String
-out dflags = outWith $ showSDoc dflags
+out :: Outputable a => SDocContext -> a -> String
+out sDocContext = outWith $ Outputable.renderWithContext sDocContext
operator :: String -> String
operator (x : xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x : xs ++ ")"
operator x = x
-commaSeparate :: Outputable a => DynFlags -> [a] -> String
-commaSeparate dflags = showSDoc dflags . interpp'SP
+commaSeparate :: Outputable a => SDocContext -> [a] -> String
+commaSeparate sDocContext = Outputable.renderWithContext sDocContext . interpp'SP
---------------------------------------------------------------------
-- How to print each export
@@ -155,59 +157,54 @@ ppExportD
, expDFixities = fixities
} =
concat
- [ ppDocumentation dflags' dc ++ f d
+ [ ppDocumentation sDocContext dc ++ f d
| (d, (dc, _)) <- (decl, mbDoc) : bundledPats
]
++ ppFixities
where
- -- Since Hoogle is line based, we want to avoid breaking long lines.
- dflags' :: DynFlags
- dflags' = dflags{pprCols = maxBound}
-
f :: HsDecl GhcRn -> [String]
- f (TyClD _ d at DataDecl{}) = ppData dflags' d subdocs
- f (TyClD _ d at SynDecl{}) = ppSynonym dflags' d
- f (TyClD _ d at ClassDecl{}) = ppClass dflags' d subdocs
- f (TyClD _ (FamDecl _ d)) = ppFam dflags' d
- f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags' [name] typ]
- f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags' [name] typ]
- f (SigD _ sig) = ppSig dflags' sig
+ f (TyClD _ d at DataDecl{}) = ppData sDocContext d subdocs
+ f (TyClD _ d at SynDecl{}) = ppSynonym sDocContext d
+ f (TyClD _ d at ClassDecl{}) = ppClass sDocContext d subdocs
+ f (TyClD _ (FamDecl _ d)) = ppFam sDocContext d
+ f (ForD _ (ForeignImport _ name typ _)) = [ppSig sDocContext [name] typ]
+ f (ForD _ (ForeignExport _ name typ _)) = [ppSig sDocContext [name] typ]
+ f (SigD _ sig) = ppSigWithDoc sDocContext sig []
f _ = []
ppFixities :: [String]
- ppFixities = concatMap (ppFixity dflags') fixities
+ ppFixities = concatMap (ppFixity sDocContext) fixities
+
+ sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle
-ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
-ppSigWithDoc dflags sig subdocs = case sig of
+ppSigWithDoc :: SDocContext -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
+ppSigWithDoc sDocContext sig subdocs = case sig of
TypeSig _ names t -> concatMap (mkDocSig "" (dropWildCards t)) names
PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names
_ -> []
where
mkDocSig leader typ n =
mkSubdocN
- dflags
+ sDocContext
n
subdocs
- [leader ++ pp_sig dflags [n] typ]
+ [leader ++ ppSig sDocContext [n] typ]
-ppSig :: DynFlags -> Sig GhcRn -> [String]
-ppSig dflags x = ppSigWithDoc dflags x []
-
-pp_sig :: DynFlags -> [LocatedN Name] -> LHsSigType GhcRn -> String
-pp_sig dflags names (L _ typ) =
- operator prettyNames ++ " :: " ++ outHsSigType dflags typ
+ppSig :: SDocContext -> [LocatedN Name] -> LHsSigType GhcRn -> String
+ppSig sDocContext names (L _ typ) =
+ operator prettyNames ++ " :: " ++ outHsSigType sDocContext typ
where
- prettyNames = intercalate ", " $ map (out dflags) names
+ prettyNames = intercalate ", " $ map (out sDocContext) names
-- note: does not yet output documentation for class methods
-ppClass :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]
-ppClass dflags decl@(ClassDecl{}) subdocs =
+ppClass :: SDocContext -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]
+ppClass sDocContext decl@(ClassDecl{}) subdocs =
(ppDecl ++ ppTyFams) : ppMethods
where
ppDecl :: String
ppDecl =
out
- dflags
+ sDocContext
decl
{ tcdSigs = []
, tcdATs = []
@@ -218,7 +215,7 @@ ppClass dflags decl@(ClassDecl{}) subdocs =
ppMethods :: [String]
ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl
- ppSig' = flip (ppSigWithDoc dflags) subdocs
+ ppSig' = flip (ppSigWithDoc sDocContext) subdocs
add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVars decl)
@@ -226,7 +223,7 @@ ppClass dflags decl@(ClassDecl{}) subdocs =
ppTyFams
| null $ tcdATs decl = ""
| otherwise =
- (" " ++) . showSDoc dflags . whereWrapper $
+ (" " ++) . Outputable.renderWithContext sDocContext . whereWrapper $
concat
[ map pprTyFam (tcdATs decl)
, map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl)
@@ -237,12 +234,12 @@ ppClass dflags decl@(ClassDecl{}) subdocs =
vcat' $
map text $
mkSubdocN
- dflags
+ sDocContext
(fdLName at)
subdocs
-- Associated type families should not be printed as top-level
-- (avoid printing the `family` keyword)
- (ppFam dflags at{fdTopLevel = NotTopLevel})
+ (ppFam sDocContext at{fdTopLevel = NotTopLevel})
whereWrapper elems =
vcat'
@@ -252,9 +249,9 @@ ppClass dflags decl@(ClassDecl{}) subdocs =
]
ppClass _ _non_cls_decl _ = []
-ppFam :: DynFlags -> FamilyDecl GhcRn -> [String]
-ppFam dflags decl@(FamilyDecl{fdInfo = info}) =
- [out dflags decl']
+ppFam :: SDocContext -> FamilyDecl GhcRn -> [String]
+ppFam sDocContext decl@(FamilyDecl{fdInfo = info}) =
+ [out sDocContext decl']
where
decl' = case info of
-- We don't need to print out a closed type family's equations
@@ -280,33 +277,33 @@ ppInstance dflags unit_state x =
}
}
-ppSynonym :: DynFlags -> TyClDecl GhcRn -> [String]
-ppSynonym dflags x = [out dflags x]
+ppSynonym :: SDocContext -> TyClDecl GhcRn -> [String]
+ppSynonym sDocContext x = [out sDocContext x]
-ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]
-ppData dflags decl at DataDecl{tcdLName = name, tcdTyVars = tvs, tcdFixity = fixity, tcdDataDefn = defn} subdocs =
- out dflags (ppDataDefnHeader (pp_vanilla_decl_head name tvs fixity) defn)
- : concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn)
+ppData :: SDocContext -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]
+ppData sDocContext decl at DataDecl{tcdLName = name, tcdTyVars = tvs, tcdFixity = fixity, tcdDataDefn = defn} subdocs =
+ out sDocContext (ppDataDefnHeader (pp_vanilla_decl_head name tvs fixity) defn)
+ : concatMap (ppCtor sDocContext decl subdocs . unLoc) (dd_cons defn)
ppData _ _ _ = panic "ppData"
-- | for constructors, and named-fields...
-lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> LocatedN Name -> [String]
-lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
- Just (d, _) -> ppDocumentation dflags d
+lookupCon :: SDocContext -> [(Name, DocForDecl Name)] -> LocatedN Name -> [String]
+lookupCon sDocContext subdocs (L _ name) = case lookup name subdocs of
+ Just (d, _) -> ppDocumentation sDocContext d
_ -> []
-ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String]
-ppCtor dflags dat subdocs con at ConDeclH98{con_args = con_args'} =
+ppCtor :: SDocContext -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String]
+ppCtor sDocContext dat subdocs con at ConDeclH98{con_args = con_args'} =
-- AZ:TODO get rid of the concatMap
- concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args'
+ concatMap (lookupCon sDocContext subdocs) [con_name con] ++ f con_args'
where
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 . foExt . unLoc) (cd_fld_names r))
- ++ [out dflags (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
+ [ (concatMap (lookupCon sDocContext subdocs . noLocA . foExt . unLoc) (cd_fld_names r))
+ ++ [out sDocContext (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
| r <- map unLoc recs
]
@@ -316,11 +313,11 @@ ppCtor dflags dat subdocs con at ConDeclH98{con_args = con_args'} =
typeSig nm flds =
operator nm
++ " :: "
- ++ outHsSigType dflags (unL $ mkEmptySigType $ funs flds)
+ ++ outHsSigType sDocContext (unL $ mkEmptySigType $ funs flds)
-- We print the constructors as comma-separated list. See GHC
-- docs for con_names on why it is a list to begin with.
- name = commaSeparate dflags . toList $ unL <$> getConNames con
+ name = commaSeparate sDocContext . toList $ unL <$> getConNames con
tyVarArg (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n
tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noAnn (reL (HsTyVar noAnn NotPromoted n)) lty
@@ -332,7 +329,7 @@ ppCtor dflags dat subdocs con at ConDeclH98{con_args = con_args'} =
(HsTyVar noAnn NotPromoted (reL (tcdName dat)))
: map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)
ppCtor
- dflags
+ sDocContext
_dat
subdocs
( ConDeclGADT
@@ -343,10 +340,10 @@ ppCtor
, con_res_ty = res_ty
}
) =
- concatMap (lookupCon dflags subdocs) names ++ [typeSig]
+ concatMap (lookupCon sDocContext subdocs) names ++ [typeSig]
where
- typeSig = operator name ++ " :: " ++ outHsSigType dflags con_sig_ty
- name = out dflags $ unL <$> names
+ typeSig = operator name ++ " :: " ++ outHsSigType sDocContext con_sig_ty
+ name = out sDocContext $ unL <$> names
con_sig_ty = HsSig noExtField outer_bndrs theta_ty
where
theta_ty = case mcxt of
@@ -358,35 +355,35 @@ ppCtor
RecConGADT _ (L _ flds) -> map (cd_fld_type . unL) flds
mkFunTy a b = noLocA (HsFunTy noExtField (HsUnrestrictedArrow noExtField) a b)
-ppFixity :: DynFlags -> (Name, Fixity) -> [String]
-ppFixity dflags (name, fixity) = [out dflags ((FixitySig NoNamespaceSpecifier [noLocA name] fixity) :: FixitySig GhcRn)]
+ppFixity :: SDocContext -> (Name, Fixity) -> [String]
+ppFixity sDocContext (name, fixity) = [out sDocContext ((FixitySig NoNamespaceSpecifier [noLocA name] fixity) :: FixitySig GhcRn)]
---------------------------------------------------------------------
-- DOCUMENTATION
-ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String]
-ppDocumentation dflags (Documentation d w) = mdoc dflags d ++ doc dflags w
+ppDocumentation :: Outputable o => SDocContext -> Documentation o -> [String]
+ppDocumentation sDocContext (Documentation d w) = mdoc sDocContext d ++ doc sDocContext w
-doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String]
-doc dflags = docWith dflags ""
+doc :: Outputable o => SDocContext -> Maybe (Doc o) -> [String]
+doc sDocContext = docWith sDocContext ""
-mdoc :: Outputable o => DynFlags -> Maybe (MDoc o) -> [String]
-mdoc dflags = docWith dflags "" . fmap _doc
+mdoc :: Outputable o => SDocContext -> Maybe (MDoc o) -> [String]
+mdoc sDocContext = docWith sDocContext "" . fmap _doc
-docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String]
+docWith :: Outputable o => SDocContext -> String -> Maybe (Doc o) -> [String]
docWith _ [] Nothing = []
-docWith dflags header d =
+docWith sDocContext header d =
("" :) $
zipWith (++) ("-- | " : repeat "-- ") $
lines header
++ ["" | header /= "" && isJust d]
- ++ maybe [] (showTags . markup (markupTag dflags)) d
+ ++ maybe [] (showTags . markup (markupTag sDocContext)) d
-mkSubdocN :: DynFlags -> LocatedN Name -> [(Name, DocForDecl Name)] -> [String] -> [String]
-mkSubdocN dflags n subdocs s = mkSubdoc dflags (la2la n) subdocs s
+mkSubdocN :: SDocContext -> LocatedN Name -> [(Name, DocForDecl Name)] -> [String] -> [String]
+mkSubdocN sDocContext n subdocs s = mkSubdoc sDocContext (la2la n) subdocs s
-mkSubdoc :: DynFlags -> LocatedA Name -> [(Name, DocForDecl Name)] -> [String] -> [String]
-mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s
+mkSubdoc :: SDocContext -> LocatedA Name -> [(Name, DocForDecl Name)] -> [String] -> [String]
+mkSubdoc sDocContext n subdocs s = concatMap (ppDocumentation sDocContext) getDoc ++ s
where
getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs)
@@ -408,15 +405,15 @@ str a = [Str a]
-- or inlne for others (a,i,tt)
-- entities (&,>,<) should always be appropriately escaped
-markupTag :: Outputable o => DynFlags -> DocMarkup o [Tag]
-markupTag dflags =
+markupTag :: Outputable o => SDocContext -> DocMarkup o [Tag]
+markupTag sDocContext =
Markup
{ markupParagraph = box TagP
, markupEmpty = str ""
, markupString = str
, markupAppend = (++)
- , markupIdentifier = box (TagInline "a") . str . out dflags
- , markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd)
+ , markupIdentifier = box (TagInline "a") . str . out sDocContext
+ , markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out sDocContext . snd)
, markupModule = \(ModLink m label) -> box (TagInline "a") (fromMaybe (str m) label)
, markupWarning = box (TagInline "i")
, markupEmphasis = box (TagInline "i")
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs
=====================================
@@ -23,10 +23,12 @@ import System.FilePath
import Data.Map as M
import GHC.Data.FastString (mkFastString)
+import qualified GHC.Driver.DynFlags as DynFlags
import GHC.Iface.Ext.Binary (hie_file_result, readHieFile)
import GHC.Iface.Ext.Types (HieAST (..), HieASTs (..), HieFile (..), SourcedNodeInfo (..), pattern HiePath)
import GHC.Types.SrcLoc (mkRealSrcLoc, realSrcLocSpan, srcSpanFile)
import GHC.Unit.Module (Module, moduleName)
+import qualified GHC.Utils.Outputable as Outputable
-- | Generate hyperlinked source for given interfaces.
--
@@ -78,9 +80,9 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
mast
| M.size asts == 1 = snd <$> M.lookupMin asts
| otherwise = M.lookup (HiePath (mkFastString file)) asts
- tokens' = parse df file rawSrc
+ tokens' = parse dflags sDocContext file rawSrc
ast = fromMaybe (emptyHieAst fileFs) mast
- fullAst = recoverFullIfaceTypes df types ast
+ fullAst = recoverFullIfaceTypes sDocContext types ast
-- Warn if we didn't find an AST, but there were still ASTs
if M.null asts
@@ -104,7 +106,8 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do
-- Produce and write out the hyperlinked sources
writeUtf8File path . renderToString pretty . render' fullAst $ tokens
where
- df = ifaceDynFlags iface
+ dflags = ifaceDynFlags iface
+ sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle
render' = render (Just srcCssFile) (Just highlightScript) srcs
path = srcdir </> hypSrcModuleFile (ifaceMod iface)
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
=====================================
@@ -15,7 +15,6 @@ import GHC.Data.Bag (bagToList)
import GHC.Data.FastString (mkFastString)
import GHC.Data.StringBuffer (StringBuffer, atEnd)
import GHC.Driver.Config.Diagnostic
-import GHC.Driver.Ppr (showSDoc)
import GHC.Driver.Session
import GHC.Parser.Errors.Ppr ()
import GHC.Parser.Lexer as Lexer
@@ -33,7 +32,8 @@ import qualified GHC.Types.Error as E
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Utils.Error (pprLocMsgEnvelopeDefault)
-import GHC.Utils.Outputable (text, ($$))
+import GHC.Utils.Outputable (SDocContext, text, ($$))
+import qualified GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic (panic)
import Haddock.Backends.Hyperlinker.Types as T
@@ -46,17 +46,18 @@ import Haddock.GhcUtils
parse
:: DynFlags
-- ^ Flags for this module
+ -> SDocContext
-> FilePath
-- ^ Path to the source of this module
-> BS.ByteString
-- ^ Raw UTF-8 encoded source of this module
-> [T.Token]
-parse dflags fpath bs = case unP (go False []) initState of
+parse dflags sDocContext fpath bs = case unP (go False []) initState of
POk _ toks -> reverse toks
PFailed pst ->
let err : _ = bagToList (E.getMessages $ getPsErrorMessages pst)
in panic $
- showSDoc dflags $
+ Outputable.renderWithContext sDocContext $
text "Hyperlinker parse error:" $$ pprLocMsgEnvelopeDefault err
where
initState = initParserState pflags buf start
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
=====================================
@@ -27,7 +27,6 @@ import Haddock.Backends.Xhtml.Utils
import Haddock.Utils
import GHC
-import GHC.Driver.Ppr (showSDoc)
import GHC.Iface.Ext.Types (HieAST (..), HieArgs (..), HieType (..), HieTypeFlat, TypeIndex)
import GHC.Iface.Type
import GHC.Types.Name (getOccFS, getOccString)
@@ -36,6 +35,8 @@ import GHC.Types.Var (TypeOrConstraint (..), VarBndr (..), invisArg, visArg)
import System.FilePath.Posix ((<.>), (</>))
import qualified Data.Array as A
+import GHC.Utils.Outputable (SDocContext)
+import qualified GHC.Utils.Outputable as Outputable
{-# INLINE hypSrcDir #-}
hypSrcDir :: FilePath
@@ -122,19 +123,19 @@ type PrintedType = String
-- multiple calls to 'recoverFullType' don't share intermediate results. This
-- function fixes that.
recoverFullIfaceTypes
- :: DynFlags
+ :: SDocContext
-> A.Array TypeIndex HieTypeFlat
-- ^ flat types
-> HieAST TypeIndex
-- ^ flattened AST
-> HieAST PrintedType
-- ^ full AST
-recoverFullIfaceTypes df flattened ast = fmap (printed A.!) ast
+recoverFullIfaceTypes sDocContext flattened ast = fmap (printed A.!) ast
where
-- Splitting this out into its own array is also important: we don't want
-- to pretty print the same type many times
printed :: A.Array TypeIndex PrintedType
- printed = fmap (showSDoc df . pprIfaceType) unflattened
+ printed = fmap (Outputable.renderWithContext sDocContext . pprIfaceType) unflattened
-- The recursion in 'unflattened' is crucial - it's what gives us sharing
-- between the IfaceType's produced
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
=====================================
@@ -50,11 +50,11 @@ import Control.DeepSeq (force)
import Control.Monad (unless, when)
import Data.Bifunctor (bimap)
import qualified Data.ByteString.Builder as Builder
-import qualified Data.List as List
import Data.Char (isSpace, toUpper)
import Data.Either (partitionEithers)
import Data.Foldable (traverse_)
import Data.List (intersperse, isPrefixOf, sortBy)
+import qualified Data.List as List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -32,10 +32,10 @@ module Haddock.GhcUtils where
import Control.Arrow
import Data.Char (isSpace)
import Data.Foldable (toList)
+import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Set as Set
-import qualified Data.List as List
import Haddock.Types (DocName, DocNameI, XRecCond)
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
=====================================
@@ -29,12 +29,12 @@ import Control.Applicative ((<|>))
import Control.Arrow hiding ((<+>))
import Control.DeepSeq (force)
import Data.Foldable (toList)
+import qualified Data.List as List
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
import Data.Ord (comparing)
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
-import qualified Data.List as List
import GHC
import GHC.Builtin.Types (unrestrictedFunTyConName)
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
=====================================
@@ -56,6 +56,7 @@ import GHC.Builtin.Names
import GHC.Builtin.Types.Prim
import GHC.Core.ConLike (ConLike (..))
import GHC.Data.FastString (FastString, bytesFS, unpackFS)
+import qualified GHC.Driver.DynFlags as DynFlags
import GHC.Driver.Ppr
import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Iface.Syntax
@@ -67,7 +68,9 @@ import qualified GHC.Types.SrcLoc as SrcLoc
import qualified GHC.Types.Unique.Map as UniqMap
import GHC.Unit.Module.ModIface
import GHC.Unit.State (PackageName (..), UnitState)
+import GHC.Utils.Outputable (SDocContext)
import qualified GHC.Utils.Outputable as O
+import qualified GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic (pprPanic)
createInterface1
@@ -90,6 +93,7 @@ createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instance
, ms_location = modl
} = mod_sum
+ sDocContext = DynFlags.initSDocContext dflags Outputable.defaultUserStyle
dflags = ms_hspp_opts
mdl = mi_module mod_iface
sem_mdl = mi_semantic_module mod_iface
@@ -145,27 +149,28 @@ createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instance
(!info, header_doc) <-
processModuleHeader
dflags
+ sDocContext
pkg_name
safety
(docs_language mod_iface_docs)
(docs_extensions mod_iface_docs)
(docs_mod_hdr mod_iface_docs)
- mod_warning <- moduleWarning dflags warnings
+ mod_warning <- moduleWarning dflags sDocContext warnings
(docMap :: DocMap Name) <- do
let docsDecls = Map.fromList $ UniqMap.nonDetUniqMapToList mod_iface_docs.docs_decls
- traverse (processDocStringsParas dflags pkg_name) docsDecls
+ traverse (processDocStringsParas dflags sDocContext pkg_name) docsDecls
- exportsSinceMap <- mkExportSinceMap dflags pkg_name mod_iface_docs
+ exportsSinceMap <- mkExportSinceMap dflags sDocContext pkg_name mod_iface_docs
(argMap :: Map Name (Map Int (MDoc Name))) <- do
let docsArgs = Map.fromList $ UniqMap.nonDetUniqMapToList mod_iface_docs.docs_args
(result :: Map Name (IntMap (MDoc Name))) <-
- traverse (traverse (processDocStringParas dflags pkg_name)) docsArgs
+ traverse (traverse (processDocStringParas dflags sDocContext pkg_name)) docsArgs
let result2 = Map.map (\intMap -> Map.fromList $ IM.assocs intMap) result
- pure $ result2
+ pure result2
- warningMap <- mkWarningMap dflags warnings exportedNames
+ warningMap <- mkWarningMap dflags sDocContext warnings exportedNames
let local_instances =
filter (nameIsLocalOrFrom sem_mdl) $
@@ -199,6 +204,7 @@ createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instance
(bonus_ds $ docs_structure mod_iface_docs)
inst_ifaces
dflags
+ sDocContext
def_meths_env
let
@@ -259,15 +265,16 @@ mkExportSinceMap
:: forall m
. MonadIO m
=> DynFlags
+ -> SDocContext
-> Maybe Package
-> Docs
-> IfM m (Map Name MetaSince)
-mkExportSinceMap dflags pkg_name docs = do
+mkExportSinceMap dflags sDocContext pkg_name docs = do
Map.unions <$> traverse processExportDoc (UniqMap.nonDetUniqMapToList (docs_exports docs))
where
processExportDoc :: (Name, HsDoc GhcRn) -> IfM m (Map Name MetaSince)
processExportDoc (nm, doc) = do
- mdoc <- processDocStringsParas dflags pkg_name [doc]
+ mdoc <- processDocStringsParas dflags sDocContext pkg_name [doc]
case _doc mdoc of
DocEmpty -> return ()
_ -> warn "Export docstrings may only contain @since annotations"
@@ -282,10 +289,11 @@ mkExportSinceMap dflags pkg_name docs = do
mkWarningMap
:: MonadIO m
=> DynFlags
+ -> SDocContext
-> IfaceWarnings
-> [Name]
-> IfM m WarningMap
-mkWarningMap dflags warnings exps =
+mkWarningMap dflags sDocContext warnings exps =
case warnings of
IfWarnSome ws _ ->
let expsOccEnv = mkOccEnv [(nameOccName n, n) | n <- exps]
@@ -295,23 +303,25 @@ mkWarningMap dflags warnings exps =
case lookupOccEnv_WithFields expsOccEnv occ of
(n : _) -> Just (n, w)
[] -> Nothing
- in Map.fromList <$> traverse (traverse (parseWarning dflags)) ws'
+ in Map.fromList <$> traverse (traverse (parseWarning dflags sDocContext)) ws'
_ -> pure Map.empty
moduleWarning
:: MonadIO m
=> DynFlags
+ -> SDocContext
-> IfaceWarnings
-> IfM m (Maybe (Doc Name))
-moduleWarning dflags (IfWarnAll w) = Just <$> parseWarning dflags w
-moduleWarning _ _ = pure Nothing
+moduleWarning dflags sDocContext (IfWarnAll w) = Just <$> parseWarning dflags sDocContext w
+moduleWarning _ _ _ = pure Nothing
parseWarning
:: MonadIO m
=> DynFlags
+ -> SDocContext
-> IfaceWarningTxt
-> IfM m (Doc Name)
-parseWarning dflags w = case w of
+parseWarning dflags sDocContext w = case w of
IfDeprecatedTxt _ msg -> format "Deprecated: " (map dstToDoc msg)
IfWarningTxt _ _ msg -> format "Warning: " (map dstToDoc msg)
where
@@ -323,7 +333,7 @@ parseWarning dflags w = case w of
format x bs =
DocWarning . DocParagraph . DocAppend (DocString x)
- <$> foldrM (\doc rest -> docAppend <$> processDocString dflags doc <*> pure rest) DocEmpty bs
+ <$> foldrM (\doc rest -> docAppend <$> processDocString dflags sDocContext doc <*> pure rest) DocEmpty bs
-------------------------------------------------------------------------------
-- Doc options
@@ -391,6 +401,7 @@ mkExportItems
-> DocStructure
-> InstIfaceMap
-> DynFlags
+ -> SDocContext
-> OccEnv Name
-> IfM m [ExportItem GhcRn]
mkExportItems
@@ -407,16 +418,17 @@ mkExportItems
dsItems
instIfaceMap
dflags
+ sDocContext
defMeths =
concat <$> traverse lookupExport dsItems
where
lookupExport :: MonadIO m => DocStructureItem -> IfM m [ExportItem GhcRn]
lookupExport = \case
DsiSectionHeading lev hsDoc' -> do
- doc <- processDocString dflags hsDoc'
+ doc <- processDocString dflags sDocContext hsDoc'
pure [ExportGroup lev "" doc]
DsiDocChunk hsDoc' -> do
- doc <- processDocStringParas dflags pkgName hsDoc'
+ doc <- processDocStringParas dflags sDocContext pkgName hsDoc'
pure [ExportDoc doc]
DsiNamedChunkRef ref -> do
case Map.lookup ref namedChunks of
@@ -424,7 +436,7 @@ mkExportItems
warn $ "Cannot find documentation for: $" ++ ref
pure []
Just hsDoc' -> do
- doc <- processDocStringParas dflags pkgName hsDoc'
+ doc <- processDocStringParas dflags sDocContext pkgName hsDoc'
pure [ExportDoc doc]
DsiExports avails ->
-- TODO: We probably don't need nubAvails here.
@@ -450,6 +462,7 @@ mkExportItems
fixMap
instIfaceMap
dflags
+ sDocContext
avail
defMeths
@@ -521,6 +534,7 @@ availExportItem
-> FixMap
-> InstIfaceMap
-> DynFlags
+ -> SDocContext
-> AvailInfo
-> OccEnv Name -- Default methods
-> IfM m [ExportItem GhcRn]
@@ -535,6 +549,7 @@ availExportItem
fixMap
instIfaceMap
dflags
+ sDocContext
availInfo
defMeths =
declWith availInfo
@@ -542,7 +557,7 @@ availExportItem
declWith :: AvailInfo -> IfM m [ExportItem GhcRn]
declWith avail = do
let t = availName avail
- mayDecl <- hiDecl dflags prr t
+ mayDecl <- hiDecl dflags sDocContext prr t
case mayDecl of
Nothing -> return [ExportNoDecl t []]
Just decl -> do
@@ -578,10 +593,10 @@ availExportItem
-- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails
availDecl :: Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn)
availDecl declName parentDecl =
- extractDecl prr dflags declName parentDecl >>= \case
+ extractDecl prr dflags sDocContext declName parentDecl >>= \case
Right d -> pure d
Left err -> do
- synifiedDeclOpt <- hiDecl dflags prr declName
+ synifiedDeclOpt <- hiDecl dflags sDocContext prr declName
case synifiedDeclOpt of
Just synifiedDecl -> pure synifiedDecl
Nothing -> pprPanic "availExportItem" (O.text err)
@@ -694,10 +709,11 @@ applyExportSince _ _ dd = dd
hiDecl
:: MonadIO m
=> DynFlags
+ -> SDocContext
-> PrintRuntimeReps
-> Name
-> IfM m (Maybe (LHsDecl GhcRn))
-hiDecl dflags prr t = do
+hiDecl dflags sDocContext prr t = do
mayTyThing <- lookupName t
case mayTyThing of
Nothing -> do
@@ -713,7 +729,7 @@ hiDecl dflags prr t = do
O.<> O.comma
O.<+> O.quotes (O.ppr t)
O.<+> O.text "-- Please report this on Haddock issue tracker!"
- bugWarn = showSDoc dflags . warnLine
+ bugWarn = Outputable.renderWithContext sDocContext . warnLine
-- | Lookup docs for a declaration from maps.
lookupDocs
@@ -774,12 +790,13 @@ extractDecl
:: MonadIO m
=> PrintRuntimeReps
-> DynFlags
+ -> SDocContext
-> Name
-- ^ name of the declaration to extract
-> LHsDecl GhcRn
-- ^ parent declaration
-> IfM m (Either String (LHsDecl GhcRn))
-extractDecl prr dflags name decl
+extractDecl prr dflags sDocContext name decl
| name `elem` getMainDeclBinder emptyOccEnv (unLoc decl) = pure $ Right decl
| otherwise =
case unLoc decl of
@@ -813,7 +830,7 @@ extractDecl prr dflags name decl
in pure (Right $ L pos (SigD noExtField sig))
(_, [L pos fam_decl]) -> pure (Right $ L pos (TyClD noExtField (FamDecl noExtField fam_decl)))
([], []) -> do
- famInstDeclOpt <- hiDecl dflags prr name
+ famInstDeclOpt <- hiDecl dflags sDocContext prr name
case famInstDeclOpt of
Nothing ->
pure $
@@ -825,7 +842,7 @@ extractDecl prr dflags name decl
, getOccString clsNm
]
)
- Just famInstDecl -> extractDecl prr dflags name famInstDecl
+ Just famInstDecl -> extractDecl prr dflags sDocContext name famInstDecl
_ ->
pure $
Left
@@ -850,9 +867,9 @@ extractDecl prr dflags name decl
pure (SigD noExtField <$> lsig)
TyClD _ FamDecl{}
| isValName name -> do
- famInstOpt <- hiDecl dflags prr name
+ famInstOpt <- hiDecl dflags sDocContext prr name
case famInstOpt of
- Just famInst -> extractDecl prr dflags name famInst
+ Just famInst -> extractDecl prr dflags sDocContext name famInst
Nothing -> pure $ Left ("extractDecl: Unhandled decl for " ++ getOccString name)
InstD
_
@@ -877,7 +894,7 @@ extractDecl prr dflags name decl
[ d' | L _ d'@(DataFamInstDecl (FamEqn{feqn_rhs = dd})) <- insts, name `elem` map unLoc (concatMap (toList . getConNames . unLoc) (dd_cons dd))
]
in case matches of
- [d0] -> extractDecl prr dflags name (noLocA (InstD noExtField (DataFamInstD noExtField d0)))
+ [d0] -> extractDecl prr dflags sDocContext name (noLocA (InstD noExtField (DataFamInstD noExtField d0)))
_ -> pure $ Left "internal: extractDecl (ClsInstD)"
| otherwise ->
let matches =
@@ -891,7 +908,7 @@ extractDecl prr dflags name decl
, foExt n == name
]
in case matches of
- [d0] -> extractDecl prr dflags name (noLocA . InstD noExtField $ DataFamInstD noExtField d0)
+ [d0] -> extractDecl prr dflags sDocContext name (noLocA . InstD noExtField $ DataFamInstD noExtField d0)
_ -> pure $ Left "internal: extractDecl (ClsInstD)"
_ -> pure $ Left ("extractDecl: Unhandled decl for " ++ getOccString name)
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs
=====================================
@@ -33,7 +33,6 @@ import qualified Data.Set as Set
import GHC
import GHC.Data.EnumSet as EnumSet
import GHC.Data.FastString (unpackFS)
-import GHC.Driver.Ppr (showPpr, showSDoc)
import GHC.Driver.Session
import qualified GHC.LanguageExtensions as LangExt
import GHC.Parser.PostProcess
@@ -42,7 +41,8 @@ import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.Name.Set
import GHC.Utils.Misc ((<||>))
-import GHC.Utils.Outputable (Outputable)
+import GHC.Utils.Outputable (Outputable (ppr), SDocContext, renderWithContext)
+import qualified GHC.Utils.Outputable as Outputable
import Haddock.Interface.ParseModuleHeader
import Haddock.Parser
import Haddock.Types
@@ -50,11 +50,12 @@ import Haddock.Types
processDocStringsParas
:: MonadIO m
=> DynFlags
+ -> SDocContext
-> Maybe Package
-> [HsDoc GhcRn]
-> IfM m (MDoc Name)
-processDocStringsParas dflags pkg hdss =
- overDocF (rename dflags $ hsDocRenamer hds) $ parseParas dflags pkg (renderHsDocStrings $ hsDocString hds)
+processDocStringsParas dflags sDocContext pkg hdss =
+ overDocF (rename sDocContext $ hsDocRenamer hds) $ parseParas dflags pkg (renderHsDocStrings $ hsDocString hds)
where
hds :: WithHsDocIdentifiers [HsDocString] GhcRn
hds = WithHsDocIdentifiers (map hsDocString hdss) (concatMap hsDocIdentifiers hdss)
@@ -62,30 +63,33 @@ processDocStringsParas dflags pkg hdss =
processDocStringParas
:: MonadIO m
=> DynFlags
+ -> SDocContext
-> Maybe Package
- -> (HsDoc GhcRn)
+ -> HsDoc GhcRn
-> IfM m (MDoc Name)
-processDocStringParas dflags pkg hds =
- overDocF (rename dflags $ hsDocRenamer hds) $ parseParas dflags pkg (renderHsDocString $ hsDocString hds)
+processDocStringParas dflags sDocContext pkg hds =
+ overDocF (rename sDocContext $ hsDocRenamer hds) $ parseParas dflags pkg (renderHsDocString $ hsDocString hds)
processDocString
:: MonadIO m
=> DynFlags
- -> (HsDoc GhcRn)
+ -> SDocContext
+ -> HsDoc GhcRn
-> IfM m (Doc Name)
-processDocString dflags hds =
- rename dflags (hsDocRenamer hds) $ parseString dflags (renderHsDocString $ hsDocString hds)
+processDocString dflags sDocContext hds =
+ rename sDocContext (hsDocRenamer hds) $ parseString dflags (renderHsDocString $ hsDocString hds)
processModuleHeader
:: MonadIO m
=> DynFlags
+ -> SDocContext
-> Maybe Package
-> SafeHaskellMode
-> Maybe Language
-> EnumSet LangExt.Extension
-> Maybe (HsDoc GhcRn)
-> IfM m (HaddockModInfo Name, Maybe (MDoc Name))
-processModuleHeader dflags pkgName safety mayLang extSet mayStr = do
+processModuleHeader dflags sDocContext pkgName safety mayLang extSet mayStr = do
(hmi, doc) <-
case mayStr of
Nothing -> return failure
@@ -94,10 +98,10 @@ processModuleHeader dflags pkgName safety mayLang extSet mayStr = do
(hmi, doc) = parseModuleHeader dflags pkgName str
renamer = hsDocRenamer hsDoc
!descr <- case hmi_description hmi of
- Just hmi_descr -> Just <$> rename dflags renamer hmi_descr
+ Just hmi_descr -> Just <$> rename sDocContext renamer hmi_descr
Nothing -> pure Nothing
let hmi' = hmi{hmi_description = descr}
- doc' <- overDocF (rename dflags renamer) doc
+ doc' <- overDocF (rename sDocContext renamer) doc
return (hmi', Just doc')
let flags :: [LangExt.Extension]
@@ -105,7 +109,7 @@ processModuleHeader dflags pkgName safety mayLang extSet mayStr = do
flags = EnumSet.toList extSet \\ languageExtensions mayLang
return
( hmi
- { hmi_safety = Just $ showPpr dflags safety
+ { hmi_safety = Just $ Outputable.renderWithContext sDocContext (Outputable.ppr safety)
, hmi_language = language dflags
, hmi_extensions = flags
}
@@ -130,11 +134,11 @@ traverseSnd f =
-- See the comments in the source for implementation commentary.
rename
:: MonadIO m
- => DynFlags
+ => SDocContext
-> Renamer
-> Doc NsRdrName
-> IfM m (Doc Name)
-rename dflags renamer = rn
+rename sDocContext renamer = rn
where
rn :: MonadIO m => Doc NsRdrName -> IfM m (Doc Name)
rn d = case d of
@@ -156,13 +160,13 @@ rename dflags renamer = rn
Value -> valueNsChoices
Type -> typeNsChoices
None -> valueNsChoices <||> typeNsChoices
- case renamer (showPpr dflags x) choices of
+ case renamer (Outputable.renderWithContext sDocContext (Outputable.ppr x)) choices of
[] -> case ns of
- Type -> outOfScope dflags ns (i $> setRdrNameSpace x tcName)
- _ -> outOfScope dflags ns (i $> x)
+ Type -> outOfScope sDocContext ns (i $> setRdrNameSpace x tcName)
+ _ -> outOfScope sDocContext ns (i $> x)
[a] -> pure (DocIdentifier $ i $> a)
-- There are multiple names available.
- names -> ambiguous dflags i names
+ names -> ambiguous sDocContext i names
DocWarning dw -> DocWarning <$> rn dw
DocEmphasis de -> DocEmphasis <$> rn de
DocBold db -> DocBold <$> rn db
@@ -193,8 +197,8 @@ rename dflags renamer = rn
-- users shouldn't rely on this doing the right thing. See tickets
-- #253 and #375 on the confusion this causes depending on which
-- default we pick in 'rename'.
-outOfScope :: MonadIO m => DynFlags -> Namespace -> Wrap RdrName -> IfM m (Doc a)
-outOfScope dflags ns x =
+outOfScope :: MonadIO m => SDocContext -> Namespace -> Wrap RdrName -> IfM m (Doc a)
+outOfScope sDocContext ns x =
case unwrap x of
Unqual occ -> warnAndMonospace (x $> occ)
Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ)))
@@ -209,7 +213,7 @@ outOfScope dflags ns x =
warnAndMonospace :: (MonadIO m, Outputable a) => Wrap a -> IfM m (DocH mod id)
warnAndMonospace a = do
- let a' = showWrapped (showPpr dflags) a
+ let a' = showWrapped (renderWithContext sDocContext . Outputable.ppr) a
-- If we have already warned for this identifier, don't warn again
firstWarn <- Set.notMember a' <$> gets ifeOutOfScopeNames
@@ -233,15 +237,15 @@ outOfScope dflags ns x =
-- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class.
ambiguous
:: MonadIO m
- => DynFlags
+ => SDocContext
-> Wrap NsRdrName
-> [Name]
-- ^ More than one @gre at s sharing the same `RdrName` above.
-> IfM m (Doc Name)
-ambiguous dflags x names = do
+ambiguous sDocContext x names = do
let noChildren = map availName (nubAvails (map Avail names))
dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren
- nameStr = showNsRdrName dflags x
+ nameStr = showNsRdrName sDocContext x
msg =
"Warning: "
++ nameStr
@@ -268,13 +272,13 @@ ambiguous dflags x names = do
where
isLocalName (nameSrcLoc -> RealSrcLoc{}) = True
isLocalName _ = False
- defnLoc = showSDoc dflags . pprNameDefnLoc
+ defnLoc = Outputable.renderWithContext sDocContext . pprNameDefnLoc
-- | Printable representation of a wrapped and namespaced name
-showNsRdrName :: DynFlags -> Wrap NsRdrName -> String
-showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident
+showNsRdrName :: SDocContext -> Wrap NsRdrName -> String
+showNsRdrName sDocContext = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident
where
- ident = showWrapped (showPpr dflags . rdrName)
+ ident = showWrapped (Outputable.renderWithContext sDocContext . ppr . rdrName)
prefix = renderNs . namespace . unwrap
hsDocRenamer :: WithHsDocIdentifiers a GhcRn -> Renamer
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
=====================================
@@ -245,7 +245,10 @@ renameExportItem item = case item of
let !hoogleOut =
force $
if rnHoogleOutput
- then ppExportD rnDynFlags ed
+ then
+ -- Since Hoogle is line based, we want to avoid breaking long lines.
+ let dflags = rnDynFlags{pprCols = maxBound}
+ in ppExportD dflags ed
else []
decl' <- renameLDecl decl
=====================================
utils/haddock/haddock-api/src/Haddock/Parser.hs
=====================================
@@ -28,10 +28,10 @@ import GHC.Types.Name.Reader (RdrName (..))
import GHC.Types.SrcLoc (GenLocated (..), mkRealSrcLoc)
parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName)
-parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p
+parseParas dflags p = overDoc (P.overIdentifier (parseIdent dflags)) . P.parseParas p
parseString :: DynFlags -> String -> DocH mod (Wrap NsRdrName)
-parseString d = P.overIdentifier (parseIdent d) . P.parseString
+parseString dflags = P.overIdentifier (parseIdent dflags) . P.parseString
parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName)
parseIdent dflags ns str0 =
=====================================
utils/haddock/haddock-api/src/Haddock/Utils/Json/Parser.hs
=====================================
@@ -16,6 +16,7 @@ import Text.Parsec.ByteString.Lazy (Parser)
import Text.ParserCombinators.Parsec ((<?>))
import qualified Text.ParserCombinators.Parsec as Parsec
+import qualified Data.List as List
import Haddock.Utils.Json.Types hiding (object)
parseJSONValue :: Parser Value
@@ -94,12 +95,19 @@ parseString =
uni = check =<< Parsec.count 4 (Parsec.satisfy isHexDigit)
where
- check x
- | code <= max_char = return (toEnum code)
- | otherwise = mzero
- where
- code = fst $ head $ readHex x
- max_char = fromEnum (maxBound :: Char)
+ check :: Enum a => String -> Parser a
+ check x = do
+ code <- parseHex x
+ if code <= max_char
+ then pure (toEnum code)
+ else mzero
+ parseHex :: String -> Parser Int
+ parseHex c =
+ case List.uncons (readHex c) of
+ Nothing -> mzero
+ Just (result, _) -> pure $ fst result
+ max_char :: Int
+ max_char = fromEnum (maxBound :: Char)
parseObject :: Parser Object
parseObject =
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5759133fff9111471f79cf80a665d0135493e533
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5759133fff9111471f79cf80a665d0135493e533
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240622/aaaf788c/attachment-0001.html>
More information about the ghc-commits
mailing list