{-# 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) ["--numeric-version"] ""

installCabalLibV1 :: Env => GhcVersion -> UnpackedCabalVersion -> IO PackageDbDir
installCabalLibV1 :: GhcVersion -> UnpackedCabalVersion -> IO PackageDbDir
installCabalLibV1 ghcVer :: GhcVersion
ghcVer cabalVer :: UnpackedCabalVersion
cabalVer = do
  String -> (String -> IO PackageDbDir) -> IO PackageDbDir
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory "cabal-helper.install-cabal-tmp" ((String -> IO PackageDbDir) -> IO PackageDbDir)
-> (String -> IO PackageDbDir) -> IO PackageDbDir
forall a b. (a -> b) -> a -> b
$ \tmpdir :: 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 ver :: 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 "\
\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 db :: String
db)
  (CabalSourceDir srcdir :: String
srcdir)
  ghcVer :: GhcVersion
ghcVer
  unpackedCabalVer :: UnpackedCabalVersion
unpackedCabalVer
  = do
  civ :: CabalInstallVersion
civ@CabalInstallVersion {..} <- 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
      [
        [ "--package-db=clear"
        , "--package-db=global"
        , "--package-db=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
db
        , "--prefix=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
db String -> ShowS
</> "prefix"
        ]
        , [String]
(?progs::Programs) => [String]
cabalWithGHCProgOpts
        , if Version
cabalInstallVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> [String] -> Version
Version [1,20,0,0] []
             then ["--no-require-sandbox"]
             else []
        , [ "install", String
srcdir ]
        , if | Verbose
Word -> Bool
?verbose 3 -> ["-v2"]
             | Verbose
Word -> Bool
?verbose 4 -> ["-v3"]
             | Bool
otherwise -> []
        , [ "--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 "/") [] (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 "done"

runSetupHs
    :: Env
    => GhcVersion
    -> FilePath
    -> FilePath
    -> UnpackedCabalVersion
    -> CabalInstallVersion
    -> IO ()
runSetupHs :: GhcVersion
-> String
-> String
-> UnpackedCabalVersion
-> CabalInstallVersion
-> IO ()
runSetupHs ghcVer :: GhcVersion
ghcVer db :: String
db srcdir :: String
srcdir cabalVer :: UnpackedCabalVersion
cabalVer CabalInstallVersion {..}
    | Version
cabalInstallVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= String -> Version
parseVer "1.24" = do
      ([String] -> IO ()) -> IO ()
go (([String] -> IO ()) -> IO ()) -> ([String] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \args :: [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
$
        [ "act-as-setup", "--" ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args
    | Bool
otherwise = do
      SetupProgram {..} <- 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 nproc' :: Maybe Int
nproc'
        | CabalHEAD _ <- UnpackedCabalVersion
cabalVer =
            ["-j"String -> ShowS
forall a. [a] -> [a] -> [a]
++String
nproc]
        | CabalVersion ver :: Version
ver <- UnpackedCabalVersion
cabalVer, Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> [String] -> Version
Version [1,20] [] =
            ["-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 "" (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 run :: [String] -> IO ()
run = do
      [String] -> IO ()
run ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [ "configure", "--package-db", String
db, "--prefix", String
db String -> ShowS
</> "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 "NPROC"
      [String] -> IO ()
run ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [ "build" ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Maybe Int -> [String]
parmake_opt Maybe Int
mnproc
      [String] -> IO ()
run [ "copy" ]
      [String] -> IO ()
run [ "register" ]

newtype SetupProgram = SetupProgram { SetupProgram -> String
setupProgram :: FilePath }
compileSetupHs :: Env => GhcVersion -> FilePath -> FilePath -> IO SetupProgram
compileSetupHs :: GhcVersion -> String -> String -> IO SetupProgram
compileSetupHs (GhcVersion ghcVer :: Version
ghcVer) db :: String
db srcdir :: 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 [8] [] = [ "-fno-version-macros" ]
        | Bool
otherwise                = []

      file :: String
file = String
srcdir String -> ShowS
</> "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
    [ [ "--make"
      , "-package-conf", String
db
      ]
    , [String]
no_version_macros
    , [ String
file String -> ShowS
<.> "hs"
      , "-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
  [ [ "--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 [ "--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 _ghcVer :: GhcVersion
_ghcVer cv :: UnpackedCabalVersion
cv (PackageEnvFile env_file :: 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
    (target :: String
target, cwd :: String
cwd) <- case UnpackedCabalVersion
cv of
      CabalVersion cabalVer :: 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
$ ("Cabal-"String -> ShowS
forall a. [a] -> [a] -> [a]
++Version -> String
showVersion Version
cabalVer, "/")
      CabalHEAD (_commitid :: CommitId
_commitid, CabalSourceDir srcdir :: String
srcdir) -> do
        (String, String) -> IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (".", String
srcdir)
    CabalInstallVersion {..} <- 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 [1,20] []
             then ["--no-require-sandbox"]
             else []
        , [ if Version
cabalInstallVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> [String] -> Version
Version [2,4] []
              then "v2-install"
              else "new-install"
          ]
        , [String]
(?progs::Programs) => [String]
cabalV2WithGHCProgOpts
        , [ "--package-env=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
env_file
          , "--lib"
          , String
target
          ]
        , if | Verbose
Word -> Bool
?verbose 3 -> ["-v2"]
             | Verbose
Word -> Bool
?verbose 4 -> ["-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 "done"


cabalV2WithGHCProgOpts :: Progs => [String]
cabalV2WithGHCProgOpts :: [String]
cabalV2WithGHCProgOpts = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ "--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 [ "--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 plan :: 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 pkgdir :: String
pkgdir) }
          -> (String, NonEmpty Unit) -> Maybe (String, NonEmpty Unit)
forall a. a -> Maybe a
Just (String
pkgdir, NonEmpty Unit
units)
        _ -> 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 pkg_name :: Text
pkg_name) _) (pkgdir :: String
pkgdir, units :: 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 = $WPackage :: 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 (\u :: 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 uid :: Text
uid}
      | (Char -> Bool) -> Text -> Bool
Text.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='+') 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
/='+') Text
uid
      | Bool
otherwise = Maybe UnitId
forall a. Maybe a
Nothing

    findUnitsDependingOn :: CP.UnitId -> [CP.Unit]
    findUnitsDependingOn :: UnitId -> [Unit]
findUnitsDependingOn uid :: 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 plan_unit :: Unit
plan_unit ch_unit :: Unit pt
ch_unit
      | Just indef_uid :: 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 pkg_name :: PkgName
pkg_name _} =
      [ (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
forall a b. Coercible a b => a -> b
coerce PkgName
pkg_name) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ":") 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 pkg :: Package' ()
pkg u :: Unit
u@CP.Unit
      { uDistDir :: Unit -> Maybe String
uDistDir=Just distdirv1 :: String
distdirv1
      , uComps :: Unit -> Map CompName CompInfo
uComps=Map CompName CompInfo
comps
      , UnitId
uId :: UnitId
uId :: Unit -> UnitId
uId
      } =
        $WUnit :: 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
forall a b. Coercible a b => a -> b
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 $WUnitImplV2 :: [(ChComponentName, String)] -> Bool -> UnitImpl ('Cabal 'CV2)
UnitImplV2 {..}
          }
    mkUnit _ _ =
      String -> Unit ('Cabal 'CV2)
forall a. HasCallStack => String -> a
error "planPackages.mkUnit: Got package without distdir!"

cpCompNameToChComponentName :: CP.CompName -> ChComponentName
cpCompNameToChComponentName :: CompName -> ChComponentName
cpCompNameToChComponentName cn :: CompName
cn =
    case CompName
cn of
      CP.CompNameSetup         -> ChComponentName
ChSetupHsName
      CP.CompNameLib           -> ChLibraryName -> ChComponentName
ChLibName     ChLibraryName
ChMainLibName
      (CP.CompNameSubLib name :: 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 name :: Text
name)   -> String -> ChComponentName
ChFLibName  (String -> ChComponentName) -> String -> ChComponentName
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
name
      (CP.CompNameExe name :: Text
name)    -> String -> ChComponentName
ChExeName   (String -> ChComponentName) -> String -> ChComponentName
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
name
      (CP.CompNameTest name :: Text
name)   -> String -> ChComponentName
ChTestName  (String -> ChComponentName) -> String -> ChComponentName
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack Text
name
      (CP.CompNameBench name :: 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 procfn :: QueryEnvI c ('Cabal cpt) -> CallProcessWithCwdAndEnv a
procfn qe :: QueryEnvI c ('Cabal cpt)
qe mcwd :: Maybe String
mcwd cmd :: CabalInstallCommand
cmd args :: [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
    (CIConfigure, SCabal SCV1) ->
      String -> [String] -> [String] -> [String] -> IO a
run "v1-configure" [String]
cabalProjArgs [String]
cabalUnitArgs []
    (CIBuild, SCabal SCV1) ->
      String -> [String] -> [String] -> [String] -> IO a
run "v1-build" [String]
cabalProjArgs [] []
    (_, SCabal SCV2) ->
      String -> [String] -> [String] -> [String] -> IO a
run "v2-build" [String]
cabalProjArgs [String]
cabalUnitArgs []
  where
    Programs{..} = 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 cmdarg :: String
cmdarg before :: [String]
before aftercmd :: [String]
aftercmd after :: [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 (\qe :: 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 "")
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