{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module HIE.Bios.Cradle.Cabal
  (
  -- * Cabal Cradle interface
  cabalAction,
  runCabalGhcCmd,
  -- * Locations
  findCabalFiles,
  -- * Wrappers
  withGhcWrapperTool,
  -- * Argument processing
  processCabalWrapperArgs,
  -- * Exposed for tests
  isCabalMultipleCompSupported,
  )where

import Data.Char (isSpace)
import System.Exit
import System.Directory
import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&))
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson ((.:))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.ByteString as BS
import Data.Conduit.Process
import Data.Maybe (fromMaybe)
import Data.List
import Data.List.Extra (trimEnd, nubOrd)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import System.FilePath
import System.Info.Extra (isWindows)
import System.IO.Temp
import Data.Version
import Data.Tuple.Extra (fst3, snd3, thd3)

import HIE.Bios.Config
import HIE.Bios.Environment (getCacheDir)
import HIE.Bios.Types hiding (ActionName(..))
import HIE.Bios.Wrappers
import qualified HIE.Bios.Process as Process
import HIE.Bios.Cradle.ProjectConfig
import HIE.Bios.Cradle.Utils
import HIE.Bios.Cradle.ProgramVersions
import HIE.Bios.Cradle.Resolved
import HIE.Bios.Process

import GHC.Fingerprint (fingerprintString)
import GHC.ResponseFile (escapeArgs)

{- Note [Finding ghc-options with cabal]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to know how to compile a cabal component with GHC.
There are two main ways to obtain the ghc-options:

1. `cabal --with-ghc <ghc-shim>` (for exe:cabal <3.15 or lib:Cabal <3.15)

In this approach, we generate a <ghc-shim> which is passed to the exe:cabal process.
If a package needs to be compiled, we compile the package with the same GHC process that
exe:cabal would have used.

If the first argument is `--interactive`, then we do not launch the GHCi process,
but record all the arguments for later processing.

2. `cabal --with-repl <repl-shim>` (for exe:cabal >=3.15 and lib:Cabal >=3.15)

The <repl-shim> is notably simpler than the <ghc-shim>, as `--with-repl` invokes
<repl-shim> *only* as the final GHCi process, not for compiling dependencies or
executing preprocessors.

Thus, <repl-shim> merely needs to log all arguments that are passed to <repl-shim>.

This is the simpler, more maintainable approach, with fewer unintended side-effects.

=== Finding the GHC process cabal uses to compile a project with

We want HLS and hie-bios to honour the `with-compiler` field in `cabal.project` files.
Again, we identify two ways to find the exact GHC program that is going to be invoked by cabal.

1. `cabal exec -- ghc --interactive -e System.Environment.getExecutablePath` (for exe:cabal <3.14)

Ignoring a couple of details, we can get the path to the raw executable by asking
the GHCi process for its executable path.
The issue is that on linux, the executable path is insufficient, the GHC executable
invoked by the user is "wrapped" in a shim that specifies the libdir location, e.g.:

    > cat /home/hugin/.ghcup/bin/ghc
    #!/bin/sh
    exedir="/home/hugin/.ghcup/ghc/9.6.7/lib/ghc-9.6.7/bin"
    exeprog="./ghc-9.6.7"
    executablename="/home/hugin/.ghcup/ghc/9.6.7/lib/ghc-9.6.7/bin/./ghc-9.6.7"
    bindir="/home/hugin/.ghcup/ghc/9.6.7/bin"
    libdir="/home/hugin/.ghcup/ghc/9.6.7/lib/ghc-9.6.7/lib"
    docdir="/home/hugin/.ghcup/ghc/9.6.7/share/doc/ghc-9.6.7"
    includedir="/home/hugin/.ghcup/ghc/9.6.7/include"

    exec "$executablename" -B"$libdir" ${1+"$@"}

We find the libdir by asking GHC via `cabal exec -- ghc --print-libdir`.
Once we have these two paths, we also need to find the `ghc-pkg` location,
otherwise cabal will use the `ghc-pkg` that is found on PATH, which is not correct
if the user overwrites the compiler field via `with-compiler`.

To find `ghc-pkg`, we assume it is going to be located next to the `libdir`, and then
reconstruct the wrapper shim for `ghc-pkg`.

Then we reconstructed both the ghc and ghc-pkg program that is going to be used by cabal
and can use it in the <ghc-shim> and `cabal repl --with-compiler <ghc-shim> --with-hc-pkg <hc-pkg-shim>`.

Calling `cabal exec` can be very slow on a large codebase, over 1 second per invocation.

2. `cabal path` (for exe:cabal >= 3.14)

We can skip the reconstruction of the GHC shim by using the output of `cabal path --compiler-info`.
This gives us the location of the GHC executable shim, so we don't need to reconstruct any shims.

However, we still have to reconstruct the ghc-pkg shim when using `cabal repl --with-compiler`.

`cabal path` is incredibly fast to invoke, as it circumvents running the cabal solver.
It is easier to maintain as well.
-}

-- | Main entry point into the cabal cradle invocation.
--
-- This function does a lot of work, supporting multiple cabal-install versions and
-- different ways of obtaining the component options.
--
-- See Note [Finding ghc-options with cabal] for a detailed elaboration.
cabalAction ::
  ResolvedCradles a ->
  FilePath ->
  Maybe String ->
  LogAction IO (WithSeverity Log) ->
  CradleProjectConfig ->
  FilePath ->
  LoadStyle ->
  CradleLoadResultT IO ComponentOptions
cabalAction :: forall a.
ResolvedCradles a
-> [Char]
-> Maybe [Char]
-> LogAction IO (WithSeverity Log)
-> CradleProjectConfig
-> [Char]
-> LoadStyle
-> CradleLoadResultT IO ComponentOptions
cabalAction ResolvedCradles a
cradles [Char]
workDir Maybe [Char]
mc LogAction IO (WithSeverity Log)
l CradleProjectConfig
projectFile [Char]
fp LoadStyle
loadStyle = do
  let progVersions :: ProgramVersions
progVersions = ResolvedCradles a -> ProgramVersions
forall a. ResolvedCradles a -> ProgramVersions
cradleProgramVersions ResolvedCradles a
cradles
  Bool
multiCompSupport <- ProgramVersions -> CradleLoadResultT IO Bool
forall (m :: * -> *). MonadIO m => ProgramVersions -> m Bool
isCabalMultipleCompSupported ProgramVersions
progVersions
  -- determine which load style is supported by this cabal cradle.
  LoadStyle
determinedLoadStyle <- case LoadStyle
loadStyle of
    LoadWithContext [[Char]]
_ | Bool -> Bool
not Bool
multiCompSupport -> do
      IO () -> CradleLoadResultT IO ()
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CradleLoadResultT IO ())
-> IO () -> CradleLoadResultT IO ()
forall a b. (a -> b) -> a -> b
$
        LogAction IO (WithSeverity Log)
l
          LogAction IO (WithSeverity Log) -> WithSeverity Log -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Log -> Severity -> WithSeverity Log
forall msg. msg -> Severity -> WithSeverity msg
WithSeverity
            ( Text -> Maybe Text -> Log
LogLoadWithContextUnsupported Text
"cabal" (Maybe Text -> Log) -> Maybe Text -> Log
forall a b. (a -> b) -> a -> b
$
                Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"cabal or ghc version is too old. We require `cabal >= 3.11` and `ghc >= 9.4`"
            )
            Severity
Warning
      LoadStyle -> CradleLoadResultT IO LoadStyle
forall a. a -> CradleLoadResultT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoadStyle
LoadFile
    LoadStyle
_ -> LoadStyle -> CradleLoadResultT IO LoadStyle
forall a. a -> CradleLoadResultT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoadStyle
loadStyle

  ([[Char]]
cabalArgs, [[Char]]
loadingFiles, [[Char]]
extraDeps) <- LogAction IO (WithSeverity Log)
-> ResolvedCradles a
-> CradleProjectConfig
-> [Char]
-> Maybe [Char]
-> [Char]
-> LoadStyle
-> CradleLoadResultT IO ([[Char]], [[Char]], [[Char]])
forall (m :: * -> *) a.
MonadIO m =>
LogAction IO (WithSeverity Log)
-> ResolvedCradles a
-> CradleProjectConfig
-> [Char]
-> Maybe [Char]
-> [Char]
-> LoadStyle
-> m ([[Char]], [[Char]], [[Char]])
processCabalLoadStyle LogAction IO (WithSeverity Log)
l ResolvedCradles a
cradles CradleProjectConfig
projectFile [Char]
workDir Maybe [Char]
mc [Char]
fp LoadStyle
determinedLoadStyle

  CabalLoadFeature
cabalFeatures <- ProgramVersions -> CradleLoadResultT IO CabalLoadFeature
forall (m :: * -> *).
MonadIO m =>
ProgramVersions -> m CabalLoadFeature
determineCabalLoadFeature ProgramVersions
progVersions
  let
    -- Used for @cabal >= 3.15@ but @lib:Cabal <3.15@, in custom setups.
    mkFallbackCabalProc :: CradleLoadResultT IO CreateProcess
mkFallbackCabalProc = LogAction IO (WithSeverity Log)
-> ProgramVersions
-> CradleProjectConfig
-> [Char]
-> [[Char]]
-> CradleLoadResultT IO CreateProcess
cabalLoadFilesBefore315 LogAction IO (WithSeverity Log)
l ProgramVersions
progVersions CradleProjectConfig
projectFile [Char]
workDir [[Char]]
cabalArgs
  CreateProcess
cabalProc <- case CabalLoadFeature
cabalFeatures of
    CabalLoadFeature
CabalWithRepl -> LogAction IO (WithSeverity Log)
-> CradleProjectConfig
-> [Char]
-> [[Char]]
-> CradleLoadResultT IO CreateProcess
cabalLoadFilesWithRepl LogAction IO (WithSeverity Log)
l CradleProjectConfig
projectFile [Char]
workDir [[Char]]
cabalArgs
    CabalLoadFeature
CabalWithGhcShimWrapper -> LogAction IO (WithSeverity Log)
-> ProgramVersions
-> CradleProjectConfig
-> [Char]
-> [[Char]]
-> CradleLoadResultT IO CreateProcess
cabalLoadFilesBefore315 LogAction IO (WithSeverity Log)
l ProgramVersions
progVersions CradleProjectConfig
projectFile [Char]
workDir [[Char]]
cabalArgs

  Either (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails)
mResult <- CreateProcess
-> CradleLoadResultT IO CreateProcess
-> CradleLoadResultT
     IO
     (Either (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails))
runCabalToGetGhcOptions CreateProcess
cabalProc CradleLoadResultT IO CreateProcess
mkFallbackCabalProc
  case Either (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails)
mResult of
    Left (Int
code, ProcessErrorDetails
errorDetails) -> do
      -- Provide some dependencies an IDE can look for to trigger a reload.
      -- Best effort. Assume the working directory is the
      -- root of the component, so we are right in trivial cases at least.
      [[Char]]
deps <- IO [[Char]] -> CradleLoadResultT IO [[Char]]
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> CradleLoadResultT IO [[Char]])
-> IO [[Char]] -> CradleLoadResultT IO [[Char]]
forall a b. (a -> b) -> a -> b
$ CradleProjectConfig -> [Char] -> [Char] -> IO [[Char]]
cabalCradleDependencies CradleProjectConfig
projectFile [Char]
workDir [Char]
workDir
      let cmd :: [Char]
cmd = CmdSpec -> [Char]
prettyCmdSpec (CreateProcess -> CmdSpec
cmdspec CreateProcess
cabalProc)
      let errorMsg :: [Char]
errorMsg = [Char]
"Failed to run " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
cmd [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" in directory \"" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
workDir [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\". Consult the logs for full command and error."
      CradleError -> CradleLoadResultT IO ComponentOptions
forall (m :: * -> *) a.
Monad m =>
CradleError -> CradleLoadResultT m a
throwCE CradleError
        { cradleErrorDependencies :: [[Char]]
cradleErrorDependencies = [[Char]]
deps [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
extraDeps
        , cradleErrorExitCode :: ExitCode
cradleErrorExitCode = Int -> ExitCode
ExitFailure Int
code
        , cradleErrorStderr :: [[Char]]
cradleErrorStderr = [[Char]
errorMsg] [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> ProcessErrorDetails -> [[Char]]
prettyProcessErrorDetails ProcessErrorDetails
errorDetails
        , cradleErrorLoadingFiles :: [[Char]]
cradleErrorLoadingFiles = [[Char]]
loadingFiles
        }
    Right ([[Char]]
args, ProcessErrorDetails
errorDetails) -> do
      case [[Char]] -> Maybe ([Char], [[Char]])
processCabalWrapperArgs [[Char]]
args of
        Maybe ([Char], [[Char]])
Nothing -> do
          -- Provide some dependencies an IDE can look for to trigger a reload.
          -- Best effort. Assume the working directory is the
          -- root of the component, so we are right in trivial cases at least.
          [[Char]]
deps <- IO [[Char]] -> CradleLoadResultT IO [[Char]]
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> CradleLoadResultT IO [[Char]])
-> IO [[Char]] -> CradleLoadResultT IO [[Char]]
forall a b. (a -> b) -> a -> b
$ CradleProjectConfig -> [Char] -> [Char] -> IO [[Char]]
cabalCradleDependencies CradleProjectConfig
projectFile [Char]
workDir [Char]
workDir
          CradleError -> CradleLoadResultT IO ComponentOptions
forall (m :: * -> *) a.
Monad m =>
CradleError -> CradleLoadResultT m a
throwCE CradleError
            { cradleErrorDependencies :: [[Char]]
cradleErrorDependencies = [[Char]]
deps [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
extraDeps
            , cradleErrorExitCode :: ExitCode
cradleErrorExitCode = ExitCode
ExitSuccess
            , cradleErrorStderr :: [[Char]]
cradleErrorStderr = [[Char]
"Failed to parse result of calling cabal"] [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> ProcessErrorDetails -> [[Char]]
prettyProcessErrorDetails ProcessErrorDetails
errorDetails
            , cradleErrorLoadingFiles :: [[Char]]
cradleErrorLoadingFiles = [[Char]]
loadingFiles
            }
        Just ([Char]
componentDir, [[Char]]
ghc_args) -> do
          [[Char]]
deps <- IO [[Char]] -> CradleLoadResultT IO [[Char]]
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> CradleLoadResultT IO [[Char]])
-> IO [[Char]] -> CradleLoadResultT IO [[Char]]
forall a b. (a -> b) -> a -> b
$ CradleProjectConfig -> [Char] -> [Char] -> IO [[Char]]
cabalCradleDependencies CradleProjectConfig
projectFile [Char]
workDir [Char]
componentDir
          [[Char]]
final_args <- case CabalLoadFeature
cabalFeatures of
            CabalLoadFeature
CabalWithRepl -> IO [[Char]] -> CradleLoadResultT IO [[Char]]
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> CradleLoadResultT IO [[Char]])
-> IO [[Char]] -> CradleLoadResultT IO [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> IO [[Char]]
expandGhcOptionResponseFile [[Char]]
ghc_args
            CabalLoadFeature
CabalWithGhcShimWrapper -> [[Char]] -> CradleLoadResultT IO [[Char]]
forall a. a -> CradleLoadResultT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]]
ghc_args
          IO (CradleLoadResult ComponentOptions)
-> CradleLoadResultT IO ComponentOptions
forall (m :: * -> *) a.
m (CradleLoadResult a) -> CradleLoadResultT m a
CradleLoadResultT (IO (CradleLoadResult ComponentOptions)
 -> CradleLoadResultT IO ComponentOptions)
-> IO (CradleLoadResult ComponentOptions)
-> CradleLoadResultT IO ComponentOptions
forall a b. (a -> b) -> a -> b
$ CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CradleLoadResult ComponentOptions
 -> IO (CradleLoadResult ComponentOptions))
-> CradleLoadResult ComponentOptions
-> IO (CradleLoadResult ComponentOptions)
forall a b. (a -> b) -> a -> b
$ ComponentOptions -> CradleLoadResult ComponentOptions
forall r. r -> CradleLoadResult r
CradleSuccess
            ComponentOptions
              { componentOptions :: [[Char]]
componentOptions = [[Char]]
final_args
              , componentRoot :: [Char]
componentRoot = [Char]
componentDir
              , componentDependencies :: [[Char]]
componentDependencies = [[Char]]
deps [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
extraDeps
              }
  where
    -- | Run the given cabal process to obtain ghc options.
    -- In the special case of 'cabal >= 3.15' but 'lib:Cabal <3.15' (via custom-setups),
    -- we gracefully fall back to the given action to create an alternative cabal process which
    -- we use to find the ghc options.
    runCabalToGetGhcOptions ::
      Process.CreateProcess ->
      CradleLoadResultT IO Process.CreateProcess ->
      CradleLoadResultT IO
        (Either
          (Int, ProcessErrorDetails)
          ([String], ProcessErrorDetails)
        )
    runCabalToGetGhcOptions :: CreateProcess
-> CradleLoadResultT IO CreateProcess
-> CradleLoadResultT
     IO
     (Either (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails))
runCabalToGetGhcOptions CreateProcess
cabalProc CradleLoadResultT IO CreateProcess
mkFallbackCabalProc = do
      (ExitCode
ex, [[Char]]
output, [[Char]]
stde, [([Char]
_, Maybe [[Char]]
maybeArgs)]) <- IO (ExitCode, [[Char]], [[Char]], [([Char], Maybe [[Char]])])
-> CradleLoadResultT
     IO (ExitCode, [[Char]], [[Char]], [([Char], Maybe [[Char]])])
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, [[Char]], [[Char]], [([Char], Maybe [[Char]])])
 -> CradleLoadResultT
      IO (ExitCode, [[Char]], [[Char]], [([Char], Maybe [[Char]])]))
-> IO (ExitCode, [[Char]], [[Char]], [([Char], Maybe [[Char]])])
-> CradleLoadResultT
     IO (ExitCode, [[Char]], [[Char]], [([Char], Maybe [[Char]])])
forall a b. (a -> b) -> a -> b
$ [[Char]]
-> LogAction IO (WithSeverity Log)
-> [Char]
-> CreateProcess
-> IO (ExitCode, [[Char]], [[Char]], [([Char], Maybe [[Char]])])
Process.readProcessWithOutputs [[Char]
hie_bios_output] LogAction IO (WithSeverity Log)
l [Char]
workDir CreateProcess
cabalProc
      let args :: [[Char]]
args = [[Char]] -> Maybe [[Char]] -> [[Char]]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [[Char]]
maybeArgs
      let errorDetails :: ProcessErrorDetails
errorDetails = ProcessErrorDetails
            { processCmd :: CmdSpec
processCmd = CreateProcess -> CmdSpec
cmdspec CreateProcess
cabalProc
            , processStdout :: [[Char]]
processStdout = [[Char]]
output
            , processStderr :: [[Char]]
processStderr = [[Char]]
stde
            , processGhcOptions :: [[Char]]
processGhcOptions = [[Char]]
args
            , processHieBiosEnvironment :: [([Char], [Char])]
processHieBiosEnvironment = CreateProcess -> [([Char], [Char])]
hieBiosProcessEnv CreateProcess
cabalProc
            }
      case ExitCode
ex of
        ExitFailure{} | [[Char]] -> Bool
isCabalLibraryInProjectTooOld [[Char]]
stde -> do
          IO () -> CradleLoadResultT IO ()
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CradleLoadResultT IO ())
-> IO () -> CradleLoadResultT IO ()
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log)
l LogAction IO (WithSeverity Log) -> WithSeverity Log -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Log -> Severity -> WithSeverity Log
forall msg. msg -> Severity -> WithSeverity msg
WithSeverity ([[Char]] -> Log
LogCabalLibraryTooOld [[Char]]
stde) Severity
Debug
          CreateProcess
fallbackCabalProc <- CradleLoadResultT IO CreateProcess
mkFallbackCabalProc
          CreateProcess
-> CradleLoadResultT IO CreateProcess
-> CradleLoadResultT
     IO
     (Either (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails))
runCabalToGetGhcOptions CreateProcess
fallbackCabalProc CradleLoadResultT IO CreateProcess
mkFallbackCabalProc
        ExitFailure Int
code -> do

          Either (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails)
-> CradleLoadResultT
     IO
     (Either (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails))
forall a. a -> CradleLoadResultT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails)
 -> CradleLoadResultT
      IO
      (Either
         (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails)))
-> Either
     (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails)
-> CradleLoadResultT
     IO
     (Either (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails))
forall a b. (a -> b) -> a -> b
$ (Int, ProcessErrorDetails)
-> Either
     (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails)
forall a b. a -> Either a b
Left (Int
code, ProcessErrorDetails
errorDetails)
        ExitCode
ExitSuccess ->
          Either (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails)
-> CradleLoadResultT
     IO
     (Either (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails))
forall a. a -> CradleLoadResultT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails)
 -> CradleLoadResultT
      IO
      (Either
         (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails)))
-> Either
     (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails)
-> CradleLoadResultT
     IO
     (Either (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails))
forall a b. (a -> b) -> a -> b
$ ([[Char]], ProcessErrorDetails)
-> Either
     (Int, ProcessErrorDetails) ([[Char]], ProcessErrorDetails)
forall a b. b -> Either a b
Right ([[Char]]
args, ProcessErrorDetails
errorDetails)


runCabalGhcCmd :: ResolvedCradles a -> FilePath -> LogAction IO (WithSeverity Log) -> CradleProjectConfig -> [String] -> IO (CradleLoadResult String)
runCabalGhcCmd :: forall a.
ResolvedCradles a
-> [Char]
-> LogAction IO (WithSeverity Log)
-> CradleProjectConfig
-> [[Char]]
-> IO (CradleLoadResult [Char])
runCabalGhcCmd ResolvedCradles a
cs [Char]
wdir LogAction IO (WithSeverity Log)
l CradleProjectConfig
projectFile [[Char]]
args = CradleLoadResultT IO [Char] -> IO (CradleLoadResult [Char])
forall (m :: * -> *) a.
CradleLoadResultT m a -> m (CradleLoadResult a)
runCradleResultT (CradleLoadResultT IO [Char] -> IO (CradleLoadResult [Char]))
-> CradleLoadResultT IO [Char] -> IO (CradleLoadResult [Char])
forall a b. (a -> b) -> a -> b
$ do
  let vs :: ProgramVersions
vs = ResolvedCradles a -> ProgramVersions
forall a. ResolvedCradles a -> ProgramVersions
cradleProgramVersions ResolvedCradles a
cs
  LogAction IO (WithSeverity Log)
-> ProgramVersions
-> [Char]
-> CradleProjectConfig
-> CradleLoadResultT IO (Maybe [Char])
callCabalPathForCompilerPath LogAction IO (WithSeverity Log)
l ProgramVersions
vs [Char]
wdir CradleProjectConfig
projectFile CradleLoadResultT IO (Maybe [Char])
-> (Maybe [Char] -> CradleLoadResultT IO [Char])
-> CradleLoadResultT IO [Char]
forall a b.
CradleLoadResultT IO a
-> (a -> CradleLoadResultT IO b) -> CradleLoadResultT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just [Char]
p -> LogAction IO (WithSeverity Log)
-> [Char]
-> [Char]
-> [[Char]]
-> [Char]
-> CradleLoadResultT IO [Char]
Process.readProcessWithCwd_ LogAction IO (WithSeverity Log)
l [Char]
wdir [Char]
p [[Char]]
args [Char]
""
    Maybe [Char]
Nothing -> do
      [Char]
buildDir <- IO [Char] -> CradleLoadResultT IO [Char]
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> CradleLoadResultT IO [Char])
-> IO [Char] -> CradleLoadResultT IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
cabalBuildDir [Char]
wdir
      -- Workaround for a cabal-install bug on 3.0.0.0:
      -- ./dist-newstyle/tmp/environment.-24811: createDirectory: does not exist (No such file or directory)
      IO () -> CradleLoadResultT IO ()
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CradleLoadResultT IO ())
-> IO () -> CradleLoadResultT IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char]
buildDir [Char] -> [Char] -> [Char]
</> [Char]
"tmp")
      -- Need to pass -v0 otherwise we get "resolving dependencies..."
      CreateProcess
cabalProc <- LogAction IO (WithSeverity Log)
-> ProgramVersions
-> CradleProjectConfig
-> [Char]
-> [[Char]]
-> CradleLoadResultT IO CreateProcess
cabalExecGhc LogAction IO (WithSeverity Log)
l ProgramVersions
vs CradleProjectConfig
projectFile [Char]
wdir [[Char]]
args
      LogAction IO (WithSeverity Log)
-> CreateProcess -> [Char] -> CradleLoadResultT IO [Char]
Process.readProcessWithCwd' LogAction IO (WithSeverity Log)
l CreateProcess
cabalProc [Char]
""

processCabalLoadStyle :: MonadIO m => LogAction IO (WithSeverity Log) -> ResolvedCradles a -> CradleProjectConfig -> [Char] -> Maybe FilePath -> [Char] -> LoadStyle -> m ([FilePath], [FilePath], [FilePath])
processCabalLoadStyle :: forall (m :: * -> *) a.
MonadIO m =>
LogAction IO (WithSeverity Log)
-> ResolvedCradles a
-> CradleProjectConfig
-> [Char]
-> Maybe [Char]
-> [Char]
-> LoadStyle
-> m ([[Char]], [[Char]], [[Char]])
processCabalLoadStyle LogAction IO (WithSeverity Log)
l ResolvedCradles a
cradles CradleProjectConfig
projectFile [Char]
workDir Maybe [Char]
mc [Char]
fp LoadStyle
loadStyle = do
  let fpModule :: [Char]
fpModule = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> [Char]
fixTargetPath [Char]
fp) Maybe [Char]
mc
  let ([[Char]]
cabalArgs, [[Char]]
loadingFiles, [[Char]]
extraDeps) = case LoadStyle
loadStyle of
        LoadStyle
LoadFile -> ([[Char]
fpModule], [[Char]
fp], [])
        LoadWithContext [[Char]]
fps ->
          let allModulesFpsDeps :: [([Char], [Char], [[Char]])]
allModulesFpsDeps = (([Char]
fpModule, [Char]
fp, []) ([Char], [Char], [[Char]])
-> [([Char], [Char], [[Char]])] -> [([Char], [Char], [[Char]])]
forall a. a -> [a] -> [a]
: [[Char]] -> [([Char], [Char], [[Char]])]
moduleFilesFromSameProject [[Char]]
fps)
              allModules :: [[Char]]
allModules = [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
nubOrd ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char], [Char], [[Char]]) -> [Char]
forall a b c. (a, b, c) -> a
fst3 (([Char], [Char], [[Char]]) -> [Char])
-> [([Char], [Char], [[Char]])] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([Char], [Char], [[Char]])]
allModulesFpsDeps
              allFiles :: [[Char]]
allFiles = [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
nubOrd ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char], [Char], [[Char]]) -> [Char]
forall a b c. (a, b, c) -> b
snd3 (([Char], [Char], [[Char]]) -> [Char])
-> [([Char], [Char], [[Char]])] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([Char], [Char], [[Char]])]
allModulesFpsDeps
              allFpsDeps :: [[Char]]
allFpsDeps = [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
nubOrd ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (([Char], [Char], [[Char]]) -> [[Char]])
-> [([Char], [Char], [[Char]])] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Char], [Char], [[Char]]) -> [[Char]]
forall a b c. (a, b, c) -> c
thd3 [([Char], [Char], [[Char]])]
allModulesFpsDeps
           in ([[Char]
"--keep-temp-files", [Char]
"--enable-multi-repl"] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
allModules, [[Char]]
allFiles, [[Char]]
allFpsDeps)

  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log)
l LogAction IO (WithSeverity Log) -> WithSeverity Log -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Text -> LoadStyle -> Log
LogComputedCradleLoadStyle Text
"cabal" LoadStyle
loadStyle Log -> Severity -> WithSeverity Log
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Info
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log)
l LogAction IO (WithSeverity Log) -> WithSeverity Log -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& [Char] -> Maybe [Char] -> [[Char]] -> [[Char]] -> Log
LogCabalLoad [Char]
fp Maybe [Char]
mc (ResolvedCradle a -> [Char]
forall a. ResolvedCradle a -> [Char]
prefix (ResolvedCradle a -> [Char]) -> [ResolvedCradle a] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResolvedCradles a -> [ResolvedCradle a]
forall a. ResolvedCradles a -> [ResolvedCradle a]
resolvedCradles ResolvedCradles a
cradles) [[Char]]
loadingFiles Log -> Severity -> WithSeverity Log
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
  ([[Char]], [[Char]], [[Char]]) -> m ([[Char]], [[Char]], [[Char]])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]]
cabalArgs, [[Char]]
loadingFiles, [[Char]]
extraDeps)
  where
    -- Need to make relative on Windows, due to a Cabal bug with how it
    -- parses file targets with a C: drive in it. So we decide to make
    -- the paths relative to the working directory.
    fixTargetPath :: [Char] -> [Char]
fixTargetPath [Char]
x
      | Bool
isWindows Bool -> Bool -> Bool
&& [Char] -> Bool
hasDrive [Char]
x = [Char] -> [Char] -> [Char]
makeRelative [Char]
workDir [Char]
x
      | Bool
otherwise = [Char]
x
    moduleFilesFromSameProject :: [[Char]] -> [([Char], [Char], [[Char]])]
moduleFilesFromSameProject [[Char]]
fps =
      [ ([Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> [Char]
fixTargetPath [Char]
file) Maybe [Char]
old_mc, [Char]
file, [[Char]]
deps)
      | [Char]
file <- [[Char]]
fps,
        -- Lookup the component for the old file
        Just (ResolvedCradle {concreteCradle :: forall a. ResolvedCradle a -> ConcreteCradle a
concreteCradle = ConcreteCabal CabalType
ct, cradleDeps :: forall a. ResolvedCradle a -> [[Char]]
cradleDeps = [[Char]]
deps}) <- [(ResolvedCradle a -> [Char])
-> [Char] -> [ResolvedCradle a] -> Maybe (ResolvedCradle a)
forall a. (a -> [Char]) -> [Char] -> [a] -> Maybe a
selectCradle ResolvedCradle a -> [Char]
forall a. ResolvedCradle a -> [Char]
prefix [Char]
file (ResolvedCradles a -> [ResolvedCradle a]
forall a. ResolvedCradles a -> [ResolvedCradle a]
resolvedCradles ResolvedCradles a
cradles)],
        -- Only include this file if the old component is in the same project
        ([Char] -> Maybe [Char] -> CradleProjectConfig
projectConfigFromMaybe (ResolvedCradles a -> [Char]
forall a. ResolvedCradles a -> [Char]
cradleRoot ResolvedCradles a
cradles) (CabalType -> Maybe [Char]
cabalProjectFile CabalType
ct)) CradleProjectConfig -> CradleProjectConfig -> Bool
forall a. Eq a => a -> a -> Bool
== CradleProjectConfig
projectFile,
        let old_mc :: Maybe [Char]
old_mc = CabalType -> Maybe [Char]
cabalComponent CabalType
ct
      ]

cabalLoadFilesWithRepl :: LogAction IO (WithSeverity Log) -> CradleProjectConfig -> FilePath -> [String] -> CradleLoadResultT IO CreateProcess
cabalLoadFilesWithRepl :: LogAction IO (WithSeverity Log)
-> CradleProjectConfig
-> [Char]
-> [[Char]]
-> CradleLoadResultT IO CreateProcess
cabalLoadFilesWithRepl LogAction IO (WithSeverity Log)
l CradleProjectConfig
projectFile [Char]
workDir [[Char]]
args = do
  let cabalCommand :: [Char]
cabalCommand = [Char]
"v2-repl"

  [([Char], [Char])]
newEnvironment <- IO [([Char], [Char])] -> CradleLoadResultT IO [([Char], [Char])]
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [([Char], [Char])]
Process.getCleanEnvironment
  [Char]
wrapper_fp <- IO [Char] -> CradleLoadResultT IO [Char]
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> CradleLoadResultT IO [Char])
-> IO [Char] -> CradleLoadResultT IO [Char]
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log) -> GhcProc -> [Char] -> IO [Char]
withReplWrapperTool LogAction IO (WithSeverity Log)
l ([Char] -> GhcProc
proc [Char]
"ghc") [Char]
workDir
  CreateProcess -> CradleLoadResultT IO CreateProcess
forall a. a -> CradleLoadResultT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> GhcProc
proc [Char]
"cabal" ([[Char]
cabalCommand, [Char]
"--keep-temp-files", [Char]
"--with-repl", [Char]
wrapper_fp] [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> CradleProjectConfig -> [[Char]]
projectFileProcessArgs CradleProjectConfig
projectFile [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
args))
    { env = Just newEnvironment
    , cwd = Just workDir
    }

-- | @'cabalCradleDependencies' projectFile rootDir componentDir@.
-- Compute the dependencies of the cabal cradle based
-- on cabal project configuration, the cradle root and the component directory.
--
-- The @projectFile@ and @projectFile <> ".local"@ are always added to the list
-- of dependencies.
--
-- Directory 'componentDir' is a sub-directory where we look for
-- package specific cradle dependencies, such as a '.cabal' file.
--
-- Found dependencies are relative to 'rootDir'.
cabalCradleDependencies :: CradleProjectConfig -> FilePath -> FilePath -> IO [FilePath]
cabalCradleDependencies :: CradleProjectConfig -> [Char] -> [Char] -> IO [[Char]]
cabalCradleDependencies CradleProjectConfig
projectFile [Char]
rootDir [Char]
componentDir = do
    let relFp :: [Char]
relFp = [Char] -> [Char] -> [Char]
makeRelative [Char]
rootDir [Char]
componentDir
    [[Char]]
cabalFiles' <- [Char] -> IO [[Char]]
findCabalFiles [Char]
componentDir
    let cabalFiles :: [[Char]]
cabalFiles = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
relFp [Char] -> [Char] -> [Char]
</>) [[Char]]
cabalFiles'
    [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]] -> IO [[Char]]) -> [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
normalise ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]]
cabalFiles [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ CradleProjectConfig -> [[Char]]
projectLocationOrDefault CradleProjectConfig
projectFile

processCabalWrapperArgs :: [String] -> Maybe (FilePath, [String])
processCabalWrapperArgs :: [[Char]] -> Maybe ([Char], [[Char]])
processCabalWrapperArgs [[Char]]
args =
    case [[Char]]
args of
        ([Char]
dir: [[Char]]
ghc_args) ->
            let final_args :: [[Char]]
final_args =
                    [[Char]] -> [[Char]]
removeVerbosityOpts
                    ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
removeRTS
                    ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
removeInteractive [[Char]]
ghc_args
            in ([Char], [[Char]]) -> Maybe ([Char], [[Char]])
forall a. a -> Maybe a
Just ([Char]
dir, [[Char]]
final_args)
        [[Char]]
_ -> Maybe ([Char], [[Char]])
forall a. Maybe a
Nothing

-- ----------------------------------------------------------------------------
-- Legacy cabal commands to obtain ghc-options.
-- These commands are obsolete in the latest cabal version, but we still support
-- them.
-- ----------------------------------------------------------------------------

cabalLoadFilesBefore315 :: LogAction IO (WithSeverity Log) -> ProgramVersions -> CradleProjectConfig -> [Char] -> [String] -> CradleLoadResultT IO CreateProcess
cabalLoadFilesBefore315 :: LogAction IO (WithSeverity Log)
-> ProgramVersions
-> CradleProjectConfig
-> [Char]
-> [[Char]]
-> CradleLoadResultT IO CreateProcess
cabalLoadFilesBefore315 LogAction IO (WithSeverity Log)
l ProgramVersions
progVersions CradleProjectConfig
projectFile [Char]
workDir [[Char]]
args = do
  let cabalCommand :: [Char]
cabalCommand = [Char]
"v2-repl"
  LogAction IO (WithSeverity Log)
-> ProgramVersions
-> CradleProjectConfig
-> [Char]
-> [Char]
-> [[Char]]
-> CradleLoadResultT IO CreateProcess
cabalProcess LogAction IO (WithSeverity Log)
l ProgramVersions
progVersions CradleProjectConfig
projectFile [Char]
workDir [Char]
cabalCommand [[Char]]
args CradleLoadResultT IO CreateProcess
-> (CradleError -> IO CradleError)
-> CradleLoadResultT IO CreateProcess
forall (m :: * -> *) a.
Monad m =>
CradleLoadResultT m a
-> (CradleError -> m CradleError) -> CradleLoadResultT m a
`modCradleError` \CradleError
err -> do
    [[Char]]
deps <- CradleProjectConfig -> [Char] -> [Char] -> IO [[Char]]
cabalCradleDependencies CradleProjectConfig
projectFile [Char]
workDir [Char]
workDir
    CradleError -> IO CradleError
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CradleError -> IO CradleError) -> CradleError -> IO CradleError
forall a b. (a -> b) -> a -> b
$ CradleError
err {cradleErrorDependencies = cradleErrorDependencies err ++ deps}

-- | Execute a cabal process in our custom cache-build directory configured
-- with the custom ghc executable.
-- The created process has its working directory set to the given working directory.
--
-- Invokes the cabal process in the given directory.
-- Finds the appropriate @ghc@ version as a fallback and provides the path
-- to the custom ghc wrapper via 'hie_bios_ghc' environment variable which
-- the custom ghc wrapper may use as a fallback if it can not respond to certain
-- queries, such as ghc version or location of the libdir.
cabalProcess :: LogAction IO (WithSeverity Log) -> ProgramVersions -> CradleProjectConfig -> FilePath -> String -> [String] -> CradleLoadResultT IO CreateProcess
cabalProcess :: LogAction IO (WithSeverity Log)
-> ProgramVersions
-> CradleProjectConfig
-> [Char]
-> [Char]
-> [[Char]]
-> CradleLoadResultT IO CreateProcess
cabalProcess LogAction IO (WithSeverity Log)
l ProgramVersions
vs CradleProjectConfig
cabalProject [Char]
workDir [Char]
command [[Char]]
args = do
  ghcDirs :: ([Char], [Char])
ghcDirs@([Char]
ghcBin, [Char]
libdir) <- LogAction IO (WithSeverity Log)
-> ProgramVersions
-> [Char]
-> CradleProjectConfig
-> CradleLoadResultT IO (Maybe [Char])
callCabalPathForCompilerPath LogAction IO (WithSeverity Log)
l ProgramVersions
vs [Char]
workDir CradleProjectConfig
cabalProject CradleLoadResultT IO (Maybe [Char])
-> (Maybe [Char] -> CradleLoadResultT IO ([Char], [Char]))
-> CradleLoadResultT IO ([Char], [Char])
forall a b.
CradleLoadResultT IO a
-> (a -> CradleLoadResultT IO b) -> CradleLoadResultT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just [Char]
p -> do
      [Char]
libdir <- LogAction IO (WithSeverity Log)
-> [Char]
-> [Char]
-> [[Char]]
-> [Char]
-> CradleLoadResultT IO [Char]
Process.readProcessWithCwd_ LogAction IO (WithSeverity Log)
l [Char]
workDir [Char]
p [[Char]
"--print-libdir"] [Char]
""
      ([Char], [Char]) -> CradleLoadResultT IO ([Char], [Char])
forall a. a -> CradleLoadResultT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
p, [Char] -> [Char]
trimEnd [Char]
libdir)
    Maybe [Char]
Nothing -> LogAction IO (WithSeverity Log)
-> CradleProjectConfig
-> [Char]
-> CradleLoadResultT IO ([Char], [Char])
cabalGhcDirs LogAction IO (WithSeverity Log)
l CradleProjectConfig
cabalProject [Char]
workDir

  [Char]
ghcPkgPath <- IO [Char] -> CradleLoadResultT IO [Char]
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> CradleLoadResultT IO [Char])
-> IO [Char] -> CradleLoadResultT IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO [Char]
withGhcPkgTool [Char]
ghcBin [Char]
libdir
  [([Char], [Char])]
newEnvironment <- IO [([Char], [Char])] -> CradleLoadResultT IO [([Char], [Char])]
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [([Char], [Char])] -> CradleLoadResultT IO [([Char], [Char])])
-> IO [([Char], [Char])] -> CradleLoadResultT IO [([Char], [Char])]
forall a b. (a -> b) -> a -> b
$ ([Char], [Char]) -> IO [([Char], [Char])]
setupEnvironment ([Char], [Char])
ghcDirs
  CreateProcess
cabalProc <- IO CreateProcess -> CradleLoadResultT IO CreateProcess
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CreateProcess -> CradleLoadResultT IO CreateProcess)
-> IO CreateProcess -> CradleLoadResultT IO CreateProcess
forall a b. (a -> b) -> a -> b
$ [Char] -> IO CreateProcess
setupCabalCommand [Char]
ghcPkgPath
  CreateProcess -> CradleLoadResultT IO CreateProcess
forall a. a -> CradleLoadResultT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CreateProcess -> CradleLoadResultT IO CreateProcess)
-> CreateProcess -> CradleLoadResultT IO CreateProcess
forall a b. (a -> b) -> a -> b
$ (CreateProcess
cabalProc
      { env = Just newEnvironment
      , cwd = Just workDir
      })
  where
    processEnvironment :: (FilePath, FilePath) -> [(String, String)]
    processEnvironment :: ([Char], [Char]) -> [([Char], [Char])]
processEnvironment ([Char]
ghcBin, [Char]
libdir) =
      [([Char]
hie_bios_ghc, [Char]
ghcBin), ([Char]
hie_bios_ghc_args,  [Char]
"-B" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
libdir)]

    setupEnvironment :: (FilePath, FilePath) -> IO [(String, String)]
    setupEnvironment :: ([Char], [Char]) -> IO [([Char], [Char])]
setupEnvironment ([Char], [Char])
ghcDirs = do
      [([Char], [Char])]
environment <- IO [([Char], [Char])]
Process.getCleanEnvironment
      [([Char], [Char])] -> IO [([Char], [Char])]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([([Char], [Char])] -> IO [([Char], [Char])])
-> [([Char], [Char])] -> IO [([Char], [Char])]
forall a b. (a -> b) -> a -> b
$ ([Char], [Char]) -> [([Char], [Char])]
processEnvironment ([Char], [Char])
ghcDirs [([Char], [Char])] -> [([Char], [Char])] -> [([Char], [Char])]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])]
environment

    setupCabalCommand :: FilePath -> IO CreateProcess
    setupCabalCommand :: [Char] -> IO CreateProcess
setupCabalCommand [Char]
ghcPkgPath = do
      [Char]
wrapper_fp <- LogAction IO (WithSeverity Log) -> GhcProc -> [Char] -> IO [Char]
withGhcWrapperTool LogAction IO (WithSeverity Log)
l ([Char] -> GhcProc
proc [Char]
"ghc") [Char]
workDir
      [Char]
buildDir <- [Char] -> IO [Char]
cabalBuildDir [Char]
workDir
      let extraCabalArgs :: [[Char]]
extraCabalArgs =
            [ [Char]
"--builddir=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
buildDir
            , [Char]
command
            , [Char]
"--with-compiler", [Char]
wrapper_fp
            , [Char]
"--with-hc-pkg", [Char]
ghcPkgPath
            ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> CradleProjectConfig -> [[Char]]
projectFileProcessArgs CradleProjectConfig
cabalProject
      CreateProcess -> IO CreateProcess
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CreateProcess -> IO CreateProcess)
-> CreateProcess -> IO CreateProcess
forall a b. (a -> b) -> a -> b
$ [Char] -> GhcProc
proc [Char]
"cabal" ([[Char]]
extraCabalArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
args)

-- | Discover the location of the ghc binary 'cabal' is going to use together
-- with its libdir location.
-- The ghc executable is an absolute path, but not necessarily canonicalised
-- or normalised. Additionally, the ghc path returned is likely to be the raw
-- executable, i.e. without the usual wrapper shims on non-windows systems.
-- If you want to use the given ghc executable, you should invoke
-- 'withGhcWrapperTool'.
--
-- If cabal can not figure it out, a 'CradleError' is returned.
cabalGhcDirs :: LogAction IO (WithSeverity Log) -> CradleProjectConfig -> FilePath -> CradleLoadResultT IO (FilePath, FilePath)
cabalGhcDirs :: LogAction IO (WithSeverity Log)
-> CradleProjectConfig
-> [Char]
-> CradleLoadResultT IO ([Char], [Char])
cabalGhcDirs LogAction IO (WithSeverity Log)
l CradleProjectConfig
cabalProject [Char]
workDir = do
  [Char]
libdir <- LogAction IO (WithSeverity Log)
-> [Char]
-> [Char]
-> [[Char]]
-> [Char]
-> CradleLoadResultT IO [Char]
Process.readProcessWithCwd_ LogAction IO (WithSeverity Log)
l [Char]
workDir [Char]
"cabal"
      ([[Char]
"exec"] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
       [[Char]]
projectFileArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
       [[Char]
"-v0", [Char]
"--", [Char]
"ghc", [Char]
"--print-libdir"]
      )
      [Char]
""
  [Char]
exe <- LogAction IO (WithSeverity Log)
-> [Char]
-> [Char]
-> [[Char]]
-> [Char]
-> CradleLoadResultT IO [Char]
Process.readProcessWithCwd_ LogAction IO (WithSeverity Log)
l [Char]
workDir [Char]
"cabal"
      -- DON'T TOUCH THIS CODE
      -- This works with 'NoImplicitPrelude', with 'RebindableSyntax' and other shenanigans.
      -- @-package-env=-@ doesn't work with ghc prior 8.4.x
      ([ [Char]
"exec"] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
       [[Char]]
projectFileArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
       [ [Char]
"-v0", [Char]
"--" , [Char]
"ghc", [Char]
"-package-env=-", [Char]
"-ignore-dot-ghci", [Char]
"-e"
       , [Char]
"Control.Monad.join (Control.Monad.fmap System.IO.putStr System.Environment.getExecutablePath)"
       ]
      )
      [Char]
""
  ([Char], [Char]) -> CradleLoadResultT IO ([Char], [Char])
forall a. a -> CradleLoadResultT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> [Char]
trimEnd [Char]
exe, [Char] -> [Char]
trimEnd [Char]
libdir)
  where
    projectFileArgs :: [[Char]]
projectFileArgs = CradleProjectConfig -> [[Char]]
projectFileProcessArgs CradleProjectConfig
cabalProject

-- | Discovers the location of 'ghc-pkg' given the absolute path to 'ghc'
-- and its '$libdir' (obtainable by running @ghc --print-libdir@).
--
-- @'withGhcPkgTool' ghcPathAbs libdir@ guesses the location by looking at
-- the filename of 'ghcPathAbs' and expects that 'ghc-pkg' is right next to it,
-- which is guaranteed by the ghc build system. Most OS's follow this
-- convention.
--
-- On unix, there is a high-chance that the obtained 'ghc' location is the
-- "unwrapped" executable, e.g. the executable without a shim that specifies
-- the '$libdir' and other important constants.
-- As such, the executable 'ghc-pkg' is similarly without a wrapper shim and
-- is lacking certain constants such as 'global-package-db'. It is, therefore,
-- not suitable to pass in to other consumers, such as 'cabal'.
--
-- Here, we restore the wrapper-shims, if necessary, thus the returned filepath
-- can be passed to 'cabal' without further modifications.
withGhcPkgTool :: FilePath -> FilePath -> IO FilePath
withGhcPkgTool :: [Char] -> [Char] -> IO [Char]
withGhcPkgTool [Char]
ghcPathAbs [Char]
libdir = do
  let ghcName :: [Char]
ghcName = [Char] -> [Char]
takeFileName [Char]
ghcPathAbs
      -- TODO: check for existence
      ghcPkgPath :: [Char]
ghcPkgPath = [Char] -> [Char]
guessGhcPkgFromGhc [Char]
ghcName
  if Bool
isWindows
    then [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
ghcPkgPath
    else [Char] -> IO [Char]
withGhcPkgShim [Char]
ghcPkgPath
  where
    ghcDir :: [Char]
ghcDir = [Char] -> [Char]
takeDirectory [Char]
ghcPathAbs

    guessGhcPkgFromGhc :: [Char] -> [Char]
guessGhcPkgFromGhc [Char]
ghcName =
      let ghcPkgName :: Text
ghcPkgName = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"ghc" Text
"ghc-pkg" ([Char] -> Text
T.pack [Char]
ghcName)
      in [Char]
ghcDir [Char] -> [Char] -> [Char]
</> Text -> [Char]
T.unpack Text
ghcPkgName

    -- Only on unix, creates a wrapper script that's hopefully identical
    -- to the wrapper script 'ghc-pkg' usually comes with.
    --
    -- 'ghc-pkg' needs to know the 'global-package-db' location which is
    -- passed in via a wrapper shim that basically wraps 'ghc-pkg' and
    -- only passes in the correct 'global-package-db'.
    -- For an example on how the wrapper script is supposed to look like, take
    -- a look at @cat $(which ghc-pkg)@, assuming 'ghc-pkg' is on your $PATH.
    --
    -- If we used the raw executable, i.e. not wrapped in a shim, then 'cabal'
    -- can not use the given 'ghc-pkg'.
    withGhcPkgShim :: [Char] -> IO [Char]
withGhcPkgShim [Char]
ghcPkg = do
      let globalPackageDb :: [Char]
globalPackageDb = [Char]
libdir [Char] -> [Char] -> [Char]
</> [Char]
"package.conf.d"
          -- This is the same as the wrapper-shims ghc-pkg usually comes with.
          contents :: [Char]
contents = [[Char]] -> [Char]
unlines
            [ [Char]
"#!/bin/sh"
            , [[Char]] -> [Char]
unwords [[Char]
"exec", [Char] -> [Char]
escapeFilePath [Char]
ghcPkg
                      , [Char]
"--global-package-db", [Char] -> [Char]
escapeFilePath [Char]
globalPackageDb
                      , [Char]
"${1+\"$@\"}"
                      ]
            ]
          srcHash :: [Char]
srcHash = Fingerprint -> [Char]
forall a. Show a => a -> [Char]
show ([Char] -> Fingerprint
fingerprintString [Char]
contents)
      [Char] -> [Char] -> ([Char] -> IO ()) -> IO [Char]
cacheFile [Char]
"ghc-pkg" [Char]
srcHash (([Char] -> IO ()) -> IO [Char]) -> ([Char] -> IO ()) -> IO [Char]
forall a b. (a -> b) -> a -> b
$ \[Char]
wrapperFp -> [Char] -> [Char] -> IO ()
writeFile [Char]
wrapperFp [Char]
contents

    -- Escape the filepath and trim excess newlines added by 'escapeArgs'
    escapeFilePath :: [Char] -> [Char]
escapeFilePath [Char]
fp = [Char] -> [Char]
trimEnd ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
escapeArgs [[Char]
fp]

-- ----------------------------------------------------------------------------
-- Wrapper Tools
-- ----------------------------------------------------------------------------

-- | GHC process that accepts GHC arguments.
type GhcProc = [String] -> CreateProcess

-- | Generate a fake GHC that can be passed to cabal or stack
-- when run with --interactive, it will print out its
-- command-line arguments and exit
withGhcWrapperTool :: LogAction IO (WithSeverity Log) -> GhcProc -> FilePath -> IO FilePath
withGhcWrapperTool :: LogAction IO (WithSeverity Log) -> GhcProc -> [Char] -> IO [Char]
withGhcWrapperTool LogAction IO (WithSeverity Log)
l GhcProc
mkGhcCall [Char]
wdir = do
  LogAction IO (WithSeverity Log)
-> GhcProc -> [Char] -> [Char] -> [Char] -> [Char] -> IO [Char]
withWrapperTool LogAction IO (WithSeverity Log)
l GhcProc
mkGhcCall [Char]
wdir [Char]
"wrapper" [Char]
cabalWrapperHs [Char]
cabalWrapper

-- | Generate a script/binary that can be passed to cabal's '--with-repl'.
-- On windows, this compiles a Haskell file, while on other systems, we persist
-- a haskell source file and ad-hoc compile it with 'GhcProc'.
--
-- 'GhcProc' is unused on other platforms.
--
withReplWrapperTool :: LogAction IO (WithSeverity Log) -> GhcProc -> FilePath -> IO FilePath
withReplWrapperTool :: LogAction IO (WithSeverity Log) -> GhcProc -> [Char] -> IO [Char]
withReplWrapperTool LogAction IO (WithSeverity Log)
l GhcProc
mkGhcCall [Char]
wdir =
  LogAction IO (WithSeverity Log)
-> GhcProc -> [Char] -> [Char] -> [Char] -> [Char] -> IO [Char]
withWrapperTool LogAction IO (WithSeverity Log)
l GhcProc
mkGhcCall [Char]
wdir [Char]
"repl-wrapper" [Char]
cabalWithReplWrapperHs [Char]
cabalWithReplWrapper

withWrapperTool :: LogAction IO (WithSeverity Log) -> GhcProc -> String -> FilePath -> String -> String -> IO FilePath
withWrapperTool :: LogAction IO (WithSeverity Log)
-> GhcProc -> [Char] -> [Char] -> [Char] -> [Char] -> IO [Char]
withWrapperTool LogAction IO (WithSeverity Log)
l GhcProc
mkGhcCall [Char]
wdir [Char]
baseName [Char]
windowsWrapper [Char]
unixWrapper = do
  let wrapperContents :: [Char]
wrapperContents = if Bool
isWindows then [Char]
windowsWrapper else [Char]
unixWrapper
      withExtension :: [Char] -> [Char]
withExtension [Char]
fp = if Bool
isWindows then [Char]
fp [Char] -> [Char] -> [Char]
<.> [Char]
"exe" else [Char]
fp
      srcHash :: [Char]
srcHash = Fingerprint -> [Char]
forall a. Show a => a -> [Char]
show ([Char] -> Fingerprint
fingerprintString [Char]
wrapperContents)
  [Char] -> [Char] -> ([Char] -> IO ()) -> IO [Char]
cacheFile ([Char] -> [Char]
withExtension [Char]
baseName) [Char]
srcHash (([Char] -> IO ()) -> IO [Char]) -> ([Char] -> IO ()) -> IO [Char]
forall a b. (a -> b) -> a -> b
$ \[Char]
wrapper_fp ->
    if Bool
isWindows
    then
      [Char] -> ([Char] -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> ([Char] -> m a) -> m a
withSystemTempDirectory [Char]
"hie-bios" (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ [Char]
tmpDir -> do
        let wrapper_hs :: [Char]
wrapper_hs = [Char]
wrapper_fp [Char] -> [Char] -> [Char]
-<.> [Char]
"hs"
        [Char] -> [Char] -> IO ()
writeFile [Char]
wrapper_hs [Char]
wrapperContents
        let ghcArgs :: [[Char]]
ghcArgs = [[Char]
"-rtsopts=ignore", [Char]
"-outputdir", [Char]
tmpDir, [Char]
"-o", [Char]
wrapper_fp, [Char]
wrapper_hs]
        let ghcProc :: CreateProcess
ghcProc = (GhcProc
mkGhcCall [[Char]]
ghcArgs)
                    { cwd = Just wdir
                    }
        LogAction IO (WithSeverity Log)
l LogAction IO (WithSeverity Log) -> WithSeverity Log -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& CreateProcess -> Log
LogCreateProcessRun CreateProcess
ghcProc Log -> Severity -> WithSeverity Log
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Debug
        CreateProcess -> [Char] -> IO [Char]
readCreateProcess CreateProcess
ghcProc [Char]
"" IO [Char] -> ([Char] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> IO ()
putStr
    else [Char] -> [Char] -> IO ()
writeFile [Char]
wrapper_fp [Char]
wrapperContents

-- ----------------------------------------------------------------------------
-- 'cabal.project' options
-- ----------------------------------------------------------------------------

projectFileProcessArgs :: CradleProjectConfig -> [String]
projectFileProcessArgs :: CradleProjectConfig -> [[Char]]
projectFileProcessArgs (ExplicitConfig [Char]
prjFile) = [[Char]
"--project-file", [Char]
prjFile]
projectFileProcessArgs CradleProjectConfig
NoExplicitConfig = []

projectLocationOrDefault :: CradleProjectConfig -> [FilePath]
projectLocationOrDefault :: CradleProjectConfig -> [[Char]]
projectLocationOrDefault = \case
  CradleProjectConfig
NoExplicitConfig -> [[Char]
"cabal.project", [Char]
"cabal.project.local"]
  (ExplicitConfig [Char]
prjFile) -> [[Char]
prjFile, [Char]
prjFile [Char] -> [Char] -> [Char]
<.> [Char]
"local"]

-- ----------------------------------------------------------------------------
-- cabal locations
-- ----------------------------------------------------------------------------

-- | Given the root directory, get the build dir we are using for cabal
-- In the `hie-bios` cache directory
cabalBuildDir :: FilePath -> IO FilePath
cabalBuildDir :: [Char] -> IO [Char]
cabalBuildDir [Char]
workDir = do
  [Char]
abs_work_dir <- [Char] -> IO [Char]
makeAbsolute [Char]
workDir
  let dirHash :: [Char]
dirHash = Fingerprint -> [Char]
forall a. Show a => a -> [Char]
show ([Char] -> Fingerprint
fingerprintString [Char]
abs_work_dir)
  [Char] -> IO [Char]
getCacheDir ([Char]
"dist-" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) ([Char] -> [Char]
takeBaseName [Char]
abs_work_dir)[Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>[Char]
"-"[Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>[Char]
dirHash)

-- |Find .cabal files in the given directory.
--
-- Might return multiple results,biosAction as we can not know in advance
-- which one is important to the user.
findCabalFiles :: FilePath -> IO [FilePath]
findCabalFiles :: [Char] -> IO [[Char]]
findCabalFiles [Char]
wdir = do
  [[Char]]
dirContent <- [Char] -> IO [[Char]]
listDirectory [Char]
wdir
  [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]] -> IO [[Char]]) -> [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".cabal") ([Char] -> Bool) -> ([Char] -> [Char]) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
takeExtension) [[Char]]
dirContent

-- ----------------------------------------------------------------------------
-- cabal process wrappers and helpers
-- ----------------------------------------------------------------------------

cabalExecGhc :: LogAction IO (WithSeverity Log) -> ProgramVersions -> CradleProjectConfig -> FilePath -> [String] -> CradleLoadResultT IO CreateProcess
cabalExecGhc :: LogAction IO (WithSeverity Log)
-> ProgramVersions
-> CradleProjectConfig
-> [Char]
-> [[Char]]
-> CradleLoadResultT IO CreateProcess
cabalExecGhc LogAction IO (WithSeverity Log)
l ProgramVersions
vs CradleProjectConfig
projectFile [Char]
wdir [[Char]]
args = do
  LogAction IO (WithSeverity Log)
-> ProgramVersions
-> CradleProjectConfig
-> [Char]
-> [Char]
-> [[Char]]
-> CradleLoadResultT IO CreateProcess
cabalProcess LogAction IO (WithSeverity Log)
l ProgramVersions
vs CradleProjectConfig
projectFile [Char]
wdir [Char]
"v2-exec" ([[Char]] -> CradleLoadResultT IO CreateProcess)
-> [[Char]] -> CradleLoadResultT IO CreateProcess
forall a b. (a -> b) -> a -> b
$ [[Char]
"ghc", [Char]
"-v0", [Char]
"--"] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
args

callCabalPathForCompilerPath :: LogAction IO (WithSeverity Log) -> ProgramVersions -> FilePath -> CradleProjectConfig -> CradleLoadResultT IO (Maybe FilePath)
callCabalPathForCompilerPath :: LogAction IO (WithSeverity Log)
-> ProgramVersions
-> [Char]
-> CradleProjectConfig
-> CradleLoadResultT IO (Maybe [Char])
callCabalPathForCompilerPath LogAction IO (WithSeverity Log)
l ProgramVersions
vs [Char]
workDir CradleProjectConfig
projectFile = do
  ProgramVersions -> CradleLoadResultT IO Bool
forall (m :: * -> *). MonadIO m => ProgramVersions -> m Bool
isCabalPathSupported ProgramVersions
vs CradleLoadResultT IO Bool
-> (Bool -> CradleLoadResultT IO (Maybe [Char]))
-> CradleLoadResultT IO (Maybe [Char])
forall a b.
CradleLoadResultT IO a
-> (a -> CradleLoadResultT IO b) -> CradleLoadResultT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> Maybe [Char] -> CradleLoadResultT IO (Maybe [Char])
forall a. a -> CradleLoadResultT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing
    Bool
True -> do
      let
        args :: [[Char]]
args = [[Char]
"path", [Char]
"--output-format=json"] [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> CradleProjectConfig -> [[Char]]
projectFileProcessArgs CradleProjectConfig
projectFile
        bs :: [Char] -> ByteString
bs = ByteString -> ByteString
BS.fromStrict (ByteString -> ByteString)
-> ([Char] -> ByteString) -> [Char] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> ([Char] -> Text) -> [Char] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack
        parse_compiler_path :: ByteString -> Either [Char] (Maybe [Char])
parse_compiler_path = (Object -> Parser (Maybe [Char]))
-> Object -> Either [Char] (Maybe [Char])
forall a b. (a -> Parser b) -> a -> Either [Char] b
Aeson.parseEither ((Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"compiler") (Object -> Parser Object)
-> (Object -> Parser (Maybe [Char]))
-> Object
-> Parser (Maybe [Char])
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>  (Object -> Key -> Parser (Maybe [Char])
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"path")) (Object -> Either [Char] (Maybe [Char]))
-> (ByteString -> Either [Char] Object)
-> ByteString
-> Either [Char] (Maybe [Char])
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteString -> Either [Char] Object
forall a. FromJSON a => ByteString -> Either [Char] a
Aeson.eitherDecode

      [Char]
compiler_info <- LogAction IO (WithSeverity Log)
-> [Char]
-> [Char]
-> [[Char]]
-> [Char]
-> CradleLoadResultT IO [Char]
Process.readProcessWithCwd_ LogAction IO (WithSeverity Log)
l [Char]
workDir [Char]
"cabal" [[Char]]
args [Char]
""
      case ByteString -> Either [Char] (Maybe [Char])
parse_compiler_path ([Char] -> ByteString
bs [Char]
compiler_info) of
        Left [Char]
err -> do
          IO () -> CradleLoadResultT IO ()
forall a. IO a -> CradleLoadResultT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CradleLoadResultT IO ())
-> IO () -> CradleLoadResultT IO ()
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log)
l LogAction IO (WithSeverity Log) -> WithSeverity Log -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Log -> Severity -> WithSeverity Log
forall msg. msg -> Severity -> WithSeverity msg
WithSeverity (Text -> Log
LogCabalPath (Text -> Log) -> Text -> Log
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
err) Severity
Warning
          Maybe [Char] -> CradleLoadResultT IO (Maybe [Char])
forall a. a -> CradleLoadResultT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing
        Right Maybe [Char]
a -> Maybe [Char] -> CradleLoadResultT IO (Maybe [Char])
forall a. a -> CradleLoadResultT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Char]
a

-- ----------------------------------------------------------------------------
-- Version and cabal capability checks
-- ----------------------------------------------------------------------------

data CabalLoadFeature
  = CabalWithRepl
  | CabalWithGhcShimWrapper

determineCabalLoadFeature :: MonadIO m => ProgramVersions -> m CabalLoadFeature
determineCabalLoadFeature :: forall (m :: * -> *).
MonadIO m =>
ProgramVersions -> m CabalLoadFeature
determineCabalLoadFeature ProgramVersions
vs = do
  Maybe Version
cabal_version <- IO (Maybe Version) -> m (Maybe Version)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Version) -> m (Maybe Version))
-> IO (Maybe Version) -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ CachedIO (Maybe Version) -> IO (Maybe Version)
forall a. CachedIO a -> IO a
runCachedIO (CachedIO (Maybe Version) -> IO (Maybe Version))
-> CachedIO (Maybe Version) -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ ProgramVersions -> CachedIO (Maybe Version)
cabalVersion ProgramVersions
vs
  -- determine which load style is supported by this cabal cradle.
  case Maybe Version
cabal_version of
    Just Version
ver
      | Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
makeVersion [Int
3, Int
15] -> CabalLoadFeature -> m CabalLoadFeature
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CabalLoadFeature
CabalWithRepl
      | Bool
otherwise -> CabalLoadFeature -> m CabalLoadFeature
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CabalLoadFeature
CabalWithGhcShimWrapper
    Maybe Version
_ -> CabalLoadFeature -> m CabalLoadFeature
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CabalLoadFeature
CabalWithGhcShimWrapper

-- | When @cabal repl --with-repl@ is called in a project with a custom setup which forces
-- an older @lib:Cabal@ version, then the error message looks roughly like:
--
-- @
--   Error: [Cabal-7107]
--   Could not resolve dependencies:
--   [__0] trying: cabal-with-custom-setup-0.1.0.0 (user goal)
--   [__1] next goal: cabal-with-custom-setup:setup.Cabal (dependency of cabal-with-custom-setup)
--   [__1] rejecting: cabal-with-custom-setup:setup.Cabal; 3.10.3.0/installed-3.10.3.0, ... (constraint from --with-repl requires >=3.15)
--   ...
-- @
--
-- We do a quick and dirty string comparison to check whether the error message looks like it has been caused
-- by using a @lib:Cabal@ version that doesn't support the @--with-repl@ flag.
isCabalLibraryInProjectTooOld :: [String] -> Bool
isCabalLibraryInProjectTooOld :: [[Char]] -> Bool
isCabalLibraryInProjectTooOld [[Char]]
stderr =
  [Char]
"constraint from --with-repl requires >=3.15" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` [[Char]] -> [Char]
unlines [[Char]]
stderr

isCabalPathSupported :: MonadIO m => ProgramVersions -> m Bool
isCabalPathSupported :: forall (m :: * -> *). MonadIO m => ProgramVersions -> m Bool
isCabalPathSupported ProgramVersions
vs = do
  Maybe Version
v <- IO (Maybe Version) -> m (Maybe Version)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Version) -> m (Maybe Version))
-> IO (Maybe Version) -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ CachedIO (Maybe Version) -> IO (Maybe Version)
forall a. CachedIO a -> IO a
runCachedIO (CachedIO (Maybe Version) -> IO (Maybe Version))
-> CachedIO (Maybe Version) -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ ProgramVersions -> CachedIO (Maybe Version)
cabalVersion ProgramVersions
vs
  Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> (Version -> Bool) -> Maybe Version -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
makeVersion [Int
3,Int
14]) Maybe Version
v

isCabalMultipleCompSupported :: MonadIO m => ProgramVersions -> m Bool
isCabalMultipleCompSupported :: forall (m :: * -> *). MonadIO m => ProgramVersions -> m Bool
isCabalMultipleCompSupported ProgramVersions
vs = do
  Maybe Version
cabal_version <- IO (Maybe Version) -> m (Maybe Version)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Version) -> m (Maybe Version))
-> IO (Maybe Version) -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ CachedIO (Maybe Version) -> IO (Maybe Version)
forall a. CachedIO a -> IO a
runCachedIO (CachedIO (Maybe Version) -> IO (Maybe Version))
-> CachedIO (Maybe Version) -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ ProgramVersions -> CachedIO (Maybe Version)
cabalVersion ProgramVersions
vs
  Maybe Version
ghc_version <- IO (Maybe Version) -> m (Maybe Version)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Version) -> m (Maybe Version))
-> IO (Maybe Version) -> m (Maybe Version)
forall a b. (a -> b) -> a -> b
$ CachedIO (Maybe Version) -> IO (Maybe Version)
forall a. CachedIO a -> IO a
runCachedIO (CachedIO (Maybe Version) -> IO (Maybe Version))
-> CachedIO (Maybe Version) -> IO (Maybe Version)
forall a b. (a -> b) -> a -> b
$ ProgramVersions -> CachedIO (Maybe Version)
ghcVersion ProgramVersions
vs
  -- determine which load style is supported by this cabal cradle.
  case (Maybe Version
cabal_version, Maybe Version
ghc_version) of
    (Just Version
cabal, Just Version
ghc) -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Version
ghc Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
makeVersion [Int
9, Int
4] Bool -> Bool -> Bool
&& Version
cabal Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
makeVersion [Int
3, Int
11]
    (Maybe Version, Maybe Version)
_ -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False