[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Silence x-partial in Haddock.Backends.Xhtml
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Sep 5 10:37:14 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
46021a1b by Hécate Kleidukos at 2024-09-05T06:37:04-04:00
Silence x-partial in Haddock.Backends.Xhtml
This is an unfortunate consequence of two mechanisms:
* GHC provides (possibly-empty) lists of names
* The functions that retrieve those names are not equipped to do error
reporting, and thus accept these lists at face value. They will have
to be attached an effect for error reporting in a later refactoring
- - - - -
23a4eed5 by Hécate Kleidukos at 2024-09-05T06:37:04-04:00
hadrian: Support loading haddock in ghci
There is one tricky aspect with wired-in packages where the boot package
is built with `-this-unit-id ghc` but the dependency is reported as
`-package-id ghc-9.6...`. This has never been fixed in GHC as the
situation of loading wired-in packages into the multi-repl seems like
quite a niche feature that is always just easier to workaround.
- - - - -
79bc287a by Matthew Pickering at 2024-09-05T06:37:04-04:00
hadrian/multi: Load all targets when ./hadrian/ghci-multi is called
This seems to make a bit more sense than just loading `ghc` component
(and dependencies).
- - - - -
07ba0d21 by Matthew Pickering at 2024-09-05T06:37:05-04:00
ci: Beef up determinism interface test
There have recently been some determinism issues with the simplifier and
documentation. We enable more things to test in the ABI test to check
that we produce interface files deterministically.
- - - - -
8 changed files:
- .gitlab/ci.sh
- hadrian/ghci-multi-cabal.in
- hadrian/src/Rules/ToolArgs.hs
- utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
- utils/haddock/haddock-api/src/Haddock/Utils/Json.hs
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -753,7 +753,7 @@ function check_interfaces(){
}
function abi_test() {
- for i in {1..20}; do info "iteration $i"; run_abi_test; done
+ for i in {1..10}; do info "iteration $i"; run_abi_test; done
}
function run_abi_test() {
@@ -761,8 +761,8 @@ function run_abi_test() {
fail "HC not set"
fi
mkdir -p out
- OUT="$PWD/out/run1" DIR=$(mktemp -d XXXX-looooooooong) cabal_abi_test -O0
- OUT="$PWD/out/run2" DIR=$(mktemp -d XXXX-short) cabal_abi_test -O0
+ OUT="$PWD/out/run1" DIR=$(mktemp -d XXXX-looooooooong) cabal_abi_test -O1 -haddock
+ OUT="$PWD/out/run2" DIR=$(mktemp -d XXXX-short) cabal_abi_test -O1 -haddock -dunique-increment=-1 -dinitial-unique=16777215
check_interfaces out/run1 out/run2 abis "Mismatched ABI hash"
check_interfaces out/run1 out/run2 interfaces "Mismatched interface hashes"
}
=====================================
hadrian/ghci-multi-cabal.in
=====================================
@@ -8,6 +8,6 @@ if [[ $(printf "9.4.0\n%s\n" $($RUN_GHC --numeric-version) | sort -uV | head -n
set -e
export TOOL_OUTPUT=.hadrian_ghci_multi/ghci_args
# Replace newlines with spaces, as these otherwise break the ghci invocation on windows.
-CABFLAGS=-v0 "hadrian/build-cabal" multi:ghc --build-root=.hadrian_ghci_multi --flavour=ghc-in-ghci $HADRIAN_ARGS
+CABFLAGS=-v0 "hadrian/build-cabal" multi --build-root=.hadrian_ghci_multi --flavour=ghc-in-ghci $HADRIAN_ARGS
GHC_FLAGS="$GHC_FLAGS $(cat $TOOL_OUTPUT | tr '\n\r' ' ')"
$RUN_GHC --interactive $GHC_FLAGS $@ -fno-code -fwrite-interface -O0 +RTS -A128m
=====================================
hadrian/src/Rules/ToolArgs.hs
=====================================
@@ -16,7 +16,9 @@ import System.Directory (canonicalizePath)
import System.Environment (lookupEnv)
import qualified Data.Set as Set
import Oracles.ModuleFiles
+import Oracles.Setting
import Utilities
+import Data.Version.Extra
-- | @tool:@ is used by tooling in order to get the arguments necessary
-- to set up a GHC API session which can compile modules from GHC. When
@@ -85,7 +87,16 @@ multiSetup pkg_s = do
need (srcs ++ gens)
let rexp m = ["-reexported-module", m]
let hidir = root </> "interfaces" </> pkgPath p
- writeFile' (resp_file root p) (intercalate "\n" (arg_list
+ ghcVersion <- ghcVersionStage stage0InTree
+ let ghc_wired_in = readVersion ghcVersion < makeVersion [9,8,1]
+ ghc_package_id = "-package-id ghc-" ++ ghcVersion
+ normalise_ghc = if ghc_wired_in then normalisePackageIds else id
+ normalisePackageIds :: [String] -> [String]
+ normalisePackageIds ((isPrefixOf ghc_package_id -> True) : xs) = "-package-id" : "ghc" : xs
+ normalisePackageIds (x:xs) = x : normalisePackageIds xs
+ normalisePackageIds [] = []
+
+ writeFile' (resp_file root p) (intercalate "\n" (normalise_ghc arg_list
++ modules cd
++ concatMap rexp (reexportModules cd)
++ ["-outputdir", hidir]))
@@ -150,7 +161,9 @@ toolTargets = [ cabalSyntax
, ghcHeap
, ghci
, ghcPkg -- # executable
- -- , haddock -- # depends on ghc library
+ , haddock -- # depends on ghc library
+ , haddockApi
+ , haddockLibrary
, hsc2hs -- # executable
, hpc
, hpcBin -- # executable
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs
=====================================
@@ -26,20 +26,20 @@ import Data.Foldable (toList)
import Data.List (sort)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map as Map
-import Data.Maybe
+import qualified Data.Maybe as Maybe
import GHC hiding (fromMaybeContext)
import GHC.Core.Type (Specificity (..))
import GHC.Data.FastString (unpackFS)
import GHC.Types.Name (getOccString, nameOccName, tidyNameOcc)
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader (rdrNameOcc)
+import GHC.Utils.Ppr hiding (Doc, quote)
+import qualified GHC.Utils.Ppr as Pretty
import System.Directory
import System.FilePath
import Prelude hiding ((<>))
import Documentation.Haddock.Markup
-import GHC.Utils.Ppr hiding (Doc, quote)
-import qualified GHC.Utils.Ppr as Pretty
import Haddock.Doc (combineDocumentation)
import Haddock.GhcUtils
import Haddock.Types
@@ -90,7 +90,7 @@ ppLaTeX
ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir =
do
createDirectoryIfMissing True odir
- when (isNothing maybe_style) $
+ when (Maybe.isNothing maybe_style) $
copyFile (libdir </> "latex" </> haddockSty) (odir </> haddockSty)
ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces
mapM_ (ppLaTeXModule title odir) visible_ifaces
@@ -139,7 +139,7 @@ ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do
mods = sort (map (moduleBasename . ifaceMod) ifaces)
- filename = odir </> (fromMaybe "haddock" packageStr <.> "tex")
+ filename = odir </> (Maybe.fromMaybe "haddock" packageStr <.> "tex")
writeUtf8File filename (show tex)
@@ -174,7 +174,7 @@ ppLaTeXModule _title odir iface = do
]
description =
- (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface
+ (Maybe.fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface
body = processExports exports
--
@@ -201,7 +201,7 @@ exportListItem
in sep (punctuate comma [leader <+> ppDocBinder name | name <- names])
<> case subdocs of
[] -> empty
- _ -> parens (sep (punctuate comma (mapMaybe go subdocs)))
+ _ -> parens (sep (punctuate comma (Maybe.mapMaybe go subdocs)))
exportListItem (ExportNoDecl y []) =
ppDocBinder y
exportListItem (ExportNoDecl y subs) =
@@ -368,7 +368,7 @@ ppFamDecl associated doc instances decl unicode =
(if null body then Nothing else Just (vcat body))
$$ instancesBit
where
- body = catMaybes [familyEqns, documentationToLaTeX doc]
+ body = Maybe.catMaybes [familyEqns, documentationToLaTeX doc]
whereBit = case fdInfo (tcdFam decl) of
ClosedTypeFamily _ -> keyword "where"
@@ -544,7 +544,7 @@ ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode
text "\\haddockbeginargs"
$$ vcat (map (uncurry (<->)) (ppSubSigLike unicode typ argDocs [] sep0))
$$ text "\\end{tabulary}\\par"
- $$ fromMaybe empty (documentationToLaTeX doc)
+ $$ Maybe.fromMaybe empty (documentationToLaTeX doc)
-- | This splits up a type signature along @->@ and adds docs (when they exist)
-- to the arguments. The output is a list of (leader/seperator, argument and
@@ -741,7 +741,7 @@ ppClassDecl
hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds
- body = catMaybes [documentationToLaTeX doc, body_]
+ body = Maybe.catMaybes [documentationToLaTeX doc, body_]
body_
| null lsigs, null ats, null at_defs = Nothing
@@ -764,9 +764,13 @@ ppClassDecl
| L _ (ClassOpSig _ is_def lnames typ) <- lsigs
, let doc
| is_def = noDocForDecl
- | otherwise = lookupAnySubdoc (head names) subdocs
+ | otherwise = lookupAnySubdoc firstName subdocs
names = map (cleanName . unLoc) lnames
leader = if is_def then Just (keyword "default") else Nothing
+ firstName =
+ case Maybe.listToMaybe names of
+ Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
+ Just hd -> hd
]
-- N.B. taking just the first name is ok. Signatures with multiple
-- names are expanded so that each name gets its own signature.
@@ -853,7 +857,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode =
where
cons = dd_cons (tcdDataDefn dataDecl)
- body = catMaybes [doc >>= documentationToLaTeX, constrBit, patternBit]
+ body = Maybe.catMaybes [doc >>= documentationToLaTeX, constrBit, patternBit]
(whereBit, leaders)
| null cons
@@ -1031,7 +1035,11 @@ ppSideBySideField subdocs unicode (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 (foExt $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst
+ mbDoc = lookup (foExt $ unLoc name) subdocs >>= fmap _doc . combineDocumentation . fst
+ name =
+ case Maybe.listToMaybe names of
+ Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
+ Just hd -> hd
-- | Pretty-print a bundled pattern synonym
ppSideBySidePat
@@ -1157,7 +1165,7 @@ ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode
ppContextNoArrow :: HsContext DocNameI -> Bool -> LaTeX
ppContextNoArrow cxt unicode =
- fromMaybe empty $
+ Maybe.fromMaybe empty $
ppContextNoLocsMaybe (map unLoc cxt) unicode
ppContextNoLocs :: [HsType DocNameI] -> Bool -> LaTeX
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
=====================================
@@ -6,6 +6,7 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wwarn=x-partial #-}
-- |
-- Module : Haddock.Backends.Html
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
=====================================
@@ -10,7 +10,7 @@
-----------------------------------------------------------------------------
-- |
--- Module : Haddock.Backends.Html.Decl
+-- Module : Haddock.Backends.Xhtml.Decl
-- Copyright : (c) Simon Marlow 2003-2006,
-- David Waern 2006-2009,
-- Mark Lentczner 2010
@@ -28,7 +28,7 @@ import Data.Foldable (toList)
import Data.List (intersperse, sort)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map as Map
-import Data.Maybe
+import qualified Data.Maybe as Maybe
import GHC hiding (LexicalFixity (..), fromMaybeContext)
import GHC.Core.Type (Specificity (..))
import GHC.Data.BooleanFormula
@@ -279,13 +279,17 @@ ppTypeOrFunSig
qual
emptyCtxts
| summary = pref1
- | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curname pkg qual doc
+ | Map.null argDocs = topDeclElem links loc splice docName pref1 +++ docSection curname pkg qual doc
| otherwise =
- topDeclElem links loc splice docnames pref2
+ topDeclElem links loc splice docName pref2
+++ subArguments pkg qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts)
+++ docSection curname pkg qual doc
where
- curname = getName <$> listToMaybe docnames
+ curname = getName <$> Maybe.listToMaybe docnames
+ docName =
+ case Maybe.listToMaybe docnames of
+ Nothing -> error "No docnames. An invariant was broken. Please report this to the Haddock project"
+ Just hd -> hd
-- | This splits up a type signature along @->@ and adds docs (when they exist)
-- to the arguments.
@@ -489,11 +493,15 @@ ppSimpleSig
-> HsSigType DocNameI
-> Html
ppSimpleSig links splice unicode qual emptyCtxts loc names typ =
- topDeclElem' names $ ppTypeSig True occNames ppTyp unicode
+ topDeclElem' docName $ ppTypeSig True occNames ppTyp unicode
where
topDeclElem' = topDeclElem links loc splice
ppTyp = ppSigType unicode qual emptyCtxts typ
occNames = map getOccName names
+ docName =
+ case Maybe.listToMaybe names of
+ Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
+ Just hd -> hd
--------------------------------------------------------------------------------
@@ -530,13 +538,13 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod
curname = Just $ getName docname
header_ =
- topDeclElem links loc splice [docname] $
+ topDeclElem links loc splice docname $
ppFamHeader summary associated decl unicode qual <+> ppFixities fixities qual
instancesBit
| FamilyDecl{fdInfo = ClosedTypeFamily mb_eqns} <- decl
, not summary =
- subEquations pkg qual $ map (ppFamDeclEqn . unLoc) $ fromMaybe [] mb_eqns
+ subEquations pkg qual $ map (ppFamDeclEqn . unLoc) $ Maybe.fromMaybe [] mb_eqns
| otherwise =
ppInstances links (OriginFamily docname) instances splice unicode pkg qual
@@ -706,7 +714,7 @@ 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 $
+ Maybe.fromMaybe noHtml $
ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts
ppContextNoLocs :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Html
@@ -790,9 +798,9 @@ ppShortClassDecl
pkg
qual =
if not (any isUserLSig sigs) && null ats
- then (if summary then id else topDeclElem links loc splice [nm]) hdr
+ then (if summary then id else topDeclElem links loc splice nm) hdr
else
- (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")
+ (if summary then id else topDeclElem links loc splice nm) (hdr <+> keyword "where")
+++ shortSubDecls
False
( [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats, let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
@@ -814,8 +822,12 @@ ppShortClassDecl
pkg
qual
| L _ (ClassOpSig _ False lnames typ) <- sigs
- , let doc = lookupAnySubdoc (head names) subdocs
- names = map unLoc lnames
+ , let names = map unLoc lnames
+ subdocName =
+ case Maybe.listToMaybe names of
+ Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
+ Just hd -> hd
+ doc = lookupAnySubdoc subdocName subdocs
]
-- FIXME: is taking just the first name ok? Is it possible that
-- there are different subdocs for different names in a single
@@ -876,8 +888,8 @@ ppClassDecl
sigs = map unLoc lsigs
classheader
- | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)
- | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)
+ | any isUserLSig lsigs = topDeclElem links loc splice nm (hdr unicode qual <+> keyword "where" <+> fixs)
+ | otherwise = topDeclElem links loc splice nm (hdr unicode qual <+> fixs)
-- Only the fixity relevant to the class header
fixs = ppFixities [f | f@(n, _) <- fixities, n == unLoc lname] qual
@@ -890,7 +902,7 @@ ppClassDecl
atBit =
subAssociatedTypes
[ ppAssocType summary links doc at subfixs splice unicode pkg qual
- <+> subDefaults (maybeToList defTys)
+ <+> subDefaults (Maybe.maybeToList defTys)
| at <- ats
, let name = unLoc . fdLName $ unLoc at
doc = lookupAnySubdoc name subdocs
@@ -941,7 +953,7 @@ ppClassDecl
unicode
pkg
qual
- <+> subDefaults (maybeToList defSigs)
+ <+> subDefaults (Maybe.maybeToList defSigs)
| ClassOpSig _ False lnames typ <- sigs
, name <- map unLoc lnames
, let doc = lookupAnySubdoc name subdocs
@@ -1111,7 +1123,7 @@ ppInstanceAssocTys
-> [DocInstance DocNameI]
-> [Html]
ppInstanceAssocTys links splice unicode qual orphan insts =
- maybeToList $
+ Maybe.maybeToList $
subTableSrc Nothing qual links True $
zipWith
mkInstHead
@@ -1137,10 +1149,14 @@ ppInstanceSigs links splice unicode qual sigs = do
L _ rtyp = dropWildCards typ
-- Instance methods signatures are synified and thus don't have a useful
-- SrcSpan value. Use the methods name location instead.
- return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head lnames) names rtyp
+ let lname =
+ case Maybe.listToMaybe lnames of
+ Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
+ Just hd -> hd
+ return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA lname) names rtyp
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
-lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
+lookupAnySubdoc n = Maybe.fromMaybe noDocForDecl . lookup n
instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> String
instanceId origin no orphan ihd =
@@ -1256,7 +1272,7 @@ ppDataDecl
ConDeclGADT{} -> False
header_ =
- topDeclElem links loc splice [docname] $
+ topDeclElem links loc splice docname $
ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix
fix = ppFixities (filter (\(n, _) -> n == docname) fixities) qual
@@ -1531,7 +1547,10 @@ 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 (foExt $ unLoc $ head names) subdocs >>= combineDocumentation . fst
+ mbDoc = lookup (foExt $ unLoc declName) subdocs >>= combineDocumentation . fst
+ declName = case Maybe.listToMaybe names of
+ Nothing -> error "No names. An invariant was broken. Please report this to the Haddock project"
+ Just hd -> hd
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html
ppShortField summary unicode qual (ConDeclField _ names ltype _) =
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
=====================================
@@ -311,9 +311,9 @@ declElem = paragraph ! [theclass "src"]
-- a box for top level documented names
-- it adds a source and wiki link at the right hand side of the box
-topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html
-topDeclElem lnks loc splice names html =
- declElem << (html <+> (links lnks loc splice Nothing $ head names))
+topDeclElem :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html -> Html
+topDeclElem lnks loc splice name html =
+ declElem << (html <+> links lnks loc splice Nothing name)
-- FIXME: is it ok to simply take the first name?
=====================================
utils/haddock/haddock-api/src/Haddock/Utils/Json.hs
=====================================
@@ -371,10 +371,9 @@ instance FromJSON Char where
parseJSONList v = typeMismatch "String" v
parseChar :: String -> Parser Char
-parseChar t =
- if length t == 1
- then pure $ head t
- else prependContext "Char" $ fail "expected a string of length 1"
+parseChar [c] = pure c
+parseChar [] = prependContext "Char" $ fail "expected a string of length 1, got an empty string"
+parseChar (_ : _) = prependContext "Char" $ fail "expected a string of length 1, got a longer string"
parseRealFloat :: RealFloat a => String -> Value -> Parser a
parseRealFloat _ (Number s) = pure $ realToFrac s
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4ccc25bbc3d6f35d22e7f327a1aab9f0456fcbdf...07ba0d216f0a91353db2125b7c44a19219c80213
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4ccc25bbc3d6f35d22e7f327a1aab9f0456fcbdf...07ba0d216f0a91353db2125b7c44a19219c80213
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/20240905/55e71052/attachment-0001.html>
More information about the ghc-commits
mailing list