Skip to content

Rebuild source directories added to the sandbox. #1118

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 8 commits into from
Dec 10, 2012
Merged

Rebuild source directories added to the sandbox. #1118

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
8 commits
Select commit Hold shift + click to select a range
de1c132
Remove some duplication.
23Skidoo Nov 15, 2012
fcc1316
Move 'debugNoWrap' to the Utils module.
23Skidoo Nov 22, 2012
4a5e613
80-col violations.
23Skidoo Dec 9, 2012
5eca8da
Rename 'InstallContext' to 'InstallArgs'.
23Skidoo Dec 9, 2012
b33260d
Make 'adjustPlanOnlyDeps' top-level, rename to 'pruneInstallPlan'.
23Skidoo Dec 9, 2012
7772ce9
Add an alternative interface for 'D.C.Install.install'.
23Skidoo Dec 9, 2012
5417ddd
Rebuild source directories added to sandbox.
23Skidoo Dec 9, 2012
7305ef4
Add TODOs.
23Skidoo Dec 10, 2012
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
10 changes: 9 additions & 1 deletion Cabal/Distribution/Simple/Utils.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -54,7 +54,7 @@ module Distribution.Simple.Utils (
dieWithLocation,
topHandler,
warn, notice, setupMessage, info, debug,
chattyTry,
debugNoWrap, chattyTry,

-- * running programs
rawSystemExit,
Expand Down Expand Up @@ -316,6 +316,14 @@ debug verbosity msg =
putStr (wrapText msg)
hFlush stdout

-- | A variant of 'debug' that doesn't perform the automatic line
-- wrapping. Produces better output in some cases.
debugNoWrap :: Verbosity -> String -> IO ()
debugNoWrap verbosity msg =
when (verbosity >= deafening) $ do
putStrLn msg
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

debug doesn't add an extra newline. Do we really want to add one here?

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

debug itself doesn't, but wrapText does.

hFlush stdout

-- | Perform an IO action, catching any IO exceptions and printing an error
-- if one occurs.
chattyTry :: String -- ^ a description of the action we were attempting
Expand Down
190 changes: 117 additions & 73 deletions cabal-install/Distribution/Client/Install.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,18 @@
-- High level interface to package installation.
-----------------------------------------------------------------------------
module Distribution.Client.Install (
install
-- * High-level interface
install,

-- * Lower-level interface that allows to manipulate the install plan
makeInstallContext,
makeInstallPlan,
processInstallPlan,
InstallArgs,
InstallContext,

-- * Prune certain packages from the install plan
pruneInstallPlan
) where

import Data.List
Expand All @@ -41,7 +52,7 @@ import System.Directory
import System.FilePath
( (</>), (<.>), takeDirectory )
import System.IO
( openFile, IOMode(WriteMode), stdout, hFlush, hClose )
( openFile, IOMode(WriteMode), hClose )
import System.IO.Error
( isDoesNotExistError, ioeGetFileName )

Expand Down Expand Up @@ -112,15 +123,15 @@ import Distribution.PackageDescription.Configuration
import Distribution.Version
( Version, anyVersion, thisVersion )
import Distribution.Simple.Utils as Utils
( notice, info, warn, die, intercalate, withTempDirectory )
( notice, info, warn, debugNoWrap, die, intercalate, withTempDirectory )
import Distribution.Client.Utils
( numberOfProcessors, inDir, mergeBy, MergeResult(..) )
import Distribution.System
( Platform, buildPlatform, OS(Windows), buildOS )
import Distribution.Text
( display )
import Distribution.Verbosity as Verbosity
( Verbosity, showForCabal, normal, verbose, deafening )
( Verbosity, showForCabal, normal, verbose )
import Distribution.Simple.BuildPaths ( exeExtension )

--TODO:
Expand Down Expand Up @@ -155,58 +166,95 @@ install
-> [UserTarget]
-> IO ()
install verbosity packageDBs repos comp conf
globalFlags configFlags configExFlags installFlags haddockFlags userTargets0 = do
globalFlags configFlags configExFlags installFlags haddockFlags
userTargets0 = do

installContext <- makeInstallContext verbosity args userTargets0
installPlan <- foldProgress logMsg die return =<<
makeInstallPlan verbosity args installContext

processInstallPlan verbosity args installContext installPlan
where
args :: InstallArgs
args = (packageDBs, repos, comp, conf,
globalFlags, configFlags, configExFlags, installFlags,
haddockFlags)

logMsg message rest = debugNoWrap verbosity message >> rest

-- TODO: Make InstallContext a proper datatype with documented fields.
-- | Common context for makeInstallPlan and processInstallPlan.
type InstallContext = ( PackageIndex, SourcePackageDb
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

A TODO for the future: we probably want to make InstallContext and InstallArgs into proper data types with documented fields.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Thought about this. Not that hard to change.

, [UserTarget], [PackageSpecifier SourcePackage] )

-- TODO: Make InstallArgs a proper datatype with documented fields or just get
-- rid of it completely.
-- | Initial arguments given to 'install' or 'makeInstallContext'.
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Another future TODO: we should think about if we can turn there types and functions into abstractions instead of just ways to share code. For example: is InstallArgs a useful concept on its own? What does it represent?

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The InstallArgs type synonym is used only for making argument lists a bit shorter. It wouldn't be very hard to remove it.

type InstallArgs = ( PackageDBStack
, [Repo]
, Compiler
, ProgramConfiguration
, GlobalFlags
, ConfigFlags
, ConfigExFlags
, InstallFlags
, HaddockFlags )

-- | Make an install context given install arguments.
makeInstallContext :: Verbosity -> InstallArgs -> [UserTarget]
-> IO InstallContext
makeInstallContext verbosity
(packageDBs, repos, comp, conf,
globalFlags, _, _, _, _) userTargets0 = do

installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos

solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) (compilerId comp)

let -- For install, if no target is given it means we use the
-- current directory as the single target
userTargets | null userTargets0 = [UserTargetLocalDir "."]
| otherwise = userTargets0

pkgSpecifiers <- resolveUserTargets verbosity
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets

(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
userTargets

return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers)

-- | Make an install plan given install context and install arguments.
makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext
-> IO (Progress String String InstallPlan)
makeInstallPlan verbosity
(_, _, comp, _,
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

All these _ patterns suggest that the grouping of these arguments together might not be the best possible one.

I'm really keen on making progress on this issue now to meet our promised end-of-year release date, so I'm inclined to leave any non-essential work as future TODOs, including this.

_, configFlags, configExFlags, installFlags,
_)
(installedPkgIndex, sourcePkgDb,
_, pkgSpecifiers) = do

solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))
(compilerId comp)
notice verbosity "Resolving dependencies..."
installPlan <- foldProgress logMsg die return $
planPackages
comp solver configFlags configExFlags installFlags
installedPkgIndex sourcePkgDb pkgSpecifiers
return $ planPackages comp solver configFlags configExFlags installFlags
installedPkgIndex sourcePkgDb pkgSpecifiers

-- | Given an install plan, perform the actual installations.
processInstallPlan :: Verbosity -> InstallArgs -> InstallContext
-> InstallPlan
-> IO ()
processInstallPlan verbosity
args@(_, _, _, _, _, _, _, installFlags, _)
(installedPkgIndex, sourcePkgDb,
userTargets, pkgSpecifiers) installPlan = do
checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb
installFlags pkgSpecifiers

unless dryRun $ do
installPlan' <- performInstallations verbosity
context installedPkgIndex installPlan
postInstallActions verbosity context userTargets installPlan'

args installedPkgIndex installPlan
postInstallActions verbosity args userTargets installPlan'
where
context :: InstallContext
context = (packageDBs, repos, comp, conf,
globalFlags, configFlags, configExFlags, installFlags, haddockFlags)

dryRun = fromFlag (installDryRun installFlags)
logMsg message rest = debugNoWrap message >> rest
-- Solver debug output really looks better without automatic
-- line wrapping. TODO: This should probably be moved into
-- the utilities module.
debugNoWrap xs = when (verbosity >= deafening) (putStrLn xs >> hFlush stdout)

type InstallContext = ( PackageDBStack
, [Repo]
, Compiler
, ProgramConfiguration
, GlobalFlags
, ConfigFlags
, ConfigExFlags
, InstallFlags
, HaddockFlags )
dryRun = fromFlag (installDryRun installFlags)

-- ------------------------------------------------------------
-- * Installation planning
Expand All @@ -229,7 +277,7 @@ planPackages comp solver configFlags configExFlags installFlags
solver
resolverParams

>>= if onlyDeps then adjustPlanOnlyDeps else return
>>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return

where
resolverParams =
Expand Down Expand Up @@ -280,33 +328,6 @@ planPackages comp solver configFlags configExFlags installFlags
testsEnabled = fromFlagOrDefault False $ configTests configFlags
benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags

--TODO: this is a general feature and should be moved to D.C.Dependency
-- Also, the InstallPlan.remove should return info more precise to the
-- problem, rather than the very general PlanProblem type.
adjustPlanOnlyDeps :: InstallPlan -> Progress String String InstallPlan
adjustPlanOnlyDeps =
either (Fail . explain) Done
. InstallPlan.remove (isTarget pkgSpecifiers)
where
explain :: [InstallPlan.PlanProblem] -> String
explain problems =
"Cannot select only the dependencies (as requested by the "
++ "'--only-dependencies' flag), "
++ (case pkgids of
[pkgid] -> "the package " ++ display pkgid ++ " is "
_ -> "the packages "
++ intercalate ", " (map display pkgids) ++ " are ")
++ "required by a dependency of one of the other targets."
where
pkgids =
nub [ depid
| InstallPlan.PackageMissingDeps _ depids <- problems
, depid <- depids
, packageName depid `elem` targetnames ]

targetnames = map pkgSpecifierTarget pkgSpecifiers


reinstall = fromFlag (installReinstall installFlags)
reorderGoals = fromFlag (installReorderGoals installFlags)
independentGoals = fromFlag (installIndependentGoals installFlags)
Expand All @@ -316,6 +337,34 @@ planPackages comp solver configFlags configExFlags installFlags
upgradeDeps = fromFlag (installUpgradeDeps installFlags)
onlyDeps = fromFlag (installOnlyDeps installFlags)

-- | Remove the provided targets from the install plan.
pruneInstallPlan :: Package pkg => [PackageSpecifier pkg] -> InstallPlan
-> Progress String String InstallPlan
pruneInstallPlan pkgSpecifiers =
-- TODO: this is a general feature and should be moved to D.C.Dependency
-- Also, the InstallPlan.remove should return info more precise to the
-- problem, rather than the very general PlanProblem type.
either (Fail . explain) Done
. InstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)
where
explain :: [InstallPlan.PlanProblem] -> String
explain problems =
"Cannot select only the dependencies (as requested by the "
++ "'--only-dependencies' flag), "
++ (case pkgids of
[pkgid] -> "the package " ++ display pkgid ++ " is "
_ -> "the packages "
++ intercalate ", " (map display pkgids) ++ " are ")
++ "required by a dependency of one of the other targets."
where
pkgids =
nub [ depid
| InstallPlan.PackageMissingDeps _ depids <- problems
, depid <- depids
, packageName depid `elem` targetnames ]

targetnames = map pkgSpecifierTarget pkgSpecifiers

-- ------------------------------------------------------------
-- * Informational messages
-- ------------------------------------------------------------
Expand Down Expand Up @@ -422,11 +471,6 @@ data PackageStatus = NewPackage

type PackageChange = MergeResult PackageIdentifier PackageIdentifier

isTarget :: Package pkg => [PackageSpecifier SourcePackage] -> pkg -> Bool
isTarget pkgSpecifiers pkg = packageName pkg `elem` targetnames
where
targetnames = map pkgSpecifierTarget pkgSpecifiers

extractReinstalls :: PackageStatus -> [InstalledPackageId]
extractReinstalls (Reinstall ipids _) = ipids
extractReinstalls _ = []
Expand Down Expand Up @@ -551,7 +595,7 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
-- * error reporting
--
postInstallActions :: Verbosity
-> InstallContext
-> InstallArgs
-> [UserTarget]
-> InstallPlan
-> IO ()
Expand Down Expand Up @@ -749,7 +793,7 @@ data InstallMisc = InstallMisc {
type UseLogFile = Maybe (PackageIdentifier -> FilePath, Verbosity)

performInstallations :: Verbosity
-> InstallContext
-> InstallArgs
-> PackageIndex
-> InstallPlan
-> IO InstallPlan
Expand Down
Loading