mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 05:36:09 +03:00
Support parsedResultAction of GHC plugins (#795)
* add failing test
* add fix (disable hasrecord due to linker error on my local machine)
* re-enable record-hasfield
* Allow CPP in Preprocessor module
* Revert "Allow CPP in Preprocessor module"
This reverts commit c392150421
.
* apply pr 801
* move all the CPP to D.I.GHC.Compat
* fix hlint complaint
* unconditionally import MonadIO
* refactor, address PR comments
* isolate the two plugin tests
* minimize diff
* Fix test timeout
* Disable record pre processor test in 8.4
* Fix compiler warning on 8.4
* Fix yet another warning in 8.4
* Explicitly import for 8.4
* 8.4 again
* Don't apply this plugin in 8.4
The Plugins import is unavailable in 8.4
* CPP at it again
This commit is contained in:
parent
91cb1a96e0
commit
8d478394af
@ -350,6 +350,10 @@ test-suite ghcide-tests
|
||||
tasty-quickcheck,
|
||||
tasty-rerun,
|
||||
text
|
||||
if (impl(ghc >= 8.6))
|
||||
build-depends:
|
||||
record-dot-preprocessor,
|
||||
record-hasfield
|
||||
hs-source-dirs: test/cabal test/exe test/src bench/lib
|
||||
include-dirs: include
|
||||
ghc-options: -threaded -Wall -Wno-name-shadowing -O0
|
||||
|
@ -43,7 +43,6 @@ import Development.IDE.Types.Options
|
||||
import Development.IDE.Types.Location
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
import DynamicLoading (initializePlugins)
|
||||
import LoadIface (loadModuleInterface)
|
||||
#endif
|
||||
|
||||
@ -101,8 +100,8 @@ parseModule
|
||||
parseModule IdeOptions{..} env comp_pkgs filename modTime mbContents =
|
||||
fmap (either (, Nothing) id) $
|
||||
evalGhcEnv env $ runExceptT $ do
|
||||
(contents, dflags) <- preprocessor filename mbContents
|
||||
(diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename modTime contents
|
||||
(contents, dflags) <- preprocessor env filename mbContents
|
||||
(diag, modu) <- parseFileContents env optPreprocessor dflags comp_pkgs filename modTime contents
|
||||
return (diag, Just (contents, modu))
|
||||
|
||||
|
||||
@ -456,12 +455,13 @@ getModSummaryFromBuffer fp modTime dflags parsed contents = do
|
||||
-- Runs preprocessors as needed.
|
||||
getModSummaryFromImports
|
||||
:: (HasDynFlags m, ExceptionMonad m, MonadIO m)
|
||||
=> FilePath
|
||||
=> HscEnv
|
||||
-> FilePath
|
||||
-> UTCTime
|
||||
-> Maybe SB.StringBuffer
|
||||
-> ExceptT [FileDiagnostic] m ModSummary
|
||||
getModSummaryFromImports fp modTime contents = do
|
||||
(contents, dflags) <- preprocessor fp contents
|
||||
getModSummaryFromImports env fp modTime contents = do
|
||||
(contents, dflags) <- preprocessor env fp contents
|
||||
(srcImports, textualImports, L _ moduleName) <-
|
||||
ExceptT $ liftIO $ first (diagFromErrMsgs "parser" dflags) <$> GHC.getHeaderImports dflags contents fp fp
|
||||
|
||||
@ -532,14 +532,15 @@ parseHeader dflags filename contents = do
|
||||
-- parsed module (or errors) and any parse warnings. Does not run any preprocessors
|
||||
parseFileContents
|
||||
:: GhcMonad m
|
||||
=> (GHC.ParsedSource -> IdePreprocessedSource)
|
||||
=> HscEnv
|
||||
-> (GHC.ParsedSource -> IdePreprocessedSource)
|
||||
-> DynFlags -- ^ flags to use
|
||||
-> [PackageName] -- ^ The package imports to ignore
|
||||
-> FilePath -- ^ the filename (for source locations)
|
||||
-> UTCTime -- ^ the modification timestamp
|
||||
-> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
|
||||
-> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
|
||||
parseFileContents customPreprocessor dflags comp_pkgs filename modTime contents = do
|
||||
parseFileContents env customPreprocessor dflags comp_pkgs filename modTime contents = do
|
||||
let loc = mkRealSrcLoc (mkFastString filename) 1 1
|
||||
case unP Parser.parseModule (mkPState dflags contents loc) of
|
||||
#if MIN_GHC_API_VERSION(8,10,0)
|
||||
@ -574,17 +575,17 @@ parseFileContents customPreprocessor dflags comp_pkgs filename modTime contents
|
||||
let parsed' = removePackageImports comp_pkgs parsed
|
||||
let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
|
||||
ms <- getModSummaryFromBuffer filename modTime dflags parsed' contents
|
||||
parsed'' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed
|
||||
let pm =
|
||||
ParsedModule {
|
||||
pm_mod_summary = ms
|
||||
, pm_parsed_source = parsed'
|
||||
, pm_parsed_source = parsed''
|
||||
, pm_extra_src_files=[] -- src imports not allowed
|
||||
, pm_annotations = hpm_annotations
|
||||
}
|
||||
warnings = diagFromErrMsgs "parser" dflags warns
|
||||
pure (warnings ++ preproc_warnings, pm)
|
||||
|
||||
|
||||
-- | After parsing the module remove all package imports referring to
|
||||
-- these packages as we have already dealt with what they map to.
|
||||
removePackageImports :: [PackageName] -> GHC.ParsedSource -> GHC.ParsedSource
|
||||
|
@ -37,8 +37,8 @@ import Exception (ExceptionMonad)
|
||||
|
||||
-- | Given a file and some contents, apply any necessary preprocessors,
|
||||
-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
|
||||
preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)
|
||||
preprocessor filename mbContents = do
|
||||
preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)
|
||||
preprocessor env filename mbContents = do
|
||||
-- Perform unlit
|
||||
(isOnDisk, contents) <-
|
||||
if isLiterate filename then do
|
||||
@ -51,7 +51,7 @@ preprocessor filename mbContents = do
|
||||
return (isOnDisk, contents)
|
||||
|
||||
-- Perform cpp
|
||||
dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
|
||||
dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents
|
||||
(isOnDisk, contents, dflags) <-
|
||||
if not $ xopt LangExt.Cpp dflags then
|
||||
return (isOnDisk, contents, dflags)
|
||||
@ -68,7 +68,7 @@ preprocessor filename mbContents = do
|
||||
[] -> throw e
|
||||
diags -> return $ Left diags
|
||||
)
|
||||
dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
|
||||
dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents
|
||||
return (False, contents, dflags)
|
||||
|
||||
-- Perform preprocessor
|
||||
@ -76,7 +76,7 @@ preprocessor filename mbContents = do
|
||||
return (contents, dflags)
|
||||
else do
|
||||
contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents
|
||||
dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
|
||||
dflags <- ExceptT $ parsePragmasIntoDynFlags env filename contents
|
||||
return (contents, dflags)
|
||||
where
|
||||
logAction :: IORef [CPPLog] -> LogAction
|
||||
@ -134,10 +134,11 @@ isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]
|
||||
-- | This reads the pragma information directly from the provided buffer.
|
||||
parsePragmasIntoDynFlags
|
||||
:: (ExceptionMonad m, HasDynFlags m, MonadIO m)
|
||||
=> FilePath
|
||||
=> HscEnv
|
||||
-> FilePath
|
||||
-> SB.StringBuffer
|
||||
-> m (Either [FileDiagnostic] DynFlags)
|
||||
parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
|
||||
parsePragmasIntoDynFlags env fp contents = catchSrcErrors "pragmas" $ do
|
||||
dflags0 <- getDynFlags
|
||||
let opts = Hdr.getOptions dflags0 contents fp
|
||||
|
||||
@ -145,8 +146,8 @@ parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
|
||||
liftIO $ evaluate $ rnf opts
|
||||
|
||||
(dflags, _, _) <- parseDynamicFilePragma dflags0 opts
|
||||
return $ disableWarningsAsErrors dflags
|
||||
|
||||
dflags' <- liftIO $ initializePlugins env dflags
|
||||
return $ disableWarningsAsErrors dflags'
|
||||
|
||||
-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
|
||||
runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
|
||||
|
@ -735,11 +735,12 @@ isHiFileStableRule = define $ \IsHiFileStable f -> do
|
||||
getModSummaryRule :: Rules ()
|
||||
getModSummaryRule = do
|
||||
defineEarlyCutoff $ \GetModSummary f -> do
|
||||
dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f
|
||||
session <- hscEnv <$> use_ GhcSession f
|
||||
let dflags = hsc_dflags session
|
||||
(modTime, mFileContent) <- getFileContents f
|
||||
let fp = fromNormalizedFilePath f
|
||||
modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $
|
||||
getModSummaryFromImports fp modTime (textToStringBuffer <$> mFileContent)
|
||||
getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent)
|
||||
case modS of
|
||||
Right ms -> do
|
||||
let fingerPrint = hash (computeFingerprint f dflags ms, hashUTC modTime)
|
||||
|
@ -56,6 +56,8 @@ module Development.IDE.GHC.Compat(
|
||||
disableWarningsAsErrors,
|
||||
|
||||
module GHC,
|
||||
initializePlugins,
|
||||
applyPluginsParsedResultAction,
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,8,0)
|
||||
@ -112,6 +114,8 @@ import FastString (FastString)
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
import Development.IDE.GHC.HieAst (mkHieFile)
|
||||
import Development.IDE.GHC.HieBin
|
||||
import qualified DynamicLoading
|
||||
import Plugins (Plugin(parsedResultAction), withPlugins)
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,8,0)
|
||||
import HieUtils
|
||||
@ -467,3 +471,27 @@ wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags
|
||||
wopt_unset_fatal dfs f
|
||||
= dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }
|
||||
#endif
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
initializePlugins :: HscEnv -> DynFlags -> IO DynFlags
|
||||
initializePlugins env dflags = do
|
||||
DynamicLoading.initializePlugins env dflags
|
||||
|
||||
applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource
|
||||
applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do
|
||||
-- Apply parsedResultAction of plugins
|
||||
let applyPluginAction p opts = parsedResultAction p opts ms
|
||||
fmap hpm_module $
|
||||
runHsc env $ withPlugins dflags applyPluginAction
|
||||
(HsParsedModule parsed [] hpm_annotations)
|
||||
|
||||
#else
|
||||
initializePlugins :: HscEnv -> DynFlags -> IO DynFlags
|
||||
initializePlugins _env dflags = do
|
||||
return dflags
|
||||
|
||||
applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource
|
||||
applyPluginsParsedResultAction _env _dflags _ms _hpm_annotations parsed =
|
||||
return parsed
|
||||
#endif
|
||||
|
||||
|
@ -77,7 +77,8 @@ main = do
|
||||
, codeLensesTests
|
||||
, outlineTests
|
||||
, findDefinitionAndHoverTests
|
||||
, pluginTests
|
||||
, pluginSimpleTests
|
||||
, pluginParsedResultTests
|
||||
, preprocessorTests
|
||||
, thTests
|
||||
, safeTests
|
||||
@ -2250,29 +2251,43 @@ checkFileCompiles fp =
|
||||
void (openTestDataDoc (dir </> fp))
|
||||
expectNoMoreDiagnostics 0.5
|
||||
|
||||
pluginSimpleTests :: TestTree
|
||||
pluginSimpleTests =
|
||||
testSessionWait "simple plugin" $ do
|
||||
let content =
|
||||
T.unlines
|
||||
[ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
|
||||
, "{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}"
|
||||
, "module Testing where"
|
||||
, "import Data.Proxy"
|
||||
, "import GHC.TypeLits"
|
||||
-- This function fails without plugins being initialized.
|
||||
, "f :: forall n. KnownNat n => Proxy n -> Integer"
|
||||
, "f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))"
|
||||
, "foo :: Int -> Int -> Int"
|
||||
, "foo a b = a + c"
|
||||
]
|
||||
_ <- createDoc "Testing.hs" "haskell" content
|
||||
expectDiagnostics
|
||||
[ ( "Testing.hs",
|
||||
[(DsError, (8, 14), "Variable not in scope: c")]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
pluginTests :: TestTree
|
||||
pluginTests = testSessionWait "plugins" $ do
|
||||
let content =
|
||||
T.unlines
|
||||
[ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
|
||||
, "{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-}"
|
||||
, "module Testing where"
|
||||
, "import Data.Proxy"
|
||||
, "import GHC.TypeLits"
|
||||
-- This function fails without plugins being initialized.
|
||||
, "f :: forall n. KnownNat n => Proxy n -> Integer"
|
||||
, "f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2))"
|
||||
, "foo :: Int -> Int -> Int"
|
||||
, "foo a b = a + c"
|
||||
]
|
||||
_ <- createDoc "Testing.hs" "haskell" content
|
||||
expectDiagnostics
|
||||
[ ( "Testing.hs",
|
||||
[(DsError, (8, 14), "Variable not in scope: c")]
|
||||
)
|
||||
]
|
||||
pluginParsedResultTests :: TestTree
|
||||
pluginParsedResultTests =
|
||||
(`xfail84` "record-dot-preprocessor unsupported on 8.4") $ testSessionWait "parsedResultAction plugin" $ do
|
||||
let content =
|
||||
T.unlines
|
||||
[ "{-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}"
|
||||
, "{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}"
|
||||
, "module Testing (Company(..), display) where"
|
||||
, "data Company = Company {name :: String}"
|
||||
, "display :: Company -> String"
|
||||
, "display c = c.name"
|
||||
]
|
||||
_ <- createDoc "Testing.hs" "haskell" content
|
||||
expectNoMoreDiagnostics 1
|
||||
|
||||
cppTests :: TestTree
|
||||
cppTests =
|
||||
@ -2734,6 +2749,13 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')
|
||||
xfail :: TestTree -> String -> TestTree
|
||||
xfail = flip expectFailBecause
|
||||
|
||||
xfail84 :: TestTree -> String -> TestTree
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
xfail84 t _ = t
|
||||
#else
|
||||
xfail84 = flip expectFailBecause
|
||||
#endif
|
||||
|
||||
expectFailCabal :: String -> TestTree -> TestTree
|
||||
#ifdef STACK
|
||||
expectFailCabal _ = id
|
||||
|
Loading…
Reference in New Issue
Block a user