-- |
-- Module      :  Distribution.Client.GenBounds
-- Copyright   :  (c) Doug Beardsley 2015
-- License     :  BSD-like
--
-- Maintainer  :  cabal-devel@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- The cabal gen-bounds command for generating PVP-compliant version bounds.
module Distribution.Client.GenBounds
  ( genBounds
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.Freeze
  ( getFreezePkgs
  )
import Distribution.Client.Setup
  ( FreezeFlags (..)
  , GlobalFlags (..)
  , RepoContext
  )
import Distribution.Client.Utils
  ( hasElem
  , incVersion
  )
import Distribution.Package
  ( Package (..)
  , packageName
  , packageVersion
  , unPackageName
  )
import Distribution.PackageDescription
  ( enabledBuildDepends
  )
import Distribution.PackageDescription.Configuration
  ( finalizePD
  )
import Distribution.Simple.Compiler
import Distribution.Simple.PackageDescription
  ( readGenericPackageDescription
  )
import Distribution.Simple.Program
  ( ProgramDb
  )
import Distribution.Simple.Utils
  ( notice
  , tryFindPackageDesc
  )
import Distribution.System
  ( Platform
  )
import Distribution.Types.ComponentRequestedSpec
  ( defaultComponentRequestedSpec
  )
import Distribution.Types.Dependency
import Distribution.Utils.Path (relativeSymbolicPath)
import Distribution.Version
  ( LowerBound (..)
  , UpperBound (..)
  , Version
  , VersionInterval (..)
  , VersionRange
  , alterVersion
  , asVersionIntervals
  , earlierVersion
  , hasUpperBound
  , intersectVersionRanges
  , orLaterVersion
  )

-- | Given a version, return an API-compatible (according to PVP) version range.
--
-- Example: @0.4.1.2@ produces the version range @>= 0.4.1 && < 0.5@.
--
-- This version is slightly different than the one in
-- 'Distribution.Client.Init'.  This one uses a.b.c as the lower bound because
-- the user could be using a new function introduced in a.b.c which would make
-- ">= a.b" incorrect.
pvpize :: Version -> VersionRange
pvpize :: Version -> VersionRange
pvpize Version
v =
  Version -> VersionRange
orLaterVersion (Int -> Version
vn Int
3)
    VersionRange -> VersionRange -> VersionRange
`intersectVersionRanges` Version -> VersionRange
earlierVersion (Int -> Version -> Version
incVersion Int
1 (Int -> Version
vn Int
2))
  where
    vn :: Int -> Version
vn Int
n = ([Int] -> [Int]) -> Version -> Version
alterVersion (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
n) Version
v

-- | Show the PVP-mandated version range for this package. The @padTo@ parameter
-- specifies the width of the package name column.
showBounds :: Package pkg => Int -> pkg -> String
showBounds :: forall pkg. Package pkg => Int -> pkg -> String
showBounds Int
padTo pkg
p =
  [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    Int -> String -> String
padAfter Int
padTo (PackageName -> String
unPackageName (PackageName -> String) -> PackageName -> String
forall a b. (a -> b) -> a -> b
$ pkg -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName pkg
p)
      String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
      -- TODO: use normaliseVersionRange
      (VersionInterval -> String) -> [VersionInterval] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map VersionInterval -> String
showInterval (VersionRange -> [VersionInterval]
asVersionIntervals (VersionRange -> [VersionInterval])
-> VersionRange -> [VersionInterval]
forall a b. (a -> b) -> a -> b
$ Version -> VersionRange
pvpize (Version -> VersionRange) -> Version -> VersionRange
forall a b. (a -> b) -> a -> b
$ pkg -> Version
forall pkg. Package pkg => pkg -> Version
packageVersion pkg
p)
  where
    padAfter :: Int -> String -> String
    padAfter :: Int -> String -> String
padAfter Int
n String
str = String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) Char
' '

    showInterval :: VersionInterval -> String
    showInterval :: VersionInterval -> String
showInterval (VersionInterval (LowerBound Version
_ Bound
_) UpperBound
NoUpperBound) =
      String -> String
forall a. HasCallStack => String -> a
error String
"Error: expected upper bound...this should never happen!"
    showInterval (VersionInterval (LowerBound Version
l Bound
_) (UpperBound Version
u Bound
_)) =
      [String] -> String
unwords [String
">=", Version -> String
forall a. Pretty a => a -> String
prettyShow Version
l, String
"&& <", Version -> String
forall a. Pretty a => a -> String
prettyShow Version
u]

-- | Entry point for the @gen-bounds@ command.
genBounds
  :: Verbosity
  -> PackageDBStackCWD
  -> RepoContext
  -> Compiler
  -> Platform
  -> ProgramDb
  -> GlobalFlags
  -> FreezeFlags
  -> IO ()
genBounds :: Verbosity
-> PackageDBStackCWD
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FreezeFlags
-> IO ()
genBounds Verbosity
verbosity PackageDBStackCWD
packageDBs RepoContext
repoCtxt Compiler
comp Platform
platform ProgramDb
progdb GlobalFlags
globalFlags FreezeFlags
freezeFlags = do
  let cinfo :: CompilerInfo
cinfo = Compiler -> CompilerInfo
compilerInfo Compiler
comp

  SymbolicPath Pkg 'File
path <- RelativePath Pkg 'File -> SymbolicPath Pkg 'File
forall from (to :: FileOrDir).
RelativePath from to -> SymbolicPath from to
relativeSymbolicPath (RelativePath Pkg 'File -> SymbolicPath Pkg 'File)
-> IO (RelativePath Pkg 'File) -> IO (SymbolicPath Pkg 'File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> IO (RelativePath Pkg 'File)
tryFindPackageDesc Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing
  GenericPackageDescription
gpd <- HasCallStack =>
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO GenericPackageDescription
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File
-> IO GenericPackageDescription
readGenericPackageDescription Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing SymbolicPath Pkg 'File
path
  -- NB: We don't enable tests or benchmarks, since often they
  -- don't really have useful bounds.
  let epd :: Either [Dependency] (PackageDescription, FlagAssignment)
epd =
        FlagAssignment
-> ComponentRequestedSpec
-> (Dependency -> Bool)
-> Platform
-> CompilerInfo
-> [PackageVersionConstraint]
-> GenericPackageDescription
-> Either [Dependency] (PackageDescription, FlagAssignment)
finalizePD
          FlagAssignment
forall a. Monoid a => a
mempty
          ComponentRequestedSpec
defaultComponentRequestedSpec
          (Bool -> Dependency -> Bool
forall a b. a -> b -> a
const Bool
True)
          Platform
platform
          CompilerInfo
cinfo
          []
          GenericPackageDescription
gpd
  case Either [Dependency] (PackageDescription, FlagAssignment)
epd of
    Left [Dependency]
_ -> String -> IO ()
putStrLn String
"finalizePD failed"
    Right (PackageDescription
pd, FlagAssignment
_) -> do
      let needBounds :: [String]
needBounds =
            (Dependency -> String) -> [Dependency] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Dependency -> String
depName ([Dependency] -> [String]) -> [Dependency] -> [String]
forall a b. (a -> b) -> a -> b
$
              (Dependency -> Bool) -> [Dependency] -> [Dependency]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Dependency -> Bool) -> Dependency -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionRange -> Bool
hasUpperBound (VersionRange -> Bool)
-> (Dependency -> VersionRange) -> Dependency -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependency -> VersionRange
depVersion) ([Dependency] -> [Dependency]) -> [Dependency] -> [Dependency]
forall a b. (a -> b) -> a -> b
$
                PackageDescription -> ComponentRequestedSpec -> [Dependency]
enabledBuildDepends PackageDescription
pd ComponentRequestedSpec
defaultComponentRequestedSpec

      [SolverPlanPackage]
pkgs <-
        Verbosity
-> PackageDBStackCWD
-> RepoContext
-> Compiler
-> Platform
-> ProgramDb
-> GlobalFlags
-> FreezeFlags
-> IO [SolverPlanPackage]
getFreezePkgs
          Verbosity
verbosity
          PackageDBStackCWD
packageDBs
          RepoContext
repoCtxt
          Compiler
comp
          Platform
platform
          ProgramDb
progdb
          GlobalFlags
globalFlags
          FreezeFlags
freezeFlags

      let isNeeded :: SolverPlanPackage -> Bool
isNeeded = [String] -> String -> Bool
forall a. Ord a => [a] -> a -> Bool
hasElem [String]
needBounds (String -> Bool)
-> (SolverPlanPackage -> String) -> SolverPlanPackage -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
unPackageName (PackageName -> String)
-> (SolverPlanPackage -> PackageName)
-> SolverPlanPackage
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolverPlanPackage -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName
      let thePkgs :: [SolverPlanPackage]
thePkgs = (SolverPlanPackage -> Bool)
-> [SolverPlanPackage] -> [SolverPlanPackage]
forall a. (a -> Bool) -> [a] -> [a]
filter SolverPlanPackage -> Bool
isNeeded [SolverPlanPackage]
pkgs

      let padTo :: Int
padTo = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (SolverPlanPackage -> Int) -> [SolverPlanPackage] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> (SolverPlanPackage -> String) -> SolverPlanPackage -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
unPackageName (PackageName -> String)
-> (SolverPlanPackage -> PackageName)
-> SolverPlanPackage
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolverPlanPackage -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName) [SolverPlanPackage]
pkgs

      if [SolverPlanPackage] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SolverPlanPackage]
thePkgs
        then
          Verbosity -> String -> IO ()
notice
            Verbosity
verbosity
            String
"Congratulations, all your dependencies have upper bounds!"
        else do
          Verbosity -> String -> IO ()
notice Verbosity
verbosity String
boundsNeededMsg
          (SolverPlanPackage -> IO ()) -> [SolverPlanPackage] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ())
-> (SolverPlanPackage -> String) -> SolverPlanPackage -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
",") (String -> String)
-> (SolverPlanPackage -> String) -> SolverPlanPackage -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SolverPlanPackage -> String
forall pkg. Package pkg => Int -> pkg -> String
showBounds Int
padTo) [SolverPlanPackage]
thePkgs

depName :: Dependency -> String
depName :: Dependency -> String
depName (Dependency PackageName
pn VersionRange
_ NonEmptySet LibraryName
_) = PackageName -> String
unPackageName PackageName
pn

depVersion :: Dependency -> VersionRange
depVersion :: Dependency -> VersionRange
depVersion (Dependency PackageName
_ VersionRange
vr NonEmptySet LibraryName
_) = VersionRange
vr

-- | The message printed when some dependencies are found to be lacking proper
-- PVP-mandated bounds.
boundsNeededMsg :: String
boundsNeededMsg :: String
boundsNeededMsg =
  [String] -> String
unlines
    [ String
""
    , String
"The following packages need bounds and here is a suggested starting point."
    , String
"You can copy and paste this into the build-depends section in your .cabal"
    , String
"file and it should work (with the appropriate removal of commas)."
    , String
""
    , String
"Note that version bounds are a statement that you've successfully built and"
    , String
"tested your package and expect it to work with any of the specified package"
    , String
"versions (PROVIDED that those packages continue to conform with the PVP)."
    , String
"Therefore, the version bounds generated here are the most conservative"
    , String
"based on the versions that you are currently building with.  If you know"
    , String
"your package will work with versions outside the ranges generated here,"
    , String
"feel free to widen them."
    , String
""
    ]