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

ghcide.cabal

@@ -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

src/Development/IDE/Core/Compile.hs

@@ -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

src/Development/IDE/Core/Preprocessor.hs

@@ -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

src/Development/IDE/Core/Rules.hs

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

src/Development/IDE/GHC/Compat.hs

@@ -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
+

test/exe/Main.hs

@@ -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