himportscan upgrade for GHC 9.6

himportscan/src/HImportScan/GHC/FakeSettings9_4.hs

@@ -2,7 +2,7 @@
 -- SPDX-License-Identifier: BSD-3-Clause.
 {-#LANGUAGE CPP #-}
 
-#if __GLASGOW_HASKELL__ >= 904
+#if __GLASGOW_HASKELL__ == 904
 
 {-# OPTIONS_GHC -Wno-missing-fields #-}
 {-# OPTIONS_GHC -Wno-name-shadowing #-}

himportscan/src/HImportScan/GHC/FakeSettings9_6.hs

@@ -0,0 +1,67 @@
+-- Copyright (c) 2020, Shayne Fletcher. All rights reserved.
+-- SPDX-License-Identifier: BSD-3-Clause.
+{-#LANGUAGE CPP #-}
+
+#if __GLASGOW_HASKELL__ >= 906
+
+{-# OPTIONS_GHC -Wno-missing-fields #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+
+-- This file is a single code path copied over from https://hackage.haskell.org/package/ghc-lib-parser-ex-8.10.0.24/docs/src/Language.Haskell.GhclibParserEx.GHC.Settings.Config.html
+-- TODO[GL]: We can get rid of this file once we only support >=9.2, as ParserOpts are much smaller there.
+module HImportScan.GHC.FakeSettings9_6(
+    fakeSettings
+  , fakeLlvmConfig
+  )
+where
+
+import GHC.CmmToLlvm.Config (LlvmConfig (..))
+import GHC.Settings.Config
+import GHC.Driver.Session
+import GHC.Utils.Fingerprint
+import GHC.Platform
+import GHC.Settings
+
+fakeSettings :: Settings
+fakeSettings = Settings
+  { sGhcNameVersion=ghcNameVersion
+  , sFileSettings=fileSettings
+  , sTargetPlatform=platform
+  , sPlatformMisc=platformMisc
+  , sToolSettings=toolSettings
+  , sRawSettings=[]
+  }
+  where
+    toolSettings = ToolSettings {
+      toolSettings_opt_P_fingerprint=fingerprint0
+      }
+    fileSettings = FileSettings {}
+    platformMisc = PlatformMisc {}
+    ghcNameVersion =
+      GhcNameVersion{ghcNameVersion_programName="ghc"
+                    ,ghcNameVersion_projectVersion=cProjectVersion
+                    }
+    platform =
+      Platform{
+        platformWordSize=PW8
+      , platformArchOS=ArchOS {archOS_arch=ArchUnknown, archOS_OS=OSUnknown}
+      , platformByteOrder = LittleEndian
+      , platformUnregisterised=True
+      , platformHasGnuNonexecStack = False
+      , platformHasIdentDirective = False
+      , platformHasSubsectionsViaSymbols = False
+      , platformIsCrossCompiling = False
+      , platformLeadingUnderscore = False
+      , platformTablesNextToCode = False
+      , platform_constants = Nothing
+      , platformHasLibm = True
+      }
+
+fakeLlvmConfig :: LlvmConfig
+fakeLlvmConfig = LlvmConfig [] []
+
+#else
+
+module HImportScan.GHC.FakeSettings9_4 where
+
+#endif

himportscan/src/HImportScan/GHC9_4.hs

@@ -1,6 +1,6 @@
 {-#LANGUAGE CPP #-}
 
-#if __GLASGOW_HASKELL__ >= 904
+#if __GLASGOW_HASKELL__ == 904
 
 -- | A module abstracting the provenance of GHC API names
 module HImportScan.GHC9_4 (module X, imports, handleParseError, getOptions) where

himportscan/src/HImportScan/GHC9_6.hs

@@ -0,0 +1,103 @@
+{-#LANGUAGE CPP #-}
+
+#if __GLASGOW_HASKELL__ >= 906
+
+-- | A module abstracting the provenance of GHC API names
+module HImportScan.GHC9_6 (module X, imports, handleParseError, getOptions) where
+
+import HImportScan.GHC.FakeSettings9_6 as X
+
+import GHC.Driver.Session as X (DynFlags, defaultDynFlags, xopt_set, xopt_unset)
+import GHC.Data.EnumSet as X (empty, fromList)
+import GHC.Driver.Errors as X (printMessages)
+import GHC.Data.FastString as X (FastString, mkFastString, unpackFS)
+import GHC as X (runGhc, getSessionDynFlags)
+import GHC.LanguageExtensions as X
+  (Extension
+    ( ImportQualifiedPost
+    , PackageImports
+    , TemplateHaskell
+    , ImplicitPrelude
+    , PatternSynonyms
+    , ExplicitNamespaces
+    , MagicHash
+    )
+  )
+import GHC.Parser.Header as X (getImports)
+import GHC.Types.Error (NoDiagnosticOpts (..))
+import GHC.Types.SourceError (mkSrcErr)
+import GHC.Parser.Lexer as X
+  ( ParseResult(..)
+  , ParserOpts
+  , Token(..)
+  , lexer
+  , loc
+  , unP
+  )
+import GHC.Unit.Module as X (ModuleName, moduleNameString)
+import GHC.Types.SrcLoc as X
+  ( Located
+  , RealSrcLoc
+  , SrcLoc(RealSrcLoc)
+  , getLoc
+  , mkRealSrcLoc
+  , srcLocLine
+  , srcLocCol
+  , srcSpanStart
+  , unLoc
+  )
+import GHC.Data.StringBuffer as X (StringBuffer(StringBuffer), stringToStringBuffer)
+import GHC.Driver.Config.Parser
+import GHC.Utils.Logger as X
+import Control.Exception (throwIO)
+import GHC.Parser.Errors.Types (PsMessage)
+import GHC.Driver.Errors.Types (GhcMessage(GhcPsMessage))
+import GHC.Driver.Config.Diagnostic (initDiagOpts)
+import GHC.Types.Error (Messages)
+import GHC.Types.PkgQual (RawPkgQual (RawPkgQual, NoRawPkgQual))
+import qualified GHC.Types.SourceText as StringLiteral (sl_fs)
+import qualified GHC.Parser.Header as PH (getOptions)
+
+initOpts :: DynFlags -> ParserOpts
+initOpts = initParserOpts
+
+getOptions :: DynFlags -> StringBuffer -> FilePath -> [Located String]
+getOptions dynFlags sb filePath =
+  snd $ PH.getOptions (initOpts dynFlags) sb filePath
+
+imports ::
+  DynFlags ->
+  StringBuffer ->
+  FilePath ->
+  IO
+    ( Either
+      -- (Bag PsError)
+      (Messages PsMessage)
+      ( [(Maybe FastString, Located ModuleName)],
+        [(Maybe FastString, Located ModuleName)], Located ModuleName
+      )
+    )
+imports dynFlagsWithExtensions sb filePath = do
+  -- [GG] We should never care about the Prelude import,
+  -- since it is always a module from an external library.
+  -- Hence the `False`.
+  imports' <- getImports (initOpts dynFlagsWithExtensions) False sb filePath filePath
+
+  return $ (\ (m1, m2, _, mname) -> (toFastMessage <$> m1, toFastMessage <$> m2, mname)) `fmap` imports'
+  where
+    toFastMessage (NoRawPkgQual, b) = (Nothing, b)
+    toFastMessage (RawPkgQual stringLit, b) = (Just $ StringLiteral.sl_fs stringLit, b)
+
+handleParseError :: DynFlags -> Messages PsMessage -> IO a
+handleParseError dynFlagsWithExtensions err = do
+  logger <- initLogger
+  let diagOpts = initDiagOpts dynFlagsWithExtensions
+      ghcErrors = GhcPsMessage <$> err
+  printMessages logger NoDiagnosticOpts diagOpts err
+  throwIO (mkSrcErr ghcErrors)
+
+#else
+
+module HImportScan.GHC9_6 where
+
+#endif

himportscan/src/HImportScan/ImportScanner.hs

@@ -26,7 +26,9 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import System.Directory (doesFileExist)
 
-#if __GLASGOW_HASKELL__ >= 904
+#if   __GLASGOW_HASKELL__ >= 906
+import HImportScan.GHC9_6 as GHC
+#elif __GLASGOW_HASKELL__ == 904
 import HImportScan.GHC9_4 as GHC
 #elif __GLASGOW_HASKELL__ >= 902
 import HImportScan.GHC9_2 as GHC
@@ -112,8 +114,12 @@ scanImports filePath contents = do
 
   -- TODO[GL]: Once we're on ghc 9.2 we can get rid of all the things relating to dynFlags, and use the much smaller
   -- ParserOpts, as getImports no longer depends on DynFlags then.
-  let dynFlagsWithExtensions = toggleDynFlags $ GHC.defaultDynFlags GHC.fakeSettings GHC.fakeLlvmConfig
-
+  let dynFlagsWithExtensions = toggleDynFlags $
+#if __GLASGOW_HASKELL__ >= 906
+        GHC.defaultDynFlags GHC.fakeSettings
+#else
+        GHC.defaultDynFlags GHC.fakeSettings GHC.fakeLlvmConfig
+#endif
   let
     -- [GL] The fact that the resulting strings here contain the "-X"s makes me a bit doubtful that this is the right approach,
     -- but this is what I found for now.