{-# LANGUAGE CPP #-}
module Development.IDE.Core.Preprocessor
( preprocessor
) where
import Development.IDE.GHC.Compat
import qualified Development.IDE.GHC.Compat.Util as Util
import Development.IDE.GHC.CPP
import Development.IDE.GHC.Orphans ()
import qualified Development.IDE.GHC.Util as Util
import Control.DeepSeq (NFData (rnf))
import Control.Exception (evaluate)
import Control.Exception.Safe (catch, throw)
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Char
import Data.IORef (IORef, modifyIORef,
newIORef, readIORef)
import Data.List.Extra
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Development.IDE.GHC.Error
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import qualified GHC.LanguageExtensions as LangExt
import System.FilePath
import System.IO.Extra
#if MIN_VERSION_ghc(9,3,0)
import GHC.Utils.Logger (LogFlags (..))
#endif
preprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO (Util.StringBuffer, [String], HscEnv, Util.Fingerprint)
preprocessor :: HscEnv
-> String
-> Maybe StringBuffer
-> ExceptT
[FileDiagnostic] IO (StringBuffer, [String], HscEnv, Fingerprint)
preprocessor HscEnv
env String
filename Maybe StringBuffer
mbContents = do
(Bool
isOnDisk, StringBuffer
contents) <-
if String -> Bool
isLiterate String
filename then do
StringBuffer
newcontent <- IO StringBuffer -> ExceptT [FileDiagnostic] IO StringBuffer
forall a. IO a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StringBuffer -> ExceptT [FileDiagnostic] IO StringBuffer)
-> IO StringBuffer -> ExceptT [FileDiagnostic] IO StringBuffer
forall a b. (a -> b) -> a -> b
$ HscEnv -> String -> Maybe StringBuffer -> IO StringBuffer
runLhs HscEnv
env String
filename Maybe StringBuffer
mbContents
(Bool, StringBuffer)
-> ExceptT [FileDiagnostic] IO (Bool, StringBuffer)
forall a. a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, StringBuffer
newcontent)
else do
StringBuffer
contents <- IO StringBuffer -> ExceptT [FileDiagnostic] IO StringBuffer
forall a. IO a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StringBuffer -> ExceptT [FileDiagnostic] IO StringBuffer)
-> IO StringBuffer -> ExceptT [FileDiagnostic] IO StringBuffer
forall a b. (a -> b) -> a -> b
$ IO StringBuffer
-> (StringBuffer -> IO StringBuffer)
-> Maybe StringBuffer
-> IO StringBuffer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO StringBuffer
Util.hGetStringBuffer String
filename) StringBuffer -> IO StringBuffer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe StringBuffer
mbContents
let isOnDisk :: Bool
isOnDisk = Maybe StringBuffer -> Bool
forall a. Maybe a -> Bool
isNothing Maybe StringBuffer
mbContents
(Bool, StringBuffer)
-> ExceptT [FileDiagnostic] IO (Bool, StringBuffer)
forall a. a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isOnDisk, StringBuffer
contents)
!Fingerprint
src_hash <- IO Fingerprint -> ExceptT [FileDiagnostic] IO Fingerprint
forall a. IO a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fingerprint -> ExceptT [FileDiagnostic] IO Fingerprint)
-> IO Fingerprint -> ExceptT [FileDiagnostic] IO Fingerprint
forall a b. (a -> b) -> a -> b
$ StringBuffer -> IO Fingerprint
Util.fingerprintFromStringBuffer StringBuffer
contents
([String]
opts, HscEnv
pEnv) <- IO (Either [FileDiagnostic] ([String], HscEnv))
-> ExceptT [FileDiagnostic] IO ([String], HscEnv)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either [FileDiagnostic] ([String], HscEnv))
-> ExceptT [FileDiagnostic] IO ([String], HscEnv))
-> IO (Either [FileDiagnostic] ([String], HscEnv))
-> ExceptT [FileDiagnostic] IO ([String], HscEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> String
-> StringBuffer
-> IO (Either [FileDiagnostic] ([String], HscEnv))
parsePragmasIntoHscEnv HscEnv
env String
filename StringBuffer
contents
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
pEnv
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
pEnv
(Bool
newIsOnDisk, StringBuffer
newContents, [String]
newOpts, HscEnv
newEnv) <-
if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Extension -> DynFlags -> Bool
xopt Extension
LangExt.Cpp DynFlags
dflags then
(Bool, StringBuffer, [String], HscEnv)
-> ExceptT
[FileDiagnostic] IO (Bool, StringBuffer, [String], HscEnv)
forall a. a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isOnDisk, StringBuffer
contents, [String]
opts, HscEnv
pEnv)
else do
IORef [CPPLog]
cppLogs <- IO (IORef [CPPLog]) -> ExceptT [FileDiagnostic] IO (IORef [CPPLog])
forall a. IO a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [CPPLog])
-> ExceptT [FileDiagnostic] IO (IORef [CPPLog]))
-> IO (IORef [CPPLog])
-> ExceptT [FileDiagnostic] IO (IORef [CPPLog])
forall a b. (a -> b) -> a -> b
$ [CPPLog] -> IO (IORef [CPPLog])
forall a. a -> IO (IORef a)
newIORef []
let newLogger :: Logger
newLogger = (LogAction -> LogAction) -> Logger -> Logger
pushLogHook (LogAction -> LogAction -> LogAction
forall a b. a -> b -> a
const (LogActionCompat -> LogAction
logActionCompat (LogActionCompat -> LogAction) -> LogActionCompat -> LogAction
forall a b. (a -> b) -> a -> b
$ IORef [CPPLog] -> LogActionCompat
logAction IORef [CPPLog]
cppLogs)) Logger
logger
StringBuffer
con <- IO (Either [FileDiagnostic] StringBuffer)
-> ExceptT [FileDiagnostic] IO StringBuffer
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
(IO (Either [FileDiagnostic] StringBuffer)
-> ExceptT [FileDiagnostic] IO StringBuffer)
-> IO (Either [FileDiagnostic] StringBuffer)
-> ExceptT [FileDiagnostic] IO StringBuffer
forall a b. (a -> b) -> a -> b
$ (StringBuffer -> Either [FileDiagnostic] StringBuffer
forall a b. b -> Either a b
Right (StringBuffer -> Either [FileDiagnostic] StringBuffer)
-> IO StringBuffer -> IO (Either [FileDiagnostic] StringBuffer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HscEnv -> String -> Maybe StringBuffer -> IO StringBuffer
runCpp (Logger -> HscEnv -> HscEnv
putLogHook Logger
newLogger HscEnv
pEnv) String
filename
(Maybe StringBuffer -> IO StringBuffer)
-> Maybe StringBuffer -> IO StringBuffer
forall a b. (a -> b) -> a -> b
$ if Bool
isOnDisk then Maybe StringBuffer
forall a. Maybe a
Nothing else StringBuffer -> Maybe StringBuffer
forall a. a -> Maybe a
Just StringBuffer
contents))
IO (Either [FileDiagnostic] StringBuffer)
-> (GhcException -> IO (Either [FileDiagnostic] StringBuffer))
-> IO (Either [FileDiagnostic] StringBuffer)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch`
( \(GhcException
e :: Util.GhcException) -> do
[CPPLog]
logs <- IORef [CPPLog] -> IO [CPPLog]
forall a. IORef a -> IO a
readIORef IORef [CPPLog]
cppLogs
case String -> [CPPLog] -> [FileDiagnostic]
diagsFromCPPLogs String
filename ([CPPLog] -> [CPPLog]
forall a. [a] -> [a]
reverse [CPPLog]
logs) of
[] -> GhcException -> IO (Either [FileDiagnostic] StringBuffer)
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Exception e) =>
e -> m a
throw GhcException
e
[FileDiagnostic]
diags -> Either [FileDiagnostic] StringBuffer
-> IO (Either [FileDiagnostic] StringBuffer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [FileDiagnostic] StringBuffer
-> IO (Either [FileDiagnostic] StringBuffer))
-> Either [FileDiagnostic] StringBuffer
-> IO (Either [FileDiagnostic] StringBuffer)
forall a b. (a -> b) -> a -> b
$ [FileDiagnostic] -> Either [FileDiagnostic] StringBuffer
forall a b. a -> Either a b
Left [FileDiagnostic]
diags
)
([String]
options, HscEnv
hscEnv) <- IO (Either [FileDiagnostic] ([String], HscEnv))
-> ExceptT [FileDiagnostic] IO ([String], HscEnv)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either [FileDiagnostic] ([String], HscEnv))
-> ExceptT [FileDiagnostic] IO ([String], HscEnv))
-> IO (Either [FileDiagnostic] ([String], HscEnv))
-> ExceptT [FileDiagnostic] IO ([String], HscEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> String
-> StringBuffer
-> IO (Either [FileDiagnostic] ([String], HscEnv))
parsePragmasIntoHscEnv HscEnv
pEnv String
filename StringBuffer
con
(Bool, StringBuffer, [String], HscEnv)
-> ExceptT
[FileDiagnostic] IO (Bool, StringBuffer, [String], HscEnv)
forall a. a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, StringBuffer
con, [String]
options, HscEnv
hscEnv)
if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Pp DynFlags
dflags then
(StringBuffer, [String], HscEnv, Fingerprint)
-> ExceptT
[FileDiagnostic] IO (StringBuffer, [String], HscEnv, Fingerprint)
forall a. a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StringBuffer
newContents, [String]
newOpts, HscEnv
newEnv, Fingerprint
src_hash)
else do
StringBuffer
con <- IO StringBuffer -> ExceptT [FileDiagnostic] IO StringBuffer
forall a. IO a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StringBuffer -> ExceptT [FileDiagnostic] IO StringBuffer)
-> IO StringBuffer -> ExceptT [FileDiagnostic] IO StringBuffer
forall a b. (a -> b) -> a -> b
$ HscEnv -> String -> Maybe StringBuffer -> IO StringBuffer
runPreprocessor HscEnv
newEnv String
filename (Maybe StringBuffer -> IO StringBuffer)
-> Maybe StringBuffer -> IO StringBuffer
forall a b. (a -> b) -> a -> b
$ if Bool
newIsOnDisk then Maybe StringBuffer
forall a. Maybe a
Nothing else StringBuffer -> Maybe StringBuffer
forall a. a -> Maybe a
Just StringBuffer
newContents
([String]
options, HscEnv
hscEnv) <- IO (Either [FileDiagnostic] ([String], HscEnv))
-> ExceptT [FileDiagnostic] IO ([String], HscEnv)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either [FileDiagnostic] ([String], HscEnv))
-> ExceptT [FileDiagnostic] IO ([String], HscEnv))
-> IO (Either [FileDiagnostic] ([String], HscEnv))
-> ExceptT [FileDiagnostic] IO ([String], HscEnv)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> String
-> StringBuffer
-> IO (Either [FileDiagnostic] ([String], HscEnv))
parsePragmasIntoHscEnv HscEnv
newEnv String
filename StringBuffer
con
(StringBuffer, [String], HscEnv, Fingerprint)
-> ExceptT
[FileDiagnostic] IO (StringBuffer, [String], HscEnv, Fingerprint)
forall a. a -> ExceptT [FileDiagnostic] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (StringBuffer
con, [String]
options, HscEnv
hscEnv, Fingerprint
src_hash)
where
logAction :: IORef [CPPLog] -> LogActionCompat
logAction :: IORef [CPPLog] -> LogActionCompat
logAction IORef [CPPLog]
cppLogs LogFlags
dflags Maybe DiagnosticReason
_reason Maybe Severity
severity SrcSpan
srcSpan PrintUnqualified
_style SDoc
msg = do
#if MIN_VERSION_ghc(9,3,0)
let cppLog :: CPPLog
cppLog = Severity -> SrcSpan -> Text -> CPPLog
CPPLog (Severity -> Maybe Severity -> Severity
forall a. a -> Maybe a -> a
fromMaybe Severity
SevWarning Maybe Severity
severity) SrcSpan
srcSpan (Text -> CPPLog) -> Text -> CPPLog
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext (LogFlags -> SDocContext
log_default_user_context LogFlags
dflags) SDoc
msg
#else
let cppLog = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg
#endif
IORef [CPPLog] -> ([CPPLog] -> [CPPLog]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [CPPLog]
cppLogs (CPPLog
cppLog :)
data CPPLog = CPPLog Severity SrcSpan Text
deriving (Int -> CPPLog -> ShowS
[CPPLog] -> ShowS
CPPLog -> String
(Int -> CPPLog -> ShowS)
-> (CPPLog -> String) -> ([CPPLog] -> ShowS) -> Show CPPLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CPPLog -> ShowS
showsPrec :: Int -> CPPLog -> ShowS
$cshow :: CPPLog -> String
show :: CPPLog -> String
$cshowList :: [CPPLog] -> ShowS
showList :: [CPPLog] -> ShowS
Show)
data CPPDiag
= CPPDiag
{ CPPDiag -> Range
cdRange :: Range,
CPPDiag -> Maybe DiagnosticSeverity
cdSeverity :: Maybe DiagnosticSeverity,
CPPDiag -> [Text]
cdMessage :: [Text]
}
deriving (Int -> CPPDiag -> ShowS
[CPPDiag] -> ShowS
CPPDiag -> String
(Int -> CPPDiag -> ShowS)
-> (CPPDiag -> String) -> ([CPPDiag] -> ShowS) -> Show CPPDiag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CPPDiag -> ShowS
showsPrec :: Int -> CPPDiag -> ShowS
$cshow :: CPPDiag -> String
show :: CPPDiag -> String
$cshowList :: [CPPDiag] -> ShowS
showList :: [CPPDiag] -> ShowS
Show)
diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]
diagsFromCPPLogs :: String -> [CPPLog] -> [FileDiagnostic]
diagsFromCPPLogs String
filename [CPPLog]
logs =
(CPPDiag -> FileDiagnostic) -> [CPPDiag] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (\CPPDiag
d -> (String -> NormalizedFilePath
toNormalizedFilePath' String
filename, ShowDiagnostic
ShowDiag, CPPDiag -> Diagnostic
cppDiagToDiagnostic CPPDiag
d)) ([CPPDiag] -> [FileDiagnostic]) -> [CPPDiag] -> [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$
[CPPDiag] -> [CPPLog] -> [CPPDiag]
go [] [CPPLog]
logs
where
go :: [CPPDiag] -> [CPPLog] -> [CPPDiag]
go :: [CPPDiag] -> [CPPLog] -> [CPPDiag]
go [CPPDiag]
acc [] = [CPPDiag] -> [CPPDiag]
forall a. [a] -> [a]
reverse ([CPPDiag] -> [CPPDiag]) -> [CPPDiag] -> [CPPDiag]
forall a b. (a -> b) -> a -> b
$ (CPPDiag -> CPPDiag) -> [CPPDiag] -> [CPPDiag]
forall a b. (a -> b) -> [a] -> [b]
map (\CPPDiag
d -> CPPDiag
d {cdMessage = reverse $ cdMessage d}) [CPPDiag]
acc
go [CPPDiag]
acc (CPPLog Severity
sev (RealSrcSpan RealSrcSpan
rSpan Maybe BufSpan
_) Text
msg : [CPPLog]
gLogs) =
let diag :: CPPDiag
diag = Range -> Maybe DiagnosticSeverity -> [Text] -> CPPDiag
CPPDiag (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
rSpan) (Severity -> Maybe DiagnosticSeverity
toDSeverity Severity
sev) [Text
msg]
in [CPPDiag] -> [CPPLog] -> [CPPDiag]
go (CPPDiag
diag CPPDiag -> [CPPDiag] -> [CPPDiag]
forall a. a -> [a] -> [a]
: [CPPDiag]
acc) [CPPLog]
gLogs
go (CPPDiag
diag : [CPPDiag]
diags) (CPPLog Severity
_sev (UnhelpfulSpan UnhelpfulSpanReason
_) Text
msg : [CPPLog]
gLogs) =
[CPPDiag] -> [CPPLog] -> [CPPDiag]
go (CPPDiag
diag {cdMessage = msg : cdMessage diag} CPPDiag -> [CPPDiag] -> [CPPDiag]
forall a. a -> [a] -> [a]
: [CPPDiag]
diags) [CPPLog]
gLogs
go [] (CPPLog Severity
_sev (UnhelpfulSpan UnhelpfulSpanReason
_) Text
_msg : [CPPLog]
gLogs) = [CPPDiag] -> [CPPLog] -> [CPPDiag]
go [] [CPPLog]
gLogs
cppDiagToDiagnostic :: CPPDiag -> Diagnostic
cppDiagToDiagnostic :: CPPDiag -> Diagnostic
cppDiagToDiagnostic CPPDiag
d =
Diagnostic
{ $sel:_range:Diagnostic :: Range
_range = CPPDiag -> Range
cdRange CPPDiag
d,
$sel:_severity:Diagnostic :: Maybe DiagnosticSeverity
_severity = CPPDiag -> Maybe DiagnosticSeverity
cdSeverity CPPDiag
d,
$sel:_code:Diagnostic :: Maybe (Int32 |? Text)
_code = Maybe (Int32 |? Text)
forall a. Maybe a
Nothing,
$sel:_source:Diagnostic :: Maybe Text
_source = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"CPP",
$sel:_message:Diagnostic :: Text
_message = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ CPPDiag -> [Text]
cdMessage CPPDiag
d,
$sel:_relatedInformation:Diagnostic :: Maybe [DiagnosticRelatedInformation]
_relatedInformation = Maybe [DiagnosticRelatedInformation]
forall a. Maybe a
Nothing,
$sel:_tags:Diagnostic :: Maybe [DiagnosticTag]
_tags = Maybe [DiagnosticTag]
forall a. Maybe a
Nothing,
$sel:_codeDescription:Diagnostic :: Maybe CodeDescription
_codeDescription = Maybe CodeDescription
forall a. Maybe a
Nothing,
$sel:_data_:Diagnostic :: Maybe Value
_data_ = Maybe Value
forall a. Maybe a
Nothing
}
isLiterate :: FilePath -> Bool
isLiterate :: String -> Bool
isLiterate String
x = ShowS
takeExtension String
x String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".lhs",String
".lhs-boot"]
parsePragmasIntoHscEnv
:: HscEnv
-> FilePath
-> Util.StringBuffer
-> IO (Either [FileDiagnostic] ([String], HscEnv))
parsePragmasIntoHscEnv :: HscEnv
-> String
-> StringBuffer
-> IO (Either [FileDiagnostic] ([String], HscEnv))
parsePragmasIntoHscEnv HscEnv
env String
fp StringBuffer
contents = DynFlags
-> Text
-> IO ([String], HscEnv)
-> IO (Either [FileDiagnostic] ([String], HscEnv))
forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors DynFlags
dflags0 Text
"pragmas" (IO ([String], HscEnv)
-> IO (Either [FileDiagnostic] ([String], HscEnv)))
-> IO ([String], HscEnv)
-> IO (Either [FileDiagnostic] ([String], HscEnv))
forall a b. (a -> b) -> a -> b
$ do
#if MIN_VERSION_ghc(9,3,0)
let (Messages PsMessage
_warns,[Located String]
opts) = ParserOpts
-> StringBuffer -> String -> (Messages PsMessage, [Located String])
getOptions (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags0) StringBuffer
contents String
fp
#else
let opts = getOptions dflags0 contents fp
#endif
() -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Located String] -> ()
forall a. NFData a => a -> ()
rnf [Located String]
opts
(DynFlags
dflags, [Located String]
_, [Warn]
_) <- DynFlags
-> [Located String] -> IO (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
dflags0 [Located String]
opts
HscEnv
hsc_env' <- HscEnv -> IO HscEnv
initializePlugins (DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags HscEnv
env)
([String], HscEnv) -> IO ([String], HscEnv)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Located String -> String) -> [Located String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> String
forall l e. GenLocated l e -> e
unLoc [Located String]
opts, DynFlags -> HscEnv -> HscEnv
hscSetFlags (DynFlags -> DynFlags
disableWarningsAsErrors (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env') HscEnv
hsc_env')
where dflags0 :: DynFlags
dflags0 = HscEnv -> DynFlags
hsc_dflags HscEnv
env
runLhs :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer
runLhs :: HscEnv -> String -> Maybe StringBuffer -> IO StringBuffer
runLhs HscEnv
env String
filename Maybe StringBuffer
contents = (String -> IO StringBuffer) -> IO StringBuffer
forall a. (String -> IO a) -> IO a
withTempDir ((String -> IO StringBuffer) -> IO StringBuffer)
-> (String -> IO StringBuffer) -> IO StringBuffer
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
let fout :: String
fout = String
dir String -> ShowS
</> ShowS
takeFileName String
filename String -> ShowS
<.> String
"unlit"
String
filesrc <- case Maybe StringBuffer
contents of
Maybe StringBuffer
Nothing -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
filename
Just StringBuffer
cnts -> do
let fsrc :: String
fsrc = String
dir String -> ShowS
</> ShowS
takeFileName String
filename String -> ShowS
<.> String
"literate"
String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
fsrc IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
Handle -> StringBuffer -> IO ()
hPutStringBuffer Handle
h StringBuffer
cnts
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
fsrc
String -> String -> IO ()
unlit String
filesrc String
fout
String -> IO StringBuffer
Util.hGetStringBuffer String
fout
where
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
env
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
env
unlit :: String -> String -> IO ()
unlit String
filein String
fileout = Logger -> DynFlags -> [Option] -> IO ()
runUnlit Logger
logger DynFlags
dflags (String -> String -> [Option]
args String
filein String
fileout)
args :: String -> String -> [Option]
args String
filein String
fileout = [
String -> Option
Option String
"-h"
, String -> Option
Option (ShowS
escape String
filename)
, String -> String -> Option
FileOption String
"" String
filein
, String -> String -> Option
FileOption String
"" String
fileout ]
escape :: ShowS
escape (Char
'\\':String
cs) = Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape String
cs
escape (Char
'\"':String
cs) = Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'\"'Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape String
cs
escape (Char
'\'':String
cs) = Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'\''Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape String
cs
escape (Char
c:String
cs) = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape String
cs
escape [] = []
runCpp :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer
runCpp :: HscEnv -> String -> Maybe StringBuffer -> IO StringBuffer
runCpp HscEnv
env0 String
filename Maybe StringBuffer
mbContents = (String -> IO StringBuffer) -> IO StringBuffer
forall a. (String -> IO a) -> IO a
withTempDir ((String -> IO StringBuffer) -> IO StringBuffer)
-> (String -> IO StringBuffer) -> IO StringBuffer
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
let out :: String
out = String
dir String -> ShowS
</> ShowS
takeFileName String
filename String -> ShowS
<.> String
"out"
let dflags1 :: DynFlags
dflags1 = String -> DynFlags -> DynFlags
addOptP String
"-D__GHCIDE__" (HscEnv -> DynFlags
hsc_dflags HscEnv
env0)
let env1 :: HscEnv
env1 = DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags1 HscEnv
env0
case Maybe StringBuffer
mbContents of
Maybe StringBuffer
Nothing -> do
HscEnv -> String -> String -> IO ()
doCpp HscEnv
env1 String
filename String
out
IO StringBuffer -> IO StringBuffer
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StringBuffer -> IO StringBuffer)
-> IO StringBuffer -> IO StringBuffer
forall a b. (a -> b) -> a -> b
$ String -> IO StringBuffer
Util.hGetStringBuffer String
out
Just StringBuffer
contents -> do
let dflags2 :: DynFlags
dflags2 = String -> DynFlags -> DynFlags
addIncludePathsQuote (ShowS
takeDirectory String
filename) DynFlags
dflags1
let env2 :: HscEnv
env2 = DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags2 HscEnv
env0
let inp :: String
inp = String
dir String -> ShowS
</> String
"___GHCIDE_MAGIC___"
String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
inp IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
Handle -> StringBuffer -> IO ()
hPutStringBuffer Handle
h StringBuffer
contents
HscEnv -> String -> String -> IO ()
doCpp HscEnv
env2 String
inp String
out
let tweak :: ShowS
tweak String
x
| Just String
y <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"# " String
x
, String
"___GHCIDE_MAGIC___" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
y
, let num :: String
num = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) String
y
= String
"# " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
num String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
z -> if Char -> Bool
isPathSeparator Char
z then Char
'/' else Char
z) String
filename String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\""
| Bool
otherwise = String
x
String -> StringBuffer
Util.stringToStringBuffer (String -> StringBuffer) -> ShowS -> String -> StringBuffer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
tweak ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> StringBuffer) -> IO String -> IO StringBuffer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFileUTF8' String
out
runPreprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer
runPreprocessor :: HscEnv -> String -> Maybe StringBuffer -> IO StringBuffer
runPreprocessor HscEnv
env String
filename Maybe StringBuffer
mbContents = (String -> IO StringBuffer) -> IO StringBuffer
forall a. (String -> IO a) -> IO a
withTempDir ((String -> IO StringBuffer) -> IO StringBuffer)
-> (String -> IO StringBuffer) -> IO StringBuffer
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
let out :: String
out = String
dir String -> ShowS
</> ShowS
takeFileName String
filename String -> ShowS
<.> String
"out"
String
inp <- case Maybe StringBuffer
mbContents of
Maybe StringBuffer
Nothing -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
filename
Just StringBuffer
contents -> do
let inp :: String
inp = String
dir String -> ShowS
</> ShowS
takeFileName String
filename String -> ShowS
<.> String
"hs"
String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
inp IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
Handle -> StringBuffer -> IO ()
hPutStringBuffer Handle
h StringBuffer
contents
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
inp
Logger -> DynFlags -> [Option] -> IO ()
runPp Logger
logger DynFlags
dflags [String -> Option
Option String
filename, String -> Option
Option String
inp, String -> String -> Option
FileOption String
"" String
out]
String -> IO StringBuffer
Util.hGetStringBuffer String
out
where
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
env
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
env