mirror of
https://github.com/haskell/ghcide.git
synced 2025-01-07 10:39:40 +03:00
Pull the preprocessor functions into a separate module
This commit is contained in:
Neil Mitchell
parent
f66c886217
commit
18ee98f069
@ -99,6 +99,7 @@ library
|
||||
other-modules:
|
||||
Development.IDE.Core.Debouncer
|
||||
Development.IDE.Core.Compile
|
||||
Development.IDE.Core.Preprocessor
|
||||
Development.IDE.GHC.Compat
|
||||
Development.IDE.GHC.CPP
|
||||
Development.IDE.GHC.Error
|
||||
|
||||
@ -16,13 +16,12 @@ module Development.IDE.Core.Compile
|
||||
) where
|
||||
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Development.IDE.GHC.CPP
|
||||
import Development.IDE.Core.Preprocessor
|
||||
import Development.IDE.GHC.Error
|
||||
import Development.IDE.GHC.Warnings
|
||||
import Development.IDE.Types.Diagnostics
|
||||
import Development.IDE.GHC.Orphans()
|
||||
import Development.IDE.GHC.Util
|
||||
import Development.IDE.GHC.Compat
|
||||
import qualified GHC.LanguageExtensions.Type as GHC
|
||||
import Development.IDE.Types.Options
|
||||
import Development.IDE.Types.Location
|
||||
@ -54,10 +53,6 @@ import Data.Maybe
|
||||
import Data.Tuple.Extra
|
||||
import qualified Data.Map.Strict as Map
|
||||
import System.FilePath
|
||||
import System.IO.Extra
|
||||
import Data.Char
|
||||
|
||||
import SysTools (Option (..), runUnlit)
|
||||
|
||||
|
||||
-- | Given a string buffer, return a pre-processed @ParsedModule@.
|
||||
@ -270,70 +265,6 @@ getModSummaryFromBuffer fp contents dflags parsed = do
|
||||
then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
|
||||
else (HsSrcFile , \newExt -> stem <.> newExt)
|
||||
|
||||
-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
|
||||
runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
|
||||
runLhs dflags filename contents = withTempDir $ \dir -> do
|
||||
let fout = dir </> takeFileName filename <.> "unlit"
|
||||
filesrc <- case contents of
|
||||
Nothing -> return filename
|
||||
Just cnts -> do
|
||||
let fsrc = dir </> takeFileName filename <.> "literate"
|
||||
withBinaryFile fsrc WriteMode $ \h ->
|
||||
hPutStringBuffer h cnts
|
||||
return fsrc
|
||||
unlit filesrc fout
|
||||
SB.hGetStringBuffer fout
|
||||
where
|
||||
unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)
|
||||
args filein fileout = [
|
||||
SysTools.Option "-h"
|
||||
, SysTools.Option (escape filename) -- name this file
|
||||
, SysTools.FileOption "" filein -- input file
|
||||
, SysTools.FileOption "" fileout ] -- output file
|
||||
-- taken from ghc's DriverPipeline.hs
|
||||
escape ('\\':cs) = '\\':'\\': escape cs
|
||||
escape ('\"':cs) = '\\':'\"': escape cs
|
||||
escape ('\'':cs) = '\\':'\'': escape cs
|
||||
escape (c:cs) = c : escape cs
|
||||
escape [] = []
|
||||
|
||||
-- | Run CPP on a file
|
||||
runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
|
||||
runCpp dflags filename contents = withTempDir $ \dir -> do
|
||||
let out = dir </> takeFileName filename <.> "out"
|
||||
case contents of
|
||||
Nothing -> do
|
||||
-- Happy case, file is not modified, so run CPP on it in-place
|
||||
-- which also makes things like relative #include files work
|
||||
-- and means location information is correct
|
||||
doCpp dflags True filename out
|
||||
liftIO $ SB.hGetStringBuffer out
|
||||
|
||||
Just contents -> do
|
||||
-- Sad path, we have to create a version of the path in a temp dir
|
||||
-- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)
|
||||
|
||||
-- Relative includes aren't going to work, so we fix that by adding to the include path.
|
||||
dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags
|
||||
|
||||
-- Location information is wrong, so we fix that by patching it afterwards.
|
||||
let inp = dir </> "___GHCIDE_MAGIC___"
|
||||
withBinaryFile inp WriteMode $ \h ->
|
||||
hPutStringBuffer h contents
|
||||
doCpp dflags True inp out
|
||||
|
||||
-- Fix up the filename in lines like:
|
||||
-- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"
|
||||
let tweak x
|
||||
| Just x <- stripPrefix "# " x
|
||||
, "___GHCIDE_MAGIC___" `isInfixOf` x
|
||||
, let num = takeWhile (not . isSpace) x
|
||||
-- important to use /, and never \ for paths, even on Windows, since then C escapes them
|
||||
-- and GHC gets all confused
|
||||
= "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
|
||||
| otherwise = x
|
||||
stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
|
||||
|
||||
-- | Given a buffer, flags, file path and module summary, produce a
|
||||
-- parsed module (or errors) and any parse warnings.
|
||||
parseFileContents
|
||||
|
||||
90
src/Development/IDE/Core/Preprocessor.hs
Normal file
90
src/Development/IDE/Core/Preprocessor.hs
Normal file
@ -0,0 +1,90 @@
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
-- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API.
|
||||
-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.
|
||||
module Development.IDE.Core.Preprocessor
|
||||
( runLhs
|
||||
, runCpp
|
||||
) where
|
||||
|
||||
import Development.IDE.GHC.CPP
|
||||
import Development.IDE.GHC.Orphans()
|
||||
import Development.IDE.GHC.Compat
|
||||
import GHC
|
||||
import GhcMonad
|
||||
import StringBuffer as SB
|
||||
|
||||
import Data.List.Extra
|
||||
import System.FilePath
|
||||
import System.IO.Extra
|
||||
import Data.Char
|
||||
|
||||
import SysTools (Option (..), runUnlit)
|
||||
|
||||
-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
|
||||
runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
|
||||
runLhs dflags filename contents = withTempDir $ \dir -> do
|
||||
let fout = dir </> takeFileName filename <.> "unlit"
|
||||
filesrc <- case contents of
|
||||
Nothing -> return filename
|
||||
Just cnts -> do
|
||||
let fsrc = dir </> takeFileName filename <.> "literate"
|
||||
withBinaryFile fsrc WriteMode $ \h ->
|
||||
hPutStringBuffer h cnts
|
||||
return fsrc
|
||||
unlit filesrc fout
|
||||
SB.hGetStringBuffer fout
|
||||
where
|
||||
unlit filein fileout = SysTools.runUnlit dflags (args filein fileout)
|
||||
args filein fileout = [
|
||||
SysTools.Option "-h"
|
||||
, SysTools.Option (escape filename) -- name this file
|
||||
, SysTools.FileOption "" filein -- input file
|
||||
, SysTools.FileOption "" fileout ] -- output file
|
||||
-- taken from ghc's DriverPipeline.hs
|
||||
escape ('\\':cs) = '\\':'\\': escape cs
|
||||
escape ('\"':cs) = '\\':'\"': escape cs
|
||||
escape ('\'':cs) = '\\':'\'': escape cs
|
||||
escape (c:cs) = c : escape cs
|
||||
escape [] = []
|
||||
|
||||
-- | Run CPP on a file
|
||||
runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
|
||||
runCpp dflags filename contents = withTempDir $ \dir -> do
|
||||
let out = dir </> takeFileName filename <.> "out"
|
||||
case contents of
|
||||
Nothing -> do
|
||||
-- Happy case, file is not modified, so run CPP on it in-place
|
||||
-- which also makes things like relative #include files work
|
||||
-- and means location information is correct
|
||||
doCpp dflags True filename out
|
||||
liftIO $ SB.hGetStringBuffer out
|
||||
|
||||
Just contents -> do
|
||||
-- Sad path, we have to create a version of the path in a temp dir
|
||||
-- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)
|
||||
|
||||
-- Relative includes aren't going to work, so we fix that by adding to the include path.
|
||||
dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags
|
||||
|
||||
-- Location information is wrong, so we fix that by patching it afterwards.
|
||||
let inp = dir </> "___GHCIDE_MAGIC___"
|
||||
withBinaryFile inp WriteMode $ \h ->
|
||||
hPutStringBuffer h contents
|
||||
doCpp dflags True inp out
|
||||
|
||||
-- Fix up the filename in lines like:
|
||||
-- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"
|
||||
let tweak x
|
||||
| Just x <- stripPrefix "# " x
|
||||
, "___GHCIDE_MAGIC___" `isInfixOf` x
|
||||
, let num = takeWhile (not . isSpace) x
|
||||
-- important to use /, and never \ for paths, even on Windows, since then C escapes them
|
||||
-- and GHC gets all confused
|
||||
= "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
|
||||
| otherwise = x
|
||||
stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
|
||||
Loading…
Reference in New Issue
Block a user