diff --git a/ghcide.cabal b/ghcide.cabal index d3f40b2332..a09fbecbcf 100644 --- a/ghcide.cabal +++ b/ghcide.cabal @@ -131,6 +131,14 @@ library Development.IDE.Spans.Type ghc-options: -Wall -Wno-name-shadowing +executable ghcide-test-preprocessor + default-language: Haskell2010 + hs-source-dirs: test/preprocessor + ghc-options: -Wall + main-is: Main.hs + build-depends: + base == 4.* + executable ghcide if flag(ghc-lib) buildable: False @@ -169,7 +177,8 @@ test-suite ghcide-tests type: exitcode-stdio-1.0 default-language: Haskell2010 build-tool-depends: - ghcide:ghcide + ghcide:ghcide, + ghcide:ghcide-test-preprocessor build-depends: base, bytestring, diff --git a/src/Development/IDE/Core/Preprocessor.hs b/src/Development/IDE/Core/Preprocessor.hs index c1de038f01..511af17ce9 100644 --- a/src/Development/IDE/Core/Preprocessor.hs +++ b/src/Development/IDE/Core/Preprocessor.hs @@ -20,7 +20,7 @@ import DynFlags import qualified HeaderInfo as Hdr import Development.IDE.Types.Diagnostics import Development.IDE.GHC.Error -import SysTools (Option (..), runUnlit) +import SysTools (Option (..), runUnlit, runPp) import Control.Monad.Trans.Except import qualified GHC.LanguageExtensions as LangExt import Data.Maybe @@ -43,10 +43,19 @@ preprocessor filename mbContents = do -- Perform cpp dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents - if not $ xopt LangExt.Cpp dflags then + (isOnDisk, contents, dflags) <- + if not $ xopt LangExt.Cpp dflags then + return (isOnDisk, contents, dflags) + else do + contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents + dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents + return (False, contents, dflags) + + -- Perform preprocessor + if not $ gopt Opt_Pp dflags then return (contents, dflags) else do - contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents + contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents return (contents, dflags) @@ -132,3 +141,18 @@ runCpp dflags filename contents = withTempDir $ \dir -> do = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\"" | otherwise = x stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out + + +-- | Run a preprocessor on a file +runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer +runPreprocessor dflags filename contents = withTempDir $ \dir -> do + let out = dir takeFileName filename <.> "out" + inp <- case contents of + Nothing -> return filename + Just contents -> do + let inp = dir takeFileName filename <.> "hs" + withBinaryFile inp WriteMode $ \h -> + hPutStringBuffer h contents + return inp + runPp dflags [SysTools.Option filename, SysTools.Option inp, SysTools.FileOption "" out] + SB.hGetStringBuffer out diff --git a/test/exe/Main.hs b/test/exe/Main.hs index 4225960cab..c916f8da49 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -42,6 +42,7 @@ main = defaultMain $ testGroup "HIE" , codeLensesTests , findDefinitionAndHoverTests , pluginTests + , preprocessorTests , thTests ] @@ -914,6 +915,21 @@ pluginTests = testSessionWait "plugins" $ do ) ] +preprocessorTests :: TestTree +preprocessorTests = testSessionWait "preprocessor" $ do + let content = + T.unlines + [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}" + , "module Testing where" + , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic + ] + _ <- openDoc' "Testing.hs" "haskell" content + expectDiagnostics + [ ( "Testing.hs", + [(DsError, (2, 8), "Variable not in scope: z")] + ) + ] + thTests :: TestTree thTests = testGroup diff --git a/test/preprocessor/Main.hs b/test/preprocessor/Main.hs new file mode 100644 index 0000000000..560f62eeb4 --- /dev/null +++ b/test/preprocessor/Main.hs @@ -0,0 +1,10 @@ + +module Main(main) where + +import System.Environment + +main :: IO () +main = do + _:input:output:_ <- getArgs + let f = map (\x -> if x == 'x' then 'y' else x) + writeFile output . f =<< readFile input