{-|
Module      : Merge
License     : GPL-3+
Maintainer  : haskell@gentoo.org

Core functionality of the @merge@ command of @HackPort@.
-}
module Merge
  ( merge
  , mergeGenericPackageDescription
  ) where

import           Control.Monad
import           Control.Exception
import qualified Data.Text as T
import qualified Data.Text.IO as T
import           Data.Function (on)
import qualified Data.Map.Strict as Map
import           Data.Maybe
import qualified Data.List as L
import qualified Data.Set as S
import qualified Data.Time.Clock as TC

-- cabal
import qualified Distribution.Package as Cabal
import qualified Distribution.Version as Cabal
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription.PrettyPrint as Cabal (showPackageDescription)
import qualified Distribution.Solver.Types.SourcePackage as CabalInstall
import qualified Distribution.Solver.Types.PackageIndex as CabalInstall

import           Distribution.Pretty (prettyShow)
import           Distribution.Verbosity
import           Distribution.Simple.Utils

-- cabal-install
import           Distribution.Client.IndexUtils ( getSourcePackages )
import qualified Distribution.Client.GlobalFlags as CabalInstall
import           Distribution.Client.Types
-- others
import           Control.Parallel.Strategies
import qualified Data.List.Split as DLS
import           System.Directory ( getCurrentDirectory
                        , setCurrentDirectory
                        , createDirectoryIfMissing
                        , doesFileExist
                        , listDirectory
                        )
import           System.Process
import           System.FilePath ((</>),(<.>))
import           System.Exit

-- hackport
import qualified AnsiColor as A
import qualified Cabal2Ebuild as C2E
import qualified Portage.EBuild as E
import qualified Portage.EMeta as EM
import           Error as E

import qualified Portage.Cabal as Portage
import qualified Portage.PackageId as Portage
import qualified Portage.Version as Portage
import qualified Portage.Metadata as Portage
import qualified Portage.Overlay as Overlay
import qualified Portage.Resolve as Portage
import qualified Portage.Dependency as Portage
import qualified Portage.Use as Portage

import qualified Portage.GHCCore as GHCCore

import qualified Merge.Dependencies as Merge
import qualified Merge.Utils        as Merge

{-
Requested features:
  * Add files to git?
-}

-- | Call @diff@ between two ebuilds.
diffEbuilds :: FilePath -> Portage.PackageId -> Portage.PackageId -> IO ()
diffEbuilds :: FilePath -> PackageId -> PackageId -> IO ()
diffEbuilds FilePath
fp PackageId
a PackageId
b = do ExitCode
_ <- FilePath -> IO ExitCode
system (FilePath -> IO ExitCode) -> FilePath -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ FilePath
"diff -u --color=auto "
                             FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fp FilePath -> FilePath -> FilePath
</> PackageId -> FilePath
Portage.packageIdToFilePath PackageId
a FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" "
                             FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fp FilePath -> FilePath -> FilePath
</> PackageId -> FilePath
Portage.packageIdToFilePath PackageId
b
                        IO ()
forall a. IO a
exitSuccess

-- | Given a list of available packages, and maybe a preferred version,
-- return the available package with that version. Latest version is chosen
-- if no preference.
resolveVersion :: [UnresolvedSourcePackage] -> Maybe Cabal.Version -> Maybe UnresolvedSourcePackage
resolveVersion :: [UnresolvedSourcePackage]
-> Maybe Version -> Maybe UnresolvedSourcePackage
resolveVersion [UnresolvedSourcePackage]
avails Maybe Version
Nothing = UnresolvedSourcePackage -> Maybe UnresolvedSourcePackage
forall a. a -> Maybe a
Just (UnresolvedSourcePackage -> Maybe UnresolvedSourcePackage)
-> UnresolvedSourcePackage -> Maybe UnresolvedSourcePackage
forall a b. (a -> b) -> a -> b
$ (UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering)
-> [UnresolvedSourcePackage] -> UnresolvedSourcePackage
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
L.maximumBy ((UnresolvedSourcePackage -> Version)
-> UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (PackageIdentifier -> Version
Cabal.pkgVersion (PackageIdentifier -> Version)
-> (UnresolvedSourcePackage -> PackageIdentifier)
-> UnresolvedSourcePackage
-> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnresolvedSourcePackage -> PackageIdentifier
forall loc. SourcePackage loc -> PackageIdentifier
CabalInstall.srcpkgPackageId)) [UnresolvedSourcePackage]
avails
resolveVersion [UnresolvedSourcePackage]
avails (Just Version
ver) = [UnresolvedSourcePackage] -> Maybe UnresolvedSourcePackage
forall a. [a] -> Maybe a
listToMaybe ((UnresolvedSourcePackage -> Bool)
-> [UnresolvedSourcePackage] -> [UnresolvedSourcePackage]
forall a. (a -> Bool) -> [a] -> [a]
filter UnresolvedSourcePackage -> Bool
forall loc. SourcePackage loc -> Bool
match [UnresolvedSourcePackage]
avails)
  where
    match :: SourcePackage loc -> Bool
match SourcePackage loc
avail = Version
ver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== PackageIdentifier -> Version
Cabal.pkgVersion (SourcePackage loc -> PackageIdentifier
forall loc. SourcePackage loc -> PackageIdentifier
CabalInstall.srcpkgPackageId SourcePackage loc
avail)

-- | This function is executed by the @merge@ command of @HackPort@.
-- Its functionality is as follows:
--
-- 1. Feed user input to 'readPackageString'
-- 2. Look for a matching package on the @hackage@ database
-- 3. Run 'mergeGenericPackageDescription' with the supplied information
-- 4. Generate a coloured diff between the old and new ebuilds.
--
-- Various information is printed in between these steps depending on the
-- 'Verbosity'.
merge :: Verbosity -> CabalInstall.RepoContext -> [String] -> FilePath -> Maybe String -> IO ()
merge :: Verbosity
-> RepoContext -> [FilePath] -> FilePath -> Maybe FilePath -> IO ()
merge Verbosity
verbosity RepoContext
repoContext [FilePath]
args FilePath
overlayPath Maybe FilePath
users_cabal_flags = do
  (Maybe Category
m_category, PackageName
user_pName, Maybe Version
m_version) <-
    case [FilePath]
-> Either
     HackPortError (Maybe Category, PackageName, Maybe Version)
Merge.readPackageString [FilePath]
args of
      Left HackPortError
err -> HackPortError -> IO (Maybe Category, PackageName, Maybe Version)
forall a. HackPortError -> IO a
throwEx HackPortError
err
      Right (Maybe Category
c,PackageName
p,Maybe Version
m_v) ->
        case Maybe Version
m_v of
          Maybe Version
Nothing -> (Maybe Category, PackageName, Maybe Version)
-> IO (Maybe Category, PackageName, Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Category
c,PackageName
p,Maybe Version
forall a. Maybe a
Nothing)
          Just Version
v -> case Version -> Maybe Version
Portage.toCabalVersion Version
v of
                      Maybe Version
Nothing -> HackPortError -> IO (Maybe Category, PackageName, Maybe Version)
forall a. HackPortError -> IO a
throwEx (FilePath -> HackPortError
ArgumentError FilePath
"illegal version")
                      Just Version
ver -> (Maybe Category, PackageName, Maybe Version)
-> IO (Maybe Category, PackageName, Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Category
c,PackageName
p,Version -> Maybe Version
forall a. a -> Maybe a
Just Version
ver)

  Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Category: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Maybe Category -> FilePath
forall a. Show a => a -> FilePath
show Maybe Category
m_category
  Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Package: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageName -> FilePath
forall a. Show a => a -> FilePath
show PackageName
user_pName
  Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Version: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Maybe Version -> FilePath
forall a. Show a => a -> FilePath
show Maybe Version
m_version

  let user_pname_str :: FilePath
user_pname_str = PackageName -> FilePath
Cabal.unPackageName PackageName
user_pName

  Overlay
overlay <- FilePath -> IO Overlay
Overlay.loadLazy FilePath
overlayPath
  -- portage_path <- Host.portage_dir `fmap` Host.getInfo
  -- portage <- Overlay.loadLazy portage_path
  PackageIndex UnresolvedSourcePackage
index <- (SourcePackageDb -> PackageIndex UnresolvedSourcePackage)
-> IO SourcePackageDb -> IO (PackageIndex UnresolvedSourcePackage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex (IO SourcePackageDb -> IO (PackageIndex UnresolvedSourcePackage))
-> IO SourcePackageDb -> IO (PackageIndex UnresolvedSourcePackage)
forall a b. (a -> b) -> a -> b
$ Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages Verbosity
verbosity RepoContext
repoContext

  -- find all packages that maches the user specified package name
  [UnresolvedSourcePackage]
availablePkgs <-
    case ((PackageName, [UnresolvedSourcePackage])
 -> [UnresolvedSourcePackage])
-> [(PackageName, [UnresolvedSourcePackage])]
-> [[UnresolvedSourcePackage]]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, [UnresolvedSourcePackage])
-> [UnresolvedSourcePackage]
forall a b. (a, b) -> b
snd (PackageIndex UnresolvedSourcePackage
-> FilePath -> [(PackageName, [UnresolvedSourcePackage])]
forall pkg. PackageIndex pkg -> FilePath -> [(PackageName, [pkg])]
CabalInstall.searchByName PackageIndex UnresolvedSourcePackage
index FilePath
user_pname_str) of
      [] -> HackPortError -> IO [UnresolvedSourcePackage]
forall a. HackPortError -> IO a
throwEx (FilePath -> HackPortError
PackageNotFound FilePath
user_pname_str)
      [[UnresolvedSourcePackage]
pkg] -> [UnresolvedSourcePackage] -> IO [UnresolvedSourcePackage]
forall (m :: * -> *) a. Monad m => a -> m a
return [UnresolvedSourcePackage]
pkg
      [[UnresolvedSourcePackage]]
pkgs  -> do let cabal_pkg_to_pn :: SourcePackage loc -> FilePath
cabal_pkg_to_pn SourcePackage loc
pkg = PackageName -> FilePath
Cabal.unPackageName (PackageName -> FilePath) -> PackageName -> FilePath
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> PackageName
Cabal.pkgName (SourcePackage loc -> PackageIdentifier
forall loc. SourcePackage loc -> PackageIdentifier
CabalInstall.srcpkgPackageId SourcePackage loc
pkg)
                      names :: [FilePath]
names      = ([UnresolvedSourcePackage] -> FilePath)
-> [[UnresolvedSourcePackage]] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (UnresolvedSourcePackage -> FilePath
forall loc. SourcePackage loc -> FilePath
cabal_pkg_to_pn (UnresolvedSourcePackage -> FilePath)
-> ([UnresolvedSourcePackage] -> UnresolvedSourcePackage)
-> [UnresolvedSourcePackage]
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnresolvedSourcePackage] -> UnresolvedSourcePackage
forall a. [a] -> a
L.head) [[UnresolvedSourcePackage]]
pkgs
                  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Ambiguous names: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
L.intercalate FilePath
", " [FilePath]
names
                  [[UnresolvedSourcePackage]]
-> ([UnresolvedSourcePackage] -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[UnresolvedSourcePackage]]
pkgs (([UnresolvedSourcePackage] -> IO ()) -> IO ())
-> ([UnresolvedSourcePackage] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[UnresolvedSourcePackage]
ps ->
                      do let p_name :: FilePath
p_name = (UnresolvedSourcePackage -> FilePath
forall loc. SourcePackage loc -> FilePath
cabal_pkg_to_pn (UnresolvedSourcePackage -> FilePath)
-> ([UnresolvedSourcePackage] -> UnresolvedSourcePackage)
-> [UnresolvedSourcePackage]
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnresolvedSourcePackage] -> UnresolvedSourcePackage
forall a. [a] -> a
L.head) [UnresolvedSourcePackage]
ps
                         Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
p_name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
L.intercalate FilePath
", " ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ (UnresolvedSourcePackage -> FilePath)
-> [UnresolvedSourcePackage] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (Version -> FilePath)
-> (UnresolvedSourcePackage -> Version)
-> UnresolvedSourcePackage
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> Version
Cabal.pkgVersion (PackageIdentifier -> Version)
-> (UnresolvedSourcePackage -> PackageIdentifier)
-> UnresolvedSourcePackage
-> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnresolvedSourcePackage -> PackageIdentifier
forall loc. SourcePackage loc -> PackageIdentifier
CabalInstall.srcpkgPackageId) [UnresolvedSourcePackage]
ps)
                  [UnresolvedSourcePackage] -> IO [UnresolvedSourcePackage]
forall (m :: * -> *) a. Monad m => a -> m a
return ([UnresolvedSourcePackage] -> IO [UnresolvedSourcePackage])
-> [UnresolvedSourcePackage] -> IO [UnresolvedSourcePackage]
forall a b. (a -> b) -> a -> b
$ [[UnresolvedSourcePackage]] -> [UnresolvedSourcePackage]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[UnresolvedSourcePackage]]
pkgs

  -- select a single package taking into account the user specified version
  UnresolvedSourcePackage
selectedPkg <-
    case [UnresolvedSourcePackage]
-> Maybe Version -> Maybe UnresolvedSourcePackage
resolveVersion [UnresolvedSourcePackage]
availablePkgs Maybe Version
m_version of
      Maybe UnresolvedSourcePackage
Nothing -> do
        FilePath -> IO ()
putStrLn FilePath
"No such version for that package, available versions:"
        [UnresolvedSourcePackage]
-> (UnresolvedSourcePackage -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [UnresolvedSourcePackage]
availablePkgs ((UnresolvedSourcePackage -> IO ()) -> IO ())
-> (UnresolvedSourcePackage -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ UnresolvedSourcePackage
avail ->
          FilePath -> IO ()
putStrLn (PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> FilePath)
-> (UnresolvedSourcePackage -> PackageIdentifier)
-> UnresolvedSourcePackage
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnresolvedSourcePackage -> PackageIdentifier
forall loc. SourcePackage loc -> PackageIdentifier
CabalInstall.srcpkgPackageId (UnresolvedSourcePackage -> FilePath)
-> UnresolvedSourcePackage -> FilePath
forall a b. (a -> b) -> a -> b
$ UnresolvedSourcePackage
avail)
        HackPortError -> IO UnresolvedSourcePackage
forall a. HackPortError -> IO a
throwEx (FilePath -> HackPortError
ArgumentError FilePath
"no such version for that package")
      Just UnresolvedSourcePackage
avail -> UnresolvedSourcePackage -> IO UnresolvedSourcePackage
forall (m :: * -> *) a. Monad m => a -> m a
return UnresolvedSourcePackage
avail

  -- print some info
  Verbosity -> FilePath -> IO ()
info Verbosity
verbosity FilePath
"Selecting package:"
  [UnresolvedSourcePackage]
-> (UnresolvedSourcePackage -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [UnresolvedSourcePackage]
availablePkgs ((UnresolvedSourcePackage -> IO ()) -> IO ())
-> (UnresolvedSourcePackage -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ UnresolvedSourcePackage
avail -> do
    let match_text :: FilePath
match_text | UnresolvedSourcePackage -> PackageIdentifier
forall loc. SourcePackage loc -> PackageIdentifier
CabalInstall.srcpkgPackageId UnresolvedSourcePackage
avail PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== UnresolvedSourcePackage -> PackageIdentifier
forall loc. SourcePackage loc -> PackageIdentifier
CabalInstall.srcpkgPackageId UnresolvedSourcePackage
selectedPkg = FilePath
"* "
                   | Bool
otherwise = FilePath
"- "
    Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
match_text FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageIdentifier -> FilePath)
-> (UnresolvedSourcePackage -> PackageIdentifier)
-> UnresolvedSourcePackage
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnresolvedSourcePackage -> PackageIdentifier
forall loc. SourcePackage loc -> PackageIdentifier
CabalInstall.srcpkgPackageId (UnresolvedSourcePackage -> FilePath)
-> UnresolvedSourcePackage -> FilePath
forall a b. (a -> b) -> a -> b
$ UnresolvedSourcePackage
avail)

  let cabal_pkgId :: PackageIdentifier
cabal_pkgId = UnresolvedSourcePackage -> PackageIdentifier
forall loc. SourcePackage loc -> PackageIdentifier
CabalInstall.srcpkgPackageId UnresolvedSourcePackage
selectedPkg
      norm_pkgName :: PackageName
norm_pkgName = PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
Cabal.packageName (PackageIdentifier -> PackageIdentifier
Portage.normalizeCabalPackageId PackageIdentifier
cabal_pkgId)
  Category
cat <- IO Category
-> (Category -> IO Category) -> Maybe Category -> IO Category
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Verbosity -> Overlay -> PackageName -> IO Category
Portage.resolveCategory Verbosity
verbosity Overlay
overlay PackageName
norm_pkgName) Category -> IO Category
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Category
m_category
  Verbosity
-> FilePath
-> Category
-> GenericPackageDescription
-> Bool
-> Maybe FilePath
-> IO ()
mergeGenericPackageDescription Verbosity
verbosity FilePath
overlayPath Category
cat (UnresolvedSourcePackage -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
CabalInstall.srcpkgDescription UnresolvedSourcePackage
selectedPkg) Bool
True Maybe FilePath
users_cabal_flags

  -- Maybe generate a diff
  let pkgPath :: FilePath
pkgPath = FilePath
overlayPath FilePath -> FilePath -> FilePath
</> (Category -> FilePath
Portage.unCategory Category
cat) FilePath -> FilePath -> FilePath
</> (PackageName -> FilePath
Cabal.unPackageName PackageName
norm_pkgName)
      newPkgId :: PackageId
newPkgId = Category -> PackageIdentifier -> PackageId
Portage.fromCabalPackageId Category
cat PackageIdentifier
cabal_pkgId
  [FilePath]
pkgDir <- FilePath -> IO [FilePath]
listDirectory FilePath
pkgPath
  case [FilePath] -> PackageId -> Maybe PackageId
Merge.getPreviousPackageId [FilePath]
pkgDir PackageId
newPkgId of
    Just PackageId
validPkg -> do Verbosity -> FilePath -> IO ()
info Verbosity
verbosity FilePath
"Generating a diff..."
                        FilePath -> PackageId -> PackageId -> IO ()
diffEbuilds FilePath
overlayPath PackageId
validPkg PackageId
newPkgId
    Maybe PackageId
_ -> Verbosity -> FilePath -> IO ()
info Verbosity
verbosity FilePath
"Nothing to diff!"

-- used to be FlagAssignment in Cabal but now it's an opaque type
type CabalFlags = [(Cabal.FlagName, Bool)]

-- | Generate an ebuild from a 'Cabal.GenericPackageDescription'.
mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> Cabal.GenericPackageDescription -> Bool -> Maybe String -> IO ()
mergeGenericPackageDescription :: Verbosity
-> FilePath
-> Category
-> GenericPackageDescription
-> Bool
-> Maybe FilePath
-> IO ()
mergeGenericPackageDescription Verbosity
verbosity FilePath
overlayPath Category
cat GenericPackageDescription
pkgGenericDesc Bool
fetch Maybe FilePath
users_cabal_flags = do
  Overlay
overlay <- FilePath -> IO Overlay
Overlay.loadLazy FilePath
overlayPath
  let merged_cabal_pkg_name :: PackageName
merged_cabal_pkg_name = PackageIdentifier -> PackageName
Cabal.pkgName (PackageDescription -> PackageIdentifier
Cabal.package (GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
pkgGenericDesc))
      merged_PN :: FilePath
merged_PN = PackageName -> FilePath
Portage.cabal_pn_to_PN PackageName
merged_cabal_pkg_name
      pkgdir :: FilePath
pkgdir    = FilePath
overlayPath FilePath -> FilePath -> FilePath
</> Category -> FilePath
Portage.unCategory Category
cat FilePath -> FilePath -> FilePath
</> FilePath
merged_PN
  EMeta
existing_meta <- FilePath -> IO EMeta
EM.findExistingMeta FilePath
pkgdir
  let requested_cabal_flags :: Maybe FilePath
requested_cabal_flags = [Maybe FilePath] -> Maybe FilePath
forall a. [Maybe a] -> Maybe a
Merge.first_just_of [Maybe FilePath
users_cabal_flags, EMeta -> Maybe FilePath
EM.cabal_flags EMeta
existing_meta]

      -- accepts things, like: "cabal_flag:iuse_name", "+cabal_flag", "-cabal_flag"
      read_fas :: Maybe String -> (CabalFlags, [(String, String)])
      read_fas :: Maybe FilePath -> (CabalFlags, [(FilePath, FilePath)])
read_fas Maybe FilePath
Nothing = ([], [])
      read_fas (Just FilePath
user_fas_s) = (CabalFlags
user_fas, [(FilePath, FilePath)]
user_renames)
          where user_fas :: CabalFlags
user_fas = [ (FlagName
cf, Bool
b)
                           | ((FlagName
cf, FilePath
_), Just Bool
b) <- [((FlagName, FilePath), Maybe Bool)]
cn_in_mb
                           ]
                user_renames :: [(FilePath, FilePath)]
user_renames = [ (FilePath
cfn, FilePath
ein)
                               | ((FlagName
cabal_cfn, FilePath
ein), Maybe Bool
Nothing) <- [((FlagName, FilePath), Maybe Bool)]
cn_in_mb
                               , let cfn :: FilePath
cfn = FlagName -> FilePath
Cabal.unFlagName FlagName
cabal_cfn
                               ]
                cn_in_mb :: [((FlagName, FilePath), Maybe Bool)]
cn_in_mb = (FilePath -> ((FlagName, FilePath), Maybe Bool))
-> [FilePath] -> [((FlagName, FilePath), Maybe Bool)]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> ((FlagName, FilePath), Maybe Bool)
read_fa ([FilePath] -> [((FlagName, FilePath), Maybe Bool)])
-> [FilePath] -> [((FlagName, FilePath), Maybe Bool)]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
DLS.splitOn FilePath
"," FilePath
user_fas_s
                read_fa :: String -> ((Cabal.FlagName, String), Maybe Bool)
                read_fa :: FilePath -> ((FlagName, FilePath), Maybe Bool)
read_fa [] = FilePath -> ((FlagName, FilePath), Maybe Bool)
forall a. HasCallStack => FilePath -> a
error (FilePath -> ((FlagName, FilePath), Maybe Bool))
-> FilePath -> ((FlagName, FilePath), Maybe Bool)
forall a b. (a -> b) -> a -> b
$ FilePath
"read_fas: empty flag?"
                read_fa (Char
op:FilePath
flag) =
                    case Char
op of
                        Char
'+'   -> (FilePath -> (FlagName, FilePath)
get_rename FilePath
flag, Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
                        Char
'-'   -> (FilePath -> (FlagName, FilePath)
get_rename FilePath
flag, Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
                        Char
_     -> (FilePath -> (FlagName, FilePath)
get_rename (Char
opChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
flag), Maybe Bool
forall a. Maybe a
Nothing)
                  where get_rename :: String -> (Cabal.FlagName, String)
                        get_rename :: FilePath -> (FlagName, FilePath)
get_rename FilePath
s =
                            case FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
DLS.splitOn FilePath
":" FilePath
s of
                                [FilePath
cabal_flag_name] -> (FilePath -> FlagName
Cabal.mkFlagName FilePath
cabal_flag_name, FilePath
cabal_flag_name)
                                [FilePath
cabal_flag_name, FilePath
iuse_name] -> (FilePath -> FlagName
Cabal.mkFlagName FilePath
cabal_flag_name, FilePath
iuse_name)
                                [FilePath]
_                 -> FilePath -> (FlagName, FilePath)
forall a. HasCallStack => FilePath -> a
error (FilePath -> (FlagName, FilePath))
-> FilePath -> (FlagName, FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath
"get_rename: too many components" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show (FilePath
s)

      (CabalFlags
user_specified_fas, [(FilePath, FilePath)]
cf_to_iuse_rename) = Maybe FilePath -> (CabalFlags, [(FilePath, FilePath)])
read_fas Maybe FilePath
requested_cabal_flags

  Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity FilePath
"searching for minimal suitable ghc version"
  (CompilerInfo
compiler_info, [PackageName]
ghc_packages, PackageDescription
pkgDesc0, FlagAssignment
_flags, InstalledPackageIndex
pix) <- case GenericPackageDescription
-> FlagAssignment
-> Maybe
     (CompilerInfo, [PackageName], PackageDescription, FlagAssignment,
      InstalledPackageIndex)
GHCCore.minimumGHCVersionToBuildPackage GenericPackageDescription
pkgGenericDesc (CabalFlags -> FlagAssignment
Cabal.mkFlagAssignment CabalFlags
user_specified_fas) of
              Just (CompilerInfo, [PackageName], PackageDescription, FlagAssignment,
 InstalledPackageIndex)
v  -> (CompilerInfo, [PackageName], PackageDescription, FlagAssignment,
 InstalledPackageIndex)
-> IO
     (CompilerInfo, [PackageName], PackageDescription, FlagAssignment,
      InstalledPackageIndex)
forall (m :: * -> *) a. Monad m => a -> m a
return (CompilerInfo, [PackageName], PackageDescription, FlagAssignment,
 InstalledPackageIndex)
v
              Maybe
  (CompilerInfo, [PackageName], PackageDescription, FlagAssignment,
   InstalledPackageIndex)
Nothing -> let pn :: FilePath
pn = PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageName
merged_cabal_pkg_name
                             cn :: FilePath
cn = Category -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Category
cat
                         in FilePath
-> IO
     (CompilerInfo, [PackageName], PackageDescription, FlagAssignment,
      InstalledPackageIndex)
forall a. HasCallStack => FilePath -> a
error (FilePath
 -> IO
      (CompilerInfo, [PackageName], PackageDescription, FlagAssignment,
       InstalledPackageIndex))
-> FilePath
-> IO
     (CompilerInfo, [PackageName], PackageDescription, FlagAssignment,
      InstalledPackageIndex)
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [ FilePath
"mergeGenericPackageDescription: failed to find suitable GHC for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pn
                                            , FilePath
"  You can try to merge the package manually:"
                                            , FilePath
"  $ cabal unpack " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pn
                                            , FilePath
"  $ cd " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pn FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"*/"
                                            , FilePath
"  # fix " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pn FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".cabal"
                                            , FilePath
"  $ hackport make-ebuild " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cn FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pn FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".cabal"
                                            ]

  let ([Dependency]
accepted_deps, [Dependency]
skipped_deps) = [PackageName]
-> PackageName -> [Dependency] -> ([Dependency], [Dependency])
Portage.partition_depends [PackageName]
ghc_packages PackageName
merged_cabal_pkg_name
                                      (PackageDescription -> [Dependency]
Merge.exeAndLibDeps PackageDescription
pkgDesc0)

      pkgDesc :: RetroPackageDescription
pkgDesc = PackageDescription -> [Dependency] -> RetroPackageDescription
Merge.RetroPackageDescription PackageDescription
pkgDesc0 [Dependency]
accepted_deps
      cabal_flag_descs :: [PackageFlag]
cabal_flag_descs = GenericPackageDescription -> [PackageFlag]
Cabal.genPackageFlags GenericPackageDescription
pkgGenericDesc
      all_flags :: [FlagName]
all_flags = (PackageFlag -> FlagName) -> [PackageFlag] -> [FlagName]
forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> FlagName
Cabal.flagName [PackageFlag]
cabal_flag_descs
      make_fas  :: [Cabal.PackageFlag] -> [CabalFlags]
      make_fas :: [PackageFlag] -> [CabalFlags]
make_fas  [] = [[]]
      make_fas  (PackageFlag
f:[PackageFlag]
rest) = [ (FlagName
fn, Bool
is_enabled) (FlagName, Bool) -> CabalFlags -> CabalFlags
forall a. a -> [a] -> [a]
: CabalFlags
fas
                           | CabalFlags
fas <- [PackageFlag] -> [CabalFlags]
make_fas [PackageFlag]
rest
                           , let fn :: FlagName
fn = PackageFlag -> FlagName
Cabal.flagName PackageFlag
f
                                 users_choice :: Maybe Bool
users_choice = FlagName -> CabalFlags -> Maybe Bool
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FlagName
fn CabalFlags
user_specified_fas
                           , Bool
is_enabled <- [Bool] -> (Bool -> [Bool]) -> Maybe Bool -> [Bool]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Bool
False, Bool
True]
                                                 (\Bool
b -> [Bool
b])
                                                 Maybe Bool
users_choice
                           ]
      all_possible_flag_assignments :: [CabalFlags]
      all_possible_flag_assignments :: [CabalFlags]
all_possible_flag_assignments = [PackageFlag] -> [CabalFlags]
make_fas [PackageFlag]
cabal_flag_descs

      pp_fa :: CabalFlags -> String
      pp_fa :: CabalFlags -> FilePath
pp_fa CabalFlags
fa = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
L.intercalate FilePath
", " [ (if Bool
b then Char
'+' else Char
'-') Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
f
                                    | (FlagName
cabal_f, Bool
b) <- CabalFlags
fa
                                    , let f :: FilePath
f = FlagName -> FilePath
Cabal.unFlagName FlagName
cabal_f
                                    ]

      cfn_to_iuse :: String -> String
      cfn_to_iuse :: FilePath -> FilePath
cfn_to_iuse FilePath
cfn =
          case FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
cfn [(FilePath, FilePath)]
cf_to_iuse_rename of
              Maybe FilePath
Nothing  -> FilePath -> FilePath
Merge.mangle_iuse FilePath
cfn
              Just FilePath
ein -> FilePath
ein

      -- key idea is to generate all possible list of flags
      deps1 :: [(CabalFlags, Merge.EDep)]
      deps1 :: [(CabalFlags, EDep)]
deps1  = [ ( CabalFlags
f CabalFlags -> CabalFlags -> CabalFlags
`updateFa` FlagAssignment -> CabalFlags
Cabal.unFlagAssignment FlagAssignment
fr
                 , RetroPackageDescription -> EDep
cabal_to_emerge_dep RetroPackageDescription
pkgDesc_filtered_bdeps)
               | CabalFlags
f <- [CabalFlags]
all_possible_flag_assignments
               , Right (PackageDescription
pkgDesc1,FlagAssignment
fr) <- [FlagAssignment
-> ComponentRequestedSpec
-> (Dependency -> Bool)
-> Platform
-> CompilerInfo
-> [PackageVersionConstraint]
-> GenericPackageDescription
-> Either [Dependency] (PackageDescription, FlagAssignment)
GHCCore.finalizePD (CabalFlags -> FlagAssignment
Cabal.mkFlagAssignment CabalFlags
f)
                                         ComponentRequestedSpec
GHCCore.defaultComponentRequestedSpec
                                         (InstalledPackageIndex -> Dependency -> Bool
GHCCore.dependencySatisfiable InstalledPackageIndex
pix)
                                         Platform
GHCCore.platform
                                         CompilerInfo
compiler_info
                                         []
                                         GenericPackageDescription
pkgGenericDesc]
               -- drop circular deps and shipped deps
               , let ([Dependency]
ad, [Dependency]
_sd) = [PackageName]
-> PackageName -> [Dependency] -> ([Dependency], [Dependency])
Portage.partition_depends [PackageName]
ghc_packages PackageName
merged_cabal_pkg_name
                                 (PackageDescription -> [Dependency]
Merge.exeAndLibDeps PackageDescription
pkgDesc1)
               -- TODO: drop ghc libraries from tests depends as well
               -- (see deepseq in hackport-0.3.5 as an example)
               , let pkgDesc_filtered_bdeps :: RetroPackageDescription
pkgDesc_filtered_bdeps = PackageDescription -> [Dependency] -> RetroPackageDescription
Merge.RetroPackageDescription PackageDescription
pkgDesc1 [Dependency]
ad
               ] [(CabalFlags, EDep)]
-> Strategy [(CabalFlags, EDep)] -> [(CabalFlags, EDep)]
forall a. a -> Strategy a -> a
`using` Strategy (CabalFlags, EDep) -> Strategy [(CabalFlags, EDep)]
forall a. Strategy a -> Strategy [a]
parList Strategy (CabalFlags, EDep)
forall a. NFData a => Strategy a
rdeepseq
          where
            updateFa :: CabalFlags -> CabalFlags -> CabalFlags
            updateFa :: CabalFlags -> CabalFlags -> CabalFlags
updateFa [] CabalFlags
_ = []
            updateFa ((FlagName, Bool)
x:CabalFlags
xs) CabalFlags
y = case FlagName -> CabalFlags -> Maybe Bool
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ((FlagName, Bool) -> FlagName
forall a b. (a, b) -> a
fst (FlagName, Bool)
x) CabalFlags
y of
                                  -- TODO: when does this code get triggered?
                                  Maybe Bool
Nothing ->          (FlagName, Bool)
x (FlagName, Bool) -> CabalFlags -> CabalFlags
forall a. a -> [a] -> [a]
: CabalFlags -> CabalFlags -> CabalFlags
updateFa CabalFlags
xs CabalFlags
y
                                  Just Bool
y' -> ((FlagName, Bool) -> FlagName
forall a b. (a, b) -> a
fst (FlagName, Bool)
x,Bool
y') (FlagName, Bool) -> CabalFlags -> CabalFlags
forall a. a -> [a] -> [a]
: CabalFlags -> CabalFlags -> CabalFlags
updateFa CabalFlags
xs CabalFlags
y
      -- then remove all flags that can't be changed
      successfully_resolved_flag_assignments :: [CabalFlags]
successfully_resolved_flag_assignments = ((CabalFlags, EDep) -> CabalFlags)
-> [(CabalFlags, EDep)] -> [CabalFlags]
forall a b. (a -> b) -> [a] -> [b]
map (CabalFlags, EDep) -> CabalFlags
forall a b. (a, b) -> a
fst [(CabalFlags, EDep)]
deps1
      common_fa :: CabalFlags
common_fa = (CabalFlags -> CabalFlags -> CabalFlags)
-> [CabalFlags] -> CabalFlags
forall a. (a -> a -> a) -> [a] -> a
L.foldl1' CabalFlags -> CabalFlags -> CabalFlags
forall a. Eq a => [a] -> [a] -> [a]
L.intersect [CabalFlags]
successfully_resolved_flag_assignments
      common_flags :: [FlagName]
common_flags = ((FlagName, Bool) -> FlagName) -> CabalFlags -> [FlagName]
forall a b. (a -> b) -> [a] -> [b]
map (FlagName, Bool) -> FlagName
forall a b. (a, b) -> a
fst CabalFlags
common_fa
      active_flags :: [FlagName]
active_flags = [FlagName]
all_flags [FlagName] -> [FlagName] -> [FlagName]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [FlagName]
common_flags
      active_flag_descs :: [PackageFlag]
active_flag_descs = (PackageFlag -> Bool) -> [PackageFlag] -> [PackageFlag]
forall a. (a -> Bool) -> [a] -> [a]
filter (\PackageFlag
x -> PackageFlag -> FlagName
Cabal.flagName PackageFlag
x FlagName -> [FlagName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FlagName]
active_flags) [PackageFlag]
cabal_flag_descs
      irresolvable_flag_assignments :: [CabalFlags]
irresolvable_flag_assignments = [CabalFlags]
all_possible_flag_assignments [CabalFlags] -> [CabalFlags] -> [CabalFlags]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [CabalFlags]
successfully_resolved_flag_assignments
      -- flags, not guarding any dependency variation, like:
      --     if flag(foo)
      --         ghc-options: -O2
      ([FlagName]
irrelevant_flags, [(CabalFlags, EDep)]
deps1') = (([FlagName], [(CabalFlags, EDep)])
 -> FlagName -> ([FlagName], [(CabalFlags, EDep)]))
-> ([FlagName], [(CabalFlags, EDep)])
-> [FlagName]
-> ([FlagName], [(CabalFlags, EDep)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' ([FlagName], [(CabalFlags, EDep)])
-> FlagName -> ([FlagName], [(CabalFlags, EDep)])
drop_irrelevant ([], [(CabalFlags, EDep)]
deps1) [FlagName]
active_flags
          where drop_irrelevant :: ([Cabal.FlagName], [(CabalFlags, Merge.EDep)]) -> Cabal.FlagName -> ([Cabal.FlagName], [(CabalFlags, Merge.EDep)])
                drop_irrelevant :: ([FlagName], [(CabalFlags, EDep)])
-> FlagName -> ([FlagName], [(CabalFlags, EDep)])
drop_irrelevant ([FlagName]
ifs, [(CabalFlags, EDep)]
ds) FlagName
f =
                    case [(CabalFlags, EDep)]
fenabled_ds' [(CabalFlags, EDep)] -> [(CabalFlags, EDep)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(CabalFlags, EDep)]
fdisabled_ds' of
                        Bool
True  -> (FlagName
fFlagName -> [FlagName] -> [FlagName]
forall a. a -> [a] -> [a]
:[FlagName]
ifs, [(CabalFlags, EDep)]
fenabled_ds')
                        Bool
False -> (  [FlagName]
ifs, [(CabalFlags, EDep)]
ds)
                    where ([(CabalFlags, EDep)]
fenabled_ds', [(CabalFlags, EDep)]
fdisabled_ds') = ( [(CabalFlags, EDep)] -> [(CabalFlags, EDep)]
forall a. Ord a => [a] -> [a]
L.sort ([(CabalFlags, EDep)] -> [(CabalFlags, EDep)])
-> [(CabalFlags, EDep)] -> [(CabalFlags, EDep)]
forall a b. (a -> b) -> a -> b
$ ((CabalFlags, EDep) -> (CabalFlags, EDep))
-> [(CabalFlags, EDep)] -> [(CabalFlags, EDep)]
forall a b. (a -> b) -> [a] -> [b]
map (CabalFlags, EDep) -> (CabalFlags, EDep)
drop_f [(CabalFlags, EDep)]
fenabled_ds
                                                          , [(CabalFlags, EDep)] -> [(CabalFlags, EDep)]
forall a. Ord a => [a] -> [a]
L.sort ([(CabalFlags, EDep)] -> [(CabalFlags, EDep)])
-> [(CabalFlags, EDep)] -> [(CabalFlags, EDep)]
forall a b. (a -> b) -> a -> b
$ ((CabalFlags, EDep) -> (CabalFlags, EDep))
-> [(CabalFlags, EDep)] -> [(CabalFlags, EDep)]
forall a b. (a -> b) -> [a] -> [b]
map (CabalFlags, EDep) -> (CabalFlags, EDep)
drop_f [(CabalFlags, EDep)]
fdisabled_ds
                                                          )
                          drop_f :: (CabalFlags, Merge.EDep) -> (CabalFlags, Merge.EDep)
                          drop_f :: (CabalFlags, EDep) -> (CabalFlags, EDep)
drop_f (CabalFlags
fas, EDep
d) = (((FlagName, Bool) -> Bool) -> CabalFlags -> CabalFlags
forall a. (a -> Bool) -> [a] -> [a]
filter ((FlagName
f FlagName -> FlagName -> Bool
forall a. Eq a => a -> a -> Bool
/=) (FlagName -> Bool)
-> ((FlagName, Bool) -> FlagName) -> (FlagName, Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FlagName, Bool) -> FlagName
forall a b. (a, b) -> a
fst) CabalFlags
fas, EDep
d)
                          ([(CabalFlags, EDep)]
fenabled_ds, [(CabalFlags, EDep)]
fdisabled_ds) = ((CabalFlags, EDep) -> Bool)
-> [(CabalFlags, EDep)]
-> ([(CabalFlags, EDep)], [(CabalFlags, EDep)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (CabalFlags, EDep) -> Bool
is_fe [(CabalFlags, EDep)]
ds
                          is_fe :: (CabalFlags, Merge.EDep) -> Bool
                          is_fe :: (CabalFlags, EDep) -> Bool
is_fe (CabalFlags
fas, EDep
_d) =
                              case FlagName -> CabalFlags -> Maybe Bool
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FlagName
f CabalFlags
fas of
                                  Just Bool
v  -> Bool
v
                                  -- should not happen
                                  Maybe Bool
Nothing -> FilePath -> Bool
forall a. HasCallStack => FilePath -> a
error (FilePath -> Bool) -> FilePath -> Bool
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [ FilePath
"ERROR: drop_irrelevant: searched for missing flag"
                                                             , FlagName -> FilePath
forall a. Show a => a -> FilePath
show FlagName
f
                                                             , FilePath
"in assignment"
                                                             , CabalFlags -> FilePath
forall a. Show a => a -> FilePath
show CabalFlags
fas
                                                             ]

      -- and finally prettify all deps:
      leave_only_dynamic_fa :: CabalFlags -> CabalFlags
      leave_only_dynamic_fa :: CabalFlags -> CabalFlags
leave_only_dynamic_fa CabalFlags
fa = ((FlagName, Bool) -> Bool) -> CabalFlags -> CabalFlags
forall a. (a -> Bool) -> [a] -> [a]
filter (\(FlagName
fn, Bool
_) -> (FlagName -> Bool) -> [FlagName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (FlagName
fn FlagName -> FlagName -> Bool
forall a. Eq a => a -> a -> Bool
/=) [FlagName]
irrelevant_flags) (CabalFlags -> CabalFlags) -> CabalFlags -> CabalFlags
forall a b. (a -> b) -> a -> b
$ CabalFlags
fa CabalFlags -> CabalFlags -> CabalFlags
forall a. Eq a => [a] -> [a] -> [a]
L.\\ CabalFlags
common_fa

      -- build roughly balanced complete dependency tree instead of skewed one
      bimerge :: [Merge.EDep] -> Merge.EDep
      bimerge :: [EDep] -> EDep
bimerge [EDep]
deps = case [EDep] -> [EDep]
forall a. Monoid a => [a] -> [a]
go [EDep]
deps of
                         []  -> EDep
forall a. Monoid a => a
mempty
                         [EDep
r] -> EDep
r
                         [EDep]
_   -> FilePath -> EDep
forall a. HasCallStack => FilePath -> a
error FilePath
"bimerge: something bad happened"
          where go :: [a] -> [a]
go [a]
deps' =
                    case [a]
deps' of
                        (a
d1:a
d2:[a]
ds) -> [a] -> [a]
go (a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
d1 a
d2 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
go [a]
ds)
                        [a]
_          -> [a]
deps'

      tdeps :: Merge.EDep
      tdeps :: EDep
tdeps = [EDep] -> EDep
bimerge ([EDep] -> EDep) -> [EDep] -> EDep
forall a b. (a -> b) -> a -> b
$ ((CabalFlags, EDep) -> EDep) -> [(CabalFlags, EDep)] -> [EDep]
forall a b. (a -> b) -> [a] -> [b]
map (CabalFlags, EDep) -> EDep
set_fa_to_ed [(CabalFlags, EDep)]
deps1'

      set_fa_to_ed :: (CabalFlags, Merge.EDep) -> Merge.EDep
      set_fa_to_ed :: (CabalFlags, EDep) -> EDep
set_fa_to_ed (CabalFlags
fa, EDep
ed) = EDep
ed { rdep :: Dependency
Merge.rdep = CabalFlags -> Dependency -> Dependency
liftFlags (CabalFlags -> CabalFlags
leave_only_dynamic_fa CabalFlags
fa) (Dependency -> Dependency) -> Dependency -> Dependency
forall a b. (a -> b) -> a -> b
$ EDep -> Dependency
Merge.rdep EDep
ed
                                 , dep :: Dependency
Merge.dep  = CabalFlags -> Dependency -> Dependency
liftFlags (CabalFlags -> CabalFlags
leave_only_dynamic_fa CabalFlags
fa) (Dependency -> Dependency) -> Dependency -> Dependency
forall a b. (a -> b) -> a -> b
$ EDep -> Dependency
Merge.dep EDep
ed
                                 }

      liftFlags :: CabalFlags -> Portage.Dependency -> Portage.Dependency
      liftFlags :: CabalFlags -> Dependency -> Dependency
liftFlags CabalFlags
fs Dependency
e = let k :: Dependency -> Dependency
k = ((FlagName, Bool)
 -> (Dependency -> Dependency) -> Dependency -> Dependency)
-> (Dependency -> Dependency)
-> CabalFlags
-> Dependency
-> Dependency
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(FlagName
y,Bool
b) Dependency -> Dependency
x -> (Bool, Use) -> Dependency -> Dependency
Portage.mkUseDependency (Bool
b, FilePath -> Use
Portage.Use (FilePath -> Use) -> (FlagName -> FilePath) -> FlagName -> Use
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
cfn_to_iuse (FilePath -> FilePath)
-> (FlagName -> FilePath) -> FlagName -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagName -> FilePath
Cabal.unFlagName (FlagName -> Use) -> FlagName -> Use
forall a b. (a -> b) -> a -> b
$ FlagName
y) (Dependency -> Dependency)
-> (Dependency -> Dependency) -> Dependency -> Dependency
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependency -> Dependency
x)
                                      Dependency -> Dependency
forall a. a -> a
id CabalFlags
fs
                       in Dependency -> Dependency
k Dependency
e

      cabal_to_emerge_dep :: Merge.RetroPackageDescription -> Merge.EDep
      cabal_to_emerge_dep :: RetroPackageDescription -> EDep
cabal_to_emerge_dep RetroPackageDescription
cabal_pkg = Overlay
-> RetroPackageDescription
-> CompilerInfo
-> [PackageName]
-> PackageName
-> EDep
Merge.resolveDependencies Overlay
overlay RetroPackageDescription
cabal_pkg CompilerInfo
compiler_info [PackageName]
ghc_packages PackageName
merged_cabal_pkg_name

  -- When there are lots of package flags, computation of every possible flag combination
  -- can take a while (e.g., 12 package flags = 2^12 possible flag combinations).
  -- Warn the user about this if there are at least 12 package flags. 'cabal_flag_descs'
  -- is usually an overestimation since it includes flags that hackport will strip out,
  -- but using it instead of 'active_flag_descs' avoids forcing the very computation we
  -- are trying to warn the user about.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PackageFlag] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PackageFlag]
cabal_flag_descs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
12) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"There are up to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
    FilePath -> FilePath
A.bold (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^([PackageFlag] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PackageFlag]
cabal_flag_descs) :: Int)) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
    FilePath
" possible flag combinations.\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
    Color -> Bool -> Color -> FilePath -> FilePath
A.inColor Color
A.Yellow Bool
True Color
A.Default FilePath
"This may take a while."

  Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"buildDepends pkgDesc0 raw: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageDescription -> FilePath
Cabal.showPackageDescription PackageDescription
pkgDesc0
  Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"buildDepends pkgDesc0: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show ((Dependency -> FilePath) -> [Dependency] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Dependency -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageDescription -> [Dependency]
Merge.exeAndLibDeps PackageDescription
pkgDesc0))
  Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"buildDepends pkgDesc:  " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show ((Dependency -> FilePath) -> [Dependency] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Dependency -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (RetroPackageDescription -> [Dependency]
Merge.buildDepends RetroPackageDescription
pkgDesc))

  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Accepted depends: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show ((Dependency -> FilePath) -> [Dependency] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Dependency -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow [Dependency]
accepted_deps)
  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Skipped  depends: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show ((Dependency -> FilePath) -> [Dependency] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Dependency -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow [Dependency]
skipped_deps)
  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Dead flags: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show ((CabalFlags -> FilePath) -> [CabalFlags] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map CabalFlags -> FilePath
pp_fa [CabalFlags]
irresolvable_flag_assignments)
  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Dropped  flags: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show (((FlagName, Bool) -> FilePath) -> CabalFlags -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FlagName -> FilePath
Cabal.unFlagName(FlagName -> FilePath)
-> ((FlagName, Bool) -> FlagName) -> (FlagName, Bool) -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(FlagName, Bool) -> FlagName
forall a b. (a, b) -> a
fst) CabalFlags
common_fa)
  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Active flags: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show ((FlagName -> FilePath) -> [FlagName] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FlagName -> FilePath
Cabal.unFlagName [FlagName]
active_flags)
  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Irrelevant flags: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show ((FlagName -> FilePath) -> [FlagName] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FlagName -> FilePath
Cabal.unFlagName [FlagName]
irrelevant_flags)
  -- mapM_ print tdeps

  [PackageName] -> (PackageName -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [PackageName]
ghc_packages ((PackageName -> IO ()) -> IO ())
-> (PackageName -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
      \PackageName
name -> Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Excluded packages (comes with ghc): " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageName -> FilePath
Cabal.unPackageName PackageName
name

  let pp_fn :: (FlagName, Bool) -> FilePath
pp_fn (FlagName
cabal_fn, Bool
yesno) = Bool -> FilePath
b Bool
yesno FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FlagName -> FilePath
Cabal.unFlagName FlagName
cabal_fn
          where b :: Bool -> FilePath
b Bool
True  = FilePath
""
                b Bool
False = FilePath
"-"

      -- appends 's' to each line except the last one
      --  handy to build multiline shell expressions
      icalate :: [a] -> [[a]] -> [[a]]
icalate [a]
_s []     = []
      icalate [a]
_s [[a]
x]    = [[a]
x]
      icalate  [a]
s ([a]
x:[[a]]
xs) = ([a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
s) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]] -> [[a]]
icalate [a]
s [[a]]
xs

      build_configure_call :: [String] -> [String]
      build_configure_call :: [FilePath] -> [FilePath]
build_configure_call [] = []
      build_configure_call [FilePath]
conf_args = FilePath -> [FilePath] -> [FilePath]
forall a. [a] -> [[a]] -> [[a]]
icalate FilePath
" \\" ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
                                           FilePath
"haskell-cabal_src_configure" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:
                                           (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Char
'\t'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:) [FilePath]
conf_args

      -- returns list USE-parameters to './setup configure'
      selected_flags :: ([Cabal.FlagName], CabalFlags) -> [String]
      selected_flags :: ([FlagName], CabalFlags) -> [FilePath]
selected_flags ([], []) = []
      selected_flags ([FlagName]
active_fns, CabalFlags
users_fas) = ((FilePath, FilePath) -> FilePath)
-> [(FilePath, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> b
snd (((FilePath, FilePath) -> (FilePath, FilePath) -> Ordering)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy (FilePath -> FilePath -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (FilePath -> FilePath -> Ordering)
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> (FilePath, FilePath)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst) [(FilePath, FilePath)]
flag_pairs)
          where flag_pairs :: [(String, String)]
                flag_pairs :: [(FilePath, FilePath)]
flag_pairs = [(FilePath, FilePath)]
active_pairs [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, FilePath)]
users_pairs
                active_pairs :: [(FilePath, FilePath)]
active_pairs = (FilePath -> (FilePath, FilePath))
-> [FilePath] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
fn -> (FilePath
fn,                    FilePath
"$(cabal_flag " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
cfn_to_iuse FilePath
fn FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fn FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")")) ([FilePath] -> [(FilePath, FilePath)])
-> [FilePath] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ (FlagName -> FilePath) -> [FlagName] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FlagName -> FilePath
Cabal.unFlagName [FlagName]
active_fns
                users_pairs :: [(FilePath, FilePath)]
users_pairs  = ((FlagName, Bool) -> (FilePath, FilePath))
-> CabalFlags -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\(FlagName, Bool)
fa -> ((FlagName -> FilePath
Cabal.unFlagName (FlagName -> FilePath)
-> ((FlagName, Bool) -> FlagName) -> (FlagName, Bool) -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FlagName, Bool) -> FlagName
forall a b. (a, b) -> a
fst) (FlagName, Bool)
fa, FilePath
"--flag=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (FlagName, Bool) -> FilePath
pp_fn (FlagName, Bool)
fa)) CabalFlags
users_fas
      to_iuse :: PackageFlag -> FilePath
to_iuse PackageFlag
x = let fn :: FilePath
fn = FlagName -> FilePath
Cabal.unFlagName (FlagName -> FilePath) -> FlagName -> FilePath
forall a b. (a -> b) -> a -> b
$ PackageFlag -> FlagName
Cabal.flagName PackageFlag
x
                      p :: FilePath
p  = if PackageFlag -> Bool
Cabal.flagDefault PackageFlag
x then FilePath
"+" else FilePath
""
                  in FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
cfn_to_iuse FilePath
fn

      ebuild :: EBuild
ebuild =   (\EBuild
e -> EBuild
e { depend :: Dependency
E.depend        =            EDep -> Dependency
Merge.dep EDep
tdeps} )
               (EBuild -> EBuild) -> (EBuild -> EBuild) -> EBuild -> EBuild
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\EBuild
e -> EBuild
e { depend_extra :: [FilePath]
E.depend_extra  = Set FilePath -> [FilePath]
forall a. Set a -> [a]
S.toList (Set FilePath -> [FilePath]) -> Set FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ EDep -> Set FilePath
Merge.dep_e EDep
tdeps } )
               (EBuild -> EBuild) -> (EBuild -> EBuild) -> EBuild -> EBuild
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\EBuild
e -> EBuild
e { rdepend :: Dependency
E.rdepend       =            EDep -> Dependency
Merge.rdep EDep
tdeps} )
               (EBuild -> EBuild) -> (EBuild -> EBuild) -> EBuild -> EBuild
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\EBuild
e -> EBuild
e { rdepend_extra :: [FilePath]
E.rdepend_extra = Set FilePath -> [FilePath]
forall a. Set a -> [a]
S.toList (Set FilePath -> [FilePath]) -> Set FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ EDep -> Set FilePath
Merge.rdep_e EDep
tdeps } )
               (EBuild -> EBuild) -> (EBuild -> EBuild) -> EBuild -> EBuild
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\EBuild
e -> EBuild
e { src_configure :: [FilePath]
E.src_configure = [FilePath] -> [FilePath]
build_configure_call ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
                                                  ([FlagName], CabalFlags) -> [FilePath]
selected_flags ([FlagName]
active_flags, CabalFlags
user_specified_fas) } )
               (EBuild -> EBuild) -> (EBuild -> EBuild) -> EBuild -> EBuild
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\EBuild
e -> EBuild
e { iuse :: [FilePath]
E.iuse = EBuild -> [FilePath]
E.iuse EBuild
e [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (PackageFlag -> FilePath) -> [PackageFlag] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> FilePath
to_iuse [PackageFlag]
active_flag_descs })
               (EBuild -> EBuild) -> (EBuild -> EBuild) -> EBuild -> EBuild
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( case Maybe FilePath
requested_cabal_flags of
                       Maybe FilePath
Nothing  -> EBuild -> EBuild
forall a. a -> a
id
                       Just FilePath
ucf -> (\EBuild
e -> EBuild
e { used_options :: [(FilePath, FilePath)]
E.used_options  = EBuild -> [(FilePath, FilePath)]
E.used_options EBuild
e [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath
"flags", FilePath
ucf)] }))
               (EBuild -> EBuild) -> EBuild -> EBuild
forall a b. (a -> b) -> a -> b
$ Category -> PackageDescription -> EBuild
C2E.cabal2ebuild Category
cat (RetroPackageDescription -> PackageDescription
Merge.packageDescription RetroPackageDescription
pkgDesc)

  let active_flag_descs_renamed :: [PackageFlag]
active_flag_descs_renamed =
        (\PackageFlag
f -> PackageFlag
f { flagName :: FlagName
Cabal.flagName = FilePath -> FlagName
Cabal.mkFlagName (FilePath -> FlagName)
-> (PackageFlag -> FilePath) -> PackageFlag -> FlagName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
cfn_to_iuse (FilePath -> FilePath)
-> (PackageFlag -> FilePath) -> PackageFlag -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagName -> FilePath
Cabal.unFlagName
                   (FlagName -> FilePath)
-> (PackageFlag -> FlagName) -> PackageFlag -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageFlag -> FlagName
Cabal.flagName (PackageFlag -> FlagName) -> PackageFlag -> FlagName
forall a b. (a -> b) -> a -> b
$ PackageFlag
f }) (PackageFlag -> PackageFlag) -> [PackageFlag] -> [PackageFlag]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageFlag]
active_flag_descs
  [PackageFlag]
iuse_flag_descs <- [PackageFlag] -> IO [PackageFlag]
Merge.dropIfUseExpands [PackageFlag]
active_flag_descs_renamed
  Verbosity -> EMeta -> FilePath -> EBuild -> [PackageFlag] -> IO ()
mergeEbuild Verbosity
verbosity EMeta
existing_meta FilePath
pkgdir EBuild
ebuild [PackageFlag]
iuse_flag_descs

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fetch (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let cabal_pkgId :: PackageIdentifier
cabal_pkgId = PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
Cabal.packageId (RetroPackageDescription -> PackageDescription
Merge.packageDescription RetroPackageDescription
pkgDesc)
        norm_pkgName :: PackageName
norm_pkgName = PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
Cabal.packageName (PackageIdentifier -> PackageIdentifier
Portage.normalizeCabalPackageId PackageIdentifier
cabal_pkgId)
    Verbosity -> FilePath -> PackageId -> IO ()
fetchDigestAndCheck Verbosity
verbosity (FilePath
overlayPath FilePath -> FilePath -> FilePath
</> Category -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Category
cat FilePath -> FilePath -> FilePath
</> PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageName
norm_pkgName)
      (PackageId -> IO ()) -> PackageId -> IO ()
forall a b. (a -> b) -> a -> b
$ Category -> PackageIdentifier -> PackageId
Portage.fromCabalPackageId Category
cat PackageIdentifier
cabal_pkgId

-- | Run @ebuild@ and @pkgcheck@ commands in the directory of the
-- newly-generated ebuild.
--
-- This will ensure well-formed ebuilds and @metadata.xml@, and will update (if possible)
-- the @Manifest@ file.
fetchDigestAndCheck :: Verbosity
                    -> FilePath -- ^ directory of ebuild
                    -> Portage.PackageId -- ^ newest ebuild
                    -> IO ()
fetchDigestAndCheck :: Verbosity -> FilePath -> PackageId -> IO ()
fetchDigestAndCheck Verbosity
verbosity FilePath
ebuildDir PackageId
pkgId =
  let ebuild :: FilePath
ebuild = PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageName -> PackageName
Portage.cabalPkgName (PackageName -> PackageName)
-> (PackageId -> PackageName) -> PackageId -> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageId -> PackageName
Portage.packageId (PackageId -> PackageName) -> PackageId -> PackageName
forall a b. (a -> b) -> a -> b
$ PackageId
pkgId)
               FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageId -> Version
Portage.pkgVersion PackageId
pkgId) FilePath -> FilePath -> FilePath
<.> FilePath
"ebuild"
  in FilePath -> IO () -> IO ()
forall a. FilePath -> IO a -> IO a
withWorkingDirectory FilePath
ebuildDir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity FilePath
"Recalculating digests..."
    ExitCode
emEx <- FilePath -> IO ExitCode
system (FilePath -> IO ExitCode) -> FilePath -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ FilePath
"ebuild " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
ebuild FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" manifest > /dev/null 2>&1"
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
emEx ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity FilePath
"ebuild manifest failed horribly. Do something about it!"

    Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Running " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
A.bold FilePath
"pkgcheck scan..."

    (ExitCode
psEx,FilePath
psOut,FilePath
_) <- CreateProcess -> FilePath -> IO (ExitCode, FilePath, FilePath)
readCreateProcessWithExitCode (FilePath -> CreateProcess
shell FilePath
"pkgcheck scan --color True") FilePath
""
    
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
psEx ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ -- this should never be true, even with QA issues.
      Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Color -> Bool -> Color -> FilePath -> FilePath
A.inColor Color
A.Red Bool
True Color
A.Default FilePath
"pkgcheck scan failed."
    Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity FilePath
psOut

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

withWorkingDirectory :: FilePath -> IO a -> IO a
withWorkingDirectory :: FilePath -> IO a -> IO a
withWorkingDirectory FilePath
newDir IO a
action = do
  FilePath
oldDir <- IO FilePath
getCurrentDirectory
  IO () -> (() -> IO ()) -> (() -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    (FilePath -> IO ()
setCurrentDirectory FilePath
newDir)
    (\()
_ -> FilePath -> IO ()
setCurrentDirectory FilePath
oldDir)
    (\()
_ -> IO a
action)

-- | Write the ebuild (and sometimes a new @metadata.xml@) to its directory.
mergeEbuild :: Verbosity -> EM.EMeta -> FilePath -> E.EBuild -> [Cabal.PackageFlag] -> IO ()
mergeEbuild :: Verbosity -> EMeta -> FilePath -> EBuild -> [PackageFlag] -> IO ()
mergeEbuild Verbosity
verbosity EMeta
existing_meta FilePath
pkgdir EBuild
ebuild [PackageFlag]
flags = do
  let edir :: FilePath
edir = FilePath
pkgdir
      elocal :: FilePath
elocal = EBuild -> FilePath
E.name EBuild
ebuild FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"-"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ EBuild -> FilePath
E.version EBuild
ebuild FilePath -> FilePath -> FilePath
<.> FilePath
"ebuild"
      epath :: FilePath
epath = FilePath
edir FilePath -> FilePath -> FilePath
</> FilePath
elocal
      emeta :: FilePath
emeta = FilePath
"metadata.xml"
      mpath :: FilePath
mpath = FilePath
edir FilePath -> FilePath -> FilePath
</> FilePath
emeta
  Bool
yet_meta <- FilePath -> IO Bool
doesFileExist FilePath
mpath
  -- If there is an existing @metadata.xml@, read it in as a 'T.Text'.
  -- Otherwise return 'T.empty'. We only use this once more to directly
  -- compare to @default_meta@ before writing it.
  Text
current_meta <- if Bool
yet_meta
                  then FilePath -> IO Text
T.readFile FilePath
mpath
                  else Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
T.empty
  -- Either create an object of the 'Portage.Metadata' type from a valid @current_meta@,
  -- or supply a default minimal metadata object. Note the difference to @current_meta@:
  -- @current_meta@ is of type 'T.Text', @current_meta'@ is of type 'Portage.Metadata'.
  let current_meta' :: Metadata
current_meta' = Metadata -> Maybe Metadata -> Metadata
forall a. a -> Maybe a -> a
fromMaybe Metadata
Portage.makeMinimalMetadata
                      (Text -> Maybe Metadata
Portage.pureMetadataFromFile Text
current_meta)
      -- Create the @metadata.xml@ string, adding new USE flags (if any) to those of
      -- the existing @metadata.xml@. If an existing flag has a new and old description,
      -- the new one takes precedence.
      default_meta :: Text
default_meta = Map FilePath FilePath -> Text
Portage.makeDefaultMetadata
                     (Map FilePath FilePath -> Text) -> Map FilePath FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [PackageFlag] -> Map FilePath FilePath
Merge.metaFlags [PackageFlag]
flags Map FilePath FilePath
-> Map FilePath FilePath -> Map FilePath FilePath
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union`
                     Metadata -> Map FilePath FilePath
Portage.metadataUseFlags Metadata
current_meta'
      -- Create a 'Map.Map' of USE flags with updated descriptions.
      new_flags :: Map FilePath FilePath
new_flags = (FilePath -> FilePath -> Maybe FilePath)
-> Map FilePath FilePath
-> Map FilePath FilePath
-> Map FilePath FilePath
forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith (\FilePath
new FilePath
old -> if (FilePath
new FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
old)
                                                  then FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
old FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
A.bold (FilePath
" -> " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
new)
                                                  else Maybe FilePath
forall a. Maybe a
Nothing)
                  ([PackageFlag] -> Map FilePath FilePath
Merge.metaFlags [PackageFlag]
flags)
                  (Map FilePath FilePath -> Map FilePath FilePath)
-> Map FilePath FilePath -> Map FilePath FilePath
forall a b. (a -> b) -> a -> b
$ Metadata -> Map FilePath FilePath
Portage.metadataUseFlags Metadata
current_meta'

  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
edir
  UTCTime
now <- IO UTCTime
TC.getCurrentTime

  let (Maybe [FilePath]
existing_keywords, Maybe FilePath
existing_license) = (EMeta -> Maybe [FilePath]
EM.keywords EMeta
existing_meta, EMeta -> Maybe FilePath
EM.license EMeta
existing_meta)
      new_keywords :: [FilePath]
new_keywords = [FilePath]
-> ([FilePath] -> [FilePath]) -> Maybe [FilePath] -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (EBuild -> [FilePath]
E.keywords EBuild
ebuild) ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
Merge.to_unstable) Maybe [FilePath]
existing_keywords
      new_license :: Either FilePath FilePath
new_license  = (FilePath -> Either FilePath FilePath)
-> (FilePath -> Either FilePath FilePath)
-> Either FilePath FilePath
-> Either FilePath FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\FilePath
err -> Either FilePath FilePath
-> (FilePath -> Either FilePath FilePath)
-> Maybe FilePath
-> Either FilePath FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Either FilePath FilePath
forall a b. a -> Either a b
Left FilePath
err)
                                           FilePath -> Either FilePath FilePath
forall a b. b -> Either a b
Right
                                           Maybe FilePath
existing_license)
                            FilePath -> Either FilePath FilePath
forall a b. b -> Either a b
Right
                            (EBuild -> Either FilePath FilePath
E.license EBuild
ebuild)
      ebuild' :: EBuild
ebuild'      = EBuild
ebuild { keywords :: [FilePath]
E.keywords = [FilePath]
new_keywords
                            , license :: Either FilePath FilePath
E.license = Either FilePath FilePath
new_license
                            }
      s_ebuild' :: FilePath
s_ebuild'    = UTCTime -> EBuild -> FilePath
E.showEBuild UTCTime
now EBuild
ebuild'

  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Current keywords: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Maybe [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show Maybe [FilePath]
existing_keywords FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" -> " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
new_keywords
  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Current license:  " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Maybe FilePath -> FilePath
forall a. Show a => a -> FilePath
show Maybe FilePath
existing_license FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" -> " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Either FilePath FilePath -> FilePath
forall a. Show a => a -> FilePath
show Either FilePath FilePath
new_license

  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Writing " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
elocal
  FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
s_ebuild' Int -> IO () -> IO ()
`seq` FilePath -> Text -> IO ()
T.writeFile FilePath
epath (FilePath -> Text
T.pack FilePath
s_ebuild')

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
current_meta Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
default_meta) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
current_meta Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
T.empty) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
A.bold (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"Default and current " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
emeta FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" differ."
      if (Map FilePath FilePath
new_flags Map FilePath FilePath -> Map FilePath FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= Map FilePath FilePath
forall k a. Map k a
Map.empty)
        then Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"New or updated USE flags:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
             ([FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ Map FilePath FilePath -> [FilePath]
Portage.prettyPrintFlagsHuman Map FilePath FilePath
new_flags)
        else Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity FilePath
"No new USE flags."

    Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Writing " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
emeta
    FilePath -> Text -> IO ()
T.writeFile FilePath
mpath Text
default_meta