Merge pull request #1518 from bgamari/wip/ghc-9.4-merge

Merge GHC 9.4 into `main`

.github/workflows/ci.yml

@@ -4,7 +4,7 @@ name: CI
 on:
   pull_request:
   push:
-    branches: ["ghc-9.2"]
+    branches: ["ghc-head"]
 
 jobs:
   cabal:
@@ -15,46 +15,41 @@ jobs:
         os: [ubuntu-latest]
         cabal: ["3.6"]
         ghc:
-          - "9.2.2"
+          - "head"
 
     steps:
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v2
+      if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/ghc-head'
 
-    - uses: haskell/actions/setup@v2
+    - name: Install gmp and tinfo
+      run: |
+        sudo -- sh -c "apt-get update"
+        sudo -- sh -c "apt-get -y install libgmp-dev libtinfo-dev"
+
+    - uses: haskell/actions/setup@main
       id: setup-haskell-cabal
       name: Setup Haskell
       with:
         ghc-version: ${{ matrix.ghc }}
         cabal-version: ${{ matrix.cabal }}
 
-    # GitHub preinstalls recent GHC versions, and haskell/actions/setup uses the
-    # preinstalled version when possible. However, GitHub's preinstalled GHC does
-    # not include documentation, and we need documentation to run Haddock tests.
-    # Therefore, we reinstall GHC to ensure that we have the documentation we
-    # need.
-    - name: Reinstall GHC with docs
-      run: |
-        if [[ ! -e ~/.ghcup/ghc/${{ matrix.ghc }}/share/doc ]]; then
-          ghcup install ghc --force ${{ matrix.ghc }} --set
-        fi
+    - name: Prepare environment
+      run: echo "$HOME/.ghcup/bin" >> $GITHUB_PATH
 
-    - name: Setup
+    - name: Freeze
       run: |
-        cabal configure --with-compiler ghc-${{ matrix.ghc }} --enable-tests --enable-benchmarks --test-show-details=direct
         cabal freeze
-
+ 
     - uses: actions/cache@v2
       name: Cache ~/.cabal/store
       with:
         path: |
           ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
-          dist-newstyle
         key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
-        restore-keys: |
-          ${{ runner.os }}-cabal-${{ matrix.ghc }}
 
     - name: Build
       run: |
+        cabal configure --enable-tests --enable-benchmarks --test-show-details=direct
         cabal build all
 
     - name: Test

CONTRIBUTING.md

@@ -36,28 +36,32 @@ cd haddock
 
 ### Git Branches
 
-Pull requests are to be opened against the `main` branch, from which are forked
-GHC-specific branches (like `ghc-9.2`, `ghc-9.4`, etc).
+If your patch consists of glue code and interface changes with GHC, please
+open a Pull Request targeting the `ghc-head` branch.
+
+Otherwise, for improvements to the documentation generator,
+please base your pull request on the current GHC version branch
+(`ghc-9.0` for instance). The PR will be forward-ported to `ghc-head`
+so that documentation built within GHC can benefit from it.
 
 ### Building the packages
 
 #### Using `cabal`
 
-First update the package list:
+Requires cabal `>= 3.4` and GHC `== 9.4`:
+
+You can install the latest build of GHC via ghcup using this command:
 
 ```bash
-cabal v2-update
+ghcup install ghc -u "https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/raw/ghc-x86_64-deb9-linux-integer-simple.tar.xz?job=validate-x86_64-linux-deb9-integer-simple" head
 ```
 
-This is needed as [email protected] uses the
-[ghc.head](https://ghc.gitlab.haskell.org/head.hackage/) package repository.
-
 ```bash
 cabal v2-build all --enable-tests
 cabal v2-test all
 ```
 
-### Updating golden test suite outputs
+### Updating golden testsuite outputs
 
 If you've changed Haddock's output, you will probably need to accept the new
 output of Haddock's golden test suites (`html-test`, `latex-test`,
@@ -69,5 +73,6 @@ cabal v2-test html-test latex-test hoogle-test hypsrc-test \
   --test-option='--accept'
 ```
 
+
 [SSCCE]: http://sscce.org/
 [CoC]: ./CODE_OF_CONDUCT.md

cabal.project

@@ -1,17 +1,23 @@
-with-compiler: ghc-9.2
+with-compiler: ghc-9.4
 
 packages: ./
           ./haddock-api
           ./haddock-library
           ./haddock-test
 
-active-repositories: hackage.haskell.org, head.hackage.ghc.haskell.org:override
+with-compiler: ghc-9.4
 
-repository head.hackage.ghc.haskell.org
-   url: https://ghc.gitlab.haskell.org/head.hackage/
-   secure: True
-   key-threshold: 3
-   root-keys:
-       f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89
-       26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329
-       7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d
+allow-newer:
+  ghc-paths:Cabal,
+  *:base,
+  *:ghc-prim,
+  tree-diff:time
+
+package haddock-library
+ tests: False
+
+package haddock-api
+  tests: False
+
+-- Pinning the index-state helps to make reasonably CI deterministic
+index-state: 2022-08-05T20:43:48Z

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 <[email protected]>, Alex Biehl <[email protected]>, Simon Hengel <[email protected]>, Mateusz Kowalczyk <[email protected]>
@@ -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

haddock-api/src/Documentation/Haddock.hs

@@ -52,9 +52,7 @@ module Documentation.Haddock (
   -- * Interface files
   InterfaceFile(..),
   readInterfaceFile,
-  nameCacheFromGhc,
   freshNameCache,
-  NameCacheAccessor,
 
   -- * Flags and options
   Flag(..),

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
+

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)]