-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

module Development.IDE.Core.Preprocessor
  ( preprocessor
  ) where

import Development.IDE.GHC.CPP
import Development.IDE.GHC.Orphans()
import Development.IDE.GHC.Compat
import GhcMonad
import StringBuffer as SB

import Data.List.Extra
import System.FilePath
import System.IO.Extra
import Data.Char
import qualified HeaderInfo as Hdr
import Development.IDE.Types.Diagnostics
import Development.IDE.Types.Location
import Development.IDE.GHC.Error
import SysTools (Option (..), runUnlit, runPp)
import Control.Monad.Trans.Except
import qualified GHC.LanguageExtensions as LangExt
import Data.Maybe
import Control.Exception.Safe (catch, throw)
import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
import Data.Text (Text)
import qualified Data.Text as T
import Outputable (showSDoc)
import Control.DeepSeq (NFData(rnf))
import Control.Exception (evaluate)
import HscTypes (HscEnv(hsc_dflags))


-- | Given a file and some contents, apply any necessary preprocessors,
--   e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
preprocessor :: HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] IO (StringBuffer, DynFlags)
preprocessor :: HscEnv
-> FilePath
-> Maybe StringBuffer
-> ExceptT [FileDiagnostic] IO (StringBuffer, DynFlags)
preprocessor HscEnv
env FilePath
filename Maybe StringBuffer
mbContents = do
    -- Perform unlit
    (Bool
isOnDisk, StringBuffer
contents) <-
        if FilePath -> Bool
isLiterate FilePath
filename then do
            let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
env
            StringBuffer
newcontent <- IO StringBuffer -> ExceptT [FileDiagnostic] IO StringBuffer
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
$ DynFlags -> FilePath -> Maybe StringBuffer -> IO StringBuffer
runLhs DynFlags
dflags FilePath
filename Maybe StringBuffer
mbContents
            (Bool, StringBuffer)
-> ExceptT [FileDiagnostic] IO (Bool, StringBuffer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, StringBuffer
newcontent)
        else do
            StringBuffer
contents <- IO StringBuffer -> ExceptT [FileDiagnostic] IO StringBuffer
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 (FilePath -> IO StringBuffer
hGetStringBuffer FilePath
filename) StringBuffer -> IO StringBuffer
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 (m :: * -> *) a. Monad m => a -> m a
return (Bool
isOnDisk, StringBuffer
contents)

    -- Perform cpp
    DynFlags
dflags  <- IO (Either [FileDiagnostic] DynFlags)
-> ExceptT [FileDiagnostic] IO DynFlags
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either [FileDiagnostic] DynFlags)
 -> ExceptT [FileDiagnostic] IO DynFlags)
-> IO (Either [FileDiagnostic] DynFlags)
-> ExceptT [FileDiagnostic] IO DynFlags
forall a b. (a -> b) -> a -> b
$ HscEnv
-> FilePath
-> StringBuffer
-> IO (Either [FileDiagnostic] DynFlags)
parsePragmasIntoDynFlags HscEnv
env FilePath
filename StringBuffer
contents
    (Bool
isOnDisk, StringBuffer
contents, DynFlags
dflags) <-
        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, DynFlags)
-> ExceptT [FileDiagnostic] IO (Bool, StringBuffer, DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isOnDisk, StringBuffer
contents, DynFlags
dflags)
        else do
            IORef [CPPLog]
cppLogs <- IO (IORef [CPPLog]) -> ExceptT [FileDiagnostic] IO (IORef [CPPLog])
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 []
            StringBuffer
contents <- 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
<$> (DynFlags -> FilePath -> Maybe StringBuffer -> IO StringBuffer
runCpp DynFlags
dflags {log_action :: LogAction
log_action = IORef [CPPLog] -> LogAction
logAction IORef [CPPLog]
cppLogs} FilePath
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.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch`
                            ( \(GhcException
e :: GhcException) -> do
                                [CPPLog]
logs <- IORef [CPPLog] -> IO [CPPLog]
forall a. IORef a -> IO a
readIORef IORef [CPPLog]
cppLogs
                                case FilePath -> [CPPLog] -> [FileDiagnostic]
diagsFromCPPLogs FilePath
filename ([CPPLog] -> [CPPLog]
forall a. [a] -> [a]
reverse [CPPLog]
logs) of
                                  [] -> GhcException -> IO (Either [FileDiagnostic] StringBuffer)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw GhcException
e
                                  [FileDiagnostic]
diags -> Either [FileDiagnostic] StringBuffer
-> IO (Either [FileDiagnostic] StringBuffer)
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
                            )
            DynFlags
dflags <- IO (Either [FileDiagnostic] DynFlags)
-> ExceptT [FileDiagnostic] IO DynFlags
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either [FileDiagnostic] DynFlags)
 -> ExceptT [FileDiagnostic] IO DynFlags)
-> IO (Either [FileDiagnostic] DynFlags)
-> ExceptT [FileDiagnostic] IO DynFlags
forall a b. (a -> b) -> a -> b
$ HscEnv
-> FilePath
-> StringBuffer
-> IO (Either [FileDiagnostic] DynFlags)
parsePragmasIntoDynFlags HscEnv
env FilePath
filename StringBuffer
contents
            (Bool, StringBuffer, DynFlags)
-> ExceptT [FileDiagnostic] IO (Bool, StringBuffer, DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, StringBuffer
contents, DynFlags
dflags)

    -- Perform preprocessor
    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, DynFlags)
-> ExceptT [FileDiagnostic] IO (StringBuffer, DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (StringBuffer
contents, DynFlags
dflags)
    else do
        StringBuffer
contents <- IO StringBuffer -> ExceptT [FileDiagnostic] IO StringBuffer
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
$ DynFlags -> FilePath -> Maybe StringBuffer -> IO StringBuffer
runPreprocessor DynFlags
dflags FilePath
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
        DynFlags
dflags <- IO (Either [FileDiagnostic] DynFlags)
-> ExceptT [FileDiagnostic] IO DynFlags
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either [FileDiagnostic] DynFlags)
 -> ExceptT [FileDiagnostic] IO DynFlags)
-> IO (Either [FileDiagnostic] DynFlags)
-> ExceptT [FileDiagnostic] IO DynFlags
forall a b. (a -> b) -> a -> b
$ HscEnv
-> FilePath
-> StringBuffer
-> IO (Either [FileDiagnostic] DynFlags)
parsePragmasIntoDynFlags HscEnv
env FilePath
filename StringBuffer
contents
        (StringBuffer, DynFlags)
-> ExceptT [FileDiagnostic] IO (StringBuffer, DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (StringBuffer
contents, DynFlags
dflags)
  where
    logAction :: IORef [CPPLog] -> LogAction
    logAction :: IORef [CPPLog] -> LogAction
logAction IORef [CPPLog]
cppLogs DynFlags
dflags WarnReason
_reason Severity
severity SrcSpan
srcSpan PprStyle
_style MsgDoc
msg = do
      let log :: CPPLog
log = Severity -> SrcSpan -> Text -> CPPLog
CPPLog Severity
severity SrcSpan
srcSpan (Text -> CPPLog) -> Text -> CPPLog
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ DynFlags -> MsgDoc -> FilePath
showSDoc DynFlags
dflags MsgDoc
msg
      IORef [CPPLog] -> ([CPPLog] -> [CPPLog]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [CPPLog]
cppLogs (CPPLog
log CPPLog -> [CPPLog] -> [CPPLog]
forall a. a -> [a] -> [a]
:)


data CPPLog = CPPLog Severity SrcSpan Text
  deriving (Int -> CPPLog -> ShowS
[CPPLog] -> ShowS
CPPLog -> FilePath
(Int -> CPPLog -> ShowS)
-> (CPPLog -> FilePath) -> ([CPPLog] -> ShowS) -> Show CPPLog
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [CPPLog] -> ShowS
$cshowList :: [CPPLog] -> ShowS
show :: CPPLog -> FilePath
$cshow :: CPPLog -> FilePath
showsPrec :: Int -> CPPLog -> ShowS
$cshowsPrec :: Int -> 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 -> FilePath
(Int -> CPPDiag -> ShowS)
-> (CPPDiag -> FilePath) -> ([CPPDiag] -> ShowS) -> Show CPPDiag
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [CPPDiag] -> ShowS
$cshowList :: [CPPDiag] -> ShowS
show :: CPPDiag -> FilePath
$cshow :: CPPDiag -> FilePath
showsPrec :: Int -> CPPDiag -> ShowS
$cshowsPrec :: Int -> CPPDiag -> ShowS
Show)


diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]
diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]
diagsFromCPPLogs FilePath
filename [CPPLog]
logs =
  (CPPDiag -> FileDiagnostic) -> [CPPDiag] -> [FileDiagnostic]
forall a b. (a -> b) -> [a] -> [b]
map (\CPPDiag
d -> (FilePath -> NormalizedFilePath
toNormalizedFilePath' FilePath
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
    -- On errors, CPP calls logAction with a real span for the initial log and
    -- then additional informational logs with `UnhelpfulSpan`. Collect those
    -- informational log messages and attaches them to the initial log message.
    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 :: [Text]
cdMessage = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ CPPDiag -> [Text]
cdMessage CPPDiag
d}) [CPPDiag]
acc
    go [CPPDiag]
acc (CPPLog Severity
sev (RealSrcSpan RealSrcSpan
span) Text
msg : [CPPLog]
logs) =
      let diag :: CPPDiag
diag = Range -> Maybe DiagnosticSeverity -> [Text] -> CPPDiag
CPPDiag (RealSrcSpan -> Range
realSrcSpanToRange RealSrcSpan
span) (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]
logs
    go (CPPDiag
diag : [CPPDiag]
diags) (CPPLog Severity
_sev (UnhelpfulSpan FastString
_) Text
msg : [CPPLog]
logs) =
      [CPPDiag] -> [CPPLog] -> [CPPDiag]
go (CPPDiag
diag {cdMessage :: [Text]
cdMessage = Text
msg Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: CPPDiag -> [Text]
cdMessage CPPDiag
diag} CPPDiag -> [CPPDiag] -> [CPPDiag]
forall a. a -> [a] -> [a]
: [CPPDiag]
diags) [CPPLog]
logs
    go [] (CPPLog Severity
_sev (UnhelpfulSpan FastString
_) Text
_msg : [CPPLog]
logs) = [CPPDiag] -> [CPPLog] -> [CPPDiag]
go [] [CPPLog]
logs
    cppDiagToDiagnostic :: CPPDiag -> Diagnostic
    cppDiagToDiagnostic :: CPPDiag -> Diagnostic
cppDiagToDiagnostic CPPDiag
d =
      Diagnostic :: Range
-> Maybe DiagnosticSeverity
-> Maybe NumberOrString
-> Maybe Text
-> Text
-> Maybe (List DiagnosticTag)
-> Maybe (List DiagnosticRelatedInformation)
-> Diagnostic
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 NumberOrString
_code = Maybe NumberOrString
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 (List DiagnosticRelatedInformation)
_relatedInformation = Maybe (List DiagnosticRelatedInformation)
forall a. Maybe a
Nothing,
          $sel:_tags:Diagnostic :: Maybe (List DiagnosticTag)
_tags = Maybe (List DiagnosticTag)
forall a. Maybe a
Nothing
        }


isLiterate :: FilePath -> Bool
isLiterate :: FilePath -> Bool
isLiterate FilePath
x = ShowS
takeExtension FilePath
x FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
".lhs",FilePath
".lhs-boot"]


-- | This reads the pragma information directly from the provided buffer.
parsePragmasIntoDynFlags
    :: HscEnv
    -> FilePath
    -> SB.StringBuffer
    -> IO (Either [FileDiagnostic] DynFlags)
parsePragmasIntoDynFlags :: HscEnv
-> FilePath
-> StringBuffer
-> IO (Either [FileDiagnostic] DynFlags)
parsePragmasIntoDynFlags HscEnv
env FilePath
fp StringBuffer
contents = DynFlags
-> Text -> IO DynFlags -> IO (Either [FileDiagnostic] DynFlags)
forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors DynFlags
dflags0 Text
"pragmas" (IO DynFlags -> IO (Either [FileDiagnostic] DynFlags))
-> IO DynFlags -> IO (Either [FileDiagnostic] DynFlags)
forall a b. (a -> b) -> a -> b
$ do
    let opts :: [Located FilePath]
opts = DynFlags -> StringBuffer -> FilePath -> [Located FilePath]
Hdr.getOptions DynFlags
dflags0 StringBuffer
contents FilePath
fp

    -- Force bits that might keep the dflags and stringBuffer alive unnecessarily
    () -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Located FilePath] -> ()
forall a. NFData a => a -> ()
rnf [Located FilePath]
opts

    (DynFlags
dflags, [Located FilePath]
_, [Warn]
_) <- DynFlags
-> [Located FilePath] -> IO (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
parseDynamicFilePragma DynFlags
dflags0 [Located FilePath]
opts
    DynFlags
dflags' <- HscEnv -> DynFlags -> IO DynFlags
initializePlugins HscEnv
env DynFlags
dflags
    DynFlags -> IO DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> IO DynFlags) -> DynFlags -> IO DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
disableWarningsAsErrors DynFlags
dflags'
  where dflags0 :: DynFlags
dflags0 = HscEnv -> DynFlags
hsc_dflags HscEnv
env

-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
runLhs :: DynFlags -> FilePath -> Maybe StringBuffer -> IO StringBuffer
runLhs DynFlags
dflags FilePath
filename Maybe StringBuffer
contents = (FilePath -> IO StringBuffer) -> IO StringBuffer
forall a. (FilePath -> IO a) -> IO a
withTempDir ((FilePath -> IO StringBuffer) -> IO StringBuffer)
-> (FilePath -> IO StringBuffer) -> IO StringBuffer
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
    let fout :: FilePath
fout = FilePath
dir FilePath -> ShowS
</> ShowS
takeFileName FilePath
filename FilePath -> ShowS
<.> FilePath
"unlit"
    FilePath
filesrc <- case Maybe StringBuffer
contents of
        Maybe StringBuffer
Nothing   -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
filename
        Just StringBuffer
cnts -> do
            let fsrc :: FilePath
fsrc = FilePath
dir FilePath -> ShowS
</> ShowS
takeFileName FilePath
filename FilePath -> ShowS
<.> FilePath
"literate"
            FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
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
            FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
fsrc
    FilePath -> FilePath -> IO ()
unlit FilePath
filesrc FilePath
fout
    FilePath -> IO StringBuffer
SB.hGetStringBuffer FilePath
fout
  where
    unlit :: FilePath -> FilePath -> IO ()
unlit FilePath
filein FilePath
fileout = DynFlags -> [Option] -> IO ()
SysTools.runUnlit DynFlags
dflags (FilePath -> FilePath -> [Option]
args FilePath
filein FilePath
fileout)
    args :: FilePath -> FilePath -> [Option]
args FilePath
filein FilePath
fileout = [
                      FilePath -> Option
SysTools.Option     FilePath
"-h"
                    , FilePath -> Option
SysTools.Option     (ShowS
escape FilePath
filename) -- name this file
                    , FilePath -> FilePath -> Option
SysTools.FileOption FilePath
"" FilePath
filein       -- input file
                    , FilePath -> FilePath -> Option
SysTools.FileOption FilePath
"" FilePath
fileout ]    -- output file
    -- taken from ghc's DriverPipeline.hs
    escape :: ShowS
escape (Char
'\\':FilePath
cs) = Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape FilePath
cs
    escape (Char
'\"':FilePath
cs) = Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'\"'Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape FilePath
cs
    escape (Char
'\'':FilePath
cs) = Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'\''Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape FilePath
cs
    escape (Char
c:FilePath
cs)    = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape FilePath
cs
    escape []        = []

-- | Run CPP on a file
runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
runCpp :: DynFlags -> FilePath -> Maybe StringBuffer -> IO StringBuffer
runCpp DynFlags
dflags FilePath
filename Maybe StringBuffer
contents = (FilePath -> IO StringBuffer) -> IO StringBuffer
forall a. (FilePath -> IO a) -> IO a
withTempDir ((FilePath -> IO StringBuffer) -> IO StringBuffer)
-> (FilePath -> IO StringBuffer) -> IO StringBuffer
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
    let out :: FilePath
out = FilePath
dir FilePath -> ShowS
</> ShowS
takeFileName FilePath
filename FilePath -> ShowS
<.> FilePath
"out"
    DynFlags
dflags <- DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DynFlags -> IO DynFlags) -> DynFlags -> IO DynFlags
forall a b. (a -> b) -> a -> b
$ FilePath -> DynFlags -> DynFlags
addOptP FilePath
"-D__GHCIDE__" DynFlags
dflags

    case Maybe StringBuffer
contents of
        Maybe StringBuffer
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
            DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp DynFlags
dflags Bool
True FilePath
filename FilePath
out
            IO StringBuffer -> IO StringBuffer
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
$ FilePath -> IO StringBuffer
SB.hGetStringBuffer FilePath
out

        Just StringBuffer
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.
            DynFlags
dflags <- DynFlags -> IO DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> IO DynFlags) -> DynFlags -> IO DynFlags
forall a b. (a -> b) -> a -> b
$ FilePath -> DynFlags -> DynFlags
addIncludePathsQuote (ShowS
takeDirectory FilePath
filename) DynFlags
dflags

            -- Location information is wrong, so we fix that by patching it afterwards.
            let inp :: FilePath
inp = FilePath
dir FilePath -> ShowS
</> FilePath
"___GHCIDE_MAGIC___"
            FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
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
            DynFlags -> Bool -> FilePath -> FilePath -> IO ()
doCpp DynFlags
dflags Bool
True FilePath
inp FilePath
out

            -- Fix up the filename in lines like:
            -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"
            let tweak :: ShowS
tweak FilePath
x
                    | Just FilePath
x <- FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"# " FilePath
x
                    , FilePath
"___GHCIDE_MAGIC___" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` FilePath
x
                    , let num :: FilePath
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) FilePath
x
                    -- important to use /, and never \ for paths, even on Windows, since then C escapes them
                    -- and GHC gets all confused
                        = FilePath
"# " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
num FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" \"" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
x -> if Char -> Bool
isPathSeparator Char
x then Char
'/' else Char
x) FilePath
filename FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"\""
                    | Bool
otherwise = FilePath
x
            FilePath -> StringBuffer
stringToStringBuffer (FilePath -> StringBuffer) -> ShowS -> FilePath -> StringBuffer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> (FilePath -> [FilePath]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
tweak ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines (FilePath -> StringBuffer) -> IO FilePath -> IO StringBuffer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
readFileUTF8' FilePath
out


-- | Run a preprocessor on a file
runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
runPreprocessor :: DynFlags -> FilePath -> Maybe StringBuffer -> IO StringBuffer
runPreprocessor DynFlags
dflags FilePath
filename Maybe StringBuffer
contents = (FilePath -> IO StringBuffer) -> IO StringBuffer
forall a. (FilePath -> IO a) -> IO a
withTempDir ((FilePath -> IO StringBuffer) -> IO StringBuffer)
-> (FilePath -> IO StringBuffer) -> IO StringBuffer
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
    let out :: FilePath
out = FilePath
dir FilePath -> ShowS
</> ShowS
takeFileName FilePath
filename FilePath -> ShowS
<.> FilePath
"out"
    FilePath
inp <- case Maybe StringBuffer
contents of
        Maybe StringBuffer
Nothing -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
filename
        Just StringBuffer
contents -> do
            let inp :: FilePath
inp = FilePath
dir FilePath -> ShowS
</> ShowS
takeFileName FilePath
filename FilePath -> ShowS
<.> FilePath
"hs"
            FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
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
            FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
inp
    DynFlags -> [Option] -> IO ()
runPp DynFlags
dflags [FilePath -> Option
SysTools.Option FilePath
filename, FilePath -> Option
SysTools.Option FilePath
inp, FilePath -> FilePath -> Option
SysTools.FileOption FilePath
"" FilePath
out]
    FilePath -> IO StringBuffer
SB.hGetStringBuffer FilePath
out