diff --git a/Stackage/Build.hs b/Stackage/Build.hs deleted file mode 100644 index 6742b100..00000000 --- a/Stackage/Build.hs +++ /dev/null @@ -1,116 +0,0 @@ -module Stackage.Build - ( build - , defaultBuildSettings - , BuildSettings (..) - ) where - -import Control.Monad (unless) -import Prelude hiding (pi) -import Stackage.CheckCabalVersion (checkCabalVersion) -import Stackage.Config -import Stackage.InstallInfo -import Stackage.ModuleNameConflict -import Stackage.Types -import Stackage.Util -import System.Exit (ExitCode (ExitSuccess), exitWith) -import System.IO (BufferMode (NoBuffering), - IOMode (WriteMode), hPutStrLn, - hSetBuffering, withBinaryFile) -import qualified System.IO.UTF8 -import System.Process (rawSystem, runProcess, - waitForProcess) -import qualified Data.ByteString.Lazy.Char8 as L8 - -defaultBuildSettings :: Maybe Int -- ^ argument to -j - -> GhcMajorVersion - -> BuildSettings -defaultBuildSettings cores version = BuildSettings - { sandboxRoot = "sandbox" - , extraArgs = \bs -> "-fnetwork23" : "-fhttps" : - case bs of - BSTest -> [] - _ -> - case cores of - Nothing -> ["-j"] - Just 1 -> [] - Just j -> ["-j" ++ show j] - , testWorkerThreads = 4 - , buildDocs = True - , tarballDir = "patching/tarballs" - , cabalFileDir = Nothing - , underlayPackageDirs = [] - } - -build :: BuildSettings -> BuildPlan -> IO () -build settings' bp = do - libVersion <- checkCabalVersion - - putStrLn "Wiping out old sandbox folder" - rm_r $ sandboxRoot settings' - rm_r "logs" - settings <- fixBuildSettings settings' - - putStrLn "Creating new package database" - ec1 <- rawSystem "ghc-pkg" ["init", packageDir settings] - unless (ec1 == ExitSuccess) $ do - putStrLn "Unable to create package database via ghc-pkg init" - exitWith ec1 - - menv <- fmap Just $ getModifiedEnv settings - let runCabal args handle = runProcess "cabal" args Nothing menv Nothing (Just handle) (Just handle) - - -- First install build tools so they can be used below. - let installBuildTool tool = do - let toolsDir = packageDir settings ++ "-tools" - rm_r toolsDir - ecInit <- rawSystem "ghc-pkg" ["init", toolsDir] - unless (ecInit == ExitSuccess) $ do - putStrLn "Unable to create package database via ghc-pkg init" - exitWith ecInit - - putStrLn $ "Installing build tool: " ++ tool - ec <- withBinaryFile "build-tools.log" WriteMode $ \handle -> do - hSetBuffering handle NoBuffering - - let args = addCabalArgs settings BSTools - $ "install" - : ("--cabal-lib-version=" ++ libVersion) - : "--build-log=logs-tools/$pkg.log" - : [tool] - hPutStrLn handle ("cabal " ++ unwords (map (\s -> "'" ++ s ++ "'") args)) - ph <- runCabal args handle - waitForProcess ph - unless (ec == ExitSuccess) $ do - putStrLn $ concat - [ "Building of " - , tool - , " failed, please see build-tools.log" - ] - exitWith ec - putStrLn $ tool ++ " built" - rm_r toolsDir - mapM_ installBuildTool $ bpTools bp - - putStrLn "Beginning Stackage build" - ph <- withBinaryFile "build.log" WriteMode $ \handle -> do - packageList <- mapM (replaceTarball $ tarballDir settings) $ bpPackageList bp - let args = addCabalArgs settings BSBuild - $ "install" - : ("--cabal-lib-version=" ++ libVersion) - : "--build-log=logs/$pkg.log" - : "--max-backjumps=-1" - : "--reorder-goals" - : "--build-summary=build-summary/$pkgid.report" - : packageList - hPutStrLn handle ("cabal " ++ unwords (map (\s -> "'" ++ s ++ "'") args)) - runCabal args handle - ec <- waitForProcess ph - unless (ec == ExitSuccess) $ do - putStrLn "Build failed, please see build.log" - L8.readFile "build.log" >>= L8.putStr - exitWith ec - - putStrLn "Build completed successfully, checking for module name conflicts" - conflicts <- getModuleNameConflicts $ packageDir settings - System.IO.UTF8.writeFile "module-name-conflicts.txt" - $ renderModuleNameConflicts conflicts diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs deleted file mode 100644 index c32c2865..00000000 --- a/Stackage/BuildPlan.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeSynonymInstances #-} -module Stackage.BuildPlan - ( readBuildPlan - , writeBuildPlan - , writeBuildPlanCsv - ) where - -import qualified Data.Map as Map -import qualified Data.Set as Set -import Distribution.Text (display, simpleParse) -import Stackage.Types -import qualified System.IO.UTF8 -import Data.Char (isSpace) -import Stackage.Util -import Data.List (intercalate) - -readBuildPlan :: FilePath -> IO BuildPlan -readBuildPlan fp = do - str <- System.IO.UTF8.readFile fp - case fromString str of - Left s -> error $ "Could not read build plan: " ++ s - Right (x, "") -> return x - Right (_, _:_) -> error "Trailing content when reading build plan" - -writeBuildPlan :: FilePath -> BuildPlan -> IO () -writeBuildPlan fp bp = System.IO.UTF8.writeFile fp $ toString bp - -class AsString a where - toString :: a -> String - fromString :: String -> Either String (a, String) - -instance AsString BuildPlan where - toString BuildPlan {..} = concat - [ makeSection "tools" bpTools - , makeSection "packages" $ Map.toList bpPackages - , makeSection "core" $ Map.toList bpCore - , makeSection "optional-core" $ Map.toList bpOptionalCore - , makeSection "skipped-tests" $ Set.toList bpSkippedTests - , makeSection "expected-failures" $ Set.toList bpExpectedFailures - ] - fromString s1 = do - (tools, s2) <- getSection "tools" s1 - (packages, s3) <- getSection "packages" s2 - (core, s4) <- getSection "core" s3 - (optionalCore, s5) <- getSection "optional-core" s4 - (skipped, s6) <- getSection "skipped-tests" s5 - (failures, s7) <- getSection "expected-failures" s6 - let bp = BuildPlan - { bpTools = tools - , bpPackages = Map.fromList packages - , bpCore = Map.fromList core - , bpOptionalCore = Map.fromList optionalCore - , bpSkippedTests = Set.fromList skipped - , bpExpectedFailures = Set.fromList failures - } - return (bp, s7) - -makeSection :: AsString a => String -> [a] -> String -makeSection title contents = unlines - $ ("-- BEGIN " ++ title) - : map toString contents - ++ ["-- END " ++ title, ""] - -instance AsString String where - toString = id - fromString s = Right (s, "") - -instance AsString PackageName where - toString (PackageName pn) = pn - fromString s = Right (PackageName s, "") - -instance AsString (Maybe Version) where - toString Nothing = "" - toString (Just x) = toString x - fromString s - | all isSpace s = return (Nothing, s) - | otherwise = do - (v, s') <- fromString s - return (Just v, s') - -instance AsString a => AsString (PackageName, a) where - toString (PackageName pn, s) = concat [pn, " ", toString s] - fromString s = do - (pn, rest) <- takeWord s - (rest', s') <- fromString rest - return ((PackageName pn, rest'), s') - -takeWord :: AsString a => String -> Either String (a, String) -takeWord s = - case break (== ' ') s of - (x, _:y) -> do - (x', s') <- fromString x - if null s' - then Right (x', y) - else Left $ "Unconsumed input in takeWord call" - (_, []) -> Left "takeWord failed" - -instance AsString SelectedPackageInfo where - toString SelectedPackageInfo {..} = unwords - [ display spiVersion - , toString spiHasTests - , (\v -> if null v then "@" else v) $ githubMentions spiGithubUser - , unMaintainer spiMaintainer - ] - fromString s1 = do - (version, s2) <- takeWord s1 - (hasTests, s3) <- takeWord s2 - (gu, m) <- takeWord s3 - Right (SelectedPackageInfo - { spiVersion = version - , spiHasTests = hasTests - , spiGithubUser = [gu] - , spiMaintainer = Maintainer m - }, "") - -instance AsString (Maybe String) where - toString Nothing = "@" - toString (Just x) = "@" ++ x - fromString "@" = Right (Nothing, "") - fromString ('@':rest) = Right (Just rest, "") - fromString x = Left $ "Invalid Github user: " ++ x - -instance AsString Bool where - toString True = "test" - toString False = "notest" - fromString "test" = Right (True, "") - fromString "notest" = Right (False, "") - fromString x = Left $ "Invalid test value: " ++ x - -instance AsString Version where - toString = display - fromString s = - case simpleParse s of - Nothing -> Left $ "Invalid version: " ++ s - Just v -> Right (v, "") - -getSection :: AsString a => String -> String -> Either String ([a], String) -getSection title orig = - case lines orig of - [] -> Left "Unexpected EOF when looking for a section" - l1:ls1 - | l1 == begin -> - case break (== end) ls1 of - (here, _:"":rest) -> do - here' <- mapM fromString' here - Right (here', unlines rest) - (_, _) -> Left $ "Could not find section end: " ++ title - | otherwise -> Left $ "Could not find section start: " ++ title - where - begin = "-- BEGIN " ++ title - end = "-- END " ++ title - - fromString' x = do - (y, z) <- fromString x - if null z - then return y - else Left $ "Unconsumed input on line: " ++ x - --- | Used for Hackage distribution purposes. -writeBuildPlanCsv :: FilePath -> BuildPlan -> IO () -writeBuildPlanCsv fp bp = - -- Obviously a proper CSV library should be used... but we're minimizing - -- deps - System.IO.UTF8.writeFile fp $ unlines' $ map toRow $ Map.toList fullMap - where - -- Hackage server is buggy, and won't accept trailing newlines. See: - -- https://github.com/haskell/hackage-server/issues/141#issuecomment-34615935 - unlines' = intercalate "\n" - - fullMap = Map.unions - [ fmap spiVersion $ bpPackages bp - , Map.mapMaybe id $ bpCore bp - , bpOptionalCore bp - ] - - toRow (PackageName name, version) = concat - [ "\"" - , name - , "\",\"" - , display version - , "\",\"http://www.stackage.org/package/" - , name - , "\"" - ] diff --git a/Stackage/CheckCabalVersion.hs b/Stackage/CheckCabalVersion.hs deleted file mode 100644 index 2713aab2..00000000 --- a/Stackage/CheckCabalVersion.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Stackage.CheckCabalVersion - ( checkCabalVersion - ) where - -import Control.Exception (assert) -import Distribution.Text (simpleParse) -import Distribution.Version (withinRange) -import Prelude hiding (pi) -import System.Process (readProcess) - -checkCabalVersion :: IO String -checkCabalVersion = do - putStrLn "Checking Cabal version" - versionString <- readProcess "cabal" ["--version"] "" - libVersion <- - case map words $ lines versionString of - [_,["using","version",libVersion,"of","the","Cabal","library"]] -> return libVersion - _ -> error "Did not understand cabal --version output" - - case (simpleParse libVersion, simpleParse ">= 1.16") of - (Nothing, _) -> error $ "cabal binary reported an invalid Cabal library version: " ++ libVersion - (_, Nothing) -> assert False $ return () - (Just v, Just vr) - | v `withinRange` vr -> return () - | otherwise -> error $ "cabal binary build against unsupported Cabal library version: " ++ libVersion - - return libVersion diff --git a/Stackage/CheckPlan.hs b/Stackage/CheckPlan.hs deleted file mode 100644 index d0c72842..00000000 --- a/Stackage/CheckPlan.hs +++ /dev/null @@ -1,73 +0,0 @@ -module Stackage.CheckPlan - ( checkPlan - ) where - -import Control.Monad (unless, when) -import Data.List (isPrefixOf, sort) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Stackage.CheckCabalVersion (checkCabalVersion) -import Stackage.InstallInfo -import Stackage.Types -import Stackage.Util -import System.Exit (ExitCode (ExitFailure, ExitSuccess), - exitWith) -import System.Process (readProcessWithExitCode) - -data Mismatch = OnlyDryRun String | OnlySimpleList String - deriving Show - -checkPlan :: BuildSettings -> BuildPlan -> IO () -checkPlan settings bp = do - _ <- checkCabalVersion - - putStrLn "Checking build plan" - packages <- mapM (replaceTarball $ tarballDir settings) (bpPackageList bp) - (ec, dryRun', stderr) <- readProcessWithExitCode "cabal" - ( addCabalArgsOnlyGlobal settings - $ "install" - : "--dry-run" - : "--max-backjumps=-1" - : "--reorder-goals" - : extraArgs settings BSBuild ++ packages - ) "" - when (ec /= ExitSuccess || "Warning:" `isPrefixOf` stderr) $ do - putStr stderr - putStr dryRun' - putStrLn "cabal returned a bad result, exiting" - exitWith ec - let dryRun = sort $ filter notOptionalCore $ map (takeWhile (/= ' ')) $ drop 2 $ lines dryRun' - let mismatches = getMismatches dryRun (filter notOptionalCore $ bpPackageList bp) - unless (null $ filter (not . acceptableMismatch) mismatches) $ do - putStrLn "Found the following mismatches" - mapM_ print mismatches - exitWith $ ExitFailure 1 - putStrLn "Build plan checked, no mismatches" - where - optionalCore = Set.fromList $ map packageVersionString $ Map.toList $ bpOptionalCore bp - notOptionalCore s = not $ s `Set.member` optionalCore - -getMismatches :: [String] -> [String] -> [Mismatch] -getMismatches = - go - where - go [] y = map OnlySimpleList y - go x [] = map OnlyDryRun x - go (x:xs) (y:ys) = - case compare x y of - EQ -> go xs ys - LT -> OnlyDryRun x : go xs (y:ys) - GT -> OnlySimpleList y : go (x:xs) ys - --- | Some mismatches are going to be acceptable. The reasons are described --- below. -acceptableMismatch :: Mismatch -> Bool -acceptableMismatch m = - case m of - -- GHC 7.4 included extensible-extensions as a core package, and - -- therefore the HP at time of writing (2012.4.0.0) includes it in that - -- list. However, GHC 7.6 does /not/ include that package. As a result, - -- we get that package included in the dry run but not our list of - -- packages to build. See issue #57. - OnlyDryRun s | "extensible-exceptions-" `isPrefixOf` s -> True - _ -> False diff --git a/Stackage/Config.hs b/Stackage/Config.hs index 13e2092e..232d8588 100644 --- a/Stackage/Config.hs +++ b/Stackage/Config.hs @@ -1,842 +1,8 @@ -{-# LANGUAGE CPP #-} -module Stackage.Config where +{- -import Control.Monad (when, unless) -import Control.Monad.Trans.Writer (Writer, execWriter, tell) -import Data.Char (toLower) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Set (fromList, singleton) -import Distribution.Text (simpleParse) -import Stackage.Types +NOTE: This module is no longer used for tracking packages included in Stackage. +To simplify the codebase, that information is now stored in the +build-constraints.yaml configuration file. The file should be self-explanatory. +Sorry for the inconvenience. --- | Packages which are shipped with GHC but are not included in the --- Haskell Platform list of core packages. -defaultExtraCore :: GhcMajorVersion -> Set PackageName -defaultExtraCore _ = fromList $ map PackageName $ words - "binary Win32 ghc-prim integer-gmp" - --- | Test suites which are expected to fail for some reason. The test suite --- will still be run and logs kept, but a failure will not indicate an --- error in our package combination. -defaultExpectedFailures :: GhcMajorVersion - -> Bool -- ^ haskell platform - -> Set PackageName -defaultExpectedFailures ghcVer requireHP = execWriter $ do - -- Requires an old version of WAI and Warp for tests - add "HTTP" - - -- text and setenv have recursive dependencies in their tests, which - -- cabal can't (yet) handle - add "text" - add "setenv" - - -- The version of GLUT included with the HP does not generate - -- documentation correctly. - add "GLUT" - - -- https://github.com/bos/statistics/issues/42 - add "statistics" - - -- https://github.com/kazu-yamamoto/simple-sendfile/pull/10 - add "simple-sendfile" - - -- http://hackage.haskell.org/trac/hackage/ticket/954 - add "diagrams" - - -- https://github.com/fpco/stackage/issues/24 - add "unix-time" - - -- With transformers 0.3, it doesn't provide any modules - add "transformers-compat" - - -- Tests require shell script and are incompatible with sandboxed package - -- databases - add "HTF" - - -- https://github.com/simonmar/monad-par/issues/28 - add "monad-par" - - -- Unfortunately network failures seem to happen haphazardly - add "network" - - -- https://github.com/ekmett/hyphenation/issues/1 - add "hyphenation" - - -- Test suite takes too long to run on some systems - add "punycode" - - -- http://hub.darcs.net/stepcut/happstack/issue/1 - add "happstack-server" - - -- Requires a Facebook app. - add "fb" - - -- https://github.com/tibbe/hashable/issues/64 - add "hashable" - - -- https://github.com/vincenthz/language-java/issues/10 - add "language-java" - - add "threads" - add "crypto-conduit" - add "pandoc" - add "language-ecmascript" - add "hspec" - add "alex" - - -- https://github.com/basvandijk/concurrent-extra/issues/ - add "concurrent-extra" - - -- https://github.com/skogsbaer/xmlgen/issues/2 - add "xmlgen" - - -- Something very strange going on with the test suite, I can't figure - -- out how to fix it - add "bson" - - -- Requires a locally running PostgreSQL server with appropriate users - add "postgresql-simple" - - -- Missing files - add "websockets" - - -- Some kind of Cabal bug when trying to run tests - add "thyme" - - add "shake" - - -- https://github.com/jgm/pandoc-citeproc/issues/5 - add "pandoc-citeproc" - - -- Problems with doctest and sandboxing - add "warp" - add "wai-logger" - - -- https://github.com/fpco/stackage/issues/163 - add "hTalos" - add "seqloc" - - -- https://github.com/bos/math-functions/issues/25 - add "math-functions" - - -- FIXME the test suite fails fairly regularly in builds, though I haven't - -- discovered why yet - add "crypto-numbers" - - -- Test suite is currently failing regularly, needs to be worked out still. - add "lens" - - -- Requires too old a version of test-framework - add "time" - - -- No code included any more, therefore Haddock fails - mapM_ add $ words =<< - [ "comonad-transformers comonads-fd groupoids" - , "profunctor-extras semigroupoid-extras" - , "hamlet shakespeare-css shakespeare-i18n" - , "shakespeare-js shakespeare-text" - , "attoparsec-conduit blaze-builder-conduit http-client-conduit" - , "network-conduit zlib-conduit http-client-multipart" - , "wai-eventsource wai-test" - , "hspec-discover" - ] - - -- Cloud Haskell tests seem to be unreliable - mapM_ add $ words =<< - [ "distributed-process lockfree-queue network-transport-tcp" - ] - - -- Pulls in monad-peel which does not compile - when (ghcVer >= GhcMajorVersion 7 8) $ add "monad-control" - - -- https://github.com/fpco/stackage/issues/226 - add "options" - - -- https://github.com/gtk2hs/gtk2hs/issues/36 - add "glib" - add "pango" - - -- https://github.com/acw/bytestring-progress/issues/3 - add "bytestring-progress" - - -- Seems to require 32-bit functions - add "nettle" - - -- Depends on a missing graphviz executable - add "graphviz" - - -- https://github.com/silkapp/json-schema/issues/8 - when (ghcVer <= GhcMajorVersion 7 6) $ - add "json-schema" - - -- No AWS creds available - add "aws" - - -- Not sure why... - add "singletons" - - add "hspec2" - add "hspec-wai" - - -- Requires too new a version of time - when (ghcVer < GhcMajorVersion 7 8) $ add "cookie" - - -- https://github.com/fpco/stackage/issues/285 - add "diagrams-haddock" - add "scientific" - add "json-schema" - - -- https://github.com/BioHaskell/octree/issues/4 - add "Octree" - - -- No code until we upgrade to network 2.6 - add "network-uri" - - -- https://github.com/goldfirere/th-desugar/issues/12 - add "th-desugar" - - -- https://github.com/haskell/c2hs/issues/108 - add "c2hs" - - -- https://github.com/jmillikin/haskell-filesystem/issues/3 - add "system-filepath" - - -- For some unknown reason, doctest has trouble on GHC 7.6. This only - -- happens during a Stackage test. - -- - -- See: http://www.reddit.com/r/haskell/comments/2go92u/beginner_error_messages_in_c_vs_haskell/cklaspk - when (ghcVer == GhcMajorVersion 7 6) $ add "http-types" - - -- Requires a running webdriver server - add "webdriver" - add "webdriver-snoy" - - -- Weird conflicts with sandboxing - add "ghc-mod" - add "ghcid" - - -- Requires locally running server - add "bloodhound" - - -- Too lazy to keep the test dependencies up to date - let names = - words "hasql hasql-postgres hasql-backend postgresql-binary" ++ - words "stm-containers focus list-t slave-thread partial-handler" ++ - words "neat-interpolation cases" ++ - words "base-prelude mtl-prelude" - in mapM_ add names - - -- https://github.com/gtk2hs/gtk2hs/issues/79 - add "gio" - add "gtk" - - -- Requires SAT solver and old QuickCheck - add "ersatz" - - -- https://github.com/ekmett/gl/issues/3 - add "gl" - - -- Failing doctests - add "bits" - - -- No server running - add "amqp" - - when (ghcVer == GhcMajorVersion 7 8 && requireHP) $ do - -- https://github.com/vincenthz/hs-asn1/issues/11 - add "asn1-encoding" - - -- https://github.com/vincenthz/hs-tls/issues/84 - add "tls" - - add "x509" - - -- Often run out of inotify handles - add "fsnotify" - - -- Requires a correctly set up Postgres instance - add "opaleye" - where - add = tell . singleton . PackageName - --- | List of packages for our stable Hackage. All dependencies will be --- included as well. Please indicate who will be maintaining the package --- via comments. -defaultStablePackages :: GhcMajorVersion - -> Bool -- ^ using haskell platform? - -> Map PackageName (VersionRange, Maintainer) -defaultStablePackages ghcVer requireHP = unPackageMap $ execWriter $ do - when (ghcVer == GhcMajorVersion 7 8 && requireHP) haskellPlatform78 - mapM_ (add "michael@snoyman.com") $ words =<< - [ "yesod yesod-newsfeed yesod-sitemap yesod-static yesod-test yesod-bin" - , "markdown mime-mail-ses" - , "persistent persistent-template persistent-sqlite persistent-postgresql persistent-mysql" - , "network-conduit-tls yackage warp-tls keter" - , "process-conduit stm-conduit" - , "classy-prelude-yesod yesod-fay yesod-eventsource wai-websockets" - , "random-shuffle hebrew-time" - , "bzlib-conduit case-insensitive" - , "conduit-extra conduit-combinators yesod-websockets" - , "cabal-src" - , "yesod-auth-deskcom monadcryptorandom sphinx" - , "yesod-gitrepo" - ] - - -- https://github.com/fpco/stackage/issues/261 - addRange "Michael Snoyman" "cabal-install" $ - case () of - () - | ghcVer <= GhcMajorVersion 7 6 -> "< 1.17" - | ghcVer <= GhcMajorVersion 7 8 -> "< 1.19" - | otherwise -> "-any" - -- cabal-install is buggy still... - addRange "Michael Snoyman" "network" "< 2.6" - addRange "Michael Snoyman" "network-uri" "< 2.6" - - mapM_ (add "FP Complete ") $ words =<< - [ "web-fpco th-expand-syns configurator smtLib" - , "fixed-list indents language-c pretty-class" - , "csv-conduit cassava" - , "async shelly thyme" - , "hxt hxt-relaxng dimensional" - , "cairo diagrams-cairo gtk2hs-buildtools" - , "base16-bytestring convertible" - , "compdata hybrid-vectors" - , "executable-path formatting quandl-api" - , "fgl hmatrix hmatrix-gsl" - , "alex happy c2hs" - , "fpco-api aws persistent-mongoDB" - , "random-fu lhs2tex" - , "Chart Chart-diagrams histogram-fill random-source" - , "webdriver" - , "foreign-store" - , "statistics-linreg" - -- https://github.com/Soostone/retry/issues/18 - -- , "retry" - ] - when (ghcVer < GhcMajorVersion 7 8) $ do -- No GHC 7.8 support - mapM_ (add "FP Complete ") $ words =<< - [ "" -- too unreliable for the moment "distributed-process distributed-process-simplelocalnet" - -- https://github.com/fpco/stackage/issues/295 - --, "threepenny-gui unification-fd" - ] - addRange "FP Complete " "compdata" "< 0.8" - when (ghcVer >= GhcMajorVersion 7 8 && not requireHP) $ - mapM_ (add "FP Complete ") $ words =<< - [ "criterion" - , "th-lift singletons th-desugar quickcheck-assertions" - , "distributed-process distributed-process-simplelocalnet" -- cloud-haskell" - ] - - addRange "FP Complete " "kure" "<= 2.4.10" - - mapM_ (add "Omari Norman ") $ words - "barecheck rainbow rainbow-tests" - when (ghcVer >= GhcMajorVersion 7 8 && not requireHP) $ - mapM_ (add "Omari Norman ") $ words - "quickpull" - - mapM_ (add "Neil Mitchell") $ words - "hlint hoogle shake derive tagsoup cmdargs safe uniplate nsis js-jquery js-flot extra bake ghcid" - - mapM_ (add "Alan Zimmerman") $ words - "hjsmin language-javascript" - - when (ghcVer >= GhcMajorVersion 7 8 && not requireHP) $ - mapM_ (add "Alfredo Di Napoli ") $ words - "mandrill" - - mapM_ (add "Jasper Van der Jeugt") $ words - "blaze-html blaze-markup stylish-haskell" - - mapM_ (add "Antoine Latter") $ words - "uuid byteorder" - - mapM_ (add "Philipp Middendorf ") $ words - "clock" - - mapM_ (add "Stefan Wehr ") $ words - "HTF xmlgen stm-stats" - when (ghcVer < GhcMajorVersion 7 8) $ add "Stefan Wehr " "hscurses" - - mapM_ (add "Bart Massey ") $ words - "parseargs" - - mapM_ (add "Vincent Hanquez") $ words =<< - [ "bytedump certificate cipher-aes cipher-rc4 connection" - , "cprng-aes cpu crypto-pubkey-types crypto-random-api cryptocipher" - , "cryptohash hit language-java libgit pem siphash socks tls" - , "tls-debug vhd language-java" - ] - - mapM_ (add "Chris Done") $ words =<< - [ "ace check-email freenect gd" - , "hostname-validate ini lucid osdkeys pdfinfo" - , "pure-io sourcemap frisby" - , "present" - ] - - -- Requires older haddock currently - when (ghcVer == GhcMajorVersion 7 8 && requireHP) $ - mapM_ (add "Chris Done") $ words =<< - [ "haskell-docs" - ] - - -- https://github.com/jgoerzen/testpack/issues/10 - when (ghcVer >= GhcMajorVersion 7 8 && not requireHP) $ - mapM_ (add "Chris Done") $ words =<< - [ "scrobble" - ] - - -- Requires too new a process for GHC 7.6 - when (ghcVer >= GhcMajorVersion 7 8) $ - mapM_ (add "Chris Done") $ words =<< - [ "shell-conduit" - ] - - -- TODO: Add hindent and structured-haskell-mode once they've been ported to HSE 1.16. - -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) - -- Does not compile on Windows - mapM_ (add "Vincent Hanquez") $ words "udbus xenstore" -#endif - - when (ghcVer < GhcMajorVersion 7 8) $ - mapM_ (add "Alberto G. Corona ") $ words - "RefSerialize TCache Workflow MFlow" - - mapM_ (add "Edward Kmett ") $ words =<< - [ "ad adjunctions bifunctors bound charset comonad comonad-transformers" - , "comonads-fd compressed concurrent-supply constraints contravariant" - , "distributive either eq free groupoids heaps hyphenation" - , "integration intervals kan-extensions lca lens linear monadic-arrays machines" - , "mtl profunctors profunctor-extras reducers reflection" - , "semigroups semigroupoids semigroupoid-extras speculation tagged void" - , "graphs monad-products monad-st wl-pprint-extras wl-pprint-terminfo" - , "numeric-extras parsers pointed prelude-extras reducers" - , "streams vector-instances" - , "approximate bits bytes compensated exceptions" - , "linear-accelerate log-domain" - , "monad-products monad-st nats" - , "ersatz" - -- hyperloglog - ] - when (ghcVer < GhcMajorVersion 7 8) $ do - mapM_ (add "Edward Kmett ") $ words =<< - [ "categories comonad-extras recursion-schemes syb-extras" - ] - addRange "Edward Kmett " "bits" "< 0.4" - when (ghcVer >= GhcMajorVersion 7 8) $ - mapM_ (add "Edward Kmett ") $ words =<< - -- https://github.com/ekmett/fixed/issues/1 - [ "fixed" - -- https://github.com/ekmett/half/issues/1 - , "half gl" - ] - when (ghcVer >= GhcMajorVersion 7 8 && not requireHP) $ - mapM_ (add "Edward Kmett ") $ words =<< - [ "lens-aeson quickpull zlib-lens" - ] - -- Temporary upper bound for some of the above packages - addRange "Edward Kmett " "generic-deriving" "< 1.7" - - mapM_ (add "Andrew Farmer ") $ words - "scotty wai-middleware-static" - - mapM_ (add "Simon Hengel ") $ words - "hspec hspec-wai hspec-wai-json aeson-qq interpolate doctest base-compat" - - mapM_ (add "Mario Blazevic ") $ words - "monad-parallel monad-coroutine incremental-parser monoid-subclasses" - - mapM_ (add "Brent Yorgey ") $ words =<< - [ "monoid-extras dual-tree vector-space-points active force-layout" - , "diagrams diagrams-contrib diagrams-core diagrams-lib diagrams-svg" - , "diagrams-postscript haxr" - , "BlogLiterately" - , "MonadRandom" - , "diagrams-builder diagrams-haddock BlogLiterately-diagrams" - ] - mapM_ (add "Vincent Berthoux ") $ words - "JuicyPixels" - - mapM_ (add "Patrick Brisbin") $ words "gravatar" - - -- https://github.com/fpco/stackage/issues/299 - -- mapM_ (add "Paul Harper ") $ words "yesod-auth-oauth2" - - mapM_ (add "Felipe Lessa ") $ words - "esqueleto fb fb-persistent yesod-fb yesod-auth-fb" - - mapM_ (add "Alexander Altman ") $ words - "base-unicode-symbols containers-unicode-symbols" - - if ghcVer >= GhcMajorVersion 7 8 - then add "Trevor L. McDonell " "accelerate" - else do - addRange "Trevor L. McDonell " "accelerate" "< 0.15" - addRange "Michael Snoyman" "linear-accelerate" "< 0.2" - - mapM_ (add "Dan Burton ") $ words =<< - [ "basic-prelude composition io-memoize numbers rev-state runmemo" - , "tardis lens-family-th" - ] - - mapM_ (add "Daniel Díaz ") $ words - "HaTeX matrix" - when (ghcVer >= GhcMajorVersion 7 8) $ - mapM_ (add "Daniel Díaz ") $ words - "binary-list" - - mapM_ (add "Gabriel Gonzalez ") - ["pipes", "pipes-parse", "pipes-concurrency"] - - when (ghcVer >= GhcMajorVersion 7 8) $ - mapM_ (add "Chris Allen ") - ["bloodhound"] - - mapM_ (add "Adam Bergmark ") $ words - "fay fay-base fay-dom fay-jquery fay-text fay-uri snaplet-fay" - - when (ghcVer >= GhcMajorVersion 7 8 && not requireHP) $ - mapM_ (add "Rodrigo Setti ") $ words - "messagepack messagepack-rpc" - - mapM_ (add "Boris Lykah ") $ words - "groundhog groundhog-th groundhog-sqlite groundhog-postgresql groundhog-mysql" - - mapM_ (add "Janne Hellsten ") $ words - "sqlite-simple" - - mapM_ (add "Michal J. Gajda") $ words - "iterable Octree FenwickTree" - -- https://github.com/BioHaskell/hPDB/issues/2 - when (ghcVer >= GhcMajorVersion 7 8) $ do - mapM_ (add "Michal J. Gajda") $ words - "hPDB hPDB-examples" - - mapM_ (add "Roman Cheplyaka ") $ words =<< - [ "smallcheck tasty tasty-smallcheck tasty-quickcheck tasty-hunit tasty-golden" - , "traverse-with-class regex-applicative time-lens" - , "haskell-names haskell-packages hse-cpp" - , "action-permutations amqp curl generics-sop heredoc immortal timezone-olson timezone-series" - ] - - mapM_ (add "George Giorgidze ") $ words - "HCodecs YampaSynth" - - mapM_ (add "Phil Hargett ") $ words - "courier" - -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) - mapM_ (add "Aycan iRiCAN ") $ words - "hdaemonize hsyslog hweblib" -#else - mapM_ (add "Aycan iRiCAN ") $ words - "hweblib" -#endif - - mapM_ (add "Joachim Breitner ") $ words - "circle-packing arbtt" - when (ghcVer >= GhcMajorVersion 7 8) $ - mapM_ (add "Joachim Breitner ") $ words - "ghc-heap-view" - - when (ghcVer < GhcMajorVersion 7 8) $ - mapM_ (add "John Wiegley") $ words =<< - [ "bindings-DSL github monad-extras numbers" - ] - - mapM_ (add "Aditya Bhargava ") $ words - "hOpenPGP openpgp-asciiarmor MusicBrainz DAV hopenpgp-tools" - - -- https://github.com/fpco/stackage/issues/160 - mapM_ (add "Ketil Malde") $ words =<< - [ "biocore biofasta biofastq biosff" - , "blastxml bioace biophd" - , "biopsl" -- https://github.com/ingolia/SamTools/issues/3 samtools - , "seqloc bioalign BlastHTTP" - -- The following have out-of-date dependencies currently - -- biostockholm memexml RNAwolf - -- , "Biobase BiobaseDotP BiobaseFR3D BiobaseInfernal BiobaseMAF" - -- , "BiobaseTrainingData BiobaseTurner BiobaseXNA BiobaseVienna" - -- , "BiobaseTypes BiobaseFasta" - -- MC-Fold-DP - ] - -- https://github.com/fpco/stackage/issues/163 - addRange "Michael Snoyman" "biophd" "< 0.0.6 || > 0.0.6" - - mapM_ (add "Silk ") $ words =<< - [ "arrow-list attoparsec-expr bumper code-builder fay-builder" - , "hxt-pickle-utils multipart regular-xmlpickler" - , "tostring uri-encode imagesize-conduit" - ] - when (ghcVer >= GhcMajorVersion 7 8 && not requireHP) $ do - mapM_ (add "Silk ") $ words =<< - [ "aeson-utils generic-aeson json-schema" - , "rest-client rest-core rest-gen rest-happstack rest-snap rest-stringmap" - , "rest-types rest-wai tostring uri-encode imagesize-conduit" - ] - - mapM_ (add "Simon Michael ") $ words - "hledger" - - mapM_ (add "Mihai Maruseac ") $ words - "io-manager" - - mapM_ (add "Dimitri Sabadie ") $ words - "ghc-syb-utils" - - mapM_ (add "Boris Buliga ") $ words - "ghc-mod io-choice" - when (ghcVer >= GhcMajorVersion 7 8) $ - mapM_ (add "Boris Buliga ") $ words - "system-canonicalpath" - - when (ghcVer >= GhcMajorVersion 7 8) $ - mapM_ (add "Yann Esposito ") $ words - "holy-project" - when requireHP $ addRange "Yann Esposito " "holy-project" "< 0.1.1.1" - - mapM_ (add "Paul Rouse ") $ words - "yesod-auth-hashdb" - - add "Toralf Wittner " "zeromq4-haskell" - - mapM_ (add "trupill@gmail.com") $ words - "djinn-lib djinn-ghc" - - mapM_ (add "Arash Rouhani ") $ words - "yesod-text-markdown" - - mapM_ (add "Matvey Aksenov ") $ words =<< - ["text-binary BoundedChan bytestring-lexing bytestring-trie" - ,"data-accessor data-accessor-mtl file-location here" - ,"hlibgit2 hostname-validate interpolatedstring-perl6 iproute" - ,"missing-foreign multimap parallel-io"] - when (ghcVer >= GhcMajorVersion 7 8) $ - mapM_ (add "Emanuel Borsobom ") $ words - "haddock-api git-embed" - when (not requireHP) $ - mapM_ (add "Emanuel Borsobom ") $ words - "fuzzcheck MissingH" - - mapM_ (add "Michael Sloan = GhcMajorVersion 7 8 && not requireHP) $ do - mapM_ (add "Nikita Volkov ") $ - words "hasql hasql-postgres hasql-backend postgresql-binary" ++ - words "stm-containers focus list-t slave-thread partial-handler" ++ - words "neat-interpolation cases" ++ - words "base-prelude mtl-prelude" - addRange "Nikita Volkov " "mtl-prelude" "< 2" - - mapM_ (add "Iustin Pop ") $ words - "prefix-units" - - mapM_ (add "Alexander Thiemann ") $ words - "graph-core reroute Spock" - - mapM_ (add "Joey Eremondi ") $ words =<< - [ "prettyclass language-glsl union-find aeson-pretty QuasiText" - , "digest zip-archive elm-compiler elm-core-sources elm-build-lib" - -- elm-package - ] - - - mapM_ (add "Arthur Fayzrakhmanov ") $ words - "sodium hdevtools" - - -- https://github.com/fpco/stackage/issues/217 - addRange "Michael Snoyman" "transformers" "< 0.4" - addRange "Michael Snoyman" "mtl" "< 2.2" - addRange "Michael Snoyman" "lifted-base" "< 0.2.2.2" - - -- https://github.com/fpco/stackage/issues/224 - when (ghcVer <= GhcMajorVersion 7 6) $ do - addRange "Michael Snoyman" "zip-archive" "== 0.2.2.1" - addRange "Michael Snoyman" "pandoc" "== 1.12.4.2" - addRange "Michael Snoyman" "texmath" "<= 0.6.6.3" - addRange "Michael Snoyman" "attoparsec" "== 0.11.3.1" - addRange "Michael Snoyman" "parsers" "< 0.11" - addRange "Michael Snoyman" "scientific" "< 0.3" - addRange "Michael Snoyman" "aeson" "< 0.7.0.5" - addRange "Michael Snoyman" "aeson-utils" "< 0.2.2" - addRange "Michael Snoyman" "formatting" "< 5" - addRange "Michael Snoyman" "aws" "< 0.10" - addRange "Michael Snoyman" "network" "< 2.6" - addRange "Michael Snoyman" "network-uri" "< 2.6" - - -- 0.16.2 fixes dependency issues with different version of GHC - -- and Haskell Platform. Now builds on GHC 7.4-7.8. Version 1.0 is - -- guaranteed to break the API. See - -- https://travis-ci.org/jswebtools/language-ecmascript for - -- current build status. - addRange "Andrey Chudnov " "language-ecmascript" ">= 0.16.2 && < 1.0" - - -- https://github.com/fpco/stackage/issues/271 - when (ghcVer < GhcMajorVersion 7 8) $ - addRange "Michael Snoyman" "aeson" "< 0.8" - - -- https://github.com/fpco/stackage/issues/288 - addRange "Michael Snoyman" "text" "< 1.2" - - -- Force a specific version that's compatible with transformers 0.3 - addRange "Michael Snoyman" "transformers-compat" "== 0.3.3.3" - - -- https://github.com/fpco/stackage/issues/291 - addRange "Michael Snoyman" "random" "< 1.0.1.3" - - -- https://github.com/fpco/stackage/issues/314 - addRange "Michael Snoyman" "hxt" "< 9.3.1.9" - - -- https://github.com/fpco/stackage/issues/318 - addRange "Michael Snoyman" "HaXml" "< 1.25" - - -- https://github.com/fpco/stackage/issues/319 - addRange "Michael Snoyman" "polyparse" "< 1.10" - - -- https://github.com/fpco/stackage/issues/341 - addRange "Michael Snoyman" "haskell-names" "< 0.5" - - -- https://github.com/nikita-volkov/stm-containers/issues/3 - addRange "Michael Snoyman" "free" "< 4.10" - - -- https://github.com/fpco/stackage/issues/354 - addRange "Michael Snoyman" "JuicyPixels" "< 3.2" - - when (ghcVer == GhcMajorVersion 7 8 && requireHP) $ do - -- Yay workarounds for unnecessarily old versions - let peg x y = addRange "Haskell Platform" x y - peg "aeson" "== 0.7.0.4" - peg "scientific" "== 0.2.0.2" - peg "criterion" "<= 0.8.1.0" - peg "tasty-quickcheck" "< 0.8.0.3" - peg "formatting" "< 5.0" - peg "parsers" "< 0.11" - peg "lens" "< 4.2" - peg "contravariant" "< 1" - peg "adjunctions" "< 4.2" - peg "kan-extensions" "< 4.1" - peg "semigroupoids" "< 4.1" - peg "aws" "< 0.10" - peg "pandoc" "< 1.13" - peg "texmath" "<= 0.6.6.3" - peg "checkers" "== 0.3.2" - peg "HandsomeSoup" "< 0.3.3" - peg "network-uri" "< 2.6" - - mapM_ (add "Tom Ellis ") $ words - "opaleye product-profunctors" - -add :: String -> String -> Writer PackageMap () -add maintainer package = addRange maintainer package "-any" - -addRange :: String -> String -> String -> Writer PackageMap () -addRange maintainer package range = - case simpleParse range of - Nothing -> error $ "Invalid range " ++ show range ++ " for " ++ package - Just range' -> tell $ PackageMap $ Map.singleton (PackageName package) (range', Maintainer maintainer) - --- | Hard coded Haskell Platform versions -haskellPlatform78 :: Writer PackageMap () -haskellPlatform78 = do - addRange "Haskell Platform" "ghc" "== 7.8.3" - addRange "Haskell Platform" "haddock" "== 2.14.3" - addRange "Haskell Platform" "array" "== 0.5.0.0" - addRange "Haskell Platform" "base" "== 4.7.0.1" - addRange "Haskell Platform" "bytestring" "== 0.10.4.0" - addRange "Haskell Platform" "Cabal" "== 1.18.1.3" - addRange "Haskell Platform" "containers" "== 0.5.5.1" - addRange "Haskell Platform" "deepseq" "== 1.3.0.2" - addRange "Haskell Platform" "directory" "== 1.2.1.0" - addRange "Haskell Platform" "filepath" "== 1.3.0.2" - addRange "Haskell Platform" "haskell2010" "== 1.1.2.0" - addRange "Haskell Platform" "haskell98" "== 2.0.0.3" - addRange "Haskell Platform" "hpc" "== 0.6.0.1" - addRange "Haskell Platform" "old-locale" "== 1.0.0.6" - addRange "Haskell Platform" "old-time" "== 1.1.0.2" - addRange "Haskell Platform" "pretty" "== 1.1.1.1" - addRange "Haskell Platform" "process" "== 1.2.0.0" - addRange "Haskell Platform" "template-haskell" "== 2.9.0.0" - addRange "Haskell Platform" "time" "== 1.4.2" - addRange "Haskell Platform" "transformers" "== 0.3.0.0" - addRange "Haskell Platform" "unix" "== 2.7.0.1" - addRange "Haskell Platform" "xhtml" "== 3000.2.1" - addRange "Haskell Platform" "async" "== 2.0.1.5" - addRange "Haskell Platform" "attoparsec" "== 0.10.4.0" - addRange "Haskell Platform" "case-insensitive" "== 1.1.0.3" - addRange "Haskell Platform" "fgl" "== 5.5.0.1" - addRange "Haskell Platform" "GLURaw" "== 1.4.0.1" - addRange "Haskell Platform" "GLUT" "== 2.5.1.1" - addRange "Haskell Platform" "hashable" "== 1.2.2.0" - addRange "Haskell Platform" "haskell-src" "== 1.0.1.6" - addRange "Haskell Platform" "html" "== 1.0.1.2" - addRange "Haskell Platform" "HTTP" "== 4000.2.10" - addRange "Haskell Platform" "HUnit" "== 1.2.5.2" - addRange "Haskell Platform" "mtl" "== 2.1.3.1" - addRange "Haskell Platform" "network" "== 2.4.2.3" - addRange "Haskell Platform" "OpenGL" "== 2.9.2.0" - addRange "Haskell Platform" "OpenGLRaw" "== 1.5.0.0" - addRange "Haskell Platform" "parallel" "== 3.2.0.4" - addRange "Haskell Platform" "parsec" "== 3.1.5" - addRange "Haskell Platform" "primitive" "== 0.5.2.1" - addRange "Haskell Platform" "QuickCheck" "== 2.6" - addRange "Haskell Platform" "random" "== 1.0.1.1" - addRange "Haskell Platform" "regex-base" "== 0.93.2" - addRange "Haskell Platform" "regex-compat" "== 0.95.1" - addRange "Haskell Platform" "regex-posix" "== 0.95.2" - addRange "Haskell Platform" "split" "== 0.2.2" - addRange "Haskell Platform" "stm" "== 2.4.2" - addRange "Haskell Platform" "syb" "== 0.4.1" - addRange "Haskell Platform" "text" "== 1.1.0.0" - addRange "Haskell Platform" "transformers" "== 0.3.0.0" - addRange "Haskell Platform" "unordered-containers" "== 0.2.4.0" - addRange "Haskell Platform" "vector" "== 0.10.9.1" - addRange "Haskell Platform" "xhtml" "== 3000.2.1" - addRange "Haskell Platform" "zlib" "== 0.5.4.1" - addRange "Haskell Platform" "alex" "== 3.1.3" - addRange "Haskell Platform" "cabal-install" "== 1.18.0.5" - addRange "Haskell Platform" "happy" "== 1.19.4" - addRange "Haskell Platform" "hscolour" "== 1.20.3" - --- | Replacement Github users. This is useful when a project is owned by an --- organization. It also lets you ping multiple users. --- --- Note that cross organization team mentions aren't allowed by Github. -convertGithubUser :: String -> [String] -convertGithubUser x = - fromMaybe [x] $ Map.lookup (map toLower x) pairs - where - pairs = Map.fromList - [ ("diagrams", ["byorgey", "fryguybob", "jeffreyrosenbluth", "bergey"]) - , ("yesodweb", ["snoyberg"]) - , ("fpco", ["snoyberg"]) - , ("faylang", ["bergmark"]) - , ("silkapp", ["bergmark", "hesselink"]) - , ("snapframework",["mightybyte"]) - , ("haskell-ro", ["mihaimaruseac"]) - ] +-} diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs deleted file mode 100644 index 92099c31..00000000 --- a/Stackage/GhcPkg.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Stackage.GhcPkg where - -import Stackage.Types -import System.Process -import Distribution.Text (simpleParse) -import Distribution.Version (Version (Version)) -import Data.Char (isSpace) -import qualified Data.Set as Set - -getPackages :: [String] -> GhcMajorVersion -> IO (Set PackageIdentifier) -getPackages extraArgs version = do - output <- readProcess "ghc-pkg" (extraArgs ++ [arg, "list"]) "" - fmap Set.unions $ mapM parse $ drop 1 $ lines output - where - -- Account for a change in command line option name - arg - | version >= GhcMajorVersion 7 6 = "--no-user-package-db" - | otherwise = "--no-user-package-conf" - parse s = - case clean s of - "" -> return Set.empty - s' -> - case simpleParse s' of - Just x -> return $ Set.singleton x - Nothing -> error $ "Could not parse ghc-pkg output: " ++ show s - clean = stripParens . dropWhile isSpace . reverse . dropWhile isSpace . reverse - stripParens x@('(':_:_) - | last x == ')' = tail $ init $ x - stripParens x = x - -getGlobalPackages :: GhcMajorVersion -> IO (Set PackageIdentifier) -getGlobalPackages version = getPackages [] version - -getDBPackages :: [FilePath] -> GhcMajorVersion -> IO (Set PackageIdentifier) -getDBPackages [] _ = return Set.empty -getDBPackages packageDirs version = - getPackages (map packageDbArg packageDirs) version - where - packageDbArg db - | version >= GhcMajorVersion 7 6 = "--package-db=" ++ db - | otherwise = "--package-conf" ++ db - -getGhcVersion :: IO GhcMajorVersion -getGhcVersion = do - versionOutput <- readProcess "ghc-pkg" ["--version"] "" - maybe (error $ "Invalid version output: " ++ show versionOutput) return $ do - verS:_ <- Just $ reverse $ words versionOutput - Version (x:y:_) _ <- simpleParse verS - return $ GhcMajorVersion x y diff --git a/Stackage/Init.hs b/Stackage/Init.hs deleted file mode 100644 index b8b599c5..00000000 --- a/Stackage/Init.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Stackage.Init (stackageInit) where - -import Data.List (isInfixOf, isPrefixOf) -import Stackage.Util -import System.FilePath (()) - -stackageInit :: IO () -stackageInit = do - c <- getCabalRoot - let config = c "config" - orig <- readFile config - -- bypass laziness - _ <- return $! length orig - writeFile config $ unlines $ go $ lines orig - where - go = addStackage - . map commentHackage - . filter (\s -> not $ "stackage" `isInfixOf` s) - - addStackage [] = stackageLines [] - addStackage (l:ls) - | "remote-repo-cache:" `isPrefixOf` l = stackageLines $ l : ls - | otherwise = l : addStackage ls - - stackageLines x = - "remote-repo: stackage:http://hackage.haskell.org/packages/archive" - : "remote-repo: stackage-extra:http://hackage.haskell.org/packages/archive" - : x - - commentHackage s - | s == "remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive" = "--" ++ s - | otherwise = s diff --git a/Stackage/InstallInfo.hs b/Stackage/InstallInfo.hs deleted file mode 100644 index 5188c7a6..00000000 --- a/Stackage/InstallInfo.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -module Stackage.InstallInfo - ( getInstallInfo - , bpPackageList - ) where - -import Control.Monad (forM_, unless) -import Data.List (foldl') -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Time (getCurrentTime, formatTime) -import Data.Version (showVersion) -import qualified Distribution.Text -import Distribution.Version (simplifyVersionRange, withinRange) -import Stackage.GhcPkg -import Stackage.LoadDatabase -import Stackage.NarrowDatabase -import Stackage.ServerFiles -import Stackage.Types -import Stackage.Util -import System.Directory (createDirectoryIfMissing) -import System.FilePath (()) -import qualified System.IO as IO -import qualified System.IO.UTF8 -import System.Locale (defaultTimeLocale) -import System.Exit (exitFailure) - -dropExcluded :: SelectSettings - -> Map PackageName (VersionRange, Maintainer) - -> Map PackageName (VersionRange, Maintainer) -dropExcluded bs m0 = - foldl' (flip Map.delete) m0 (Set.toList $ excludedPackages bs) - -getInstallInfo :: SelectSettings -> IO InstallInfo -getInstallInfo settings = do - core <- do - putStrLn "Loading core packages from global database" - getGlobalPackages $ selectGhcVersion settings - underlay <- getDBPackages (selectUnderlayPackageDirs settings) (selectGhcVersion settings) - let underlaySet = Set.map pkgName underlay - coreMap = Map.unions - $ map (\(PackageIdentifier k v) -> Map.singleton k v) - $ Set.toList core - allPackages' = - stablePackages settings $ requireHaskellPlatform settings - allPackages = dropExcluded settings allPackages' - totalCore - | ignoreUpgradeableCore settings = - Map.fromList $ map (\n -> (PackageName n, Nothing)) $ words "base containers template-haskell" - | otherwise = - Map.fromList (map (\(PackageIdentifier p v) -> (p, Just v)) (Set.toList core)) - `Map.union` Map.fromList (map (, Nothing) (Set.toList $ extraCore settings)) - - putStrLn "Loading package database" - pdb <- loadPackageDB settings coreMap (Map.keysSet totalCore) allPackages underlaySet - - putStrLn "Narrowing package database" - (final, errs) <- narrowPackageDB settings (Map.keysSet totalCore) pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages - - putStrLn "Printing build plan to build-plan.log" - System.IO.UTF8.writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final - System.IO.UTF8.writeFile "hackage-map.txt" $ unlines $ map showHackageMap $ Map.toList final - - unless (Set.null errs) $ do - putStrLn "Build plan requires some disallowed packages" - mapM_ putStrLn $ Set.toList errs - exitFailure - - putStrLn "Checking for bad versions" - case checkBadVersions settings coreMap pdb final of - badVersions - | Map.null badVersions -> return () - | otherwise -> do - forM_ (Map.toList badVersions) $ \(user, badDeps) -> do - putStrLn $ user ++ " cannot use: " - forM_ (Map.toList badDeps) $ \(name, (version, range)) -> do - putStrLn $ concat - [ "- " - , packageVersionString (name, version) - , " -- " - , Distribution.Text.display $ simplifyVersionRange range - ] - putStrLn "" - - error "Conflicting build plan, exiting" - - let ii = InstallInfo - { iiCore = totalCore - , iiPackages = Map.map biToSPI final - , iiOptionalCore = Map.empty - , iiPackageDB = pdb - } - - forM_ [False, True] $ \isInc -> do - let incexc = if isInc then "inclusive" else "exclusive" - - now <- getCurrentTime - let ghcVer = - let GhcMajorVersion x y = selectGhcVersion settings - in show x ++ "." ++ show y - date = formatTime defaultTimeLocale "%Y-%m-%d" now - - createDirectoryIfMissing True incexc - - putStrLn $ "Inclusive/exclusive: " ++ incexc - - putStrLn "Creating hackage file (for publishing to Stackage server)" - let isHP = requireHaskellPlatform settings - IO.withBinaryFile (incexc "hackage") IO.WriteMode $ \hackageH -> - IO.withBinaryFile (incexc "create-snapshot.sh") IO.WriteMode - (createHackageFile isInc isHP ii ghcVer date hackageH) - - putStrLn "Creating desc file (for publishing to Stackage server)" - System.IO.UTF8.writeFile (incexc "desc") $ concat - [ "Stackage build for GHC " - , ghcVer - , if requireHaskellPlatform settings - then " + Haskell Platform" - else "" - , ", " - , date - , ", " - , incexc - , "\nGenerated on " - , show now - ] - - System.IO.UTF8.writeFile (incexc "slug") $ concat - [ date - , "-ghc" - , ghcVer - , if requireHaskellPlatform settings then "hp" else "" - , if isInc then "-inc" else "-exc" - ] - - return ii - -biToSPI :: BuildInfo -> SelectedPackageInfo -biToSPI BuildInfo {..} = SelectedPackageInfo - { spiVersion = biVersion - , spiMaintainer = biMaintainer - , spiGithubUser = biGithubUser - , spiHasTests = biHasTests - } - -showDep :: (PackageName, BuildInfo) -> String -showDep (PackageName name, BuildInfo {..}) = - concat - [ name - , "-" - , showVersion biVersion - , " (" - , unMaintainer biMaintainer - , " " ++ githubMentions biGithubUser - , ")" - , ": " - , unwords $ map unP biUsers - ] - where - unP (PackageName p) = p - --- | Convert to format used by Hackage for displaying distribution versions. --- For more info, see https://github.com/fpco/stackage/issues/38. -showHackageMap :: (PackageName, BuildInfo) -> String -showHackageMap (PackageName name, BuildInfo {..}) = - show (name, showVersion biVersion, Nothing :: Maybe String) - -bpPackageList :: BuildPlan -> [String] -bpPackageList = map packageVersionString . Map.toList . Map.map spiVersion . bpPackages - --- | Check for internal mismatches in required and actual package versions. -checkBadVersions :: SelectSettings - -> Map PackageName Version -- ^ core - -> PackageDB - -> Map PackageName BuildInfo - -> Map String (Map PackageName (Version, VersionRange)) -checkBadVersions settings core (PackageDB pdb) buildPlan = - Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan - where - unexpectedFailure name _ = name `Set.notMember` expectedFailures settings - - getBadVersions :: (PackageName, BuildInfo) -> Map String (Map PackageName (Version, VersionRange)) - getBadVersions (name, bi) - | Map.null badVersions = Map.empty - | otherwise = Map.singleton display badVersions - where - badVersions = Map.unions $ map (uncurry checkPackage) $ Map.toList $ biDeps bi - display = concat - [ packageVersionString (name, biVersion bi) - , " (" - , unMaintainer $ biMaintainer bi - , case Map.lookup name pdb of - Just PackageInfo { piGithubUser = gus } -> " " ++ githubMentions gus - _ -> "" - , ")" - ] - - checkPackage :: PackageName -> VersionRange -> Map PackageName (Version, VersionRange) - checkPackage name vr = - case Map.lookup name buildPlan of - Nothing -> - case Map.lookup name core of - -- Might be part of extra-core - Nothing -> Map.empty - Just version - | version `withinRange` vr -> Map.empty - | otherwise -> Map.singleton name (version, vr) - Just bi - | biVersion bi `withinRange` vr -> Map.empty - | otherwise -> Map.singleton name (biVersion bi, vr) diff --git a/Stackage/LoadDatabase.hs b/Stackage/LoadDatabase.hs deleted file mode 100644 index d54cabd0..00000000 --- a/Stackage/LoadDatabase.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Stackage.LoadDatabase where - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Compression.GZip as GZip -import Control.Exception (IOException, handle) -import Control.Monad (guard, foldM) -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as L8 -import Data.List (stripPrefix) -import qualified Data.Map as Map -import Data.Maybe (catMaybes, listToMaybe, - mapMaybe, fromMaybe) -import Data.Monoid (Monoid (..)) -import Data.Set (member) -import qualified Data.Set as Set -import Distribution.Compiler (CompilerFlavor (GHC)) -import Distribution.Package (Dependency (Dependency)) -import Distribution.PackageDescription (Condition (..), - ConfVar (..), - FlagName (FlagName), - RepoType (Git), - SourceRepo (..), - benchmarkBuildInfo, - buildInfo, buildTools, - condBenchmarks, - condExecutables, - condLibrary, - condTestSuites, - condTreeComponents, - condTreeConstraints, - condTreeData, - flagDefault, flagName, - genPackageFlags, - homepage, libBuildInfo, - packageDescription, - sourceRepos, - testBuildInfo) -import Distribution.PackageDescription.Parse (ParseResult (ParseOk), - parsePackageDescription) -import Distribution.System (buildArch, buildOS) -import Distribution.Text (simpleParse) -import Distribution.Version (Version (Version), - unionVersionRanges, - withinRange) -import Stackage.Config (convertGithubUser) -import Stackage.Types -import Stackage.Util -import System.Directory (doesFileExist, getDirectoryContents) -import System.FilePath ((<.>), ()) - --- | Load the raw package database. --- --- We want to put in some restrictions: --- --- * Drop all core packages. We never want to install a new version of --- those, nor include them in the package list. --- --- * For packages with a specific version bound, find the maximum matching --- version. --- --- * For other packages, select the maximum version number. -loadPackageDB :: SelectSettings - -> Map PackageName Version -- ^ core packages from HP file - -> Set PackageName -- ^ all core packages, including extras - -> Map PackageName (VersionRange, Maintainer) -- ^ additional deps - -> Set PackageName -- ^ underlay packages to exclude - -> IO PackageDB -loadPackageDB settings coreMap core deps underlay = do - tarName <- getTarballName - lbs <- L.readFile tarName - pdb <- addEntries mempty $ Tar.read lbs - contents <- handle (\(_ :: IOException) -> return []) - $ getDirectoryContents $ selectTarballDir settings - pdb' <- foldM addTarball pdb $ mapMaybe stripTarGz contents - return $ excludeUnderlay pdb' - where - addEntries _ (Tar.Fail e) = error $ show e - addEntries db Tar.Done = return db - addEntries db (Tar.Next e es) = addEntry db e >>= flip addEntries es - - stripTarGz = fmap reverse . stripPrefix (reverse ".tar.gz") . reverse - - ghcVersion' = - let GhcMajorVersion x y = selectGhcVersion settings - in Version [x, y, 2] [] - - addEntry :: PackageDB -> Tar.Entry -> IO PackageDB - addEntry pdb e = - case getPackageVersion e of - Nothing -> return pdb - Just (p, v) - | p `member` core -> return pdb - | otherwise -> - case Map.lookup p deps of - Just (vrange, _maintainer) - | not $ withinRange v vrange -> return pdb - _ -> do - let pkgname = packageVersionString (p, v) - tarball = selectTarballDir settings pkgname <.> "tar.gz" - case Tar.entryContent e of - Tar.NormalFile bs _ -> addPackage p v bs pdb - _ -> return pdb - - addTarball :: PackageDB -> FilePath -> IO PackageDB - addTarball pdb tarball' = do - lbs <- L.readFile tarball - let (v', p') = break (== '-') $ reverse tarball' - p = PackageName $ reverse $ drop 1 p' - v <- maybe (error $ "Invalid tarball name: " ++ tarball) return - $ simpleParse $ reverse v' - case Map.lookup p deps of - Just (vrange, _) - | not $ withinRange v vrange -> return pdb - _ -> findCabalAndAddPackage tarball p v pdb $ Tar.read $ GZip.decompress lbs - where - tarball = selectTarballDir settings tarball' <.> "tar.gz" - - excludeUnderlay :: PackageDB -> PackageDB - excludeUnderlay (PackageDB pdb) = - PackageDB $ Map.filterWithKey (\k _ -> Set.notMember k underlay) pdb - - skipTests p = p `Set.member` skippedTests settings - - -- Find the relevant cabal file in the given entries and add its contents - -- to the package database - findCabalAndAddPackage tarball p v pdb = - loop - where - fixPath '\\' = '/' - fixPath c = c - - expectedPath = let PackageName p' = p in concat - [ packageVersionString (p, v) - , "/" - , p' - , ".cabal" - ] - loop Tar.Done = error $ concat - [ "Missing cabal file " - , show expectedPath - , " in tarball: " - , show tarball - ] - loop (Tar.Fail e) = error $ concat - [ "Unable to read tarball " - , show tarball - , ": " - , show e - ] - loop (Tar.Next entry rest) - | map fixPath (Tar.entryPath entry) == expectedPath = - case Tar.entryContent entry of - Tar.NormalFile bs _ -> addPackage p v bs pdb - _ -> error $ concat - [ "In tarball " - , show tarball - , " the cabal file " - , show expectedPath - , " was not a normal file" - ] - | otherwise = loop rest - - addPackage p v lbs pdb = do - let (deps', hasTests, buildToolsExe', buildToolsOther', mgpd, execs, mgithub) = parseDeps p lbs - return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo - { piVersion = v - , piDeps = deps' - , piHasTests = hasTests - , piBuildToolsExe = buildToolsExe' - , piBuildToolsAll = buildToolsExe' `Set.union` buildToolsOther' - , piGPD = mgpd - , piExecs = execs - , piGithubUser = fromMaybe [] mgithub - } - - parseDeps p lbs = - case parsePackageDescription $ L8.unpack lbs of - ParseOk _ gpd -> (mconcat - [ maybe mempty (go gpd) $ condLibrary gpd - , mconcat $ map (go gpd . snd) $ condExecutables gpd - , if skipTests p - then mempty - else mconcat $ map (go gpd . snd) $ condTestSuites gpd - -- FIXME , mconcat $ map (go gpd . snd) $ condBenchmarks gpd - ], not $ null $ condTestSuites gpd - , Set.fromList $ map depName $ libExeBuildInfo gpd - , Set.fromList $ map depName $ testBenchBuildInfo gpd - , Just gpd - , Set.fromList $ map (Executable . fst) $ condExecutables gpd - , fmap convertGithubUser $ listToMaybe $ catMaybes - $ parseGithubUserHP (homepage $ packageDescription gpd) - : map parseGithubUserSR (sourceRepos $ packageDescription gpd) - ) - _ -> (mempty, defaultHasTestSuites, Set.empty, Set.empty, Nothing, Set.empty, Nothing) - where - libExeBuildInfo gpd = concat - [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd - , concat $ map (goBI buildInfo . snd) $ condExecutables gpd - ] - testBenchBuildInfo gpd = concat - [ if skipTests p - then [] - else concat $ map (goBI testBuildInfo . snd) $ condTestSuites gpd - , concat $ map (goBI benchmarkBuildInfo . snd) $ condBenchmarks gpd - ] - goBI f x = buildTools $ f $ condTreeData x - - depName (Dependency (PackageName pn) _) = Executable pn - go gpd tree - = Map.filterWithKey (\k _ -> not $ ignoredDep k) - $ Map.unionsWith unionVersionRanges - $ Map.fromList (map (\(Dependency pn vr) -> (pn, vr)) $ condTreeConstraints tree) - : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree) - - -- Some specific overrides for cases where getting Stackage to be smart - -- enough to handle things would be too difficult. - ignoredDep :: PackageName -> Bool - ignoredDep dep - -- The flag logic used by text-stream-decode confuses Stackage. - | dep == PackageName "text" && p == PackageName "text-stream-decode" = True - | otherwise = False - - checkCond gpd (cond, tree, melse) - | checkCond' cond = Just tree - | otherwise = melse - where - checkCond' (Var (OS os)) = os == buildOS - checkCond' (Var (Arch arch)) = arch == buildArch - - -- Sigh... the small_base flag on mersenne-random-pure64 is backwards - checkCond' (Var (Flag (FlagName "small_base"))) - | p == PackageName "mersenne-random-pure64" = False - - checkCond' (Var (Flag flag@(FlagName flag'))) = - flag' `Set.notMember` disabledFlags settings && - flag `elem` flags' - checkCond' (Var (Impl compiler range)) = - compiler == GHC && withinRange ghcVersion' range - checkCond' (Lit b) = b - checkCond' (CNot c) = not $ checkCond' c - checkCond' (COr c1 c2) = checkCond' c1 || checkCond' c2 - checkCond' (CAnd c1 c2) = checkCond' c1 && checkCond' c2 - - flags' = map flagName (filter flagDefault $ genPackageFlags gpd) ++ - (map FlagName $ Set.toList $ Stackage.Types.flags settings coreMap) - --- | Attempt to grab the Github username from a homepage. -parseGithubUserHP :: String -> Maybe String -parseGithubUserHP url1 = do - url2 <- listToMaybe $ mapMaybe (flip stripPrefix url1) - [ "http://github.com/" - , "https://github.com/" - ] - let x = takeWhile (/= '/') url2 - guard $ not $ null x - Just x - --- | Attempt to grab the Github username from a source repo. -parseGithubUserSR :: SourceRepo -> Maybe String -parseGithubUserSR sr = - case (repoType sr, repoLocation sr) of - (Just Git, Just s) -> parseGithubUserHP s - _ -> Nothing diff --git a/Stackage/ModuleNameConflict.hs b/Stackage/ModuleNameConflict.hs deleted file mode 100644 index 4b09ad3f..00000000 --- a/Stackage/ModuleNameConflict.hs +++ /dev/null @@ -1,52 +0,0 @@ -module Stackage.ModuleNameConflict - ( ModuleNameConflicts - , getModuleNameConflicts - , renderModuleNameConflicts - , parseModuleNameConflicts - ) where - -import Distribution.Simple.Configure (configCompiler, getInstalledPackages) -import Distribution.Simple.Compiler (CompilerFlavor (GHC), PackageDB (GlobalPackageDB, SpecificPackageDB)) -import Distribution.Verbosity (normal) -import Distribution.Simple.Program (defaultProgramConfiguration) -import Distribution.Simple.PackageIndex (moduleNameIndex) -import Distribution.InstalledPackageInfo (sourcePackageId) -import Distribution.Package (PackageIdentifier (PackageIdentifier), PackageName (PackageName)) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.List (intercalate) -import Distribution.ModuleName (components) - -type ModuleNameConflicts = Map.Map (Set.Set String) (Set.Set String) - -getModuleNameConflicts :: FilePath -> IO ModuleNameConflicts -getModuleNameConflicts path = do - (compiler, progConfig) <- - configCompiler (Just GHC) Nothing Nothing defaultProgramConfiguration normal - let stack = - [ GlobalPackageDB - , SpecificPackageDB path - ] - packageIndex <- getInstalledPackages normal compiler stack progConfig - let modMap = moduleNameIndex packageIndex - packageName (PackageIdentifier (PackageName x) _) = x - simpleMN = intercalate "." . components - overlaps = Map.unionsWith Set.union - $ map (\(mn, pkgs) -> Map.singleton pkgs (Set.singleton $ simpleMN mn)) - $ Map.toList - $ Map.filter (\x -> Set.size x > 1) - $ Map.map Set.fromList - $ fmap (map (packageName . sourcePackageId)) modMap - return overlaps - -renderModuleNameConflicts :: ModuleNameConflicts -> String -renderModuleNameConflicts = - unlines . map (unwords . Set.toList) . concatMap (\(x, y) -> [x, y]) . Map.toList - -parseModuleNameConflicts :: String -> ModuleNameConflicts -parseModuleNameConflicts = - Map.fromList . toPairs . map (Set.fromList . words) . lines - where - toPairs [] = [] - toPairs [_] = [] - toPairs (x:y:z) = (x, y) : toPairs z diff --git a/Stackage/NarrowDatabase.hs b/Stackage/NarrowDatabase.hs deleted file mode 100644 index 42b47101..00000000 --- a/Stackage/NarrowDatabase.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Stackage.NarrowDatabase where - -import Control.Monad.Trans.Writer -import Data.List (foldl') -import qualified Data.Map as Map -import qualified Data.Set as Set -import Prelude hiding (pi) -import Stackage.Types -import Stackage.Util - --- | Narrow down the database to only the specified packages and all of --- their dependencies. -narrowPackageDB :: SelectSettings - -> Set PackageName -- ^ core packages to be excluded from installation - -> PackageDB - -> Set (PackageName, Maintainer) - -> IO (Map PackageName BuildInfo, Set String) -narrowPackageDB settings core (PackageDB pdb) packageSet = - runWriterT $ loop Map.empty $ Set.map (\(name, maintainer) -> ([], name, maintainer)) packageSet - where - loop result toProcess = - case Set.minView toProcess of - Nothing -> return result - Just ((users, p, maintainer), toProcess') -> - case Map.lookup p pdb of - Nothing - | p `Set.member` core -> loop result toProcess' - | null users -> error $ "Unknown package: " ++ show p - | otherwise -> loop result toProcess' - Just pi -> do - let users' = p:users - result' = Map.insert p BuildInfo - { biVersion = piVersion pi - , biUsers = users - , biMaintainer = maintainer - , biDeps = piDeps pi - , biGithubUser = piGithubUser pi - , biHasTests = piHasTests pi - } result - case piGPD pi of - Nothing -> return () - Just gpd -> - case allowedPackage settings gpd of - Left msg -> tell $ Set.singleton $ concat - [ packageVersionString (p, piVersion pi) - , ": " - , msg - ] - Right () -> return () - loop result' $ foldl' (addDep users' result' maintainer) toProcess' $ Map.keys $ piDeps pi - addDep users result maintainer toProcess p = - case Map.lookup p result of - Nothing -> Set.insert (users, p, maintainer) toProcess - Just{} -> toProcess diff --git a/Stackage/Select.hs b/Stackage/Select.hs deleted file mode 100644 index 7e6f7692..00000000 --- a/Stackage/Select.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE CPP #-} -module Stackage.Select - ( select - , defaultSelectSettings - ) where - -import Data.Either (partitionEithers) -import qualified Data.Map as Map -import Data.Maybe (mapMaybe) -import Data.Set (empty) -import qualified Data.Set as Set -import Distribution.Text (simpleParse) -import Distribution.Version (withinRange) -import Prelude hiding (pi) -import Stackage.Config -import Stackage.InstallInfo -import Stackage.Types -import Stackage.Util - -defaultSelectSettings :: GhcMajorVersion - -> Bool -- ^ haskell platform? - -> SelectSettings -defaultSelectSettings version requireHP = SelectSettings - { extraCore = defaultExtraCore version - , expectedFailures = defaultExpectedFailures version requireHP - , stablePackages = defaultStablePackages version - , haskellPlatformDir = "hp" - , requireHaskellPlatform = requireHP - , ignoreUpgradeableCore = False - , excludedPackages = empty - , flags = \coreMap -> - Set.fromList (words "blaze_html_0_5 small_base https splitbase old-locale new-base") `Set.union` - -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) - -- Needed on Windows to get unix-compat to compile - (if version >= GhcMajorVersion 7 6 then Set.empty else Set.fromList (words "old-time")) - `Set.union` -#endif - -- Support for containers-unicode-symbols - (case Map.lookup (PackageName "containers") coreMap of - Just v | Just range <- simpleParse "< 0.5", v `withinRange` range - -> Set.singleton "containers-old" - _ -> Set.empty) `Set.union` - - {- - -- Support for network 2.6 - (if version >= GhcMajorVersion 7 8 && not requireHP - then Set.singleton "network-uri" - else Set.empty) - -} - Set.empty - , disabledFlags = Set.fromList (words "bytestring-in-base test-hlint") - `Set.union` - (if version <= GhcMajorVersion 7 4 - then Set.singleton "bytestring-builder" - else Set.empty) - - -- SHA and binary - - `Set.union` - (if version <= GhcMajorVersion 7 6 - then Set.singleton "decoderinterface" - else Set.empty) `Set.union` - - {- - -- Support for network 2.6 - (if version >= GhcMajorVersion 7 8 && not requireHP - then Set.empty - else Set.singleton "network-uri") - -} - Set.singleton "network-uri" - , allowedPackage = const $ Right () - , useGlobalDatabase = False - , skippedTests = - Set.insert (PackageName "ReadArgs") $ -- old version of hspec - Set.insert (PackageName "ersatz") $ -- old QuickCheck - if version >= GhcMajorVersion 7 8 - then Set.fromList - [ PackageName "punycode" -- pulls in encoding - ] - else Set.empty - , selectGhcVersion = version - , selectTarballDir = "patching/tarballs" - , selectUnderlayPackageDirs = [] - } - -select :: SelectSettings -> IO BuildPlan -select settings' = do - ii <- getInstallInfo settings' - - bt <- - case iiBuildTools ii of - Left s -> error $ "Could not topologically sort build tools: " ++ s - Right x -> return x - - return BuildPlan - { bpTools = bt - , bpPackages = iiPackages ii - , bpOptionalCore = iiOptionalCore ii - , bpCore = iiCore ii - , bpSkippedTests = skippedTests settings' - , bpExpectedFailures = expectedFailures settings' - } - --- | Get all of the build tools required. -iiBuildTools :: InstallInfo -> Either String [String] -iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } = - fmap (map packageVersionString) - $ topSort - $ map addDependencies - $ filter (flip Set.notMember coreTools . fst) - $ Set.toList - $ Set.fromList - $ mapMaybe (flip Map.lookup buildToolMap) - $ Set.toList - $ Set.unions - $ map piBuildToolsAll - $ Map.elems - $ Map.filterWithKey isSelected m - where - isSelected name _ = name `Set.member` selected - selected = Set.fromList $ Map.keys packages - - -- Build tools shipped with GHC which we should not attempt to build - -- ourselves. - coreTools = Set.fromList $ map PackageName $ words "hsc2hs" - - -- The map from build tool name to the package it comes from. - buildToolMap :: Map Executable (PackageName, Version) - buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m - - toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version) - toBuildToolMap (pn, pi) = Map.unions - $ map (flip Map.singleton (pn, piVersion pi)) - $ Set.toList - $ piExecs pi - - addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version)) - addDependencies (pn, pv) = - ((pn, pv), deps) - where - deps = - case Map.lookup pn m of - Nothing -> Set.empty - Just pi -> Set.fromList - $ mapMaybe (flip Map.lookup buildToolMap) - $ Set.toList - $ piBuildToolsExe pi `Set.union` manualDeps - - manualDeps - | pn == PackageName "c2hs" = Set.singleton $ Executable "happy" - | otherwise = Set.empty - -topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a] -topSort orig = - uncurry go . partitionEithers . map (splitter . limitDeps) $ orig - where - splitter (x, y) - | Set.null y = Left x - | otherwise = Right (x, y) - - go x [] = Right x - go [] y = Left $ "The following form a cycle: " ++ show (map fst y) - go (x:xs) ys = do - let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys - rest <- go (xs ++ xs') ys' - return $ x : rest - - dropDep x (y, z) = (y, Set.delete x z) - - allVertices = Set.fromList $ map fst orig - limitDeps (x, y) = (x, Set.intersection allVertices y) diff --git a/Stackage/ServerFiles.hs b/Stackage/ServerFiles.hs deleted file mode 100644 index bd08900c..00000000 --- a/Stackage/ServerFiles.hs +++ /dev/null @@ -1,104 +0,0 @@ --- | Create the files necessary for Stackage server. -module Stackage.ServerFiles - ( createHackageFile - ) where - -import Stackage.Util -import Stackage.Types -import qualified Data.Map as Map -import Control.Exception (throwIO) -import qualified Codec.Archive.Tar as Tar -import qualified Data.ByteString.Lazy as L -import Control.Arrow (second) -import Control.Monad (unless) -import Distribution.Text (display) -import System.Directory (doesFileExist) -import System.FilePath ((), (<.>)) -import System.IO (Handle, hPutStrLn, hPutStr) - -createHackageFile :: Bool -- ^ inclusive? - -> Bool -- ^ haskell platform? - -> InstallInfo - -> String -- ^ GHC version - -> String -- ^ date - -> Handle -- ^ hackage - -> Handle -- ^ tarballs - -> IO () -createHackageFile isInc hp ii ghcVer date hackageH tarballH = do - let stackageFP = concat - [ "../ghc-" - , ghcVer - , if hp then "hp" else "" - , "-" - , date - , if isInc then "-inclusive" else "-exclusive" - , ".stackage" - ] - hPutStr tarballH $ concat - [ "#!/bin/bash -ex\n\ntar czfv " - , stackageFP - , " hackage desc slug ../build*" - ] - indextargz <- getTarballName - indexLBS <- L.readFile indextargz - loop $ Tar.read indexLBS - hPutStrLn tarballH "" - hPutStrLn tarballH $ concat - [ "runghc ../stackage-upload.hs " - , stackageFP - , " unstable-ghc" - , filter (/= '.') ghcVer - , if hp then "hp" else "" - , if isInc then "-inclusive" else "-exclusive" - ] - - unless isInc $ do - -- Add in some OS-specific package/version combos to work with - -- non-Linux systems. - hPutStrLn hackageH "hfsevents-0.1.5" - hPutStrLn hackageH "Win32-notify-0.3" - where - selected = Map.fromList . map toStrs . Map.toList $ - fmap spiVersion (iiPackages ii) - `Map.union` iiOptionalCore ii - `Map.union` Map.mapMaybe id (iiCore ii) - - toStrs (PackageName name, version) = (name, display version) - - loop Tar.Done = return () - loop (Tar.Fail e) = throwIO e - loop (Tar.Next e es) = go e >> loop es - - go e = - case parsePair $ Tar.entryPath e of - Nothing -> return () - Just (name, version) -> - case Map.lookup name selected of - Just version' - | version == version' -> emit True name version - | otherwise -> return () - Nothing - | isInc -> emit False name version - | otherwise -> return () - - emit usePatch name version = do - exists <- if usePatch then doesFileExist tarball else return False - if exists - then hPutStr tarballH $ ' ' : ".." tarball - else hPutStrLn hackageH base - where - base = concat [name, "-", version] - tarball = "patching" "tarballs" base <.> "tar" <.> "gz" - -parsePair :: String -> Maybe (String, String) -parsePair s = - case splitOn '/' s of - [name, version, cabal] | name ++ ".cabal" == cabal -> Just (name, version) - _ -> Nothing - -splitOn :: Eq a => a -> [a] -> [[a]] -splitOn _ [] = [] -splitOn c x = - y : splitOn c z - where - (y, z) = second (drop 1) $ break (== c) x diff --git a/Stackage/Tarballs.hs b/Stackage/Tarballs.hs deleted file mode 100644 index df48f839..00000000 --- a/Stackage/Tarballs.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Stackage.Tarballs - ( makeTarballs - ) where - -import qualified Codec.Archive.Tar as Tar -import qualified Data.ByteString.Lazy as L -import qualified Data.Map as Map -import qualified Data.Set as Set -import Stackage.Types -import Stackage.Util -import System.Directory (createDirectoryIfMissing) -import System.FilePath (takeDirectory) - -makeTarballs :: BuildPlan -> IO () -makeTarballs bp = do - putStrLn "Building tarballs" - tarName <- getTarballName - origEntries <- fmap Tar.read $ L.readFile tarName - (stableEntries, extraEntries) <- loop id id origEntries - - (stableTar, extraTar) <- getStackageTarballNames - - createDirectoryIfMissing True $ takeDirectory stableTar - L.writeFile stableTar $ Tar.write stableEntries - - createDirectoryIfMissing True $ takeDirectory extraTar - L.writeFile extraTar $ Tar.write extraEntries - where - -- Using "error . show" for compatibility with tar 0.3 and 0.4 - loop _ _ (Tar.Fail err) = error $ show err - loop stable extra Tar.Done = return (stable [], extra []) - loop stable extra (Tar.Next e es) = - loop stable' extra' es - where - (stable', extra') = - case getPackageVersion e of - Nothing -> (stable, extra) - Just (package, version) -> - case Map.lookup package $ bpPackages bp of - Just spi - | version == spiVersion spi -> (stable . (e:), extra) - | otherwise -> (stable, extra) - Nothing - | package `Map.member` bpCore bp -> (stable, extra) - | otherwise -> (stable, extra . (e:)) diff --git a/Stackage/Test.hs b/Stackage/Test.hs deleted file mode 100644 index 19210abe..00000000 --- a/Stackage/Test.hs +++ /dev/null @@ -1,298 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Stackage.Test - ( runTestSuites - ) where - -import qualified Control.Concurrent as C -import Control.Exception (Exception, SomeException, handle, throwIO, IOException, try) -import Control.Monad (replicateM, unless, when, forM_) -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Control.Monad.Trans.Writer as W -import Distribution.Package (Dependency (Dependency)) -import Data.Version (parseVersion, Version (Version)) -import Data.Typeable (Typeable) -import Stackage.Types -import Stackage.Util -import System.Directory (copyFile, createDirectory, - createDirectoryIfMissing, doesFileExist, findExecutable, - getDirectoryContents, removeFile, - renameDirectory, canonicalizePath) -import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath ((<.>), (), takeDirectory) -import System.IO (IOMode (WriteMode, AppendMode), - withBinaryFile) -import System.Process (readProcess, runProcess, waitForProcess, createProcess, proc, cwd) -import Text.ParserCombinators.ReadP (readP_to_S) -import Data.IORef (IORef, readIORef, atomicModifyIORef, newIORef) -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as L8 -import qualified Distribution.PackageDescription as PD -import Distribution.PackageDescription.Parse (ParseResult (ParseOk), - parsePackageDescription) - -runTestSuites :: BuildSettings -> BuildPlan -> IO () -runTestSuites settings' bp = do - settings <- fixBuildSettings settings' - let selected' = Map.filterWithKey notSkipped $ bpPackages bp - let testdir = "runtests" - docdir = "haddock" - rm_r testdir - rm_r docdir - createDirectory testdir - createDirectory docdir - - putStrLn "Determining package dependencies" - selected <- mapM (addDependencies settings (Map.keysSet selected') testdir) - $ Map.toList selected' - putStrLn "Running test suites" - - copyBuiltInHaddocks docdir - - cabalVersion <- getCabalVersion - haddockFilesRef <- newIORef [] - allPass <- parFoldM - (testWorkerThreads settings) - (runTestSuite cabalVersion settings testdir docdir bp haddockFilesRef) - (&&) - True - selected - unless allPass $ error $ "There were failures, please see the logs in " ++ testdir - where - notSkipped p _ = p `Set.notMember` bpSkippedTests bp - -addDependencies :: BuildSettings - -> Set PackageName -- ^ all packages to be installed - -> FilePath -- ^ testdir - -> (PackageName, SelectedPackageInfo) - -> IO (PackageName, Set PackageName, SelectedPackageInfo) -addDependencies settings allPackages testdir (packageName, spi) = do - package' <- replaceTarball (tarballDir settings) package - deps <- handle (\e -> print (e :: IOException) >> return Set.empty) - $ getDeps allPackages testdir packageName package package' - return (packageName, deps, spi) - where - package = packageVersionString (packageName, spiVersion spi) - -getDeps :: Set PackageName -- ^ all packages to be installed - -> FilePath -> PackageName -> String -> String -> IO (Set PackageName) -getDeps allPackages testdir (PackageName name) nameVer loc = do - (Nothing, Nothing, Nothing, ph) <- createProcess - (proc "cabal" ["unpack", loc, "--verbose=0"]) { cwd = Just testdir } - ec <- waitForProcess ph - unless (ec == ExitSuccess) $ error $ "Unable to unpack: " ++ loc - lbs <- L.readFile $ testdir nameVer name <.> "cabal" - case parsePackageDescription $ L8.unpack lbs of - ParseOk _ gpd -> return $ Set.intersection allPackages $ allLibraryDeps gpd - _ -> return Set.empty - -allLibraryDeps :: PD.GenericPackageDescription -> Set PackageName -allLibraryDeps = - maybe Set.empty (W.execWriter . goTree) . PD.condLibrary - where - goTree tree = do - mapM_ goDep $ PD.condTreeConstraints tree - forM_ (PD.condTreeComponents tree) $ \(_, y, z) -> do - goTree y - maybe (return ()) goTree z - - goDep (Dependency pn _) = W.tell $ Set.singleton pn - -getCabalVersion :: IO CabalVersion -getCabalVersion = do - output <- readProcess "cabal" ["--numeric-version"] "" - case filter (null . snd) $ readP_to_S parseVersion $ filter notCRLF output of - (Version (x:y:_) _, _):_ -> return $ CabalVersion x y - _ -> error $ "Invalid cabal version: " ++ show output - where - notCRLF '\n' = False - notCRLF '\r' = False - notCRLF _ = True - -parFoldM :: Int -- ^ number of threads - -> ((PackageName, payload) -> IO c) - -> (a -> c -> a) - -> a - -> [(PackageName, Set PackageName, payload)] - -> IO a -parFoldM threadCount0 f g a0 bs0 = do - ma <- C.newMVar a0 - mbs <- C.newMVar bs0 - signal <- C.newEmptyMVar - completed <- newIORef Set.empty - tids <- replicateM threadCount0 $ C.forkIO $ worker completed ma mbs signal - wait threadCount0 signal tids - - unrun <- C.takeMVar mbs - when (not $ null unrun) $ - error $ "The following tests were not run: " ++ unwords - [x | (PackageName x, _, _) <- unrun] - C.takeMVar ma - where - worker completedRef ma mbs signal = - handle - (C.putMVar signal . Just) - (loop >> C.putMVar signal Nothing) - where - loop = do - mb <- C.modifyMVar mbs $ \bs -> do - completed <- readIORef completedRef - return $ case findReady completed bs of - -- There's a workload ready with no deps - Just (b, bs') -> (bs', Just b) - -- No workload with no deps - Nothing -> (bs, Nothing) - case mb of - Nothing -> return () - Just (name, _, payload) -> do - c <- f (name, payload) - C.modifyMVar_ ma $ \a -> return $! g a c - atomicModifyIORef completedRef $ \s -> (Set.insert name s, ()) - loop - wait threadCount signal tids - | threadCount == 0 = return () - | otherwise = do - me <- C.takeMVar signal - case me of - Nothing -> wait (threadCount - 1) signal tids - Just e -> do - mapM_ C.killThread tids - throwIO (e :: SomeException) - --- | Find a workload whose dependencies have been met. -findReady :: Ord key - => Set key -- ^ workloads already complete - -> [(key, Set key, value)] - -> Maybe ((key, Set key, value), [(key, Set key, value)]) -findReady completed = - loop id - where - loop _ [] = Nothing - loop front (x@(_, deps, _):xs) - | Set.null $ Set.difference deps completed = Just (x, front xs) - | otherwise = loop (front . (x:)) xs - -data TestException = TestException - deriving (Show, Typeable) -instance Exception TestException - -data CabalVersion = CabalVersion Int Int - deriving (Eq, Ord, Show) - -runTestSuite :: CabalVersion - -> BuildSettings - -> FilePath -- ^ testdir - -> FilePath -- ^ docdir - -> BuildPlan - -> IORef [(String, FilePath)] -- ^ .haddock files - -> (PackageName, SelectedPackageInfo) - -> IO Bool -runTestSuite cabalVersion settings testdir docdir - bp haddockFilesRef (packageName, SelectedPackageInfo {..}) = do - -- Set up a new environment that includes the sandboxed bin folder in PATH. - env' <- getModifiedEnv settings - let menv = Just $ addSandbox env' - addSandbox = (("HASKELL_PACKAGE_SANDBOX", packageDir settings):) - - let run cmd args wdir handle' = do - ph <- runProcess cmd args (Just wdir) menv Nothing (Just handle') (Just handle') - ec <- waitForProcess ph - unless (ec == ExitSuccess) $ throwIO TestException - - passed <- handle (\TestException -> return False) $ do - case cabalFileDir settings of - Nothing -> return () - Just cfd -> do - let PackageName name = packageName - basename = name ++ ".cabal" - src = dir basename - dst = cfd basename - createDirectoryIfMissing True cfd - copyFile src dst - getHandle WriteMode $ run "cabal" (addCabalArgs settings BSTest ["configure", "--enable-tests"]) dir - - -- Try building docs first in case tests have an expected failure. - when (buildDocs settings) $ do - -- https://github.com/gtk2hs/gtk2hs/issues/79 - when (packageName `Set.member` buildBeforeHaddock) $ - getHandle AppendMode $ run "cabal" ["build"] dir - - hfs <- readIORef haddockFilesRef - let hfsOpts = flip map hfs $ \(pkgVer, hf) -> concat - [ "--haddock-options=--read-interface=" - , "../" - , pkgVer - , "/," - , hf - ] - getHandle AppendMode $ run "cabal" - ( "haddock" - : "--hyperlink-source" - : "--html" - : "--hoogle" - -- FIXME is this redundant with read-interface above? - : "--html-location=../$pkg-$version/" - : hfsOpts) dir - let PackageName packageName' = packageName - handle (\(_ :: IOException) -> return ()) $ renameDirectory - (dir "dist" "doc" "html" packageName') - (docdir package) - - enewPath <- try $ canonicalizePath $ docdir package packageName' <.> "haddock" - case enewPath :: Either IOException FilePath of - Left _ -> return () -- print e - Right newPath -> atomicModifyIORef haddockFilesRef $ \hfs' - -> ((package, newPath) : hfs', ()) - - when spiHasTests $ do - getHandle AppendMode $ run "cabal" ["build"] dir - getHandle AppendMode $ run "cabal" (concat - [ ["test"] - , if cabalVersion >= CabalVersion 1 20 - then ["--show-details=streaming"] -- FIXME temporary workaround for https://github.com/haskell/cabal/issues/1810 - else [] - ]) dir - return True - let expectedFailure = packageName `Set.member` bpExpectedFailures bp - if passed - then do - removeFile logfile - when expectedFailure $ putStrLn $ " " ++ package ++ " passed, but I didn't think it would." - else unless expectedFailure $ putStrLn $ concat - [ "Test suite failed: " - , package - , "(" - , unMaintainer spiMaintainer - , githubMentions spiGithubUser - , ")" - ] - rm_r dir - return $! passed || expectedFailure - where - logfile = testdir package <.> "log" - dir = testdir package - getHandle mode = withBinaryFile logfile mode - package = packageVersionString (packageName, spiVersion) - - buildBeforeHaddock = Set.fromList $ map PackageName $ words =<< - [ "gio gtk" - ] - -copyBuiltInHaddocks docdir = do - Just ghc <- findExecutable "ghc" - copyTree (takeDirectory ghc "../share/doc/ghc/html/libraries") docdir - where - copyTree src dest = do - entries <- fmap (filter (\s -> s /= "." && s /= "..")) - $ getDirectoryContents src - forM_ entries $ \entry -> do - let src' = src entry - dest' = dest entry - isFile <- doesFileExist src' - if isFile - then copyFile src' dest' - else do - createDirectory dest' - copyTree src' dest' diff --git a/Stackage/Types.hs b/Stackage/Types.hs deleted file mode 100644 index 9fe76d45..00000000 --- a/Stackage/Types.hs +++ /dev/null @@ -1,165 +0,0 @@ -module Stackage.Types - ( module X - , module Stackage.Types - ) where - -import Data.Map as X (Map) -import Data.Map (unionWith) -import Data.Monoid (Monoid (..)) -import Data.Set as X (Set) -import Data.Version as X (Version) -import Distribution.Package as X (PackageIdentifier (..), - PackageName (..)) -import Distribution.PackageDescription (GenericPackageDescription) -import Distribution.Version as X (VersionRange (..)) -import Distribution.Version (intersectVersionRanges) - -newtype PackageDB = PackageDB (Map PackageName PackageInfo) - deriving (Show, Eq) - -instance Monoid PackageDB where - mempty = PackageDB mempty - PackageDB x `mappend` PackageDB y = - PackageDB $ unionWith newest x y - where - newest pi1 pi2 - | piVersion pi1 > piVersion pi2 = pi1 - | otherwise = pi2 - -data PackageInfo = PackageInfo - { piVersion :: Version - , piDeps :: Map PackageName VersionRange - , piHasTests :: Bool - , piBuildToolsExe :: Set Executable -- ^ required just for building executable/lib - , piBuildToolsAll :: Set Executable -- ^ required for all stanzas - , piGPD :: Maybe GenericPackageDescription - , piExecs :: Set Executable - , piGithubUser :: [String] - } - deriving (Show, Eq) - -newtype Executable = Executable String - deriving (Show, Eq, Ord) - --- | Information on a package we're going to build. -data BuildInfo = BuildInfo - { biVersion :: Version - , biUsers :: [PackageName] - , biMaintainer :: Maintainer - , biDeps :: Map PackageName VersionRange - , biGithubUser :: [String] - , biHasTests :: Bool - } - -data HaskellPlatform = HaskellPlatform - { hpcore :: Set PackageIdentifier - , hplibs :: Set PackageIdentifier - } - deriving (Show, Eq, Ord) -instance Monoid HaskellPlatform where - mempty = HaskellPlatform mempty mempty - HaskellPlatform a x `mappend` HaskellPlatform b y = HaskellPlatform (mappend a b) (mappend x y) - -data InstallInfo = InstallInfo - { iiCore :: Map PackageName (Maybe Version) - , iiPackages :: Map PackageName SelectedPackageInfo - , iiOptionalCore :: Map PackageName Version - -- ^ This is intended to hold onto packages which might be automatically - -- provided in the global package database. In practice, this would be - -- Haskell Platform packages provided by distributions. - , iiPackageDB :: PackageDB - } - -data SelectedPackageInfo = SelectedPackageInfo - { spiVersion :: Version - , spiMaintainer :: Maintainer - , spiGithubUser :: [String] - , spiHasTests :: Bool - } - deriving (Show, Read) - -data BuildPlan = BuildPlan - { bpTools :: [String] - , bpPackages :: Map PackageName SelectedPackageInfo - , bpCore :: Map PackageName (Maybe Version) - , bpOptionalCore :: Map PackageName Version - -- ^ See 'iiOptionalCore' - , bpSkippedTests :: Set PackageName - , bpExpectedFailures :: Set PackageName - -- ^ Expected test failures. Unlike SkippedTests, we should still try to - -- build them. - } - --- | Email address of a Stackage maintainer. -newtype Maintainer = Maintainer { unMaintainer :: String } - deriving (Show, Eq, Ord, Read) - -data SelectSettings = SelectSettings - { haskellPlatformDir :: FilePath - , flags :: Map PackageName Version -> Set String - -- ^ Compile flags which should be turned on. Takes a Map providing the - -- core packages so that flags can be set appropriately. - , disabledFlags :: Set String - -- ^ Compile flags which should always be disabled. - , extraCore :: Set PackageName - , ignoreUpgradeableCore :: Bool - -- ^ Do not pin down the versions of upgradeable core packages. - , requireHaskellPlatform :: Bool - , allowedPackage :: GenericPackageDescription -> Either String () - -- ^ Checks if a package is allowed into the distribution. By default, we - -- allow all packages in, though this could be used to filter out certain - -- untrusted packages, or packages with an unacceptable license. - -- - -- Returns a reason for stripping in Left, or Right if the package is - -- allowed. - , expectedFailures :: Set PackageName - , excludedPackages :: Set PackageName - -- ^ Packages which should be dropped from the list of stable packages, - -- even if present via the Haskell Platform or @stablePackages@. If these - -- packages are dependencies of others, they will still be included. - , stablePackages :: Bool -- require Haskell Platform? - -> Map PackageName (VersionRange, Maintainer) - , useGlobalDatabase :: Bool - -- ^ Instead of checking the Haskell Platform file for core packages, query - -- the global database. For this to be reliable, you should only have - -- default packages in your global database. Default is @False@. - , skippedTests :: Set PackageName - -- ^ Do not build or run test suites, usually in order to avoid a - -- dependency. - , selectGhcVersion :: GhcMajorVersion - , selectTarballDir :: FilePath - -- ^ Directory containing replacement tarballs. - , selectUnderlayPackageDirs :: [FilePath] - -- ^ Additional package directories to reference - } - -data BuildStage = BSTools | BSBuild | BSTest - -data BuildSettings = BuildSettings - { sandboxRoot :: FilePath - , extraArgs :: BuildStage -> [String] - , testWorkerThreads :: Int - -- ^ How many threads to spawn for running test suites. - , buildDocs :: Bool - -- ^ Build docs as part of the test procedure. - , tarballDir :: FilePath - -- ^ Directory containing replacement tarballs. - , cabalFileDir :: Maybe FilePath - -- ^ Directory to place cabal files in - , underlayPackageDirs :: [FilePath] - -- ^ Additional package directories to reference - } - --- | A wrapper around a @Map@ providing a better @Monoid@ instance. -newtype PackageMap = PackageMap { unPackageMap :: Map PackageName (VersionRange, Maintainer) } - -instance Monoid PackageMap where - mempty = PackageMap mempty - PackageMap x `mappend` PackageMap y = - PackageMap $ unionWith go x y - where - go (r1, m1) (r2, _) = (intersectVersionRanges r1 r2, m1) - --- | GHC major version. For example, for GHC 7.4.2, this would be 7 4. -data GhcMajorVersion = GhcMajorVersion Int Int - deriving (Show, Ord, Eq) diff --git a/Stackage/Util.hs b/Stackage/Util.hs deleted file mode 100644 index 2a7293a2..00000000 --- a/Stackage/Util.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE CPP #-} -module Stackage.Util where - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Tar.Entry as TarEntry -import Control.Monad (guard, when) -import Data.Char (isSpace, toUpper) -import Data.List (intercalate, stripPrefix) -import qualified Data.Map as Map -import Data.Maybe (mapMaybe) -import qualified Data.Set as Set -import Data.Version (showVersion) -import Distribution.License (License (..)) -import qualified Distribution.Package as P -import qualified Distribution.PackageDescription as PD -import Distribution.Text (display, simpleParse) -import Distribution.Version (thisVersion) -import Stackage.Types -import System.Directory (doesDirectoryExist, - removeDirectoryRecursive, - getAppUserDataDirectory, - canonicalizePath, - createDirectoryIfMissing, doesFileExist) -import System.Environment (getEnvironment) -import System.FilePath ((), (<.>)) - --- | Allow only packages with permissive licenses. -allowPermissive :: [String] -- ^ list of explicitly allowed packages - -> PD.GenericPackageDescription - -> Either String () -allowPermissive allowed gpd - | P.pkgName (PD.package $ PD.packageDescription gpd) `elem` map PackageName allowed = Right () - | otherwise = - case PD.license $ PD.packageDescription gpd of - BSD3 -> Right () - MIT -> Right () - PublicDomain -> Right () - l -> Left $ "Non-permissive license: " ++ display l - -identsToRanges :: Set PackageIdentifier -> Map PackageName (VersionRange, Maintainer) -identsToRanges = - Map.unions . map go . Set.toList - where - go (PackageIdentifier package version) = Map.singleton package (thisVersion version, Maintainer "Haskell Platform") - -packageVersionString :: (PackageName, Version) -> String -packageVersionString (PackageName p, v) = concat [p, "-", showVersion v] - -rm_r :: FilePath -> IO () -rm_r fp = do - exists <- doesDirectoryExist fp - when exists $ removeDirectoryRecursive fp - -getCabalRoot :: IO FilePath -getCabalRoot = getAppUserDataDirectory "cabal" - --- | Name of the 00-index.tar downloaded from Hackage. -getTarballName :: IO FilePath -getTarballName = do - c <- getCabalRoot - configLines <- fmap lines $ readFile (c "config") - case mapMaybe getRemoteCache configLines of - [x] -> return $ x "hackage.haskell.org" "00-index.tar" - [] -> error $ "No remote-repo-cache found in Cabal config file" - _ -> error $ "Multiple remote-repo-cache entries found in Cabal config file" - where - getRemoteCache s = do - ("remote-repo-cache", ':':v) <- Just $ break (== ':') s - Just $ reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace v - -stableRepoName, extraRepoName :: String -stableRepoName = "stackage" -extraRepoName = "stackage-extra" - --- | Locations for the stackage and stackage-extra tarballs -getStackageTarballNames :: IO (FilePath, FilePath) -getStackageTarballNames = do - c <- getCabalRoot - let f x = c "packages" x "00-index.tar" - return (f stableRepoName, f extraRepoName) - -getPackageVersion :: Tar.Entry -> Maybe (PackageName, Version) -getPackageVersion e = do - let (package', s1) = break (== '/') fp - package = PackageName package' - s2 <- stripPrefix "/" s1 - let (version', s3) = break (== '/') s2 - version <- simpleParse version' - s4 <- stripPrefix "/" s3 - guard $ s4 == package' ++ ".cabal" - Just (package, version) - where - fp = TarEntry.fromTarPathToPosixPath $ TarEntry.entryTarPath e - --- | If a package cannot be parsed or is not found, the default value for --- whether it has a test suite. We default to @True@ since, worst case --- scenario, this just means a little extra time trying to run a suite that's --- not there. Defaulting to @False@ would result in silent failures. -defaultHasTestSuites :: Bool -defaultHasTestSuites = True - -packageDir, libDir, binDir, dataDir, docDir :: BuildSettings -> FilePath -packageDir = ( "package-db") . sandboxRoot -libDir = ( "lib") . sandboxRoot -binDir = ( "bin") . sandboxRoot -dataDir = ( "share") . sandboxRoot -docDir x = sandboxRoot x "share" "doc" "$pkgid" - -addCabalArgsOnlyGlobal :: BuildSettings -> [String] -> [String] -addCabalArgsOnlyGlobal settings rest - = "--package-db=clear" - : "--package-db=global" - : map ("--package-db=" ++) (underlayPackageDirs settings) - ++ rest - -addCabalArgs :: BuildSettings -> BuildStage -> [String] -> [String] -addCabalArgs settings bs rest - = addCabalArgsOnlyGlobal settings - $ ("--package-db=" ++ packageDir settings ++ toolsSuffix) - : ("--libdir=" ++ libDir settings ++ toolsSuffix) - : ("--bindir=" ++ binDir settings) - : ("--datadir=" ++ dataDir settings) - : ("--docdir=" ++ docDir settings ++ toolsSuffix) - : extraArgs settings bs ++ rest - where - toolsSuffix = - case bs of - BSTools -> "-tools" - _ -> "" - --- | Modified environment that adds our sandboxed bin folder to PATH. -getModifiedEnv :: BuildSettings -> IO [(String, String)] -getModifiedEnv settings = do - fmap (map $ fixEnv $ binDir settings) getEnvironment - where - fixEnv :: FilePath -> (String, String) -> (String, String) - fixEnv bin (p, x) - -- Thank you Windows having case-insensitive environment variables... - | map toUpper p == "PATH" = (p, bin ++ pathSep : x) - | otherwise = (p, x) - - -- | Separate for the PATH environment variable - pathSep :: Char -#ifdef mingw32_HOST_OS - pathSep = ';' -#else - pathSep = ':' -#endif - --- | Minor fixes, such as making paths absolute. --- --- Note: creates the sandbox root in the process. -fixBuildSettings :: BuildSettings -> IO BuildSettings -fixBuildSettings settings' = do - let root' = sandboxRoot settings' - createDirectoryIfMissing True root' - root <- canonicalizePath root' - return settings' { sandboxRoot = root } - --- | Check if a tarball exists in the tarball directory and, if so, use that --- instead of the given name. -replaceTarball :: FilePath -- ^ tarball directory - -> String - -> IO String -replaceTarball tarballdir pkgname = do - exists <- doesFileExist fp - if exists - then canonicalizePath fp - else return pkgname - where - fp = tarballdir pkgname <.> "tar.gz" - -githubMentions :: [String] -> String -githubMentions = intercalate "," . map ('@' :) diff --git a/Stackage2/BuildConstraints.hs b/Stackage2/BuildConstraints.hs index 28de49c8..276515b7 100644 --- a/Stackage2/BuildConstraints.hs +++ b/Stackage2/BuildConstraints.hs @@ -12,14 +12,17 @@ module Stackage2.BuildConstraints , defaultBuildConstraints ) where +import Control.Monad.Writer.Strict (execWriter, tell) import Data.Aeson -import qualified Data.Map as Map -import Distribution.System (Arch, OS) +import qualified Data.Map as Map +import Data.Yaml (decodeEither', decodeFileEither) +import Distribution.Package (Dependency (..)) +import Distribution.System (Arch, OS) import qualified Distribution.System -import Distribution.Version (anyVersion) -import qualified Stackage.Config as Old -import qualified Stackage.Select as Old -import qualified Stackage.Types as Old +import Distribution.Version (anyVersion) +import Distribution.Version (anyVersion) +import Filesystem (isFile) +import Network.HTTP.Client (Manager, httpLbs, responseBody) import Stackage2.CorePackages import Stackage2.Prelude @@ -80,6 +83,9 @@ data BuildConstraints = BuildConstraints , bcPackageConstraints :: PackageName -> PackageConstraints , bcSystemInfo :: SystemInfo + + , bcGithubUsers :: Map Text (Set Text) + -- ^ map an account to set of pingees } data PackageConstraints = PackageConstraints @@ -113,50 +119,19 @@ instance FromJSON PackageConstraints where return PackageConstraints {..} -- | The proposed plan from the requirements provided by contributors. -defaultBuildConstraints :: IO BuildConstraints -defaultBuildConstraints = do - bcSystemInfo <- getSystemInfo - oldGhcVer <- - case siGhcVersion bcSystemInfo of - Version (x:y:_) _ -> return $ Old.GhcMajorVersion x y - _ -> error $ "Didn't not understand GHC version: " ++ show (siGhcVersion bcSystemInfo) - - - let oldSettings = Old.defaultSelectSettings oldGhcVer False - oldStable = Old.defaultStablePackages oldGhcVer False - defaultGlobalFlags = asMap $ mapFromList $ - map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++ - map (, False) (map FlagName $ setToList $ Old.disabledFlags oldSettings) - expectedFailures = Old.defaultExpectedFailures oldGhcVer False ++ - newExpectedFailures - skippedTests = - old ++ extraSkippedTests - where - old = setFromList $ map unPackageName $ setToList $ Old.skippedTests oldSettings - - bcPackages = Map.keysSet oldStable - bcPackageConstraints name = - PackageConstraints {..} - where - mold = lookup name $ oldStable - - pcVersionRange = simplifyVersionRange $ maybe anyVersion fst mold - pcMaintainer = (Maintainer . pack . Old.unMaintainer . snd) <$> mold - pcTests - | unPackageName name `member` skippedTests = Don'tBuild - | name `member` expectedFailures = ExpectFailure - | otherwise = ExpectSuccess - - pcBuildBenchmarks = unPackageName name `notMember` skippedBenchs - - -- FIXME ultimately separate haddock and test failures in specification - pcHaddocks - | name `member` expectedFailures = ExpectFailure - | otherwise = ExpectSuccess - - pcFlagOverrides = packageFlags name ++ defaultGlobalFlags - - return BuildConstraints {..} +-- +-- Checks the current directory for a build-constraints.yaml file and uses it +-- if present. If not, downloads from Github. +defaultBuildConstraints :: Manager -> IO BuildConstraints +defaultBuildConstraints man = do + e <- isFile fp + if e + then decodeFileEither (fpToString fp) >>= either throwIO toBC + else httpLbs req man >>= + either throwIO toBC . decodeEither' . toStrict . responseBody + where + fp = "build-constraints.yaml" + req = "https://raw.githubusercontent.com/fpco/stackage/master/build-constraints.yaml" getSystemInfo :: IO SystemInfo getSystemInfo = do @@ -169,30 +144,74 @@ getSystemInfo = do siOS = Distribution.System.Linux siArch = Distribution.System.X86_64 -packageFlags :: PackageName -> Map FlagName Bool -packageFlags (PackageName "mersenne-random-pure64") = singletonMap (FlagName "small_base") False -packageFlags _ = mempty +loadBuildConstraints fp = decodeFileEither fp >>= either throwIO toBC -extraSkippedTests :: HashSet Text -extraSkippedTests = setFromList $ words =<< - [ "HTTP Octree options" - , "hasql" - , "bloodhound fb" -- require old hspec - , "diagrams-haddock" -- requires old tasty - , "hasql-postgres" -- requires old hasql - , "compdata" -- https://github.com/pa-ba/compdata/issues/4 - ] +data ConstraintFile = ConstraintFile + { cfGlobalFlags :: Map FlagName Bool + , cfPackageFlags :: Map PackageName (Map FlagName Bool) + , cfSkippedTests :: Set PackageName + , cfExpectedTestFailures :: Set PackageName + , cfExpectedHaddockFailures :: Set PackageName + , cfSkippedBenchmarks :: Set PackageName + , cfPackages :: Map Maintainer (Vector Dependency) + , cfGithubUsers :: Map Text (Set Text) + } -skippedBenchs :: HashSet Text -skippedBenchs = setFromList $ words =<< - [ "machines criterion-plus graphviz lifted-base pandoc stm-containers uuid" - , "cases hasql-postgres" -- pulls in criterion-plus, which has restrictive upper bounds - -- https://github.com/vincenthz/hs-crypto-cipher/issues/46 - , "cipher-aes cipher-blowfish cipher-camellia cipher-des cipher-rc4" - , "hasql" -- sometimes falls out-of-sync on hasql-postgres - ] +instance FromJSON ConstraintFile where + parseJSON = withObject "ConstraintFile" $ \o -> do + cfGlobalFlags <- goFlagMap <$> o .: "global-flags" + cfPackageFlags <- (goPackageMap . fmap goFlagMap) <$> o .: "package-flags" + cfSkippedTests <- getPackages o "skipped-tests" + cfExpectedTestFailures <- getPackages o "expected-test-failures" + cfExpectedHaddockFailures <- getPackages o "expected-haddock-failures" + cfSkippedBenchmarks <- getPackages o "skipped-benchmarks" + cfPackages <- o .: "packages" + >>= mapM (mapM toDep) + . Map.mapKeysWith const Maintainer + cfGithubUsers <- o .: "github-users" + return ConstraintFile {..} + where + goFlagMap = Map.mapKeysWith const FlagName + goPackageMap = Map.mapKeysWith const PackageName + getPackages o name = (setFromList . map PackageName) <$> o .: name -newExpectedFailures :: Set PackageName -newExpectedFailures = setFromList $ map PackageName $ words =<< - [ "cautious-file" -- weird problems with cabal test - ] + toDep :: Monad m => Text -> m Dependency + toDep = either (fail . show) return . simpleParse + +toBC :: ConstraintFile -> IO BuildConstraints +toBC ConstraintFile {..} = do + bcSystemInfo <- getSystemInfo + return BuildConstraints {..} + where + combine (maintainer, range1) (_, range2) = + (maintainer, intersectVersionRanges range1 range2) + revmap = unionsWith combine $ ($ []) $ execWriter + $ forM_ (mapToList cfPackages) + $ \(maintainer, deps) -> forM_ deps + $ \(Dependency name range) -> + tell (singletonMap name (maintainer, range):) + + bcPackages = Map.keysSet revmap + + bcPackageConstraints name = + PackageConstraints {..} + where + mpair = lookup name revmap + pcMaintainer = fmap fst mpair + pcVersionRange = maybe anyVersion snd mpair + pcTests + | name `member` cfSkippedTests = Don'tBuild + | name `member` cfExpectedTestFailures = ExpectFailure + | otherwise = ExpectSuccess + pcBuildBenchmarks = name `notMember` cfSkippedBenchmarks + pcHaddocks + | name `member` cfExpectedHaddockFailures = ExpectFailure + + -- Temporary to match old behavior + | name `member` cfExpectedTestFailures = ExpectFailure + + | otherwise = ExpectSuccess + pcFlagOverrides = fromMaybe mempty (lookup name cfPackageFlags) ++ + cfGlobalFlags + + bcGithubUsers = cfGithubUsers diff --git a/Stackage2/BuildPlan.hs b/Stackage2/BuildPlan.hs index 6bad8037..ef212a32 100644 --- a/Stackage2/BuildPlan.hs +++ b/Stackage2/BuildPlan.hs @@ -32,6 +32,7 @@ data BuildPlan = BuildPlan { bpSystemInfo :: SystemInfo , bpTools :: Vector (PackageName, Version) , bpPackages :: Map PackageName PackagePlan + , bpGithubUsers :: Map Text (Set Text) } deriving (Show, Eq) @@ -51,6 +52,7 @@ instance FromJSON BuildPlan where bpSystemInfo <- o .: "system-info" bpTools <- (o .: "tools") >>= mapM goTool bpPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") + bpGithubUsers <- o .:? "github-users" .!= mempty return BuildPlan {..} where goTool = withObject "Tool" $ \o -> (,) @@ -105,6 +107,7 @@ newBuildPlan bc@BuildConstraints {..} = liftIO $ do { bpSystemInfo = bcSystemInfo , bpTools = tools , bpPackages = packages + , bpGithubUsers = bcGithubUsers } where SystemInfo {..} = bcSystemInfo @@ -182,7 +185,7 @@ mkPackagePlan bc gpd = do return PackagePlan {..} where PackageIdentifier name ppVersion = package $ packageDescription gpd - ppGithubPings = getGithubPings gpd + ppGithubPings = getGithubPings bc gpd ppConstraints = bcPackageConstraints bc name ppUsers = mempty -- must be filled in later diff --git a/Stackage2/CompleteBuild.hs b/Stackage2/CompleteBuild.hs index ec13527c..beba7702 100644 --- a/Stackage2/CompleteBuild.hs +++ b/Stackage2/CompleteBuild.hs @@ -39,11 +39,11 @@ data Settings = Settings , postBuild :: IO () } -getSettings :: BuildType -> IO Settings -getSettings Nightly = do +getSettings :: Manager -> BuildType -> IO Settings +getSettings man Nightly = do day <- tshow . utctDay <$> getCurrentTime let slug' = "nightly-" ++ day - plan' <- defaultBuildConstraints >>= newBuildPlan + plan' <- defaultBuildConstraints man >>= newBuildPlan return Settings { planFile = fpFromText ("nightly-" ++ day) <.> "yaml" , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day @@ -59,7 +59,7 @@ getSettings Nightly = do , plan = plan' , postBuild = return () } -getSettings (LTS bumpType) = do +getSettings man (LTS bumpType) = do Option mlts <- fmap (fmap getMax) $ runResourceT $ sourceDirectory "." $$ foldMapC (Option . fmap Max . parseLTSVer . filename) @@ -70,7 +70,7 @@ getSettings (LTS bumpType) = do case mlts of Nothing -> LTSVer 0 0 Just (LTSVer x _) -> LTSVer (x + 1) 0 - plan' <- defaultBuildConstraints >>= newBuildPlan + plan' <- defaultBuildConstraints man >>= newBuildPlan return (new, plan') Minor -> do old <- maybe (error "No LTS plans found in current directory") return mlts @@ -133,7 +133,7 @@ completeBuild buildType = withManager defaultManagerSettings $ \man -> do hSetBuffering stdout LineBuffering putStrLn $ "Loading settings for: " ++ tshow buildType - Settings {..} <- getSettings buildType + Settings {..} <- getSettings man buildType putStrLn $ "Writing build plan to: " ++ fpToText planFile encodeFile (fpToString planFile) plan diff --git a/Stackage2/ConstraintFile.hs b/Stackage2/ConstraintFile.hs deleted file mode 100644 index 71a8560a..00000000 --- a/Stackage2/ConstraintFile.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, RecordWildCards #-} -module Stackage2.ConstraintFile - ( loadBuildConstraints - ) where - -import Stackage2.Prelude -import Data.Yaml (decodeFileEither) -import Stackage2.BuildConstraints -import Data.Aeson -import qualified Data.Map as Map -import Distribution.Package (Dependency (..)) -import Distribution.Version (anyVersion) -import Control.Monad.Writer.Strict (execWriter, tell) - -loadBuildConstraints fp = decodeFileEither fp >>= either throwIO toBC - -data ConstraintFile = ConstraintFile - { cfGlobalFlags :: Map FlagName Bool - , cfPackageFlags :: Map PackageName (Map FlagName Bool) - , cfSkippedTests :: Set PackageName - , cfExpectedTestFailures :: Set PackageName - , cfExpectedHaddockFailures :: Set PackageName - , cfSkippedBenchmarks :: Set PackageName - , cfPackages :: Map Maintainer (Vector Dependency) - } - -instance FromJSON ConstraintFile where - parseJSON = withObject "ConstraintFile" $ \o -> do - cfGlobalFlags <- goFlagMap <$> o .: "global-flags" - cfPackageFlags <- (goPackageMap . fmap goFlagMap) <$> o .: "package-flags" - cfSkippedTests <- getPackages o "skipped-tests" - cfExpectedTestFailures <- getPackages o "expected-test-failures" - cfExpectedHaddockFailures <- getPackages o "expected-haddock-failures" - cfSkippedBenchmarks <- getPackages o "skipped-benchmarks" - cfPackages <- o .: "packages" - >>= mapM (mapM toDep) - . Map.mapKeysWith const Maintainer - return ConstraintFile {..} - where - goFlagMap = Map.mapKeysWith const FlagName - goPackageMap = Map.mapKeysWith const PackageName - getPackages o name = (setFromList . map PackageName) <$> o .: name - - toDep :: Monad m => Text -> m Dependency - toDep = either (fail . show) return . simpleParse - -toBC :: ConstraintFile -> IO BuildConstraints -toBC ConstraintFile {..} = do - bcSystemInfo <- getSystemInfo - return BuildConstraints {..} - where - combine (maintainer, range1) (_, range2) = - (maintainer, intersectVersionRanges range1 range2) - revmap = unionsWith combine $ ($ []) $ execWriter - $ forM_ (mapToList cfPackages) - $ \(maintainer, deps) -> forM_ deps - $ \(Dependency name range) -> - tell (singletonMap name (maintainer, range):) - - bcPackages = Map.keysSet revmap - - bcPackageConstraints name = - PackageConstraints {..} - where - mpair = lookup name revmap - pcMaintainer = fmap fst mpair - pcVersionRange = maybe anyVersion snd mpair - pcTests - | name `member` cfSkippedTests = Don'tBuild - | name `member` cfExpectedTestFailures = ExpectFailure - | otherwise = ExpectSuccess - pcBuildBenchmarks = name `notMember` cfSkippedBenchmarks - pcHaddocks - | name `member` cfExpectedHaddockFailures = ExpectFailure - - -- Temporary to match old behavior - | name `member` cfExpectedTestFailures = ExpectFailure - - | otherwise = ExpectSuccess - pcFlagOverrides = fromMaybe mempty (lookup name cfPackageFlags) ++ - cfGlobalFlags diff --git a/Stackage2/GithubPings.hs b/Stackage2/GithubPings.hs index 53456443..9b37a759 100644 --- a/Stackage2/GithubPings.hs +++ b/Stackage2/GithubPings.hs @@ -1,18 +1,20 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module Stackage2.GithubPings ( getGithubPings ) where -import Distribution.PackageDescription -import qualified Stackage.Config as Old -import Stackage2.Prelude +import Distribution.PackageDescription +import Stackage2.BuildConstraints +import Stackage2.Prelude -- | Determine accounts to be pinged on Github based on various metadata in the -- package description. -getGithubPings :: GenericPackageDescription -> Set Text -getGithubPings gpd = - setFromList $ map pack $ foldMap Old.convertGithubUser $ +getGithubPings :: BuildConstraints -- ^ for mapping to pingees + -> GenericPackageDescription -> Set Text +getGithubPings bc gpd = + foldMap (\(pack -> name) -> fromMaybe (singletonSet name) (lookup name (bcGithubUsers bc))) $ goHomepage (homepage $ packageDescription gpd) ++ concatMap goRepo (sourceRepos $ packageDescription gpd) where diff --git a/Stackage2/UpdateBuildPlan.hs b/Stackage2/UpdateBuildPlan.hs index 8cd7a0c6..237b73ea 100644 --- a/Stackage2/UpdateBuildPlan.hs +++ b/Stackage2/UpdateBuildPlan.hs @@ -24,6 +24,7 @@ updateBuildConstraints BuildPlan {..} = where bcSystemInfo = bpSystemInfo bcPackages = Map.keysSet bpPackages + bcGithubUsers = bpGithubUsers bcPackageConstraints name = PackageConstraints { pcVersionRange = addBumpRange (maybe anyVersion pcVersionRange moldPC) diff --git a/app/stackage.hs b/app/stackage.hs deleted file mode 100644 index 67f37488..00000000 --- a/app/stackage.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -import Data.Set (fromList) -import Stackage.Build (build, defaultBuildSettings) -import Stackage.BuildPlan (readBuildPlan, writeBuildPlan, writeBuildPlanCsv) -import Stackage.CheckPlan (checkPlan) -import Stackage.GhcPkg (getGhcVersion) -import Stackage.Init (stackageInit) -import Stackage.Select (defaultSelectSettings, select) -import Stackage.Tarballs (makeTarballs) -import Stackage.Test (runTestSuites) -import Stackage.Types -import Stackage.Util (allowPermissive) -import System.Environment (getArgs, getProgName) -import System.IO (hFlush, stdout) - -data SelectArgs = SelectArgs - { excluded :: [String] - , noPlatform :: Bool - , ignoreUpgradeable :: Bool - , onlyPermissive :: Bool - , allowed :: [String] - , buildPlanDest :: FilePath - , buildPlanCsvDest :: FilePath - , globalDB :: Bool - } - -parseSelectArgs :: [String] -> IO SelectArgs -parseSelectArgs = - loop SelectArgs - { excluded = [] - , noPlatform = True - , ignoreUpgradeable = False - , onlyPermissive = False - , allowed = [] - , buildPlanDest = defaultBuildPlan - , buildPlanCsvDest = defaultBuildPlanCsv - , globalDB = False - } - where - loop x [] = return x - loop x ("--exclude":y:rest) = loop x { excluded = y : excluded x } rest - loop x ("--no-platform":rest) = loop x { noPlatform = True } rest - loop x ("--platform":rest) = loop x { noPlatform = False } rest - loop x ("--ignore-upgradeable":rest) = loop x { ignoreUpgradeable = True } rest - loop x ("--only-permissive":rest) = loop x { onlyPermissive = True } rest - loop x ("--allow":y:rest) = loop x { allowed = y : allowed x } rest - loop x ("--build-plan":y:rest) = loop x { buildPlanDest = y } rest - loop x ("--build-plan-csv":y:rest) = loop x { buildPlanCsvDest = y } rest - loop x ("--use-global-db":rest) = loop x { globalDB = True } rest - loop _ (y:_) = error $ "Did not understand argument: " ++ y - -data BuildArgs = BuildArgs - { sandbox :: String - , buildPlanSrc :: FilePath - , extraArgs' :: [String] -> [String] - , noDocs :: Bool - , buildCores :: Maybe Int - , testThreads :: Maybe Int - } - -parseBuildArgs :: GhcMajorVersion -> [String] -> IO BuildArgs -parseBuildArgs version = - loop BuildArgs - { sandbox = sandboxRoot $ defaultBuildSettings Nothing version - , buildPlanSrc = defaultBuildPlan - , extraArgs' = id - , noDocs = False - , buildCores = Nothing - , testThreads = Nothing - } - where - loop x [] = return x - loop x ("--sandbox":y:rest) = loop x { sandbox = y } rest - loop x ("--build-plan":y:rest) = loop x { buildPlanSrc = y } rest - loop x ("--arg":y:rest) = loop x { extraArgs' = extraArgs' x . (y:) } rest - loop x ("--no-docs":rest) = loop x { noDocs = True } rest - loop x ("-j":y:rest) = loop x { buildCores = Just $ read y } rest - loop x ("--test-threads":y:rest) = loop x { testThreads = Just $ read y } rest - loop _ (y:_) = error $ "Did not understand argument: " ++ y - -defaultBuildPlan :: FilePath -defaultBuildPlan = "build-plan.txt" - -defaultBuildPlanCsv :: FilePath -defaultBuildPlanCsv = "build-plan.csv" - -withBuildSettings :: [String] -> (BuildSettings -> BuildPlan -> IO a) -> IO a -withBuildSettings args f = do - version <- getGhcVersion - BuildArgs {..} <- parseBuildArgs version args - bp <- readBuildPlan buildPlanSrc - let bs = defaultBuildSettings buildCores version - modTestThreads settings' = - case testThreads of - Nothing -> settings' - Just t -> settings' { testWorkerThreads = t } - settings = modTestThreads bs - { sandboxRoot = sandbox - , extraArgs = extraArgs' . extraArgs bs - , buildDocs = not noDocs - } - f settings bp - -main :: IO () -main = do - args <- getArgs - case args of - "select":rest -> do - SelectArgs {..} <- parseSelectArgs rest - ghcVersion <- getGhcVersion - bp <- select - (defaultSelectSettings ghcVersion $ not noPlatform) - { excludedPackages = fromList $ map PackageName excluded - , requireHaskellPlatform = not noPlatform - , ignoreUpgradeableCore = ignoreUpgradeable - , allowedPackage = - if onlyPermissive - then allowPermissive allowed - else const $ Right () - , useGlobalDatabase = globalDB - } - writeBuildPlan buildPlanDest bp - writeBuildPlanCsv buildPlanCsvDest bp - ("check":rest) -> withBuildSettings rest checkPlan - ("build":rest) -> withBuildSettings rest build - ("test":rest) -> withBuildSettings rest runTestSuites - ("tarballs":rest) -> withBuildSettings rest $ const makeTarballs - ["init"] -> do - putStrLn "Note: init isn't really ready for prime time use." - putStrLn "Using it may make it impossible to build stackage." - putStr "Are you sure you want continue (y/n)? " - hFlush stdout - x <- getLine - case x of - c:_ | c `elem` "yY" -> stackageInit - _ -> putStrLn "Probably a good decision, exiting." - ["update"] -> stackageInit >> error "FIXME update" - _ -> do - pn <- getProgName - putStrLn $ "Usage: " ++ pn ++ " " - putStrLn "Available commands:" - --putStrLn " update Download updated Stackage databases. Automatically calls init." - --putStrLn " init Initialize your cabal file to use Stackage" - putStrLn " uploads" - putStrLn " select [--no-clean] [--no-platform] [--exclude package...] [--only-permissive] [--allow package] [--build-plan file]" - putStrLn " check [--build-plan file] [--sandbox rootdir] [--arg cabal-arg]" - putStrLn " build [--build-plan file] [--sandbox rootdir] [--arg cabal-arg]" - putStrLn " test [--build-plan file] [--sandbox rootdir] [--arg cabal-arg] [--no-docs]" diff --git a/stackage.cabal b/stackage.cabal index a597a3cd..7cf5dc37 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -13,25 +13,7 @@ cabal-version: >=1.10 library default-language: Haskell2010 - exposed-modules: Stackage.NarrowDatabase - Stackage.LoadDatabase - Stackage.ModuleNameConflict - Stackage.Util - Stackage.Types - Stackage.Config - Stackage.InstallInfo - Stackage.CheckPlan - Stackage.Tarballs - Stackage.Test - Stackage.Build - Stackage.Init - Stackage.BuildPlan - Stackage.CheckCabalVersion - Stackage.Select - Stackage.GhcPkg - Stackage.ServerFiles - - Stackage2.Prelude + exposed-modules: Stackage2.Prelude Stackage2.BuildConstraints Stackage2.CorePackages Stackage2.PackageIndex @@ -77,14 +59,6 @@ library , semigroups , xml-conduit -executable stackage - default-language: Haskell2010 - hs-source-dirs: app - main-is: stackage.hs - build-depends: base - , stackage - , containers - executable stackage-nightly default-language: Haskell2010 hs-source-dirs: app