cabal-install/src/Distribution/Client/GenBounds.hs

   1 {-# LANGUAGE CPP #-}
   2
   3 -----------------------------------------------------------------------------
   4
   5 -----------------------------------------------------------------------------
   6
   7 -- |
   8 -- Module      :  Distribution.Client.GenBounds
   9 -- Copyright   :  (c) Doug Beardsley 2015
  10 -- License     :  BSD-like
  11 --
  12 -- Maintainer  :  cabal-devel@gmail.com
  13 -- Stability   :  provisional
  14 -- Portability :  portable
  15 --
  16 -- The cabal gen-bounds command for generating PVP-compliant version bounds.
  17 module Distribution.Client.GenBounds
  18   ( genBounds
  19   ) where
  20
  21 import Distribution.Client.Compat.Prelude
  22 import Prelude ()
  23
  24 import Distribution.Client.Freeze
  25   ( getFreezePkgs
  26   )
  27 import Distribution.Client.Setup
  28   ( FreezeFlags (..)
  29   , GlobalFlags (..)
  30   , RepoContext
  31   )
  32 import Distribution.Client.Utils
  33   ( hasElem
  34   , incVersion
  35   )
  36 import Distribution.Package
  37   ( Package (..)
  38   , packageName
  39   , packageVersion
  40   , unPackageName
  41   )
  42 import Distribution.PackageDescription
  43   ( enabledBuildDepends
  44   )
  45 import Distribution.PackageDescription.Configuration
  46   ( finalizePD
  47   )
  48 import Distribution.Simple.Compiler
  49   ( Compiler
  50   , PackageDBStack
  51   , compilerInfo
  52   )
  53 import Distribution.Simple.PackageDescription
  54   ( readGenericPackageDescription
  55   )
  56 import Distribution.Simple.Program
  57   ( ProgramDb
  58   )
  59 import Distribution.Simple.Utils
  60   ( notice
  61   , tryFindPackageDesc
  62   )
  63 import Distribution.System
  64   ( Platform
  65   )
  66 import Distribution.Types.ComponentRequestedSpec
  67   ( defaultComponentRequestedSpec
  68   )
  69 import Distribution.Types.Dependency
  70 import Distribution.Version
  71   ( LowerBound (..)
  72   , UpperBound (..)
  73   , Version
  74   , VersionInterval (..)
  75   , VersionRange
  76   , alterVersion
  77   , asVersionIntervals
  78   , earlierVersion
  79   , hasUpperBound
  80   , intersectVersionRanges
  81   , orLaterVersion
  82   )
  83 import System.Directory
  84   ( getCurrentDirectory
  85   )
  86
  87 -- | Given a version, return an API-compatible (according to PVP) version range.
  88 --
  89 -- Example: @0.4.1.2@ produces the version range @>= 0.4.1 && < 0.5@.
  90 --
  91 -- This version is slightly different than the one in
  92 -- 'Distribution.Client.Init'.  This one uses a.b.c as the lower bound because
  93 -- the user could be using a new function introduced in a.b.c which would make
  94 -- ">= a.b" incorrect.
  95 pvpize :: Version -> VersionRange
  96 pvpize v =
  97   orLaterVersion (vn 3)
  98     `intersectVersionRanges` earlierVersion (incVersion 1 (vn 2))
  99   where
 100     vn n = alterVersion (take n) v
 101
 102 -- | Show the PVP-mandated version range for this package. The @padTo@ parameter
 103 -- specifies the width of the package name column.
 104 showBounds :: Package pkg => Int -> pkg -> String
 105 showBounds padTo p =
 106   unwords $
 107     padAfter padTo (unPackageName $ packageName p)
 108       :
 109       -- TODO: use normaliseVersionRange
 110       map showInterval (asVersionIntervals $ pvpize $ packageVersion p)
 111   where
 112     padAfter :: Int -> String -> String
 113     padAfter n str = str ++ replicate (n - length str) ' '
 114
 115     showInterval :: VersionInterval -> String
 116     showInterval (VersionInterval (LowerBound _ _) NoUpperBound) =
 117       error "Error: expected upper bound...this should never happen!"
 118     showInterval (VersionInterval (LowerBound l _) (UpperBound u _)) =
 119       unwords [">=", prettyShow l, "&& <", prettyShow u]
 120
 121 -- | Entry point for the @gen-bounds@ command.
 122 genBounds
 123   :: Verbosity
 124   -> PackageDBStack
 125   -> RepoContext
 126   -> Compiler
 127   -> Platform
 128   -> ProgramDb
 129   -> GlobalFlags
 130   -> FreezeFlags
 131   -> IO ()
 132 genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do
 133   let cinfo = compilerInfo comp
 134
 135   cwd <- getCurrentDirectory
 136   path <- tryFindPackageDesc verbosity cwd
 137   gpd <- readGenericPackageDescription verbosity path
 138   -- NB: We don't enable tests or benchmarks, since often they
 139   -- don't really have useful bounds.
 140   let epd =
 141         finalizePD
 142           mempty
 143           defaultComponentRequestedSpec
 144           (const True)
 145           platform
 146           cinfo
 147           []
 148           gpd
 149   case epd of
 150     Left _ -> putStrLn "finalizePD failed"
 151     Right (pd, _) -> do
 152       let needBounds =
 153             map depName $
 154               filter (not . hasUpperBound . depVersion) $
 155                 enabledBuildDepends pd defaultComponentRequestedSpec
 156
 157       pkgs <-
 158         getFreezePkgs
 159           verbosity
 160           packageDBs
 161           repoCtxt
 162           comp
 163           platform
 164           progdb
 165           globalFlags
 166           freezeFlags
 167
 168       let isNeeded = hasElem needBounds . unPackageName . packageName
 169       let thePkgs = filter isNeeded pkgs
 170
 171       let padTo = maximum $ map (length . unPackageName . packageName) pkgs
 172
 173       if null thePkgs
 174         then
 175           notice
 176             verbosity
 177             "Congratulations, all your dependencies have upper bounds!"
 178         else do
 179           notice verbosity boundsNeededMsg
 180           traverse_ (notice verbosity . (++ ",") . showBounds padTo) thePkgs
 181
 182 depName :: Dependency -> String
 183 depName (Dependency pn _ _) = unPackageName pn
 184
 185 depVersion :: Dependency -> VersionRange
 186 depVersion (Dependency _ vr _) = vr
 187
 188 -- | The message printed when some dependencies are found to be lacking proper
 189 -- PVP-mandated bounds.
 190 boundsNeededMsg :: String
 191 boundsNeededMsg =
 192   unlines
 193     [ ""
 194     , "The following packages need bounds and here is a suggested starting point."
 195     , "You can copy and paste this into the build-depends section in your .cabal"
 196     , "file and it should work (with the appropriate removal of commas)."
 197     , ""
 198     , "Note that version bounds are a statement that you've successfully built and"
 199     , "tested your package and expect it to work with any of the specified package"
 200     , "versions (PROVIDED that those packages continue to conform with the PVP)."
 201     , "Therefore, the version bounds generated here are the most conservative"
 202     , "based on the versions that you are currently building with.  If you know"
 203     , "your package will work with versions outside the ranges generated here,"
 204     , "feel free to widen them."
 205     , ""
 206     ]