haskell/ghcide#279, support preprocessors (haskell/ghcide#282)

* Support preprocessors

* Add a preprocessor for testing

* Add a preprocessor test

Author: ndmitchell

ghcide/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,

ghcide/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

ghcide/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

ghcide/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