-- 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.Compat
import qualified Development.IDE.GHC.Compat.Util   as Util
import           Development.IDE.GHC.Orphans       ()

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

-- | 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], DynFlags)
preprocessor :: HscEnv
-> FilePath
-> Maybe StringBuffer
-> ExceptT [FileDiagnostic] IO (StringBuffer, [FilePath], DynFlags)
preprocessor HscEnv
env0 FilePath
filename Maybe StringBuffer
mbContents = do
    -- Perform unlit
    (Bool
isOnDisk, StringBuffer
contents) <-
        if FilePath -> Bool
isLiterate FilePath
filename then do
            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
$ HscEnv -> FilePath -> Maybe StringBuffer -> IO StringBuffer
runLhs HscEnv
env0 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
Util.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
    ([FilePath]
opts, DynFlags
dflags) <- IO (Either [FileDiagnostic] ([FilePath], DynFlags))
-> ExceptT [FileDiagnostic] IO ([FilePath], DynFlags)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either [FileDiagnostic] ([FilePath], DynFlags))
 -> ExceptT [FileDiagnostic] IO ([FilePath], DynFlags))
-> IO (Either [FileDiagnostic] ([FilePath], DynFlags))
-> ExceptT [FileDiagnostic] IO ([FilePath], DynFlags)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> FilePath
-> StringBuffer
-> IO (Either [FileDiagnostic] ([FilePath], DynFlags))
parsePragmasIntoDynFlags HscEnv
env0 FilePath
filename StringBuffer
contents
    let env1 :: HscEnv
env1 = DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags HscEnv
env0
    let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
env1
    (Bool
isOnDisk, StringBuffer
contents, [FilePath]
opts, 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, [FilePath], DynFlags)
-> ExceptT
     [FileDiagnostic] IO (Bool, StringBuffer, [FilePath], DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isOnDisk, StringBuffer
contents, [FilePath]
opts, 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 []
            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
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
<$> (HscEnv -> FilePath -> Maybe StringBuffer -> IO StringBuffer
runCpp (Logger -> HscEnv -> HscEnv
putLogHook Logger
newLogger HscEnv
env1) 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 :: Util.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
                            )
            ([FilePath]
opts, DynFlags
dflags) <- IO (Either [FileDiagnostic] ([FilePath], DynFlags))
-> ExceptT [FileDiagnostic] IO ([FilePath], DynFlags)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either [FileDiagnostic] ([FilePath], DynFlags))
 -> ExceptT [FileDiagnostic] IO ([FilePath], DynFlags))
-> IO (Either [FileDiagnostic] ([FilePath], DynFlags))
-> ExceptT [FileDiagnostic] IO ([FilePath], DynFlags)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> FilePath
-> StringBuffer
-> IO (Either [FileDiagnostic] ([FilePath], DynFlags))
parsePragmasIntoDynFlags HscEnv
env1 FilePath
filename StringBuffer
contents
            (Bool, StringBuffer, [FilePath], DynFlags)
-> ExceptT
     [FileDiagnostic] IO (Bool, StringBuffer, [FilePath], DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, StringBuffer
contents, [FilePath]
opts, 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, [FilePath], DynFlags)
-> ExceptT [FileDiagnostic] IO (StringBuffer, [FilePath], DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (StringBuffer
contents, [FilePath]
opts, 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
$ HscEnv -> FilePath -> Maybe StringBuffer -> IO StringBuffer
runPreprocessor HscEnv
env1 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
        ([FilePath]
opts, DynFlags
dflags) <- IO (Either [FileDiagnostic] ([FilePath], DynFlags))
-> ExceptT [FileDiagnostic] IO ([FilePath], DynFlags)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either [FileDiagnostic] ([FilePath], DynFlags))
 -> ExceptT [FileDiagnostic] IO ([FilePath], DynFlags))
-> IO (Either [FileDiagnostic] ([FilePath], DynFlags))
-> ExceptT [FileDiagnostic] IO ([FilePath], DynFlags)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> FilePath
-> StringBuffer
-> IO (Either [FileDiagnostic] ([FilePath], DynFlags))
parsePragmasIntoDynFlags HscEnv
env1 FilePath
filename StringBuffer
contents
        (StringBuffer, [FilePath], DynFlags)
-> ExceptT [FileDiagnostic] IO (StringBuffer, [FilePath], DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (StringBuffer
contents, [FilePath]
opts, DynFlags
dflags)
  where
    logAction :: IORef [CPPLog] -> LogActionCompat
    logAction :: IORef [CPPLog] -> LogActionCompat
logAction IORef [CPPLog]
cppLogs DynFlags
dflags WarnReason
_reason Severity
severity SrcSpan
srcSpan PrintUnqualified
_style SDoc
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 -> SDoc -> FilePath
showSDoc DynFlags
dflags SDoc
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 Maybe ()
_) 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 (Int32 |? Text)
-> 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 (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 (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
    -> Util.StringBuffer
    -> IO (Either [FileDiagnostic] ([String], DynFlags))
parsePragmasIntoDynFlags :: HscEnv
-> FilePath
-> StringBuffer
-> IO (Either [FileDiagnostic] ([FilePath], DynFlags))
parsePragmasIntoDynFlags HscEnv
env FilePath
fp StringBuffer
contents = DynFlags
-> Text
-> IO ([FilePath], DynFlags)
-> IO (Either [FileDiagnostic] ([FilePath], DynFlags))
forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors DynFlags
dflags0 Text
"pragmas" (IO ([FilePath], DynFlags)
 -> IO (Either [FileDiagnostic] ([FilePath], DynFlags)))
-> IO ([FilePath], DynFlags)
-> IO (Either [FileDiagnostic] ([FilePath], DynFlags))
forall a b. (a -> b) -> a -> b
$ do
    let opts :: [Located FilePath]
opts = DynFlags -> StringBuffer -> FilePath -> [Located FilePath]
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
    HscEnv
hsc_env' <- HscEnv -> IO HscEnv
initializePlugins (DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags HscEnv
env)
    ([FilePath], DynFlags) -> IO ([FilePath], DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Located FilePath -> FilePath) -> [Located FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Located FilePath -> FilePath
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located FilePath]
opts, DynFlags -> DynFlags
disableWarningsAsErrors (HscEnv -> DynFlags
hsc_dflags 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 -> FilePath -> Maybe StringBuffer -> IO StringBuffer
runLhs HscEnv
env 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
Util.hGetStringBuffer FilePath
fout
  where
    logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
env
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
env

    unlit :: FilePath -> FilePath -> IO ()
unlit FilePath
filein FilePath
fileout = Logger -> DynFlags -> [Option] -> IO ()
runUnlit Logger
logger DynFlags
dflags (FilePath -> FilePath -> [Option]
args FilePath
filein FilePath
fileout)
    args :: FilePath -> FilePath -> [Option]
args FilePath
filein FilePath
fileout = [
                      FilePath -> Option
Option     FilePath
"-h"
                    , FilePath -> Option
Option     (ShowS
escape FilePath
filename) -- name this file
                    , FilePath -> FilePath -> Option
FileOption FilePath
"" FilePath
filein       -- input file
                    , FilePath -> FilePath -> Option
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 :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer
runCpp :: HscEnv -> FilePath -> Maybe StringBuffer -> IO StringBuffer
runCpp HscEnv
env0 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"
    let dflags1 :: DynFlags
dflags1 = FilePath -> DynFlags -> DynFlags
addOptP FilePath
"-D__GHCIDE__" (HscEnv -> DynFlags
hsc_dflags HscEnv
env0)
    let env1 :: HscEnv
env1 = DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
dflags1 HscEnv
env0

    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
            HscEnv -> Bool -> FilePath -> FilePath -> IO ()
doCpp HscEnv
env1 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
Util.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.
            let dflags2 :: DynFlags
dflags2 = FilePath -> DynFlags -> DynFlags
addIncludePathsQuote (ShowS
takeDirectory FilePath
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 :: 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
            HscEnv -> Bool -> FilePath -> FilePath -> IO ()
doCpp HscEnv
env2 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
Util.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 :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer
runPreprocessor :: HscEnv -> FilePath -> Maybe StringBuffer -> IO StringBuffer
runPreprocessor HscEnv
env 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
    Logger -> DynFlags -> [Option] -> IO ()
runPp Logger
logger DynFlags
dflags [FilePath -> Option
Option FilePath
filename, FilePath -> Option
Option FilePath
inp, FilePath -> FilePath -> Option
FileOption FilePath
"" FilePath
out]
    FilePath -> IO StringBuffer
Util.hGetStringBuffer FilePath
out
  where
    logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
env
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
env