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

Internal helper functions for "Merge".
-}
module Merge.Utils
  ( readPackageString
  , getPreviousPackageId
  , first_just_of
  , drop_prefix
  , squash_debug
  , convert_underscores
  , mangle_iuse
  , to_unstable
  , metaFlags
  , dropIfUseExpands
  -- hspec exports
  , dropIfUseExpand
  ) where

import qualified Control.Applicative as A
import qualified Control.Monad as M
import qualified Data.Char as C
import           Data.Maybe (catMaybes, mapMaybe)
import qualified Data.List as L
import qualified Data.Map.Strict as Map
import qualified System.Directory as SD
import qualified System.FilePath as SF
import           System.FilePath ((</>))
import           System.Process (readCreateProcess, shell)
import           Error
import qualified Portage.PackageId as Portage

import qualified Distribution.Package            as Cabal
import qualified Distribution.PackageDescription as Cabal

-- | Parse a ['String'] as a valid package string. E.g. @category\/name-1.0.0@.
-- Return 'HackPortError' if the string to parse is invalid.
--
-- When the ['String'] is valid:
--
-- >>> readPackageString ["dev-haskell/packagename1-1.0.0"]
-- Right (Just (Category {unCategory = "dev-haskell"}),PackageName "packagename1",Just (Version {versionNumber = [1,0,0], versionChar = Nothing, versionSuffix = [], versionRevision = 0}))
--
-- When the ['String'] is empty:
--
-- >>> readPackageString []
-- Left ...
readPackageString :: [String]
                  -> Either HackPortError ( Maybe Portage.Category
                                          , Cabal.PackageName
                                          , Maybe Portage.Version
                                          )
readPackageString :: [String]
-> Either
     HackPortError (Maybe Category, PackageName, Maybe Version)
readPackageString [String]
args = do
  String
packageString <-
    case [String]
args of
      [] -> HackPortError -> Either HackPortError String
forall a b. a -> Either a b
Left (String -> HackPortError
ArgumentError String
"Need an argument, [category/]package[-version]")
      [String
pkg] -> String -> Either HackPortError String
forall (m :: * -> *) a. Monad m => a -> m a
return String
pkg
      [String]
_ -> HackPortError -> Either HackPortError String
forall a b. a -> Either a b
Left (String -> HackPortError
ArgumentError (String
"Too many arguments: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
args))
  case String
-> Either String (Maybe Category, PackageName, Maybe Version)
Portage.parseFriendlyPackage String
packageString of
    Right v :: (Maybe Category, PackageName, Maybe Version)
v@(Maybe Category
_,PackageName
_,Maybe Version
Nothing) -> (Maybe Category, PackageName, Maybe Version)
-> Either
     HackPortError (Maybe Category, PackageName, Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Category, PackageName, Maybe Version)
v
    -- we only allow versions we can convert into cabal versions
    Right v :: (Maybe Category, PackageName, Maybe Version)
v@(Maybe Category
_,PackageName
_,Just (Portage.Version [Int]
_ Maybe Char
Nothing [] Int
0)) -> (Maybe Category, PackageName, Maybe Version)
-> Either
     HackPortError (Maybe Category, PackageName, Maybe Version)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Category, PackageName, Maybe Version)
v
    Left String
e -> HackPortError
-> Either
     HackPortError (Maybe Category, PackageName, Maybe Version)
forall a b. a -> Either a b
Left (HackPortError
 -> Either
      HackPortError (Maybe Category, PackageName, Maybe Version))
-> HackPortError
-> Either
     HackPortError (Maybe Category, PackageName, Maybe Version)
forall a b. (a -> b) -> a -> b
$ String -> HackPortError
ArgumentError (String -> HackPortError) -> String -> HackPortError
forall a b. (a -> b) -> a -> b
$ String
"Could not parse [category/]package[-version]: "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
packageString String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nParsec error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e
    Either String (Maybe Category, PackageName, Maybe Version)
_ -> HackPortError
-> Either
     HackPortError (Maybe Category, PackageName, Maybe Version)
forall a b. a -> Either a b
Left (HackPortError
 -> Either
      HackPortError (Maybe Category, PackageName, Maybe Version))
-> HackPortError
-> Either
     HackPortError (Maybe Category, PackageName, Maybe Version)
forall a b. (a -> b) -> a -> b
$ String -> HackPortError
ArgumentError (String -> HackPortError) -> String -> HackPortError
forall a b. (a -> b) -> a -> b
$ String
"Could not parse [category/]package[-version]: "
         String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
packageString

-- | Maybe return a 'Portage.PackageId' of the next highest version for a given
--   package, relative to the provided 'Portage.PackageId'.
--
-- For example:
-- 
-- >>> let ebuildDir = ["foo-bar2-3.0.1.ebuild","metadata.xml"]
-- >>> let newPkgId = Portage.PackageId (Portage.PackageName (Portage.Category "dev-haskell") (Cabal.mkPackageName "foo-bar2")) (Portage.Version [3,0,2] Nothing [] 0 )
--
-- >>> getPreviousPackageId ebuildDir newPkgId
-- Just (PackageId {packageId = PackageName {category = Category {unCategory = "dev-haskell"}, cabalPkgName = PackageName "foo-bar2"}, pkgVersion = Version {versionNumber = [3,0,1], versionChar = Nothing, versionSuffix = [], versionRevision = 0}})
getPreviousPackageId :: [FilePath] -- ^ list of ebuilds for given package
                     -> Portage.PackageId -- ^ new PackageId
                     -> Maybe Portage.PackageId -- ^ maybe PackageId of previous version
getPreviousPackageId :: [String] -> PackageId -> Maybe PackageId
getPreviousPackageId [String]
pkgDir PackageId
newPkgId = do
  let pkgIds :: [PackageId]
pkgIds = [PackageId] -> [PackageId]
forall a. [a] -> [a]
reverse 
               ([PackageId] -> [PackageId])
-> ([PackageId] -> [PackageId]) -> [PackageId] -> [PackageId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageId -> Version) -> [PackageId] -> [PackageId]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (PackageId -> Version
Portage.pkgVersion)
               ([PackageId] -> [PackageId])
-> ([PackageId] -> [PackageId]) -> [PackageId] -> [PackageId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageId -> Bool) -> [PackageId] -> [PackageId]
forall a. (a -> Bool) -> [a] -> [a]
filter (PackageId -> PackageId -> Bool
forall a. Ord a => a -> a -> Bool
<PackageId
newPkgId)
               ([PackageId] -> [PackageId]) -> [PackageId] -> [PackageId]
forall a b. (a -> b) -> a -> b
$ (String -> Maybe PackageId) -> [String] -> [PackageId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Category -> String -> Maybe PackageId
Portage.filePathToPackageId (PackageName -> Category
Portage.category (PackageName -> Category)
-> (PackageId -> PackageName) -> PackageId -> Category
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageId -> PackageName
Portage.packageId (PackageId -> Category) -> PackageId -> Category
forall a b. (a -> b) -> a -> b
$ PackageId
newPkgId))
               ([String] -> [PackageId]) -> [String] -> [PackageId]
forall a b. (a -> b) -> a -> b
$ String -> String
SF.dropExtension (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
fp -> String -> String
SF.takeExtension String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".ebuild") [String]
pkgDir
  case [PackageId]
pkgIds of
    PackageId
x:[PackageId]
_ -> PackageId -> Maybe PackageId
forall a. a -> Maybe a
Just PackageId
x
    [PackageId]
_ -> Maybe PackageId
forall a. Maybe a
Nothing

-- | Alias for 'msum'.
-- 
-- prop> \a -> first_just_of a == M.msum a
first_just_of :: [Maybe a] -> Maybe a
first_just_of :: [Maybe a] -> Maybe a
first_just_of = [Maybe a] -> Maybe a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
M.msum

-- | Remove @with@ or @use@ prefixes from flag names.
--
-- >>> drop_prefix "with_conduit"
-- "conduit"
-- >>> drop_prefix "use-https"
-- "https"
-- >>> drop_prefix "no_examples"
-- "no_examples"
drop_prefix :: String -> String
drop_prefix :: String -> String
drop_prefix String
x =
  let prefixes :: [String]
prefixes = [String
"with",String
"use"]
      separators :: [String]
separators = [String
"-",String
"_"]
      combinations :: [String]
combinations = (String -> String -> String) -> [String] -> [String] -> [String]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
A.liftA2 String -> String -> String
forall a. [a] -> [a] -> [a]
(++) [String]
prefixes [String]
separators
  in case [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ((String -> String -> Maybe String)
-> [String] -> [String] -> [Maybe String]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
A.liftA2 String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
L.stripPrefix [String]
combinations [String
x]) of
    [String
z] -> String
z
    [String]
_ -> String
x

-- | Squash debug-related @USE@ flags under the @debug@ global
--   @USE@ flag.
--
-- >>> squash_debug "use-debug-foo"
-- "debug"
-- >>> squash_debug "foo-bar"
-- "foo-bar"
squash_debug :: String -> String
squash_debug :: String -> String
squash_debug String
flag = if String
"debug" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf` (Char -> Char
C.toLower (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
flag)
                         then String
"debug"
                         else String
flag

-- | Gentoo allows underscore ('_') names in @IUSE@ only for
-- @USE_EXPAND@ values. If it's not a user-specified rename mangle
-- it into a hyphen ('-').
-- 
-- >>> convert_underscores "remove_my_underscores"
-- "remove-my-underscores"
convert_underscores :: String -> String
convert_underscores :: String -> String
convert_underscores = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
f
  where f :: Char -> Char
f Char
'_' = Char
'-'
        f Char
c   = Char
c

-- | Perform all @IUSE@ mangling.
--
-- >>> mangle_iuse "use_foo-bar_debug"
-- "debug"
-- >>> mangle_iuse "with-bar_quux"
-- "bar-quux"
mangle_iuse :: String -> String
mangle_iuse :: String -> String
mangle_iuse = String -> String
squash_debug (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
drop_prefix (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
convert_underscores

-- | Convert all stable keywords to testing (unstable) keywords.
-- Preserve arch masks (-).
--
-- >>> to_unstable "amd64"
-- "~amd64"
-- >>> to_unstable "~amd64"
-- "~amd64"
-- >>> to_unstable "-amd64"
-- "-amd64"
to_unstable :: String -> String
to_unstable :: String -> String
to_unstable String
kw =
    case String
kw of
        Char
'~':String
_ -> String
kw
        Char
'-':String
_ -> String
kw
        String
_     -> Char
'~'Char -> String -> String
forall a. a -> [a] -> [a]
:String
kw

-- | Generate a 'Map.Map' of 'Cabal.PackageFlag' names and their descriptions.
--
-- For example, if we construct a singleton list holding a 'Cabal.PackageFlag' with
-- 'Cabal.FlagName' @foo@ and 'Cabal.FlagDescription' @bar@, we should get
-- a 'Map.Map' containing those values:
--
-- >>> let flags = [(Cabal.emptyFlag (Cabal.mkFlagName "foo")) {Cabal.flagDescription = "bar"}]
-- >>> metaFlags flags
-- fromList [("foo","bar")]
metaFlags :: [Cabal.PackageFlag] -> Map.Map String String
metaFlags :: [PackageFlag] -> Map String String
metaFlags [PackageFlag]
flags =
  [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, String)] -> Map String String)
-> [(String, String)] -> Map String String
forall a b. (a -> b) -> a -> b
$
  [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip (String -> String
mangle_iuse (String -> String)
-> (PackageFlag -> String) -> PackageFlag -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagName -> String
Cabal.unFlagName (FlagName -> String)
-> (PackageFlag -> FlagName) -> PackageFlag -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageFlag -> FlagName
Cabal.flagName (PackageFlag -> String) -> [PackageFlag] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageFlag]
flags)
  (PackageFlag -> String
Cabal.flagDescription (PackageFlag -> String) -> [PackageFlag] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageFlag]
flags)

-- | Return a list of @USE_EXPAND@s maintained by ::gentoo.
--
-- First, 'getUseExpands' runs @portageq@ to determine the 'FilePath' of the
-- directory containing valid @USE_EXPAND@s. If the 'FilePath' exists,
-- it drops the filename extensions to return a list of @USE_EXPAND@s
-- as Portage understands them. If the 'FilePath' does not exist, 'getUseExpands'
-- supplies a bare-bones list of @USE_EXPAND@s.
getUseExpands :: IO [String]
getUseExpands :: IO [String]
getUseExpands = do
  String
portDir <- CreateProcess -> String -> IO String
readCreateProcess (String -> CreateProcess
shell String
"portageq get_repo_path / gentoo") String
""
  let use_expands_dir :: String
use_expands_dir = ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhileEnd Char -> Bool
C.isSpace String
portDir) String -> String -> String
</> String
"profiles" String -> String -> String
</> String
"desc"
  Bool
path_exists <- String -> IO Bool
SD.doesPathExist String
use_expands_dir
  if Bool
path_exists
    then do [String]
use_expands_contents <- String -> IO [String]
SD.listDirectory String
use_expands_dir
            [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
SF.dropExtension (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
use_expands_contents)
    -- Provide some sensible defaults if hackport cannot find ::gentoo
    else let use_expands_contents :: [String]
use_expands_contents = [String
"cpu_flags_arm",String
"cpu_flags_ppc",String
"cpu_flags_x86"]
         in [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
use_expands_contents

-- | Return a 'Cabal.PackageFlag' if it is not a @USE_EXPAND@.
--
-- If the 'Cabal.flagName' has a prefix matching any valid @USE_EXPAND@,
-- then return 'Nothing'. Otherwise return 'Just' 'Cabal.PackageFlag'.
dropIfUseExpand :: [String] -> Cabal.PackageFlag -> Maybe Cabal.PackageFlag
dropIfUseExpand :: [String] -> PackageFlag -> Maybe PackageFlag
dropIfUseExpand [String]
use_expands PackageFlag
flag =
  if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ((String -> String -> Bool) -> [String] -> [String] -> [Bool]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
A.liftA2 String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf [String]
use_expands [FlagName -> String
Cabal.unFlagName (FlagName -> String)
-> (PackageFlag -> FlagName) -> PackageFlag -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageFlag -> FlagName
Cabal.flagName (PackageFlag -> String) -> PackageFlag -> String
forall a b. (a -> b) -> a -> b
$ PackageFlag
flag])
  then Maybe PackageFlag
forall a. Maybe a
Nothing else PackageFlag -> Maybe PackageFlag
forall a. a -> Maybe a
Just PackageFlag
flag

-- | Strip @USE_EXPAND@s from a ['Cabal.PackageFlag'].
dropIfUseExpands :: [Cabal.PackageFlag] -> IO [Cabal.PackageFlag]
dropIfUseExpands :: [PackageFlag] -> IO [PackageFlag]
dropIfUseExpands [PackageFlag]
flags = do
  [String]
use_expands <- IO [String]
getUseExpands
  [PackageFlag] -> IO [PackageFlag]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageFlag] -> IO [PackageFlag])
-> [PackageFlag] -> IO [PackageFlag]
forall a b. (a -> b) -> a -> b
$ [Maybe PackageFlag] -> [PackageFlag]
forall a. [Maybe a] -> [a]
catMaybes ([String] -> PackageFlag -> Maybe PackageFlag
dropIfUseExpand [String]
use_expands (PackageFlag -> Maybe PackageFlag)
-> [PackageFlag] -> [Maybe PackageFlag]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageFlag]
flags)