[Updated patch for world-file support
Peter Robinson <thaldyron(a)gmail.com>**20090929200551
Ignore-this: 2362afdac5b775f3bc018883da9afd53
This is a new patch for Ticket #199; it adds the "--one-shot" option.
A world file entry contains the package-name, package-version, and
user flags (if any).
For example, the file entry generated by
# cabal install stm-io-hooks --flags="-debug"
looks like this:
# stm-io-hooks -any --flags="-debug"
To rebuild/upgrade the packages in world (e.g. when updating the compiler)
use
# cabal install world
Installing package 'foo' without adding it to the world file:
# cabal install foo --one-shot
] {
hunk ./Distribution/Client/Config.hs 161
+ worldFile <- defaultWorldFile
hunk ./Distribution/Client/Config.hs 170
+ },
+ savedGlobalFlags = mempty {
+ globalWorldFile = toFlag worldFile
hunk ./Distribution/Client/Config.hs 186
+ worldFile <- defaultWorldFile
hunk ./Distribution/Client/Config.hs 190
- globalRemoteRepos = [defaultRemoteRepo]
+ globalRemoteRepos = [defaultRemoteRepo],
+ globalWorldFile = toFlag worldFile
hunk ./Distribution/Client/Config.hs 217
+-- | Default position of the world file
+defaultWorldFile :: IO FilePath
+defaultWorldFile = do
+ dir <- defaultCabalDir
+ return $ dir </> "world"
+
hunk ./Distribution/Client/Setup.hs 90
- globalLocalRepos :: [FilePath]
+ globalLocalRepos :: [FilePath],
+ globalWorldFile :: Flag FilePath
hunk ./Distribution/Client/Setup.hs 101
- globalLocalRepos = mempty
+ globalLocalRepos = mempty,
+ globalWorldFile = mempty
hunk ./Distribution/Client/Setup.hs 152
+
+ ,option [] ["world-file"]
+ "The location of the world file"
+ globalWorldFile (\v flags -> flags { globalWorldFile = v })
+ (reqArgFlag "FILE")
hunk ./Distribution/Client/Setup.hs 167
- globalLocalRepos = mempty
+ globalLocalRepos = mempty,
+ globalWorldFile = mempty
hunk ./Distribution/Client/Setup.hs 176
- globalLocalRepos = combine globalLocalRepos
+ globalLocalRepos = combine globalLocalRepos,
+ globalWorldFile = combine globalWorldFile
hunk ./Distribution/Client/Setup.hs 468
- installSymlinkBinDir:: Flag FilePath
+ installSymlinkBinDir:: Flag FilePath,
+ installOneShot :: Flag Bool
hunk ./Distribution/Client/Setup.hs 483
- installSymlinkBinDir= mempty
+ installSymlinkBinDir= mempty,
+ installOneShot = Flag False
hunk ./Distribution/Client/Setup.hs 571
+ , option [] ["one-shot"]
+ "Do not record the packages in the world file."
+ installOneShot (\v flags -> flags { installOneShot = v })
+ trueArg
hunk ./Distribution/Client/Setup.hs 595
- installSymlinkBinDir= mempty
+ installSymlinkBinDir= mempty,
+ installOneShot = mempty
hunk ./Distribution/Client/Setup.hs 608
- installSymlinkBinDir= combine installSymlinkBinDir
+ installSymlinkBinDir= combine installSymlinkBinDir,
+ installOneShot = combine installOneShot
hunk ./Distribution/Client/Types.hs 19
- ( GenericPackageDescription, FlagAssignment )
+ ( GenericPackageDescription, FlagAssignment, FlagName(FlagName) )
hunk ./Distribution/Client/Types.hs 24
+import Distribution.Text
+ ( Text(disp,parse) )
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Text.PrettyPrint as Disp
+ $
hunk ./Distribution/Client/Types.hs 30
+import Data.Char as Char
hunk ./Distribution/Client/Types.hs 117
- deriving (Show)
+ deriving (Show,Eq)
+
+
+instance Text UnresolvedDependency where
+ disp udep = disp (dependency udep) Disp.<+> dispFlags (depFlags udep)
+ where $
+ dispFlags [] = Disp.empty
+ dispFlags fs = Disp.text "--flags=" $
+ Disp.<> $
+ (Disp.doubleQuotes $ flagAssToDoc fs)
+ flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc -> $
+ (if not val then Disp.char '-' $
+ else Disp.empty)
+ Disp.<> Disp.text fname $
+ Disp.<+> flagAssDoc)
+ Disp.empty $
+ parse = do
+ dep <- parse $
+ Parse.skipSpaces
+ flagAss <- Parse.option [] parseFlagAssignment
+ return $ UnresolvedDependency dep flagAss $
+ where
+ parseFlagAssignment :: Parse.ReadP r FlagAssignment
+ parseFlagAssignment = do $
+ Parse.string "--flags"
+ Parse.skipSpaces
+ Parse.char '='
+ Parse.skipSpaces
+ inDoubleQuotes $ Parse.many1 flag
+ where
+ inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a
+ inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"') $
+
+ flag = do
+ Parse.skipSpaces
+ val <- negative Parse.+++ positive
+ name <- ident
+ Parse.skipSpaces
+ return (FlagName name,val)
+ negative = do
+ Parse.char '-'
+ return False
+ positive = return True
+
+ ident :: Parse.ReadP r String
+ ident = do $
+ -- First character must be a letter/digit to avoid flags
+ -- like "+-debug":
+ c <- Parse.satisfy Char.isAlphaNum
+ cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_' $
+ || ch == '-')
+ return (c:cs)
+ $
+
addfile ./Distribution/Client/World.hs
hunk ./Distribution/Client/World.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.World
+-- Copyright : (c) Peter Robinson 2009
+-- License : BSD-like
+--
+-- Maintainer : thaldyron(a)gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Interface to the world-file that contains a list of explicitly $
+-- requested packages. Meant to be imported qualified.
+--
+-- A world file entry stores the package-name, package-version, and $
+-- user flags.
+-- For example, the entry generated by $
+-- # cabal install stm-io-hooks --flags="-debug" $
+-- looks like this:
+-- # stm-io-hooks -any --flags="-debug"
+-- To rebuild/upgrade the packages in world (e.g. when updating the compiler) $
+-- use
+-- # cabal install world
+-- $
+-----------------------------------------------------------------------------
+module Distribution.Client.World( insert, $
+ delete,
+ getContents,
+ worldPkg,
+ )
+where
+import Distribution.Client.Utils( writeFileAtomic ) $
+import Distribution.Client.Types $
+ ( UnresolvedDependency(dependency) )
+import Distribution.Package $
+ ( PackageName(..), Dependency( Dependency ) )
+import Distribution.Version( anyVersion )
+import Distribution.Text( display, simpleParse )
+import Distribution.Verbosity ( Verbosity )
+import Distribution.Simple.Utils ( die, notice, chattyTry )
+import Data.List( unionBy, deleteFirstsBy, nubBy, all )
+import Data.Maybe( isJust, fromJust )
+import Control.Monad( unless )
+import System.IO.Error( isDoesNotExistError, )
+import qualified Data.ByteString.Lazy.Char8 as B
+import Prelude hiding ( getContents )
+
+
+-- | Adds packages to the world file; creates the file if it doesn't $
+-- exist yet. Flag assignments for a package are updated if already $
+-- present. IO errors are non-fatal.
+insert :: Verbosity -> Bool -> FilePath -> [UnresolvedDependency] -> IO ()
+insert = modifyWorld $ unionBy equalUDep
+
+-- | Removes packages from the world file. $
+-- Note: Currently unused as there is no mechanism in Cabal (yet) to $
+-- handle uninstalls. IO errors are non-fatal.
+delete :: Verbosity -> Bool -> FilePath -> [UnresolvedDependency] -> IO ()
+delete = modifyWorld $ flip (deleteFirstsBy equalUDep)
+
+-- | UnresolvedDependency values are considered equal if their dependency
+-- is equal, i.e., we don't care about differing flags.
+equalUDep :: UnresolvedDependency -> UnresolvedDependency -> Bool
+equalUDep u1 u2 = dependency u1 == dependency u2
+
+-- | Modifies the world file by applying an update-function ('unionBy'
+-- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of $
+-- packages. IO errors are considered non-fatal.
+modifyWorld :: ([UnresolvedDependency] -> [UnresolvedDependency] $
+ -> [UnresolvedDependency]) $
+ -- ^ Function that defines how $
+ -- the list of user packages are merged with
+ -- existing world packages. $
+ -> Verbosity $
+ -> Bool -- ^ Dry-run?
+ -> FilePath -- ^ Location of the world file
+ -> [UnresolvedDependency] -- ^ list of user supplied packages
+ -> IO () $
+modifyWorld _ _ _ _ [] = return ()
+modifyWorld f verbosity dryRun world pkgs = $
+ chattyTry "Error while updating world-file. " $ do
+ pkgsOldWorld <- getContents world
+ -- Filter out packages that are not in the world file:
+ let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld
+ -- 'Dependency' is not an Ord instance, so we need to check for $
+ -- equivalence the awkward way:
+ if not (all (`elem` pkgsOldWorld) pkgsNewWorld &&
+ all (`elem` pkgsNewWorld) pkgsOldWorld) $
+ then $
+ unless dryRun $ do
+ writeFileAtomic world $ B.unlines $
+ [B.pack (display pkg) | pkg <- pkgsNewWorld]
+ notice verbosity "Updating world-file..." $
+ else
+ notice verbosity "World-file already up to date."
+
+
+-- | Returns the content of the world file as a list
+getContents :: FilePath -> IO [UnresolvedDependency]
+getContents world = do
+ content <- safelyReadFile world
+ let result = map simpleParse (lines . B.unpack $ content)
+ if all isJust result
+ then return $ map fromJust result
+ else die "Could not parse world file."
+ where $
+ safelyReadFile :: FilePath -> IO B.ByteString
+ safelyReadFile file = B.readFile file `catch` handler $
+ where
+ handler e | isDoesNotExistError e = return B.empty
+ | otherwise = ioError e $
+
+
+-- | A dummy package that represents the world file. $
+worldPkg :: Dependency
+worldPkg = Dependency (PackageName "world") anyVersion
+
+
hunk ./Main.hs 58
+import qualified Distribution.Client.World as World
hunk ./Main.hs 203
+ pkgsFlagAss = configConfigurationsFlags configFlags'
+ pkgsNoWorld = filter (/=World.worldPkg) pkgs $
+ -- User-specified packages except 'world':
+ uDepsNoWorld = [ UnresolvedDependency pkg pkgsFlagAss
+ | pkg <- pkgsNoWorld ]
+ worldFile = fromFlag $ globalWorldFile globalFlags'
+ dryRun = fromFlagOrDefault False (installDryRun installFlags')
+ oneShot = fromFlagOrDefault False (installOneShot installFlags')
+
+ -- Read packages from the world file if requested:
+ uDepsFromWorld <- if pkgsNoWorld /= pkgs && not oneShot
+ then do $
+ unless (null pkgsFlagAss) $ $
+ die "Package world does not take any flags."
+ World.getContents worldFile
+ else return []
hunk ./Main.hs 223
- [ UnresolvedDependency pkg (configConfigurationsFlags configFlags')
- | pkg <- pkgs ]
+ (uDepsFromWorld ++ uDepsNoWorld)
+ unless oneShot $ World.insert verbosity dryRun worldFile uDepsNoWorld $
hunk ./cabal-install.cabal 73
+ Distribution.Client.World
}
