gitlab-ci: Check coverage of GHC flags in users guide

This ensures that all GHC flags are documented during the documentation
build.

Fixes #17315.

3 files changed, 293 insertions, 0 deletions

diff --git a/docs/users_guide/compare-flags.py b/docs/users_guide/compare-flags.py
new file mode 100755
index 0000000000..086746e64a
--- /dev/null
+++ b/docs/users_guide/compare-flags.py
@@ -0,0 +1,91 @@
+#!/usr/bin/env python
+# -*- coding: utf-8 -*-
+
+"""
+Linter to verify that all flags reported by GHC's --show-options mode
+are documented in the user's guide.
+"""
+
+import sys
+import subprocess
+from typing import Set
+from pathlib import Path
+
+# A list of known-undocumented flags. This should be considered to be a to-do
+# list of flags that need to be documented.
+EXPECTED_UNDOCUMENTED_PATH = \
+    Path(__file__).parent / 'expected-undocumented-flags.txt'
+
+EXPECTED_UNDOCUMENTED = \
+    {line for line in open(EXPECTED_UNDOCUMENTED_PATH).read().split()}
+
+def expected_undocumented(flag: str) -> bool:
+    if flag in EXPECTED_UNDOCUMENTED:
+        return True
+    if flag.startswith('-Werror'):
+        return True
+    if flag.startswith('-Wno-') \
+            or flag.startswith('-dno') \
+            or flag.startswith('-fno') \
+            or flag.startswith('-XNo'):
+        return True
+    if flag.startswith('-Wwarn=') \
+            or flag.startswith('-Wno-warn='):
+        return True
+
+    return False
+
+def read_documented_flags(doc_flags) -> Set[str]:
+    # Map characters that mark the end of a flag
+    # to whitespace.
+    trans = str.maketrans({
+        '=': ' ',
+        '[': ' ',
+        '⟨': ' ',
+    })
+    return {line.translate(trans).split()[0]
+            for line in doc_flags.read().split('\n')
+            if line != ''}
+
+def read_ghc_flags(ghc_path: str) -> Set[str]:
+    ghc_output = subprocess.check_output([ghc_path, '--show-options'],
+                                         encoding='UTF-8')
+    return {flag
+            for flag in ghc_output.split('\n')
+            if not expected_undocumented(flag)
+            if flag != ''}
+
+def main() -> None:
+    import argparse
+    parser = argparse.ArgumentParser()
+    parser.add_argument('--ghc', type=argparse.FileType('r'),
+                        help='path of GHC executable')
+    parser.add_argument('--doc-flags', type=argparse.FileType('r'),
+                        help='path of ghc-flags.txt output from Sphinx')
+    args = parser.parse_args()
+
+    doc_flags = read_documented_flags(args.doc_flags)
+    ghc_flags = read_ghc_flags(args.ghc.name)
+
+    failed = False
+
+    undocumented = ghc_flags - doc_flags
+    if len(undocumented) > 0:
+        print(f'Found {len(undocumented)} flags not documented in the users guide:')
+        print('\n'.join(f'  {flag}' for flag in sorted(undocumented)))
+        print()
+        failed = True
+
+    now_documented = EXPECTED_UNDOCUMENTED.intersection(doc_flags)
+    if len(now_documented) > 0:
+        print(f'Found flags that are documented yet listed in {EXPECTED_UNDOCUMENTED_PATH}:')
+        print('\n'.join(f'  {flag}' for flag in sorted(now_documented)))
+        print()
+        failed = True
+
+    if failed:
+        sys.exit(1)
+
+
+if __name__ == '__main__':
+    main()
diff --git a/docs/users_guide/expected-undocumented-flags.txt b/docs/users_guide/expected-undocumented-flags.txt
new file mode 100644
index 0000000000..041eeda3eb
--- /dev/null
+++ b/docs/users_guide/expected-undocumented-flags.txt
@@ -0,0 +1,185 @@
+-#include
+--abi-hash
+--backpack
+--print-booter-version
+--print-build-platform
+--print-c-compiler-flags
+--print-c-compiler-link-flags
+--print-debug-on
+--print-global-package-db
+--print-have-interpreter
+--print-have-native-code-generator
+--print-host-platform
+--print-ld-flags
+--print-leading-underscore
+--print-object-splitting-supported
+--print-project-git-commit-id
+--print-project-version
+--print-rts-ways
+--print-stage
+--print-support-smp
+--print-tables-next-to-code
+--print-target-platform
+--print-unregisterised
+--show-packages
+-Onot
+-Wall-missed-specializations
+-Walternative-layout-rule-transitional
+-Wauto-orphans
+-Wdefault
+-Wderiving-typeable
+-Wextra
+-Wimplicit-kind-vars
+-Wmissed-specializations
+-Wmissing-space-after-bang
+-Wnot
+-Wprepositive-qualified-module
+-XAlternativeLayoutRule
+-XAlternativeLayoutRuleTransitional
+-XAutoDeriveTypeable
+-XDoAndIfThenElse
+-XDoRec
+-XGHCForeignImportPrim
+-XGenerics
+-XHaskell2010
+-XHaskell98
+-XImplicitPrelude
+-XJavaScriptFFI
+-XMonoPatBinds
+-XMonomorphismRestriction
+-XParallelArrays
+-XPatternGuards
+-XPatternSignatures
+-XPolymorphicComponents
+-XRecordPuns
+-XRelaxedLayout
+-XRelaxedPolyRec
+-XTraditionalRecordSyntax
+-XUnliftedFFITypes
+-auto
+-auto-all
+-caf-all
+-copy-libs-when-linking
+-dannot-lint
+-dasm-lint
+-ddebug-output
+-ddump-asm-conflicts
+-ddump-call-arity
+-ddump-cs-trace
+-ddump-debug
+-ddump-exitify
+-ddump-simpl-trace
+-ddump-view-pattern-commoning
+-ddump-vt-trace
+-dppr-ticks
+-dsource-stats
+-dstg-stats
+-dsuppress-stg-exts
+-dynhisuf
+-dyno
+-dynosuf
+-exclude-module
+-fallow-incoherent-instances
+-fallow-overlapping-instances
+-fallow-undecidable-instances
+-farrows
+-fast-llvm
+-fbang-patterns
+-fbuilding-cabal-package
+-fconstraint-solver-iterations
+-fcontext-stack
+-fcross-module-specialize
+-fdiagnostics-color=always
+-fdiagnostics-color=auto
+-fdiagnostics-color=never
+-fembed-manifest
+-fextended-default-rules
+-fffi
+-ffi
+-fflat-cache
+-ffloat-all-lams
+-ffloat-lam-args
+-ffrontend-opt
+-fgen-manifest
+-fghci-history
+-fghci-sandbox
+-fhistory-size
+-fimplicit-params
+-fimplicit-prelude
+-firrefutable-tuples
+-fkeep-cafs
+-fkill-absence
+-fkill-one-shot
+-fmax-errors
+-fmax-pmcheck-iterations
+-fmono-pat-binds
+-fmonomorphism-restriction
+-fnum-constant-folding
+-fpre-inlining
+-fprof-count-entries
+-freduction-depth
+-frewrite-rules
+-fscoped-type-variables
+-fshared-implib
+-fshow-valid-hole-fits
+-fshow-valid-substitutions
+-fsort-valid-hole-fits
+-fspec-constr-recursive
+-fspecialize
+-fspecialize-aggressively
+-fstg-lift-lams-non-rec-args-any
+-fstg-lift-lams-rec-args-any
+-fth
+-ftype-function-depth
+-fuse-rpaths
+-fversion-macros
+-fvia-c
+-fworker-wrapper
+-haddock
+-haddock-opts
+-hpcdir
+-instantiated-with
+-keep-hi-file
+-keep-o-file
+-mavx
+-mavx2
+-mavx512cd
+-mavx512er
+-mavx512f
+-mavx512pf
+-mbmi
+-msse
+-msse3
+-msse4
+-n
+-no-auto
+-no-auto-all
+-no-caf-all
+-no-keep-hi-file
+-no-keep-hi-files
+-no-keep-o-file
+-no-keep-o-files
+-no-link
+-no-pie
+-no-recomp
+-no-rtsopts
+-no-user-package-conf
+-package-conf
+-package-name
+-pgmar
+-pgmranlib
+-recomp
+-relative-dynlib-paths
+-rtsopts=all
+-rtsopts=ignore
+-rtsopts=ignoreAll
+-rtsopts=none
+-rtsopts=some
+-smp
+-split-objs
+-syslib
+-this-component-id
+-this-package-key
+-ticky-LNE
+-ticky-allocd
+-ticky-dyn-thunk
diff --git a/hadrian/src/Rules/Documentation.hs b/hadrian/src/Rules/Documentation.hs
index 2671c921e2..28740fb936 100644
--- a/hadrian/src/Rules/Documentation.hs
+++ b/hadrian/src/Rules/Documentation.hs
@@ -16,6 +16,7 @@ import Context
 import Expression (getContextData, interpretInContext, (?), package)
 import Flavour
 import Oracles.ModuleFiles
+import Oracles.Setting (topDirectory)
 import Packages
 import Settings
 import Target
@@ -111,6 +112,11 @@ documentationRules = do
 
         need $ map (root -/-) targets
 
+        when (SphinxPDFs `Set.member` doctargets)
+          $ checkUserGuideFlags $ pdfRoot -/- "users_guide" -/- "ghc-flags.txt"
+        when (SphinxHTML `Set.member` doctargets)
+          $ checkUserGuideFlags $ htmlRoot -/- "users_guide" -/- "ghc-flags.txt"
+
     where archiveTarget "libraries"   = Haddocks
           archiveTarget _             = SphinxHTML
 
@@ -124,6 +130,17 @@ checkSphinxWarnings out = do
     when ("reference target not found" `isInfixOf` log)
       $ fail "Undefined reference targets found in Sphinx log."
 
+-- | Check that all GHC flags are documented in the users guide.
+checkUserGuideFlags :: FilePath -> Action ()
+checkUserGuideFlags documentedFlagList = do
+    scriptPath <- (</> "docs/user_guide/compare-flags.py") <$> topDirectory
+    ghcPath <- (</>) <$> topDirectory <*> programPath (vanillaContext Stage1 ghc)
+    runBuilder Python
+      [ scriptPath
+      , "--doc-flags", documentedFlagList
+      , "--ghc", ghcPath
+      ] [documentedFlagList] []
+
 
 ------------------------------------- HTML -------------------------------------