diff --git a/himportscan/src/HImportScan/GHC/FakeSettings9_4.hs b/himportscan/src/HImportScan/GHC/FakeSettings9_4.hs index 07b5e1c..1bf76e3 100644 --- a/himportscan/src/HImportScan/GHC/FakeSettings9_4.hs +++ b/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 #-} diff --git a/himportscan/src/HImportScan/GHC/FakeSettings9_6.hs b/himportscan/src/HImportScan/GHC/FakeSettings9_6.hs new file mode 100644 index 0000000..ee1fc2e --- /dev/null +++ b/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 diff --git a/himportscan/src/HImportScan/GHC9_4.hs b/himportscan/src/HImportScan/GHC9_4.hs index 89fad09..9b61c04 100644 --- a/himportscan/src/HImportScan/GHC9_4.hs +++ b/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 diff --git a/himportscan/src/HImportScan/GHC9_6.hs b/himportscan/src/HImportScan/GHC9_6.hs new file mode 100644 index 0000000..12b0e74 --- /dev/null +++ b/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 diff --git a/himportscan/src/HImportScan/ImportScanner.hs b/himportscan/src/HImportScan/ImportScanner.hs index 1205b26..3b130a6 100644 --- a/himportscan/src/HImportScan/ImportScanner.hs +++ b/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.