#279, support preprocessors (#282)

* Support preprocessors

* Add a preprocessor for testing

* Add a preprocessor test
This commit is contained in:
Neil Mitchell 2019-12-19 11:06:03 +00:00 committed by Andreas Herrmann
parent b1435e2aee
commit 70cb92cc01
4 changed files with 63 additions and 4 deletions

View File

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

View File

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

View File

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

10
test/preprocessor/Main.hs Normal file
View File

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