diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 0.8.1 + +* Redefine core packages [#395](https://github.com/fpco/stackage/issues/395) +* Add --constraint flag for create-plan + ## 0.8.0.1 * GHC 7.10 support diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs --- a/Stackage/BuildConstraints.hs +++ b/Stackage/BuildConstraints.hs @@ -14,6 +14,7 @@ , toBC , BuildConstraintsSource (..) , loadBuildConstraints + , setConstraints ) where import Control.Monad.Writer.Strict (execWriter, tell) @@ -39,6 +40,22 @@ , bcGithubUsers :: Map Text (Set Text) -- ^ map an account to set of pingees } + +-- | Modify the version bounds with the given Dependencies +setConstraints :: [Dependency] -> BuildConstraints -> BuildConstraints +setConstraints deps bc = + bc { bcPackageConstraints = f } + where + depMap = unionsWith intersectVersionRanges $ map toMap deps + toMap (Dependency k v) = asMap $ singletonMap k v + + f' = bcPackageConstraints bc + f pkg = + case lookup pkg depMap of + Nothing -> pc + Just vr -> pc { pcVersionRange = vr } + where + pc = f' pkg -- | The proposed plan from the requirements provided by contributors. -- diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -19,6 +19,7 @@ ) where import System.Directory (getAppUserDataDirectory) +import Distribution.Package (Dependency) import Filesystem (isDirectory, createTree, isFile, rename) import Filesystem.Path (parent) import Control.Concurrent (threadDelay, getNumCapabilities) @@ -232,8 +233,9 @@ createPlan :: Target -> FilePath + -> [Dependency] -- ^ additional constraints -> IO () -createPlan target dest = withManager tlsManagerSettings $ \man -> do +createPlan target dest constraints = withManager tlsManagerSettings $ \man -> do putStrLn $ "Creating plan for: " ++ tshow target bc <- case target of @@ -253,7 +255,7 @@ return $ updateBuildConstraints oldplan _ -> defaultBuildConstraints man - plan <- planFromConstraints bc + plan <- planFromConstraints $ setConstraints constraints bc putStrLn $ "Writing build plan to " ++ fpToText dest encodeFile (fpToString dest) plan diff --git a/Stackage/CorePackages.hs b/Stackage/CorePackages.hs --- a/Stackage/CorePackages.hs +++ b/Stackage/CorePackages.hs @@ -1,43 +1,104 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module Stackage.CorePackages ( getCorePackages , getCoreExecutables , getGhcVersion ) where -import qualified Data.Text as T -import Filesystem (listDirectory) +import Control.Monad.State.Strict (StateT, execStateT, get, modify, + put) +import qualified Data.Map.Lazy as Map +import qualified Data.Text as T +import Filesystem (listDirectory) import Stackage.Prelude -import System.Directory (findExecutable) +import System.Directory (findExecutable) +addDeepDepends :: PackageName -> StateT (Map PackageName Version) IO () +addDeepDepends name@(PackageName name') = do + m <- get + case lookup name m of + Just _ -> return () + Nothing -> do + -- Specifically use a lazy Map insert since we inject bottom as a + -- value. If anyone's curious as the presence of the bottom: we + -- need to insert something to avoid cycles. We could keep a + -- separate Set of already-traversed packages, but this is easier + -- (if a bit hackier). + put $ Map.insert name (error "Version prematurely forced") m + let cp = proc "ghc-pkg" ["--no-user-package-conf", "describe", name'] + version <- withCheckedProcess cp $ \ClosedStream src Inherited -> + src $$ decodeUtf8C =$ linesUnboundedC =$ getZipSink ( + ZipSink (dependsConduit =$ dependsSink) + *> ZipSink versionSink) + modify $ insertMap name version + where + -- This sink finds the first line starting with "version: " and parses the + -- value + versionSink = + loop + where + loop = await >>= maybe (error "version: not found") go + + go t = + case stripPrefix "version: " t of + Nothing -> loop + Just x -> simpleParse x + + -- Finds the beginning of the depends: block and parses the value. Lots of + -- ugly text hacking here to try and be compatible with multiple versions + -- of GHC. + dependsConduit = do + dropWhileC $ not . ("depends:" `isPrefixOf`) + takeWhileC isGood =$= concatMapC sanitize + where + -- GHC 7.8 puts a package on the first line with "depends:", GHC 7.10 + -- does not. We want to take all lines that have a dependency and then + -- stop. This finds them. + isGood t = "depends:" `isPrefixOf` t || " " `isPrefixOf` t + + -- Strip off: leading whitespace, the word buildin_rts for some reason, and + -- the depends:. If we end up with an empty line or a line with just + -- builtin_rts, ignore it. + sanitize t1 + | null t2 = Nothing + | t2 == "builtin_rts" = Nothing + | otherwise = Just t2 + where + t2 = dropPrefixMaybe "builtin_rts " $ dropPrefixMaybe "depends:" t1 + + dropPrefixMaybe x y' = + fromMaybe y $ stripPrefix x y + where + y = dropWhile (== ' ') y' + + -- For each dependency we find: parse it to a package name and then add its + -- dependencies. + dependsSink = mapM_C $ \t -> do + pn <- simpleParse $ getPackageName t + addDeepDepends pn + + -- Strip off the hash and version number + getPackageName = + reverse . dropSeg . dropSeg . reverse . dropWhile (== ' ') + where + dropSeg = drop 1 . dropWhile (/= '-') + -- | Get a @Map@ of all of the core packages. Core packages are defined as -- packages which ship with GHC itself. -- -- Precondition: GHC global package database has only core packages, and GHC -- ships with just a single version of each packages. getCorePackages :: IO (Map PackageName Version) -getCorePackages = - withCheckedProcess cp $ \ClosedStream src Inherited -> - src $$ decodeUtf8C =$ linesUnboundedC =$ foldMapMC parsePackage - where - cp = proc "ghc-pkg" ["--no-user-package-conf", "list"] - parsePackage t - | ":" `isInfixOf` t = return mempty - | Just p <- stripSuffix "-" p' = singletonMap - <$> simpleParse p - <*> simpleParse v - | otherwise = return mempty - where - (p', v) = T.breakOnEnd "-" $ dropParens $ T.strip t - - dropParens s - | length s > 2 && headEx s == '(' && lastEx s == ')' = - initEx $ tailEx s - | otherwise = s +getCorePackages = flip execStateT mempty $ mapM_ (addDeepDepends . PackageName) + [ "ghc" + {- + , "haskell2010" + , "haskell98" + -} + ] -- | A list of executables that are shipped with GHC. getCoreExecutables :: IO (Set ExeName) diff --git a/Stackage/PackageIndex.hs b/Stackage/PackageIndex.hs --- a/Stackage/PackageIndex.hs +++ b/Stackage/PackageIndex.hs @@ -80,7 +80,7 @@ | otherwise = return () goContent fp name version lbs = - case parsePackageDescription $ unpack $ decodeUtf8 lbs of + case parsePackageDescription $ unpack $ dropBOM $ decodeUtf8 lbs of ParseFailed e -> throwM $ CabalParseException (fpFromString fp) e ParseOk _warnings gpd -> do let pd = packageDescription gpd @@ -89,6 +89,9 @@ throwM $ MismatchedNameVersion (fpFromString fp) name name' version version' return gpd + + -- https://github.com/haskell/hackage-server/issues/351 + dropBOM t = fromMaybe t $ stripPrefix "\xFEFF" t parseNameVersion t1 = do let (p', t2) = break (== '/') $ T.replace "\\" "/" t1 diff --git a/app/stackage.hs b/app/stackage.hs --- a/app/stackage.hs +++ b/app/stackage.hs @@ -40,7 +40,11 @@ addCommand "update" "Update the package index" id (pure $ stackageUpdate defaultStackageUpdateSettings) addCommand "create-plan" "Generate a new plan file (possibly based on a previous LTS)" id - (createPlan <$> target <*> planFile) + (createPlan + <$> target + <*> planFile + <*> many constraint + ) addCommand "check" "Verify that a plan is valid" id (checkPlan <$> (fmap Just planFile <|> pure Nothing)) addCommand "fetch" "Fetch all tarballs needed by a plan" id @@ -74,107 +78,6 @@ <*> allowNewer - {- - config = - subparser $ - mconcat - [ cmnd - (uncurry completeBuild) - (fmap (Nightly, ) buildFlags) - "nightly" - "Build, test and upload the Nightly snapshot" - , cmnd - (uncurry completeBuild) - (lts Major) - "lts-major" - "Build, test and upload the LTS (major) snapshot" - , cmnd - (uncurry completeBuild) - (lts Minor) - "lts-minor" - "Build, test and upload the LTS (minor) snapshot" - , cmnd - (const justCheck) - (pure ()) - "check" - "Just check that the build plan is ok" - , cmnd - installBuild - installFlags - "install" - , cmnd - upload - uploadFlags - "upload" - "Upload a pre-existing bundle" - , cmnd - printStats - printStatsFlags - "stats" - "Print statistics on a build plan" - , cmnd - (uncurry diffPlans) - diffPlansFlags - "diff" - "Show the high-level differences between two build plans" - ] - - cmnd exec parse name desc = - command name $ - info - (fmap exec (parse <**> helpOption)) - (progDesc desc) - - buildFlags = - BuildFlags <$> - fmap - not - (switch - (long "skip-tests" ++ - help "Skip build and running the test suites")) <*> - fmap - not - (switch - (long "skip-haddock" ++ - help "Skip generating haddock documentation")) <*> - fmap - not - (switch - (long "skip-upload" <> - help "Skip uploading bundle, docs, etc.")) <*> - switch - (long "enable-library-profiling" <> - help "Enable profiling when building") <*> - switch - (long "skip-check" <> - help "Skip the check phase, and pass --allow-newer to cabal configure") <*> - (fmap fromString (strOption - (long "server-url" <> - metavar "SERVER-URL" <> - showDefault <> value (T.unpack $ unStackageServer def) <> - help "Server to upload bundle to"))) <*> - fmap - not - (switch - (long "skip-hoogle" <> - help "Skip generating Hoogle input files")) <*> - (fmap (Just . fromString) (strOption - (long "bundle-dest" <> metavar "FILENAME")) - <|> pure Nothing) <*> - (fmap not (switch - (long "skip-git-push" <> - help "Do not perform a git push after completion (for LTS builds only)"))) <*> - (fmap (Just . fromString) (strOption - (long "plan-file" <> metavar "FILENAME")) - <|> pure Nothing) <*> - (switch - (long "pre-build" <> - help "Only perform operations up until the actual build")) <*> - (switch - (long "load-plan" <> - help "Load plan from file")) - -} - installFlags :: Parser InstallFlags installFlags = InstallFlags <$> @@ -330,3 +233,15 @@ metavar "SERVER-URL" ++ showDefault ++ value (T.unpack $ unStackageServer def) ++ help "Server to upload bundle to"))) + + constraint = + option constraintRead + (long "constraint" ++ + metavar "CONSTRAINT" ++ + help "New constraints for plan construction") + + constraintRead = do + s <- str + case simpleParse $ T.pack s of + Nothing -> fail $ "Invalid constraint: " ++ s + Just d -> return d diff --git a/stackage-curator.cabal b/stackage-curator.cabal --- a/stackage-curator.cabal +++ b/stackage-curator.cabal @@ -1,5 +1,5 @@ name: stackage-curator -version: 0.8.0.1 +version: 0.8.1 synopsis: Tools for curating Stackage bundles description: Please see for a description and documentation. homepage: https://github.com/fpco/stackage