-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# 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

-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]

#if MIN_VERSION_ghc(9,3,0)
import           GHC.Utils.Logger                  (LogFlags (..))
#endif

-- | 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 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
    -- Perform unlit
    (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)

    -- Compute the source hash before the preprocessor because this is
    -- how GHC does it.
    !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

    -- Perform cpp
    ([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)

    -- 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, [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
    -- 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 = 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"]


-- | This reads the pragma information directly from the provided buffer.
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

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

-- | Run (unlit) literate haskell preprocessor on a file, or buffer if set
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) -- name this file
                    , String -> String -> Option
FileOption String
"" String
filein       -- input file
                    , String -> String -> Option
FileOption String
"" String
fileout ]    -- output file
    -- taken from ghc's DriverPipeline.hs
    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 []        = []

-- | Run CPP on a file
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
            -- 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
            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
            -- 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.
            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
            -- Location information is wrong, so we fix that by patching it afterwards.
            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

            -- Fix up the filename in lines like:
            -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___"
            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
                    -- important to use /, and never \ for paths, even on Windows, since then C escapes them
                    -- and GHC gets all confused
                        = 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


-- | Run a preprocessor on a file
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