{-# LANGUAGE DataKinds, MultiWayIf, TupleSections, GADTs, OverloadedStrings #-}

-- cabal-helper: Simple interface to Cabal's configuration state
-- Copyright (C) 2018  Daniel Gröber <cabal-helper@dxld.at>
--
-- SPDX-License-Identifier: Apache-2.0
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0

{-|
Module      : CabalHelper.Compiletime.Program.Cabal
Description : cabal-install program interface
License     : Apache-2.0
-}

module CabalHelper.Compiletime.Program.CabalInstall where

import Control.Arrow ((&&&))
import qualified Cabal.Plan as CP
import Control.Monad
import Data.Coerce
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Semigroup ((<>))
import Data.Maybe
import Data.Version
import System.IO
import System.IO.Temp
import System.Directory
import System.Environment
import System.FilePath
import Text.Printf
import Text.Read

import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as Text

import qualified CabalHelper.Compiletime.Cabal as Cabal
import CabalHelper.Compiletime.Types
import CabalHelper.Compiletime.Program.GHC
  ( GhcVersion(..), createPkgDb )
import CabalHelper.Compiletime.Types.Cabal
  ( CabalSourceDir(..), UnpackedCabalVersion, CabalVersion'(..) )
import CabalHelper.Compiletime.Cabal
  ( unpackCabalV1 )
import CabalHelper.Compiletime.Process
import CabalHelper.Shared.InterfaceTypes
  ( ChComponentName(..), ChLibraryName(..) )
import CabalHelper.Shared.Common
  ( parseVer, trim, appCacheDir )

newtype CabalInstallVersion = CabalInstallVersion { CabalInstallVersion -> Version
cabalInstallVer :: Version }

data HEAD = HEAD deriving (HEAD -> HEAD -> Bool
(HEAD -> HEAD -> Bool) -> (HEAD -> HEAD -> Bool) -> Eq HEAD
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HEAD -> HEAD -> Bool
$c/= :: HEAD -> HEAD -> Bool
== :: HEAD -> HEAD -> Bool
$c== :: HEAD -> HEAD -> Bool
Eq, Int -> HEAD -> ShowS
[HEAD] -> ShowS
HEAD -> String
(Int -> HEAD -> ShowS)
-> (HEAD -> String) -> ([HEAD] -> ShowS) -> Show HEAD
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HEAD] -> ShowS
$cshowList :: [HEAD] -> ShowS
show :: HEAD -> String
$cshow :: HEAD -> String
showsPrec :: Int -> HEAD -> ShowS
$cshowsPrec :: Int -> HEAD -> ShowS
Show)

cabalInstallVersion :: (Verbose, Progs) => IO CabalInstallVersion
cabalInstallVersion :: IO CabalInstallVersion
cabalInstallVersion = do
  Version -> CabalInstallVersion
CabalInstallVersion (Version -> CabalInstallVersion)
-> (String -> Version) -> String -> CabalInstallVersion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Version
parseVer (String -> Version) -> ShowS -> String -> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
trim
    (String -> CabalInstallVersion)
-> IO String -> IO CabalInstallVersion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbose => String -> [String] -> String -> IO String
String -> [String] -> String -> IO String
readProcess' (Programs -> String
cabalProgram ?progs::Programs
Programs
?progs) [String
"--numeric-version"] String
""

installCabalLibV1 :: Env => GhcVersion -> UnpackedCabalVersion -> IO PackageDbDir
installCabalLibV1 :: GhcVersion -> UnpackedCabalVersion -> IO PackageDbDir
installCabalLibV1 GhcVersion
ghcVer UnpackedCabalVersion
cabalVer = do
  String -> (String -> IO PackageDbDir) -> IO PackageDbDir
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"cabal-helper.install-cabal-tmp" ((String -> IO PackageDbDir) -> IO PackageDbDir)
-> (String -> IO PackageDbDir) -> IO PackageDbDir
forall a b. (a -> b) -> a -> b
$ \String
tmpdir -> do
    UnpackedCabalVersion -> IO ()
forall a. CabalVersion' a -> IO ()
installingMessage UnpackedCabalVersion
cabalVer
    CabalSourceDir
srcdir <- Env => UnpackedCabalVersion -> String -> IO CabalSourceDir
UnpackedCabalVersion -> String -> IO CabalSourceDir
unpackCabalV1 UnpackedCabalVersion
cabalVer String
tmpdir

    PackageDbDir
db <- (Verbose, ?progs::Programs) =>
UnpackedCabalVersion -> IO PackageDbDir
UnpackedCabalVersion -> IO PackageDbDir
createPkgDb UnpackedCabalVersion
cabalVer

    Env =>
PackageDbDir
-> CabalSourceDir -> GhcVersion -> UnpackedCabalVersion -> IO ()
PackageDbDir
-> CabalSourceDir -> GhcVersion -> UnpackedCabalVersion -> IO ()
callCabalInstall PackageDbDir
db CabalSourceDir
srcdir GhcVersion
ghcVer UnpackedCabalVersion
cabalVer

    PackageDbDir -> IO PackageDbDir
forall (m :: * -> *) a. Monad m => a -> m a
return PackageDbDir
db

installingMessage :: CabalVersion' a -> IO ()
installingMessage :: CabalVersion' a -> IO ()
installingMessage = CabalVersion' a -> IO ()
forall a. CabalVersion' a -> IO ()
message
  where
    message :: CabalVersion' a -> IO ()
message (CabalHEAD {}) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- only used for tests
    message (CabalVersion Version
ver) = do
      String
appdir <- IO String
appCacheDir
      let sver :: String
sver = Version -> String
showVersion Version
ver
      -- TODO: dumping this to stderr is not really acceptable, we need to have
      -- a way to let API clients override this!
      Handle -> String -> IO ()
hPutStr Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"\
\cabal-helper: Installing a private copy of Cabal because we couldn't\n\
\find the right version anywhere on your system. You can set the environment\n\
\variable CABAL_HELPER_DEBUG=1 to see where we searched.\n\
\\n\
\Note that this installation might take a little while but it will only\n\
\happen once per Cabal library version used in your build-plans.\n\
\\n\
\If you want to avoid this automatic installation altogether install\n\
\version %s of the Cabal library manually, either using cabal or your\n\
\system package manager. With cabal you can use the following command:\n\
\    $ cabal install Cabal --constraint \"Cabal == %s\"\n\
\\n\
\FYI the build products and cabal-helper executable cache are all in the\n\
\following directory, you can simply delete it if you think something\n\
\is broken :\n\
\    %s\n\
\Please do report any problems you encounter.\n\
\\n\
\Installing Cabal %s ...\n" String
sver String
sver String
appdir String
sver

callCabalInstall
    :: Env
    => PackageDbDir
    -> CabalSourceDir
    -> GhcVersion
    -> UnpackedCabalVersion
    -> IO ()
callCabalInstall :: PackageDbDir
-> CabalSourceDir -> GhcVersion -> UnpackedCabalVersion -> IO ()
callCabalInstall
  (PackageDbDir String
db)
  (CabalSourceDir String
srcdir)
  GhcVersion
ghcVer
  UnpackedCabalVersion
unpackedCabalVer
  = do
  civ :: CabalInstallVersion
civ@CabalInstallVersion {Version
cabalInstallVer :: Version
cabalInstallVer :: CabalInstallVersion -> Version
..} <- IO CabalInstallVersion
(Verbose, ?progs::Programs) => IO CabalInstallVersion
cabalInstallVersion
  [String]
cabal_opts <- [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [
        [ String
"--package-db=clear"
        , String
"--package-db=global"
        , String
"--package-db=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
db
        , String
"--prefix=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
db String -> ShowS
</> String
"prefix"
        ]
        , [String]
(?progs::Programs) => [String]
cabalWithGHCProgOpts
        , if Version
cabalInstallVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> [String] -> Version
Version [Int
1,Int
20,Int
0,Int
0] []
             then [String
"--no-require-sandbox"]
             else []
        , [ String
"install", String
srcdir ]
        , if | Verbose
Word -> Bool
?verbose Word
3 -> [String
"-v2"]
             | Verbose
Word -> Bool
?verbose Word
4 -> [String
"-v3"]
             | Bool
otherwise -> []
        , [ String
"--only-dependencies" ]
      ]

  Verbose =>
Maybe String
-> [(String, EnvOverride)] -> String -> [String] -> IO ()
Maybe String
-> [(String, EnvOverride)] -> String -> [String] -> IO ()
callProcessStderr (String -> Maybe String
forall a. a -> Maybe a
Just String
"/") [] (Programs -> String
cabalProgram ?progs::Programs
Programs
?progs) [String]
cabal_opts

  Env =>
GhcVersion
-> String
-> String
-> UnpackedCabalVersion
-> CabalInstallVersion
-> IO ()
GhcVersion
-> String
-> String
-> UnpackedCabalVersion
-> CabalInstallVersion
-> IO ()
runSetupHs GhcVersion
ghcVer String
db String
srcdir UnpackedCabalVersion
unpackedCabalVer CabalInstallVersion
civ

  Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"done"

runSetupHs
    :: Env
    => GhcVersion
    -> FilePath
    -> FilePath
    -> UnpackedCabalVersion
    -> CabalInstallVersion
    -> IO ()
runSetupHs :: GhcVersion
-> String
-> String
-> UnpackedCabalVersion
-> CabalInstallVersion
-> IO ()
runSetupHs GhcVersion
ghcVer String
db String
srcdir UnpackedCabalVersion
cabalVer CabalInstallVersion {Version
cabalInstallVer :: Version
cabalInstallVer :: CabalInstallVersion -> Version
..}
    | Version
cabalInstallVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= String -> Version
parseVer String
"1.24" = do
      ([String] -> IO ()) -> IO ()
go (([String] -> IO ()) -> IO ()) -> ([String] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[String]
args -> Verbose =>
Maybe String
-> [(String, EnvOverride)] -> String -> [String] -> IO ()
Maybe String
-> [(String, EnvOverride)] -> String -> [String] -> IO ()
callProcessStderr (String -> Maybe String
forall a. a -> Maybe a
Just String
srcdir) [] (Programs -> String
cabalProgram ?progs::Programs
Programs
?progs) ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [ String
"act-as-setup", String
"--" ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args
    | Bool
otherwise = do
      SetupProgram {String
setupProgram :: SetupProgram -> String
setupProgram :: String
..} <- Env => GhcVersion -> String -> String -> IO SetupProgram
GhcVersion -> String -> String -> IO SetupProgram
compileSetupHs GhcVersion
ghcVer String
db String
srcdir
      ([String] -> IO ()) -> IO ()
go (([String] -> IO ()) -> IO ()) -> ([String] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbose =>
Maybe String
-> [(String, EnvOverride)] -> String -> [String] -> IO ()
Maybe String
-> [(String, EnvOverride)] -> String -> [String] -> IO ()
callProcessStderr (String -> Maybe String
forall a. a -> Maybe a
Just String
srcdir) [] String
setupProgram
  where
    parmake_opt :: Maybe Int -> [String]
    parmake_opt :: Maybe Int -> [String]
parmake_opt Maybe Int
nproc'
        | CabalHEAD (CommitId, CabalSourceDir)
_ <- UnpackedCabalVersion
cabalVer =
            [String
"-j"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
nproc]
        | CabalVersion Version
ver <- UnpackedCabalVersion
cabalVer, Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> [String] -> Version
Version [Int
1,Int
20] [] =
            [String
"-j"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
nproc]
        | Bool
otherwise =
            []
      where
        nproc :: String
nproc = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Maybe Int -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
nproc'
    go :: ([String] -> IO ()) -> IO ()
    go :: ([String] -> IO ()) -> IO ()
go [String] -> IO ()
run = do
      [String] -> IO ()
run ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [ String
"configure", String
"--package-db", String
db, String
"--prefix", String
db String -> ShowS
</> String
"prefix" ]
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
(?progs::Programs) => [String]
cabalWithGHCProgOpts
      Maybe Int
mnproc <- Maybe (Maybe Int) -> Maybe Int
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Int) -> Maybe Int)
-> (Maybe String -> Maybe (Maybe Int)) -> Maybe String -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe Int) -> Maybe String -> Maybe (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Maybe String -> Maybe Int) -> IO (Maybe String) -> IO (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"NPROC"
      [String] -> IO ()
run ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [ String
"build" ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Maybe Int -> [String]
parmake_opt Maybe Int
mnproc
      [String] -> IO ()
run [ String
"copy" ]
      [String] -> IO ()
run [ String
"register" ]

newtype SetupProgram = SetupProgram { SetupProgram -> String
setupProgram :: FilePath }
compileSetupHs :: Env => GhcVersion -> FilePath -> FilePath -> IO SetupProgram
compileSetupHs :: GhcVersion -> String -> String -> IO SetupProgram
compileSetupHs (GhcVersion Version
ghcVer) String
db String
srcdir = do
  let no_version_macros :: [String]
no_version_macros
        | Version
ghcVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> [String] -> Version
Version [Int
8] [] = [ String
"-fno-version-macros" ]
        | Bool
otherwise                = []

      file :: String
file = String
srcdir String -> ShowS
</> String
"Setup"

  Verbose =>
Maybe String
-> [(String, EnvOverride)] -> String -> [String] -> IO ()
Maybe String
-> [(String, EnvOverride)] -> String -> [String] -> IO ()
callProcessStderr (String -> Maybe String
forall a. a -> Maybe a
Just String
srcdir) [] (Programs -> String
ghcProgram ?progs::Programs
Programs
?progs) ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ String
"--make"
      , String
"-package-conf", String
db
      ]
    , [String]
no_version_macros
    , [ String
file String -> ShowS
<.> String
"hs"
      , String
"-o", String
file
      ]
    ]
  SetupProgram -> IO SetupProgram
forall (m :: * -> *) a. Monad m => a -> m a
return (SetupProgram -> IO SetupProgram)
-> SetupProgram -> IO SetupProgram
forall a b. (a -> b) -> a -> b
$ String -> SetupProgram
SetupProgram String
file

cabalWithGHCProgOpts :: Progs => [String]
cabalWithGHCProgOpts :: [String]
cabalWithGHCProgOpts = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"--with-ghc=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Programs -> String
ghcProgram ?progs::Programs
Programs
?progs ]
  -- Only pass ghc-pkg if it was actually set otherwise we
  -- might break cabal's guessing logic
  , if Programs -> String
ghcPkgProgram ?progs::Programs
Programs
?progs String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= Programs -> String
ghcPkgProgram Programs
defaultPrograms
      then [ String
"--with-ghc-pkg=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Programs -> String
ghcPkgProgram ?progs::Programs
Programs
?progs ]
      else []
  ]

installCabalLibV2 :: Env => GhcVersion -> UnpackedCabalVersion -> PackageEnvFile -> IO ()
installCabalLibV2 :: GhcVersion -> UnpackedCabalVersion -> PackageEnvFile -> IO ()
installCabalLibV2 GhcVersion
_ghcVer UnpackedCabalVersion
cv (PackageEnvFile String
env_file) = do
  Bool
exists <- String -> IO Bool
doesFileExist String
env_file
  if Bool
exists
    then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else do
    UnpackedCabalVersion -> IO ()
forall a. CabalVersion' a -> IO ()
installingMessage UnpackedCabalVersion
cv
    (String
target, String
cwd) <- case UnpackedCabalVersion
cv of
      CabalVersion Version
cabalVer -> do
        (String, String) -> IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> IO (String, String))
-> (String, String) -> IO (String, String)
forall a b. (a -> b) -> a -> b
$ (String
"Cabal-"String -> ShowS
forall a. [a] -> [a] -> [a]
++Version -> String
showVersion Version
cabalVer, String
"/")
      CabalHEAD (CommitId
_commitid, CabalSourceDir String
srcdir) -> do
        (String, String) -> IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
".", String
srcdir)
    CabalInstallVersion {Version
cabalInstallVer :: Version
cabalInstallVer :: CabalInstallVersion -> Version
..} <- IO CabalInstallVersion
(Verbose, ?progs::Programs) => IO CabalInstallVersion
cabalInstallVersion
    [String]
cabal_opts <- [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ if Version
cabalInstallVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> [String] -> Version
Version [Int
1,Int
20] []
             then [String
"--no-require-sandbox"]
             else []
        , [ if Version
cabalInstallVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> [String] -> Version
Version [Int
2,Int
4] []
              then String
"v2-install"
              else String
"new-install"
          ]
        , [String]
(?progs::Programs) => [String]
cabalV2WithGHCProgOpts
        , [ String
"--package-env=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
env_file
          , String
"--lib"
          , String
target
          ]
        , if | Verbose
Word -> Bool
?verbose Word
3 -> [String
"-v2"]
             | Verbose
Word -> Bool
?verbose Word
4 -> [String
"-v3"]
             | Bool
otherwise -> []
        ]
    Verbose =>
Maybe String
-> [(String, EnvOverride)] -> String -> [String] -> IO ()
Maybe String
-> [(String, EnvOverride)] -> String -> [String] -> IO ()
callProcessStderr (String -> Maybe String
forall a. a -> Maybe a
Just String
cwd) [] (Programs -> String
cabalProgram ?progs::Programs
Programs
?progs) [String]
cabal_opts
    Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"done"


cabalV2WithGHCProgOpts :: Progs => [String]
cabalV2WithGHCProgOpts :: [String]
cabalV2WithGHCProgOpts = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"--with-compiler=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Programs -> String
ghcProgram ?progs::Programs
Programs
?progs ]
  , if Programs -> String
ghcPkgProgram ?progs::Programs
Programs
?progs String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= Programs -> String
ghcPkgProgram Programs
defaultPrograms
      then [ String
"--with-hc-pkg=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Programs -> String
ghcPkgProgram ?progs::Programs
Programs
?progs ]
      else []
  ]

planPackages :: CP.PlanJson -> IO [Package ('Cabal 'CV2)]
planPackages :: PlanJson -> IO [Package ('Cabal 'CV2)]
planPackages PlanJson
plan = do
    [IO (Package ('Cabal 'CV2))] -> IO [Package ('Cabal 'CV2)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([IO (Package ('Cabal 'CV2))] -> IO [Package ('Cabal 'CV2)])
-> [IO (Package ('Cabal 'CV2))] -> IO [Package ('Cabal 'CV2)]
forall a b. (a -> b) -> a -> b
$
      Map PkgId (IO (Package ('Cabal 'CV2)))
-> [IO (Package ('Cabal 'CV2))]
forall k a. Map k a -> [a]
Map.elems (Map PkgId (IO (Package ('Cabal 'CV2)))
 -> [IO (Package ('Cabal 'CV2))])
-> Map PkgId (IO (Package ('Cabal 'CV2)))
-> [IO (Package ('Cabal 'CV2))]
forall a b. (a -> b) -> a -> b
$
      (PkgId -> (String, NonEmpty Unit) -> IO (Package ('Cabal 'CV2)))
-> Map PkgId (String, NonEmpty Unit)
-> Map PkgId (IO (Package ('Cabal 'CV2)))
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey PkgId -> (String, NonEmpty Unit) -> IO (Package ('Cabal 'CV2))
mkPackage (Map PkgId (String, NonEmpty Unit)
 -> Map PkgId (IO (Package ('Cabal 'CV2))))
-> Map PkgId (String, NonEmpty Unit)
-> Map PkgId (IO (Package ('Cabal 'CV2)))
forall a b. (a -> b) -> a -> b
$
      (NonEmpty Unit -> Maybe (String, NonEmpty Unit))
-> Map PkgId (NonEmpty Unit) -> Map PkgId (String, NonEmpty Unit)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe NonEmpty Unit -> Maybe (String, NonEmpty Unit)
packagesWithSourceDir (Map PkgId (NonEmpty Unit) -> Map PkgId (String, NonEmpty Unit))
-> Map PkgId (NonEmpty Unit) -> Map PkgId (String, NonEmpty Unit)
forall a b. (a -> b) -> a -> b
$
      [Unit] -> Map PkgId (NonEmpty Unit)
groupByMap ([Unit] -> Map PkgId (NonEmpty Unit))
-> [Unit] -> Map PkgId (NonEmpty Unit)
forall a b. (a -> b) -> a -> b
$
      Map UnitId Unit -> [Unit]
forall k a. Map k a -> [a]
Map.elems (Map UnitId Unit -> [Unit]) -> Map UnitId Unit -> [Unit]
forall a b. (a -> b) -> a -> b
$
      PlanJson -> Map UnitId Unit
CP.pjUnits PlanJson
plan
  where
    groupByMap :: [Unit] -> Map PkgId (NonEmpty Unit)
groupByMap = (NonEmpty Unit -> NonEmpty Unit -> NonEmpty Unit)
-> [(PkgId, NonEmpty Unit)] -> Map PkgId (NonEmpty Unit)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith NonEmpty Unit -> NonEmpty Unit -> NonEmpty Unit
forall a. Semigroup a => a -> a -> a
(<>) ([(PkgId, NonEmpty Unit)] -> Map PkgId (NonEmpty Unit))
-> ([Unit] -> [(PkgId, NonEmpty Unit)])
-> [Unit]
-> Map PkgId (NonEmpty Unit)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unit -> (PkgId, NonEmpty Unit))
-> [Unit] -> [(PkgId, NonEmpty Unit)]
forall a b. (a -> b) -> [a] -> [b]
map (Unit -> PkgId
CP.uPId (Unit -> PkgId)
-> (Unit -> NonEmpty Unit) -> Unit -> (PkgId, NonEmpty Unit)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Unit -> [Unit] -> NonEmpty Unit
forall a. a -> [a] -> NonEmpty a
:|[]))

    packagesWithSourceDir :: NonEmpty Unit -> Maybe (String, NonEmpty Unit)
packagesWithSourceDir units :: NonEmpty Unit
units@(Unit
unit :| [Unit]
_) =
      case Unit
unit of
        CP.Unit { uPkgSrc :: Unit -> Maybe PkgLoc
uPkgSrc=Just (CP.LocalUnpackedPackage String
pkgdir) }
          -> (String, NonEmpty Unit) -> Maybe (String, NonEmpty Unit)
forall a. a -> Maybe a
Just (String
pkgdir, NonEmpty Unit
units)
        Unit
_ -> Maybe (String, NonEmpty Unit)
forall a. Maybe a
Nothing

    mkPackage :: CP.PkgId -> (FilePath, NonEmpty CP.Unit) -> IO (Package ('Cabal 'CV2))
    mkPackage :: PkgId -> (String, NonEmpty Unit) -> IO (Package ('Cabal 'CV2))
mkPackage (CP.PkgId (CP.PkgName Text
pkg_name) Ver
_) (String
pkgdir, NonEmpty Unit
units) = do
      String
cabal_file <- String -> Maybe String -> IO String
Cabal.complainIfNoCabalFile String
pkgdir (Maybe String -> IO String) -> IO (Maybe String) -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Maybe String)
Cabal.findCabalFile String
pkgdir
      let pkg :: Package ('Cabal 'CV2)
pkg = Package :: forall units.
String
-> String
-> CabalFile
-> [(String, Bool)]
-> units
-> Package' units
Package
            { pPackageName :: String
pPackageName = Text -> String
Text.unpack Text
pkg_name
            , pSourceDir :: String
pSourceDir = String
pkgdir
            , pCabalFile :: CabalFile
pCabalFile = String -> CabalFile
CabalFile String
cabal_file
            , pFlags :: [(String, Bool)]
pFlags = []
            , pUnits :: NonEmpty (Unit ('Cabal 'CV2))
pUnits = (Unit -> Unit ('Cabal 'CV2))
-> NonEmpty Unit -> NonEmpty (Unit ('Cabal 'CV2))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Unit
u -> Unit -> Unit ('Cabal 'CV2) -> Unit ('Cabal 'CV2)
forall (pt :: ProjType). Unit -> Unit pt -> Unit pt
fixBackpackUnit Unit
u (Unit ('Cabal 'CV2) -> Unit ('Cabal 'CV2))
-> Unit ('Cabal 'CV2) -> Unit ('Cabal 'CV2)
forall a b. (a -> b) -> a -> b
$ Package' () -> Unit -> Unit ('Cabal 'CV2)
mkUnit Package ('Cabal 'CV2)
pkg { pUnits :: ()
pUnits = () } Unit
u) NonEmpty Unit
units
            }
      Package ('Cabal 'CV2) -> IO (Package ('Cabal 'CV2))
forall (m :: * -> *) a. Monad m => a -> m a
return Package ('Cabal 'CV2)
pkg

    takeBackpackIndefUnitId :: CP.Unit -> Maybe CP.UnitId
    takeBackpackIndefUnitId :: Unit -> Maybe UnitId
takeBackpackIndefUnitId CP.Unit {uId :: Unit -> UnitId
uId=CP.UnitId Text
uid}
      | (Char -> Bool) -> Text -> Bool
Text.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'+') Text
uid = UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just (UnitId -> Maybe UnitId) -> UnitId -> Maybe UnitId
forall a b. (a -> b) -> a -> b
$ Text -> UnitId
CP.UnitId (Text -> UnitId) -> Text -> UnitId
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
Text.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'+') Text
uid
      | Bool
otherwise = Maybe UnitId
forall a. Maybe a
Nothing

    findUnitsDependingOn :: CP.UnitId -> [CP.Unit]
    findUnitsDependingOn :: UnitId -> [Unit]
findUnitsDependingOn UnitId
uid = Map UnitId Unit -> [Unit]
forall k a. Map k a -> [a]
Map.elems (Map UnitId Unit -> [Unit]) -> Map UnitId Unit -> [Unit]
forall a b. (a -> b) -> a -> b
$
      (Unit -> Bool) -> Map UnitId Unit -> Map UnitId Unit
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((CompInfo -> Bool) -> [CompInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member UnitId
uid (Set UnitId -> Bool)
-> (CompInfo -> Set UnitId) -> CompInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompInfo -> Set UnitId
CP.ciLibDeps) ([CompInfo] -> Bool) -> (Unit -> [CompInfo]) -> Unit -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map CompName CompInfo -> [CompInfo]
forall k a. Map k a -> [a]
Map.elems (Map CompName CompInfo -> [CompInfo])
-> (Unit -> Map CompName CompInfo) -> Unit -> [CompInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unit -> Map CompName CompInfo
CP.uComps) (Map UnitId Unit -> Map UnitId Unit)
-> Map UnitId Unit -> Map UnitId Unit
forall a b. (a -> b) -> a -> b
$
      PlanJson -> Map UnitId Unit
CP.pjUnits PlanJson
plan

    -- Horrible workaround for https://github.com/haskell/cabal/issues/6201
    fixBackpackUnit :: Unit -> Unit pt -> Unit pt
fixBackpackUnit Unit
plan_unit Unit pt
ch_unit
      | Just UnitId
indef_uid <- Unit -> Maybe UnitId
takeBackpackIndefUnitId Unit
plan_unit = do
        let deps :: [Unit]
deps = UnitId -> [Unit]
findUnitsDependingOn UnitId
indef_uid
        Unit pt
ch_unit { uImpl :: UnitImpl pt
uImpl = (Unit pt -> UnitImpl pt
forall (pt :: ProjType). Unit pt -> UnitImpl pt
uImpl Unit pt
ch_unit)
          { uiV2Components :: [(ChComponentName, String)]
uiV2Components = (Unit -> [(ChComponentName, String)])
-> [Unit] -> [(ChComponentName, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Unit -> [(ChComponentName, String)]
unitTargets [Unit]
deps
          , uiV2OnlyDependencies :: Bool
uiV2OnlyDependencies = Bool
True
          } }
      | Bool
otherwise =
        Unit pt
ch_unit

    unitTargets :: CP.Unit -> [(ChComponentName, String)]
    unitTargets :: Unit -> [(ChComponentName, String)]
unitTargets CP.Unit {Map CompName CompInfo
uComps :: Map CompName CompInfo
uComps :: Unit -> Map CompName CompInfo
uComps, uPId :: Unit -> PkgId
uPId=CP.PkgId PkgName
pkg_name Ver
_} =
      [ (CompName -> ChComponentName
cpCompNameToChComponentName CompName
comp, Text -> String
Text.unpack Text
target)
      | CompName
comp <- Map CompName CompInfo -> [CompName]
forall k a. Map k a -> [k]
Map.keys Map CompName CompInfo
uComps
      , let comp_str :: Text
comp_str = PkgName -> CompName -> Text
CP.dispCompNameTarget PkgName
pkg_name CompName
comp
      , let target :: Text
target = ((PkgName -> Text
coerce PkgName
pkg_name) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
comp_str
      ]

    mkUnit :: Package' () -> CP.Unit -> Unit ('Cabal 'CV2)
    mkUnit :: Package' () -> Unit -> Unit ('Cabal 'CV2)
mkUnit Package' ()
pkg u :: Unit
u@CP.Unit
      { uDistDir :: Unit -> Maybe String
uDistDir=Just String
distdirv1
      , uComps :: Unit -> Map CompName CompInfo
uComps=Map CompName CompInfo
comps
      , UnitId
uId :: UnitId
uId :: Unit -> UnitId
uId
      } =
        Unit :: forall (pt :: ProjType).
UnitId -> Package' () -> DistDirLib -> UnitImpl pt -> Unit pt
Unit
          { uUnitId :: UnitId
uUnitId     = String -> UnitId
UnitId (String -> UnitId) -> String -> UnitId
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (UnitId -> Text
coerce UnitId
uId)
          , uPackage :: Package' ()
uPackage    = Package' ()
pkg
          , uDistDir :: DistDirLib
uDistDir    = String -> DistDirLib
DistDirLib String
distdirv1
          , uImpl :: UnitImpl ('Cabal 'CV2)
uImpl       =
            let
              comp_names :: [CompName]
comp_names = Map CompName CompInfo -> [CompName]
forall k a. Map k a -> [k]
Map.keys Map CompName CompInfo
comps
              uiV2ComponentNames :: [ChComponentName]
uiV2ComponentNames = (CompName -> ChComponentName) -> [CompName] -> [ChComponentName]
forall a b. (a -> b) -> [a] -> [b]
map CompName -> ChComponentName
cpCompNameToChComponentName [CompName]
comp_names
              uiV2Components :: [(ChComponentName, String)]
uiV2Components = Unit -> [(ChComponentName, String)]
unitTargets Unit
u
              uiV2OnlyDependencies :: Bool
uiV2OnlyDependencies = Bool
False
            in UnitImplV2 :: [(ChComponentName, String)] -> Bool -> UnitImpl ('Cabal 'CV2)
UnitImplV2 {Bool
[(ChComponentName, String)]
uiV2OnlyDependencies :: Bool
uiV2Components :: [(ChComponentName, String)]
uiV2OnlyDependencies :: Bool
uiV2Components :: [(ChComponentName, String)]
..}
          }
    mkUnit Package' ()
_ Unit
_ =
      String -> Unit ('Cabal 'CV2)
forall a. HasCallStack => String -> a
error String
"planPackages.mkUnit: Got package without distdir!"

cpCompNameToChComponentName :: CP.CompName -> ChComponentName
cpCompNameToChComponentName :: CompName -> ChComponentName
cpCompNameToChComponentName CompName
cn =
    case CompName
cn of
      CompName
CP.CompNameSetup         -> ChComponentName
ChSetupHsName
      CompName
CP.CompNameLib           -> ChLibraryName -> ChComponentName
ChLibName     ChLibraryName
ChMainLibName
      (CP.CompNameSubLib Text
name) -> ChLibraryName -> ChComponentName
ChLibName   (ChLibraryName -> ChComponentName)
-> ChLibraryName -> ChComponentName
forall a b. (a -> b) -> a -> b
$ String -> ChLibraryName
ChSubLibName (String -> ChLibraryName) -> String -> ChLibraryName
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
name
      (CP.CompNameFLib Text
name)   -> String -> ChComponentName
ChFLibName  (String -> ChComponentName) -> String -> ChComponentName
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
name
      (CP.CompNameExe Text
name)    -> String -> ChComponentName
ChExeName   (String -> ChComponentName) -> String -> ChComponentName
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
name
      (CP.CompNameTest Text
name)   -> String -> ChComponentName
ChTestName  (String -> ChComponentName) -> String -> ChComponentName
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
name
      (CP.CompNameBench Text
name)  -> String -> ChComponentName
ChBenchName (String -> ChComponentName) -> String -> ChComponentName
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
name

data CabalInstallCommand
    = CIConfigure
    | CIBuild

doCabalInstallCmd
    :: (QueryEnvI c ('Cabal cpt) -> CallProcessWithCwdAndEnv a)
    -> QueryEnvI c ('Cabal cpt)
    -> Maybe FilePath -> CabalInstallCommand -> [String] -> IO a
doCabalInstallCmd :: (QueryEnvI c ('Cabal cpt) -> CallProcessWithCwdAndEnv a)
-> QueryEnvI c ('Cabal cpt)
-> Maybe String
-> CabalInstallCommand
-> [String]
-> IO a
doCabalInstallCmd QueryEnvI c ('Cabal cpt) -> CallProcessWithCwdAndEnv a
procfn QueryEnvI c ('Cabal cpt)
qe Maybe String
mcwd CabalInstallCommand
cmd [String]
args = do
  case (CabalInstallCommand
cmd, QueryEnvI c ('Cabal cpt) -> SProjType ('Cabal cpt)
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> SProjType pt
projTypeOfQueryEnv QueryEnvI c ('Cabal cpt)
qe) of
    (CabalInstallCommand
CIConfigure, SCabal SCabalProjType pt
SCV1) ->
      String -> [String] -> [String] -> [String] -> IO a
run String
"v1-configure" [String]
cabalProjArgs [String]
cabalUnitArgs []
    (CabalInstallCommand
CIBuild, SCabal SCabalProjType pt
SCV1) ->
      String -> [String] -> [String] -> [String] -> IO a
run String
"v1-build" [String]
cabalProjArgs [] []
    (CabalInstallCommand
_, SCabal SCabalProjType pt
SCV2) ->
      String -> [String] -> [String] -> [String] -> IO a
run String
"v2-build" [String]
cabalProjArgs [String]
cabalUnitArgs []
  where
    Programs{String
[String]
[(String, EnvOverride)]
haddockProgram :: Programs -> String
stackEnv :: Programs -> [(String, EnvOverride)]
stackUnitArgs :: Programs -> [String]
stackProjArgs :: Programs -> [String]
stackProgram :: Programs -> String
cabalUnitArgs :: Programs -> [String]
cabalProjArgs :: Programs -> [String]
haddockProgram :: String
ghcPkgProgram :: String
ghcProgram :: String
stackEnv :: [(String, EnvOverride)]
stackUnitArgs :: [String]
stackProjArgs :: [String]
stackProgram :: String
cabalProgram :: String
cabalUnitArgs :: [String]
cabalProjArgs :: [String]
ghcPkgProgram :: Programs -> String
ghcProgram :: Programs -> String
cabalProgram :: Programs -> String
..} = QueryEnvI c ('Cabal cpt) -> Programs
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> Programs
qePrograms QueryEnvI c ('Cabal cpt)
qe
    run :: String -> [String] -> [String] -> [String] -> IO a
run String
cmdarg [String]
before [String]
aftercmd [String]
after  = QueryEnvI c ('Cabal cpt) -> CallProcessWithCwdAndEnv a
procfn QueryEnvI c ('Cabal cpt)
qe Maybe String
mcwd [] String
cabalProgram ([String] -> IO a) -> [String] -> IO a
forall a b. (a -> b) -> a -> b
$
      [String]
before [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
cmdarg] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
aftercmd [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
after

readCabalInstallCmd
    :: QueryEnvI c ('Cabal cpt)
    -> Maybe FilePath -> CabalInstallCommand -> [String] -> IO String
callCabalInstallCmd
    :: QueryEnvI c ('Cabal cpt)
    -> Maybe FilePath -> CabalInstallCommand -> [String] -> IO ()

readCabalInstallCmd :: QueryEnvI c ('Cabal cpt)
-> Maybe String -> CabalInstallCommand -> [String] -> IO String
readCabalInstallCmd = (QueryEnvI c ('Cabal cpt) -> CallProcessWithCwdAndEnv String)
-> QueryEnvI c ('Cabal cpt)
-> Maybe String
-> CabalInstallCommand
-> [String]
-> IO String
forall (c :: ProjType -> *) (cpt :: CabalProjType) a.
(QueryEnvI c ('Cabal cpt) -> CallProcessWithCwdAndEnv a)
-> QueryEnvI c ('Cabal cpt)
-> Maybe String
-> CabalInstallCommand
-> [String]
-> IO a
doCabalInstallCmd (\QueryEnvI c ('Cabal cpt)
qe -> QueryEnvI c ('Cabal cpt) -> ReadProcessWithCwdAndEnv
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt -> ReadProcessWithCwdAndEnv
qeReadProcess QueryEnvI c ('Cabal cpt)
qe String
"")
callCabalInstallCmd :: QueryEnvI c ('Cabal cpt)
-> Maybe String -> CabalInstallCommand -> [String] -> IO ()
callCabalInstallCmd = (QueryEnvI c ('Cabal cpt)
 -> Maybe String
 -> [(String, EnvOverride)]
 -> String
 -> [String]
 -> IO ())
-> QueryEnvI c ('Cabal cpt)
-> Maybe String
-> CabalInstallCommand
-> [String]
-> IO ()
forall (c :: ProjType -> *) (cpt :: CabalProjType) a.
(QueryEnvI c ('Cabal cpt) -> CallProcessWithCwdAndEnv a)
-> QueryEnvI c ('Cabal cpt)
-> Maybe String
-> CabalInstallCommand
-> [String]
-> IO a
doCabalInstallCmd QueryEnvI c ('Cabal cpt)
-> Maybe String
-> [(String, EnvOverride)]
-> String
-> [String]
-> IO ()
forall (c :: ProjType -> *) (pt :: ProjType).
QueryEnvI c pt
-> Maybe String
-> [(String, EnvOverride)]
-> String
-> [String]
-> IO ()
qeCallProcess