haskell/stackage
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage.git synced 2026-02-15 15:55:50 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Remove all old code

Browse Source 
Now constraints are always taken from a config file, meaning that
executables do not need to be recompiled for every settings change.
This commit is contained in:
Michael Snoyman 2014-12-15 07:49:25 +02:00
parent 0dfc7ff9d4
commit 11f9b73cf3
25 changed files with 119 additions and 3206 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

116
Stackage/Build.hs
View File

@ -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

186
Stackage/BuildPlan.hs
View File

@ -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
, "\""
]

27
Stackage/CheckCabalVersion.hs
View File

@ -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

73
Stackage/CheckPlan.hs
View File

@ -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

846
Stackage/Config.hs
View File

@ -1,842 +1,8 @@
{-# LANGUAGE CPP #-} {-
module Stackage.Config where
import Control.Monad (when, unless) NOTE: This module is no longer used for tracking packages included in Stackage.
import Control.Monad.Trans.Writer (Writer, execWriter, tell) To simplify the codebase, that information is now stored in the
import Data.Char (toLower) build-constraints.yaml configuration file. The file should be self-explanatory.
import qualified Data.Map as Map Sorry for the inconvenience.
import Data.Maybe (fromMaybe)
import Data.Set (fromList, singleton)
import Distribution.Text (simpleParse)
import Stackage.Types
-- | 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 <michael@fpcomplete.com>") $ 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 <michael@fpcomplete.com>") $ 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 <michael@fpcomplete.com>" "compdata" "< 0.8"
when (ghcVer >= GhcMajorVersion 7 8 && not requireHP) $
mapM_ (add "FP Complete <michael@fpcomplete.com>") $ words =<<
[ "criterion"
, "th-lift singletons th-desugar quickcheck-assertions"
, "distributed-process distributed-process-simplelocalnet" -- cloud-haskell"
]
addRange "FP Complete <michael@fpcomplete.com>" "kure" "<= 2.4.10"
mapM_ (add "Omari Norman <omari@smileystation.com>") $ words
"barecheck rainbow rainbow-tests"
when (ghcVer >= GhcMajorVersion 7 8 && not requireHP) $
mapM_ (add "Omari Norman <omari@smileystation.com>") $ 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 <alfredo.dinapoli@gmail.com>") $ 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 <pmidden@secure.mailbox.org>") $ words
"clock"
mapM_ (add "Stefan Wehr <wehr@factisresearch.com>") $ words
"HTF xmlgen stm-stats"
when (ghcVer < GhcMajorVersion 7 8) $ add "Stefan Wehr <wehr@factisresearch.com>" "hscurses"
mapM_ (add "Bart Massey <bart.massey+stackage@gmail.com>") $ 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 <agocorona@gmail.com>") $ words
"RefSerialize TCache Workflow MFlow"
mapM_ (add "Edward Kmett <ekmett@gmail.com>") $ 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 <ekmett@gmail.com>") $ words =<<
[ "categories comonad-extras recursion-schemes syb-extras"
]
addRange "Edward Kmett <ekmett@gmail.com>" "bits" "< 0.4"
when (ghcVer >= GhcMajorVersion 7 8) $
mapM_ (add "Edward Kmett <ekmett@gmail.com>") $ 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 <ekmett@gmail.com>") $ words =<<
[ "lens-aeson quickpull zlib-lens"
]
-- Temporary upper bound for some of the above packages
addRange "Edward Kmett <ekmett@gmail.com>" "generic-deriving" "< 1.7"
mapM_ (add "Andrew Farmer <afarmer@ittc.ku.edu>") $ words
"scotty wai-middleware-static"
mapM_ (add "Simon Hengel <sol@typeful.net>") $ words
"hspec hspec-wai hspec-wai-json aeson-qq interpolate doctest base-compat"
mapM_ (add "Mario Blazevic <blamario@yahoo.com>") $ words
"monad-parallel monad-coroutine incremental-parser monoid-subclasses"
mapM_ (add "Brent Yorgey <byorgey@gmail.com>") $ 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 <vincent.berthoux@gmail.com>") $ words
"JuicyPixels"
mapM_ (add "Patrick Brisbin") $ words "gravatar"
-- https://github.com/fpco/stackage/issues/299
-- mapM_ (add "Paul Harper <benekastah@gmail.com>") $ words "yesod-auth-oauth2"
mapM_ (add "Felipe Lessa <felipe.lessa@gmail.com>") $ words
"esqueleto fb fb-persistent yesod-fb yesod-auth-fb"
mapM_ (add "Alexander Altman <alexanderaltman@me.com>") $ words
"base-unicode-symbols containers-unicode-symbols"
if ghcVer >= GhcMajorVersion 7 8
then add "Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>" "accelerate"
else do
addRange "Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>" "accelerate" "< 0.15"
addRange "Michael Snoyman" "linear-accelerate" "< 0.2"
mapM_ (add "Dan Burton <danburton.email@gmail.com>") $ words =<<
[ "basic-prelude composition io-memoize numbers rev-state runmemo"
, "tardis lens-family-th"
]
mapM_ (add "Daniel Díaz <dhelta.diaz@gmail.com>") $ words
"HaTeX matrix"
when (ghcVer >= GhcMajorVersion 7 8) $
mapM_ (add "Daniel Díaz <dhelta.diaz@gmail.com>") $ words
"binary-list"
mapM_ (add "Gabriel Gonzalez <Gabriel439@gmail.com>")
["pipes", "pipes-parse", "pipes-concurrency"]
when (ghcVer >= GhcMajorVersion 7 8) $
mapM_ (add "Chris Allen <cma@bitemyapp.com>")
["bloodhound"]
mapM_ (add "Adam Bergmark <adam@bergmark.nl>") $ 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 <rodrigosetti@gmail.com>") $ words
"messagepack messagepack-rpc"
mapM_ (add "Boris Lykah <lykahb@gmail.com>") $ words
"groundhog groundhog-th groundhog-sqlite groundhog-postgresql groundhog-mysql"
mapM_ (add "Janne Hellsten <jjhellst@gmail.com>") $ 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 <roma@ro-che.info>") $ 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 <giorgidze@gmail.com>") $ words
"HCodecs YampaSynth"
mapM_ (add "Phil Hargett <phil@haphazardhouse.net>") $ words
"courier"
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
mapM_ (add "Aycan iRiCAN <iricanaycan@gmail.com>") $ words
"hdaemonize hsyslog hweblib"
#else
mapM_ (add "Aycan iRiCAN <iricanaycan@gmail.com>") $ words
"hweblib"
#endif
mapM_ (add "Joachim Breitner <mail@joachim-breitner.de>") $ words
"circle-packing arbtt"
when (ghcVer >= GhcMajorVersion 7 8) $
mapM_ (add "Joachim Breitner <mail@joachim-breitner.de>") $ words
"ghc-heap-view"
when (ghcVer < GhcMajorVersion 7 8) $
mapM_ (add "John Wiegley") $ words =<<
[ "bindings-DSL github monad-extras numbers"
]
mapM_ (add "Aditya Bhargava <adit@adit.io") $ words
"HandsomeSoup"
mapM_ (add "Clint Adams <clint@debian.org>") $ 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 <code@silk.co>") $ 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 <code@silk.co>") $ 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 <simon@joyful.com>") $ words
"hledger"
mapM_ (add "Mihai Maruseac <mihai.maruseac@gmail.com>") $ words
"io-manager"
mapM_ (add "Dimitri Sabadie <dimitri.sabadie@gmail.com") $ words
"monad-journal"
mapM_ (add "Thomas Schilling <nominolo@googlemail.com>") $ words
"ghc-syb-utils"
mapM_ (add "Boris Buliga <d12frosted@icloud.com>") $ words
"ghc-mod io-choice"
when (ghcVer >= GhcMajorVersion 7 8) $
mapM_ (add "Boris Buliga <d12frosted@icloud.com>") $ words
"system-canonicalpath"
when (ghcVer >= GhcMajorVersion 7 8) $
mapM_ (add "Yann Esposito <yann.esposito@gmail.com>") $ words
"holy-project"
when requireHP $ addRange "Yann Esposito <yann.esposito@gmail.com>" "holy-project" "< 0.1.1.1"
mapM_ (add "Paul Rouse <pgr@doynton.org>") $ words
"yesod-auth-hashdb"
add "Toralf Wittner <tw@dtex.org>" "zeromq4-haskell"
mapM_ (add "trupill@gmail.com") $ words
"djinn-lib djinn-ghc"
mapM_ (add "Arash Rouhani <miffoljud@gmail.com>") $ words
"yesod-text-markdown"
mapM_ (add "Matvey Aksenov <matvey.aksenov@gmail.com") $ words
"terminal-size"
mapM_ (add "Luis G. Torres <lgtorres42@gmail.com") $ words
"kdt"
{- https://github.com/fpco/stackage/pull/331
mapM_ (add "Jyotirmoy Bhattacharya <jyotirmoy@jyotirmoy.net") $ words
"hakyll"
-}
mapM_ (add "Emanuel Borsobom <manny@fpcomplete.com>") $ 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 <manny@fpcomplete.com>") $ words
"haddock-api git-embed"
when (not requireHP) $
mapM_ (add "Emanuel Borsobom <manny@fpcomplete.com>") $ words
"fuzzcheck MissingH"
mapM_ (add "Michael Sloan <mgsloan@gmail.com") $ words
"th-orphans th-reify-many"
when (ghcVer == GhcMajorVersion 7 8 && not requireHP) $
mapM_ (add "Michael Snoyman") $ words =<<
[ "repa repa-io repa-algorithms repa-devil JuicyPixels-repa"
]
when (ghcVer >= GhcMajorVersion 7 8 && not requireHP) $ do
mapM_ (add "Nikita Volkov <nikita.y.volkov@mail.ru>") $
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 <nikita.y.volkov@mail.ru>" "mtl-prelude" "< 2"
mapM_ (add "Iustin Pop <iustin@k1024.org>") $ words
"prefix-units"
mapM_ (add "Alexander Thiemann <mail@athiemann.net>") $ words
"graph-core reroute Spock"
mapM_ (add "Joey Eremondi <joey@eremondi.com>") $ 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 <heraldhoi@gmail.com>") $ 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 <oss@chudnov.com>" "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 <tom-stackage@jaguarpaw.co.uk>") $ 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"])
]

49
Stackage/GhcPkg.hs
View File

@ -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

32
Stackage/Init.hs
View File

@ -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

211
Stackage/InstallInfo.hs
View File

@ -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)

264
Stackage/LoadDatabase.hs
View File

@ -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

52
Stackage/ModuleNameConflict.hs
View File

@ -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

54
Stackage/NarrowDatabase.hs
View File

@ -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

173
Stackage/Select.hs
View File

@ -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)

104
Stackage/ServerFiles.hs
View File

@ -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

45
Stackage/Tarballs.hs
View File

@ -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:))

298
Stackage/Test.hs
View File

@ -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'

165
Stackage/Types.hs
View File

@ -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)

174
Stackage/Util.hs
View File

@ -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 ('@' :)

167
Stackage2/BuildConstraints.hs
View File

@ -12,14 +12,17 @@ module Stackage2.BuildConstraints
, defaultBuildConstraints , defaultBuildConstraints
) where ) where
import Control.Monad.Writer.Strict (execWriter, tell)
import Data.Aeson import Data.Aeson
import qualified Data.Map as Map import qualified Data.Map as Map
import Distribution.System (Arch, OS) import Data.Yaml (decodeEither', decodeFileEither)
import Distribution.Package (Dependency (..))
import Distribution.System (Arch, OS)
import qualified Distribution.System import qualified Distribution.System
import Distribution.Version (anyVersion) import Distribution.Version (anyVersion)
import qualified Stackage.Config as Old import Distribution.Version (anyVersion)
import qualified Stackage.Select as Old import Filesystem (isFile)
import qualified Stackage.Types as Old import Network.HTTP.Client (Manager, httpLbs, responseBody)
import Stackage2.CorePackages import Stackage2.CorePackages
import Stackage2.Prelude import Stackage2.Prelude
@ -80,6 +83,9 @@ data BuildConstraints = BuildConstraints
, bcPackageConstraints :: PackageName -> PackageConstraints , bcPackageConstraints :: PackageName -> PackageConstraints
, bcSystemInfo :: SystemInfo , bcSystemInfo :: SystemInfo
, bcGithubUsers :: Map Text (Set Text)
-- ^ map an account to set of pingees
} }
data PackageConstraints = PackageConstraints data PackageConstraints = PackageConstraints
@ -113,50 +119,19 @@ instance FromJSON PackageConstraints where
return PackageConstraints {..} return PackageConstraints {..}
-- | The proposed plan from the requirements provided by contributors. -- | The proposed plan from the requirements provided by contributors.
defaultBuildConstraints :: IO BuildConstraints --
defaultBuildConstraints = do -- Checks the current directory for a build-constraints.yaml file and uses it
bcSystemInfo <- getSystemInfo -- if present. If not, downloads from Github.
oldGhcVer <- defaultBuildConstraints :: Manager -> IO BuildConstraints
case siGhcVersion bcSystemInfo of defaultBuildConstraints man = do
Version (x:y:_) _ -> return $ Old.GhcMajorVersion x y e <- isFile fp
_ -> error $ "Didn't not understand GHC version: " ++ show (siGhcVersion bcSystemInfo) if e
then decodeFileEither (fpToString fp) >>= either throwIO toBC
else httpLbs req man >>=
let oldSettings = Old.defaultSelectSettings oldGhcVer False either throwIO toBC . decodeEither' . toStrict . responseBody
oldStable = Old.defaultStablePackages oldGhcVer False where
defaultGlobalFlags = asMap $ mapFromList $ fp = "build-constraints.yaml"
map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++ req = "https://raw.githubusercontent.com/fpco/stackage/master/build-constraints.yaml"
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 {..}
getSystemInfo :: IO SystemInfo getSystemInfo :: IO SystemInfo
getSystemInfo = do getSystemInfo = do
@ -169,30 +144,74 @@ getSystemInfo = do
siOS = Distribution.System.Linux siOS = Distribution.System.Linux
siArch = Distribution.System.X86_64 siArch = Distribution.System.X86_64
packageFlags :: PackageName -> Map FlagName Bool loadBuildConstraints fp = decodeFileEither fp >>= either throwIO toBC
packageFlags (PackageName "mersenne-random-pure64") = singletonMap (FlagName "small_base") False
packageFlags _ = mempty
extraSkippedTests :: HashSet Text data ConstraintFile = ConstraintFile
extraSkippedTests = setFromList $ words =<< { cfGlobalFlags :: Map FlagName Bool
[ "HTTP Octree options" , cfPackageFlags :: Map PackageName (Map FlagName Bool)
, "hasql" , cfSkippedTests :: Set PackageName
, "bloodhound fb" -- require old hspec , cfExpectedTestFailures :: Set PackageName
, "diagrams-haddock" -- requires old tasty , cfExpectedHaddockFailures :: Set PackageName
, "hasql-postgres" -- requires old hasql , cfSkippedBenchmarks :: Set PackageName
, "compdata" -- https://github.com/pa-ba/compdata/issues/4 , cfPackages :: Map Maintainer (Vector Dependency)
] , cfGithubUsers :: Map Text (Set Text)
}
skippedBenchs :: HashSet Text instance FromJSON ConstraintFile where
skippedBenchs = setFromList $ words =<< parseJSON = withObject "ConstraintFile" $ \o -> do
[ "machines criterion-plus graphviz lifted-base pandoc stm-containers uuid" cfGlobalFlags <- goFlagMap <$> o .: "global-flags"
, "cases hasql-postgres" -- pulls in criterion-plus, which has restrictive upper bounds cfPackageFlags <- (goPackageMap . fmap goFlagMap) <$> o .: "package-flags"
-- https://github.com/vincenthz/hs-crypto-cipher/issues/46 cfSkippedTests <- getPackages o "skipped-tests"
, "cipher-aes cipher-blowfish cipher-camellia cipher-des cipher-rc4" cfExpectedTestFailures <- getPackages o "expected-test-failures"
, "hasql" -- sometimes falls out-of-sync on hasql-postgres 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 toDep :: Monad m => Text -> m Dependency
newExpectedFailures = setFromList $ map PackageName $ words =<< toDep = either (fail . show) return . simpleParse
[ "cautious-file" -- weird problems with cabal test
] 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

5
Stackage2/BuildPlan.hs
View File

@ -32,6 +32,7 @@ data BuildPlan = BuildPlan
{ bpSystemInfo :: SystemInfo { bpSystemInfo :: SystemInfo
, bpTools :: Vector (PackageName, Version) , bpTools :: Vector (PackageName, Version)
, bpPackages :: Map PackageName PackagePlan , bpPackages :: Map PackageName PackagePlan
, bpGithubUsers :: Map Text (Set Text)
} }
deriving (Show, Eq) deriving (Show, Eq)
@ -51,6 +52,7 @@ instance FromJSON BuildPlan where
bpSystemInfo <- o .: "system-info" bpSystemInfo <- o .: "system-info"
bpTools <- (o .: "tools") >>= mapM goTool bpTools <- (o .: "tools") >>= mapM goTool
bpPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") bpPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages")
bpGithubUsers <- o .:? "github-users" .!= mempty
return BuildPlan {..} return BuildPlan {..}
where where
goTool = withObject "Tool" $ \o -> (,) goTool = withObject "Tool" $ \o -> (,)
@ -105,6 +107,7 @@ newBuildPlan bc@BuildConstraints {..} = liftIO $ do
{ bpSystemInfo = bcSystemInfo { bpSystemInfo = bcSystemInfo
, bpTools = tools , bpTools = tools
, bpPackages = packages , bpPackages = packages
, bpGithubUsers = bcGithubUsers
} }
where where
SystemInfo {..} = bcSystemInfo SystemInfo {..} = bcSystemInfo
@ -182,7 +185,7 @@ mkPackagePlan bc gpd = do
return PackagePlan {..} return PackagePlan {..}
where where
PackageIdentifier name ppVersion = package $ packageDescription gpd PackageIdentifier name ppVersion = package $ packageDescription gpd
ppGithubPings = getGithubPings gpd ppGithubPings = getGithubPings bc gpd
ppConstraints = bcPackageConstraints bc name ppConstraints = bcPackageConstraints bc name
ppUsers = mempty -- must be filled in later ppUsers = mempty -- must be filled in later

12
Stackage2/CompleteBuild.hs
View File

@ -39,11 +39,11 @@ data Settings = Settings
, postBuild :: IO () , postBuild :: IO ()
} }
getSettings :: BuildType -> IO Settings getSettings :: Manager -> BuildType -> IO Settings
getSettings Nightly = do getSettings man Nightly = do
day <- tshow . utctDay <$> getCurrentTime day <- tshow . utctDay <$> getCurrentTime
let slug' = "nightly-" ++ day let slug' = "nightly-" ++ day
plan' <- defaultBuildConstraints >>= newBuildPlan plan' <- defaultBuildConstraints man >>= newBuildPlan
return Settings return Settings
{ planFile = fpFromText ("nightly-" ++ day) <.> "yaml" { planFile = fpFromText ("nightly-" ++ day) <.> "yaml"
, buildDir = fpFromText $ "builds/stackage-nightly-" ++ day , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day
@ -59,7 +59,7 @@ getSettings Nightly = do
, plan = plan' , plan = plan'
, postBuild = return () , postBuild = return ()
} }
getSettings (LTS bumpType) = do getSettings man (LTS bumpType) = do
Option mlts <- fmap (fmap getMax) $ runResourceT Option mlts <- fmap (fmap getMax) $ runResourceT
$ sourceDirectory "." $ sourceDirectory "."
$$ foldMapC (Option . fmap Max . parseLTSVer . filename) $$ foldMapC (Option . fmap Max . parseLTSVer . filename)
@ -70,7 +70,7 @@ getSettings (LTS bumpType) = do
case mlts of case mlts of
Nothing -> LTSVer 0 0 Nothing -> LTSVer 0 0
Just (LTSVer x _) -> LTSVer (x + 1) 0 Just (LTSVer x _) -> LTSVer (x + 1) 0
plan' <- defaultBuildConstraints >>= newBuildPlan plan' <- defaultBuildConstraints man >>= newBuildPlan
return (new, plan') return (new, plan')
Minor -> do Minor -> do
old <- maybe (error "No LTS plans found in current directory") return mlts 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 hSetBuffering stdout LineBuffering
putStrLn $ "Loading settings for: " ++ tshow buildType putStrLn $ "Loading settings for: " ++ tshow buildType
Settings {..} <- getSettings buildType Settings {..} <- getSettings man buildType
putStrLn $ "Writing build plan to: " ++ fpToText planFile putStrLn $ "Writing build plan to: " ++ fpToText planFile
encodeFile (fpToString planFile) plan encodeFile (fpToString planFile) plan

81
Stackage2/ConstraintFile.hs
View File

@ -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

14
Stackage2/GithubPings.hs
View File

@ -1,18 +1,20 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Stackage2.GithubPings module Stackage2.GithubPings
( getGithubPings ( getGithubPings
) where ) where
import Distribution.PackageDescription import Distribution.PackageDescription
import qualified Stackage.Config as Old import Stackage2.BuildConstraints
import Stackage2.Prelude import Stackage2.Prelude
-- | Determine accounts to be pinged on Github based on various metadata in the -- | Determine accounts to be pinged on Github based on various metadata in the
-- package description. -- package description.
getGithubPings :: GenericPackageDescription -> Set Text getGithubPings :: BuildConstraints -- ^ for mapping to pingees
getGithubPings gpd = -> GenericPackageDescription -> Set Text
setFromList $ map pack $ foldMap Old.convertGithubUser $ getGithubPings bc gpd =
foldMap (\(pack -> name) -> fromMaybe (singletonSet name) (lookup name (bcGithubUsers bc))) $
goHomepage (homepage $ packageDescription gpd) ++ goHomepage (homepage $ packageDescription gpd) ++
concatMap goRepo (sourceRepos $ packageDescription gpd) concatMap goRepo (sourceRepos $ packageDescription gpd)
where where

1
Stackage2/UpdateBuildPlan.hs
View File

@ -24,6 +24,7 @@ updateBuildConstraints BuildPlan {..} =
where where
bcSystemInfo = bpSystemInfo bcSystemInfo = bpSystemInfo
bcPackages = Map.keysSet bpPackages bcPackages = Map.keysSet bpPackages
bcGithubUsers = bpGithubUsers
bcPackageConstraints name = PackageConstraints bcPackageConstraints name = PackageConstraints
{ pcVersionRange = addBumpRange (maybe anyVersion pcVersionRange moldPC) { pcVersionRange = addBumpRange (maybe anyVersion pcVersionRange moldPC)

148
app/stackage.hs
View File

@ -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 ++ " <command>"
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]"

28
stackage.cabal
View File

@ -13,25 +13,7 @@ cabal-version: >=1.10
library library
default-language: Haskell2010 default-language: Haskell2010
exposed-modules: Stackage.NarrowDatabase exposed-modules: Stackage2.Prelude
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
Stackage2.BuildConstraints Stackage2.BuildConstraints
Stackage2.CorePackages Stackage2.CorePackages
Stackage2.PackageIndex Stackage2.PackageIndex
@ -77,14 +59,6 @@ library
, semigroups , semigroups
, xml-conduit , xml-conduit
executable stackage
default-language: Haskell2010
hs-source-dirs: app
main-is: stackage.hs
build-depends: base
, stackage
, containers
executable stackage-nightly executable stackage-nightly
default-language: Haskell2010 default-language: Haskell2010
hs-source-dirs: app hs-source-dirs: app