diff --git a/HACKING.rst b/HACKING.rst new file mode 100644 --- /dev/null +++ b/HACKING.rst @@ -0,0 +1,168 @@ +CONTRIBUTING TO HACKPORT +======================== + +Introduction +------------ + +First of all, welcome to ``HackPort`` development! + +Hacking on ``HackPort`` should be more-or-less straightforward, but +there are some peculiarities that may cause headaches for new +contributors. This document aims to cover some common pitfalls for new +contributors to ``HackPort``. + +Setting up your development repository +-------------------------------------- + +On GitHub, fork the ``gentoo-haskell/hackport`` repository. If you will be +working on the ``cabal`` submodule, you should also fork the +``gentoo-haskell/cabal`` repository. + +The ``HackPort`` source repository contains two git submodules: ``cabal`` +and ``hackage-security``. Ensure that these submodules are populated by +cloning the ``HackPort`` repository with the ``--recurse-submodules`` +option: + +``git clone --recurse-submodules https://github.com//hackport.git`` + +If you have already cloned the ``HackPort`` source repository without +``--recurse-submodules``, run +``git submodule init && git submodule update`` to populate the submodule +directories. For more information visit +https://git-scm.com/book/en/v2/Git-Tools-Submodules. + +Bumping the cabal submodule +--------------------------- + +The ``cabal`` submodule follows the upstream Cabal source repository, +and adds a handful of local patches designed to allow ``HackPort`` to +use it correctly. Enter the ``cabal/`` directory and run ``git log`` to +see for yourself: the most recent commits will be a dozen or so patches +written by ``HackPort`` contributors over the years to ensure +compatibility between ``HackPort`` and Cabal. Underneath those commits will +be those of Cabal upstream. + +Our patches need to be carried over whenever we bump the ``cabal`` +submodule to a newer upstream commit. Let’s run through one way of +carrying out this process. + +1. Add the upstream Cabal source repository as a remote repository in + our cabal submodule, i.e. + + ``cd cabal && git remote add upstream https://github.com/haskell/cabal`` + + Note that this only needs to be done once. + +2. Checkout a new branch within your ``cabal`` submodule, i.e. + ``git checkout -b `` + +3. Fetch the latest changes from Cabal upstream (or just the changes you + need), e.g. \ ``git fetch upstream master``. + +4. Rebase onto the latest changes or a given commit, e.g. + + ``git rebase 6e9d6bdc79ecab601d6602d445e9cdcbecfd2591`` + + What I usually like to do is browse the upstream Cabal repository on + GitHub to find a stable point in its commit history, and for that + I’ll find a commit that is tagged as ‘Cabal-v’. **A WORD OF + CAUTION:** generally Cabal upstream creates tags in branches + *outside* of ‘master’, which can cause rebasing headaches in the + future. If you find yourself looking at a specific commit referenced + by a git tag for a given Cabal version, check the commit description + for a comment such as ‘(cherry picked from commit 853414b)’. Commit + ‘854514b’ in this example is *generally* a commit in the ‘master’ + branch, which is what we want. Rebase onto *that* commit, not the + commit tagged as ‘Cabal-v’. In this example, do + + ``git rebase 854514b`` and **not** ``git rebase Cabal-v`` + + If you *really* want to rebase onto a specific tag in a specific + branch other than master, you may find that when rebasing to a newer + upstream Cabal commit in the future you will need to rebase by doing + + ``git rebase --onto `` + + ```` being the new commit to rebase onto and + ```` being the commit that we were previously based on. + +5. Work through the ensuing conflicts. You are likely to come across + some conflicts between our patches and the changes pulled from Cabal + upstream. This is normal. Work through the conflicts (about a dozen + or so) by carrying over our changes into the newer Cabal files that + we’ve just rebased onto. Usually, it’s a simple matter of ensuring + that a particular language extension is enabled in a certain file, + such as adding + + ``{-# LANGUAGE NoMonoLocalBinds #-}`` + + to the top of a Cabal source file. + +6. Try to compile hackport on top of the updated ``cabal`` submodule: + + ``cabal v2-build`` + + This may be the tricky part. There may have been breaking changes + between upstream Cabal versions, which can cause breakages within + ``HackPort``. + + If files in the ``cabal`` submodule fail to compile, it’s usually + related to a language extension that needs to be enabled such as + ``NoMonoLocalBinds``. + + If files in the ``HackPort`` repository fail to compile, it’s usually to + do with functions which have been changed or removed in Cabal + upstream, now reflected in our updated ``cabal`` submodule. You’ll + need to study the Cabal library documentation for the relevant + changes, which can be done on Hackage in your web browser. + +7. Hopefully, everything now compiles and ``HackPort`` functions + correctly at run time. Assuming it is decided that these changes + should be pushed into gentoo-haskell’s ``HackPort`` repository (and + assuming that you have commit access) ensure that you push both the + ``cabal`` submodule and the ``HackPort`` repository at large. You *can* + do this in one step by using + + ``git push --recurse-submodules=on-demand`` + + but you can also do it manually. + + Otherwise, open a pull request for both ``gentoo-haskell/cabal`` and + ``gentoo-haskell/hackport``. + +Releasing a new version of HackPort +----------------------------------- + +First, create a tag of your new ``HackPort`` version: + +``git tag "v" -s`` + +The ``-s`` option signs the tag with your GnuPG key, if you wish to do +this. + +Next, run the ‘mk_release_tarball.bash’ script. ``cabal sdist`` does not +build the submodules, which is why we need to use this script instead. + +Assuming everything builds correctly and you are a designated +``HackPort`` maintainer on Hackage, you can publish the ``HackPort`` +source distribution: + +``cabal upload --publish `` + +Bump the ``HackPort`` ebuild in ``::haskell`` to the newest version +reflected on Hackage. + +Further help and information +---------------------------- + +There will usually be a ``HackPort`` developer hanging about in +``#gentoo-haskell`` on FreeNode. Join the channel and ask away! + +TODO +---- + +- Include section explaining how to determine and add the list of bundled + libraries for a given GHC version to ``HackPort``. + + + diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -2,7 +2,6 @@ module Main (main) where -import Control.Applicative import Control.Monad import Data.Maybe import Data.List diff --git a/Merge.hs b/Merge.hs --- a/Merge.hs +++ b/Merge.hs @@ -200,14 +200,10 @@ -- | Remove "with" or "use" prefixes from flag names. drop_prefix :: String -> String -drop_prefix = \x -> - case splitAt 5 x of - ("with_", b) -> b - ("with-", b) -> b - _ -> case splitAt 4 x of - ("use_", b) -> b - ("use-", b) -> b - _ -> x +drop_prefix x + | take 5 x `elem` ["with_","with-"] = drop 5 x + | take 4 x `elem` ["use_","use-"] = drop 4 x + | otherwise = x -- used to be FlagAssignment in Cabal but now it's an opaque type type CabalFlags = [(Cabal.FlagName, Bool)] diff --git a/Merge/Dependencies.hs b/Merge/Dependencies.hs --- a/Merge/Dependencies.hs +++ b/Merge/Dependencies.hs @@ -11,7 +11,7 @@ ) where import Data.Maybe ( isJust, isNothing ) -import Data.Monoid ( Monoid, mempty, mappend) +import Data.Monoid ( Monoid, mempty ) import qualified Data.List as L import qualified Data.Set as S diff --git a/Portage/EBuild.hs b/Portage/EBuild.hs --- a/Portage/EBuild.hs +++ b/Portage/EBuild.hs @@ -11,11 +11,11 @@ import Portage.EBuild.Render import qualified Portage.Dependency.Normalize as PN -import Data.String.Utils import qualified Data.Time.Clock as TC import qualified Data.Time.Format as TC import qualified Data.Function as F import qualified Data.List as L +import qualified Data.List.Split as LS import Data.Version(Version(..)) import qualified Paths_hackport(version) @@ -140,6 +140,7 @@ toHttps = replace "http://github.com/" "https://github.com/" this_year :: String this_year = TC.formatTime TC.defaultTimeLocale "%Y" now + replace old new = L.intercalate new . LS.splitOn old -- "+a" -> "a" -- "b" -> "b" diff --git a/Portage/GHCCore.hs b/Portage/GHCCore.hs --- a/Portage/GHCCore.hs +++ b/Portage/GHCCore.hs @@ -31,10 +31,10 @@ import Debug.Trace -- ghcs tried in specified order. --- It means that first ghc in this list is a minmum default. +-- It means that first ghc in this list is a minimum default. ghcs :: [(DC.CompilerInfo, InstalledPackageIndex)] ghcs = modern_ghcs - where modern_ghcs = [ghc741, ghc742, ghc762, ghc782, ghc7101, ghc7102, ghc801, ghc802, ghc821, ghc843, ghc863, ghc865, ghc881] + where modern_ghcs = [ghc741, ghc742, ghc762, ghc782, ghc7101, ghc7102, ghc801, ghc802, ghc821, ghc843, ghc863, ghc865, ghc881, ghc883, ghc8101] cabalFromGHC :: [Int] -> Maybe Cabal.Version cabalFromGHC ver = lookup ver table @@ -51,6 +51,8 @@ , ([8,6,3], Cabal.mkVersion [2,4,0,1]) , ([8,6,5], Cabal.mkVersion [2,4,0,1]) , ([8,8,1], Cabal.mkVersion [3,0,0,0]) + , ([8,8,3], Cabal.mkVersion [3,0,1,0]) + , ([8,10,1], Cabal.mkVersion [3,2,0,0]) ] platform :: Platform @@ -120,6 +122,12 @@ ghc nrs = DC.unknownCompilerInfo c_id DC.NoAbiTag where c_id = CompilerId GHC (mkVersion nrs) +ghc8101 :: (DC.CompilerInfo, InstalledPackageIndex) +ghc8101 = (ghc [8,10,1], mkIndex ghc8101_pkgs) + +ghc883 :: (DC.CompilerInfo, InstalledPackageIndex) +ghc883 = (ghc [8,8,3], mkIndex ghc883_pkgs) + ghc881 :: (DC.CompilerInfo, InstalledPackageIndex) ghc881 = (ghc [8,8,1], mkIndex ghc881_pkgs) @@ -165,6 +173,73 @@ -- example: https://downloads.haskell.org/~ghc/8.6.5/docs/html/users_guide/8.6.5-notes.html -- * our binary tarballs (package.conf.d.initial subdir) -- * ancient: http://haskell.org/haskellwiki/Libraries_released_with_GHC +ghc8101_pkgs :: [Cabal.PackageIdentifier] +ghc8101_pkgs = + [ p "array" [0,5,4,0] + , p "base" [4,14,0,0] + , p "binary" [0,8,8,0] -- used by libghc + , p "bytestring" [0,10,10,0] +-- , p "Cabal" [3,2,0,0] package is upgradeable + , p "containers" [0,6,2,1] + , p "deepseq" [1,4,4,0] -- used by time + , p "directory" [1,3,6,0] + , p "filepath" [1,4,2,1] +-- , p "exceptions [0,10,4] -- used by haskeline, package is upgradeable + , p "ghc-boot" [8,10,1] + , p "ghc-boot-th" [8,10,1] + , p "ghc-compact" [0,1,0,0] + , p "ghc-prim" [0,6,1,0] + , p "ghc-heap" [8,10,1] + , p "ghci" [8,10,1] +-- , p "haskeline" [0,8,0,0] package is upgradeable + , p "hpc" [0,6,1,0] -- used by libghc + , p "integer-gmp" [1,0,3,0] + -- , p "mtl" [2,2,2] package is upgradeable(?) + -- , p "parsec" [3,1,14,0] package is upgradeable(?) + , p "pretty" [1,1,3,6] + , p "process" [1,6,8,2] + -- , p "stm" [2,5,0,0] package is upgradeable(?) + , p "template-haskell" [2,16,0,0] -- used by libghc + -- , p "terminfo" [0,4,1,4] + -- , p "text" [1,2,3,2] dependency of Cabal library + , p "time" [1,9,3,0] -- used by unix, directory, hpc, ghc. unsafe to upgrade + , p "transformers" [0,5,6,2] -- used by libghc + , p "unix" [2,7,2,2] +-- , p "xhtml" [3000,2,2,1] + ] + +ghc883_pkgs :: [Cabal.PackageIdentifier] +ghc883_pkgs = + [ p "array" [0,5,4,0] + , p "base" [4,13,0,0] + , p "binary" [0,8,7,0] -- used by libghc + , p "bytestring" [0,10,10,0] +-- , p "Cabal" [3,0,1,0] package is upgradeable + , p "containers" [0,6,2,1] + , p "deepseq" [1,4,4,0] -- used by time + , p "directory" [1,3,6,0] + , p "filepath" [1,4,2,1] + , p "ghc-boot" [8,8,3] + , p "ghc-boot-th" [8,8,3] + , p "ghc-compact" [0,1,0,0] + , p "ghc-prim" [0,5,3,0] + , p "ghci" [8,8,3] +-- , p "haskeline" [0,7,5,0] package is upgradeable + , p "hpc" [0,6,0,3] -- used by libghc + , p "integer-gmp" [1,0,2,0] + -- , p "mtl" [2,2,2] package is upgradeable(?) + -- , p "parsec" [3,1,14,0] package is upgradeable(?) + , p "pretty" [1,1,3,6] + , p "process" [1,6,8,0] + -- , p "stm" [2,5,0,0] package is upgradeable(?) + , p "template-haskell" [2,15,0,0] -- used by libghc + -- , p "terminfo" [0,4,1,4] + -- , p "text" [1,2,4,0] dependency of Cabal library + , p "time" [1,9,3,0] -- used by unix, directory, hpc, ghc. unsafe to upgrade + , p "transformers" [0,5,6,2] -- used by libghc + , p "unix" [2,7,2,2] +-- , p "xhtml" [3000,2,2,1] + ] ghc881_pkgs :: [Cabal.PackageIdentifier] ghc881_pkgs = diff --git a/Portage/Metadata.hs b/Portage/Metadata.hs --- a/Portage/Metadata.hs +++ b/Portage/Metadata.hs @@ -6,11 +6,9 @@ import qualified Data.ByteString as B -import Control.Applicative - import Text.XML.Light -data Metadata = Metadata +newtype Metadata = Metadata { metadata_emails :: [String] -- , metadataMaintainers :: [String], -- , metadataUseFlags :: [(String,String)] diff --git a/Portage/PackageId.hs b/Portage/PackageId.hs --- a/Portage/PackageId.hs +++ b/Portage/PackageId.hs @@ -61,7 +61,7 @@ parsec = do category <- parsec _ <- P.char '/' - name <- parsec + name <- parseCabalPackageName return $ PackageName category name instance Pretty PackageId where diff --git a/Portage/Version.hs b/Portage/Version.hs --- a/Portage/Version.hs +++ b/Portage/Version.hs @@ -28,15 +28,16 @@ import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>)) import qualified Data.Char as Char (isAlpha, isDigit) +import qualified Data.List.NonEmpty as NonEmpty #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif -data Version = Version { versionNumber :: [Int] -- [1,42,3] ~= 1.42.3 - , versionChar :: (Maybe Char) -- optional letter +data Version = Version { versionNumber :: [Int] -- [1,42,3] ~= 1.42.3 + , versionChar :: (Maybe Char) -- optional letter , versionSuffix :: [Suffix] - , versionRevision :: Int -- revision, 0 means none + , versionRevision :: Int -- revision, 0 means none } deriving (Eq, Ord, Show, Read) @@ -52,11 +53,11 @@ instance Parsec Version where parsec = do - ver <- P.sepBy1 digits (P.char '.') + ver <- P.sepByNonEmpty digits (P.char '.') c <- P.optional $ P.satisfy Char.isAlpha suf <- P.many parsec rev <- P.option 0 $ P.string "-r" *> digits - return $ Version ver c suf rev + return $ Version (NonEmpty.toList ver) c suf rev -- foo-9999* is treated as live ebuild -- Cabal-1.17.9999* as well diff --git a/Status.hs b/Status.hs --- a/Status.hs +++ b/Status.hs @@ -24,7 +24,6 @@ import Data.Map as Map (Map) import qualified Data.Traversable as T -import Control.Applicative import Control.Monad -- cabal diff --git a/cabal/.dockerignore b/cabal/.dockerignore new file mode 100644 --- /dev/null +++ b/cabal/.dockerignore @@ -0,0 +1,32 @@ +# Note: some cabal-testsuite tests need .git, so we cannot ignore that. + +cabal.project.local +.ghc.environment.* + +**/.hpc +**/*.hi +**/*.o +**/*.p_hi +**/*.prof +**/*.tix + +**/*.sw* + +**/Setup +**/*.dist + +Cabal/dist/ +Cabal/.python-sphinx-virtualenv/ +Cabal/tests/Setup +Cabal/Setup +Cabal/source-file-list + +cabal-install/dist/ +cabal-install/Setup +cabal-install/source-file-list + +.github/ +dist-newstyle/ +dist-newstyle-*/ + +Cabal/.python-sphinx-virtualenv diff --git a/cabal/.github/ISSUE_TEMPLATE/bug_report.md b/cabal/.github/ISSUE_TEMPLATE/bug_report.md --- a/cabal/.github/ISSUE_TEMPLATE/bug_report.md +++ b/cabal/.github/ISSUE_TEMPLATE/bug_report.md @@ -22,7 +22,7 @@ **Expected behavior** A clear and concise description of what you expected to happen. -**System informataion** +**System information** - Operating system - `cabal`, `ghc` versions diff --git a/cabal/.mailmap b/cabal/.mailmap --- a/cabal/.mailmap +++ b/cabal/.mailmap @@ -20,6 +20,7 @@ Andres Löh Andres Löh Andy Craze +Arian van Putten Audrey Tang audreyt Austin Seipp Austin Seipp @@ -57,6 +58,7 @@ Edward Z. Yang Edward Z. Yang Einar Karttunen +Emily Pillmore Federico Mastellone Felix Yan Felix Yan Francesco Gazzetta @@ -117,6 +119,7 @@ Malcolm Wallace Malcolm.Wallace Mark Weber marco-oweber Martin Sjögren md9ms +Matt Renaud Mikhail Glushenkov Mikhail Glushenkov Mikhail Glushenkov @@ -156,8 +159,8 @@ Thomas Tuegel Thomas Tuegel Veronika Romashkina +Zejun Wu capsjac # Goes by that name online ghthrowaway7 <41365123+ghthrowaway7@users.noreply.github.com> # Goes by that name online quasicomputational # Goes by that name online vedksah <31156362+vedksah@users.noreply.github.com> # Goes by that name online -! diff --git a/cabal/.travis.yml b/cabal/.travis.yml --- a/cabal/.travis.yml +++ b/cabal/.travis.yml @@ -2,25 +2,16 @@ # We specify language: c, so it doesn't default to e.g. ruby language: c -dist: trusty +dist: xenial # This sets the default config for each job to use full VMs. # The VMs have 2 cores and 8 gigs of ram. Larger VMs are also available. sudo: true # We whitelist branches, as we don't really need to build dev-branches. +# Except if those branches are in a fork. # Remember to add release branches, both here and to appveyor.yml. -branches: - only: - - master - - "3.0" - - "2.4" - - "2.2" - - "2.0" - - "1.24" - - "1.22" - - "1.20" - - "1.18" +if: branch IN (master, 3.0, 2.4, 2.2, 2.0, 1.24, 1.22, 1.20, 1.18) OR repo != haskell/cabal # The following enables several GHC versions to be tested; often it's enough to # test only against the last release in a major GHC version. Feel free to omit @@ -59,7 +50,7 @@ - env: GHCVER=8.4.4 SCRIPT=script USE_GOLD=YES DEPLOY_DOCS=YES os: linux sudo: required - - env: GHCVER=8.6.4 SCRIPT=script USE_GOLD=YES + - env: GHCVER=8.6.5 SCRIPT=script USE_GOLD=YES os: linux sudo: required #- env: GHCVER=8.8.1 SCRIPT=script USE_GOLD=YES @@ -96,22 +87,32 @@ - env: GHCVER=8.0.2 SCRIPT=bootstrap os: osx - # It's been long known that CI with - # Stack does not work so it's disabled until further notice - # to reduce latency and avoid wasting CI slots for no reason. - # - #- env: GHCVER=via-stack SCRIPT=stack STACK_CONFIG=stack.yaml - # os: linux - # - # See https://github.com/haskell/cabal/pull/4667#issuecomment-321036564 - # for why failures are allowed. - # allow_failures: - # - env: GHCVER=via-stack SCRIPT=stack STACK_CONFIG=stack.yaml + # It's been long known that CI with + # Stack does not work so it's disabled until further notice + # to reduce latency and avoid wasting CI slots for no reason. + # + #- env: GHCVER=via-stack SCRIPT=stack STACK_CONFIG=stack.yaml + # os: linux + # + # See https://github.com/haskell/cabal/pull/4667#issuecomment-321036564 + # for why failures are allowed. + # + # OSX jobs timeout often, so they can fail + allow_failures: + # - env: GHCVER=via-stack SCRIPT=stack STACK_CONFIG=stack.yaml + - env: GHCVER=7.10.3 SCRIPT=script + os: osx + - env: GHCVER=8.0.2 SCRIPT=script + os: osx # TODO add PARSEC_BUNDLED=YES when it's so # It seems pointless to run head if we're going to ignore the results. #- GHCVER=head + # Marks the build result as soon as all the non-"allow_failures" jobs finish, based on their results + # while the remaining `allow_failures` jobs continue to run. + fast_finish: true + # Note: the distinction between `before_install` and `install` is not important. before_install: - export PATH=/opt/ghc/$GHCVER/bin:$PATH @@ -171,6 +172,6 @@ notifications: irc: + if: repo = haskell/cabal channels: - "chat.freenode.net##haskell-cabal" - slack: haskell-cabal:sCq6GLfy9N8MJrInosg871n4 diff --git a/cabal/AUTHORS b/cabal/AUTHORS --- a/cabal/AUTHORS +++ b/cabal/AUTHORS @@ -16,6 +16,7 @@ Alexei Pastuchov Alexis Williams Alistair Bailey +Alp Mestanogullari Alson Kemp Amir Mohammad Saied Anders Kaseorg @@ -29,7 +30,7 @@ Antoine Latter Anton Dessiatov Antonio Nikishaev -Arian van Putten +Arian van Putten Arun Tejasvi Chaganty Atze Dijkstra Audrey Tang @@ -66,6 +67,7 @@ Colin Wahl Conal Elliott Curtis Gagliardi +Dale Wijnand <344610+dwijnand@users.noreply.github.com> Dan Burton Daniel Buckmaster Daniel Díaz Carrete @@ -75,6 +77,7 @@ Daniel Wagner Danny Navarro Dave Laing +David Eichmann David Feuer David Fox David Himmelstrup @@ -97,6 +100,7 @@ Edsko de Vries Edward Z. Yang Einar Karttunen +Emily Pillmore Eric Kow Eric Seidel Erik Hesselink @@ -106,6 +110,7 @@ Eugene Sukhodolin Eyal Lotem Fabián Orccón +Fangyi Zhou Federico Mastellone Felix Yan Florian Hartwig @@ -125,6 +130,7 @@ Gregory Collins Gwern Branwen Haisheng.Wu +Harrison Houghton Harry Garrood Heather Henk-Jan van Tuyl @@ -145,6 +151,7 @@ Jacco Krijnen Jack Henahan Jake Wheat +James Earl Douglas Jan Path Jason Dagit Jean-Philippe Bernardy @@ -168,6 +175,7 @@ Josef Svenningsson Josh Hoyt Josh Kalderimis +Josh Meredith Judah Jacobson Jürgen Nicklisch-Franken Karel Gardas @@ -200,6 +208,7 @@ Masahiro Yamauchi Mathieu Boespflug Matt Renaud +Matthew Pickering Matthew William Cox Matthias Fischmann Matthias Kilian @@ -253,6 +262,7 @@ Phil Ruffwind Philipp Schumann Philipp Schuster +Piyush P Kurur Pranit Bauva Prayag Verma Randy Polen @@ -274,6 +284,8 @@ Ryan Scott Ryan Trinkle RyanGlScott +Sam Boosalis +Sam Halliday Samuel Bronson Samuel Gélineau Sergei Trofimovich @@ -305,21 +317,27 @@ Tim Humphries Tim McGilchrist Tomas Vestelind +Toon Nolten Toshio Ito Travis Cardwell Travis Whitaker +Tseen She Tuncer Ayaz Vaibhav Sagar +Vanessa McHale Veronika Romashkina Vincent Hanquez Vladislav Zavialov Vo Minh Thu +Wasif Hasan Baig Wojciech Danilo Yitzchak Gale Yuras Shumovich Yuriy Syrovetskiy -Zejun Wu +Zejun Wu capsjac +codetriage-readme-bot +fendor ghthrowaway7 <41365123+ghthrowaway7@users.noreply.github.com> quasicomputational vedksah <31156362+vedksah@users.noreply.github.com> diff --git a/cabal/CONTRIBUTING.md b/cabal/CONTRIBUTING.md --- a/cabal/CONTRIBUTING.md +++ b/cabal/CONTRIBUTING.md @@ -78,8 +78,6 @@ already failed), be nice to others and cancel the rest of the jobs, so that other commits on the build queue can be processed. -* If you want realtime notification when builds of your PRs finish, we have a [Slack team](https://haskell-cabal.slack.com/). To get issued an invite, fill in your email at [this sign up page](https://haskell-cabal.herokuapp.com). - **How to debug a failing CI test.** One of the annoying things about running tests on CI is when they fail, there is often no easy way to further troubleshoot the broken diff --git a/cabal/Cabal/Cabal.cabal b/cabal/Cabal/Cabal.cabal --- a/cabal/Cabal/Cabal.cabal +++ b/cabal/Cabal/Cabal.cabal @@ -35,6 +35,8 @@ -- BEGIN gen-extra-source-files tests/ParserTests/errors/MiniAgda.cabal tests/ParserTests/errors/MiniAgda.errors + tests/ParserTests/errors/big-version.cabal + tests/ParserTests/errors/big-version.errors tests/ParserTests/errors/common1.cabal tests/ParserTests/errors/common1.errors tests/ParserTests/errors/common2.cabal @@ -108,8 +110,13 @@ tests/ParserTests/regressions/Octree-0.5.cabal tests/ParserTests/regressions/Octree-0.5.expr tests/ParserTests/regressions/Octree-0.5.format + tests/ParserTests/regressions/assoc-cpp-options.cabal + tests/ParserTests/regressions/assoc-cpp-options.check tests/ParserTests/regressions/bad-glob-syntax.cabal tests/ParserTests/regressions/bad-glob-syntax.check + tests/ParserTests/regressions/big-version.cabal + tests/ParserTests/regressions/big-version.expr + tests/ParserTests/regressions/big-version.format tests/ParserTests/regressions/cc-options-with-optimization.cabal tests/ParserTests/regressions/cc-options-with-optimization.check tests/ParserTests/regressions/common-conditional.cabal @@ -159,6 +166,9 @@ tests/ParserTests/regressions/issue-5055.cabal tests/ParserTests/regressions/issue-5055.expr tests/ParserTests/regressions/issue-5055.format + tests/ParserTests/regressions/issue-5846.cabal + tests/ParserTests/regressions/issue-5846.expr + tests/ParserTests/regressions/issue-5846.format tests/ParserTests/regressions/issue-774.cabal tests/ParserTests/regressions/issue-774.check tests/ParserTests/regressions/issue-774.expr @@ -288,6 +298,10 @@ -- already depends on `fail` and `semigroups` transitively build-depends: fail == 4.9.*, semigroups >= 0.18.3 && < 0.20 + if !impl(ghc >= 7.8) + -- semigroups depends on tagged. + build-depends: tagged >=0.8.6 && <0.9 + exposed-modules: Distribution.Backpack Distribution.Backpack.Configure @@ -307,6 +321,7 @@ Distribution.Compat.Directory Distribution.Compat.Environment Distribution.Compat.Exception + Distribution.Compat.FilePath Distribution.Compat.Graph Distribution.Compat.Internal.TempFile Distribution.Compat.Newtype @@ -404,6 +419,7 @@ Distribution.Types.BuildInfo Distribution.Types.BuildType Distribution.Types.ComponentInclude + Distribution.Types.ConfVar Distribution.Types.Dependency Distribution.Types.ExeDependency Distribution.Types.LegacyExeDependency @@ -417,6 +433,7 @@ Distribution.Types.ExecutableScope Distribution.Types.Library Distribution.Types.LibraryVisibility + Distribution.Types.Flag Distribution.Types.ForeignLib Distribution.Types.ForeignLibType Distribution.Types.ForeignLibOption @@ -525,8 +542,10 @@ Distribution.Backpack.Id Distribution.Utils.UnionFind Distribution.Utils.Base62 + Distribution.Compat.Async Distribution.Compat.CopyFile Distribution.Compat.GetShortPathName + Distribution.Compat.MD5 Distribution.Compat.MonadFail Distribution.Compat.Prelude Distribution.Compat.SnocList @@ -583,9 +602,10 @@ Test.Laws Test.QuickCheck.Utils UnitTests.Distribution.Compat.CreatePipe - UnitTests.Distribution.Compat.Time UnitTests.Distribution.Compat.Graph + UnitTests.Distribution.Compat.Time UnitTests.Distribution.Simple.Glob + UnitTests.Distribution.Simple.Program.GHC UnitTests.Distribution.Simple.Program.Internal UnitTests.Distribution.Simple.Utils UnitTests.Distribution.SPDX @@ -606,14 +626,15 @@ directory, filepath, integer-logarithms >= 1.0.2 && <1.1, - tasty >= 1.1.0.3 && < 1.2, + tasty >= 1.2.3 && < 1.3, tasty-hunit, tasty-quickcheck, tagged, temporary, text, pretty, - QuickCheck >= 2.11.3 && < 2.12, + Diff >=0.4 && <0.5, + QuickCheck >= 2.13.2 && < 2.14, Cabal ghc-options: -Wall default-language: Haskell2010 @@ -624,15 +645,15 @@ main-is: ParserTests.hs build-depends: base, - base-compat >=0.10.4 && <0.11, + base-compat >=0.11.0 && <0.12, bytestring, directory, filepath, - tasty >= 1.1.0.3 && < 1.2, + tasty >= 1.2.3 && < 1.3, tasty-hunit, tasty-quickcheck, tasty-golden >=2.3.1.1 && <2.4, - Diff >=0.3.4 && <0.4, + Diff >=0.4 && <0.5, Cabal ghc-options: -Wall default-language: Haskell2010 @@ -642,7 +663,7 @@ if impl(ghc >= 7.8) build-depends: - tree-diff >= 0.0.2 && <0.1 + tree-diff >= 0.1 && <0.2 other-modules: Instances.TreeDiff Instances.TreeDiff.Language @@ -658,9 +679,9 @@ bytestring, directory, filepath, - tasty >= 1.1.0.3 && < 1.2, + tasty >= 1.2.3 && < 1.3, tasty-golden >=2.3.1.1 && <2.4, - Diff >=0.3.4 && <0.4, + Diff >=0.4 && <0.5, Cabal ghc-options: -Wall default-language: Haskell2010 @@ -702,15 +723,15 @@ filepath build-depends: - base-compat >=0.10.4 && <0.11, + base-compat >=0.11.0 && <0.12, base-orphans >=0.6 && <0.9, - optparse-applicative >=0.13.2.0 && <0.15, + optparse-applicative >=0.13.2.0 && <0.16, stm >=2.4.5.0 && <2.6, tar >=0.5.0.3 && <0.6 if impl(ghc >= 7.8) build-depends: - tree-diff >= 0.0.2 && <0.1 + tree-diff >= 0.1 && <0.2 other-modules: Instances.TreeDiff Instances.TreeDiff.Language @@ -732,7 +753,7 @@ bytestring build-depends: - tasty >= 1.1.0.3 && < 1.2, + tasty >= 1.2.3 && < 1.3, tasty-hunit, tasty-quickcheck, QuickCheck diff --git a/cabal/Cabal/ChangeLog.md b/cabal/Cabal/ChangeLog.md --- a/cabal/Cabal/ChangeLog.md +++ b/cabal/Cabal/ChangeLog.md @@ -1,7 +1,17 @@ # 3.1.0.0 (current development version) - -# 3.0.0.0 TBD + * `cabal check` verifies `cpp-options` more pedantically, allowing only + options starting with `-D` and `-U`. * TODO + + ---- + +# 3.0.0.0 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) August 2019 + * The 3.0 migration guide gives advice on adapting Custom setup + scripts to backwards-incompatible changes in this release: + https://github.com/haskell/cabal/wiki/3.0-migration-guide. + * Due to [#5119](https://github.com/haskell/cabal/issues/5119), the + `cabal check` warning for bounds on internal libraries has been + disabled. * Introduce set notation for `^>=` and `==` operators ([#5906](https://github.com/haskell/cabal/pull/5906)). * 'check' reports warnings for various ghc-\*-options fields separately @@ -34,6 +44,8 @@ add default implementation in terms of `coerce` / `unsafeCoerce`. * Implement support for response file arguments to defaultMain* and cabal-install. * Uniformly provide 'Semigroup' instances for `base < 4.9` via `semigroups` package + * Implement `{cmm,asm}-{sources,options} buildinfo fields for + separate compilation of C-- and ASM source files (#6033). * Setting `debug-info` now implies `library-stripping: False` and `executable-stripping: False) ([#2702](https://github.com/haskell/cabal/issues/2702)) * `Setup.hs copy` and `install` now work in the presence of @@ -65,7 +77,6 @@ ([#5503](https://github.com/haskell/cabal/issues/5503)). # 2.4.0.0 [Mikhail Glushenkov](mailto:mikhail.glushenkov@gmail.com) September 2018 - * Due to [#5119](https://github.com/haskell/cabal/issues/5119), the `cabal check` warning for bounds on internal libraries has been disabled. @@ -220,7 +231,7 @@ types (#4701). * Support for building with Win32 version 2.6 (#4835). * Change `compilerExtensions` and `ghcOptExtensionMap` to contain - `Maybe Flag`s, since a supported extention can lack a flag (#4443). + `Maybe Flag`s, since a supported extension can lack a flag (#4443). * Pretty-printing of `.cabal` files is slightly different due to parser changes. For an example, see https://mail.haskell.org/pipermail/cabal-devel/2017-December/010414.html. @@ -466,7 +477,7 @@ * Support GHC 7.10. * Experimental support for emitting DWARF debug info. * Preliminary support for relocatable packages. - * Allow cabal to be used inside cabal exec enviroments. + * Allow cabal to be used inside cabal exec environments. * hpc: support multiple "ways" (e.g. profiling and vanilla). * Support GHCJS. * Improved command line documentation. @@ -802,7 +813,7 @@ * It is no longer necessary to run `configure` before `clean` or `sdist` * Added support for ghc's `-split-objs` * Initial support for JHC - * Ignore extension fields in `.cabal` files (fields begining with "`x-`") + * Ignore extension fields in `.cabal` files (fields beginning with "`x-`") * Some changes to command hooks API to improve consistency * Hugs support improvements * Added GeneralisedNewtypeDeriving language extension diff --git a/cabal/Cabal/Distribution/Backpack.hs b/cabal/Cabal/Distribution/Backpack.hs --- a/cabal/Cabal/Distribution/Backpack.hs +++ b/cabal/Cabal/Distribution/Backpack.hs @@ -54,7 +54,6 @@ import Distribution.Utils.Base62 import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set ----------------------------------------------------------------------- diff --git a/cabal/Cabal/Distribution/Backpack/ComponentsGraph.hs b/cabal/Cabal/Distribution/Backpack/ComponentsGraph.hs --- a/cabal/Cabal/Distribution/Backpack/ComponentsGraph.hs +++ b/cabal/Cabal/Distribution/Backpack/ComponentsGraph.hs @@ -19,6 +19,7 @@ import Distribution.Types.UnqualComponentName import Distribution.Compat.Graph (Graph, Node(..)) import qualified Distribution.Compat.Graph as Graph +import Distribution.Utils.Generic import Distribution.Pretty (pretty) import Text.PrettyPrint @@ -94,4 +95,4 @@ text $ "Components in the package depend on each other in a cyclic way:\n " ++ intercalate " depends on " [ "'" ++ showComponentName cname ++ "'" - | cname <- cnames ++ [head cnames] ] + | cname <- cnames ++ maybeToList (safeHead cnames) ] diff --git a/cabal/Cabal/Distribution/Backpack/ModSubst.hs b/cabal/Cabal/Distribution/Backpack/ModSubst.hs --- a/cabal/Cabal/Distribution/Backpack/ModSubst.hs +++ b/cabal/Cabal/Distribution/Backpack/ModSubst.hs @@ -13,12 +13,10 @@ import Prelude () import Distribution.Compat.Prelude hiding (mod) -import Distribution.ModuleName - import Distribution.Backpack +import Distribution.ModuleName import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set -- | Applying module substitutions to semantic objects. diff --git a/cabal/Cabal/Distribution/Backpack/ModuleShape.hs b/cabal/Cabal/Distribution/Backpack/ModuleShape.hs --- a/cabal/Cabal/Distribution/Backpack/ModuleShape.hs +++ b/cabal/Cabal/Distribution/Backpack/ModuleShape.hs @@ -17,7 +17,6 @@ import Distribution.Backpack import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set ----------------------------------------------------------------------- diff --git a/cabal/Cabal/Distribution/Backpack/PreModuleShape.hs b/cabal/Cabal/Distribution/Backpack/PreModuleShape.hs --- a/cabal/Cabal/Distribution/Backpack/PreModuleShape.hs +++ b/cabal/Cabal/Distribution/Backpack/PreModuleShape.hs @@ -11,7 +11,6 @@ import Prelude () import Distribution.Compat.Prelude -import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map diff --git a/cabal/Cabal/Distribution/CabalSpecVersion.hs b/cabal/Cabal/Distribution/CabalSpecVersion.hs --- a/cabal/Cabal/Distribution/CabalSpecVersion.hs +++ b/cabal/Cabal/Distribution/CabalSpecVersion.hs @@ -26,12 +26,14 @@ | CabalSpecV2_2 | CabalSpecV2_4 | CabalSpecV3_0 + | CabalSpecV3_2 deriving (Eq, Ord, Show, Read, Enum, Bounded, Typeable, Data, Generic) -- | Show cabal spec version, but not the way in the .cabal files -- -- @since 3.0.0.0 showCabalSpecVersion :: CabalSpecVersion -> String +showCabalSpecVersion CabalSpecV3_2 = "3.2" showCabalSpecVersion CabalSpecV3_0 = "3.0" showCabalSpecVersion CabalSpecV2_4 = "2.4" showCabalSpecVersion CabalSpecV2_2 = "2.2" @@ -49,10 +51,11 @@ showCabalSpecVersion CabalSpecV1_0 = "1.0" cabalSpecLatest :: CabalSpecVersion -cabalSpecLatest = CabalSpecV3_0 +cabalSpecLatest = CabalSpecV3_2 cabalSpecFromVersionDigits :: [Int] -> CabalSpecVersion cabalSpecFromVersionDigits v + | v >= [3,1] = CabalSpecV3_2 | v >= [2,5] = CabalSpecV3_0 | v >= [2,3] = CabalSpecV2_4 | v >= [2,1] = CabalSpecV2_2 diff --git a/cabal/Cabal/Distribution/Compat/Async.hs b/cabal/Cabal/Distribution/Compat/Async.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Compat/Async.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | 'Async', yet using 'MVar's. +-- +-- Adopted from @async@ library +-- Copyright (c) 2012, Simon Marlow +-- Licensed under BSD-3-Clause +-- +module Distribution.Compat.Async ( + AsyncM, + withAsync, waitCatch, + wait, asyncThreadId, + cancel, uninterruptibleCancel, AsyncCancelled (..), + -- * Cabal extras + withAsyncNF, + ) where + +import Control.Concurrent (ThreadId, forkIO) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) +import Control.DeepSeq (NFData, force) +import Control.Exception + (BlockedIndefinitelyOnMVar (..), Exception (..), SomeException (..), catch, evaluate, mask, throwIO, throwTo, try, uninterruptibleMask_) +import Control.Monad (void) +import Data.Typeable (Typeable) +import GHC.Exts (inline) + +#if MIN_VERSION_base(4,7,0) +import Control.Exception (asyncExceptionFromException, asyncExceptionToException) +#endif + +-- | Async, but based on 'MVar', as we don't depend on @stm@. +data AsyncM a = Async + { asyncThreadId :: {-# UNPACK #-} !ThreadId + -- ^ Returns the 'ThreadId' of the thread running + -- the given 'Async'. + , _asyncMVar :: MVar (Either SomeException a) + } + +-- | Spawn an asynchronous action in a separate thread, and pass its +-- @Async@ handle to the supplied function. When the function returns +-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@. +-- +-- > withAsync action inner = mask $ \restore -> do +-- > a <- async (restore action) +-- > restore (inner a) `finally` uninterruptibleCancel a +-- +-- This is a useful variant of 'async' that ensures an @Async@ is +-- never left running unintentionally. +-- +-- Note: a reference to the child thread is kept alive until the call +-- to `withAsync` returns, so nesting many `withAsync` calls requires +-- linear memory. +-- +withAsync :: IO a -> (AsyncM a -> IO b) -> IO b +withAsync = inline withAsyncUsing forkIO + +withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b +withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) where + evaluateNF = evaluate . force + +withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b +-- The bracket version works, but is slow. We can do better by +-- hand-coding it: +withAsyncUsing doFork = \action inner -> do + var <- newEmptyMVar + mask $ \restore -> do + t <- doFork $ try (restore action) >>= putMVar var + let a = Async t var + r <- restore (inner a) `catchAll` \e -> do + uninterruptibleCancel a + throwIO e + uninterruptibleCancel a + return r + +-- | Wait for an asynchronous action to complete, and return its +-- value. If the asynchronous action threw an exception, then the +-- exception is re-thrown by 'wait'. +-- +-- > wait = atomically . waitSTM +-- +{-# INLINE wait #-} +wait :: AsyncM a -> IO a +wait a = do + res <- waitCatch a + case res of + Left (SomeException e) -> throwIO e + Right x -> return x + +-- | Wait for an asynchronous action to complete, and return either +-- @Left e@ if the action raised an exception @e@, or @Right a@ if it +-- returned a value @a@. +-- +-- > waitCatch = atomically . waitCatchSTM +-- +{-# INLINE waitCatch #-} +waitCatch :: AsyncM a -> IO (Either SomeException a) +waitCatch (Async _ var) = tryAgain (readMVar var) + where + -- See: https://github.com/simonmar/async/issues/14 + tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f + +catchAll :: IO a -> (SomeException -> IO a) -> IO a +catchAll = catch + +-- | Cancel an asynchronous action by throwing the @AsyncCancelled@ +-- exception to it, and waiting for the `Async` thread to quit. +-- Has no effect if the 'Async' has already completed. +-- +-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a +-- +-- Note that 'cancel' will not terminate until the thread the 'Async' +-- refers to has terminated. This means that 'cancel' will block for +-- as long said thread blocks when receiving an asynchronous exception. +-- +-- For example, it could block if: +-- +-- * It's executing a foreign call, and thus cannot receive the asynchronous +-- exception; +-- * It's executing some cleanup handler after having received the exception, +-- and the handler is blocking. +{-# INLINE cancel #-} +cancel :: AsyncM a -> IO () +cancel a@(Async t _) = do + throwTo t AsyncCancelled + void (waitCatch a) + +-- | The exception thrown by `cancel` to terminate a thread. +data AsyncCancelled = AsyncCancelled + deriving (Show, Eq + , Typeable + ) + +instance Exception AsyncCancelled where +#if MIN_VERSION_base(4,7,0) + -- wraps in SomeAsyncException + -- See https://github.com/ghc/ghc/commit/756a970eacbb6a19230ee3ba57e24999e4157b09 + fromException = asyncExceptionFromException + toException = asyncExceptionToException +#endif + +-- | Cancel an asynchronous action +-- +-- This is a variant of `cancel`, but it is not interruptible. +{-# INLINE uninterruptibleCancel #-} +uninterruptibleCancel :: AsyncM a -> IO () +uninterruptibleCancel = uninterruptibleMask_ . cancel diff --git a/cabal/Cabal/Distribution/Compat/DList.hs b/cabal/Cabal/Distribution/Compat/DList.hs --- a/cabal/Cabal/Distribution/Compat/DList.hs +++ b/cabal/Cabal/Distribution/Compat/DList.hs @@ -19,7 +19,7 @@ ) where import Prelude () -import Distribution.Compat.Prelude +import Distribution.Compat.Prelude hiding (toList) -- | Difference list. newtype DList a = DList ([a] -> [a]) diff --git a/cabal/Cabal/Distribution/Compat/FilePath.hs b/cabal/Cabal/Distribution/Compat/FilePath.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Compat/FilePath.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +module Distribution.Compat.FilePath +( isExtensionOf +, stripExtension +) where + +import Data.List ( isSuffixOf, stripPrefix ) +import System.FilePath + +#if !MIN_VERSION_filepath(1,4,2) +isExtensionOf :: String -> FilePath -> Bool +isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions +isExtensionOf ext = isSuffixOf ('.':ext) . takeExtensions +#endif + +#if !MIN_VERSION_filepath(1,4,1) +stripExtension :: String -> FilePath -> Maybe FilePath +stripExtension [] path = Just path +stripExtension ext@(x:_) path = stripSuffix dotExt path + where + dotExt = if isExtSeparator x then ext else '.':ext + stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] + stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys) +#endif diff --git a/cabal/Cabal/Distribution/Compat/Graph.hs b/cabal/Cabal/Distribution/Compat/Graph.hs --- a/cabal/Cabal/Distribution/Compat/Graph.hs +++ b/cabal/Cabal/Distribution/Compat/Graph.hs @@ -85,7 +85,7 @@ import Prelude () import qualified Distribution.Compat.Prelude as Prelude -import Distribution.Compat.Prelude hiding (lookup, null, empty) +import Distribution.Compat.Prelude hiding (lookup, null, empty, toList) import Data.Graph (SCC(..)) import qualified Data.Graph as G diff --git a/cabal/Cabal/Distribution/Compat/Lens.hs b/cabal/Cabal/Distribution/Compat/Lens.hs --- a/cabal/Cabal/Distribution/Compat/Lens.hs +++ b/cabal/Cabal/Distribution/Compat/Lens.hs @@ -51,7 +51,6 @@ import Distribution.Compat.Prelude import Control.Applicative (Const (..)) -import Data.Functor.Identity (Identity (..)) import Control.Monad.State.Class (MonadState (..), gets, modify) import qualified Distribution.Compat.DList as DList @@ -72,7 +71,7 @@ type Getting r s a = LensLike (Const r) s s a a -type AGetter s a = LensLike (Const a) s s a a -- this doens't exist in 'lens' +type AGetter s a = LensLike (Const a) s s a a -- this doesn't exist in 'lens' type ASetter s t a b = LensLike Identity s t a b type ALens s t a b = LensLike (Pretext a b) s t a b diff --git a/cabal/Cabal/Distribution/Compat/MD5.hs b/cabal/Cabal/Distribution/Compat/MD5.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Compat/MD5.hs @@ -0,0 +1,50 @@ +module Distribution.Compat.MD5 ( + MD5, + showMD5, + md5, + -- * Binary + binaryPutMD5, + binaryGetMD5, + ) where + +import Data.Binary (Get, Put) +import Data.Binary.Get (getWord64le) +import Data.Binary.Put (putWord64le) +import Foreign.Ptr (castPtr) +import GHC.Fingerprint (Fingerprint (..), fingerprintData) +import Numeric (showHex) +import System.IO.Unsafe (unsafeDupablePerformIO) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS + +type MD5 = Fingerprint + +-- | Show 'MD5' in human readable form +-- +-- >>> showMD5 (Fingerprint 123 456) +-- "000000000000007b00000000000001c8" +-- +-- >>> showMD5 $ md5 $ BS.pack [0..127] +-- "37eff01866ba3f538421b30b7cbefcac" +-- +showMD5 :: MD5 -> String +showMD5 (Fingerprint a b) = pad a' ++ pad b' where + a' = showHex a "" + b' = showHex b "" + pad s = replicate (16 - length s) '0' ++ s + +md5 :: BS.ByteString -> MD5 +md5 bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> + fingerprintData (castPtr ptr) len + +binaryPutMD5 :: MD5 -> Put +binaryPutMD5 (Fingerprint a b) = do + putWord64le a + putWord64le b + +binaryGetMD5 :: Get MD5 +binaryGetMD5 = do + a <- getWord64le + b <- getWord64le + return (Fingerprint a b) diff --git a/cabal/Cabal/Distribution/Compat/Parsing.hs b/cabal/Cabal/Distribution/Compat/Parsing.hs --- a/cabal/Cabal/Distribution/Compat/Parsing.hs +++ b/cabal/Cabal/Distribution/Compat/Parsing.hs @@ -25,13 +25,10 @@ , some -- from Control.Applicative, parsec many1 , many -- from Control.Applicative , sepBy - , sepBy1 , sepByNonEmpty - , sepEndBy1 - -- , sepEndByNonEmpty + , sepEndByNonEmpty , sepEndBy - , endBy1 - -- , endByNonEmpty + , endByNonEmpty , endBy , count , chainl @@ -58,6 +55,7 @@ import Control.Monad.Trans.Identity (IdentityT (..)) import Data.Foldable (asum) +import qualified Data.List.NonEmpty as NE import qualified Text.Parsec as Parsec -- | @choice ps@ tries to apply the parsers in the list @ps@ in order, @@ -96,36 +94,20 @@ -- -- > commaSep p = p `sepBy` (symbol ",") sepBy :: Alternative m => m a -> m sep -> m [a] -sepBy p sep = sepBy1 p sep <|> pure [] +sepBy p sep = toList <$> sepByNonEmpty p sep <|> pure [] {-# INLINE sepBy #-} --- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated --- by @sep@. Returns a list of values returned by @p@. -sepBy1 :: Alternative m => m a -> m sep -> m [a] -sepBy1 p sep = (:) <$> p <*> many (sep *> p) --- toList <$> sepByNonEmpty p sep -{-# INLINE sepBy1 #-} - -- | @sepByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated -- by @sep@. Returns a non-empty list of values returned by @p@. sepByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p) {-# INLINE sepByNonEmpty #-} --- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@, --- separated and optionally ended by @sep@. Returns a list of values --- returned by @p@. -sepEndBy1 :: Alternative m => m a -> m sep -> m [a] -sepEndBy1 p sep = (:) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) --- toList <$> sepEndByNonEmpty p sep - -{- -- | @sepEndByNonEmpty p sep@ parses /one/ or more occurrences of @p@, -- separated and optionally ended by @sep@. Returns a non-empty list of values -- returned by @p@. sepEndByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) sepEndByNonEmpty p sep = (:|) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) --} -- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, -- separated and optionally ended by @sep@, ie. haskell style @@ -133,22 +115,14 @@ -- -- > haskellStatements = haskellStatement `sepEndBy` semi sepEndBy :: Alternative m => m a -> m sep -> m [a] -sepEndBy p sep = sepEndBy1 p sep <|> pure [] +sepEndBy p sep = toList <$> sepEndByNonEmpty p sep <|> pure [] {-# INLINE sepEndBy #-} --- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, separated --- and ended by @sep@. Returns a list of values returned by @p@. -endBy1 :: Alternative m => m a -> m sep -> m [a] -endBy1 p sep = some (p <* sep) -{-# INLINE endBy1 #-} - -{- -- | @endByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated -- and ended by @sep@. Returns a non-empty list of values returned by @p@. endByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) -endByNonEmpty p sep = some1 (p <* sep) +endByNonEmpty p sep = NE.some1 (p <* sep) {-# INLINE endByNonEmpty #-} --} -- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated -- and ended by @sep@. Returns a list of values returned by @p@. diff --git a/cabal/Cabal/Distribution/Compat/Prelude.hs b/cabal/Cabal/Distribution/Compat/Prelude.hs --- a/cabal/Cabal/Distribution/Compat/Prelude.hs +++ b/cabal/Cabal/Distribution/Compat/Prelude.hs @@ -45,6 +45,9 @@ -- * Some types IO, NoCallStackIO, Map, + Set, + Identity (..), + Proxy (..), -- * Data.Maybe catMaybes, mapMaybe, @@ -61,6 +64,7 @@ -- * Data.List.NonEmpty NonEmpty((:|)), foldl1, foldr1, + head, tail, last, init, -- * Data.Foldable Foldable, foldMap, foldr, @@ -68,6 +72,7 @@ find, foldl', traverse_, for_, any, all, + toList, -- * Data.Traversable Traversable, traverse, sequenceA, @@ -100,7 +105,7 @@ ) where -- We also could hide few partial function import Prelude as BasePrelude hiding - ( IO, mapM, mapM_, sequence, null, length, foldr, any, all + ( IO, mapM, mapM_, sequence, null, length, foldr, any, all, head, tail, last, init -- partial functions , read , foldr1, foldl1 @@ -120,8 +125,9 @@ #if !MINVER_base_48 import Control.Applicative (Applicative (..), (<$), (<$>)) import Distribution.Compat.Semigroup (Monoid (..)) +import Data.Foldable (toList) #else -import Data.Foldable (length, null) +import Data.Foldable (length, null, Foldable(toList)) #endif import Data.Foldable (Foldable (foldMap, foldr), find, foldl', for_, traverse_, any, all) @@ -138,7 +144,10 @@ V1, U1(U1), K1(unK1), M1(unM1), (:*:)((:*:)), (:+:)(L1,R1)) +import Data.Functor.Identity (Identity (..)) import Data.Map (Map) +import Data.Proxy (Proxy (..)) +import Data.Set (Set) import Control.Arrow (first) import Control.Monad hiding (mapM) @@ -146,7 +155,7 @@ import Data.List (intercalate, intersperse, isPrefixOf, isSuffixOf, nub, nubBy, sort, sortBy, unfoldr) -import Data.List.NonEmpty (NonEmpty((:|))) +import Data.List.NonEmpty (NonEmpty((:|)), head, tail, init, last) import Data.Maybe import Data.String (IsString (..)) import Data.Int diff --git a/cabal/Cabal/Distribution/FieldGrammar/Class.hs b/cabal/Cabal/Distribution/FieldGrammar/Class.hs --- a/cabal/Cabal/Distribution/FieldGrammar/Class.hs +++ b/cabal/Cabal/Distribution/FieldGrammar/Class.hs @@ -10,8 +10,6 @@ import Distribution.Compat.Prelude import Prelude () -import Data.Functor.Identity (Identity (..)) - import Distribution.CabalSpecVersion (CabalSpecVersion) import Distribution.Compat.Newtype (Newtype) import Distribution.Fields.Field diff --git a/cabal/Cabal/Distribution/FieldGrammar/Parsec.hs b/cabal/Cabal/Distribution/FieldGrammar/Parsec.hs --- a/cabal/Cabal/Distribution/FieldGrammar/Parsec.hs +++ b/cabal/Cabal/Distribution/FieldGrammar/Parsec.hs @@ -47,7 +47,7 @@ -- is obviously invalid specification. -- -- We can parse 'Fields' like we parse @aeson@ objects, yet we use --- slighly higher-level API, so we can process unspecified fields, +-- slightly higher-level API, so we can process unspecified fields, -- to report unknown fields and save custom @x-fields@. -- module Distribution.FieldGrammar.Parsec ( @@ -66,17 +66,17 @@ import Data.List (dropWhileEnd) import Data.Ord (comparing) -import Data.Set (Set) import Distribution.Compat.Newtype import Distribution.Compat.Prelude import Distribution.Simple.Utils (fromUTF8BS) import Prelude () -import qualified Data.ByteString as BS -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Text.Parsec as P -import qualified Text.Parsec.Error as P +import qualified Data.ByteString as BS +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Text.Parsec as P +import qualified Text.Parsec.Error as P import Distribution.CabalSpecVersion import Distribution.FieldGrammar.Class @@ -156,12 +156,12 @@ uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of - Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing" - Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing" - Just [x] -> parseOne v x - Just xs -> do + Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing" + Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing" + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do warnMultipleSingularFields fn xs - last <$> traverse (parseOne v) xs + NE.last <$> traverse (parseOne v) (y:|ys) parseOne v (MkNamelessField pos fls) = unpack' _pack <$> runFieldParser pos parsec v fls @@ -169,24 +169,24 @@ booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of - Nothing -> pure def - Just [] -> pure def - Just [x] -> parseOne v x - Just xs -> do + Nothing -> pure def + Just [] -> pure def + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do warnMultipleSingularFields fn xs - last <$> traverse (parseOne v) xs + NE.last <$> traverse (parseOne v) (y:|ys) parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of - Nothing -> pure Nothing - Just [] -> pure Nothing - Just [x] -> parseOne v x - Just xs -> do + Nothing -> pure Nothing + Just [] -> pure Nothing + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do warnMultipleSingularFields fn xs - last <$> traverse (parseOne v) xs + NE.last <$> traverse (parseOne v) (y:|ys) parseOne v (MkNamelessField pos fls) | null fls = pure Nothing @@ -195,12 +195,12 @@ optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of - Nothing -> pure def - Just [] -> pure def - Just [x] -> parseOne v x - Just xs -> do + Nothing -> pure def + Just [] -> pure def + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do warnMultipleSingularFields fn xs - last <$> traverse (parseOne v) xs + NE.last <$> traverse (parseOne v) (y:|ys) parseOne v (MkNamelessField pos fls) | null fls = pure def @@ -208,12 +208,12 @@ freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of - Nothing -> pure Nothing - Just [] -> pure Nothing - Just [x] -> parseOne v x - Just xs -> do + Nothing -> pure Nothing + Just [] -> pure Nothing + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do warnMultipleSingularFields fn xs - last <$> traverse (parseOne v) xs + NE.last <$> traverse (parseOne v) (y:|ys) parseOne v (MkNamelessField pos fls) | null fls = pure Nothing @@ -222,12 +222,12 @@ freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of - Nothing -> pure "" - Just [] -> pure "" - Just [x] -> parseOne v x - Just xs -> do + Nothing -> pure "" + Just [] -> pure "" + Just [x] -> parseOne v x + Just xs@(_:y:ys) -> do warnMultipleSingularFields fn xs - last <$> traverse (parseOne v) xs + NE.last <$> traverse (parseOne v) (y:|ys) parseOne v (MkNamelessField pos fls) | null fls = pure "" diff --git a/cabal/Cabal/Distribution/Fields/ConfVar.hs b/cabal/Cabal/Distribution/Fields/ConfVar.hs --- a/cabal/Cabal/Distribution/Fields/ConfVar.hs +++ b/cabal/Cabal/Distribution/Fields/ConfVar.hs @@ -9,7 +9,7 @@ import Distribution.Fields.Field (SectionArg (..)) import Distribution.Fields.ParseResult import Distribution.Types.Condition -import Distribution.Types.GenericPackageDescription (ConfVar (..)) +import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Version (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, majorBoundVersion, mkVersion, noVersion, orEarlierVersion, orLaterVersion, thisVersion, unionVersionRanges, diff --git a/cabal/Cabal/Distribution/Fields/Field.hs b/cabal/Cabal/Distribution/Fields/Field.hs --- a/cabal/Cabal/Distribution/Fields/Field.hs +++ b/cabal/Cabal/Distribution/Fields/Field.hs @@ -47,7 +47,7 @@ fieldAnn :: Field ann -> ann fieldAnn = nameAnn . fieldName --- | All transitive descendands of 'Field', including itself. +-- | All transitive descendants of 'Field', including itself. -- -- /Note:/ the resulting list is never empty. -- diff --git a/cabal/Cabal/Distribution/Fields/Lexer.hs b/cabal/Cabal/Distribution/Fields/Lexer.hs --- a/cabal/Cabal/Distribution/Fields/Lexer.hs +++ b/cabal/Cabal/Distribution/Fields/Lexer.hs @@ -60,11 +60,11 @@ #endif #if __GLASGOW_HASKELL__ >= 503 import Data.Array -import Data.Array.Base (unsafeAt) #else import Array #endif #if __GLASGOW_HASKELL__ >= 503 +import Data.Array.Base (unsafeAt) import GHC.Exts #else import GlaExts diff --git a/cabal/Cabal/Distribution/Fields/LexerMonad.hs b/cabal/Cabal/Distribution/Fields/LexerMonad.hs --- a/cabal/Cabal/Distribution/Fields/LexerMonad.hs +++ b/cabal/Cabal/Distribution/Fields/LexerMonad.hs @@ -32,6 +32,7 @@ ) where import qualified Data.ByteString as B +import qualified Data.List.NonEmpty as NE import Distribution.Compat.Prelude import Distribution.Parsec.Position (Position (..), showPos) import Distribution.Parsec.Warning (PWarnType (..), PWarning (..)) @@ -76,15 +77,15 @@ toPWarnings = map (uncurry toWarning) . Map.toList - . Map.fromListWith (++) - . map (\(LexWarning t p) -> (t, [p])) + . Map.fromListWith (<>) + . map (\(LexWarning t p) -> (t, pure p)) where toWarning LexWarningBOM poss = - PWarning PWTLexBOM (head poss) "Byte-order mark found at the beginning of the file" + PWarning PWTLexBOM (NE.head poss) "Byte-order mark found at the beginning of the file" toWarning LexWarningNBSP poss = - PWarning PWTLexNBSP (head poss) $ "Non breaking spaces at " ++ intercalate ", " (map showPos poss) + PWarning PWTLexNBSP (NE.head poss) $ "Non breaking spaces at " ++ intercalate ", " (NE.toList $ fmap showPos poss) toWarning LexWarningTab poss = - PWarning PWTLexTab (head poss) $ "Tabs used as indentation at " ++ intercalate ", " (map showPos poss) + PWarning PWTLexTab (NE.head poss) $ "Tabs used as indentation at " ++ intercalate ", " (NE.toList $ fmap showPos poss) data LexState = LexState { curPos :: {-# UNPACK #-} !Position, -- ^ position at current input location diff --git a/cabal/Cabal/Distribution/Fields/Pretty.hs b/cabal/Cabal/Distribution/Fields/Pretty.hs --- a/cabal/Cabal/Distribution/Fields/Pretty.hs +++ b/cabal/Cabal/Distribution/Fields/Pretty.hs @@ -20,7 +20,6 @@ prettySectionArgs, ) where -import Data.Functor.Identity (Identity (..)) import Distribution.Compat.Prelude import Distribution.Pretty (showToken) import Prelude () diff --git a/cabal/Cabal/Distribution/InstalledPackageInfo.hs b/cabal/Cabal/Distribution/InstalledPackageInfo.hs --- a/cabal/Cabal/Distribution/InstalledPackageInfo.hs +++ b/cabal/Cabal/Distribution/InstalledPackageInfo.hs @@ -43,7 +43,6 @@ import Distribution.Compat.Prelude import Prelude () -import Data.Set (Set) import Distribution.Backpack import Distribution.CabalSpecVersion (cabalSpecLatest) import Distribution.FieldGrammar diff --git a/cabal/Cabal/Distribution/ModuleName.hs b/cabal/Cabal/Distribution/ModuleName.hs --- a/cabal/Cabal/Distribution/ModuleName.hs +++ b/cabal/Cabal/Distribution/ModuleName.hs @@ -50,7 +50,7 @@ Disp.hcat (intersperse (Disp.char '.') (map Disp.text $ stlToStrings ms)) instance Parsec ModuleName where - parsec = fromComponents <$> P.sepBy1 component (P.char '.') + parsec = fromComponents <$> toList <$> P.sepByNonEmpty component (P.char '.') where component = do c <- P.satisfy isUpper diff --git a/cabal/Cabal/Distribution/PackageDescription.hs b/cabal/Cabal/Distribution/PackageDescription.hs --- a/cabal/Cabal/Distribution/PackageDescription.hs +++ b/cabal/Cabal/Distribution/PackageDescription.hs @@ -140,3 +140,5 @@ import Distribution.Types.LibraryName import Distribution.Types.HookedBuildInfo import Distribution.Types.SourceRepo +import Distribution.Types.Flag +import Distribution.Types.ConfVar diff --git a/cabal/Cabal/Distribution/PackageDescription/Check.hs b/cabal/Cabal/Distribution/PackageDescription/Check.hs --- a/cabal/Cabal/Distribution/PackageDescription/Check.hs +++ b/cabal/Cabal/Distribution/PackageDescription/Check.hs @@ -57,7 +57,7 @@ import Distribution.Types.ExeDependency import Distribution.Types.LibraryName import Distribution.Types.UnqualComponentName -import Distribution.Utils.Generic (isAscii) +import Distribution.Utils.Generic (isAscii, safeInit) import Distribution.Verbosity import Distribution.Version import Language.Haskell.Extension @@ -1026,13 +1026,18 @@ checkCCFlags flags = check (any (`elem` flags) all_cLikeOptions) checkCPPOptions :: PackageDescription -> [PackageCheck] -checkCPPOptions pkg = - catMaybes [ - checkAlternatives "cpp-options" "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions] +checkCPPOptions pkg = catMaybes + [ checkAlternatives "cpp-options" "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions ] ] - where all_cppOptions = [ opts | bi <- allBuildInfo pkg - , opts <- cppOptions bi ] + ++ + [ PackageBuildWarning $ "'cpp-options': " ++ opt ++ " is not portable C-preprocessor flag" + | opt <- all_cppOptions + -- "-I" is handled above, we allow only -DNEWSTUFF and -UOLDSTUFF + , not $ any (`isPrefixOf` opt) ["-D", "-U", "-I" ] + ] + where + all_cppOptions = [ opts | bi <- allBuildInfo pkg, opts <- cppOptions bi ] checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck @@ -1587,8 +1592,8 @@ boundedAbove :: VersionRange -> Bool boundedAbove vr = case asVersionIntervals vr of - [] -> True -- this is the inconsistent version range. - intervals -> case last intervals of + [] -> True -- this is the inconsistent version range. + (x:xs) -> case last (x:|xs) of (_, UpperBound _ _) -> True (_, NoUpperBound ) -> False @@ -2141,7 +2146,7 @@ Right (_:_) -> Just noSplit where -- drop the '/' between the name and prefix: - remainder = init h : rest + remainder = safeInit h : rest where nameMax, prefixMax :: Int diff --git a/cabal/Cabal/Distribution/PackageDescription/Configuration.hs b/cabal/Cabal/Distribution/PackageDescription/Configuration.hs --- a/cabal/Cabal/Distribution/PackageDescription/Configuration.hs +++ b/cabal/Cabal/Distribution/PackageDescription/Configuration.hs @@ -66,7 +66,6 @@ import qualified Data.Map.Strict as Map.Strict import qualified Data.Map.Lazy as Map -import Data.Set ( Set ) import qualified Data.Set as Set import Data.Tree ( Tree(Node) ) diff --git a/cabal/Cabal/Distribution/PackageDescription/FieldGrammar.hs b/cabal/Cabal/Distribution/PackageDescription/FieldGrammar.hs --- a/cabal/Cabal/Distribution/PackageDescription/FieldGrammar.hs +++ b/cabal/Cabal/Distribution/PackageDescription/FieldGrammar.hs @@ -390,7 +390,9 @@ -- I.e. we don't want trigger unknown field warning <*> monoidalFieldAla "cpp-options" (alaList' NoCommaFSep Token') L.cppOptions <*> monoidalFieldAla "asm-options" (alaList' NoCommaFSep Token') L.asmOptions + ^^^ availableSince CabalSpecV3_0 [] <*> monoidalFieldAla "cmm-options" (alaList' NoCommaFSep Token') L.cmmOptions + ^^^ availableSince CabalSpecV3_0 [] <*> monoidalFieldAla "cc-options" (alaList' NoCommaFSep Token') L.ccOptions <*> monoidalFieldAla "cxx-options" (alaList' NoCommaFSep Token') L.cxxOptions ^^^ availableSince CabalSpecV2_2 [] @@ -399,7 +401,9 @@ <*> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep FilePathNT) L.extraFrameworkDirs <*> monoidalFieldAla "asm-sources" (alaList' VCat FilePathNT) L.asmSources + ^^^ availableSince CabalSpecV3_0 [] <*> monoidalFieldAla "cmm-sources" (alaList' VCat FilePathNT) L.cmmSources + ^^^ availableSince CabalSpecV3_0 [] <*> monoidalFieldAla "c-sources" (alaList' VCat FilePathNT) L.cSources <*> monoidalFieldAla "cxx-sources" (alaList' VCat FilePathNT) L.cxxSources ^^^ availableSince CabalSpecV2_2 [] diff --git a/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs b/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs --- a/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs +++ b/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs @@ -126,17 +126,10 @@ thenDoc = go thenTree ppIf (CondBranch c thenTree (Just elseTree)) = - case (False, False) of - -- case (isEmpty thenDoc, isEmpty elseDoc) of - (True, True) -> mempty - (False, True) -> [ ppIfCondition c thenDoc ] - (True, False) -> [ ppIfCondition (cNot c) elseDoc ] - (False, False) -> [ ppIfCondition c thenDoc - , PrettySection () "else" [] elseDoc - ] - where - thenDoc = go thenTree - elseDoc = go elseTree + -- See #6193 + [ ppIfCondition c (go thenTree) + , PrettySection () "else" [] (go elseTree) + ] ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [PrettyField ()] ppCondLibrary _ Nothing = mempty diff --git a/cabal/Cabal/Distribution/PackageDescription/Quirks.hs b/cabal/Cabal/Distribution/PackageDescription/Quirks.hs --- a/cabal/Cabal/Distribution/PackageDescription/Quirks.hs +++ b/cabal/Cabal/Distribution/PackageDescription/Quirks.hs @@ -1,19 +1,17 @@ -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} -- | -- -- @since 2.2.0.0 module Distribution.PackageDescription.Quirks (patchQuirks) where -import Prelude () -import Distribution.Compat.Prelude -import GHC.Fingerprint (Fingerprint (..), fingerprintData) -import Foreign.Ptr (castPtr) -import System.IO.Unsafe (unsafeDupablePerformIO) +import Distribution.Compat.MD5 +import Distribution.Compat.Prelude +import GHC.Fingerprint (Fingerprint (..)) +import Prelude () import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS -import qualified Data.Map as Map +import qualified Data.Map as Map -- | Patch legacy @.cabal@ file contents to allow parsec parser to accept -- all of Hackage. @@ -30,13 +28,7 @@ where output = f bs -md5 :: BS.ByteString -> Fingerprint -md5 bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> - fingerprintData (castPtr ptr) len - -- | 'patches' contains first 256 bytes, pre- and post-fingerprints and a patch function. --- --- patches :: Map.Map (BS.ByteString, Fingerprint) (Fingerprint, BS.ByteString -> BS.ByteString) patches = Map.fromList -- http://hackage.haskell.org/package/unicode-transforms-0.3.3 @@ -241,6 +233,24 @@ (Fingerprint 12694656661460787751 1902242956706735615) (Fingerprint 15433152131513403849 2284712791516353264) (bsReplace "1.2.03.0" "1.2.3.0") + -- 9 digits limit + , mk "Name: SGplus\nVersion: 1.1\nSynopsis: (updated) Small geometry library for dealing with vectors and collision detection\nLicense: BSD3\nLicense-file: LICENSE\nAuthor: Neil Brown\nMaintainer: " + (Fingerprint 17735649550442248029 11493772714725351354) + (Fingerprint 9565458801063261772 15955773698774721052) + (bsReplace "1000000000" "100000000") + , mk "-- Initial control-dotdotdot.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\nname: control-dotdotdot\nversion: 0.1.0.1\nsynopsis: Haskell operator\n " + (Fingerprint 1514257173776509942 7756050823377346485) + (Fingerprint 14082092642045505999 18415918653404121035) + (bsReplace "9223372036854775807" "5") + , mk "name: data-foldapp\r\nversion: 0.1.1.0\r\nsynopsis: Fold function applications. Framework for variadic functions.\r\ndescription: Fold function applications. Framework for variadic functions.\r\nhomepage: ht" + (Fingerprint 4511234156311243251 11701153011544112556) + (Fingerprint 11820542702491924189 4902231447612406724) + (bsReplace "9223372036854775807" "999" . bsReplace "9223372036854775807" "999") + , mk "-- Initial data-list-zigzag.cabal generated by cabal init. For further \r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\nname: data-list-zigzag\r\nversion: 0.1.1.1\r\nsynopsis: A list but with a balanced en" + (Fingerprint 12475837388692175691 18053834261188158945) + (Fingerprint 16279938253437334942 15753349540193002309) + (bsReplace "9223372036854775807" "999") + ] where mk a b c d = ((a, b), (c, d)) diff --git a/cabal/Cabal/Distribution/Parsec.hs b/cabal/Cabal/Distribution/Parsec.hs --- a/cabal/Cabal/Distribution/Parsec.hs +++ b/cabal/Cabal/Distribution/Parsec.hs @@ -42,7 +42,6 @@ ) where import Data.Char (digitToInt, intToDigit) -import Data.Functor.Identity (Identity (..)) import Data.List (transpose) import Distribution.CabalSpecVersion import Distribution.Compat.Prelude @@ -260,8 +259,8 @@ parsecLeadingCommaList p = do c <- P.optional comma case c of - Nothing -> P.sepEndBy1 lp comma <|> pure [] - Just _ -> P.sepBy1 lp comma + Nothing -> toList <$> P.sepEndByNonEmpty lp comma <|> pure [] + Just _ -> toList <$> P.sepByNonEmpty lp comma where lp = p <* P.spaces comma = P.char ',' *> P.spaces P. "comma" @@ -269,7 +268,7 @@ parsecOptCommaList :: CabalParsing m => m a -> m [a] parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma) where - comma = P.char ',' *> P.spaces + comma = P.char ',' *> P.spaces -- | Like 'parsecOptCommaList' but -- @@ -290,7 +289,7 @@ c <- P.optional comma case c of Nothing -> sepEndBy1Start <|> pure [] - Just _ -> P.sepBy1 lp comma + Just _ -> toList <$> P.sepByNonEmpty lp comma where lp = p <* P.spaces comma = P.char ',' *> P.spaces P. "comma" @@ -311,7 +310,7 @@ parsecMaybeQuoted p = parsecQuoted p <|> p parsecUnqualComponentName :: CabalParsing m => m String -parsecUnqualComponentName = intercalate "-" <$> P.sepBy1 component (P.char '-') +parsecUnqualComponentName = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-') where component :: CabalParsing m => m String component = do diff --git a/cabal/Cabal/Distribution/Parsec/Newtypes.hs b/cabal/Cabal/Distribution/Parsec/Newtypes.hs --- a/cabal/Cabal/Distribution/Parsec/Newtypes.hs +++ b/cabal/Cabal/Distribution/Parsec/Newtypes.hs @@ -33,7 +33,6 @@ import Distribution.Compat.Prelude import Prelude () -import Data.Functor.Identity (Identity (..)) import Distribution.CabalSpecVersion import Distribution.Compiler (CompilerFlavor) import Distribution.License (License) @@ -61,13 +60,10 @@ -- | Paragraph fill list without commas. Displayed with 'fsep'. data NoCommaFSep = NoCommaFSep --- | Proxy, internal to this module. -data P sep = P - class Sep sep where - prettySep :: P sep -> [Doc] -> Doc + prettySep :: Proxy sep -> [Doc] -> Doc - parseSep :: CabalParsing m => P sep -> m a -> m [a] + parseSep :: CabalParsing m => Proxy sep -> m a -> m [a] instance Sep CommaVCat where prettySep _ = vcat . punctuate comma @@ -116,10 +112,10 @@ instance Newtype [a] (List sep wrapper a) instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where - parsec = pack . map (unpack :: b -> a) <$> parseSep (P :: P sep) parsec + parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where - pretty = prettySep (P :: P sep) . map (pretty . (pack :: a -> b)) . unpack + pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack -- | Haskell string or @[^ ,]+@ newtype Token = Token { getToken :: String } diff --git a/cabal/Cabal/Distribution/Pretty.hs b/cabal/Cabal/Distribution/Pretty.hs --- a/cabal/Cabal/Distribution/Pretty.hs +++ b/cabal/Cabal/Distribution/Pretty.hs @@ -12,7 +12,6 @@ Separator, ) where -import Data.Functor.Identity (Identity (..)) import Distribution.CabalSpecVersion import Distribution.Compat.Prelude import Prelude () diff --git a/cabal/Cabal/Distribution/SPDX/LicenseListVersion.hs b/cabal/Cabal/Distribution/SPDX/LicenseListVersion.hs --- a/cabal/Cabal/Distribution/SPDX/LicenseListVersion.hs +++ b/cabal/Cabal/Distribution/SPDX/LicenseListVersion.hs @@ -13,6 +13,7 @@ deriving (Eq, Ord, Show, Enum, Bounded) cabalSpecVersionToSPDXListVersion :: CabalSpecVersion -> LicenseListVersion +cabalSpecVersionToSPDXListVersion CabalSpecV3_2 = LicenseListVersion_3_6 cabalSpecVersionToSPDXListVersion CabalSpecV3_0 = LicenseListVersion_3_6 cabalSpecVersionToSPDXListVersion CabalSpecV2_4 = LicenseListVersion_3_2 cabalSpecVersionToSPDXListVersion _ = LicenseListVersion_3_0 diff --git a/cabal/Cabal/Distribution/Simple.hs b/cabal/Cabal/Distribution/Simple.hs --- a/cabal/Cabal/Distribution/Simple.hs +++ b/cabal/Cabal/Distribution/Simple.hs @@ -524,9 +524,9 @@ ++ "but the package does not have a library." sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes) - | not (null nonExistant) + | exe1 : _ <- nonExistant = die' verbosity $ "The buildinfo contains info for an executable called '" - ++ prettyShow (head nonExistant) ++ "' but the package does not have a " + ++ prettyShow exe1 ++ "' but the package does not have a " ++ "executable with that name." where pkgExeNames = nub (map exeName (executables pkg_descr)) diff --git a/cabal/Cabal/Distribution/Simple/Build.hs b/cabal/Cabal/Distribution/Simple/Build.hs --- a/cabal/Cabal/Distribution/Simple/Build.hs +++ b/cabal/Cabal/Distribution/Simple/Build.hs @@ -30,6 +30,7 @@ import Prelude () import Distribution.Compat.Prelude +import Distribution.Utils.Generic import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.ComponentRequestedSpec @@ -154,7 +155,9 @@ target <- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of -- This seems DEEPLY questionable. - [] -> return (head (allTargetsInBuildOrder' pkg_descr lbi)) + [] -> case allTargetsInBuildOrder' pkg_descr lbi of + (target:_) -> return target + [] -> die' verbosity $ "Failed to determine target." [target] -> return target _ -> die' verbosity $ "The 'repl' command does not support multiple targets at once." let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] @@ -180,7 +183,7 @@ componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity buildComponent verbosity NoFlag pkg_descr lbi' suffixes comp clbi distPref - | subtarget <- init componentsToBuild ] + | subtarget <- safeInit componentsToBuild ] -- REPL for target components let clbi = targetCLBI target @@ -216,7 +219,13 @@ setupMessage' verbosity "Building" (packageId pkg_descr) (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = addExtraCxxSources (addExtraCSources libbi extras) extras } + lib' = lib { libBuildInfo = flip addExtraAsmSources extras + $ flip addExtraCmmSources extras + $ flip addExtraCxxSources extras + $ flip addExtraCSources extras + $ libbi + } + buildLib verbosity numJobs pkg_descr lbi lib' clbi let oneComponentRequested (OneComponentRequestedSpec _) = True @@ -353,6 +362,24 @@ addExtraCxxSources bi extras = bi { cxxSources = new } where new = Set.toList $ old `Set.union` exs old = Set.fromList $ cxxSources bi + exs = Set.fromList extras + + +-- | Add extra C-- sources generated by preprocessing to build +-- information. +addExtraCmmSources :: BuildInfo -> [FilePath] -> BuildInfo +addExtraCmmSources bi extras = bi { cmmSources = new } + where new = Set.toList $ old `Set.union` exs + old = Set.fromList $ cmmSources bi + exs = Set.fromList extras + + +-- | Add extra ASM sources generated by preprocessing to build +-- information. +addExtraAsmSources :: BuildInfo -> [FilePath] -> BuildInfo +addExtraAsmSources bi extras = bi { asmSources = new } + where new = Set.toList $ old `Set.union` exs + old = Set.fromList $ asmSources bi exs = Set.fromList extras diff --git a/cabal/Cabal/Distribution/Simple/Compiler.hs b/cabal/Cabal/Distribution/Simple/Compiler.hs --- a/cabal/Cabal/Distribution/Simple/Compiler.hs +++ b/cabal/Cabal/Distribution/Simple/Compiler.hs @@ -73,6 +73,7 @@ import Prelude () import Distribution.Compat.Prelude +import Distribution.Utils.Generic(safeLast) import Distribution.Pretty import Distribution.Compiler @@ -197,8 +198,9 @@ -- the top of the stack. -- registrationPackageDB :: PackageDBStack -> PackageDB -registrationPackageDB [] = error "internal error: empty package db set" -registrationPackageDB dbs = last dbs +registrationPackageDB dbs = case safeLast dbs of + Nothing -> error "internal error: empty package db set" + Just p -> p -- | Make package paths absolute diff --git a/cabal/Cabal/Distribution/Simple/Configure.hs b/cabal/Cabal/Distribution/Simple/Configure.hs --- a/cabal/Cabal/Distribution/Simple/Configure.hs +++ b/cabal/Cabal/Distribution/Simple/Configure.hs @@ -55,7 +55,7 @@ , platformDefines, ) where -import Prelude () +import qualified Prelude (tail) import Distribution.Compat.Prelude import Distribution.Compiler @@ -103,6 +103,7 @@ import Distribution.Backpack.PreExistingComponent import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour) import Distribution.Backpack.Id +import Distribution.Utils.Generic import Distribution.Utils.LogProgress import qualified Distribution.Simple.GHC as GHC @@ -113,6 +114,7 @@ import Control.Exception ( ErrorCall, Exception, evaluate, throw, throwIO, try ) import Control.Monad ( forM, forM_ ) +import Data.List.NonEmpty ( nonEmpty ) import Distribution.Compat.Binary ( decodeOrFailIO, encode ) import Distribution.Compat.Directory ( listDirectory ) import Data.ByteString.Lazy ( ByteString ) @@ -1314,19 +1316,22 @@ -- It's an external package, normal situation do_external_external = - case PackageIndex.lookupDependency installedIndex dep_pkgname vr of - [] -> Left (DependencyNotExists dep_pkgname) - pkgs -> Right $ head $ snd $ last pkgs + case pickLastIPI $ PackageIndex.lookupDependency installedIndex dep_pkgname vr of + Nothing -> Left (DependencyNotExists dep_pkgname) + Just pkg -> Right pkg -- It's an internal library, being looked up externally do_external_internal :: LibraryName -> Either FailedDependency InstalledPackageInfo do_external_internal ln = - case PackageIndex.lookupInternalDependency installedIndex + case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex (packageName pkgid) vr ln of - [] -> Left (DependencyMissingInternal dep_pkgname (packageName pkgid)) - pkgs -> Right $ head $ snd $ last pkgs + Nothing -> Left (DependencyMissingInternal dep_pkgname (packageName pkgid)) + Just pkg -> Right pkg + pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo + pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs + reportSelectedDependencies :: Verbosity -> [ResolvedDependency] -> IO () reportSelectedDependencies verbosity deps = @@ -1774,7 +1779,7 @@ findOffendingHdr = ifBuildsWith allHeaders ccArgs (return Nothing) - (go . tail . inits $ allHeaders) + (go . Prelude.tail . inits $ allHeaders) -- inits always contains at least [] where go [] = return Nothing -- cannot happen go (hdrs:hdrsInits) = @@ -1783,9 +1788,10 @@ -- If that works, try compiling too (ifBuildsWith hdrs ccArgs (go hdrsInits) - (return . Just . Right . last $ hdrs)) - (return . Just . Left . last $ hdrs) + (return . fmap Right . safeLast $ hdrs)) + (return . fmap Left . safeLast $ hdrs) + cppArgs = "-E":commonCppArgs -- preprocess only ccArgs = "-c":commonCcArgs -- don't try to link @@ -2005,7 +2011,7 @@ -- database to which the package is installed are relative to the -- prefix of the package depsPrefixRelative = do - pkgr <- GHC.pkgRoot verbosity lbi (last (withPackageDB lbi)) + pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi)) traverse_ (doCheck pkgr) ipkgs where doCheck pkgr ipkg diff --git a/cabal/Cabal/Distribution/Simple/GHC.hs b/cabal/Cabal/Distribution/Simple/GHC.hs --- a/cabal/Cabal/Distribution/Simple/GHC.hs +++ b/cabal/Cabal/Distribution/Simple/GHC.hs @@ -545,8 +545,12 @@ createDirectoryIfMissingVerbose verbosity True libTargetDir -- TODO: do we need to put hs-boot files into place for mutually recursive -- modules? - let cLikeFiles = fromNubListR $ - toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) + let cLikeFiles = fromNubListR $ mconcat + [ toNubListR (cSources libBi) + , toNubListR (cxxSources libBi) + , toNubListR (cmmSources libBi) + , toNubListR (asmSources libBi) + ] cObjs = map (`replaceExtension` objExtension) cLikeFiles baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir vanillaOpts = baseOpts `mappend` mempty { @@ -671,7 +675,6 @@ ifReplLib (runGhcProg replOpts) -- build any C sources - -- TODO: Add support for S and CMM files. unless (not has_code || null (cSources libBi)) $ do info verbosity "Building C Sources..." sequence_ @@ -702,6 +705,68 @@ unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) | filename <- cSources libBi] + -- build any ASM sources + unless (not has_code || null (asmSources libBi)) $ do + info verbosity "Building Assembler Sources..." + sequence_ + [ do let baseAsmOpts = Internal.componentAsmGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename + vanillaAsmOpts = if isGhcDynamic + -- Dynamic GHC requires objects to be built + -- with -fPIC for REPL to work. See #2207. + then baseAsmOpts { ghcOptFPic = toFlag True } + else baseAsmOpts + profAsmOpts = vanillaAsmOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedAsmOpts = vanillaAsmOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaAsmOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded asmOpts = do + needsRecomp <- checkNeedsRecompilation filename asmOpts + when needsRecomp $ runGhcProg asmOpts + runGhcProgIfNeeded vanillaAsmOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedAsmOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profAsmOpts) + | filename <- asmSources libBi] + + -- build any Cmm sources + unless (not has_code || null (cmmSources libBi)) $ do + info verbosity "Building C-- Sources..." + sequence_ + [ do let baseCmmOpts = Internal.componentCmmGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename + vanillaCmmOpts = if isGhcDynamic + -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + then baseCmmOpts { ghcOptFPic = toFlag True } + else baseCmmOpts + profCmmOpts = vanillaCmmOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCmmOpts = vanillaCmmOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCmmOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded cmmOpts = do + needsRecomp <- checkNeedsRecompilation filename cmmOpts + when needsRecomp $ runGhcProg cmmOpts + runGhcProgIfNeeded vanillaCmmOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCmmOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCmmOpts) + | filename <- cmmSources libBi] + -- TODO: problem here is we need the .c files built first, so we can load them -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. @@ -1051,7 +1116,7 @@ -- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. exeMainModuleName :: Executable -> Maybe ModuleName exeMainModuleName Executable{buildInfo = bnfo} = - -- GHC honors the last occurence of a module name updated via -main-is + -- GHC honors the last occurrence of a module name updated via -main-is -- -- Moreover, -main-is when parsed left-to-right can update either -- the "Main" module name, or the "main" function name, or both, @@ -1074,24 +1139,26 @@ -- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. decodeMainIsArg :: String -> Maybe ModuleName decodeMainIsArg arg - | not (null main_fn) && isLower (head main_fn) + | headOf main_fn isLower -- The arg looked like "Foo.Bar.baz" = Just (ModuleName.fromString main_mod) - | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" + | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" = Just (ModuleName.fromString arg) | otherwise -- The arg looked like "baz" = Nothing where + headOf :: String -> (Char -> Bool) -> Bool + headOf str pred' = any pred' (safeHead str) + (main_mod, main_fn) = splitLongestPrefix arg (== '.') splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) splitLongestPrefix str pred' | null r_pre = (str, []) - | otherwise = (reverse (tail r_pre), reverse r_suf) - -- 'tail' drops the char satisfying 'pred' + | otherwise = (reverse (safeTail r_pre), reverse r_suf) + -- 'safeTail' drops the char satisfying 'pred' where (r_suf, r_pre) = break pred' (reverse str) - -- | A collection of: -- * C input files -- * C++ input files @@ -1463,7 +1530,7 @@ } ForeignLibNativeStatic -> -- this should be caught by buildFLib - -- (and if we do implement tihs, we probably don't even want to call + -- (and if we do implement this, we probably don't even want to call -- ghc here, but rather Ar.createArLibArchive or something) cabalBug "static libraries not yet implemented" ForeignLibTypeUnknown -> @@ -1940,6 +2007,8 @@ hasLib = not $ null (allLibModules lib clbi) && null (cSources (libBuildInfo lib)) && null (cxxSources (libBuildInfo lib)) + && null (cmmSources (libBuildInfo lib)) + && null (asmSources (libBuildInfo lib)) has_code = not (componentIsIndefinite clbi) whenHasCode = when has_code whenVanilla = when (hasLib && withVanillaLib lbi) diff --git a/cabal/Cabal/Distribution/Simple/GHC/Internal.hs b/cabal/Cabal/Distribution/Simple/GHC/Internal.hs --- a/cabal/Cabal/Distribution/Simple/GHC/Internal.hs +++ b/cabal/Cabal/Distribution/Simple/GHC/Internal.hs @@ -19,7 +19,9 @@ targetPlatform, getGhcInfo, componentCcGhcOptions, + componentCmmGhcOptions, componentCxxGhcOptions, + componentAsmGhcOptions, componentGhcOptions, mkGHCiLibName, mkGHCiProfLibName, @@ -335,6 +337,42 @@ } +componentAsmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath + -> GhcOptions +componentAsmGhcOptions verbosity _implInfo lbi bi clbi odir filename = + mempty { + -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal), + ghcOptMode = toFlag GhcModeCompile, + ghcOptInputFiles = toNubListR [filename], + + ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi + ,autogenPackageModulesDir lbi + ,odir] + -- includes relative to the package + ++ PD.includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- PD.includeDirs bi], + ghcOptHideAllPackages= toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptAsmOptions = (case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"]) ++ + (case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"]) ++ + PD.asmOptions bi, + ghcOptObjDir = toFlag odir + } + + componentGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> GhcOptions @@ -396,14 +434,49 @@ ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi) } where - toGhcOptimisation NoOptimisation = mempty --TODO perhaps override? - toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation - toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation - exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt) | uid <- componentExeDeps clbi -- TODO: Ugh, localPkgDescr , Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] ] + +toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation +toGhcOptimisation NoOptimisation = mempty --TODO perhaps override? +toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation +toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation + + +componentCmmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath + -> GhcOptions +componentCmmGhcOptions verbosity _implInfo lbi bi clbi odir filename = + mempty { + -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal), + ghcOptMode = toFlag GhcModeCompile, + ghcOptInputFiles = toNubListR [filename], + + ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi + ,autogenPackageModulesDir lbi + ,odir] + -- includes relative to the package + ++ PD.includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- PD.includeDirs bi], + ghcOptCppOptions = cppOptions bi, + ghcOptCppIncludes = toNubListR $ + [autogenComponentModulesDir lbi clbi cppHeaderName], + ghcOptHideAllPackages= toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), + ghcOptDebugInfo = toFlag (withDebugInfo lbi), + ghcOptExtra = cmmOptions bi, + ghcOptObjDir = toFlag odir + } + -- | Strip out flags that are not supported in ghci filterGhciFlags :: [String] -> [String] diff --git a/cabal/Cabal/Distribution/Simple/GHCJS.hs b/cabal/Cabal/Distribution/Simple/GHCJS.hs --- a/cabal/Cabal/Distribution/Simple/GHCJS.hs +++ b/cabal/Cabal/Distribution/Simple/GHCJS.hs @@ -903,7 +903,7 @@ -- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. exeMainModuleName :: Executable -> Maybe ModuleName exeMainModuleName Executable{buildInfo = bnfo} = - -- GHC honors the last occurence of a module name updated via -main-is + -- GHC honors the last occurrence of a module name updated via -main-is -- -- Moreover, -main-is when parsed left-to-right can update either -- the "Main" module name, or the "main" function name, or both, @@ -926,21 +926,24 @@ -- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. decodeMainIsArg :: String -> Maybe ModuleName decodeMainIsArg arg - | not (null main_fn) && isLower (head main_fn) + | headOf main_fn isLower -- The arg looked like "Foo.Bar.baz" = Just (ModuleName.fromString main_mod) - | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" + | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" = Just (ModuleName.fromString arg) | otherwise -- The arg looked like "baz" = Nothing where + headOf :: String -> (Char -> Bool) -> Bool + headOf str pred' = any pred' (safeHead str) + (main_mod, main_fn) = splitLongestPrefix arg (== '.') splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) splitLongestPrefix str pred' | null r_pre = (str, []) - | otherwise = (reverse (tail r_pre), reverse r_suf) - -- 'tail' drops the char satisfying 'pred' + | otherwise = (reverse (safeTail r_pre), reverse r_suf) + -- 'safeTail' drops the char satisfying 'pred' where (r_suf, r_pre) = break pred' (reverse str) @@ -1308,7 +1311,7 @@ } ForeignLibNativeStatic -> -- this should be caught by buildFLib - -- (and if we do implement tihs, we probably don't even want to call + -- (and if we do implement this, we probably don't even want to call -- ghc here, but rather Ar.createArLibArchive or something) cabalBug "static libraries not yet implemented" ForeignLibTypeUnknown -> diff --git a/cabal/Cabal/Distribution/Simple/Glob.hs b/cabal/Cabal/Distribution/Simple/Glob.hs --- a/cabal/Cabal/Distribution/Simple/Glob.hs +++ b/cabal/Cabal/Distribution/Simple/Glob.hs @@ -37,6 +37,8 @@ import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (), (<.>)) +import qualified Data.List.NonEmpty as NE + -- Note throughout that we use splitDirectories, not splitPath. On -- Posix, this makes no difference, but, because Windows accepts both -- slash and backslash as its path separators, if we left in the @@ -151,7 +153,7 @@ fileGlobMatchesSegments pat' segs GlobFinal final -> case final of FinalMatch Recursive multidot ext -> do - let (candidateBase, candidateExts) = splitExtensions (last $ seg:segs) + let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg:|segs) guard (not (null candidateBase)) checkExt multidot ext candidateExts FinalMatch NonRecursive multidot ext -> do diff --git a/cabal/Cabal/Distribution/Simple/HaskellSuite.hs b/cabal/Cabal/Distribution/Simple/HaskellSuite.hs --- a/cabal/Cabal/Distribution/Simple/HaskellSuite.hs +++ b/cabal/Cabal/Distribution/Simple/HaskellSuite.hs @@ -26,6 +26,7 @@ import Distribution.Simple.LocalBuildInfo import Distribution.System (Platform) import Distribution.Compat.Exception +import Distribution.Utils.Generic import Language.Haskell.Extension import Distribution.Simple.Program.Builtin @@ -92,15 +93,15 @@ hstoolVersion = findProgramVersion "--hspkg-version" id numericVersion :: Verbosity -> FilePath -> IO (Maybe Version) -numericVersion = findProgramVersion "--compiler-version" (last . words) +numericVersion = findProgramVersion "--compiler-version" (fromMaybe "" . safeLast . words) getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version) getCompilerVersion verbosity prog = do output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"] let parts = words output - name = concat $ init parts -- there shouldn't be any spaces in the name anyway - versionStr = last parts + name = concat $ safeInit parts -- there shouldn't be any spaces in the name anyway + versionStr = fromMaybe "" $ safeLast parts version <- maybe (die' verbosity "haskell-suite: couldn't determine compiler version") return $ simpleParsec versionStr @@ -217,7 +218,7 @@ runProgramInvocation verbosity $ (programInvocation hspkg - ["update", packageDbOpt $ last packageDbs]) + ["update", packageDbOpt $ registrationPackageDB packageDbs]) { progInvokeInput = Just $ showInstalledPackageInfo installedPkgInfo } initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO () diff --git a/cabal/Cabal/Distribution/Simple/PackageIndex.hs b/cabal/Cabal/Distribution/Simple/PackageIndex.hs --- a/cabal/Cabal/Distribution/Simple/PackageIndex.hs +++ b/cabal/Cabal/Distribution/Simple/PackageIndex.hs @@ -112,6 +112,7 @@ import qualified Data.Array as Array import qualified Data.Graph as Graph import Data.List as List ( groupBy, deleteBy, deleteFirstsBy ) +import qualified Data.List.NonEmpty as NE import qualified Data.Tree as Tree import Control.Monad import Distribution.Compat.Stack @@ -210,20 +211,20 @@ -- ones. -- fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex -fromList pkgs = mkPackageIndex pids pnames +fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames) where pids = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ] pnames = Map.fromList - [ (liftM2 (,) packageName IPI.sourceLibName (head pkgsN), pvers) - | pkgsN <- groupBy (equating (liftM2 (,) packageName IPI.sourceLibName)) + [ (liftM2 (,) packageName IPI.sourceLibName (NE.head pkgsN), pvers) + | pkgsN <- NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName)) . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion)) $ pkgs , let pvers = Map.fromList - [ (packageVersion (head pkgsNV), - nubBy (equating installedUnitId) (reverse pkgsNV)) - | pkgsNV <- groupBy (equating packageVersion) pkgsN + [ (packageVersion (NE.head pkgsNV), + NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV)) + | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN ] ] diff --git a/cabal/Cabal/Distribution/Simple/PreProcess.hs b/cabal/Cabal/Distribution/Simple/PreProcess.hs --- a/cabal/Cabal/Distribution/Simple/PreProcess.hs +++ b/cabal/Cabal/Distribution/Simple/PreProcess.hs @@ -269,7 +269,7 @@ let (srcStem, ext) = splitExtension psrcRelFile psrcFile = psrcLoc psrcRelFile pp = fromMaybe (error "Distribution.Simple.PreProcess: Just expected") - (lookup (tailNotNull ext) handlers) + (lookup (safeTail ext) handlers) -- Preprocessing files for 'sdist' is different from preprocessing -- for 'build'. When preprocessing for sdist we preprocess to -- avoid that the user has to have the preprocessors available. @@ -296,8 +296,6 @@ where dirName = takeDirectory - tailNotNull [] = [] - tailNotNull x = tail x -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files -- be in the same place as the hs files, so if we put the hs file in dist/ @@ -727,8 +725,9 @@ pp $ buildDir lbi nm' nm' ++ "-tmp" TestSuiteLibV09 _ _ -> pp $ buildDir lbi stubName test stubName test ++ "-tmp" - TestSuiteUnsupported tt -> die' verbosity $ "No support for preprocessing test " - ++ "suite type " ++ prettyShow tt + TestSuiteUnsupported tt -> + die' verbosity $ "No support for preprocessing test suite type " ++ + prettyShow tt CBench bm -> do let nm' = unUnqualComponentName $ benchmarkName bm case benchmarkInterface bm of diff --git a/cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs b/cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs --- a/cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs +++ b/cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs @@ -17,6 +17,7 @@ import Prelude () import Distribution.Compat.Prelude +import Distribution.Utils.Generic (safeTail, safeLast, safeInit) import Data.List (mapAccumL) @@ -33,12 +34,10 @@ classify :: String -> Classified classify ('>':s) = BirdTrack s classify ('#':s) = case tokens s of - (line:file:_) | all isDigit line - && length file >= 2 - && head file == '"' - && last file == '"' + (line:file@('"':_:_):_) | all isDigit line + && safeLast file == Just '"' -- this shouldn't fail as we tested for 'all isDigit' - -> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (tail (init file)) -- TODO:eradicateNoParse + -> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse _ -> CPP s where tokens = unfoldr $ \str -> case lex str of (t@(_:_), str'):_ -> Just (t, str') diff --git a/cabal/Cabal/Distribution/Simple/Program.hs b/cabal/Cabal/Distribution/Simple/Program.hs --- a/cabal/Cabal/Distribution/Simple/Program.hs +++ b/cabal/Cabal/Distribution/Simple/Program.hs @@ -90,6 +90,7 @@ , reconfigurePrograms , requireProgram , requireProgramVersion + , needProgram , runDbProgram , getDbProgramOutput diff --git a/cabal/Cabal/Distribution/Simple/Program/Db.hs b/cabal/Cabal/Distribution/Simple/Program/Db.hs --- a/cabal/Cabal/Distribution/Simple/Program/Db.hs +++ b/cabal/Cabal/Distribution/Simple/Program/Db.hs @@ -57,6 +57,7 @@ reconfigurePrograms, requireProgram, requireProgramVersion, + needProgram, ) where @@ -413,19 +414,31 @@ requireProgram :: Verbosity -> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb) requireProgram verbosity prog progdb = do + mres <- needProgram verbosity prog progdb + case mres of + Nothing -> die' verbosity notFound + Just res -> return res + where + notFound = "The program '" ++ programName prog ++ "' is required but it could not be found." +-- | Check that a program is configured and available to be run. +-- +-- It returns 'Nothing' if the program couldn't be configured, +-- or is not found. +-- +-- @since 3.2.0.0 +needProgram :: Verbosity -> Program -> ProgramDb + -> IO (Maybe (ConfiguredProgram, ProgramDb)) +needProgram verbosity prog progdb = do + -- If it's not already been configured, try to configure it now progdb' <- case lookupProgram prog progdb of Nothing -> configureProgram verbosity prog progdb Just _ -> return progdb case lookupProgram prog progdb' of - Nothing -> die' verbosity notFound - Just configuredProg -> return (configuredProg, progdb') - - where notFound = "The program '" ++ programName prog - ++ "' is required but it could not be found." - + Nothing -> return Nothing + Just configuredProg -> return (Just (configuredProg, progdb')) -- | Check that a program is configured and available to be run. -- diff --git a/cabal/Cabal/Distribution/Simple/Program/GHC.hs b/cabal/Cabal/Distribution/Simple/Program/GHC.hs --- a/cabal/Cabal/Distribution/Simple/Program/GHC.hs +++ b/cabal/Cabal/Distribution/Simple/Program/GHC.hs @@ -45,7 +45,6 @@ import Data.List (stripPrefix) import qualified Data.Map as Map import Data.Monoid (All(..), Any(..), Endo(..)) -import Data.Set (Set) import qualified Data.Set as Set normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String] @@ -56,7 +55,7 @@ supportedGHCVersions :: VersionRange supportedGHCVersions = intersectVersionRanges (orLaterVersion (mkVersion [8,0])) - (earlierVersion (mkVersion [8,7])) + (earlierVersion (mkVersion [8,9])) from :: Monoid m => [Int] -> m -> m from version flags @@ -219,6 +218,7 @@ , from [8,4] [ "-ddebug-output" ] , from [8,4] $ to [8,6] [ "-fno-max-valid-substitutions" ] , from [8,6] [ "-dhex-word-literals" ] + , from [8,8] [ "-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits" ] ] isOptIntFlag :: String -> Any @@ -413,6 +413,9 @@ -- | Options to pass through to the C++ compiler. ghcOptCxxOptions :: [String], + -- | Options to pass through to the Assembler. + ghcOptAsmOptions :: [String], + -- | Options to pass through to CPP; the @ghc -optP@ flag. ghcOptCppOptions :: [String], @@ -665,6 +668,7 @@ | inc <- flags ghcOptCppIncludes ] , [ "-optc" ++ opt | opt <- ghcOptCcOptions opts] , [ "-optc" ++ opt | opt <- ghcOptCxxOptions opts] + , [ "-opta" ++ opt | opt <- ghcOptAsmOptions opts] ----------------- -- Linker stuff @@ -746,8 +750,10 @@ --------------- -- Inputs - , [ prettyShow modu | modu <- flags ghcOptInputModules ] + -- Specify the input file(s) first, so that in ghci the `main-is` module is + -- in scope instead of the first module defined in `other-modules`. , flags ghcOptInputFiles + , [ prettyShow modu | modu <- flags ghcOptInputModules ] , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ] , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ] diff --git a/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs b/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs --- a/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs +++ b/cabal/Cabal/Distribution/Simple/Program/HcPkg.hs @@ -162,7 +162,7 @@ -- | registerMultiInstance registerOptions , recacheMultiInstance hpi - = do let pkgdb = last packagedbs + = do let pkgdb = registrationPackageDB packagedbs writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo recache hpi verbosity pkgdb @@ -386,9 +386,7 @@ | otherwise = "register" args file = [cmdname, file] - ++ (if noPkgDbStack hpi - then [packageDbOpts hpi (last packagedbs)] - else packageDbStackOpts hpi packagedbs) + ++ packageDbStackOpts hpi packagedbs ++ [ "--enable-multi-instance" | registerMultiInstance registerOptions ] ++ [ "--force-files" @@ -423,9 +421,7 @@ describeInvocation hpi verbosity packagedbs pkgid = programInvocation (hcPkgProgram hpi) $ ["describe", prettyShow pkgid] - ++ (if noPkgDbStack hpi - then [packageDbOpts hpi (last packagedbs)] - else packageDbStackOpts hpi packagedbs) + ++ packageDbStackOpts hpi packagedbs ++ verbosityOpts hpi verbosity hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId @@ -460,19 +456,21 @@ packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String] -packageDbStackOpts hpi dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> "--global" - : "--user" - : map specific dbs - (GlobalPackageDB:dbs) -> "--global" - : ("--no-user-" ++ packageDbFlag hpi) - : map specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db - specific _ = ierror - ierror :: a - ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) +packageDbStackOpts hpi dbstack + | noPkgDbStack hpi = [packageDbOpts hpi (registrationPackageDB dbstack)] + | otherwise = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> "--global" + : "--user" + : map specific dbs + (GlobalPackageDB:dbs) -> "--global" + : ("--no-user-" ++ packageDbFlag hpi) + : map specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db + specific _ = ierror + ierror :: a + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) packageDbFlag :: HcPkgInfo -> String packageDbFlag hpi diff --git a/cabal/Cabal/Distribution/Simple/Program/Internal.hs b/cabal/Cabal/Distribution/Simple/Program/Internal.hs --- a/cabal/Cabal/Distribution/Simple/Program/Internal.hs +++ b/cabal/Cabal/Distribution/Simple/Program/Internal.hs @@ -13,6 +13,7 @@ import Prelude () import Distribution.Compat.Prelude +import Distribution.Utils.Generic(safeTail) -- | Extract the version number from the output of 'strip --version'. -- @@ -29,7 +30,7 @@ filterPar' :: Int -> [String] -> [String] filterPar' _ [] = [] filterPar' n (x:xs) - | n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((tail x):xs) + | n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((safeTail x):xs) | n > 0 && ")" `isSuffixOf` x = filterPar' (n-1) xs | n > 0 = filterPar' n xs | otherwise = x:filterPar' n xs diff --git a/cabal/Cabal/Distribution/Simple/Program/Run.hs b/cabal/Cabal/Distribution/Simple/Program/Run.hs --- a/cabal/Cabal/Distribution/Simple/Program/Run.hs +++ b/cabal/Cabal/Distribution/Simple/Program/Run.hs @@ -34,6 +34,7 @@ import Distribution.Simple.Utils import Distribution.Verbosity import Distribution.Compat.Environment +import Distribution.Utils.Generic import qualified Data.Map as Map import System.FilePath @@ -243,13 +244,14 @@ chunkSize = maxCommandLineSize - fixedArgSize in case splitChunks chunkSize args of - [] -> [ simple ] + [] -> [ simple ] - [c] -> [ simple `appendArgs` c ] + [c] -> [ simple `appendArgs` c ] - (c:cs) -> [ initial `appendArgs` c ] - ++ [ middle `appendArgs` c'| c' <- init cs ] - ++ [ final `appendArgs` c'| let c' = last cs ] + (c:c2:cs) | (xs, x) <- unsnocNE (c2:|cs) -> + [ initial `appendArgs` c ] + ++ [ middle `appendArgs` c'| c' <- xs ] + ++ [ final `appendArgs` x ] where appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation diff --git a/cabal/Cabal/Distribution/Simple/Setup.hs b/cabal/Cabal/Distribution/Simple/Setup.hs --- a/cabal/Cabal/Distribution/Simple/Setup.hs +++ b/cabal/Cabal/Distribution/Simple/Setup.hs @@ -58,7 +58,8 @@ defaultBenchmarkFlags, benchmarkCommand, CopyDest(..), configureArgs, configureOptions, configureCCompiler, configureLinker, - buildOptions, haddockOptions, installDirsOptions, testOptions', + buildOptions, haddockOptions, installDirsOptions, + testOptions', benchmarkOptions', programDbOptions, programDbPaths', programFlagsDescription, replOptions, @@ -2027,29 +2028,32 @@ , "BENCHCOMPONENTS [FLAGS]" ] , commandDefaultFlags = defaultBenchmarkFlags - , commandOptions = \showOrParseArgs -> - [ optionVerbosity benchmarkVerbosity - (\v flags -> flags { benchmarkVerbosity = v }) - , optionDistPref - benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d }) - showOrParseArgs - , option [] ["benchmark-options"] - ("give extra options to benchmark executables " - ++ "(name templates can use $pkgid, $compiler, " - ++ "$os, $arch, $benchmark)") - benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) - (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) - (const [])) - , option [] ["benchmark-option"] - ("give extra option to benchmark executables " - ++ "(no need to quote options containing spaces, " - ++ "name template can use $pkgid, $compiler, " - ++ "$os, $arch, $benchmark)") - benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) - (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) - (map fromPathTemplate)) - ] + , commandOptions = benchmarkOptions' } + +benchmarkOptions' :: ShowOrParseArgs -> [OptionField BenchmarkFlags] +benchmarkOptions' showOrParseArgs = + [ optionVerbosity benchmarkVerbosity + (\v flags -> flags { benchmarkVerbosity = v }) + , optionDistPref + benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d }) + showOrParseArgs + , option [] ["benchmark-options"] + ("give extra options to benchmark executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)") + benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) + (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) + (const [])) + , option [] ["benchmark-option"] + ("give extra option to benchmark executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)") + benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) + (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) + (map fromPathTemplate)) + ] emptyBenchmarkFlags :: BenchmarkFlags emptyBenchmarkFlags = mempty diff --git a/cabal/Cabal/Distribution/Simple/SrcDist.hs b/cabal/Cabal/Distribution/Simple/SrcDist.hs --- a/cabal/Cabal/Distribution/Simple/SrcDist.hs +++ b/cabal/Cabal/Distribution/Simple/SrcDist.hs @@ -459,7 +459,8 @@ in findFileWithExtension fileExts (hsSourceDirs bi) file | module_ <- modules ++ otherModules bi ] - return $ sources ++ catMaybes bootFiles ++ cSources bi ++ cxxSources bi ++ jsSources bi + return $ sources ++ catMaybes bootFiles ++ cSources bi ++ cxxSources bi ++ + cmmSources bi ++ asmSources bi ++ jsSources bi where nonEmpty x _ [] = x diff --git a/cabal/Cabal/Distribution/Simple/UHC.hs b/cabal/Cabal/Distribution/Simple/UHC.hs --- a/cabal/Cabal/Distribution/Simple/UHC.hs +++ b/cabal/Cabal/Distribution/Simple/UHC.hs @@ -24,7 +24,6 @@ import Prelude () import Distribution.Compat.Prelude -import Data.Foldable (toList) import Distribution.InstalledPackageInfo import Distribution.Package hiding (installedUnitId) @@ -278,7 +277,7 @@ -> InstalledPackageInfo -> IO () registerPackage verbosity comp progdb packageDbs installedPkgInfo = do - dbdir <- case last packageDbs of + dbdir <- case registrationPackageDB packageDbs of GlobalPackageDB -> getGlobalPackageDir verbosity progdb UserPackageDB -> getUserPackageDir SpecificPackageDB dir -> return dir diff --git a/cabal/Cabal/Distribution/Simple/Utils.hs b/cabal/Cabal/Distribution/Simple/Utils.hs --- a/cabal/Cabal/Distribution/Simple/Utils.hs +++ b/cabal/Cabal/Distribution/Simple/Utils.hs @@ -151,6 +151,7 @@ ordNub, ordNubBy, ordNubRight, + safeHead, safeTail, unintersperse, wrapText, @@ -168,6 +169,7 @@ import Prelude () import Distribution.Compat.Prelude +import Control.Exception (SomeException) import Distribution.Utils.Generic import Distribution.Utils.IOData (IOData(..), IODataMode(..)) @@ -175,9 +177,11 @@ import Distribution.ModuleName as ModuleName import Distribution.System import Distribution.Version +import Distribution.Compat.Async import Distribution.Compat.CopyFile import Distribution.Compat.Internal.TempFile import Distribution.Compat.Exception +import Distribution.Compat.FilePath as FilePath import Distribution.Compat.Stack import Distribution.Verbosity import Distribution.Types.PackageId @@ -199,8 +203,6 @@ import Distribution.Pretty import Distribution.Parsec -import Control.Concurrent.MVar - ( newEmptyMVar, putMVar, takeMVar ) import Data.Typeable ( cast ) import qualified Data.ByteString.Lazy as BS @@ -213,7 +215,7 @@ ( getProgName ) import System.Exit ( exitWith, ExitCode(..) ) -import System.FilePath +import System.FilePath as FilePath ( normalise, (), (<.>) , getSearchPath, joinPath, takeDirectory, splitExtension , splitDirectories, searchPathSeparator ) @@ -226,8 +228,7 @@ import qualified Control.Exception as Exception import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) -import Control.Exception (IOException, evaluate, throwIO) -import Control.Concurrent (forkIO) +import Control.Exception (IOException, evaluate, throwIO, fromException) import Numeric (showFFloat) import qualified System.Process as Process ( CreateProcess(..), StdStream(..), proc) @@ -828,53 +829,48 @@ -- fork off a couple threads to pull on the stderr and stdout -- so if the process writes to stderr we do not block. - err <- hGetContents errh - - out <- IOData.hGetContents outh outputMode + withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetContents outh outputMode) $ \outA -> do + -- push all the input, if any + case input of + Nothing -> return () + Just inputData -> do + -- input mode depends on what the caller wants + -- todo: ignoreSigPipe + IOData.hPutContents inh inputData + --TODO: this probably fails if the process refuses to consume + -- or if it closes stdin (eg if it exits) - mv <- newEmptyMVar - let force str = do - mberr <- Exception.try (evaluate (rnf str) >> return ()) - putMVar mv (mberr :: Either IOError ()) - _ <- forkIO $ force out - _ <- forkIO $ force err + -- wait for both to finish + mberr1 <- waitCatch outA + mberr2 <- waitCatch errA - -- push all the input, if any - case input of - Nothing -> return () - Just inputData -> do - -- input mode depends on what the caller wants - IOData.hPutContents inh inputData - --TODO: this probably fails if the process refuses to consume - -- or if it closes stdin (eg if it exits) + -- wait for the program to terminate + exitcode <- waitForProcess pid - -- wait for both to finish, in either order - mberr1 <- takeMVar mv - mberr2 <- takeMVar mv + -- get the stderr, so it can be added to error message + err <- reportOutputIOError mberr2 - -- wait for the program to terminate - exitcode <- waitForProcess pid - unless (exitcode == ExitSuccess) $ - debug verbosity $ path ++ " returned " ++ show exitcode - ++ if null err then "" else - " with error message:\n" ++ err - ++ case input of - Nothing -> "" - Just d | IOData.null d -> "" - Just (IODataText inp) -> "\nstdin input:\n" ++ inp - Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp + unless (exitcode == ExitSuccess) $ + debug verbosity $ path ++ " returned " ++ show exitcode + ++ if null err then "" else + " with error message:\n" ++ err + ++ case input of + Nothing -> "" + Just d | IOData.null d -> "" + Just (IODataText inp) -> "\nstdin input:\n" ++ inp + Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp - -- Check if we we hit an exception while consuming the output - -- (e.g. a text decoding error) - reportOutputIOError mberr1 - reportOutputIOError mberr2 + -- Check if we we hit an exception while consuming the output + -- (e.g. a text decoding error) + out <- reportOutputIOError mberr1 - return (out, err, exitcode) + return (out, err, exitcode) where - reportOutputIOError :: Either IOError () -> NoCallStackIO () - reportOutputIOError = - either (\e -> throwIO (ioeSetFileName e ("output of " ++ path))) - return + reportOutputIOError :: Either SomeException a -> NoCallStackIO a + reportOutputIOError (Right x) = return x + reportOutputIOError (Left exc) = case fromException exc of + Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path)) + Nothing -> throwIO exc -- | Look for a program and try to find it's version number. It can accept -- either an absolute path or the name of a program binary, in which case we @@ -1412,11 +1408,25 @@ -- unchanged. dropExeExtension :: FilePath -> FilePath dropExeExtension filepath = - case splitExtension filepath of - (filepath', extension) | extension `elem` exeExtensions -> filepath' - | otherwise -> filepath + -- System.FilePath's extension handling functions are horribly + -- inconsistent, consider: + -- + -- isExtensionOf "" "foo" == False but + -- isExtensionOf "" "foo." == True. + -- + -- On the other hand stripExtension doesn't remove the empty extension: + -- + -- stripExtension "" "foo." == Just "foo." + -- + -- Since by "" in exeExtensions we mean 'no extension' anyways we can + -- just always ignore it here. + let exts = [ ext | ext <- exeExtensions, ext /= "" ] in + fromMaybe filepath $ do + ext <- find (`FilePath.isExtensionOf` filepath) exts + ext `FilePath.stripExtension` filepath --- | List of possible executable file extensions on the current platform. +-- | List of possible executable file extensions on the current build +-- platform. exeExtensions :: [String] exeExtensions = case buildOS of -- Possible improvement: on Windows, read the list of extensions from the diff --git a/cabal/Cabal/Distribution/Types/BuildInfo.hs b/cabal/Cabal/Distribution/Types/BuildInfo.hs --- a/cabal/Cabal/Distribution/Types/BuildInfo.hs +++ b/cabal/Cabal/Distribution/Types/BuildInfo.hs @@ -84,7 +84,7 @@ -- and copied and registered together with this library. The -- logic on how this library is built will have to be encoded in a -- custom Setup for now. Oherwise cabal would need to lear how to - -- call arbitary library builders. + -- call arbitrary library builders. extraLibFlavours :: [String], -- ^ Hidden Flag. This set of strings, will be appended to all libraries when -- copying. E.g. [libHS_ | flavour <- extraLibFlavours]. This -- should only be needed in very specific cases, e.g. the `rts` package, where diff --git a/cabal/Cabal/Distribution/Types/ConfVar.hs b/cabal/Cabal/Distribution/Types/ConfVar.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/ConfVar.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.ConfVar ( + ConfVar(..), + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.Flag +import Distribution.Types.VersionRange +import Distribution.Compiler +import Distribution.System + +-- | A @ConfVar@ represents the variable type used. +data ConfVar = OS OS + | Arch Arch + | Flag FlagName + | Impl CompilerFlavor VersionRange + deriving (Eq, Show, Typeable, Data, Generic) + +instance Binary ConfVar + +instance NFData ConfVar where rnf = genericRnf diff --git a/cabal/Cabal/Distribution/Types/Dependency.hs b/cabal/Cabal/Distribution/Types/Dependency.hs --- a/cabal/Cabal/Distribution/Types/Dependency.hs +++ b/cabal/Cabal/Distribution/Types/Dependency.hs @@ -29,7 +29,6 @@ import Distribution.Types.UnqualComponentName import Text.PrettyPrint ((<+>)) -import Data.Set (Set) import qualified Data.Set as Set -- | Describes a dependency on a source package (API) @@ -89,6 +88,9 @@ $ (char ':' *> spaces *>) $ versionGuardMultilibs $ pure <$> parseLib name <|> parseMultipleLibs name + + spaces -- https://github.com/haskell/cabal/issues/5846 + ver <- parsec <|> pure anyVersion return $ Dependency name ver $ Set.fromList libs where makeLib pn ln | unPackageName pn == ln = LMainLibName diff --git a/cabal/Cabal/Distribution/Types/DependencyMap.hs b/cabal/Cabal/Distribution/Types/DependencyMap.hs --- a/cabal/Cabal/Distribution/Types/DependencyMap.hs +++ b/cabal/Cabal/Distribution/Types/DependencyMap.hs @@ -13,7 +13,6 @@ import Distribution.Types.LibraryName import Distribution.Version -import Data.Set (Set) import qualified Data.Map.Lazy as Map -- | A map of dependencies. Newtyped since the default monoid instance is not diff --git a/cabal/Cabal/Distribution/Types/ExeDependency.hs b/cabal/Cabal/Distribution/Types/ExeDependency.hs --- a/cabal/Cabal/Distribution/Types/ExeDependency.hs +++ b/cabal/Cabal/Distribution/Types/ExeDependency.hs @@ -33,9 +33,31 @@ pretty (ExeDependency name exe ver) = (pretty name <<>> text ":" <<>> pretty exe) <+> pretty ver +-- | +-- +-- Examples +-- +-- >>> simpleParsec "happy:happy" :: Maybe ExeDependency +-- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") AnyVersion) +-- +-- >>> simpleParsec "happy:happy >= 1.19.12" :: Maybe ExeDependency +-- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [1,19,12]))) +-- +-- >>> simpleParsec "happy:happy>=1.19.12" :: Maybe ExeDependency +-- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [1,19,12]))) +-- +-- >>> simpleParsec "happy : happy >= 1.19.12" :: Maybe ExeDependency +-- Nothing +-- +-- >>> simpleParsec "happy: happy >= 1.19.12" :: Maybe ExeDependency +-- Nothing +-- +-- >>> simpleParsec "happy :happy >= 1.19.12" :: Maybe ExeDependency +-- Nothing +-- instance Parsec ExeDependency where parsec = do - name <- lexemeParsec + name <- parsec _ <- P.char ':' exe <- lexemeParsec ver <- parsec <|> pure anyVersion diff --git a/cabal/Cabal/Distribution/Types/Flag.hs b/cabal/Cabal/Distribution/Types/Flag.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/Flag.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Distribution.Types.Flag ( + Flag(..), + emptyFlag, + FlagName, + mkFlagName, + unFlagName, + FlagAssignment, + mkFlagAssignment, + unFlagAssignment, + lookupFlagAssignment, + insertFlagAssignment, + diffFlagAssignment, + findDuplicateFlagAssignments, + nullFlagAssignment, + showFlagValue, + dispFlagAssignment, + parsecFlagAssignment, + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText +import Distribution.Utils.Generic (lowercase) + +import Distribution.Parsec +import Distribution.Pretty + +import qualified Data.Map as Map +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.CharParsing as P + +-- ----------------------------------------------------------------------------- +-- The Flag' type + +-- | A flag can represent a feature to be included, or a way of linking +-- a target against its dependencies, or in fact whatever you can think of. +data Flag = MkFlag + { flagName :: FlagName + , flagDescription :: String + , flagDefault :: Bool + , flagManual :: Bool + } + deriving (Show, Eq, Typeable, Data, Generic) + +instance Binary Flag + +instance NFData Flag where rnf = genericRnf + +-- | A 'Flag' initialized with default parameters. +emptyFlag :: FlagName -> Flag +emptyFlag name = MkFlag + { flagName = name + , flagDescription = "" + , flagDefault = True + , flagManual = False + } + +-- | A 'FlagName' is the name of a user-defined configuration flag +-- +-- Use 'mkFlagName' and 'unFlagName' to convert from/to a 'String'. +-- +-- This type is opaque since @Cabal-2.0@ +-- +-- @since 2.0.0.2 +newtype FlagName = FlagName ShortText + deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData) + +-- | Construct a 'FlagName' from a 'String' +-- +-- 'mkFlagName' is the inverse to 'unFlagName' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'FlagName' is valid +-- +-- @since 2.0.0.2 +mkFlagName :: String -> FlagName +mkFlagName = FlagName . toShortText + +-- | 'mkFlagName' +-- +-- @since 2.0.0.2 +instance IsString FlagName where + fromString = mkFlagName + +-- | Convert 'FlagName' to 'String' +-- +-- @since 2.0.0.2 +unFlagName :: FlagName -> String +unFlagName (FlagName s) = fromShortText s + +instance Binary FlagName + +instance Pretty FlagName where + pretty = Disp.text . unFlagName + +instance Parsec FlagName where + -- Note: we don't check that FlagName doesn't have leading dash, + -- cabal check will do that. + parsec = mkFlagName . lowercase <$> parsec' + where + parsec' = (:) <$> lead <*> rest + lead = P.satisfy (\c -> isAlphaNum c || c == '_') + rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') + +-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to +-- 'Bool' flag values. It represents the flags chosen by the user or +-- discovered during configuration. For example @--flags=foo --flags=-bar@ +-- becomes @[("foo", True), ("bar", False)]@ +-- +newtype FlagAssignment + = FlagAssignment { getFlagAssignment :: Map.Map FlagName (Int, Bool) } + deriving (Binary, Generic, NFData) + +instance Eq FlagAssignment where + (==) (FlagAssignment m1) (FlagAssignment m2) + = fmap snd m1 == fmap snd m2 + +instance Ord FlagAssignment where + compare (FlagAssignment m1) (FlagAssignment m2) + = fmap snd m1 `compare` fmap snd m2 + +-- | Combines pairs of values contained in the 'FlagAssignment' Map. +-- +-- The last flag specified takes precedence, and we record the number +-- of times we have seen the flag. +-- +combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool) +combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2) + +-- The 'Semigroup' instance currently is right-biased. +-- +-- If duplicate flags are specified, we want the last flag specified to +-- take precedence and we want to know how many times the flag has been +-- specified so that we have the option of warning the user about +-- supplying duplicate flags. +instance Semigroup FlagAssignment where + (<>) (FlagAssignment m1) (FlagAssignment m2) + = FlagAssignment (Map.unionWith combineFlagValues m1 m2) + +instance Monoid FlagAssignment where + mempty = FlagAssignment Map.empty + mappend = (<>) + +-- | Construct a 'FlagAssignment' from a list of flag/value pairs. +-- +-- If duplicate flags occur in the input list, the later entries +-- in the list will take precedence. +-- +-- @since 2.2.0 +mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment +mkFlagAssignment = + FlagAssignment . + Map.fromListWith (flip combineFlagValues) . fmap (fmap (\b -> (1, b))) + +-- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs. +-- +-- @ 'null' ('findDuplicateFlagAssignments' fa) ==> ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @ +-- +-- @since 2.2.0 +unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)] +unFlagAssignment = fmap (fmap snd) . Map.toList . getFlagAssignment + +-- | Test whether 'FlagAssignment' is empty. +-- +-- @since 2.2.0 +nullFlagAssignment :: FlagAssignment -> Bool +nullFlagAssignment = Map.null . getFlagAssignment + +-- | Lookup the value for a flag +-- +-- Returns 'Nothing' if the flag isn't contained in the 'FlagAssignment'. +-- +-- @since 2.2.0 +lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool +lookupFlagAssignment fn = fmap snd . Map.lookup fn . getFlagAssignment + +-- | Insert or update the boolean value of a flag. +-- +-- If the flag is already present in the 'FlagAssigment', the +-- value will be updated and the fact that multiple values have +-- been provided for that flag will be recorded so that a +-- warning can be generated later on. +-- +-- @since 2.2.0 +insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment +-- TODO: this currently just shadows prior values for an existing +-- flag; rather than enforcing uniqueness at construction, it's +-- verified later on via `D.C.Dependency.configuredPackageProblems` +insertFlagAssignment flag val = + FlagAssignment . + Map.insertWith (flip combineFlagValues) flag (1, val) . getFlagAssignment + +-- | Remove all flag-assignments from the first 'FlagAssignment' that +-- are contained in the second 'FlagAssignment' +-- +-- NB/TODO: This currently only removes flag assignments which also +-- match the value assignment! We should review the code which uses +-- this operation to figure out if this it's not enough to only +-- compare the flagnames without the values. +-- +-- @since 2.2.0 +diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment +diffFlagAssignment fa1 fa2 = FlagAssignment + (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2)) + +-- | Find the 'FlagName's that have been listed more than once. +-- +-- @since 2.2.0 +findDuplicateFlagAssignments :: FlagAssignment -> [FlagName] +findDuplicateFlagAssignments = + Map.keys . Map.filter ((> 1) . fst) . getFlagAssignment + +-- | @since 2.2.0 +instance Read FlagAssignment where + readsPrec p s = [ (FlagAssignment x, rest) | (x,rest) <- readsPrec p s ] + +-- | @since 2.2.0 +instance Show FlagAssignment where + showsPrec p (FlagAssignment xs) = showsPrec p xs + +-- | String representation of a flag-value pair. +showFlagValue :: (FlagName, Bool) -> String +showFlagValue (f, True) = '+' : unFlagName f +showFlagValue (f, False) = '-' : unFlagName f + +-- | Pretty-prints a flag assignment. +dispFlagAssignment :: FlagAssignment -> Disp.Doc +dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment + +-- | Parses a flag assignment. +parsecFlagAssignment :: CabalParsing m => m FlagAssignment +parsecFlagAssignment = mkFlagAssignment <$> + P.sepBy (onFlag <|> offFlag) P.skipSpaces1 + where + onFlag = do + _ <- P.optional (P.char '+') + f <- parsec + return (f, True) + offFlag = do + _ <- P.char '-' + f <- parsec + return (f, False) diff --git a/cabal/Cabal/Distribution/Types/GenericPackageDescription.hs b/cabal/Cabal/Distribution/Types/GenericPackageDescription.hs --- a/cabal/Cabal/Distribution/Types/GenericPackageDescription.hs +++ b/cabal/Cabal/Distribution/Types/GenericPackageDescription.hs @@ -6,32 +6,10 @@ module Distribution.Types.GenericPackageDescription ( GenericPackageDescription(..), emptyGenericPackageDescription, - Flag(..), - emptyFlag, - FlagName, - mkFlagName, - unFlagName, - FlagAssignment, - mkFlagAssignment, - unFlagAssignment, - lookupFlagAssignment, - insertFlagAssignment, - diffFlagAssignment, - findDuplicateFlagAssignments, - nullFlagAssignment, - showFlagValue, - dispFlagAssignment, - parsecFlagAssignment, - ConfVar(..), ) where import Prelude () import Distribution.Compat.Prelude -import Distribution.Utils.ShortText -import Distribution.Utils.Generic (lowercase) -import qualified Text.PrettyPrint as Disp -import qualified Data.Map as Map -import qualified Distribution.Compat.CharParsing as P -- lens import Distribution.Compat.Lens as L @@ -39,21 +17,17 @@ import Distribution.Types.PackageDescription +import Distribution.Types.Benchmark +import Distribution.Types.CondTree +import Distribution.Types.ConfVar import Distribution.Types.Dependency -import Distribution.Types.Library -import Distribution.Types.ForeignLib import Distribution.Types.Executable +import Distribution.Types.Flag +import Distribution.Types.ForeignLib +import Distribution.Types.Library import Distribution.Types.TestSuite -import Distribution.Types.Benchmark import Distribution.Types.UnqualComponentName -import Distribution.Types.CondTree - import Distribution.Package -import Distribution.Version -import Distribution.Compiler -import Distribution.System -import Distribution.Parsec -import Distribution.Pretty -- --------------------------------------------------------------------------- -- The 'GenericPackageDescription' type @@ -101,229 +75,4 @@ <*> (traverse . L._2 . traverse . L.buildInfo) f x5 <*> (traverse . L._2 . traverse . L.buildInfo) f x6 --- ----------------------------------------------------------------------------- --- The Flag' type --- | A flag can represent a feature to be included, or a way of linking --- a target against its dependencies, or in fact whatever you can think of. -data Flag = MkFlag - { flagName :: FlagName - , flagDescription :: String - , flagDefault :: Bool - , flagManual :: Bool - } - deriving (Show, Eq, Typeable, Data, Generic) - -instance Binary Flag - -instance NFData Flag where rnf = genericRnf - --- | A 'Flag' initialized with default parameters. -emptyFlag :: FlagName -> Flag -emptyFlag name = MkFlag - { flagName = name - , flagDescription = "" - , flagDefault = True - , flagManual = False - } - --- | A 'FlagName' is the name of a user-defined configuration flag --- --- Use 'mkFlagName' and 'unFlagName' to convert from/to a 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0.0.2 -newtype FlagName = FlagName ShortText - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData) - --- | Construct a 'FlagName' from a 'String' --- --- 'mkFlagName' is the inverse to 'unFlagName' --- --- Note: No validations are performed to ensure that the resulting --- 'FlagName' is valid --- --- @since 2.0.0.2 -mkFlagName :: String -> FlagName -mkFlagName = FlagName . toShortText - --- | 'mkFlagName' --- --- @since 2.0.0.2 -instance IsString FlagName where - fromString = mkFlagName - --- | Convert 'FlagName' to 'String' --- --- @since 2.0.0.2 -unFlagName :: FlagName -> String -unFlagName (FlagName s) = fromShortText s - -instance Binary FlagName - -instance Pretty FlagName where - pretty = Disp.text . unFlagName - -instance Parsec FlagName where - -- Note: we don't check that FlagName doesn't have leading dash, - -- cabal check will do that. - parsec = mkFlagName . lowercase <$> parsec' - where - parsec' = (:) <$> lead <*> rest - lead = P.satisfy (\c -> isAlphaNum c || c == '_') - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') - --- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to --- 'Bool' flag values. It represents the flags chosen by the user or --- discovered during configuration. For example @--flags=foo --flags=-bar@ --- becomes @[("foo", True), ("bar", False)]@ --- -newtype FlagAssignment - = FlagAssignment { getFlagAssignment :: Map.Map FlagName (Int, Bool) } - deriving (Binary, Generic, NFData) - -instance Eq FlagAssignment where - (==) (FlagAssignment m1) (FlagAssignment m2) - = fmap snd m1 == fmap snd m2 - -instance Ord FlagAssignment where - compare (FlagAssignment m1) (FlagAssignment m2) - = fmap snd m1 `compare` fmap snd m2 - --- | Combines pairs of values contained in the 'FlagAssignment' Map. --- --- The last flag specified takes precedence, and we record the number --- of times we have seen the flag. --- -combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool) -combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2) - --- The 'Semigroup' instance currently is right-biased. --- --- If duplicate flags are specified, we want the last flag specified to --- take precedence and we want to know how many times the flag has been --- specified so that we have the option of warning the user about --- supplying duplicate flags. -instance Semigroup FlagAssignment where - (<>) (FlagAssignment m1) (FlagAssignment m2) - = FlagAssignment (Map.unionWith combineFlagValues m1 m2) - -instance Monoid FlagAssignment where - mempty = FlagAssignment Map.empty - mappend = (<>) - --- | Construct a 'FlagAssignment' from a list of flag/value pairs. --- --- If duplicate flags occur in the input list, the later entries --- in the list will take precedence. --- --- @since 2.2.0 -mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment -mkFlagAssignment = - FlagAssignment . - Map.fromListWith (flip combineFlagValues) . fmap (fmap (\b -> (1, b))) - --- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs. --- --- @ 'null' ('findDuplicateFlagAssignments' fa) ==> ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @ --- --- @since 2.2.0 -unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)] -unFlagAssignment = fmap (fmap snd) . Map.toList . getFlagAssignment - --- | Test whether 'FlagAssignment' is empty. --- --- @since 2.2.0 -nullFlagAssignment :: FlagAssignment -> Bool -nullFlagAssignment = Map.null . getFlagAssignment - --- | Lookup the value for a flag --- --- Returns 'Nothing' if the flag isn't contained in the 'FlagAssignment'. --- --- @since 2.2.0 -lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool -lookupFlagAssignment fn = fmap snd . Map.lookup fn . getFlagAssignment - --- | Insert or update the boolean value of a flag. --- --- If the flag is already present in the 'FlagAssigment', the --- value will be updated and the fact that multiple values have --- been provided for that flag will be recorded so that a --- warning can be generated later on. --- --- @since 2.2.0 -insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment --- TODO: this currently just shadows prior values for an existing --- flag; rather than enforcing uniqueness at construction, it's --- verified later on via `D.C.Dependency.configuredPackageProblems` -insertFlagAssignment flag val = - FlagAssignment . - Map.insertWith (flip combineFlagValues) flag (1, val) . getFlagAssignment - --- | Remove all flag-assignments from the first 'FlagAssignment' that --- are contained in the second 'FlagAssignment' --- --- NB/TODO: This currently only removes flag assignments which also --- match the value assignment! We should review the code which uses --- this operation to figure out if this it's not enough to only --- compare the flagnames without the values. --- --- @since 2.2.0 -diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment -diffFlagAssignment fa1 fa2 = FlagAssignment - (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2)) - --- | Find the 'FlagName's that have been listed more than once. --- --- @since 2.2.0 -findDuplicateFlagAssignments :: FlagAssignment -> [FlagName] -findDuplicateFlagAssignments = - Map.keys . Map.filter ((> 1) . fst) . getFlagAssignment - --- | @since 2.2.0 -instance Read FlagAssignment where - readsPrec p s = [ (FlagAssignment x, rest) | (x,rest) <- readsPrec p s ] - --- | @since 2.2.0 -instance Show FlagAssignment where - showsPrec p (FlagAssignment xs) = showsPrec p xs - --- | String representation of a flag-value pair. -showFlagValue :: (FlagName, Bool) -> String -showFlagValue (f, True) = '+' : unFlagName f -showFlagValue (f, False) = '-' : unFlagName f - --- | Pretty-prints a flag assignment. -dispFlagAssignment :: FlagAssignment -> Disp.Doc -dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment - --- | Parses a flag assignment. -parsecFlagAssignment :: CabalParsing m => m FlagAssignment -parsecFlagAssignment = mkFlagAssignment <$> - P.sepBy (onFlag <|> offFlag) P.skipSpaces1 - where - onFlag = do - _ <- P.optional (P.char '+') - f <- parsec - return (f, True) - offFlag = do - _ <- P.char '-' - f <- parsec - return (f, False) --- {-# DEPRECATED parseFlagAssignment "Use parsecFlagAssignment. This symbol will be removed in Cabal-3.0 (est. Mar 2019)." #-} - --- ----------------------------------------------------------------------------- --- The 'CondVar' type - --- | A @ConfVar@ represents the variable type used. -data ConfVar = OS OS - | Arch Arch - | Flag FlagName - | Impl CompilerFlavor VersionRange - deriving (Eq, Show, Typeable, Data, Generic) - -instance Binary ConfVar - -instance NFData ConfVar where rnf = genericRnf diff --git a/cabal/Cabal/Distribution/Types/GenericPackageDescription/Lens.hs b/cabal/Cabal/Distribution/Types/GenericPackageDescription/Lens.hs --- a/cabal/Cabal/Distribution/Types/GenericPackageDescription/Lens.hs +++ b/cabal/Cabal/Distribution/Types/GenericPackageDescription/Lens.hs @@ -21,9 +21,9 @@ import Distribution.Types.PackageDescription (PackageDescription) import Distribution.Types.Benchmark (Benchmark) import Distribution.Types.ForeignLib (ForeignLib) -import Distribution.Types.GenericPackageDescription - ( GenericPackageDescription(GenericPackageDescription) - , Flag(MkFlag), FlagName, ConfVar (..)) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription(GenericPackageDescription) ) +import Distribution.Types.Flag (Flag(MkFlag), FlagName) +import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Types.Library (Library) import Distribution.Types.TestSuite (TestSuite) import Distribution.Types.UnqualComponentName (UnqualComponentName) diff --git a/cabal/Cabal/Distribution/Types/LegacyExeDependency.hs b/cabal/Cabal/Distribution/Types/LegacyExeDependency.hs --- a/cabal/Cabal/Distribution/Types/LegacyExeDependency.hs +++ b/cabal/Cabal/Distribution/Types/LegacyExeDependency.hs @@ -40,7 +40,7 @@ verRange <- parsecMaybeQuoted parsec <|> pure anyVersion pure $ LegacyExeDependency name verRange where - nameP = intercalate "-" <$> P.sepBy1 component (P.char '-') + nameP = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-') component = do cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_') if all isDigit cs then fail "invalid component" else return cs diff --git a/cabal/Cabal/Distribution/Types/LocalBuildInfo.hs b/cabal/Cabal/Distribution/Types/LocalBuildInfo.hs --- a/cabal/Cabal/Distribution/Types/LocalBuildInfo.hs +++ b/cabal/Cabal/Distribution/Types/LocalBuildInfo.hs @@ -129,7 +129,7 @@ -- In principle, this is supposed to contain the -- resolved package description, that does not contain -- any conditionals. However, it MAY NOT contain - -- the description wtih a 'HookedBuildInfo' applied + -- the description with a 'HookedBuildInfo' applied -- to it; see 'HookedBuildInfo' for the whole sordid saga. -- As much as possible, Cabal library should avoid using -- this parameter. diff --git a/cabal/Cabal/Distribution/Types/MungedPackageName.hs b/cabal/Cabal/Distribution/Types/MungedPackageName.hs --- a/cabal/Cabal/Distribution/Types/MungedPackageName.hs +++ b/cabal/Cabal/Distribution/Types/MungedPackageName.hs @@ -68,7 +68,7 @@ -- >>> prettyShow $ MungedPackageName "servant" LMainLibName -- "servant" -- --- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey") +-- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey") -- "z-servant-z-lackey" -- instance Pretty MungedPackageName where @@ -77,7 +77,7 @@ -- indefinite package for us. pretty = Disp.text . encodeCompatPackageName' --- | +-- | -- -- >>> simpleParsec "servant" :: Maybe MungedPackageName -- Just (MungedPackageName (PackageName "servant") LMainLibName) @@ -137,7 +137,7 @@ parseZDashCode :: CabalParsing m => m [String] parseZDashCode = do - ns <- P.sepBy1 (some (P.satisfy (/= '-'))) (P.char '-') + ns <- toList <$> P.sepByNonEmpty (some (P.satisfy (/= '-'))) (P.char '-') return (go ns) where go ns = case break (=="z") ns of diff --git a/cabal/Cabal/Distribution/Types/PackageId.hs b/cabal/Cabal/Distribution/Types/PackageId.hs --- a/cabal/Cabal/Distribution/Types/PackageId.hs +++ b/cabal/Cabal/Distribution/Types/PackageId.hs @@ -13,6 +13,7 @@ import Distribution.Types.PackageName import Distribution.Version (Version, nullVersion) +import qualified Data.List.NonEmpty as NE import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp @@ -58,10 +59,10 @@ -- instance Parsec PackageIdentifier where parsec = do - xs' <- P.sepBy1 component (P.char '-') - (v, xs) <- case simpleParsec (last xs') of - Nothing -> return (nullVersion, xs') -- all components are version - Just v -> return (v, init xs') + xs' <- P.sepByNonEmpty component (P.char '-') + (v, xs) <- case simpleParsec (NE.last xs') of + Nothing -> return (nullVersion, toList xs') -- all components are version + Just v -> return (v, NE.init xs') if not (null xs) && all (\c -> all (/= '.') c && not (all isDigit c)) xs then return $ PackageIdentifier (mkPackageName (intercalate "-" xs)) v else fail "all digits or a dot in a portion of package name" diff --git a/cabal/Cabal/Distribution/Types/PkgconfigVersionRange.hs b/cabal/Cabal/Distribution/Types/PkgconfigVersionRange.hs --- a/cabal/Cabal/Distribution/Types/PkgconfigVersionRange.hs +++ b/cabal/Cabal/Distribution/Types/PkgconfigVersionRange.hs @@ -61,7 +61,7 @@ -- note: the wildcard is used in some places, e.g -- http://hackage.haskell.org/package/bindings-libzip-0.10.1/bindings-libzip.cabal -- - -- however, in the presense of alphanumerics etc. lax version parser, + -- however, in the presence of alphanumerics etc. lax version parser, -- wildcard is ill-specified parsec = do diff --git a/cabal/Cabal/Distribution/Types/Version.hs b/cabal/Cabal/Distribution/Types/Version.hs --- a/cabal/Cabal/Distribution/Types/Version.hs +++ b/cabal/Cabal/Distribution/Types/Version.hs @@ -92,7 +92,7 @@ (map Disp.int $ versionNumbers ver)) instance Parsec Version where - parsec = mkVersion <$> P.sepBy1 versionDigitParser (P.char '.') <* tags + parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags where tags = do ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) @@ -109,7 +109,13 @@ toNumber :: CabalParsing m => [Int] -> m Int toNumber [0] = return 0 toNumber (0:_) = P.unexpected "Version digit with leading zero" - toNumber xs = return $ foldl' (\a b -> a * 10 + b) 0 xs + toNumber xs + -- 10^9 = 1000000000 + -- 2^30 = 1073741824 + -- + -- GHC Int is at least 32 bits, so 2^31-1 is the 'maxBound'. + | length xs > 9 = P.unexpected "At most 9 numbers are allowed per version number part" + | otherwise = return $ foldl' (\a b -> a * 10 + b) 0 xs d :: P.CharParsing m => m Int d = f <$> P.satisfyRange '0' '9' diff --git a/cabal/Cabal/Distribution/Types/VersionInterval.hs b/cabal/Cabal/Distribution/Types/VersionInterval.hs --- a/cabal/Cabal/Distribution/Types/VersionInterval.hs +++ b/cabal/Cabal/Distribution/Types/VersionInterval.hs @@ -118,9 +118,9 @@ doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' adjacentIntervals :: [(VersionInterval, VersionInterval)] - adjacentIntervals - | null intervals = [] - | otherwise = zip intervals (tail intervals) + adjacentIntervals = case intervals of + [] -> [] + (_:tl) -> zip intervals tl checkInvariant :: VersionIntervals -> VersionIntervals checkInvariant is = assert (invariant is) is diff --git a/cabal/Cabal/Distribution/Types/VersionRange.hs b/cabal/Cabal/Distribution/Types/VersionRange.hs --- a/cabal/Cabal/Distribution/Types/VersionRange.hs +++ b/cabal/Cabal/Distribution/Types/VersionRange.hs @@ -39,6 +39,7 @@ import Distribution.Compat.Prelude import Distribution.Types.Version import Distribution.Types.VersionRange.Internal +import Distribution.Utils.Generic import Prelude () -- | Fold over the basic syntactic structure of a 'VersionRange'. @@ -130,7 +131,9 @@ -- | @since 2.2 wildcardUpperBound :: Version -> Version wildcardUpperBound = alterVersion $ - \lowerBound -> init lowerBound ++ [last lowerBound + 1] + \lowerBound -> case unsnoc lowerBound of + Nothing -> [] + Just (xs, x) -> xs ++ [x + 1] isWildcardRange :: Version -> Version -> Bool isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2) diff --git a/cabal/Cabal/Distribution/Types/VersionRange/Internal.hs b/cabal/Cabal/Distribution/Types/VersionRange/Internal.hs --- a/cabal/Cabal/Distribution/Types/VersionRange/Internal.hs +++ b/cabal/Cabal/Distribution/Types/VersionRange/Internal.hs @@ -381,7 +381,7 @@ -- a plain version without tags or wildcards verPlain :: CabalParsing m => m Version - verPlain = mkVersion <$> P.sepBy1 digitParser (P.char '.') + verPlain = mkVersion <$> toList <$> P.sepByNonEmpty digitParser (P.char '.') -- either wildcard or normal version verOrWild :: CabalParsing m => m (Bool, Version) diff --git a/cabal/Cabal/Distribution/Utils/Generic.hs b/cabal/Cabal/Distribution/Utils/Generic.hs --- a/cabal/Cabal/Distribution/Utils/Generic.hs +++ b/cabal/Cabal/Distribution/Utils/Generic.hs @@ -64,13 +64,18 @@ ordNub, ordNubBy, ordNubRight, + safeHead, safeTail, + safeLast, + safeInit, unintersperse, wrapText, wrapLine, unfoldrM, spanMaybe, breakMaybe, + unsnoc, + unsnocNE, -- * FilePath stuff isAbsoluteOnAnyPlatform, @@ -280,11 +285,11 @@ -- -- Example: -- --- >>> tail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1] +-- >>> safeTail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1] -- *** Exception: Prelude.undefined -- ... -- --- >>> tail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1] +-- >>> safeTail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1] -- [5,4,3] -- -- >>> take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined] @@ -363,11 +368,27 @@ where bSet = Set.fromList b +-- | A total variant of 'head'. +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x + -- | A total variant of 'tail'. safeTail :: [a] -> [a] safeTail [] = [] safeTail (_:xs) = xs +-- | A total variant of 'last'. +safeLast :: [a] -> Maybe a +safeLast [] = Nothing +safeLast (x:xs) = Just (foldl (\_ a -> a) x xs) + +-- | A total variant of 'init'. +safeInit :: [a] -> [a] +safeInit [] = [] +safeInit [_] = [] +safeInit (x:xs) = x : safeInit xs + equating :: Eq a => (b -> a) -> b -> b -> Bool equating p x y = p x == p y @@ -453,6 +474,35 @@ case m of Nothing -> return [] Just (a, b') -> liftM (a :) (go b') + +-- | The opposite of 'snoc', which is the reverse of 'cons' +-- +-- Example: +-- +-- >>> unsnoc [1, 2, 3] +-- Just ([1,2],3) +-- +-- >>> unsnoc [] +-- Nothing +-- +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc (x:xs) = Just (unsnocNE (x :| xs)) + +-- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe' +-- +-- Example: +-- +-- >>> unsnocNE (1 :| [2, 3]) +-- ([1,2],3) +-- +-- >>> unsnocNE (1 :| []) +-- ([],1) +-- +unsnocNE :: NonEmpty a -> ([a], a) +unsnocNE (x:|xs) = go x xs where + go y [] = ([], y) + go y (z:zs) = let ~(ws, w) = go z zs in (y : ws, w) -- ------------------------------------------------------------ -- * FilePath stuff diff --git a/cabal/Cabal/Distribution/Utils/NubList.hs b/cabal/Cabal/Distribution/Utils/NubList.hs --- a/cabal/Cabal/Distribution/Utils/NubList.hs +++ b/cabal/Cabal/Distribution/Utils/NubList.hs @@ -25,7 +25,7 @@ deriving (Eq, Generic, Typeable) -- NubList assumes that nub retains the list order while removing duplicate --- elements (keeping the first occurence). Documentation for "Data.List.nub" +-- elements (keeping the first occurrence). Documentation for "Data.List.nub" -- does not specifically state that ordering is maintained so we will add a test -- for that to the test suite. @@ -66,7 +66,7 @@ -- | Helper used by NubList/NubListR's Read instances. readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a) -readNubList toList = R.parens . R.prec 10 $ fmap toList R.readPrec +readNubList listToL = R.parens . R.prec 10 $ fmap listToL R.readPrec -- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we -- just pull off constructor and put the list. For 'get', we get the list and diff --git a/cabal/Cabal/Distribution/Verbosity.hs b/cabal/Cabal/Distribution/Verbosity.hs --- a/cabal/Cabal/Distribution/Verbosity.hs +++ b/cabal/Cabal/Distribution/Verbosity.hs @@ -55,7 +55,6 @@ import Distribution.ReadE import Data.List (elemIndex) -import Data.Set (Set) import Distribution.Parsec import Distribution.Verbosity.Internal diff --git a/cabal/Cabal/Language/Haskell/Extension.hs b/cabal/Cabal/Language/Haskell/Extension.hs --- a/cabal/Cabal/Language/Haskell/Extension.hs +++ b/cabal/Cabal/Language/Haskell/Extension.hs @@ -23,7 +23,7 @@ classifyExtension, ) where -import Prelude () +import qualified Prelude (head) import Distribution.Compat.Prelude import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) @@ -777,7 +777,7 @@ -- to the type-level. | TypeInType - -- | Allow recursive (and therefore undecideable) super-class relationships. + -- | Allow recursive (and therefore undecidable) super-class relationships. | UndecidableSuperClasses -- | A temporary extension to help library authors check if their @@ -889,6 +889,6 @@ knownExtensionTable :: Array Char [(String, KnownExtension)] knownExtensionTable = accumArray (flip (:)) [] ('A', 'Z') - [ (head str, (str, extension)) + [ (Prelude.head str, (str, extension)) -- assume KnownExtension's Show returns a non-empty string | extension <- [toEnum 0 ..] , let str = show extension ] diff --git a/cabal/Cabal/doc/developing-packages.rst b/cabal/Cabal/doc/developing-packages.rst --- a/cabal/Cabal/doc/developing-packages.rst +++ b/cabal/Cabal/doc/developing-packages.rst @@ -1340,7 +1340,7 @@ build-depends: foo-internal, base Internal libraries are also useful for packages that define multiple -executables, but do not define a publically accessible library. Internal +executables, but do not define a publicly accessible library. Internal libraries are only visible internally in the package (so they can only be added to the :pkg-field:`build-depends` of same-package libraries, executables, test suites, etc.) Internal libraries locally shadow any @@ -2013,7 +2013,7 @@ **Library Names** External libraries are identified by the package's name they're - provided by (currently a package can only publically expose its + provided by (currently a package can only publicly expose its main library compeonent; in future, packages with multiple exposed public library components will be supported and a syntax for referring to public sub-libraries will be provided). @@ -2184,15 +2184,29 @@ :pkg-field:`other-modules`, :pkg-field:`library:exposed-modules` or :pkg-field:`executable:main-is` fields. +.. pkg-field:: hs-source-dir: directory list + :deprecated: 2.0 + :removed: 3.0 + :default: ``.`` + + Root directories for the module hierarchy. + + Deprecated in favor of :pkg-field:`hs-source-dirs`. + .. pkg-field:: hs-source-dirs: directory list :default: ``.`` Root directories for the module hierarchy. - For backwards compatibility, the old variant ``hs-source-dir`` is - also recognized. + .. note:: + Components can share source directories but modules found there will be + recompiled even if other components already built them, i.e., if a + library and an executable share a source directory and the executable + depends on the library and imports its ``Foo`` module, ``Foo`` will be + compiled twice, once as part of the library and again for the executable. + .. pkg-field:: default-extensions: identifier list A list of Haskell extensions used by every module. These determine @@ -2478,12 +2492,13 @@ appropriately. .. pkg-field:: asm-sources: filename list - :since: 2.2 + :since: 3.0 A list of assembly source files to be compiled and linked with the Haskell files. .. pkg-field:: cmm-sources: filename list + :since: 3.0 A list of C-- source files to be compiled and linked with the Haskell files. @@ -2550,8 +2565,14 @@ command-line arguments with the :pkg-field:`cc-options` and the :pkg-field:`cxx-options` fields. +.. pkg-field:: cmm-options: token list + :since: 3.0 + + Command-line arguments to be passed to the compiler when compiling + C-- code. See also :pkg-field:`cmm-sources`. + .. pkg-field:: asm-options: token list - :since: 2.2 + :since: 3.0 Command-line arguments to be passed to the assembler when compiling assembler code. See also :pkg-field:`asm-sources`. diff --git a/cabal/Cabal/doc/file-format-changelog.rst b/cabal/Cabal/doc/file-format-changelog.rst --- a/cabal/Cabal/doc/file-format-changelog.rst +++ b/cabal/Cabal/doc/file-format-changelog.rst @@ -19,6 +19,11 @@ versions of the ``Cabal`` library denote unreleased development branches which have no stability guarantee. +``cabal-version: 3.2`` +---------------------- + +* Nothing yet + ``cabal-version: 3.0`` ---------------------- @@ -69,6 +74,14 @@ * New :pkg-field:`autogen-includes` for specifying :pkg-field:`install-includes` which are autogenerated (e.g. by a ``configure`` script). +* New :pkg-field:`asm-sources` and :pkg-field:`asm-options` fields + added for suppporting bundled foreign routines implemented in + assembler. + +* New :pkg-field:`cmm-sources` and :pkg-field:`cmm-options` fields + added for suppporting bundled foreign primops implemented in + C--. + ``cabal-version: 2.4`` ---------------------- @@ -103,10 +116,6 @@ * New :pkg-field:`cxx-sources` and :pkg-field:`cxx-options` fields added for suppporting bundled foreign routines implemented in C++. - -* New :pkg-field:`asm-sources` and :pkg-field:`asm-options` fields - added for suppporting bundled foreign routines implemented in - assembler. * New :pkg-field:`extra-bundled-libraries` field for specifying additional custom library objects to be installed. diff --git a/cabal/Cabal/doc/installing-packages.rst b/cabal/Cabal/doc/installing-packages.rst --- a/cabal/Cabal/doc/installing-packages.rst +++ b/cabal/Cabal/doc/installing-packages.rst @@ -340,7 +340,7 @@ $ cabal build It can be occasionally useful to run the compiler-specific package -manager tool (e.g. ``ghc-pkg``) tool on the sandbox package DB directly +manager tool (e.g. ``ghc-pkg``) on the sandbox package DB directly (for example, you may need to unregister some packages). The ``cabal sandbox hc-pkg`` command is a convenient wrapper that runs the compiler-specific package manager tool with the arguments: @@ -1228,7 +1228,8 @@ Specify that a particular dependency should used for a particular package name. In particular, it declares that any reference to - *pkgname* in a ``build-depends`` should be resolved to *ipid*. + *pkgname* in a :pkg-field:`build-depends` should be resolved to + *ipid*. .. option:: --exact-configuration @@ -1314,8 +1315,8 @@ $ cabal install --constraint="bar == 2.1" - Version bounds have the same syntax as ``build-depends``. As - a special case, the following prevents ``bar`` from being + Version bounds have the same syntax as :pkg-field:`build-depends`. + As a special case, the following prevents ``bar`` from being used at all: :: @@ -1354,11 +1355,11 @@ $ cabal install --constraint="bar test" --constraint="bar bench" By default, constraints only apply to build dependencies - (``build-depends``), build dependencies of build + (:pkg-field:`build-depends`), build dependencies of build dependencies, and so on. Constraints normally do not apply to dependencies of the ``Setup.hs`` script of any package - (``setup-depends``) nor do they apply to build tools - (``build-tool-depends``) or the dependencies of build + (:pkg-field:`setup-depends`) nor do they apply to build tools + (:pkg-field:`build-tool-depends`) or the dependencies of build tools. To explicitly apply a constraint to a setup or build tool dependency, you can add a qualifier to the constraint as follows: @@ -1671,6 +1672,8 @@ Keeps the configuration information so it is not necessary to run the configure step again before building. +.. _setup-test: + setup test ---------- @@ -1715,7 +1718,7 @@ .. option:: --test-option=option - give an extra option to the test executables. There is no need to + Give an extra option to the test executables. There is no need to quote options containing spaces because a single option is assumed, so options will not be split on spaces. @@ -1725,6 +1728,26 @@ execution context. The text executable path and test arguments are passed as arguments to the wrapper and it is expected that the wrapper will return the test's return code, as well as a copy of stdout/stderr. + +.. _setup-bench: + +setup bench +----------- + +Run the benchmarks specified in the package description file. Aside +from the following flags, Cabal accepts the name of one or more benchmarks +on the command line after ``bench``. When supplied, Cabal will run +only the named benchmarks, otherwise, Cabal will run all benchmarks in +the package. + +.. option:: --benchmark-options=options + Give extra options to the benchmark executables. + +.. option:: --benchmark-option=option + + Give an extra option to the benchmark executables. There is no need to + quote options containing spaces because a single option is assumed, + so options will not be split on spaces. .. _setup-sdist: diff --git a/cabal/Cabal/doc/nix-local-build.rst b/cabal/Cabal/doc/nix-local-build.rst --- a/cabal/Cabal/doc/nix-local-build.rst +++ b/cabal/Cabal/doc/nix-local-build.rst @@ -653,6 +653,14 @@ ``autogen-modules`` is able to replace uses of the hooks to add generated modules, along with the custom publishing of Haddock documentation to Hackage. +.. warning:: + + Packages that use Backpack will stop working if uploaded to + Hackage, due to `issue #6005 `_. + While this is happening, we recommend not uploading these packages + to Hackage (and instead referencing the package directly + as a ``source-repository-package``). + Configuring builds with cabal.project ===================================== @@ -961,7 +969,7 @@ .. cfg-field:: allow-newer: none, all or list of scoped package names (space or comma separated) --allow-newer, --allow-newer=[none,all,[scope:][^]pkg] - :synopsis: Lift dependencies upper bound constaints. + :synopsis: Lift dependencies upper bound constraints. :default: ``none`` @@ -1054,7 +1062,7 @@ .. cfg-field:: allow-older: none, all, list of scoped package names (space or comma separated) --allow-older, --allow-older=[none,all,[scope:][^]pkg] - :synopsis: Lift dependency lower bound constaints. + :synopsis: Lift dependency lower bound constraints. :since: 2.0 :default: ``none`` @@ -1829,6 +1837,7 @@ ``haddock`` command). .. cfg-field:: haddock-html-location: templated path + --html-location=TEMPLATE :synopsis: Haddock HTML templates location. Specify a template for the location of HTML documentation for @@ -1839,14 +1848,18 @@ :: - html-location: 'http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' + html-location: http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html + The command line variant of this flag is ``--html-location`` (for + the ``haddock`` subcommand). + + :: + + --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' + Here the argument is quoted to prevent substitution by the shell. If this option is omitted, the location for each package is obtained using the package tool (e.g. ``ghc-pkg``). - - The command line variant of this flag is ``--html-location`` (for - the ``haddock`` subcommand). .. cfg-field:: haddock-executables: boolean :synopsis: Generate documentation for executables. diff --git a/cabal/Makefile b/cabal/Makefile --- a/cabal/Makefile +++ b/cabal/Makefile @@ -6,8 +6,8 @@ SPDX_LICENSE_HS:=Cabal/Distribution/SPDX/LicenseId.hs SPDX_EXCEPTION_HS:=Cabal/Distribution/SPDX/LicenseExceptionId.hs -CABALBUILD := cabal new-build --enable-tests -CABALRUN := cabal new-run --enable-tests +CABALBUILD := cabal v2-build +CABALRUN := cabal v2-run # default rules @@ -19,6 +19,10 @@ exe : $(LEXER_HS) $(CABALBUILD) cabal-install:exes +# Build library with oldest supported GHC +lib-ghc-7.6 : + $(CABALBUILD) --project-file=cabal.project.libonly --with-compiler=ghc-7.6.3 Cabal:libs + # source generation: Lexer lexer : $(LEXER_HS) @@ -33,10 +37,10 @@ spdx : $(SPDX_LICENSE_HS) $(SPDX_EXCEPTION_HS) $(SPDX_LICENSE_HS) : boot/SPDX.LicenseId.template.hs cabal-dev-scripts/src/GenUtils.hs cabal-dev-scripts/src/GenSPDX.hs license-list-data/licenses-3.0.json license-list-data/licenses-3.2.json - cabal new-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-spdx -- boot/SPDX.LicenseId.template.hs license-list-data/licenses-3.0.json license-list-data/licenses-3.2.json license-list-data/licenses-3.6.json $(SPDX_LICENSE_HS) + cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-spdx -- boot/SPDX.LicenseId.template.hs license-list-data/licenses-3.0.json license-list-data/licenses-3.2.json license-list-data/licenses-3.6.json $(SPDX_LICENSE_HS) $(SPDX_EXCEPTION_HS) : boot/SPDX.LicenseExceptionId.template.hs cabal-dev-scripts/src/GenUtils.hs cabal-dev-scripts/src/GenSPDXExc.hs license-list-data/exceptions-3.0.json license-list-data/exceptions-3.2.json - cabal new-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-spdx-exc -- boot/SPDX.LicenseExceptionId.template.hs license-list-data/exceptions-3.0.json license-list-data/exceptions-3.2.json license-list-data/exceptions-3.6.json $(SPDX_EXCEPTION_HS) + cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-spdx-exc -- boot/SPDX.LicenseExceptionId.template.hs license-list-data/exceptions-3.0.json license-list-data/exceptions-3.2.json license-list-data/exceptions-3.6.json $(SPDX_EXCEPTION_HS) # cabal-install.cabal file generation @@ -59,21 +63,21 @@ gen-extra-source-files : gen-extra-source-files-lib gen-extra-source-files-cli gen-extra-source-files-lib : - cabal new-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-extra-source-files -- $$(pwd)/Cabal/Cabal.cabal + cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-extra-source-files -- $$(pwd)/Cabal/Cabal.cabal # We need to generate cabal-install-dev so the test modules are in .cabal file! gen-extra-source-files-cli : $(MAKE) cabal-install-dev - cabal new-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-extra-source-files -- $$(pwd)/cabal-install/cabal-install.cabal.pp $$(pwd)/cabal-install/cabal-install.cabal + cabal v2-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-extra-source-files -- $$(pwd)/cabal-install/cabal-install.cabal.pp $$(pwd)/cabal-install/cabal-install.cabal $(MAKE) cabal-install-prod # ghcid ghcid-lib : - ghcid -c 'cabal new-repl Cabal' + ghcid -c 'cabal v2-repl Cabal' ghcid-cli : - ghcid -c 'cabal new-repl cabal-install' + ghcid -c 'cabal v2-repl cabal-install' # doctests (relies on .ghc.environment files) @@ -83,7 +87,7 @@ # tests check-tests : - $(CABALRUN) --enable-tests check-tests -- --cwd Cabal ${TEST} + $(CABALRUN) check-tests -- --cwd Cabal ${TEST} parser-tests : $(CABALRUN) parser-tests -- --cwd Cabal ${TEST} @@ -105,3 +109,6 @@ $(CABALBUILD) -j3 cabal-tests cabal rm -rf .ghc.environment.* cd cabal-testsuite && `cabal-plan list-bin cabal-tests` --with-cabal=`cabal-plan list-bin cabal` --hide-successes -j3 ${TEST} + +validate-via-docker: + docker build -t cabal-validate -f validate.dockerfile . diff --git a/cabal/appveyor.yml b/cabal/appveyor.yml --- a/cabal/appveyor.yml +++ b/cabal/appveyor.yml @@ -1,10 +1,12 @@ +# Read https://hub.zhox.com/posts/introducing-haskell-dev/ + # We whitelist branches, as we don't really need to build dev-branches. # Remember to add release branches, both here and to .travis.yml. branches: only: - master - "3.0" - - "2.4" + - "2.4" - "2.2" - "2.0" - "1.24" @@ -21,38 +23,42 @@ # Using '-y' and 'refreshenv' as a workaround to: # https://github.com/haskell/cabal/issues/3687 - choco source add -n mistuke -s https://www.myget.org/F/mistuke/api/v2 - - choco install -y ghc --version 8.0.2 --ignore-dependencies - - choco install -y cabal-head -pre + - choco install -y cabal --version 2.4.1.0 + - choco install -y ghc --version 8.6.5 - refreshenv + +before_build: - cabal --version - - cabal %CABOPTS% update + - ghc --version + - cabal %CABOPTS% v2-update - cabal %CABOPTS% v1-install happy alex environment: global: - CABOPTS: "--store-dir=C:\\SR" + CABOPTS: --store-dir=C:\\SR --http-transport=plain-http # Remove cache, there is no button on the web # https://www.appveyor.com/docs/build-cache/#skipping-cache-operations-for-specific-build APPVEYOR_CACHE_SKIP_RESTORE: true +clone_folder: "c:\\WORK" + cache: - dist-newstyle - "C:\\sr" build_script: - runghc cabal-dev-scripts/src/Preprocessor.hs -o cabal-install/cabal-install.cabal -f CABAL_FLAG_LIB cabal-install/cabal-install.cabal.pp - - cabal %CABOPTS% new-configure --enable-tests - - appveyor-retry cabal %CABOPTS% new-build lib:Cabal --only-dependencies - - cabal %CABOPTS% new-build lib:Cabal - - appveyor-retry cabal %CABOPTS% new-build Cabal:tests --only-dependencies - - cabal %CABOPTS% new-test Cabal - - appveyor-retry cabal %CABOPTS% new-build exe:cabal exe:cabal-tests --only-dependencies - - cabal %CABOPTS% new-build exe:cabal - - cabal %CABOPTS% new-run cabal-tests -- -j3 --with-cabal=dist-newstyle\build\x86_64-windows\ghc-8.0.2\cabal-install-3.1.0.0\x\cabal\build\cabal\cabal.exe - - appveyor-retry cabal %CABOPTS% new-build cabal-install:tests --only-dependencies + - cabal %CABOPTS% v2-configure --enable-tests + - appveyor-retry cabal %CABOPTS% v2-build lib:Cabal --only-dependencies + - cabal %CABOPTS% v2-build lib:Cabal + - appveyor-retry cabal %CABOPTS% v2-build Cabal:tests --only-dependencies + - cabal %CABOPTS% v2-test Cabal + - appveyor-retry cabal %CABOPTS% v2-build exe:cabal exe:cabal-tests --only-dependencies + - cabal %CABOPTS% v2-build exe:cabal + - cabal %CABOPTS% v2-run cabal-tests -- -j3 --with-cabal=dist-newstyle\build\x86_64-windows\ghc-8.6.5\cabal-install-3.1.0.0\x\cabal\build\cabal\cabal.exe + - appveyor-retry cabal %CABOPTS% v2-build cabal-install:tests --only-dependencies - cd cabal-install - - cabal %CABOPTS% new-run cabal-install:memory-usage-tests - - cabal %CABOPTS% new-run cabal-install:solver-quickcheck - - cabal %CABOPTS% new-run cabal-install:integration-tests2 - - cabal %CABOPTS% new-run cabal-install:unit-tests -- --pattern "! (/FileMonitor/ || /VCS/ || /Get/)" - + - cabal %CABOPTS% v2-run cabal-install:memory-usage-tests + - cabal %CABOPTS% v2-run cabal-install:solver-quickcheck + - cabal %CABOPTS% v2-run cabal-install:integration-tests2 + - cabal %CABOPTS% v2-run cabal-install:unit-tests -- --pattern "! (/FileMonitor/ || /VCS/ || /Get/)" diff --git a/cabal/boot/SPDX.LicenseExceptionId.template.hs b/cabal/boot/SPDX.LicenseExceptionId.template.hs --- a/cabal/boot/SPDX.LicenseExceptionId.template.hs +++ b/cabal/boot/SPDX.LicenseExceptionId.template.hs @@ -28,7 +28,7 @@ -- | SPDX License identifier data LicenseExceptionId -{{{ licenseIds }}} +{{ licenseIds }} deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data, Generic) instance Binary LicenseExceptionId where @@ -58,15 +58,15 @@ -- | License SPDX identifier, e.g. @"BSD-3-Clause"@. licenseExceptionId :: LicenseExceptionId -> String -{{#licenses}} -licenseExceptionId {{licenseCon}} = {{{licenseId}}} -{{/licenses}} +{% for l in licenses %} +licenseExceptionId {{l.constructor}} = {{l.id}} +{% endfor %} -- | License name, e.g. @"GNU General Public License v2.0 only"@ licenseExceptionName :: LicenseExceptionId -> String -{{#licenses}} -licenseExceptionName {{licenseCon}} = {{{licenseName}}} -{{/licenses}} +{% for l in licenses %} +licenseExceptionName {{l.constructor}} = {{l.name}} +{% endfor %} ------------------------------------------------------------------------------- -- Creation @@ -74,13 +74,13 @@ licenseExceptionIdList :: LicenseListVersion -> [LicenseExceptionId] licenseExceptionIdList LicenseListVersion_3_0 = -{{{licenseList_3_0}}} +{{licenseList_3_0}} ++ bulkOfLicenses licenseExceptionIdList LicenseListVersion_3_2 = -{{{licenseList_3_2}}} +{{licenseList_3_2}} ++ bulkOfLicenses licenseExceptionIdList LicenseListVersion_3_6 = -{{{licenseList_3_6}}} +{{licenseList_3_6}} ++ bulkOfLicenses -- | Create a 'LicenseExceptionId' from a 'String'. @@ -104,4 +104,4 @@ -- | License exceptions in all SPDX License lists bulkOfLicenses :: [LicenseExceptionId] bulkOfLicenses = -{{{licenseList_all}}} +{{licenseList_all}} diff --git a/cabal/boot/SPDX.LicenseId.template.hs b/cabal/boot/SPDX.LicenseId.template.hs --- a/cabal/boot/SPDX.LicenseId.template.hs +++ b/cabal/boot/SPDX.LicenseId.template.hs @@ -31,7 +31,7 @@ -- | SPDX License identifier data LicenseId -{{{ licenseIds }}} +{{ licenseIds }} deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data, Generic) instance Binary LicenseId where @@ -110,23 +110,23 @@ -- | License SPDX identifier, e.g. @"BSD-3-Clause"@. licenseId :: LicenseId -> String -{{#licenses}} -licenseId {{licenseCon}} = {{{licenseId}}} -{{/licenses}} +{% for l in licenses %} +licenseId {{l.constructor}} = {{l.id}} +{% endfor %} -- | License name, e.g. @"GNU General Public License v2.0 only"@ licenseName :: LicenseId -> String -{{#licenses}} -licenseName {{licenseCon}} = {{{licenseName}}} -{{/licenses}} +{% for l in licenses %} +licenseName {{l.constructor}} = {{l.name}} +{% endfor %} -- | Whether the license is approved by Open Source Initiative (OSI). -- -- See . licenseIsOsiApproved :: LicenseId -> Bool -{{#licenses}} -licenseIsOsiApproved {{licenseCon}} = {{#isOsiApproved}}True{{/isOsiApproved}}{{^isOsiApproved}}False{{/isOsiApproved}} -{{/licenses}} +{% for l in licenses %} +licenseIsOsiApproved {{l.constructor}} = {% if l.isOsiApproved %}True{% else %}False{% endif %} +{% endfor %} ------------------------------------------------------------------------------- -- Creation @@ -134,13 +134,13 @@ licenseIdList :: LicenseListVersion -> [LicenseId] licenseIdList LicenseListVersion_3_0 = -{{{licenseList_3_0}}} +{{licenseList_3_0}} ++ bulkOfLicenses licenseIdList LicenseListVersion_3_2 = -{{{licenseList_3_2}}} +{{licenseList_3_2}} ++ bulkOfLicenses licenseIdList LicenseListVersion_3_6 = -{{{licenseList_3_6}}} +{{licenseList_3_6}} ++ bulkOfLicenses -- | Create a 'LicenseId' from a 'String'. @@ -164,4 +164,4 @@ -- | Licenses in all SPDX License lists bulkOfLicenses :: [LicenseId] bulkOfLicenses = -{{{licenseList_all}}} +{{licenseList_all}} diff --git a/cabal/cabal-dev-scripts/LICENSE b/cabal/cabal-dev-scripts/LICENSE --- a/cabal/cabal-dev-scripts/LICENSE +++ b/cabal/cabal-dev-scripts/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2017, Cabal Development Team +opyright (c) 2017, Cabal Development Team All rights reserved. diff --git a/cabal/cabal-dev-scripts/cabal-dev-scripts.cabal b/cabal/cabal-dev-scripts/cabal-dev-scripts.cabal --- a/cabal/cabal-dev-scripts/cabal-dev-scripts.cabal +++ b/cabal/cabal-dev-scripts/cabal-dev-scripts.cabal @@ -1,58 +1,57 @@ -name: cabal-dev-scripts -version: 0 -synopsis: Dev scripts for cabal development -description: - This package provides a tools for Cabal development -homepage: http://www.haskell.org/cabal/ -license: BSD3 -license-file: LICENSE -author: Cabal Development Team -category: Distribution -build-type: Simple -cabal-version: >=2.0 +cabal-version: 2.2 +name: cabal-dev-scripts +version: 0 +synopsis: Dev scripts for cabal development +description: This package provides a tools for Cabal development +homepage: http://www.haskell.org/cabal/ +license: BSD-3-Clause +license-file: LICENSE +author: Cabal Development Team +category: Distribution +build-type: Simple executable gen-extra-source-files - default-language: Haskell2010 - main-is: GenExtraSourceFiles.hs - hs-source-dirs: src + default-language: Haskell2010 + main-is: GenExtraSourceFiles.hs + hs-source-dirs: src build-depends: - base >=4.10 && <4.13, - Cabal >=2.2 && <2.6, - bytestring, - directory, - filepath, - process + , base >=4.10 && <4.13 + , bytestring + , Cabal >=2.2 && <2.6 + , directory + , filepath + , process executable gen-spdx - default-language: Haskell2010 - main-is: GenSPDX.hs - other-modules: GenUtils - hs-source-dirs: src - ghc-options: -Wall + default-language: Haskell2010 + main-is: GenSPDX.hs + other-modules: GenUtils + hs-source-dirs: src + ghc-options: -Wall build-depends: - base >=4.10 && <4.13, - aeson >=1.4.0.0 && <1.5, - bytestring, - containers, - Diff >=0.3.4 && <0.4, - lens >=4.17 && <4.18, - microstache >=1.0.1.1 && <1.1, - optparse-applicative >=0.13 && <0.15, - text + , aeson ^>=1.4.1.0 + , base >=4.10 && <4.13 + , bytestring + , containers + , Diff ^>=0.4 + , lens ^>=4.18.1 + , optparse-applicative ^>=0.15.1.0 + , text + , zinza ^>=0.1 executable gen-spdx-exc - default-language: Haskell2010 - main-is: GenSPDXExc.hs - other-modules: GenUtils - hs-source-dirs: src - ghc-options: -Wall + default-language: Haskell2010 + main-is: GenSPDXExc.hs + other-modules: GenUtils + hs-source-dirs: src + ghc-options: -Wall build-depends: - base >=4.10 && <4.13, - aeson >=1.4.0.0 && <1.5, - bytestring, - containers, - Diff >=0.3.4 && <0.4, - lens >=4.17 && <4.18, - microstache >=1.0.1.1 && <1.1, - optparse-applicative >=0.13 && <0.15, - text + , aeson ^>=1.4.1.0 + , base >=4.10 && <4.13 + , bytestring + , containers + , Diff ^>=0.4 + , lens ^>=4.18.1 + , optparse-applicative ^>=0.15.1.0 + , text + , zinza ^>=0.1 diff --git a/cabal/cabal-dev-scripts/src/GenSPDX.hs b/cabal/cabal-dev-scripts/src/GenSPDX.hs --- a/cabal/cabal-dev-scripts/src/GenSPDX.hs +++ b/cabal/cabal-dev-scripts/src/GenSPDX.hs @@ -1,21 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Lens hiding ((.=)) -import Data.Aeson (FromJSON (..), Value, eitherDecode, object, withObject, (.:), (.=)) -import Data.Foldable (for_) +import Control.Lens (imap) +import Data.Aeson (FromJSON (..), eitherDecode, withObject, (.:)) import Data.List (sortOn) import Data.Semigroup ((<>)) import Data.Text (Text) import Data.Traversable (for) +import GHC.Generics (Generic) import qualified Data.ByteString.Lazy as LBS import qualified Data.Set as Set import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TL import qualified Options.Applicative as O -import qualified Text.Microstache as M +import qualified Zinza as Z import GenUtils @@ -34,7 +33,7 @@ licensesAll = PerV <$> licenses "3.0" <*> licenses "3.2" - <*> licenses "3.5" + <*> licenses "3.6" template = O.strArgument $ mconcat [ O.metavar "SPDX.LicenseId.template.hs" @@ -54,27 +53,26 @@ generate :: Opts -> IO () generate (Opts tmplFile fns out) = do lss <- for fns $ \fn -> either fail pure . eitherDecode =<< LBS.readFile fn - template <- M.compileMustacheFile tmplFile - let (ws, rendered) = generate' lss template - for_ ws $ putStrLn . M.displayMustacheWarning - TL.writeFile out (header <> "\n" <> rendered) + template <- Z.parseAndCompileTemplateIO tmplFile + output <- generate' lss template + writeFile out (header <> "\n" <> output) putStrLn $ "Generated file " ++ out generate' :: PerV LicenseList - -> M.Template - -> ([M.MustacheWarning], TL.Text) -generate' lss template = M.renderMustacheW template $ object - [ "licenseIds" .= licenseIds - , "licenses" .= licenseValues - , "licenseList_all" .= mkLicenseList (== allVers) - , "licenseList_3_0" .= mkLicenseList + -> (Input -> IO String) + -> IO String +generate' lss template = template $ Input + { inputLicenseIds = licenseIds + , inputLicenses = licenseValues + , inputLicenseList_all = mkLicenseList (== allVers) + , inputLicenseList_3_0 = mkLicenseList (\vers -> vers /= allVers && Set.member SPDXLicenseListVersion_3_0 vers) - , "licenseList_3_2" .= mkLicenseList + , inputLicenseList_3_2 = mkLicenseList (\vers -> vers /= allVers && Set.member SPDXLicenseListVersion_3_2 vers) - , "licenseList_3_6" .= mkLicenseList + , inputLicenseList_3_6 = mkLicenseList (\vers -> vers /= allVers && Set.member SPDXLicenseListVersion_3_6 vers) - ] + } where PerV (LL ls_3_0) (LL ls_3_2) (LL ls_3_6) = lss @@ -88,13 +86,13 @@ filterDeprecated = filter (not . licenseDeprecated) - licenseValues :: [Value] - licenseValues = flip map constructorNames $ \(c, l, _) -> object - [ "licenseCon" .= c - , "licenseId" .= textShow (licenseId l) - , "licenseName" .= textShow (licenseName l) - , "isOsiApproved" .= licenseOsiApproved l - ] + licenseValues :: [InputLicense] + licenseValues = flip map constructorNames $ \(c, l, _) -> InputLicense + { ilConstructor = c + , ilId = textShow (licenseId l) + , ilName = textShow (licenseName l) + , ilIsOsiApproved = licenseOsiApproved l + } licenseIds :: Text licenseIds = T.intercalate "\n" $ flip imap constructorNames $ \i (c, l, vers) -> @@ -108,7 +106,7 @@ mkLicenseList p = mkList [ n | (n, _, vers) <- constructorNames, p vers ] ------------------------------------------------------------------------------- --- Licenses +-- JSON inputs ------------------------------------------------------------------------------- data License = License @@ -119,15 +117,15 @@ } deriving (Show) +newtype LicenseList = LL [License] + deriving (Show) + instance FromJSON License where parseJSON = withObject "License" $ \obj -> License <$> obj .: "licenseId" <*> obj .: "name" <*> obj .: "isOsiApproved" <*> obj .: "isDeprecatedLicenseId" - -newtype LicenseList = LL [License] - deriving (Show) instance FromJSON LicenseList where parseJSON = withObject "License list" $ \obj -> diff --git a/cabal/cabal-dev-scripts/src/GenSPDXExc.hs b/cabal/cabal-dev-scripts/src/GenSPDXExc.hs --- a/cabal/cabal-dev-scripts/src/GenSPDXExc.hs +++ b/cabal/cabal-dev-scripts/src/GenSPDXExc.hs @@ -1,9 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Lens hiding ((.=)) -import Data.Aeson (FromJSON (..), Value, eitherDecode, object, withObject, (.:), (.=)) -import Data.Foldable (for_) +import Control.Lens (imap) +import Data.Aeson (FromJSON (..), eitherDecode, withObject, (.:)) import Data.List (sortOn) import Data.Semigroup ((<>)) import Data.Text (Text) @@ -12,10 +11,8 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Set as Set import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TL import qualified Options.Applicative as O -import qualified Text.Microstache as M +import qualified Zinza as Z import GenUtils @@ -34,7 +31,7 @@ licensesAll = PerV <$> licenses "3.0" <*> licenses "3.2" - <*> licenses "3.5" + <*> licenses "3.6" template = O.strArgument $ mconcat [ O.metavar "SPDX.LicenseExceptionId.template.hs" @@ -54,27 +51,26 @@ generate :: Opts -> IO () generate (Opts tmplFile fns out) = do lss <- for fns $ \fn -> either fail pure . eitherDecode =<< LBS.readFile fn - template <- M.compileMustacheFile tmplFile - let (ws, rendered) = generate' lss template - for_ ws $ putStrLn . M.displayMustacheWarning - TL.writeFile out (header <> "\n" <> rendered) + template <- Z.parseAndCompileTemplateIO tmplFile + output <- generate' lss template + writeFile out (header <> "\n" <> output) putStrLn $ "Generated file " ++ out generate' :: PerV LicenseList - -> M.Template - -> ([M.MustacheWarning], TL.Text) -generate' lss template = M.renderMustacheW template $ object - [ "licenseIds" .= licenseIds - , "licenses" .= licenseValues - , "licenseList_all" .= mkLicenseList (== allVers) - , "licenseList_3_0" .= mkLicenseList + -> (Input -> IO String) + -> IO String +generate' lss template = template $ Input + { inputLicenseIds = licenseIds + , inputLicenses = licenseValues + , inputLicenseList_all = mkLicenseList (== allVers) + , inputLicenseList_3_0 = mkLicenseList (\vers -> vers /= allVers && Set.member SPDXLicenseListVersion_3_0 vers) - , "licenseList_3_2" .= mkLicenseList + , inputLicenseList_3_2 = mkLicenseList (\vers -> vers /= allVers && Set.member SPDXLicenseListVersion_3_2 vers) - , "licenseList_3_6" .= mkLicenseList + , inputLicenseList_3_6 = mkLicenseList (\vers -> vers /= allVers && Set.member SPDXLicenseListVersion_3_6 vers) - ] + } where PerV (LL ls_3_0) (LL ls_3_2) (LL ls_3_6) = lss @@ -88,12 +84,13 @@ filterDeprecated = filter (not . licenseDeprecated) - licenseValues :: [Value] - licenseValues = flip map constructorNames $ \(c, l, _) -> object - [ "licenseCon" .= c - , "licenseId" .= textShow (licenseId l) - , "licenseName" .= textShow (licenseName l) - ] + licenseValues :: [InputLicense] + licenseValues = flip map constructorNames $ \(c, l, _) -> InputLicense + { ilConstructor = c + , ilId = textShow (licenseId l) + , ilName = textShow (licenseName l) + , ilIsOsiApproved = False -- not used in exceptions + } licenseIds :: Text licenseIds = T.intercalate "\n" $ flip imap constructorNames $ \i (c, l, vers) -> @@ -107,10 +104,9 @@ mkLicenseList p = mkList [ n | (n, _, vers) <- constructorNames, p vers ] ------------------------------------------------------------------------------- --- Licenses +-- JSON inputs ------------------------------------------------------------------------------- --- TODO: move to common module, confusing naming. This is LicenseException! data License = License { licenseId :: !Text , licenseName :: !Text diff --git a/cabal/cabal-dev-scripts/src/GenUtils.hs b/cabal/cabal-dev-scripts/src/GenUtils.hs --- a/cabal/cabal-dev-scripts/src/GenUtils.hs +++ b/cabal/cabal-dev-scripts/src/GenUtils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} @@ -5,16 +6,17 @@ {-# LANGUAGE ScopedTypeVariables #-} module GenUtils where -import Control.Lens +import Control.Lens (each, ix, (%~), (&)) import Data.Char (toUpper) import Data.Maybe (fromMaybe) import Data.Text (Text) +import GHC.Generics (Generic) +import qualified Zinza as Z import qualified Data.Algorithm.Diff as Diff import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T -import qualified Data.Text.Lazy as TL ------------------------------------------------------------------------------- -- License List version @@ -59,7 +61,7 @@ -- Commmons ------------------------------------------------------------------------------- -header :: TL.Text +header :: String header = "-- This file is generated. See Makefile's spdx rule" ------------------------------------------------------------------------------- @@ -127,3 +129,33 @@ " [ " <> x <> "\n" <> foldMap (\x' -> " , " <> x' <> "\n") xs <> " ]" + +------------------------------------------------------------------------------- +-- Zinza inputs +------------------------------------------------------------------------------- + +data Input = Input + { inputLicenseIds :: Text + , inputLicenses :: [InputLicense] + , inputLicenseList_all :: Text + , inputLicenseList_3_0 :: Text + , inputLicenseList_3_2 :: Text + , inputLicenseList_3_6 :: Text + } + deriving (Show, Generic) + +instance Z.Zinza Input where + toType = Z.genericToTypeSFP + toValue = Z.genericToValueSFP + +data InputLicense = InputLicense + { ilConstructor :: Text + , ilId :: Text + , ilName :: Text + , ilIsOsiApproved :: Bool + } + deriving (Show, Generic) + +instance Z.Zinza InputLicense where + toType = Z.genericToTypeSFP + toValue = Z.genericToValueSFP diff --git a/cabal/cabal-install/Distribution/Client/CmdBench.hs b/cabal/cabal-install/Distribution/Client/CmdBench.hs --- a/cabal/cabal-install/Distribution/Client/CmdBench.hs +++ b/cabal/cabal-install/Distribution/Client/CmdBench.hs @@ -20,7 +20,7 @@ ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags, TestFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Deprecated.Text @@ -33,7 +33,9 @@ import Control.Monad (when) -benchCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +benchCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) benchCommand = Client.installCommand { commandName = "v2-bench", commandSynopsis = "Run benchmarks", @@ -73,9 +75,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -benchAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +benchAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -benchAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +benchAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand @@ -119,7 +123,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/cabal/cabal-install/Distribution/Client/CmdBuild.hs b/cabal/cabal-install/Distribution/Client/CmdBuild.hs --- a/cabal/cabal-install/Distribution/Client/CmdBuild.hs +++ b/cabal/cabal-install/Distribution/Client/CmdBuild.hs @@ -20,7 +20,7 @@ , liftOptions, yesNoOpt ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags, TestFlags + ( HaddockFlags, TestFlags, BenchmarkFlags , Flag(..), toFlag, fromFlag, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives, option ) @@ -35,7 +35,8 @@ buildCommand :: CommandUI (BuildFlags, ( ConfigFlags, ConfigExFlags - , InstallFlags, HaddockFlags, TestFlags)) + , InstallFlags, HaddockFlags + , TestFlags, BenchmarkFlags )) buildCommand = CommandUI { commandName = "v2-build", commandSynopsis = "Compile targets within the project.", @@ -103,11 +104,13 @@ -- buildAction :: ( BuildFlags - , (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)) + , ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags )) -> [String] -> GlobalFlags -> IO () buildAction ( buildFlags - , (configFlags, configExFlags, installFlags, haddockFlags, testFlags)) + , ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags )) targetStrings globalFlags = do -- TODO: This flags defaults business is ugly let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags @@ -159,7 +162,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/cabal/cabal-install/Distribution/Client/CmdConfigure.hs b/cabal/cabal-install/Distribution/Client/CmdConfigure.hs --- a/cabal/cabal-install/Distribution/Client/CmdConfigure.hs +++ b/cabal/cabal-install/Distribution/Client/CmdConfigure.hs @@ -16,7 +16,7 @@ import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Simple.Setup - ( HaddockFlags, TestFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Verbosity ( normal ) @@ -26,8 +26,9 @@ ( wrapText, notice ) import qualified Distribution.Client.Setup as Client -configureCommand :: CommandUI (ConfigFlags, ConfigExFlags - ,InstallFlags, HaddockFlags, TestFlags) +configureCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) configureCommand = Client.installCommand { commandName = "v2-configure", commandSynopsis = "Add extra project configuration", @@ -78,9 +79,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -configureAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +configureAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -configureAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +configureAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) _extraArgs globalFlags = do --TODO: deal with _extraArgs, since flags with wrong syntax end up there @@ -123,5 +126,5 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags diff --git a/cabal/cabal-install/Distribution/Client/CmdExec.hs b/cabal/cabal-install/Distribution/Client/CmdExec.hs --- a/cabal/cabal-install/Distribution/Client/CmdExec.hs +++ b/cabal/cabal-install/Distribution/Client/CmdExec.hs @@ -76,6 +76,7 @@ import Distribution.Simple.Setup ( HaddockFlags , TestFlags + , BenchmarkFlags , fromFlagOrDefault ) import Distribution.Simple.Utils @@ -92,11 +93,12 @@ import Prelude () import Distribution.Client.Compat.Prelude -import Data.Set (Set) import qualified Data.Set as S import qualified Data.Map as M -execCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +execCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) execCommand = CommandUI { commandName = "v2-exec" , commandSynopsis = "Give a command access to the store." @@ -121,9 +123,11 @@ , commandDefaultFlags = commandDefaultFlags Client.installCommand } -execAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +execAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -execAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +execAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) extraArgs globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand @@ -197,7 +201,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags withOverrides env args program = program { programOverrideEnv = programOverrideEnv program ++ env , programDefaultArgs = programDefaultArgs program ++ args} diff --git a/cabal/cabal-install/Distribution/Client/CmdFreeze.hs b/cabal/cabal-install/Distribution/Client/CmdFreeze.hs --- a/cabal/cabal-install/Distribution/Client/CmdFreeze.hs +++ b/cabal/cabal-install/Distribution/Client/CmdFreeze.hs @@ -33,7 +33,7 @@ import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Simple.Setup - ( HaddockFlags, TestFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Simple.Utils ( die', notice, wrapText ) import Distribution.Verbosity @@ -49,7 +49,9 @@ import qualified Distribution.Client.Setup as Client -freezeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +freezeCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) freezeCommand = Client.installCommand { commandName = "v2-freeze", commandSynopsis = "Freeze dependencies.", @@ -99,9 +101,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -freezeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +freezeAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -freezeAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +freezeAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) extraArgs globalFlags = do unless (null extraArgs) $ @@ -132,7 +136,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags diff --git a/cabal/cabal-install/Distribution/Client/CmdHaddock.hs b/cabal/cabal-install/Distribution/Client/CmdHaddock.hs --- a/cabal/cabal-install/Distribution/Client/CmdHaddock.hs +++ b/cabal/cabal-install/Distribution/Client/CmdHaddock.hs @@ -20,7 +20,7 @@ ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags(..), TestFlags, fromFlagOrDefault ) + ( HaddockFlags(..), TestFlags, BenchmarkFlags(..), fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Verbosity @@ -31,8 +31,9 @@ import Control.Monad (when) -haddockCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags - ,HaddockFlags, TestFlags) +haddockCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) haddockCommand = Client.installCommand { commandName = "v2-haddock", commandSynopsis = "Build Haddock documentation", @@ -69,9 +70,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -haddockAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +haddockAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -haddockAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +haddockAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand @@ -113,7 +116,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags -- | This defines what a 'TargetSelector' means for the @haddock@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/cabal/cabal-install/Distribution/Client/CmdInstall.hs b/cabal/cabal-install/Distribution/Client/CmdInstall.hs --- a/cabal/cabal-install/Distribution/Client/CmdInstall.hs +++ b/cabal/cabal-install/Distribution/Client/CmdInstall.hs @@ -32,7 +32,7 @@ import Distribution.Client.Setup ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..) , configureExOptions, haddockOptions, installOptions, testOptions - , configureOptions, liftOptions ) + , benchmarkOptions, configureOptions, liftOptions ) import Distribution.Solver.Types.ConstraintSource ( ConstraintSource(..) ) import Distribution.Client.Types @@ -87,7 +87,8 @@ import Distribution.Client.InstallSymlink ( OverwritePolicy(..), symlinkBinary ) import Distribution.Simple.Setup - ( Flag(..), HaddockFlags, TestFlags, fromFlagOrDefault, flagToMaybe ) + ( Flag(..), HaddockFlags, TestFlags, BenchmarkFlags + , fromFlagOrDefault, flagToMaybe ) import Distribution.Solver.Types.SourcePackage ( SourcePackage(..) ) import Distribution.Simple.Command @@ -107,7 +108,7 @@ import Distribution.Types.UnitId ( UnitId ) import Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName, mkUnqualComponentName ) + ( UnqualComponentName, unUnqualComponentName ) import Distribution.Verbosity ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils @@ -115,7 +116,7 @@ , withTempDirectory, createDirectoryIfMissingVerbose , ordNub ) import Distribution.Utils.Generic - ( writeFileAtomic ) + ( safeHead, writeFileAtomic ) import Distribution.Deprecated.Text ( simpleParse ) import Distribution.Pretty @@ -142,7 +143,8 @@ installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags - , HaddockFlags, TestFlags, ClientInstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + , ClientInstallFlags ) installCommand = CommandUI { commandName = "v2-install" @@ -194,17 +196,19 @@ . optionName) $ haddockOptions showOrParseArgs) ++ liftOptions get5 set5 (testOptions showOrParseArgs) - ++ liftOptions get6 set6 (clientInstallOptions showOrParseArgs) - , commandDefaultFlags = ( mempty, mempty, mempty, mempty, mempty + ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs) + ++ liftOptions get7 set7 (clientInstallOptions showOrParseArgs) + , commandDefaultFlags = ( mempty, mempty, mempty, mempty, mempty, mempty , defaultClientInstallFlags ) } where - get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f) - get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f) - get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f) - get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f) - get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f) - get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f) + get1 (a,_,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f,g) = (a,b,c,d,e,f,g) + get2 (_,b,_,_,_,_,_) = b; set2 b (a,_,c,d,e,f,g) = (a,b,c,d,e,f,g) + get3 (_,_,c,_,_,_,_) = c; set3 c (a,b,_,d,e,f,g) = (a,b,c,d,e,f,g) + get4 (_,_,_,d,_,_,_) = d; set4 d (a,b,c,_,e,f,g) = (a,b,c,d,e,f,g) + get5 (_,_,_,_,e,_,_) = e; set5 e (a,b,c,d,_,f,g) = (a,b,c,d,e,f,g) + get6 (_,_,_,_,_,f,_) = f; set6 f (a,b,c,d,e,_,g) = (a,b,c,d,e,f,g) + get7 (_,_,_,_,_,_,g) = g; set7 g (a,b,c,d,e,f,_) = (a,b,c,d,e,f,g) -- | The @install@ command actually serves four different needs. It installs: @@ -225,11 +229,13 @@ -- "Distribution.Client.ProjectOrchestration" -- installAction - :: ( ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags + :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags , ClientInstallFlags) -> [String] -> GlobalFlags -> IO () -installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags +installAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags , clientInstallFlags' ) targetStrings globalFlags = do -- We never try to build tests/benchmarks for remote packages. @@ -452,10 +458,14 @@ home <- getHomeDirectory let ProjectConfig { + projectConfigBuildOnly = ProjectConfigBuildOnly { + projectConfigLogsDir + }, projectConfigShared = ProjectConfigShared { projectConfigHcFlavor, projectConfigHcPath, - projectConfigHcPkg + projectConfigHcPkg, + projectConfigStoreDir }, projectConfigLocalPackages = PackageConfig { packageConfigProgramPaths, @@ -468,7 +478,8 @@ hcPath = flagToMaybe projectConfigHcPath hcPkg = flagToMaybe projectConfigHcPkg - progDb = + -- ProgramDb with directly user specified paths + preProgDb = userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) . modifyProgramSearchPath @@ -476,9 +487,10 @@ | dir <- fromNubList packageConfigProgramPathExtra ]) $ defaultProgramDb + -- progDb is a program database with compiler tools configured properly (compiler@Compiler { compilerId = - compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb') <- - configCompilerEx hcFlavor hcPath hcPkg progDb verbosity + compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb) <- + configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity let globalEnv name = @@ -521,13 +533,13 @@ cabalDir <- getCabalDir mstoreDir <- - sequenceA $ makeAbsolute <$> flagToMaybe (globalStoreDir globalFlags) + sequenceA $ makeAbsolute <$> flagToMaybe projectConfigStoreDir let - mlogsDir = flagToMaybe (globalLogsDir globalFlags) + mlogsDir = flagToMaybe projectConfigLogsDir cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir packageDbs = storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId - installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb' + installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb let (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex envEntries @@ -590,14 +602,14 @@ then installLibraries verbosity buildCtx compiler packageDbs progDb envFile envEntries' else installExes verbosity - baseCtx buildCtx platform compiler clientInstallFlags + baseCtx buildCtx platform compiler configFlags clientInstallFlags where configFlags' = disableTestsBenchsByDefault configFlags verbosity = fromFlagOrDefault normal (configVerbosity configFlags') cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags' configExFlags installFlags clientInstallFlags' - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) -- | Install any built exe by symlinking/copying it @@ -608,12 +620,16 @@ -> ProjectBuildContext -> Platform -> Compiler + -> ConfigFlags -> ClientInstallFlags -> IO () installExes verbosity baseCtx buildCtx platform compiler - clientInstallFlags = do + configFlags clientInstallFlags = do let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx + prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags)) + suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags)) + mkUnitBinDir :: UnitId -> FilePath mkUnitBinDir = InstallDirs.bindir . @@ -621,6 +637,9 @@ mkExeName :: UnqualComponentName -> FilePath mkExeName exe = unUnqualComponentName exe <.> exeExtension platform + + mkFinalExeName :: UnqualComponentName -> FilePath + mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform installdirUnknown = "installdir is not defined. Set it in your cabal config file " ++ "or use --installdir=" @@ -633,7 +652,7 @@ doInstall = installUnitExes verbosity overwritePolicy - mkUnitBinDir mkExeName + mkUnitBinDir mkExeName mkFinalExeName installdir installMethod in traverse_ doInstall $ Map.toList $ targetsMap buildCtx where @@ -660,7 +679,8 @@ if supportsPkgEnvFiles $ getImplInfo compiler then do let - getLatest = fmap (head . snd) . take 1 . sortBy (comparing (Down . fst)) + getLatest :: PackageName -> [InstalledPackageInfo] + getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst)) . PI.lookupPackageName installedIndex globalLatest = concat (getLatest <$> globalPackages) @@ -736,13 +756,16 @@ -- ^ store directory -> (UnqualComponentName -> FilePath) -- ^ A function to get an -- ^ exe's filename + -> (UnqualComponentName -> FilePath) -- ^ A function to get an + -- ^ exe's final possibly + -- ^ different to the name in the store. -> FilePath -> InstallMethod -> ( UnitId , [(ComponentTarget, [TargetSelector])] ) -> IO () installUnitExes verbosity overwritePolicy - mkSourceBinDir mkExeName + mkSourceBinDir mkExeName mkFinalExeName installdir installMethod (unit, components) = traverse_ installAndWarn exes @@ -754,6 +777,7 @@ success <- installBuiltExe verbosity overwritePolicy (mkSourceBinDir unit) (mkExeName exe) + (mkFinalExeName exe) installdir installMethod let errorMessage = case overwritePolicy of NeverOverwrite -> @@ -773,21 +797,22 @@ :: Verbosity -> OverwritePolicy -> FilePath -- ^ The directory where the built exe is located -> FilePath -- ^ The exe's filename + -> FilePath -- ^ The exe's filename in the public install directory -> FilePath -- ^ the directory where it should be installed -> InstallMethod -> IO Bool -- ^ Whether the installation was successful installBuiltExe verbosity overwritePolicy - sourceDir exeName + sourceDir exeName finalExeName installdir InstallMethodSymlink = do notice verbosity $ "Symlinking '" <> exeName <> "'" symlinkBinary overwritePolicy installdir sourceDir - (mkUnqualComponentName exeName) + finalExeName exeName installBuiltExe verbosity overwritePolicy - sourceDir exeName + sourceDir exeName finalExeName installdir InstallMethodCopy = do notice verbosity $ "Copying '" <> exeName <> "'" exists <- doesPathExist destination @@ -797,7 +822,7 @@ (False, _ ) -> copy where source = sourceDir exeName - destination = installdir exeName + destination = installdir finalExeName remove = do isDir <- doesDirectoryExist destination if isDir diff --git a/cabal/cabal-install/Distribution/Client/CmdLegacy.hs b/cabal/cabal-install/Distribution/Client/CmdLegacy.hs --- a/cabal/cabal-install/Distribution/Client/CmdLegacy.hs +++ b/cabal/cabal-install/Distribution/Client/CmdLegacy.hs @@ -68,6 +68,9 @@ instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e) where verbosity (a, _, _, _, _) = verbosity a +instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e, f) where + verbosity (a, _, _, _, _, _) = verbosity a + instance HasVerbosity Setup.BuildFlags where verbosity = verbosity . Setup.buildVerbosity @@ -108,22 +111,22 @@ "The v1-" ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++ "It is a legacy feature and will be removed in a future release of cabal-install." ++ - " Please file a bug if you cannot replicate a working v1- use case with the new-style" ++ + " Please file a bug if you cannot replicate a working v1- use case with the nix-style" ++ " commands.\n\n" ++ - "For more information, see: https://wiki.haskell.org/Cabal/NewBuild\n" + "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html" toLegacyCmd :: CommandSpec (globals -> IO action) -> [CommandSpec (globals -> IO action)] toLegacyCmd mkSpec = [toLegacy mkSpec] - where - toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type' - where - legUi = origUi - { commandName = "v1-" ++ commandName - , commandNotes = Just $ \pname -> case commandNotes of - Just notes -> notes pname ++ "\n" ++ legacyNote commandName - Nothing -> legacyNote commandName - } + where + toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type' + where + legUi = origUi + { commandName = "v1-" ++ commandName + , commandNotes = Just $ \pname -> case commandNotes of + Just notes -> notes pname ++ "\n" ++ legacyNote commandName + Nothing -> legacyNote commandName + } legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] legacyCmd ui action = toLegacyCmd (regularCmd ui action) diff --git a/cabal/cabal-install/Distribution/Client/CmdRepl.hs b/cabal/cabal-install/Distribution/Client/CmdRepl.hs --- a/cabal/cabal-install/Distribution/Client/CmdRepl.hs +++ b/cabal/cabal-install/Distribution/Client/CmdRepl.hs @@ -45,7 +45,8 @@ import Distribution.Client.Types ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage ) import Distribution.Simple.Setup - ( HaddockFlags, TestFlags, fromFlagOrDefault, replOptions + ( HaddockFlags, TestFlags, BenchmarkFlags + , fromFlagOrDefault, replOptions , Flag(..), toFlag, trueArg, falseArg ) import Distribution.Simple.Command ( CommandUI(..), liftOption, usageAlternatives, option @@ -90,6 +91,8 @@ ( anyVersion ) import Distribution.Deprecated.Text ( display ) +import Distribution.Utils.Generic + ( safeHead ) import Distribution.Verbosity ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils @@ -143,7 +146,10 @@ ("couldn't parse dependency: " ++) (parsecCommaList parsec) -replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ReplFlags, EnvFlags) +replCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + , ReplFlags, EnvFlags + ) replCommand = Client.installCommand { commandName = "v2-repl", commandSynopsis = "Open an interactive session for the given component.", @@ -181,27 +187,31 @@ ++ "to the default component (or no component if there is no project present)\n" ++ cmdCommonHelpTextNewBuildBeta, - commandDefaultFlags = (configFlags,configExFlags,installFlags,haddockFlags,testFlags,[],defaultEnvFlags), + commandDefaultFlags = ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags + , [], defaultEnvFlags + ), commandOptions = \showOrParseArgs -> map liftOriginal (commandOptions Client.installCommand showOrParseArgs) ++ map liftReplOpts (replOptions showOrParseArgs) ++ map liftEnvOpts (envOptions showOrParseArgs) } where - (configFlags,configExFlags,installFlags,haddockFlags,testFlags) = commandDefaultFlags Client.installCommand + (configFlags,configExFlags,installFlags,haddockFlags,testFlags,benchmarkFlags) + = commandDefaultFlags Client.installCommand liftOriginal = liftOption projectOriginal updateOriginal liftReplOpts = liftOption projectReplOpts updateReplOpts liftEnvOpts = liftOption projectEnvOpts updateEnvOpts - projectOriginal (a,b,c,d,e,_,_) = (a,b,c,d,e) - updateOriginal (a,b,c,d,e) (_,_,_,_,_,f,g) = (a,b,c,d,e,f,g) + projectOriginal (a,b,c,d,e,f,_,_) = (a,b,c,d,e,f) + updateOriginal (a,b,c,d,e,f) (_,_,_,_,_,_,g,h) = (a,b,c,d,e,f,g,h) - projectReplOpts (_,_,_,_,_,f,_) = f - updateReplOpts f (a,b,c,d,e,_,g) = (a,b,c,d,e,f,g) + projectReplOpts (_,_,_,_,_,_,g,_) = g + updateReplOpts g (a,b,c,d,e,f,_,h) = (a,b,c,d,e,f,g,h) - projectEnvOpts (_,_,_,_,_,_,g) = g - updateEnvOpts g (a,b,c,d,e,f,_) = (a,b,c,d,e,f,g) + projectEnvOpts (_,_,_,_,_,_,_,h) = h + updateEnvOpts h (a,b,c,d,e,f,g,_) = (a,b,c,d,e,f,g,h) -- | The @repl@ command is very much like @build@. It brings the install plan -- up to date, selects that part of the plan needed by the given or implicit @@ -214,9 +224,13 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ReplFlags, EnvFlags) +replAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + , ReplFlags, EnvFlags ) -> [String] -> GlobalFlags -> IO () -replAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags, replFlags, envFlags) +replAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags + , replFlags, envFlags ) targetStrings globalFlags = do let ignoreProject = fromFlagOrDefault False (envIgnoreProject envFlags) @@ -244,7 +258,7 @@ targets <- validatedTargets elaboratedPlan targetSelectors let - (unitId, _) = head $ Map.toList targets + Just (unitId, _) = safeHead $ Map.toList targets originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId oci = OriginalComponentInfo unitId originalDeps Just pkgId = packageId <$> InstallPlan.lookup elaboratedPlan unitId @@ -322,7 +336,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) validatedTargets elaboratedPlan targetSelectors = do diff --git a/cabal/cabal-install/Distribution/Client/CmdRun.hs b/cabal/cabal-install/Distribution/Client/CmdRun.hs --- a/cabal/cabal-install/Distribution/Client/CmdRun.hs +++ b/cabal/cabal-install/Distribution/Client/CmdRun.hs @@ -18,7 +18,7 @@ ) where import Prelude () -import Distribution.Client.Compat.Prelude +import Distribution.Client.Compat.Prelude hiding (toList) import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages @@ -29,7 +29,7 @@ ( defaultGlobalFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags, TestFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Types.ComponentName @@ -107,7 +107,9 @@ ( (), isValid, isPathSeparator, takeExtension ) -runCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +runCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) runCommand = Client.installCommand { commandName = "v2-run", commandSynopsis = "Run an executable.", @@ -153,9 +155,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -runAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +runAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -runAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +runAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) targetStrings globalFlags = do globalTmp <- getTemporaryDirectory tempDir <- createTempDirectory globalTmp "cabal-repl." @@ -299,7 +303,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) -- | Used by the main CLI parser as heuristic to decide whether @cabal@ was diff --git a/cabal/cabal-install/Distribution/Client/CmdTest.hs b/cabal/cabal-install/Distribution/Client/CmdTest.hs --- a/cabal/cabal-install/Distribution/Client/CmdTest.hs +++ b/cabal/cabal-install/Distribution/Client/CmdTest.hs @@ -20,7 +20,7 @@ ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags, TestFlags(..), fromFlagOrDefault ) + ( HaddockFlags, TestFlags(..), BenchmarkFlags(..), fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Simple.Flag @@ -36,7 +36,9 @@ import qualified System.Exit (exitSuccess) -testCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +testCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) testCommand = Client.installCommand { commandName = "v2-test" , commandSynopsis = "Run test-suites" @@ -84,9 +86,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -testAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +testAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -testAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +testAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand @@ -131,7 +135,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags -- | This defines what a 'TargetSelector' means for the @test@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/cabal/cabal-install/Distribution/Client/CmdUpdate.hs b/cabal/cabal-install/Distribution/Client/CmdUpdate.hs --- a/cabal/cabal-install/Distribution/Client/CmdUpdate.hs +++ b/cabal/cabal-install/Distribution/Client/CmdUpdate.hs @@ -36,7 +36,7 @@ , UpdateFlags, defaultUpdateFlags , RepoContext(..) ) import Distribution.Simple.Setup - ( HaddockFlags, TestFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Simple.Utils ( die', notice, wrapText, writeFileAtomic, noticeNoWrap ) import Distribution.Verbosity @@ -64,7 +64,9 @@ import qualified Hackage.Security.Client as Sec updateCommand :: CommandUI ( ConfigFlags, ConfigExFlags - , InstallFlags, HaddockFlags, TestFlags ) + , InstallFlags, HaddockFlags + , TestFlags, BenchmarkFlags + ) updateCommand = Client.installCommand { commandName = "v2-update", commandSynopsis = "Updates list of known packages.", @@ -114,9 +116,11 @@ name <- ReadP.manyTill (ReadP.satisfy (\c -> c /= ',')) ReadP.eof return (UpdateRequest name IndexStateHead) -updateAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +updateAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -updateAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +updateAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) extraArgs globalFlags = do projectConfig <- withProjectOrGlobalConfig verbosity globalConfigFlag (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand) @@ -174,7 +178,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState) diff --git a/cabal/cabal-install/Distribution/Client/Compat/FileLock.hsc b/cabal/cabal-install/Distribution/Client/Compat/FileLock.hsc deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/Compat/FileLock.hsc +++ /dev/null @@ -1,201 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE InterruptibleFFI #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE DeriveDataTypeable #-} - --- | This compat module can be removed once base-4.10 (ghc-8.2) is the minimum --- required version. Though note that the locking functionality is not in --- public modules in base-4.10, just in the "GHC.IO.Handle.Lock" module. -module Distribution.Client.Compat.FileLock ( - FileLockingNotSupported(..) - , LockMode(..) - , hLock - , hTryLock - ) where - -#if MIN_VERSION_base(4,10,0) - -import GHC.IO.Handle.Lock - -#else - --- The remainder of this file is a modified copy --- of GHC.IO.Handle.Lock from ghc-8.2.x --- --- The modifications were just to the imports and the CPP, since we do not have --- access to the HAVE_FLOCK from the ./configure script. We approximate the --- lack of HAVE_FLOCK with defined(solaris2_HOST_OS) instead since that is the --- only known major Unix platform lacking flock(). - -import Control.Exception (Exception) -import Data.Typeable - -#if defined(solaris2_HOST_OS) - -import Control.Exception (throwIO) -import System.IO (Handle) - -#else - -import Data.Bits -import Data.Function -import Control.Concurrent.MVar - -import Foreign.C.Error -import Foreign.C.Types - -import GHC.IO.Handle.Types -import GHC.IO.FD -import GHC.IO.Exception - -#if defined(mingw32_HOST_OS) - -#if defined(i386_HOST_ARCH) -## define WINDOWS_CCONV stdcall -#elif defined(x86_64_HOST_ARCH) -## define WINDOWS_CCONV ccall -#else -# error Unknown mingw32 arch -#endif - -#include - -import Foreign.Marshal.Alloc -import Foreign.Marshal.Utils -import Foreign.Ptr -import GHC.Windows - -#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */ - -#include - -#endif /* !defined(mingw32_HOST_OS) */ - -#endif /* !defined(solaris2_HOST_OS) */ - - --- | Exception thrown by 'hLock' on non-Windows platforms that don't support --- 'flock'. -data FileLockingNotSupported = FileLockingNotSupported - deriving (Typeable, Show) - -instance Exception FileLockingNotSupported - - --- | Indicates a mode in which a file should be locked. -data LockMode = SharedLock | ExclusiveLock - --- | If a 'Handle' references a file descriptor, attempt to lock contents of the --- underlying file in appropriate mode. If the file is already locked in --- incompatible mode, this function blocks until the lock is established. The --- lock is automatically released upon closing a 'Handle'. --- --- Things to be aware of: --- --- 1) This function may block inside a C call. If it does, in order to be able --- to interrupt it with asynchronous exceptions and/or for other threads to --- continue working, you MUST use threaded version of the runtime system. --- --- 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise, --- hence all of their caveats also apply here. --- --- 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this --- function throws 'FileLockingNotImplemented'. We deliberately choose to not --- provide fcntl based locking instead because of its broken semantics. --- --- @since 4.10.0.0 -hLock :: Handle -> LockMode -> IO () -hLock h mode = lockImpl h "hLock" mode True >> return () - --- | Non-blocking version of 'hLock'. --- --- @since 4.10.0.0 -hTryLock :: Handle -> LockMode -> IO Bool -hTryLock h mode = lockImpl h "hTryLock" mode False - ----------------------------------------- - -#if defined(solaris2_HOST_OS) - --- | No-op implementation. -lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool -lockImpl _ _ _ _ = throwIO FileLockingNotSupported - -#else /* !defined(solaris2_HOST_OS) */ - -#if defined(mingw32_HOST_OS) - -lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool -lockImpl h ctx mode block = do - FD{fdFD = fd} <- handleToFd h - wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd - allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do - fillBytes ovrlpd (fromIntegral sizeof_OVERLAPPED) 0 - let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY}) - -- We want to lock the whole file without looking up its size to be - -- consistent with what flock does. According to documentation of LockFileEx - -- "locking a region that goes beyond the current end-of-file position is - -- not an error", however e.g. Windows 10 doesn't accept maximum possible - -- value (a pair of MAXDWORDs) for mysterious reasons. Work around that by - -- trying 2^32-1. - fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x0 ovrlpd >>= \case - True -> return True - False -> getLastError >>= \err -> if - | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False - | err == #{const ERROR_OPERATION_ABORTED} -> retry - | otherwise -> failWith ctx err - where - sizeof_OVERLAPPED = #{size OVERLAPPED} - - cmode = case mode of - SharedLock -> 0 - ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK} - --- https://msdn.microsoft.com/en-us/library/aa297958.aspx -foreign import ccall unsafe "_get_osfhandle" - c_get_osfhandle :: CInt -> IO HANDLE - --- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx -foreign import WINDOWS_CCONV interruptible "LockFileEx" - c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL - -#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */ - -lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool -lockImpl h ctx mode block = do - FD{fdFD = fd} <- handleToFd h - let flags = cmode .|. (if block then 0 else #{const LOCK_NB}) - fix $ \retry -> c_flock fd flags >>= \case - 0 -> return True - _ -> getErrno >>= \errno -> if - | not block && errno == eWOULDBLOCK -> return False - | errno == eINTR -> retry - | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing - where - cmode = case mode of - SharedLock -> #{const LOCK_SH} - ExclusiveLock -> #{const LOCK_EX} - -foreign import ccall interruptible "flock" - c_flock :: CInt -> CInt -> IO CInt - -#endif /* !defined(mingw32_HOST_OS) */ - --- | Turn an existing Handle into a file descriptor. This function throws an --- IOError if the Handle does not reference a file descriptor. -handleToFd :: Handle -> IO FD -handleToFd h = case h of - FileHandle _ mv -> do - Handle__{haDevice = dev} <- readMVar mv - case cast dev of - Just fd -> return fd - Nothing -> throwErr "not a file descriptor" - DuplexHandle{} -> throwErr "not a file handle" - where - throwErr msg = ioException $ IOError (Just h) - InappropriateType "handleToFd" msg Nothing Nothing - -#endif /* defined(solaris2_HOST_OS) */ - -#endif /* MIN_VERSION_base */ diff --git a/cabal/cabal-install/Distribution/Client/Config.hs b/cabal/cabal-install/Distribution/Client/Config.hs --- a/cabal/cabal-install/Distribution/Client/Config.hs +++ b/cabal/cabal-install/Distribution/Client/Config.hs @@ -81,6 +81,7 @@ ( ConfigFlags(..), configureOptions, defaultConfigFlags , HaddockFlags(..), haddockOptions, defaultHaddockFlags , TestFlags(..), defaultTestFlags + , BenchmarkFlags(..), defaultBenchmarkFlags , installDirsOptions, optionDistPref , programDbPaths', programDbOptions , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) @@ -171,7 +172,8 @@ savedUploadFlags :: UploadFlags, savedReportFlags :: ReportFlags, savedHaddockFlags :: HaddockFlags, - savedTestFlags :: TestFlags + savedTestFlags :: TestFlags, + savedBenchmarkFlags :: BenchmarkFlags } deriving Generic instance Monoid SavedConfig where @@ -191,7 +193,8 @@ savedUploadFlags = combinedSavedUploadFlags, savedReportFlags = combinedSavedReportFlags, savedHaddockFlags = combinedSavedHaddockFlags, - savedTestFlags = combinedSavedTestFlags + savedTestFlags = combinedSavedTestFlags, + savedBenchmarkFlags = combinedSavedBenchmarkFlags } where -- This is ugly, but necessary. If we're mappending two config files, we @@ -227,7 +230,8 @@ in case b' of [] -> a' _ -> b' - lastNonMempty' :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a + lastNonMempty' + :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a lastNonMempty' field subfield = let a' = subfield . field $ a b' = subfield . field $ b @@ -416,7 +420,8 @@ configFlagError = combine configFlagError, configRelocatable = combine configRelocatable, configUseResponseFiles = combine configUseResponseFiles, - configAllowDependingOnPrivateLibs = combine configAllowDependingOnPrivateLibs + configAllowDependingOnPrivateLibs = + combine configAllowDependingOnPrivateLibs } where combine = combine' savedConfigureFlags @@ -431,8 +436,10 @@ -- TODO: NubListify configPreferences = lastNonEmpty configPreferences, configSolver = combine configSolver, - configAllowNewer = combineMonoid savedConfigureExFlags configAllowNewer, - configAllowOlder = combineMonoid savedConfigureExFlags configAllowOlder, + configAllowNewer = + combineMonoid savedConfigureExFlags configAllowNewer, + configAllowOlder = + combineMonoid savedConfigureExFlags configAllowOlder, configWriteGhcEnvironmentFilesPolicy = combine configWriteGhcEnvironmentFilesPolicy } @@ -511,7 +518,16 @@ combine = combine' savedTestFlags lastNonEmpty = lastNonEmpty' savedTestFlags + combinedSavedBenchmarkFlags = BenchmarkFlags { + benchmarkDistPref = combine benchmarkDistPref, + benchmarkVerbosity = combine benchmarkVerbosity, + benchmarkOptions = lastNonEmpty benchmarkOptions + } + where + combine = combine' savedBenchmarkFlags + lastNonEmpty = lastNonEmpty' savedBenchmarkFlags + -- -- * Default config -- @@ -726,7 +742,8 @@ minp <- readConfigFile mempty configFile case minp of Nothing -> do - notice verbosity $ "Config file path source is " ++ sourceMsg source ++ "." + notice verbosity $ + "Config file path source is " ++ sourceMsg source ++ "." notice verbosity $ "Config file " ++ configFile ++ " not found." createDefaultConfigFile verbosity [] configFile Just (ParseOk ws conf) -> do @@ -766,7 +783,8 @@ getSource ((source,action): xs) = action >>= maybe (getSource xs) (return . (,) source) -readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) +readConfigFile + :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) readConfigFile initial file = handleNotExists $ fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial) (readFile file) @@ -790,7 +808,8 @@ writeConfigFile file comments vals = do let tmpFile = file <.> "tmp" createDirectoryIfMissing True (takeDirectory file) - writeFile tmpFile $ explanation ++ showConfigWithComments comments vals ++ "\n" + writeFile tmpFile $ + explanation ++ showConfigWithComments comments vals ++ "\n" renameFile tmpFile file where explanation = unlines @@ -824,7 +843,7 @@ globalRemoteRepos = toNubList [defaultRemoteRepo] }, savedInitFlags = mempty { - IT.interactive = toFlag True, + IT.interactive = toFlag False, IT.cabalVersion = toFlag (mkVersion [1,10]), IT.language = toFlag Haskell2010, IT.license = toFlag BSD3, @@ -845,7 +864,8 @@ savedUploadFlags = commandDefaultFlags uploadCommand, savedReportFlags = commandDefaultFlags reportCommand, savedHaddockFlags = defaultHaddockFlags, - savedTestFlags = defaultTestFlags + savedTestFlags = defaultTestFlags, + savedBenchmarkFlags = defaultBenchmarkFlags } conf1 <- extendToEffectiveConfig conf0 let globalFlagsConf1 = savedGlobalFlags conf1 @@ -903,7 +923,8 @@ | str == "1" -> ParseOk [] (Flag NormalOptimisation) | str == "2" -> ParseOk [] (Flag MaximumOptimisation) | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation) - | lstr == "true" -> ParseOk [caseWarning] (Flag NormalOptimisation) + | lstr == "true" -> ParseOk [caseWarning] + (Flag NormalOptimisation) | otherwise -> ParseFailed (NoParse name line) where lstr = lowercase str @@ -939,16 +960,20 @@ ++ toSavedConfig liftConfigExFlag (configureExOptions ParseArgs src) [] - [let pkgs = (Just . AllowOlder . RelaxDepsSome) `fmap` parseOptCommaList Text.parse - parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in - simpleField "allow-older" - (showRelaxDeps . fmap unAllowOlder) parseAllowOlder - configAllowOlder (\v flags -> flags { configAllowOlder = v }) - ,let pkgs = (Just . AllowNewer . RelaxDepsSome) `fmap` parseOptCommaList Text.parse - parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in - simpleField "allow-newer" - (showRelaxDeps . fmap unAllowNewer) parseAllowNewer - configAllowNewer (\v flags -> flags { configAllowNewer = v }) + [let pkgs = (Just . AllowOlder . RelaxDepsSome) + `fmap` parseOptCommaList Text.parse + parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) + `fmap` Text.parse) Parse.<++ pkgs + in simpleField "allow-older" + (showRelaxDeps . fmap unAllowOlder) parseAllowOlder + configAllowOlder (\v flags -> flags { configAllowOlder = v }) + ,let pkgs = (Just . AllowNewer . RelaxDepsSome) + `fmap` parseOptCommaList Text.parse + parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) + `fmap` Text.parse) Parse.<++ pkgs + in simpleField "allow-newer" + (showRelaxDeps . fmap unAllowNewer) parseAllowNewer + configAllowNewer (\v flags -> flags { configAllowNewer = v }) ] ++ toSavedConfig liftInstallFlag @@ -1033,8 +1058,10 @@ (fromFlagOrDefault [] . uploadPasswordCmd) (\d cfg -> cfg { uploadPasswordCmd = Flag d }) ] - ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) installDirsFields - ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields + ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) + installDirsFields + ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) + installDirsFields where optional = Parse.option mempty . fmap toFlag modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a @@ -1047,8 +1074,9 @@ liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) -> FieldDescr SavedConfig -liftGlobalInstallDirs = liftField - savedGlobalInstallDirs (\flags conf -> conf { savedGlobalInstallDirs = flags }) +liftGlobalInstallDirs = + liftField savedGlobalInstallDirs + (\flags conf -> conf { savedGlobalInstallDirs = flags }) liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig liftGlobalFlag = liftField @@ -1067,8 +1095,9 @@ savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig -liftClientInstallFlag = liftField - savedClientInstallFlags (\flags conf -> conf { savedClientInstallFlags = flags }) +liftClientInstallFlag = + liftField savedClientInstallFlags + (\flags conf -> conf { savedClientInstallFlags = flags }) liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig liftUploadFlag = liftField @@ -1125,25 +1154,32 @@ isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True isKnownSection _ = False - -- attempt to split fields that can represent lists of paths into actual lists - -- on failure, leave the field untouched + -- Attempt to split fields that can represent lists of paths into + -- actual lists on failure, leave the field untouched. splitMultiPath :: [String] -> [String] splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of ParseOk _ res -> res _ -> [s] splitMultiPath xs = xs - -- This is a fixup, pending a full config parser rewrite, to ensure that - -- config fields which can be comma seperated lists actually parse as comma seperated lists + -- This is a fixup, pending a full config parser rewrite, to + -- ensure that config fields which can be comma-separated lists + -- actually parse as comma-separated lists. fixConfigMultilines conf = conf { savedConfigureFlags = let scf = savedConfigureFlags conf in scf { - configProgramPathExtra = toNubList $ splitMultiPath (fromNubList $ configProgramPathExtra scf) - , configExtraLibDirs = splitMultiPath (configExtraLibDirs scf) - , configExtraFrameworkDirs = splitMultiPath (configExtraFrameworkDirs scf) - , configExtraIncludeDirs = splitMultiPath (configExtraIncludeDirs scf) - , configConfigureArgs = splitMultiPath (configConfigureArgs scf) + configProgramPathExtra = + toNubList $ splitMultiPath + (fromNubList $ configProgramPathExtra scf) + , configExtraLibDirs = splitMultiPath + (configExtraLibDirs scf) + , configExtraFrameworkDirs = splitMultiPath + (configExtraFrameworkDirs scf) + , configExtraIncludeDirs = splitMultiPath + (configExtraIncludeDirs scf) + , configConfigureArgs = splitMultiPath + (configConfigureArgs scf) } } @@ -1222,8 +1258,9 @@ [] -> Disp.text "" (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs $+$ Disp.text "" - $+$ ppFields (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown)) - mcomment vals + $+$ ppFields + (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown)) + mcomment vals $+$ Disp.text "" $+$ ppSection "haddock" "" haddockFlagsFields (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals) @@ -1265,19 +1302,19 @@ remoteRepoFields :: [FieldDescr RemoteRepo] remoteRepoFields = - [ simpleField "url" - (text . show) (parseTokenQ >>= parseURI') - remoteRepoURI (\x repo -> repo { remoteRepoURI = x }) - , simpleField "secure" - showSecure (Just `fmap` Text.parse) - remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x }) - , listField "root-keys" - text parseTokenQ - remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x }) - , simpleField "key-threshold" - showThreshold Text.parse - remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x }) - ] + [ simpleField "url" + (text . show) (parseTokenQ >>= parseURI') + remoteRepoURI (\x repo -> repo { remoteRepoURI = x }) + , simpleField "secure" + showSecure (Just `fmap` Text.parse) + remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x }) + , listField "root-keys" + text parseTokenQ + remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x }) + , simpleField "key-threshold" + showThreshold Text.parse + remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x }) + ] where parseURI' uriString = case parseURI uriString of @@ -1314,12 +1351,13 @@ , name `notElem` exclusions ] where exclusions = - ["author", "email", "quiet", "no-comments", "minimal", "overwrite", - "package-dir", "packagedir", "package-name", "version", "homepage", - "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe", - "simple", "main-is", "expose-module", "exposed-modules", "extension", - "dependency", "build-tool", "with-compiler", - "verbose"] + [ "author", "email", "quiet", "no-comments", "minimal", "overwrite" + , "package-dir", "packagedir", "package-name", "version", "homepage" + , "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe" + , "simple", "main-is", "expose-module", "exposed-modules", "extension" + , "dependency", "build-tool", "with-compiler" + , "verbose" + ] -- | Fields for the 'program-locations' section. withProgramsFields :: [FieldDescr [(String, FilePath)]] @@ -1336,16 +1374,17 @@ parseExtraLines :: Verbosity -> [String] -> IO SavedConfig parseExtraLines verbosity extraLines = - case parseConfig (ConstraintSourceMainConfig "additional lines") - mempty (unlines extraLines) of - ParseFailed err -> - let (line, msg) = locatedErrorMsg err - in die' verbosity $ - "Error parsing additional config lines\n" - ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg - ParseOk [] r -> return r - ParseOk ws _ -> die' verbosity $ - unlines (map (showPWarning "Error parsing additional config lines") ws) + case parseConfig (ConstraintSourceMainConfig "additional lines") + mempty (unlines extraLines) of + ParseFailed err -> + let (line, msg) = locatedErrorMsg err + in die' verbosity $ + "Error parsing additional config lines\n" + ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg + ParseOk [] r -> return r + ParseOk ws _ -> + die' verbosity $ + unlines (map (showPWarning "Error parsing additional config lines") ws) -- | Get the differences (as a pseudo code diff) between the user's -- '~/.cabal/config' and the one that cabal would generate if it didn't exist. @@ -1354,10 +1393,11 @@ userConfig <- loadRawConfig normal (globalConfigFile globalFlags) extraConfig <- parseExtraLines verbosity extraLines testConfig <- initialSavedConfig - return $ reverse . foldl' createDiff [] . M.toList - $ M.unionWith combine - (M.fromList . map justFst $ filterShow testConfig) - (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig)) + return $ + reverse . foldl' createDiff [] . M.toList + $ M.unionWith combine + (M.fromList . map justFst $ filterShow testConfig) + (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig)) where justFst (a, b) = (a, (Just b, Nothing)) justSnd (a, b) = (a, (Nothing, Just b)) @@ -1406,4 +1446,5 @@ notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "." renameFile cabalFile backup notice verbosity $ "Writing merged config to " ++ cabalFile ++ "." - writeConfigFile cabalFile commentConf (newConfig `mappend` userConfig `mappend` extraConfig) + writeConfigFile cabalFile commentConf + (newConfig `mappend` userConfig `mappend` extraConfig) diff --git a/cabal/cabal-install/Distribution/Client/Configure.hs b/cabal/cabal-install/Distribution/Client/Configure.hs --- a/cabal/cabal-install/Distribution/Client/Configure.hs +++ b/cabal/cabal-install/Distribution/Client/Configure.hs @@ -24,6 +24,7 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic (safeHead) import Distribution.Client.Dependency import qualified Distribution.Client.InstallPlan as InstallPlan @@ -85,6 +86,8 @@ import Distribution.Verbosity as Verbosity ( Verbosity ) +import Data.Foldable + ( forM_ ) import System.FilePath ( () ) -- | Choose the Cabal version such that the setup scripts compiled against this @@ -272,12 +275,12 @@ -> ConfigExFlags -> IO () checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do - unless (null unknownConstraints) $ warn verbosity $ - "Constraint refers to an unknown package: " - ++ showConstraint (head unknownConstraints) - unless (null unknownPreferences) $ warn verbosity $ - "Preference refers to an unknown package: " - ++ display (head unknownPreferences) + forM_ (safeHead unknownConstraints) $ \h -> + warn verbosity $ "Constraint refers to an unknown package: " + ++ showConstraint h + forM_ (safeHead unknownPreferences) $ \h -> + warn verbosity $ "Preference refers to an unknown package: " + ++ display h where unknownConstraints = filter (unknown . userConstraintPackageName . fst) $ configExConstraints flags diff --git a/cabal/cabal-install/Distribution/Client/FetchUtils.hs b/cabal/cabal-install/Distribution/Client/FetchUtils.hs --- a/cabal/cabal-install/Distribution/Client/FetchUtils.hs +++ b/cabal/cabal-install/Distribution/Client/FetchUtils.hs @@ -162,7 +162,7 @@ -- | Fetch a repo package if we don't have it already. -- fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath -fetchRepoTarball verbosity repoCtxt repo pkgid = do +fetchRepoTarball verbosity' repoCtxt repo pkgid = do fetched <- doesFileExist (packageFile repo pkgid) if fetched then do info verbosity $ display pkgid ++ " has already been downloaded." @@ -171,9 +171,10 @@ res <- downloadRepoPackage progressMessage verbosity ProgressDownloaded (display pkgid) return res - - where + -- whether we download or not is non-deterministic + verbosity = verboseUnmarkOutput verbosity' + downloadRepoPackage = case repo of RepoLocal{..} -> return (packageFile repo pkgid) diff --git a/cabal/cabal-install/Distribution/Client/GenBounds.hs b/cabal/cabal-install/Distribution/Client/GenBounds.hs --- a/cabal/cabal-install/Distribution/Client/GenBounds.hs +++ b/cabal/cabal-install/Distribution/Client/GenBounds.hs @@ -17,6 +17,7 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic (safeLast) import Distribution.Client.Init ( incVersion ) @@ -59,9 +60,9 @@ -- | Does this version range have an upper bound? hasUpperBound :: VersionRange -> Bool hasUpperBound vr = - case asVersionIntervals vr of - [] -> False - is -> if snd (last is) == NoUpperBound then False else True + case safeLast (asVersionIntervals vr) of + Nothing -> False + Just l -> if snd l == NoUpperBound then False else True -- | Given a version, return an API-compatible (according to PVP) version range. -- diff --git a/cabal/cabal-install/Distribution/Client/Get.hs b/cabal/cabal-install/Distribution/Client/Get.hs --- a/cabal/cabal-install/Distribution/Client/Get.hs +++ b/cabal/cabal-install/Distribution/Client/Get.hs @@ -24,6 +24,7 @@ import Prelude () import Distribution.Client.Compat.Prelude hiding (get) +import Data.Ord (comparing) import Distribution.Compat.Directory ( listDirectory ) import Distribution.Package @@ -38,6 +39,8 @@ import qualified Distribution.PackageDescription as PD import Distribution.Simple.Program ( programName ) +import Distribution.Types.SourceRepo (RepoKind (..)) +import Distribution.Client.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy) import Distribution.Client.Setup ( GlobalFlags(..), GetFlags(..), RepoContext(..) ) @@ -114,7 +117,7 @@ . map (\pkg -> (packageId pkg, packageSourceRepos pkg)) where kind = fromFlag . getSourceRepository $ getFlags - packageSourceRepos :: SourcePackage loc -> [SourceRepo] + packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo] packageSourceRepos = PD.sourceRepos . PD.packageDescription . packageDescription @@ -197,11 +200,11 @@ data ClonePackageException = ClonePackageNoSourceRepos PackageId | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind) - | ClonePackageNoRepoType PackageId SourceRepo - | ClonePackageUnsupportedRepoType PackageId SourceRepo RepoType - | ClonePackageNoRepoLocation PackageId SourceRepo + | ClonePackageNoRepoType PackageId PD.SourceRepo + | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType + | ClonePackageNoRepoLocation PackageId PD.SourceRepo | ClonePackageDestinationExists PackageId FilePath Bool - | ClonePackageFailedWithExitCode PackageId SourceRepo String ExitCode + | ClonePackageFailedWithExitCode PackageId SourceRepoProxy String ExitCode deriving (Show, Eq) instance Exception ClonePackageException where @@ -237,7 +240,7 @@ displayException (ClonePackageFailedWithExitCode pkgid repo vcsprogname exitcode) = "Failed to fetch the source repository for package " ++ display pkgid - ++ maybe "" (", repository location " ++) (PD.repoLocation repo) ++ " (" + ++ ", repository location " ++ srpLocation repo ++ " (" ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")." @@ -248,7 +251,7 @@ clonePackagesFromSourceRepo :: Verbosity -> FilePath -- ^ destination dir prefix -> Maybe RepoKind -- ^ preferred 'RepoKind' - -> [(PackageId, [SourceRepo])] + -> [(PackageId, [PD.SourceRepo])] -- ^ the packages and their -- available 'SourceRepo's -> IO () @@ -268,14 +271,14 @@ [ cloneSourceRepo verbosity vcs' repo destDir `catch` \exitcode -> throwIO (ClonePackageFailedWithExitCode - pkgid repo (programName (vcsProgram vcs)) exitcode) + pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode) | (pkgid, repo, vcs, destDir) <- pkgrepos' , let Just vcs' = Map.lookup (vcsRepoType vcs) vcss ] where - preCloneChecks :: (PackageId, [SourceRepo]) - -> IO (PackageId, SourceRepo, VCS Program, FilePath) + preCloneChecks :: (PackageId, [PD.SourceRepo]) + -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath) preCloneChecks (pkgid, repos) = do repo <- case selectPackageSourceRepo preferredRepoKind repos of Just repo -> return repo @@ -283,13 +286,13 @@ Nothing -> throwIO (ClonePackageNoSourceReposOfKind pkgid preferredRepoKind) - vcs <- case validateSourceRepo repo of - Right (_, _, _, vcs) -> return vcs + (repo', vcs) <- case validatePDSourceRepo repo of + Right (repo', _, _, vcs) -> return (repo', vcs) Left SourceRepoRepoTypeUnspecified -> throwIO (ClonePackageNoRepoType pkgid repo) - Left (SourceRepoRepoTypeUnsupported repoType) -> - throwIO (ClonePackageUnsupportedRepoType pkgid repo repoType) + Left (SourceRepoRepoTypeUnsupported repo' repoType) -> + throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType) Left SourceRepoLocationUnspecified -> throwIO (ClonePackageNoRepoLocation pkgid repo) @@ -300,5 +303,37 @@ when (destDirExists || destFileExists) $ throwIO (ClonePackageDestinationExists pkgid destDir destDirExists) - return (pkgid, repo, vcs, destDir) + return (pkgid, repo', vcs, destDir) +------------------------------------------------------------------------------- +-- Selecting +------------------------------------------------------------------------------- + +-- | Pick the 'SourceRepo' to use to get the package sources from. +-- +-- Note that this does /not/ depend on what 'VCS' drivers we are able to +-- successfully configure. It is based only on the 'SourceRepo's declared +-- in the package, and optionally on a preferred 'RepoKind'. +-- +selectPackageSourceRepo :: Maybe RepoKind + -> [PD.SourceRepo] + -> Maybe PD.SourceRepo +selectPackageSourceRepo preferredRepoKind = + listToMaybe + -- Sort repositories by kind, from This to Head to Unknown. Repositories + -- with equivalent kinds are selected based on the order they appear in + -- the Cabal description file. + . sortBy (comparing thisFirst) + -- If the user has specified the repo kind, filter out the repositories + -- they're not interested in. + . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind) + where + thisFirst :: PD.SourceRepo -> Int + thisFirst r = case PD.repoKind r of + RepoThis -> 0 + RepoHead -> case PD.repoTag r of + -- If the type is 'head' but the author specified a tag, they + -- probably meant to create a 'this' repository but screwed up. + Just _ -> 0 + Nothing -> 1 + RepoKindUnknown _ -> 2 diff --git a/cabal/cabal-install/Distribution/Client/HttpUtils.hs b/cabal/cabal-install/Distribution/Client/HttpUtils.hs --- a/cabal/cabal-install/Distribution/Client/HttpUtils.hs +++ b/cabal/cabal-install/Distribution/Client/HttpUtils.hs @@ -15,7 +15,8 @@ ) where import Prelude () -import Distribution.Client.Compat.Prelude +import Distribution.Client.Compat.Prelude hiding (Proxy (..)) +import Distribution.Utils.Generic import Network.HTTP ( Request (..), Response (..), RequestMethod (..) @@ -38,7 +39,7 @@ import Distribution.Verbosity (Verbosity) import Distribution.Pretty (prettyShow) import Distribution.Simple.Utils - ( die', info, warn, debug, notice, writeFileAtomic + ( die', info, warn, debug, notice , copyFileVerbose, withTempFile ) import Distribution.Client.Utils ( withTempFileName ) @@ -305,8 +306,8 @@ [ (name, transport) | (name, _, _, mkTrans) <- supportedTransports , transport <- maybeToList (mkTrans progdb) ] - -- there's always one because the plain one is last and never fails - let (name, transport) = head availableTransports + let (name, transport) = + fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports) debug verbosity $ "Selected http transport implementation: " ++ name return transport { transportManuallySelected = False } diff --git a/cabal/cabal-install/Distribution/Client/Init.hs b/cabal/cabal-install/Distribution/Client/Init.hs --- a/cabal/cabal-install/Distribution/Client/Init.hs +++ b/cabal/cabal-install/Distribution/Client/Init.hs @@ -37,7 +37,8 @@ ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) import Data.List - ( groupBy, (\\) ) + ( (\\) ) +import qualified Data.List.NonEmpty as NE import Data.Function ( on ) import qualified Data.Map as M @@ -636,25 +637,25 @@ -- do it. grps -> do message flags ("\nWarning: multiple packages found providing " ++ display m - ++ ": " ++ intercalate ", " (map (display . P.pkgName . head) grps)) + ++ ": " ++ intercalate ", " (fmap (display . P.pkgName . NE.head) grps)) message flags "You will need to pick one and manually add it to the Build-depends: field." return Nothing where - pkgGroups = groupBy ((==) `on` P.pkgName) (map P.packageId ps) + pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps) desugar = maybe True (< mkVersion [2]) $ flagToMaybe (cabalVersion flags) -- Given a list of available versions of the same package, pick a dependency. - toDep :: [P.PackageIdentifier] -> IO P.Dependency + toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency -- If only one version, easy. We change e.g. 0.4.2 into 0.4.* - toDep [pid] = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) (Set.singleton LMainLibName) --TODO sublibraries + toDep (pid:|[]) = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) (Set.singleton LMainLibName) --TODO sublibraries -- Otherwise, choose the latest version and issue a warning. toDep pids = do - message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.") - return $ P.Dependency (P.pkgName . head $ pids) - (pvpize desugar . maximum . map P.pkgVersion $ pids) + message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . NE.head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.") + return $ P.Dependency (P.pkgName . NE.head $ pids) + (pvpize desugar . maximum . fmap P.pkgVersion $ pids) (Set.singleton LMainLibName) --TODO take into account sublibraries -- | Given a version, return an API-compatible (according to PVP) version range. @@ -696,8 +697,8 @@ maybePrompt :: InitFlags -> IO t -> IO (Maybe t) maybePrompt flags p = case interactive flags of - Flag False -> return Nothing - _ -> Just `fmap` p + Flag True -> Just `fmap` p + _ -> return Nothing -- | Create a prompt with optional default value that returns a -- String. diff --git a/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs b/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs --- a/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs +++ b/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs @@ -22,6 +22,7 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic (safeHead, safeTail, safeLast) import Distribution.Parsec (simpleParsec) import Distribution.Simple.Setup (Flag(..), flagToMaybe) @@ -86,7 +87,7 @@ -- | Guess the package name based on the given root directory. guessPackageName :: FilePath -> IO P.PackageName -guessPackageName = liftM (P.mkPackageName . repair . last . splitDirectories) +guessPackageName = liftM (P.mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories) . tryCanonicalizePath where -- Treat each span of non-alphanumeric characters as a hyphen. Each @@ -132,7 +133,7 @@ (files, dirs) <- liftM partitionEithers (mapM (tagIsDir dir) entries) let modules = catMaybes [ guessModuleName hierarchy file | file <- files - , isUpper (head file) ] + , maybe False isUpper (safeHead file) ] modules' <- mapM (findImportsAndExts projectRoot) modules recMods <- mapM (scanRecursive dir hierarchy) dirs return $ concat (modules' : recMods) @@ -151,8 +152,8 @@ $ intercalate "." . reverse $ (unqualModName : hierarchy) ext = case takeExtension entry of '.':e -> e; e -> e scanRecursive parent hierarchy entry - | isUpper (head entry) = scan (parent entry) (entry : hierarchy) - | isLower (head entry) && not (ignoreDir entry) = + | maybe False isUpper (safeHead entry) = scan (parent entry) (entry : hierarchy) + | maybe False isLower (safeHead entry) && not (ignoreDir entry) = scanForModulesIn projectRoot $ foldl () srcRoot (reverse (entry : hierarchy)) | otherwise = return [] ignoreDir ('.':_) = True @@ -345,7 +346,7 @@ -- |Get list of categories used in Hackage. NOTE: Very slow, needs to be cached knownCategories :: SourcePackageDb -> [String] knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet - [ cat | pkg <- map head (allPackagesByName sourcePkgIndex) + [ cat | pkg <- maybeToList . safeHead =<< (allPackagesByName sourcePkgIndex) , let catList = (PD.category . PD.packageDescription . packageDescription) pkg , cat <- splitString ',' catList ] @@ -358,7 +359,7 @@ | otherwise = (Flag $ trim nameOrEmail, Flag mail) where (nameOrEmail,erest) = break (== '<') str - (mail,_) = break (== '>') (tail erest) + (mail,_) = break (== '>') (safeTail erest) trim :: String -> String trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse diff --git a/cabal/cabal-install/Distribution/Client/Install.hs b/cabal/cabal-install/Distribution/Client/Install.hs --- a/cabal/cabal-install/Distribution/Client/Install.hs +++ b/cabal/cabal-install/Distribution/Client/Install.hs @@ -31,6 +31,7 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic(safeLast) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map @@ -125,7 +126,7 @@ import Distribution.Simple.Setup ( haddockCommand, HaddockFlags(..) , buildCommand, BuildFlags(..), emptyBuildFlags - , TestFlags + , TestFlags, BenchmarkFlags , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal ( Flag(..) @@ -148,7 +149,7 @@ ( thisPackageVersion ) import Distribution.Types.GivenComponent ( GivenComponent(..) ) -import Distribution.Pretty ( prettyShow ) +import Distribution.Pretty ( prettyShow ) import Distribution.Types.PackageVersionConstraint ( PackageVersionConstraint(..) ) import Distribution.Types.MungedPackageId @@ -206,11 +207,12 @@ -> InstallFlags -> HaddockFlags -> TestFlags + -> BenchmarkFlags -> [UserTarget] -> IO () install verbosity packageDBs repos comp platform progdb useSandbox mSandboxPkgInfo - globalFlags configFlags configExFlags installFlags haddockFlags testFlags - userTargets0 = do + globalFlags configFlags configExFlags installFlags + haddockFlags testFlags benchmarkFlags userTargets0 = do unless (installRootCmd installFlags == Cabal.NoFlag) $ warn verbosity $ "--root-cmd is no longer supported, " @@ -238,7 +240,7 @@ args :: InstallArgs args = (packageDBs, repos, comp, platform, progdb, useSandbox, mSandboxPkgInfo, globalFlags, configFlags, configExFlags, - installFlags, haddockFlags, testFlags) + installFlags, haddockFlags, testFlags, benchmarkFlags) die'' message = die' verbosity (message ++ if isUseSandbox useSandbox then installFailedInSandbox else []) @@ -272,14 +274,15 @@ , ConfigExFlags , InstallFlags , HaddockFlags - , TestFlags ) + , TestFlags + , BenchmarkFlags ) -- | Make an install context given install arguments. makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget] -> IO InstallContext makeInstallContext verbosity (packageDBs, repoCtxt, comp, _, progdb,_,_, - globalFlags, _, configExFlags, installFlags, _, _) mUserTargets = do + globalFlags, _, configExFlags, installFlags, _, _, _) mUserTargets = do let idxState = flagToMaybe (installIndexState installFlags) @@ -318,7 +321,7 @@ makeInstallPlan verbosity (_, _, comp, platform, _, _, mSandboxPkgInfo, _, configFlags, configExFlags, installFlags, - _, _) + _, _, _) (installedPkgIndex, sourcePkgDb, pkgConfigDb, _, pkgSpecifiers, _) = do @@ -334,7 +337,7 @@ -> SolverInstallPlan -> IO () processInstallPlan verbosity - args@(_,_, _, _, _, _, _, _, configFlags, _, installFlags, _, _) + args@(_,_, _, _, _, _, _, _, configFlags, _, installFlags, _, _, _) (installedPkgIndex, sourcePkgDb, _, userTargets, pkgSpecifiers, _) installPlan0 = do @@ -699,11 +702,11 @@ Nothing -> "" where mLatestVersion :: Maybe Version - mLatestVersion = case SourcePackageIndex.lookupPackageName - (packageIndex sourcePkgDb) - (packageName pkg) of - [] -> Nothing - x -> Just $ packageVersion $ last x + mLatestVersion = fmap packageVersion $ + safeLast $ + SourcePackageIndex.lookupPackageName + (packageIndex sourcePkgDb) + (packageName pkg) toFlagAssignment :: [Flag] -> FlagAssignment toFlagAssignment = mkFlagAssignment . map (\ f -> (flagName f, flagDefault f)) @@ -755,7 +758,7 @@ -> IO () reportPlanningFailure verbosity (_, _, comp, platform, _, _, _ - ,_, configFlags, _, installFlags, _, _) + ,_, configFlags, _, installFlags, _, _, _) (_, sourcePkgDb, _, _, pkgSpecifiers, _) message = do @@ -835,7 +838,7 @@ -> IO () postInstallActions verbosity (packageDBs, _, comp, platform, progdb, useSandbox, mSandboxPkgInfo - ,globalFlags, configFlags, _, installFlags, _, _) + ,globalFlags, configFlags, _, installFlags, _, _, _) targets installPlan buildOutcomes = do updateSandboxTimestampsFile verbosity useSandbox mSandboxPkgInfo @@ -1089,7 +1092,8 @@ -> IO BuildOutcomes performInstallations verbosity (packageDBs, repoCtxt, comp, platform, progdb, useSandbox, _, - globalFlags, configFlags, configExFlags, installFlags, haddockFlags, testFlags) + globalFlags, configFlags, configExFlags, installFlags, + haddockFlags, testFlags, _) installedPkgIndex installPlan = do -- With 'install -j' it can be a bit hard to tell whether a sandbox is used. diff --git a/cabal/cabal-install/Distribution/Client/InstallPlan.hs b/cabal/cabal-install/Distribution/Client/InstallPlan.hs --- a/cabal/cabal-install/Distribution/Client/InstallPlan.hs +++ b/cabal/cabal-install/Distribution/Client/InstallPlan.hs @@ -96,7 +96,7 @@ import Data.List ( foldl', intercalate ) -import qualified Data.Foldable as Foldable (all) +import qualified Data.Foldable as Foldable (all, toList) import Data.Maybe ( fromMaybe, mapMaybe ) import qualified Distribution.Compat.Graph as Graph @@ -278,7 +278,7 @@ IsUnit ipkg, IsUnit srcpkg) => Graph (GenericPlanPackage ipkg srcpkg) -> String showPlanGraph graph = renderStyle defaultStyle $ - vcat (map dispPlanPackage (Graph.toList graph)) + vcat (map dispPlanPackage (Foldable.toList graph)) where dispPlanPackage p = hang (hsep [ text (showPlanPackageTag p) , disp (packageId p) @@ -309,7 +309,7 @@ toList :: GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg] -toList = Graph.toList . planGraph +toList = Foldable.toList . planGraph toMap :: GenericInstallPlan ipkg srcpkg -> Map UnitId (GenericPlanPackage ipkg srcpkg) @@ -929,7 +929,7 @@ --TODO: consider re-enabling this one, see SolverInstallPlan -} ++ [ PackageStateInvalid pkg pkg' - | pkg <- Graph.toList graph + | pkg <- Foldable.toList graph , Just pkg' <- map (flip Graph.lookup graph) (nodeNeighbors pkg) , not (stateDependencyRelation pkg pkg') ] diff --git a/cabal/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal/cabal-install/Distribution/Client/InstallSymlink.hs --- a/cabal/cabal-install/Distribution/Client/InstallSymlink.hs +++ b/cabal/cabal-install/Distribution/Client/InstallSymlink.hs @@ -48,7 +48,7 @@ symlinkBinaries _ _ _ _ _ _ _ = return [] symlinkBinary :: OverwritePolicy - -> FilePath -> FilePath -> UnqualComponentName -> String + -> FilePath -> FilePath -> FilePath -> String -> IO Bool symlinkBinary _ _ _ _ _ = fail "Symlinking feature not available on Windows" @@ -154,7 +154,7 @@ ok <- symlinkBinary overwritePolicy publicBinDir privateBinDir - publicExeName privateExeName + (display publicExeName) privateExeName if ok then return Nothing else return (Just (pkgid, publicExeName, @@ -220,7 +220,7 @@ -- @/home/user/bin@ -> FilePath -- ^ The canonical path of the private bin dir eg -- @/home/user/.cabal/bin@ - -> UnqualComponentName -- ^ The name of the executable to go in the public bin + -> FilePath -- ^ The name of the executable to go in the public bin -- dir, eg @foo@ -> String -- ^ The name of the executable to in the private bin -- dir, eg @foo-1.0@ @@ -229,7 +229,7 @@ -- not own. Other errors like permission errors just -- propagate as exceptions. symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do - ok <- targetOkToOverwrite (publicBindir publicName') + ok <- targetOkToOverwrite (publicBindir publicName) (privateBindir privateName) case ok of NotExists -> mkLink >> return True @@ -239,11 +239,10 @@ NeverOverwrite -> return False AlwaysOverwrite -> rmLink >> mkLink >> return True where - publicName' = display publicName relativeBindir = makeRelative publicBindir privateBindir mkLink = createSymbolicLink (relativeBindir privateName) - (publicBindir publicName') - rmLink = removeLink (publicBindir publicName') + (publicBindir publicName) + rmLink = removeLink (publicBindir publicName) -- | Check a file path of a symlink that we would like to create to see if it -- is OK. For it to be OK to overwrite it must either not already exist yet or diff --git a/cabal/cabal-install/Distribution/Client/Outdated.hs b/cabal/cabal-install/Distribution/Client/Outdated.hs --- a/cabal/cabal-install/Distribution/Client/Outdated.hs +++ b/cabal/cabal-install/Distribution/Client/Outdated.hs @@ -26,6 +26,7 @@ import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.PackageIndex import Distribution.Client.Sandbox.PackageEnvironment +import Distribution.Utils.Generic import Distribution.Package (PackageName, packageVersion) import Distribution.PackageDescription (allBuildDepends) @@ -204,7 +205,8 @@ relaxMinor :: VersionRange -> VersionRange relaxMinor vr = let vis = asVersionIntervals vr - (LowerBound v0 _,upper) = last vis - in case upper of - NoUpperBound -> vr - UpperBound _v1 _ -> majorBoundVersion v0 + in maybe vr relax (safeLast vis) + where relax (LowerBound v0 _, upper) = + case upper of + NoUpperBound -> vr + UpperBound _v1 _ -> majorBoundVersion v0 diff --git a/cabal/cabal-install/Distribution/Client/PackageHash.hs b/cabal/cabal-install/Distribution/Client/PackageHash.hs --- a/cabal/cabal-install/Distribution/Client/PackageHash.hs +++ b/cabal/cabal-install/Distribution/Client/PackageHash.hs @@ -60,7 +60,6 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Map as Map import qualified Data.Set as Set -import Data.Set (Set) import Data.Function (on) import Control.Exception (evaluate) diff --git a/cabal/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal/cabal-install/Distribution/Client/ProjectBuilding.hs --- a/cabal/cabal-install/Distribution/Client/ProjectBuilding.hs +++ b/cabal/cabal-install/Distribution/Client/ProjectBuilding.hs @@ -273,7 +273,7 @@ -- -- The packages are visited in dependency order, starting with packages with no -- dependencies. The result for each package is accumulated into a 'Map' and --- returned as the final result. In addition, when visting a package, the +-- returned as the final result. In addition, when visiting a package, the -- visiting function is passed the results for all the immediate package -- dependencies. This can be used to propagate information from dependencies. -- @@ -984,6 +984,12 @@ let prefix = normalise $ dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) entryDir = tmpDirNormalised prefix + + -- if there weren't anything to build, it might be that directory is not created + -- the @setup Cabal.copyCommand@ above might do nothing. + -- https://github.com/haskell/cabal/issues/4130 + createDirectoryIfMissingVerbose verbosity True entryDir + LBS.writeFile (entryDir "cabal-hash.txt") (renderPackageHashInputs (packageHashInputs pkgshared pkg)) diff --git a/cabal/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal/cabal-install/Distribution/Client/ProjectConfig.hs --- a/cabal/cabal-install/Distribution/Client/ProjectConfig.hs +++ b/cabal/cabal-install/Distribution/Client/ProjectConfig.hs @@ -100,7 +100,9 @@ ( runParseResult, PError, PWarning, showPWarning) import Distribution.Pretty () import Distribution.Types.SourceRepo - ( SourceRepo(..), RepoType(..), ) + ( RepoType(..) ) +import Distribution.Client.SourceRepo + ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut ) import Distribution.Simple.Compiler ( Compiler, compilerInfo ) import Distribution.Simple.Program @@ -139,7 +141,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map -import Data.Set (Set) +import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import qualified Data.Hashable as Hashable import Numeric (showHex) @@ -647,7 +649,7 @@ | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file | ProjectPackageLocalTarball FilePath | ProjectPackageRemoteTarball URI - | ProjectPackageRemoteRepo SourceRepo + | ProjectPackageRemoteRepo SourceRepoList | ProjectPackageNamed PackageVersionConstraint deriving Show @@ -1108,7 +1110,7 @@ :: Verbosity -> DistDirLayout -> ProjectConfigShared - -> [SourceRepo] + -> [SourceRepoList] -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] syncAndReadSourcePackagesRemoteRepos verbosity DistDirLayout{distDownloadSrcDirectory} @@ -1123,7 +1125,7 @@ -- All 'SourceRepo's grouped by referring to the "same" remote repo -- instance. So same location but can differ in commit/tag/branch/subdir. let reposByLocation :: Map (RepoType, String) - [(SourceRepo, RepoType)] + [(SourceRepoList, RepoType)] reposByLocation = Map.fromListWith (++) [ ((rtype, rloc), [(repo, vcsRepoType vcs)]) | (repo, rloc, rtype, vcs) <- repos' ] @@ -1143,7 +1145,7 @@ pathStem = distDownloadSrcDirectory localFileNameForRemoteRepo primaryRepo monitor :: FileMonitor - [SourceRepo] + [SourceRepoList] [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] monitor = newFileMonitor (pathStem <.> "cache") ] @@ -1151,7 +1153,7 @@ syncRepoGroupAndReadSourcePackages :: VCS ConfiguredProgram -> FilePath - -> [SourceRepo] + -> [SourceRepoList] -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do liftIO $ createDirectoryIfMissingVerbose verbosity False @@ -1168,24 +1170,33 @@ sequence [ readPackageFromSourceRepo repoWithSubdir repoPath | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths - , repoWithSubdir <- reposWithSubdir ] + , repoWithSubdir <- NE.toList reposWithSubdir ] where -- So to do both things above, we pair them up here. + repoGroupWithPaths + :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)] repoGroupWithPaths = zipWith (\(x, y) z -> (x,y,z)) - (Map.toList - (Map.fromListWith (++) - [ (repo { repoSubdir = Nothing }, [repo]) - | repo <- repoGroup ])) + (mapGroup + [ (repo { srpSubdir = Proxy }, repo) + | repo <- foldMap (NE.toList . srpFanOut) repoGroup + ]) repoPaths + mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)] + mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v)) + -- The repos in a group are given distinct names by simple enumeration -- foo, foo-2, foo-3 etc + repoPaths :: [FilePath] repoPaths = pathStem : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ] + readPackageFromSourceRepo + :: SourceRepositoryPackage Maybe -> FilePath + -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) readPackageFromSourceRepo repo repoPath = do - let packageDir = maybe repoPath (repoPath ) (repoSubdir repo) + let packageDir = maybe repoPath (repoPath ) (srpSubdir repo) entries <- liftIO $ getDirectoryContents packageDir --TODO: wrap exceptions case filter (\e -> takeExtension e == ".cabal") entries of @@ -1201,10 +1212,10 @@ location = RemoteSourceRepoPackage repo packageDir - reportSourceRepoProblems :: [(SourceRepo, SourceRepoProblem)] -> Rebuild a + reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems - renderSourceRepoProblems :: [(SourceRepo, SourceRepoProblem)] -> String + renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems" @@ -1357,10 +1368,9 @@ -- This is deterministic based on the source repo identity details, and -- intended to produce non-clashing file names for different repos. -- -localFileNameForRemoteRepo :: SourceRepo -> FilePath -localFileNameForRemoteRepo SourceRepo{repoType, repoLocation, repoModule} = - maybe "" ((++ "-") . mangleName) repoLocation - ++ showHex locationHash "" +localFileNameForRemoteRepo :: SourceRepoList -> FilePath +localFileNameForRemoteRepo SourceRepositoryPackage {srpType, srpLocation} = + mangleName srpLocation ++ "-" ++ showHex locationHash "" where mangleName = truncateString 10 . dropExtension . takeFileName . dropTrailingPathSeparator @@ -1368,7 +1378,7 @@ -- just the parts that make up the "identity" of the repo locationHash :: Word locationHash = - fromIntegral (Hashable.hash (show repoType, repoLocation, repoModule)) + fromIntegral (Hashable.hash (show srpType, srpLocation)) -- | Truncate a string, with a visual indication that it is truncated. diff --git a/cabal/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs --- a/cabal/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs @@ -29,6 +29,7 @@ import Distribution.Client.Types ( RemoteRepo(..), emptyRemoteRepo , AllowNewer(..), AllowOlder(..) ) +import Distribution.Client.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList) import Distribution.Client.Config ( SavedConfig(..), remoteRepoFields ) @@ -41,9 +42,7 @@ import Distribution.Package import Distribution.PackageDescription - ( SourceRepo(..), RepoKind(..) - , dispFlagAssignment ) -import Distribution.PackageDescription.FieldGrammar (sourceRepoFieldGrammar) + ( dispFlagAssignment ) import Distribution.Simple.Compiler ( OptimisationLevel(..), DebugInfoLevel(..) ) import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) ) @@ -52,6 +51,7 @@ , ConfigFlags(..), configureOptions , HaddockFlags(..), haddockOptions, defaultHaddockFlags , TestFlags(..), testOptions', defaultTestFlags + , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags , programDbPaths', splitArgs ) import Distribution.Client.Setup @@ -89,6 +89,7 @@ ( PackageVersionConstraint ) import qualified Data.Map as Map + ------------------------------------------------------------------ -- Representing the project config file in terms of legacy types -- @@ -105,7 +106,7 @@ data LegacyProjectConfig = LegacyProjectConfig { legacyPackages :: [String], legacyPackagesOptional :: [String], - legacyPackagesRepo :: [SourceRepo], + legacyPackagesRepo :: [SourceRepoList], legacyPackagesNamed :: [PackageVersionConstraint], legacySharedConfig :: LegacySharedConfig, @@ -125,7 +126,8 @@ legacyConfigureFlags :: ConfigFlags, legacyInstallPkgFlags :: InstallFlags, legacyHaddockFlags :: HaddockFlags, - legacyTestFlags :: TestFlags + legacyTestFlags :: TestFlags, + legacyBenchmarkFlags :: BenchmarkFlags } deriving Generic instance Monoid LegacyPackageConfig where @@ -167,15 +169,16 @@ -> InstallFlags -> ClientInstallFlags -> HaddockFlags -> TestFlags + -> BenchmarkFlags -> ProjectConfig commandLineFlagsToProjectConfig globalFlags configFlags configExFlags installFlags clientInstallFlags - haddockFlags testFlags = + haddockFlags testFlags benchmarkFlags = mempty { projectConfigBuildOnly = convertLegacyBuildOnlyFlags globalFlags configFlags installFlags clientInstallFlags - haddockFlags testFlags, + haddockFlags testFlags benchmarkFlags, projectConfigShared = convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags, @@ -184,7 +187,8 @@ } where (localConfig, allConfig) = splitConfig (convertLegacyPerPackageFlags - configFlags installFlags haddockFlags testFlags) + configFlags installFlags + haddockFlags testFlags benchmarkFlags) -- split the package config (from command line arguments) into -- those applied to all packages and those to local only. -- @@ -230,7 +234,8 @@ savedUploadFlags = _, savedReportFlags = _, savedHaddockFlags = haddockFlags, - savedTestFlags = testFlags + savedTestFlags = testFlags, + savedBenchmarkFlags = benchmarkFlags } = mempty { projectConfigBuildOnly = configBuildOnly, @@ -245,16 +250,18 @@ clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags haddockFlags' = defaultHaddockFlags <> haddockFlags testFlags' = defaultTestFlags <> testFlags + benchmarkFlags' = defaultBenchmarkFlags <> benchmarkFlags configAllPackages = convertLegacyPerPackageFlags - configFlags installFlags' haddockFlags' testFlags' + configFlags installFlags' + haddockFlags' testFlags' benchmarkFlags' configShared = convertLegacyAllPackageFlags globalFlags configFlags configExFlags' installFlags' configBuildOnly = convertLegacyBuildOnlyFlags globalFlags configFlags installFlags' clientInstallFlags' - haddockFlags' testFlags' + haddockFlags' testFlags' benchmarkFlags' -- | Convert the project config from the legacy types to the 'ProjectConfig' @@ -273,7 +280,7 @@ clientInstallFlags, legacyAllConfig, legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags - haddockFlags testFlags, + haddockFlags testFlags benchmarkFlags, legacySpecificConfig } = @@ -291,23 +298,25 @@ projectConfigSpecificPackage = fmap perPackage legacySpecificConfig } where - configAllPackages = convertLegacyPerPackageFlags g i h t - where LegacyPackageConfig g i h t = legacyAllConfig + configAllPackages = convertLegacyPerPackageFlags g i h t b + where LegacyPackageConfig g i h t b = legacyAllConfig configLocalPackages = convertLegacyPerPackageFlags configFlags installPerPkgFlags haddockFlags - testFlags + testFlags benchmarkFlags configPackagesShared= convertLegacyAllPackageFlags globalFlags (configFlags <> configShFlags) configExFlags installSharedFlags configBuildOnly = convertLegacyBuildOnlyFlags globalFlags configShFlags installSharedFlags clientInstallFlags - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags - perPkgHaddockFlags perPkgTestFlags) = + perPkgHaddockFlags perPkgTestFlags + perPkgBenchmarkFlags) = convertLegacyPerPackageFlags - perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags perPkgTestFlags + perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags + perPkgTestFlags perPkgBenchmarkFlags -- | Helper used by other conversion functions that returns the @@ -377,8 +386,9 @@ -- 'PackageConfig' subset of the 'ProjectConfig'. -- convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags - -> TestFlags -> PackageConfig -convertLegacyPerPackageFlags configFlags installFlags haddockFlags testFlags = + -> TestFlags -> BenchmarkFlags -> PackageConfig +convertLegacyPerPackageFlags configFlags installFlags + haddockFlags testFlags benchmarkFlags = PackageConfig{..} where ConfigFlags { @@ -453,6 +463,9 @@ testOptions = packageConfigTestTestOptions } = testFlags + BenchmarkFlags { + benchmarkOptions = packageConfigBenchmarkOptions + } = benchmarkFlags -- | Helper used by other conversion functions that returns the @@ -461,10 +474,11 @@ convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags -> InstallFlags -> ClientInstallFlags -> HaddockFlags -> TestFlags + -> BenchmarkFlags -> ProjectConfigBuildOnly convertLegacyBuildOnlyFlags globalFlags configFlags installFlags clientInstallFlags - haddockFlags _ = + haddockFlags _ _ = ProjectConfigBuildOnly{..} where projectConfigClientInstallFlags = clientInstallFlags @@ -629,7 +643,8 @@ legacyConfigureFlags = configFlags, legacyInstallPkgFlags= mempty, legacyHaddockFlags = haddockFlags, - legacyTestFlags = mempty + legacyTestFlags = mempty, + legacyBenchmarkFlags = mempty } where configFlags = ConfigFlags { @@ -700,7 +715,8 @@ legacyConfigureFlags = configFlags, legacyInstallPkgFlags = installFlags, legacyHaddockFlags = haddockFlags, - legacyTestFlags = testFlags + legacyTestFlags = testFlags, + legacyBenchmarkFlags = benchmarkFlags } where configFlags = ConfigFlags { @@ -801,6 +817,11 @@ testOptions = packageConfigTestTestOptions } + benchmarkFlags = BenchmarkFlags { + benchmarkDistPref = mempty, + benchmarkVerbosity = mempty, + benchmarkOptions = packageConfigBenchmarkOptions + } ------------------------------------------------ -- Parsing and showing the project config file @@ -1098,6 +1119,20 @@ , "fail-when-no-test-suites", "test-wrapper" ] . commandOptionsToFields ) (testOptions' ParseArgs) + ++ + ( liftFields + legacyBenchmarkFlags + (\flags conf -> conf { legacyBenchmarkFlags = flags }) + . addFields + [ newLineListField "benchmark-options" + (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) + benchmarkOptions + (\v conf -> conf { benchmarkOptions = v }) + ] + . filterFields + [] + . commandOptionsToFields + ) (benchmarkOptions' ParseArgs) where @@ -1194,7 +1229,7 @@ packageRepoSectionDescr :: FGSectionDescr LegacyProjectConfig packageRepoSectionDescr = FGSectionDescr { fgSectionName = "source-repository-package" - , fgSectionGrammar = sourceRepoFieldGrammar (RepoKindUnknown "unused") + , fgSectionGrammar = sourceRepositoryPackageGrammar , fgSectionGet = map (\x->("", x)) . legacyPackagesRepo , fgSectionSet = \lineno unused pkgrepo projconf -> do @@ -1386,7 +1421,7 @@ -- -- | Parser combinator for simple fields which uses the field type's --- 'Monoid' instance for combining multiple occurences of the field. +-- 'Monoid' instance for combining multiple occurrences of the field. monoidField :: Monoid a => String -> (a -> Doc) -> ReadP a a -> (b -> a) -> (a -> b -> b) -> FieldDescr b monoidField name showF readF get' set = diff --git a/cabal/cabal-install/Distribution/Client/ProjectConfig/Types.hs b/cabal/cabal-install/Distribution/Client/ProjectConfig/Types.hs --- a/cabal/cabal-install/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal/cabal-install/Distribution/Client/ProjectConfig/Types.hs @@ -29,6 +29,7 @@ ( UserConstraint ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) +import Distribution.Client.SourceRepo (SourceRepoList) import Distribution.Client.IndexUtils.Timestamp ( IndexState ) @@ -48,7 +49,7 @@ import Distribution.System ( Platform ) import Distribution.PackageDescription - ( FlagAssignment, SourceRepo(..) ) + ( FlagAssignment ) import Distribution.Simple.Compiler ( Compiler, CompilerFlavor , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) @@ -107,7 +108,7 @@ projectPackagesOptional :: [String], -- | Packages in this project from remote source repositories. - projectPackagesRepo :: [SourceRepo], + projectPackagesRepo :: [SourceRepoList], -- | Packages in this project from hackage repositories. projectPackagesNamed :: [PackageVersionConstraint], @@ -293,7 +294,9 @@ packageConfigTestKeepTix :: Flag Bool, packageConfigTestWrapper :: Flag FilePath, packageConfigTestFailWhenNoTestSuites :: Flag Bool, - packageConfigTestTestOptions :: [PathTemplate] + packageConfigTestTestOptions :: [PathTemplate], + -- Benchmark options + packageConfigBenchmarkOptions :: [PathTemplate] } deriving (Eq, Show, Generic) diff --git a/cabal/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal/cabal-install/Distribution/Client/ProjectOrchestration.hs --- a/cabal/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -159,6 +159,7 @@ , OptimisationLevel(..)) import qualified Data.Monoid as Mon +import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import qualified Data.Map as Map import Data.Either @@ -512,6 +513,7 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem installPlan mPkgDb = fmap mkTargetsMap + . either (Left . toList) Right . checkErrors . map (\ts -> (,) ts <$> checkTarget ts) where @@ -609,12 +611,12 @@ -> [AvailableTarget k] -> Either err [k] selectComponentTargets subtarget = - either (Left . head) Right + either (Left . NE.head) Right . checkErrors . map (selectComponentTarget subtarget) - checkErrors :: [Either e a] -> Either [e] [a] - checkErrors = (\(es, xs) -> if null es then Right xs else Left es) + checkErrors :: [Either e a] -> Either (NonEmpty e) [a] + checkErrors = (\(es, xs) -> case es of { [] -> Right xs; (e:es') -> Left (e:|es') }) . partitionEithers diff --git a/cabal/cabal-install/Distribution/Client/ProjectPlanOutput.hs b/cabal/cabal-install/Distribution/Client/ProjectPlanOutput.hs --- a/cabal/cabal-install/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal/cabal-install/Distribution/Client/ProjectPlanOutput.hs @@ -20,6 +20,7 @@ import Distribution.Client.DistDirLayout import Distribution.Client.Types (Repo(..), RemoteRepo(..), PackageLocation(..), confInstId) import Distribution.Client.PackageHash (showHashValue, hashValue) +import Distribution.Client.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..)) import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.Utils.Json as J @@ -52,7 +53,6 @@ import Distribution.Client.Compat.Prelude import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Builder as BB @@ -212,15 +212,14 @@ , "uri" J..= J.String (show (remoteRepoURI repoRemote)) ] - sourceRepoToJ :: PD.SourceRepo -> J.Value - sourceRepoToJ PD.SourceRepo{..} = + sourceRepoToJ :: SourceRepoMaybe -> J.Value + sourceRepoToJ SourceRepositoryPackage{..} = J.object $ filter ((/= J.Null) . snd) $ - [ "type" J..= fmap jdisplay repoType - , "location" J..= fmap J.String repoLocation - , "module" J..= fmap J.String repoModule - , "branch" J..= fmap J.String repoBranch - , "tag" J..= fmap J.String repoTag - , "subdir" J..= fmap J.String repoSubdir + [ "type" J..= jdisplay srpType + , "location" J..= J.String srpLocation + , "branch" J..= fmap J.String srpBranch + , "tag" J..= fmap J.String srpTag + , "subdir" J..= fmap J.String srpSubdir ] dist_dir = distBuildDirectory distDirLayout diff --git a/cabal/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal/cabal-install/Distribution/Client/ProjectPlanning.hs --- a/cabal/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -160,7 +160,6 @@ import Text.PrettyPrint hiding ((<>)) import qualified Text.PrettyPrint as Disp import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set import Control.Monad import qualified Data.Traversable as T @@ -650,7 +649,12 @@ projectConfigAllPackages projectConfigLocalPackages (getMapMappend projectConfigSpecificPackage) - let instantiatedPlan = instantiateInstallPlan elaboratedPlan + let instantiatedPlan + = instantiateInstallPlan + cabalStoreDirLayout + defaultInstallDirs + elaboratedShared + elaboratedPlan liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) return (instantiatedPlan, elaboratedShared) where @@ -1077,6 +1081,7 @@ -- respective major Cabal version bundled with the respective GHC -- release). -- + -- GHC 8.8 needs Cabal >= 3.0 -- GHC 8.6 needs Cabal >= 2.4 -- GHC 8.4 needs Cabal >= 2.2 -- GHC 8.2 needs Cabal >= 2.0 @@ -1089,11 +1094,8 @@ -- TODO: long-term, this compatibility matrix should be -- stored as a field inside 'Distribution.Compiler.Compiler' setupMinCabalVersionConstraint - | isGHC, compVer >= mkVersion [8,6,1] = mkVersion [2,4] - -- GHC 8.6alpha2 (GHC 8.6.0.20180714) still shipped with a - -- devel snapshot of Cabal-2.3.0.0; the rule below can be - -- dropped at some point - | isGHC, compVer >= mkVersion [8,6] = mkVersion [2,3] + | isGHC, compVer >= mkVersion [8,8] = mkVersion [3,0] + | isGHC, compVer >= mkVersion [8,6] = mkVersion [2,4] | isGHC, compVer >= mkVersion [8,4] = mkVersion [2,2] | isGHC, compVer >= mkVersion [8,2] = mkVersion [2,0] | isGHC, compVer >= mkVersion [8,0] = mkVersion [1,24] @@ -1481,7 +1483,7 @@ -- 5. Construct the final ElaboratedConfiguredPackage let - elab = elab1 { + elab2 = elab1 { elabModuleShape = lc_shape lc, elabUnitId = abstractUnitId (lc_uid lc), elabComponentId = lc_cid lc, @@ -1491,9 +1493,15 @@ compOrderLibDependencies = ordNub (map (abstractUnitId . ci_id) (lc_includes lc ++ lc_sig_includes lc)) - }, - elabInstallDirs = install_dirs cid + } } + elab = elab2 { + elabInstallDirs = computeInstallDirs + storeDirLayout + defaultInstallDirs + elaboratedSharedConfig + elab2 + } -- 6. Construct the updated local maps let cc_map' = extendConfiguredComponentMap cc cc_map @@ -1548,31 +1556,6 @@ | PkgconfigDependency pn _ <- PD.pkgconfigDepends (Cabal.componentBuildInfo comp) ] - install_dirs cid - | shouldBuildInplaceOnly spkg - -- use the ordinary default install dirs - = (InstallDirs.absoluteInstallDirs - pkgid - (newSimpleUnitId cid) - (compilerInfo compiler) - InstallDirs.NoCopyDest - platform - defaultInstallDirs) { - - -- absoluteInstallDirs sets these as 'undefined' but we have - -- to use them as "Setup.hs configure" args - InstallDirs.libsubdir = "", - InstallDirs.libexecsubdir = "", - InstallDirs.datasubdir = "" - } - - | otherwise - -- use special simplified install dirs - = storePackageInstallDirs - storeDirLayout - (compilerId compiler) - cid - inplace_bin_dir elab = binDirectoryFor distDirLayout @@ -1634,14 +1617,20 @@ elab where elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg - elab = elab0 { + elab1 = elab0 { elabUnitId = newSimpleUnitId pkgInstalledId, elabComponentId = pkgInstalledId, elabLinkedInstantiatedWith = Map.empty, - elabInstallDirs = install_dirs, elabPkgOrComp = ElabPackage $ ElaboratedPackage {..}, elabModuleShape = modShape } + elab = elab1 { + elabInstallDirs = + computeInstallDirs storeDirLayout + defaultInstallDirs + elaboratedSharedConfig + elab1 + } modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of Nothing -> emptyModuleShape @@ -1704,31 +1693,6 @@ -- pkgStanzasEnabled is a superset of elabStanzasRequested pkgStanzasEnabled = Map.keysSet (Map.filter (id :: Bool -> Bool) elabStanzasRequested) - install_dirs - | shouldBuildInplaceOnly pkg - -- use the ordinary default install dirs - = (InstallDirs.absoluteInstallDirs - pkgid - (newSimpleUnitId pkgInstalledId) - (compilerInfo compiler) - InstallDirs.NoCopyDest - platform - defaultInstallDirs) { - - -- absoluteInstallDirs sets these as 'undefined' but we have to - -- use them as "Setup.hs configure" args - InstallDirs.libsubdir = "", - InstallDirs.libexecsubdir = "", - InstallDirs.datasubdir = "" - } - - | otherwise - -- use special simplified install dirs - = storePackageInstallDirs - storeDirLayout - (compilerId compiler) - pkgInstalledId - elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc -> ElaboratedConfiguredPackage elaborateSolverToCommon @@ -1887,6 +1851,8 @@ elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions + elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions + perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] @@ -2153,8 +2119,8 @@ getComponentId (InstallPlan.Configured elab) = elabComponentId elab getComponentId (InstallPlan.Installed elab) = elabComponentId elab -instantiateInstallPlan :: ElaboratedInstallPlan -> ElaboratedInstallPlan -instantiateInstallPlan plan = +instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan +instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = InstallPlan.new (IndependentGoals False) (Graph.fromDistinctList (Map.elems ready_map)) where @@ -2182,12 +2148,12 @@ instantiateComponent uid cid insts | Just planpkg <- Map.lookup cid cmap = case planpkg of - InstallPlan.Configured (elab@ElaboratedConfiguredPackage + InstallPlan.Configured (elab0@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) -> do deps <- mapM (substUnitId insts) (compLinkedLibDependencies comp) let getDep (Module dep_uid _) = [dep_uid] - return $ InstallPlan.Configured elab { + elab1 = elab0 { elabUnitId = uid, elabComponentId = cid, elabInstantiatedWith = insts, @@ -2198,7 +2164,14 @@ ordNub (map unDefUnitId (deps ++ concatMap getDep (Map.elems insts))) } - } + } + elab = elab1 { + elabInstallDirs = computeInstallDirs storeDirLayout + defaultInstallDirs + elaboratedShared + elab1 + } + return $ InstallPlan.Configured elab _ -> return planpkg | otherwise = error ("instantiateComponent: " ++ display cid) @@ -3256,6 +3229,38 @@ sysconfdir = prefix "etc" + +computeInstallDirs :: StoreDirLayout + -> InstallDirs.InstallDirTemplates + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> InstallDirs.InstallDirs FilePath +computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab + | elabBuildStyle elab == BuildInplaceOnly + -- use the ordinary default install dirs + = (InstallDirs.absoluteInstallDirs + (elabPkgSourceId elab) + (elabUnitId elab) + (compilerInfo (pkgConfigCompiler elaboratedShared)) + InstallDirs.NoCopyDest + (pkgConfigPlatform elaboratedShared) + defaultInstallDirs) { + + -- absoluteInstallDirs sets these as 'undefined' but we have + -- to use them as "Setup.hs configure" args + InstallDirs.libsubdir = "", + InstallDirs.libexecsubdir = "", + InstallDirs.datasubdir = "" + } + + | otherwise + -- use special simplified install dirs + = storePackageInstallDirs' + storeDirLayout + (compilerId (pkgConfigCompiler elaboratedShared)) + (elabUnitId elab) + + --TODO: [code cleanup] perhaps reorder this code -- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, -- make the various Setup.hs {configure,build,copy} flags @@ -3459,10 +3464,10 @@ -> Verbosity -> FilePath -> Cabal.BenchmarkFlags -setupHsBenchFlags _ _ verbosity builddir = Cabal.BenchmarkFlags +setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.BenchmarkFlags { benchmarkDistPref = toFlag builddir , benchmarkVerbosity = toFlag verbosity - , benchmarkOptions = mempty + , benchmarkOptions = elabBenchmarkOptions } setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String] diff --git a/cabal/cabal-install/Distribution/Client/ProjectPlanning/Types.hs b/cabal/cabal-install/Distribution/Client/ProjectPlanning/Types.hs --- a/cabal/cabal-install/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal/cabal-install/Distribution/Client/ProjectPlanning/Types.hs @@ -297,6 +297,8 @@ elabTestFailWhenNoTestSuites :: Bool, elabTestTestOptions :: [PathTemplate], + elabBenchmarkOptions :: [PathTemplate], + -- Setup.hs related things: -- | One of four modes for how we build and interact with the Setup.hs diff --git a/cabal/cabal-install/Distribution/Client/Sandbox.hs b/cabal/cabal-install/Distribution/Client/Sandbox.hs --- a/cabal/cabal-install/Distribution/Client/Sandbox.hs +++ b/cabal/cabal-install/Distribution/Client/Sandbox.hs @@ -44,6 +44,7 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic(safeLast) import Distribution.Client.Setup ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..) @@ -91,7 +92,7 @@ import Distribution.Simple.PreProcess ( knownSuffixHandlers ) import Distribution.Simple.Program ( ProgramDb ) import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..) - , emptyTestFlags + , emptyTestFlags, emptyBenchmarkFlags , fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.SrcDist ( prepareTree ) import Distribution.Simple.Utils ( die', debug, notice, info, warn @@ -216,10 +217,10 @@ tryGetIndexFilePath' :: Verbosity -> GlobalFlags -> IO FilePath tryGetIndexFilePath' verbosity globalFlags = do let paths = fromNubList $ globalLocalRepos globalFlags - case paths of - [] -> die' verbosity $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ + case safeLast paths of + Nothing -> die' verbosity $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ "no local repos found. " ++ checkConfiguration - _ -> return $ (last paths) Index.defaultIndexFileName + Just lp -> return $ lp Index.defaultIndexFileName where checkConfiguration = "Please check your configuration ('" ++ userPackageEnvironmentFile ++ "')." @@ -685,7 +686,7 @@ ,comp, platform, progdb ,UseSandbox sandboxDir, Just sandboxPkgInfo ,globalFlags, configFlags, configExFlags, installFlags - ,haddockFlags, emptyTestFlags) + ,haddockFlags, emptyTestFlags, emptyBenchmarkFlags) -- This can actually be replaced by a call to 'install', but we use a -- lower-level API because of layer separation reasons. Additionally, we diff --git a/cabal/cabal-install/Distribution/Client/Security/HTTP.hs b/cabal/cabal-install/Distribution/Client/Security/HTTP.hs --- a/cabal/cabal-install/Distribution/Client/Security/HTTP.hs +++ b/cabal/cabal-install/Distribution/Client/Security/HTTP.hs @@ -35,7 +35,6 @@ import Hackage.Security.Client.Repository.HttpLib import Hackage.Security.Util.Checked import Hackage.Security.Util.Pretty -import qualified Hackage.Security.Util.Lens as Lens {------------------------------------------------------------------------------- 'HttpLib' implementation @@ -142,7 +141,14 @@ finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))] insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] - insert x y = Lens.modify (Lens.lookupM x) (++ y) + insert x y = modifyAssocList x (++ y) + + -- modify the first maching element + modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)] + modifyAssocList a f = go where + go [] = [] + go (p@(a', b) : xs) | a == a' = (a', f b) : xs + | otherwise = p : go xs {------------------------------------------------------------------------------- Custom exceptions diff --git a/cabal/cabal-install/Distribution/Client/Setup.hs b/cabal/cabal-install/Distribution/Client/Setup.hs --- a/cabal/cabal-install/Distribution/Client/Setup.hs +++ b/cabal/cabal-install/Distribution/Client/Setup.hs @@ -23,7 +23,7 @@ , configureExCommand, ConfigExFlags(..), defaultConfigExFlags , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) , filterTestFlags - , replCommand, testCommand, benchmarkCommand, testOptions + , replCommand, testCommand, benchmarkCommand, testOptions, benchmarkOptions , configureExOptions, reconfigureCommand , installCommand, InstallFlags(..), installOptions, defaultInstallFlags , filterHaddockArgs, filterHaddockFlags, haddockOptions @@ -101,7 +101,7 @@ import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Setup ( ConfigFlags(..), BuildFlags(..), ReplFlags - , TestFlags, BenchmarkFlags(..) + , TestFlags, BenchmarkFlags , SDistFlags(..), HaddockFlags(..) , CleanFlags(..), DoctestFlags(..) , CopyFlags(..), RegisterFlags(..) @@ -1367,13 +1367,15 @@ -- * Other commands -- ------------------------------------------------------------ -upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +upgradeCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) upgradeCommand = configureCommand { commandName = "upgrade", commandSynopsis = "(command disabled, use install instead)", commandDescription = Nothing, commandUsage = usageFlagsOrPackages "upgrade", - commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty), + commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty), commandOptions = commandOptions installCommand } @@ -1830,7 +1832,9 @@ allSolvers :: String allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver])) -installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) installCommand = CommandUI { commandName = "install", commandSynopsis = "Install packages.", @@ -1883,7 +1887,7 @@ ++ " " ++ (map (const ' ') pname) ++ " " ++ " Change installation destination\n", - commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty), + commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty), commandOptions = \showOrParseArgs -> liftOptions get1 set1 -- Note: [Hidden Flags] @@ -1902,13 +1906,15 @@ installOptions showOrParseArgs) ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) ++ liftOptions get5 set5 (testOptions showOrParseArgs) + ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs) } where - get1 (a,_,_,_,_) = a; set1 a (_,b,c,d,e) = (a,b,c,d,e) - get2 (_,b,_,_,_) = b; set2 b (a,_,c,d,e) = (a,b,c,d,e) - get3 (_,_,c,_,_) = c; set3 c (a,b,_,d,e) = (a,b,c,d,e) - get4 (_,_,_,d,_) = d; set4 d (a,b,c,_,e) = (a,b,c,d,e) - get5 (_,_,_,_,e) = e; set5 e (a,b,c,d,_) = (a,b,c,d,e) + get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f) + get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f) + get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f) + get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f) + get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f) + get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f) haddockCommand :: CommandUI HaddockFlags haddockCommand = Cabal.haddockCommand @@ -1968,6 +1974,19 @@ prefixTest name | "test-" `isPrefixOf` name = name | otherwise = "test-" ++ name +benchmarkOptions :: ShowOrParseArgs -> [OptionField BenchmarkFlags] +benchmarkOptions showOrParseArgs + = [ opt { optionName = prefixBenchmark name, + optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixBenchmark lflags)) descr + | descr <- optionDescr opt] } + | opt <- commandOptions Cabal.benchmarkCommand showOrParseArgs + , let name = optionName opt + , name `elem` ["benchmark-options", "benchmark-option"] + ] + where + prefixBenchmark name | "benchmark-" `isPrefixOf` name = name + | otherwise = "benchmark-" ++ name + fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w @@ -2230,17 +2249,17 @@ initCommand :: CommandUI IT.InitFlags initCommand = CommandUI { commandName = "init", - commandSynopsis = "Create a new .cabal package file (interactively).", + commandSynopsis = "Create a new .cabal package file.", commandDescription = Just $ \_ -> wrapText $ - "Cabalise a project by creating a .cabal, Setup.hs, and " - ++ "optionally a LICENSE file.\n" + "Create a .cabal, Setup.hs, and optionally a LICENSE file.\n" ++ "\n" - ++ "Calling init with no arguments (recommended) uses an " - ++ "interactive mode, which will try to guess as much as " - ++ "possible and prompt you for the rest. Command-line " - ++ "arguments are provided for scripting purposes. " - ++ "If you don't want interactive mode, be sure to pass " - ++ "the -n flag.\n", + ++ "Calling init with no arguments creates an executable, " + ++ "guessing as many options as possible. The interactive " + ++ "mode can be invoked by the -i/--interactive flag, which " + ++ "will try to guess as much as possible and prompt you for " + ++ "the rest. You can change init to always be interactive by " + ++ "setting the interactive flag in your configuration file. " + ++ "Command-line arguments are provided for scripting purposes.\n", commandNotes = Nothing, commandUsage = \pname -> "Usage: " ++ pname ++ " init [FLAGS]\n", diff --git a/cabal/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal/cabal-install/Distribution/Client/SetupWrapper.hs --- a/cabal/cabal-install/Distribution/Client/SetupWrapper.hs +++ b/cabal/cabal-install/Distribution/Client/SetupWrapper.hs @@ -81,6 +81,8 @@ ( Lock, criticalSection ) import Distribution.Simple.Setup ( Flag(..) ) +import Distribution.Utils.Generic + ( safeHead ) import Distribution.Simple.Utils ( die', debug, info, infoNoWrap , cabalVersion, tryFindPackageDesc, comparing @@ -726,7 +728,8 @@ ++ "' requires Cabal library version " ++ display (useCabalVersion options) ++ " but no suitable version is installed." - pkgs -> let ipkginfo = head . snd . bestVersion fst $ pkgs + pkgs -> let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs + err = error "Distribution.Client.installedCabalVersion: empty version list" in return (packageVersion ipkginfo ,Just . IPI.installedComponentId $ ipkginfo, options'') diff --git a/cabal/cabal-install/Distribution/Client/SolverInstallPlan.hs b/cabal/cabal-install/Distribution/Client/SolverInstallPlan.hs --- a/cabal/cabal-install/Distribution/Client/SolverInstallPlan.hs +++ b/cabal/cabal-install/Distribution/Client/SolverInstallPlan.hs @@ -73,6 +73,7 @@ ( fromMaybe, mapMaybe ) import Distribution.Compat.Binary (Binary(..)) import Distribution.Compat.Graph (Graph, IsNode(..)) +import qualified Data.Foldable as Foldable import qualified Data.Graph as OldGraph import qualified Distribution.Compat.Graph as Graph import qualified Data.Map as Map @@ -144,7 +145,7 @@ probs -> Left probs toList :: SolverInstallPlan -> [SolverPlanPackage] -toList = Graph.toList . planIndex +toList = Foldable.toList . planIndex toMap :: SolverInstallPlan -> Map SolverId SolverPlanPackage toMap = Graph.toMap . planIndex @@ -239,7 +240,7 @@ dependencyInconsistencies indepGoals index ] ++ [ PackageStateInvalid pkg pkg' - | pkg <- Graph.toList index + | pkg <- Foldable.toList index , Just pkg' <- map (flip Graph.lookup index) (nodeNeighbors pkg) , not (stateDependencyRelation pkg pkg') ] @@ -316,7 +317,7 @@ setupRoots :: SolverPlanIndex -> [[SolverId]] setupRoots = filter (not . null) . map (CD.setupDeps . resolverPackageLibDeps) - . Graph.toList + . Foldable.toList -- | Given a package index where we assume we want to use all the packages -- (use 'dependencyClosure' if you need to get such a index subset) find out @@ -345,7 +346,7 @@ inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) [ (packageName dep, Map.fromList [(sid,(dep,[packageId pkg]))]) | -- For each package @pkg@ - pkg <- Graph.toList index + pkg <- Foldable.toList index -- Find out which @sid@ @pkg@ depends on , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg) -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@) diff --git a/cabal/cabal-install/Distribution/Client/SourceRepo.hs b/cabal/cabal-install/Distribution/Client/SourceRepo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/SourceRepo.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +module Distribution.Client.SourceRepo where + +import Distribution.Client.Compat.Prelude +import Prelude () +import Distribution.Compat.Lens (Lens, Lens') + +import Distribution.Types.SourceRepo + ( RepoType(..)) +import Distribution.FieldGrammar (FieldGrammar, ParsecFieldGrammar', PrettyFieldGrammar', uniqueField, uniqueFieldAla, optionalFieldAla, monoidalFieldAla) +import Distribution.Parsec.Newtypes (Token (..), FilePathNT (..), alaList', NoCommaFSep (..)) + +-- | @source-repository-package@ definition +-- +data SourceRepositoryPackage f = SourceRepositoryPackage + { srpType :: !RepoType + , srpLocation :: !String + , srpTag :: !(Maybe String) + , srpBranch :: !(Maybe String) + , srpSubdir :: !(f FilePath) + } + deriving (Generic) + +deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f) +deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f) +deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f) +deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f) + +-- | Read from @cabal.project@ +type SourceRepoList = SourceRepositoryPackage [] + +-- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo' +type SourceRepoMaybe = SourceRepositoryPackage Maybe + +-- | 'SourceRepositoryPackage' without subdir. Used in clone errors. Cloning doesn't care about subdirectory. +type SourceRepoProxy = SourceRepositoryPackage Proxy + +srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g +srpHoist nt s = s { srpSubdir = nt (srpSubdir s) } + +srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy +srpToProxy s = s { srpSubdir = Proxy } + +-- | Split single @source-repository-package@ declaration with multiple subdirs, +-- into multiple ones with at most single subdir. +srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe) +srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } = + s { srpSubdir = Nothing } :| [] +srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where + f subdir = s { srpSubdir = Just subdir } + +------------------------------------------------------------------------------- +-- Lens +------------------------------------------------------------------------------- + +srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType +srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s)) +{-# INLINE srpTypeLens #-} + +srpLocationLens :: Lens' (SourceRepositoryPackage f) String +srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s)) +{-# INLINE srpLocationLens #-} + +srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String) +srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s)) +{-# INLINE srpTagLens #-} + +srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String) +srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s)) +{-# INLINE srpBranchLens #-} + +srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath) +srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s)) +{-# INLINE srpSubdirLens #-} + +------------------------------------------------------------------------------- +-- Parser & PPrinter +------------------------------------------------------------------------------- + +sourceRepositoryPackageGrammar + :: (FieldGrammar g, Applicative (g SourceRepoList)) + => g SourceRepoList SourceRepoList +sourceRepositoryPackageGrammar = SourceRepositoryPackage + <$> uniqueField "type" srpTypeLens + <*> uniqueFieldAla "location" Token srpLocationLens + <*> optionalFieldAla "tag" Token srpTagLens + <*> optionalFieldAla "branch" Token srpBranchLens + <*> monoidalFieldAla "subdir" (alaList' NoCommaFSep FilePathNT) srpSubdirLens -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there... +{-# SPECIALIZE sourceRepositoryPackageGrammar :: ParsecFieldGrammar' SourceRepoList #-} +{-# SPECIALIZE sourceRepositoryPackageGrammar :: PrettyFieldGrammar' SourceRepoList #-} diff --git a/cabal/cabal-install/Distribution/Client/SourceRepoParse.hs b/cabal/cabal-install/Distribution/Client/SourceRepoParse.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/SourceRepoParse.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Distribution.Client.SourceRepoParse where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Deprecated.ParseUtils (FieldDescr (..), syntaxError) -import Distribution.FieldGrammar.FieldDescrs (fieldDescrsToList) -import Distribution.PackageDescription.FieldGrammar (sourceRepoFieldGrammar) -import Distribution.Parsec (explicitEitherParsec) -import Distribution.Simple.Utils (fromUTF8BS) -import Distribution.Types.SourceRepo (RepoKind (..), SourceRepo) - -sourceRepoFieldDescrs :: [FieldDescr SourceRepo] -sourceRepoFieldDescrs = - map toDescr . fieldDescrsToList $ sourceRepoFieldGrammar (RepoKindUnknown "unused") - where - toDescr (name, pretty, parse) = FieldDescr - { fieldName = fromUTF8BS name - , fieldGet = pretty - , fieldSet = \lineNo str x -> - either (syntaxError lineNo) return - $ explicitEitherParsec (parse x) str - } diff --git a/cabal/cabal-install/Distribution/Client/Store.hs b/cabal/cabal-install/Distribution/Client/Store.hs --- a/cabal/cabal-install/Distribution/Client/Store.hs +++ b/cabal/cabal-install/Distribution/Client/Store.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-} -- | Management for the installed package store. @@ -23,7 +23,6 @@ import Prelude () import Distribution.Client.Compat.Prelude -import Distribution.Client.Compat.FileLock import Distribution.Client.DistDirLayout import Distribution.Client.RebuildMonad @@ -36,14 +35,21 @@ import Distribution.Verbosity import Distribution.Deprecated.Text -import Data.Set (Set) import qualified Data.Set as Set import Control.Exception import Control.Monad (forM_) import System.FilePath import System.Directory -import System.IO +#ifdef MIN_VERSION_lukko +import Lukko +#else +import System.IO (openFile, IOMode(ReadWriteMode), hClose) +import GHC.IO.Handle.Lock (hLock, hTryLock, LockMode(ExclusiveLock)) +#if MIN_VERSION_base(4,11,0) +import GHC.IO.Handle.Lock (hUnlock) +#endif +#endif -- $concurrency -- @@ -236,6 +242,26 @@ compid unitid action = bracket takeLock releaseLock (\_hnd -> action) where +#ifdef MIN_VERSION_lukko + takeLock + | fileLockingSupported = do + fd <- fdOpen (storeIncomingLock compid unitid) + gotLock <- fdTryLock fd ExclusiveLock + unless gotLock $ do + info verbosity $ "Waiting for file lock on store entry " + ++ display compid display unitid + fdLock fd ExclusiveLock + return fd + + -- if there's no locking, do nothing. Be careful on AIX. + | otherwise = return undefined -- :( + + releaseLock fd + | fileLockingSupported = do + fdUnlock fd + fdClose fd + | otherwise = return () +#else takeLock = do h <- openFile (storeIncomingLock compid unitid) ReadWriteMode -- First try non-blocking, but if we would have to wait then @@ -247,5 +273,5 @@ hLock h ExclusiveLock return h - releaseLock = hClose - + releaseLock h = hUnlock h >> hClose h +#endif diff --git a/cabal/cabal-install/Distribution/Client/Types.hs b/cabal/cabal-install/Distribution/Client/Types.hs --- a/cabal/cabal-install/Distribution/Client/Types.hs +++ b/cabal/cabal-install/Distribution/Client/Types.hs @@ -48,8 +48,8 @@ ( ComponentName(..) ) import Distribution.Types.LibraryName ( LibraryName(..) ) -import Distribution.Types.SourceRepo - ( SourceRepo ) +import Distribution.Client.SourceRepo + ( SourceRepoMaybe ) import Distribution.Solver.Types.PackageIndex ( PackageIndex ) @@ -287,7 +287,7 @@ | RepoTarballPackage Repo PackageId local -- | A package available from a version control system source repository - | RemoteSourceRepoPackage SourceRepo local + | RemoteSourceRepoPackage SourceRepoMaybe local deriving (Show, Functor, Eq, Ord, Generic, Typeable) instance Binary local => Binary (PackageLocation local) diff --git a/cabal/cabal-install/Distribution/Client/VCS.hs b/cabal/cabal-install/Distribution/Client/VCS.hs --- a/cabal/cabal-install/Distribution/Client/VCS.hs +++ b/cabal/cabal-install/Distribution/Client/VCS.hs @@ -1,20 +1,16 @@ -{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-} module Distribution.Client.VCS ( -- * VCS driver type VCS, vcsRepoType, vcsProgram, -- ** Type re-exports - SourceRepo, RepoType, - RepoKind, Program, ConfiguredProgram, - -- * Selecting amongst source repos - selectPackageSourceRepo, - -- * Validating 'SourceRepo's and configuring VCS drivers + validatePDSourceRepo, validateSourceRepo, validateSourceRepos, SourceRepoProblem(..), @@ -38,7 +34,8 @@ import Distribution.Client.Compat.Prelude import Distribution.Types.SourceRepo - ( SourceRepo(..), RepoType(..), RepoKind(..) ) + ( RepoType(..) ) +import Distribution.Client.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy) import Distribution.Client.RebuildMonad ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence ) import Distribution.Verbosity as Verbosity @@ -51,6 +48,7 @@ , emptyProgramDb, requireProgram ) import Distribution.Version ( mkVersion ) +import qualified Distribution.PackageDescription as PD import Control.Monad ( mapM_ ) @@ -58,8 +56,6 @@ ( liftIO ) import qualified Data.Char as Char import qualified Data.Map as Map -import Data.Ord - ( comparing ) import Data.Either ( partitionEithers ) import System.FilePath @@ -80,9 +76,9 @@ -- | The program invocation(s) to get\/clone a repository into a fresh -- local directory. - vcsCloneRepo :: Verbosity + vcsCloneRepo :: forall f. Verbosity -> ConfiguredProgram - -> SourceRepo + -> SourceRepositoryPackage f -> FilePath -- Source URI -> FilePath -- Destination directory -> [ProgramInvocation], @@ -90,9 +86,9 @@ -- | The program invocation(s) to synchronise a whole set of /related/ -- repositories with corresponding local directories. Also returns the -- files that the command depends on, for change monitoring. - vcsSyncRepos :: Verbosity + vcsSyncRepos :: forall f. Verbosity -> ConfiguredProgram - -> [(SourceRepo, FilePath)] + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] } @@ -101,37 +97,8 @@ -- * Selecting repos and drivers -- ------------------------------------------------------------ --- | Pick the 'SourceRepo' to use to get the package sources from. --- --- Note that this does /not/ depend on what 'VCS' drivers we are able to --- successfully configure. It is based only on the 'SourceRepo's declared --- in the package, and optionally on a preferred 'RepoKind'. --- -selectPackageSourceRepo :: Maybe RepoKind - -> [SourceRepo] - -> Maybe SourceRepo -selectPackageSourceRepo preferredRepoKind = - listToMaybe - -- Sort repositories by kind, from This to Head to Unknown. Repositories - -- with equivalent kinds are selected based on the order they appear in - -- the Cabal description file. - . sortBy (comparing thisFirst) - -- If the user has specified the repo kind, filter out the repositories - -- they're not interested in. - . filter (\repo -> maybe True (repoKind repo ==) preferredRepoKind) - where - thisFirst :: SourceRepo -> Int - thisFirst r = case repoKind r of - RepoThis -> 0 - RepoHead -> case repoTag r of - -- If the type is 'head' but the author specified a tag, they - -- probably meant to create a 'this' repository but screwed up. - Just _ -> 0 - Nothing -> 1 - RepoKindUnknown _ -> 2 - data SourceRepoProblem = SourceRepoRepoTypeUnspecified - | SourceRepoRepoTypeUnsupported RepoType + | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType | SourceRepoLocationUnspecified deriving Show @@ -140,25 +107,42 @@ -- -- | It also returns the 'VCS' driver we should use to work with it. -- -validateSourceRepo :: SourceRepo - -> Either SourceRepoProblem - (SourceRepo, String, RepoType, VCS Program) +validateSourceRepo + :: SourceRepositoryPackage f + -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program) validateSourceRepo = \repo -> do - rtype <- repoType repo ?! SourceRepoRepoTypeUnspecified - vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported rtype - uri <- repoLocation repo ?! SourceRepoLocationUnspecified + let rtype = srpType repo + vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype + let uri = srpLocation repo return (repo, uri, rtype, vcs) where a ?! e = maybe (Left e) Right a +validatePDSourceRepo + :: PD.SourceRepo + -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program) +validatePDSourceRepo repo = do + rtype <- PD.repoType repo ?! SourceRepoRepoTypeUnspecified + uri <- PD.repoLocation repo ?! SourceRepoLocationUnspecified + validateSourceRepo SourceRepositoryPackage + { srpType = rtype + , srpLocation = uri + , srpTag = PD.repoTag repo + , srpBranch = PD.repoBranch repo + , srpSubdir = PD.repoSubdir repo + } + where + a ?! e = maybe (Left e) Right a + + -- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return -- things in a convenient form to pass to 'configureVCSs', or to report -- problems. -- -validateSourceRepos :: [SourceRepo] - -> Either [(SourceRepo, SourceRepoProblem)] - [(SourceRepo, String, RepoType, VCS Program)] +validateSourceRepos :: [SourceRepositoryPackage f] + -> Either [(SourceRepositoryPackage f, SourceRepoProblem)] + [(SourceRepositoryPackage f, String, RepoType, VCS Program)] validateSourceRepos rs = case partitionEithers (map validateSourceRepo' rs) of (problems@(_:_), _) -> Left problems @@ -193,17 +177,15 @@ -- -- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first. -- -cloneSourceRepo :: Verbosity - -> VCS ConfiguredProgram - -> SourceRepo -- ^ Must have 'repoLocation' filled. - -> FilePath -- ^ Destination directory - -> IO () -cloneSourceRepo _ _ repo@SourceRepo{ repoLocation = Nothing } _ = - error $ "cloneSourceRepo: precondition violation, missing repoLocation: \"" - ++ show repo ++ "\". Validate using validateSourceRepo first." +cloneSourceRepo + :: Verbosity + -> VCS ConfiguredProgram + -> SourceRepositoryPackage f + -> [Char] + -> IO () cloneSourceRepo verbosity vcs - repo@SourceRepo{ repoLocation = Just srcuri } destdir = + repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir = mapM_ (runProgramInvocation verbosity) invocations where invocations = vcsCloneRepo vcs verbosity @@ -228,7 +210,7 @@ -- syncSourceRepos :: Verbosity -> VCS ConfiguredProgram - -> [(SourceRepo, FilePath)] + -> [(SourceRepositoryPackage f, FilePath)] -> Rebuild () syncSourceRepos verbosity vcs repos = do files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos @@ -260,7 +242,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram - -> SourceRepo + -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation] @@ -274,13 +256,13 @@ = "branch" | otherwise = "get" - tagArgs = case repoTag repo of + tagArgs = case srpTag repo of Nothing -> [] Just tag -> ["-r", "tag:" ++ tag] verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepo, FilePath)] -> IO [MonitorFilePath] + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr" bzrProgram :: Program @@ -306,7 +288,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram - -> SourceRepo + -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation] @@ -319,13 +301,13 @@ cloneCmd | programVersion prog >= Just (mkVersion [2,8]) = "clone" | otherwise = "get" - tagArgs = case repoTag repo of + tagArgs = case srpTag repo of Nothing -> [] Just tag -> ["-t", tag] verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepo, FilePath)] -> IO [MonitorFilePath] + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs" darcsProgram :: Program @@ -351,7 +333,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram - -> SourceRepo + -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation] @@ -361,11 +343,11 @@ ++ [ (programInvocation prog (checkoutArgs tag)) { progInvokeCwd = Just destdir } - | tag <- maybeToList (repoTag repo) ] + | tag <- maybeToList (srpTag repo) ] where cloneArgs = ["clone", srcuri, destdir] ++ branchArgs ++ verboseArg - branchArgs = case repoBranch repo of + branchArgs = case srpBranch repo of Just b -> ["--branch", b] Nothing -> [] checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"] @@ -373,7 +355,7 @@ vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepo, FilePath)] + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _ _ [] = return [] vcsSyncRepos verbosity gitProg @@ -383,10 +365,10 @@ sequence_ [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir) | (repo, localDir) <- secondaryRepos ] - return [ monitorDirectoryExistence dir + return [ monitorDirectoryExistence dir | dir <- (primaryLocalDir : map snd secondaryRepos) ] - vcsSyncRepo verbosity gitProg SourceRepo{..} localDir peer = do + vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do exists <- doesDirectoryExist localDir if exists then git localDir ["fetch"] @@ -404,10 +386,10 @@ Nothing -> [] Just peerLocalDir -> ["--reference", peerLocalDir] ++ verboseArg - where Just loc = repoLocation + where loc = srpLocation checkoutArgs = "checkout" : verboseArg ++ ["--detach", "--force" , checkoutTarget, "--" ] - checkoutTarget = fromMaybe "HEAD" (repoBranch `mplus` repoTag) + checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] gitProgram :: Program @@ -444,7 +426,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram - -> SourceRepo + -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation] @@ -453,17 +435,17 @@ where cloneArgs = ["clone", srcuri, destdir] ++ branchArgs ++ tagArgs ++ verboseArg - branchArgs = case repoBranch repo of + branchArgs = case srpBranch repo of Just b -> ["--branch", b] Nothing -> [] - tagArgs = case repoTag repo of + tagArgs = case srpTag repo of Just t -> ["--rev", t] Nothing -> [] verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepo, FilePath)] + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg" @@ -490,7 +472,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram - -> SourceRepo + -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation] @@ -503,7 +485,7 @@ vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepo, FilePath)] + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn" diff --git a/cabal/cabal-install/Distribution/Deprecated/Text.hs b/cabal/cabal-install/Distribution/Deprecated/Text.hs --- a/cabal/cabal-install/Distribution/Deprecated/Text.hs +++ b/cabal/cabal-install/Distribution/Deprecated/Text.hs @@ -28,7 +28,6 @@ import Distribution.Deprecated.ReadP ((<++)) import qualified Distribution.Deprecated.ReadP as Parse -import Data.Functor.Identity (Identity (..)) import Distribution.Parsec import Distribution.Pretty import qualified Text.PrettyPrint as Disp diff --git a/cabal/cabal-install/Distribution/Deprecated/ViewAsFieldDescr.hs b/cabal/cabal-install/Distribution/Deprecated/ViewAsFieldDescr.hs --- a/cabal/cabal-install/Distribution/Deprecated/ViewAsFieldDescr.hs +++ b/cabal/cabal-install/Distribution/Deprecated/ViewAsFieldDescr.hs @@ -5,6 +5,7 @@ import Distribution.Client.Compat.Prelude hiding (get) import Prelude () +import qualified Data.List.NonEmpty as NE import Distribution.Parsec (parsec) import Distribution.Pretty import Distribution.ReadE (parsecToReadE) @@ -19,10 +20,10 @@ viewAsFieldDescr :: OptionField a -> FieldDescr a viewAsFieldDescr (OptionField _n []) = error "Distribution.command.viewAsFieldDescr: unexpected" -viewAsFieldDescr (OptionField n dd) = FieldDescr n get set +viewAsFieldDescr (OptionField n (d:dd)) = FieldDescr n get set where - optDescr = head $ sortBy cmp dd + optDescr = head $ NE.sortBy cmp (d:|dd) cmp :: OptDescr a -> OptDescr a -> Ordering ReqArg{} `cmp` ReqArg{} = EQ diff --git a/cabal/cabal-install/Distribution/Solver/Modular.hs b/cabal/cabal-install/Distribution/Solver/Modular.hs --- a/cabal/cabal-install/Distribution/Solver/Modular.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular.hs @@ -16,7 +16,7 @@ import Distribution.Solver.Compat.Prelude import qualified Data.Map as M -import Data.Set (Set, isSubsetOf) +import Data.Set (isSubsetOf) import Data.Ord import Distribution.Compat.Graph ( IsNode(..) ) diff --git a/cabal/cabal-install/Distribution/Solver/Modular/IndexConversion.hs b/cabal/cabal-install/Distribution/Solver/Modular/IndexConversion.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/IndexConversion.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/IndexConversion.hs @@ -341,7 +341,7 @@ -- | Convert condition trees to flagged dependencies. Mutually -- recursive with 'convBranch'. See 'convBranch' for an explanation --- of all arguments preceeding the input 'CondTree'. +-- of all arguments preceding the input 'CondTree'. convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo -> Component -> (a -> BuildInfo) -> diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Linking.hs b/cabal/cabal-install/Distribution/Solver/Modular/Linking.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Linking.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Linking.hs @@ -12,7 +12,6 @@ import Control.Monad.State import Data.Function (on) import Data.Map ((!)) -import Data.Set (Set) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Traversable as T @@ -29,7 +28,7 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath -import Distribution.Types.GenericPackageDescription (unFlagName) +import Distribution.Types.Flag (unFlagName) {------------------------------------------------------------------------------- Validation diff --git a/cabal/cabal-install/Distribution/Solver/Types/ComponentDeps.hs b/cabal/cabal-install/Distribution/Solver/Types/ComponentDeps.hs --- a/cabal/cabal-install/Distribution/Solver/Types/ComponentDeps.hs +++ b/cabal/cabal-install/Distribution/Solver/Types/ComponentDeps.hs @@ -38,7 +38,7 @@ import Prelude () import Distribution.Types.UnqualComponentName -import Distribution.Solver.Compat.Prelude hiding (empty,zip) +import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip) import qualified Data.Map as Map import Data.Foldable (fold) diff --git a/cabal/cabal-install/Distribution/Solver/Types/PackageIndex.hs b/cabal/cabal-install/Distribution/Solver/Types/PackageIndex.hs --- a/cabal/cabal-install/Distribution/Solver/Types/PackageIndex.hs +++ b/cabal/cabal-install/Distribution/Solver/Types/PackageIndex.hs @@ -50,7 +50,8 @@ import Control.Exception (assert) import qualified Data.Map as Map -import Data.List (groupBy, isInfixOf) +import Data.List (isInfixOf) +import qualified Data.List.NonEmpty as NE import Distribution.Package ( PackageName, unPackageName, PackageIdentifier(..) @@ -136,9 +137,9 @@ where fixBucket = -- out of groups of duplicates, later ones mask earlier ones -- but Map.fromListWith (++) constructs groups in reverse order - map head + map NE.head -- Eq instance for PackageIdentifier is wrong, so use Ord: - . groupBy (\a b -> EQ == comparing packageId a b) + . NE.groupBy (\a b -> EQ == comparing packageId a b) -- relies on sortBy being a stable sort so we -- can pick consistently among duplicates . sortBy (comparing packageId) diff --git a/cabal/cabal-install/Distribution/Solver/Types/PkgConfigDb.hs b/cabal/cabal-install/Distribution/Solver/Types/PkgConfigDb.hs --- a/cabal/cabal-install/Distribution/Solver/Types/PkgConfigDb.hs +++ b/cabal/cabal-install/Distribution/Solver/Types/PkgConfigDb.hs @@ -31,7 +31,7 @@ import Distribution.Package (PkgconfigName, mkPkgconfigName) import Distribution.Parsec import Distribution.Simple.Program - (ProgramDb, getProgramOutput, pkgConfigProgram, requireProgram) + (ProgramDb, getProgramOutput, pkgConfigProgram, needProgram) import Distribution.Simple.Utils (info) import Distribution.Types.PkgconfigVersion import Distribution.Types.PkgconfigVersionRange @@ -56,24 +56,29 @@ -- information. readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do - (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram progdb - pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] - -- The output of @pkg-config --list-all@ also includes a description - -- for each package, which we do not need. - let pkgNames = map (takeWhile (not . isSpace)) pkgList - pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig - ("--modversion" : pkgNames) - (return . pkgConfigDbFromList . zip pkgNames) pkgVersions - where - -- For when pkg-config invocation fails (possibly because of a - -- too long command line). - ioErrorHandler :: IOException -> IO PkgConfigDb - ioErrorHandler e = do - info verbosity ("Failed to query pkg-config, Cabal will continue" - ++ " without solving for pkg-config constraints: " - ++ show e) - return NoPkgConfigDb + mpkgConfig <- needProgram verbosity pkgConfigProgram progdb + case mpkgConfig of + Nothing -> noPkgConfig "Cannot find pkg-config program" + Just (pkgConfig, _) -> do + pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] + -- The output of @pkg-config --list-all@ also includes a description + -- for each package, which we do not need. + let pkgNames = map (takeWhile (not . isSpace)) pkgList + pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig + ("--modversion" : pkgNames) + (return . pkgConfigDbFromList . zip pkgNames) pkgVersions + where + -- For when pkg-config invocation fails (possibly because of a + -- too long command line). + noPkgConfig extra = do + info verbosity ("Failed to query pkg-config, Cabal will continue" + ++ " without solving for pkg-config constraints: " + ++ extra) + return NoPkgConfigDb + ioErrorHandler :: IOException -> IO PkgConfigDb + ioErrorHandler e = noPkgConfig (show e) + -- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs. pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs @@ -134,10 +139,11 @@ -- > pkg-config --variable pc_path pkg-config -- getDefPath = handle ioErrorHandler $ do - (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram progdb - parseSearchPath <$> - getProgramOutput verbosity pkgConfig - ["--variable", "pc_path", "pkg-config"] + mpkgConfig <- needProgram verbosity pkgConfigProgram progdb + case mpkgConfig of + Nothing -> return [] + Just (pkgConfig, _) -> parseSearchPath <$> + getProgramOutput verbosity pkgConfig ["--variable", "pc_path", "pkg-config"] parseSearchPath str = case lines str of diff --git a/cabal/cabal-install/bootstrap.sh b/cabal/cabal-install/bootstrap.sh --- a/cabal/cabal-install/bootstrap.sh +++ b/cabal/cabal-install/bootstrap.sh @@ -260,14 +260,14 @@ # 0.2.2.* ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?" # 0.0.* -HACKAGE_SECURITY_VER="0.5.3.0"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.((2\.[2-9]|[3-9])|3)" - # >= 0.5.2 && < 0.6 +HACKAGE_SECURITY_VER="0.6.0.0"; HACKAGE_SECURITY_VER_REGEXP="0\.6\." + # >= 0.7.0.0 && < 0.7 TAR_VER="0.5.1.0"; TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.?" # >= 0.5.0.3 && < 0.6 DIGEST_VER="0.0.1.2"; DIGEST_REGEXP="0\.0\.(1\.[2-9]|[2-9]\.?)" # >= 0.0.1.2 && < 0.1 -ZIP_ARCHIVE_VER="0.3.3"; ZIP_ARCHIVE_REGEXP="0\.3\.[3-9]" - # >= 0.3.3 && < 0.4 +LUKKO_VER="0.1.1"; LUKKO_VER_REGEXP="0\.1\.[1-9]" + # >= 0.1.1 && <0.2 HACKAGE_URL="https://hackage.haskell.org/package" @@ -471,7 +471,7 @@ info_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} info_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP} info_pkg "digest" ${DIGEST_VER} ${DIGEST_REGEXP} -info_pkg "zip-archive" ${ZIP_ARCHIVE_VER} ${ZIP_ARCHIVE_REGEXP} +info_pkg "lukko" ${LUKKO_VER} ${LUKKO_REGEXP} info_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \ ${HACKAGE_SECURITY_VER_REGEXP} @@ -509,7 +509,7 @@ do_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} do_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP} do_pkg "digest" ${DIGEST_VER} ${DIGEST_REGEXP} -do_pkg "zip-archive" ${ZIP_ARCHIVE_VER} ${ZIP_ARCHIVE_REGEXP} +do_pkg "lukko" ${LUKKO_VER} ${LUKKO_REGEXP} do_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \ ${HACKAGE_SECURITY_VER_REGEXP} diff --git a/cabal/cabal-install/cabal-install.cabal b/cabal/cabal-install/cabal-install.cabal --- a/cabal/cabal-install/cabal-install.cabal +++ b/cabal/cabal-install/cabal-install.cabal @@ -21,7 +21,6 @@ Build-type: Custom Extra-Source-Files: README.md bash-completion/cabal bootstrap.sh changelog - tests/README.md -- Generated with 'make gen-extra-source-files' -- Do NOT edit this section manually; instead, run the script. @@ -122,6 +121,11 @@ default: False manual: True +Flag lukko + description: Use @lukko@ for file-locking + default: True + manual: True + custom-setup setup-depends: Cabal >= 2.2, @@ -176,7 +180,6 @@ Distribution.Client.CmdSdist Distribution.Client.Compat.Directory Distribution.Client.Compat.ExecutablePath - Distribution.Client.Compat.FileLock Distribution.Client.Compat.FilePerms Distribution.Client.Compat.Prelude Distribution.Client.Compat.Process @@ -239,7 +242,7 @@ Distribution.Client.SetupWrapper Distribution.Client.SolverInstallPlan Distribution.Client.SourceFiles - Distribution.Client.SourceRepoParse + Distribution.Client.SourceRepo Distribution.Client.SrcDist Distribution.Client.Store Distribution.Client.Tar @@ -308,7 +311,7 @@ build-depends: async >= 2.0 && < 2.3, array >= 0.4 && < 0.6, - base >= 4.8 && < 4.13, + base >= 4.8 && < 4.14, base16-bytestring >= 0.1.1 && < 0.2, binary >= 0.7.3 && < 0.9, bytestring >= 0.10.6.0 && < 0.11, @@ -331,8 +334,9 @@ stm >= 2.0 && < 2.6, tar >= 0.5.0.3 && < 0.6, time >= 1.5.0.1 && < 1.10, + transformers >= 0.4.2.0 && < 0.6, zlib >= 0.5.3 && < 0.7, - hackage-security >= 0.5.2.2 && < 0.6, + hackage-security >= 0.6.0.0 && < 0.7, text >= 1.2.3 && < 1.3, parsec >= 3.1.13.0 && < 3.2 @@ -350,6 +354,11 @@ build-depends: Win32 >= 2 && < 3 else build-depends: unix >= 2.5 && < 2.9 + + if flag(lukko) + build-depends: lukko >= 0.1 && <0.2 + else + build-depends: base >= 4.10 if flag(debug-expensive-assertions) cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS diff --git a/cabal/cabal-install/cabal-install.cabal.pp b/cabal/cabal-install/cabal-install.cabal.pp --- a/cabal/cabal-install/cabal-install.cabal.pp +++ b/cabal/cabal-install/cabal-install.cabal.pp @@ -18,7 +18,7 @@ build-depends: async >= 2.0 && < 2.3, array >= 0.4 && < 0.6, - base >= 4.8 && < 4.13, + base >= 4.8 && < 4.14, base16-bytestring >= 0.1.1 && < 0.2, binary >= 0.7.3 && < 0.9, bytestring >= 0.10.6.0 && < 0.11, @@ -41,8 +41,9 @@ stm >= 2.0 && < 2.6, tar >= 0.5.0.3 && < 0.6, time >= 1.5.0.1 && < 1.10, + transformers >= 0.4.2.0 && < 0.6, zlib >= 0.5.3 && < 0.7, - hackage-security >= 0.5.2.2 && < 0.6, + hackage-security >= 0.6.0.0 && < 0.7, text >= 1.2.3 && < 1.3, parsec >= 3.1.13.0 && < 3.2 @@ -60,6 +61,11 @@ build-depends: Win32 >= 2 && < 3 else build-depends: unix >= 2.5 && < 2.9 + + if flag(lukko) + build-depends: lukko >= 0.1 && <0.2 + else + build-depends: base >= 4.10 %enddef %def CABAL_COMPONENTCOMMON default-language: Haskell2010 @@ -105,7 +111,6 @@ Distribution.Client.CmdSdist Distribution.Client.Compat.Directory Distribution.Client.Compat.ExecutablePath - Distribution.Client.Compat.FileLock Distribution.Client.Compat.FilePerms Distribution.Client.Compat.Prelude Distribution.Client.Compat.Process @@ -168,7 +173,7 @@ Distribution.Client.SetupWrapper Distribution.Client.SolverInstallPlan Distribution.Client.SourceFiles - Distribution.Client.SourceRepoParse + Distribution.Client.SourceRepo Distribution.Client.SrcDist Distribution.Client.Store Distribution.Client.Tar @@ -274,7 +279,6 @@ %endif Extra-Source-Files: README.md bash-completion/cabal bootstrap.sh changelog - tests/README.md -- Generated with 'make gen-extra-source-files' -- Do NOT edit this section manually; instead, run the script. @@ -375,6 +379,11 @@ default: False manual: True +Flag lukko + description: Use @lukko@ for file-locking + default: True + manual: True + %if CABAL_FLAG_LIB %else custom-setup @@ -495,7 +504,7 @@ random, tagged, tar, - tasty >= 1.1.0.3 && < 1.2, + tasty >= 1.2.3 && < 1.3, tasty-hunit >= 0.10, tasty-quickcheck, tree-diff, @@ -561,7 +570,7 @@ zlib, network-uri < 2.6.2.0, network, - tasty >= 1.1.0.3 && < 1.2, + tasty >= 1.2.3 && <1.3, tasty-hunit >= 0.10, tasty-quickcheck, tagged, @@ -593,7 +602,7 @@ containers, deepseq, tagged, - tasty >= 1.1.0.3 && < 1.2, + tasty >= 1.2.3 && <1.3, tasty-hunit >= 0.10 ghc-options: -threaded @@ -622,7 +631,7 @@ hashable, random, tagged, - tasty >= 1.1.0.3 && <1.2, + tasty >= 1.2.3 && <1.3, tasty-quickcheck, QuickCheck >= 2.8.2, pretty-show >= 1.6.15 @@ -650,7 +659,7 @@ directory, edit-distance, filepath, - tasty >= 1.1.0.3 && < 1.2, + tasty >= 1.2.3 && <1.3, tasty-hunit >= 0.10, tagged diff --git a/cabal/cabal-install/changelog b/cabal/cabal-install/changelog --- a/cabal/cabal-install/changelog +++ b/cabal/cabal-install/changelog @@ -1,10 +1,15 @@ -*-change-log-*- 3.1.0.0 (current development version) + * `v2-build` (and other `v2-`prefixed commands) now accept the + `--benchmark-option(s)` flags, which pass options to benchmark executables + (analogous to how `--test-option(s)` works). (#6209) -3.0.0.0 TBD - * Parses comma-seperated lists for extra-prog-path, extra-lib-dirs, extra-framework-dirs, +3.0.0.0 Mikhail Glushenkov August 2019 + * Parse comma-separated lists for extra-prog-path, extra-lib-dirs, extra-framework-dirs, and extra-include-dirs as actual lists. (#5420) + * `v2-haddock` fails on `haddock` failures (#5977) + * `v2-run` works when given `File.lhs` literate file. (#6134) * `v2-repl` no longer changes directory to a randomized temporary folder when used outside of a project. (#5544) * `install-method` and `overwrite-policy` in `.cabal/config` now actually work. (#5942) @@ -36,6 +41,7 @@ that make it possible to copy the executable instead of symlinking it * --symlink-bindir no longer controls the symlinking directory of v2-install (installdir controls both symlinking and copying now) + * Default to non-interactive init. * Add --test-wrapper that allows a prebuild script to set the test environment. * Add filterTestFlags: filter test-wrapper for Cabal < 3.0.0. * Cabal now only builds the minimum of a package for `v2-install` (#5754, #6091) @@ -503,7 +509,7 @@ 0.6.2 Duncan Coutts Feb 2009 * The upgrade command has been disabled in this release * The configure and install commands now have consistent behaviour - * Reduce the tendancy to re-install already existing packages + * Reduce the tendency to re-install already existing packages * The --constraint= flag now works for the install command * New --preference= flag for soft constraints / version preferences * Improved bootstrap.sh script, smarter and better error checking diff --git a/cabal/cabal-install/main/Main.hs b/cabal/cabal-install/main/Main.hs --- a/cabal/cabal-install/main/Main.hs +++ b/cabal/cabal-install/main/Main.hs @@ -236,9 +236,9 @@ mainWorker :: [String] -> IO () mainWorker args = do - hasScript <- if not (null args) - then CmdRun.validScript (head args) - else return False + maybeScriptAndArgs <- case args of + [] -> return Nothing + (h:tl) -> (\b -> if b then Just (h:|tl) else Nothing) <$> CmdRun.validScript h topHandler $ case commandsRun (globalCommand commands) commands args of @@ -253,9 +253,8 @@ -> printNumericVersion CommandHelp help -> printCommandHelp help CommandList opts -> printOptionsList opts - CommandErrors errs - | hasScript -> CmdRun.handleShebang (head args) (tail args) - | otherwise -> printErrors errs + CommandErrors errs -> maybe (printErrors errs) go maybeScriptAndArgs where + go (script:|scriptArgs) = CmdRun.handleShebang script scriptArgs CommandReadyToGo action -> do globalFlags' <- updateSandboxConfigFileFlag globalFlags action globalFlags' @@ -554,9 +553,10 @@ either (const onNoPkgDesc) (const onPkgDesc) pkgDesc -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +installAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> Action -installAction (configFlags, _, installFlags, _, _) _ globalFlags +installAction (configFlags, _, installFlags, _, _, _) _ globalFlags | fromFlagOrDefault False (installOnly installFlags) = do let verb = fromFlagOrDefault normal (configVerbosity configFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verb globalFlags @@ -565,10 +565,12 @@ nixShellIfSandboxed verb dist globalFlags config useSandbox $ setupWrapper verb setupOpts Nothing - installCommand (const mempty) (const []) + installCommand (const (mempty, mempty, mempty, mempty, mempty, mempty)) + (const []) installAction - (configFlags, configExFlags, installFlags, haddockFlags, testFlags) + ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) extraArgs globalFlags = do let verb = fromFlagOrDefault normal (configVerbosity configFlags) (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) @@ -607,6 +609,9 @@ testFlags' = Cabal.defaultTestFlags `mappend` savedTestFlags config `mappend` testFlags { testDistPref = toFlag dist } + benchmarkFlags' = Cabal.defaultBenchmarkFlags `mappend` + savedBenchmarkFlags config `mappend` + benchmarkFlags { benchmarkDistPref = toFlag dist } globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAux' configFlags' -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the @@ -643,7 +648,7 @@ comp platform progdb' useSandbox mSandboxPkgInfo globalFlags' configFlags'' configExFlags' - installFlags' haddockFlags' testFlags' + installFlags' haddockFlags' testFlags' benchmarkFlags' targets where @@ -885,9 +890,10 @@ withRepoContext verbosity globalFlags' $ \repoContext -> update verbosity updateFlags repoContext -upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +upgradeAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> Action -upgradeAction (configFlags, _, _, _, _) _ _ = die' verbosity $ +upgradeAction (configFlags, _, _, _, _, _) _ _ = die' verbosity $ "Use the 'cabal install' command instead of 'cabal upgrade'.\n" ++ "You can install the latest version of a package using 'cabal install'. " ++ "The 'cabal upgrade' command has been removed because people found it " diff --git a/cabal/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs --- a/cabal/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal/cabal-install/solver-dsl/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -39,6 +39,7 @@ import Prelude () import Distribution.Solver.Compat.Prelude +import Distribution.Utils.Generic -- base import Control.Arrow (second) @@ -719,13 +720,13 @@ extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList where confPkg :: CI.SolverInstallPlan.SolverPlanPackage -> Maybe (String, Int) - confPkg (CI.SolverInstallPlan.Configured pkg) = Just $ srcPkg pkg + confPkg (CI.SolverInstallPlan.Configured pkg) = srcPkg pkg confPkg _ = Nothing - srcPkg :: SolverPackage UnresolvedPkgLoc -> (String, Int) + srcPkg :: SolverPackage UnresolvedPkgLoc -> Maybe (String, Int) srcPkg cpkg = let C.PackageIdentifier pn ver = packageInfoId (solverPkgSource cpkg) - in (C.unPackageName pn, head (C.versionNumbers ver)) + in (\vn -> (C.unPackageName pn, vn)) <$> safeHead (C.versionNumbers ver) {------------------------------------------------------------------------------- Auxiliary diff --git a/cabal/cabal-install/tests/IntegrationTests2.hs b/cabal/cabal-install/tests/IntegrationTests2.hs --- a/cabal/cabal-install/tests/IntegrationTests2.hs +++ b/cabal/cabal-install/tests/IntegrationTests2.hs @@ -68,6 +68,10 @@ import Data.Proxy (Proxy(..)) import Data.Typeable (Typeable) +#if !MIN_VERSION_directory(1,2,7) +removePathForcibly :: FilePath -> IO () +removePathForcibly = removeDirectoryRecursive +#endif main :: IO () main = @@ -117,7 +121,10 @@ , testGroup "Successful builds" $ [ testCaseSteps "Setup script styles" (testSetupScriptStyles config) , testCase "keep-going" (testBuildKeepGoing config) +#ifndef mingw32_HOST_OS + -- disabled because https://github.com/haskell/cabal/issues/6272 , testCase "local tarball" (testBuildLocalTarball config) +#endif ] , testGroup "Regression tests" $ @@ -1403,7 +1410,7 @@ expectBuildFailed failure1 _ <- expectPackageConfigured plan1 res1 "q-0.1" - -- With keep-going then we should go on to sucessfully build Q + -- With keep-going then we should go on to successfully build Q (plan2, res2) <- executePlan =<< planProject testdir (config `mappend` keepGoing True) (_, failure2) <- expectPackageFailed plan2 res2 "p-0.1" @@ -1579,7 +1586,7 @@ cleanProject :: FilePath -> IO () cleanProject testdir = do alreadyExists <- doesDirectoryExist distDir - when alreadyExists $ removeDirectoryRecursive distDir + when alreadyExists $ removePathForcibly distDir where projectRoot = ProjectRootImplicit (basedir testdir) distDirLayout = defaultDistDirLayout projectRoot Nothing diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Get.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Get.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Get.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Get.hs @@ -5,7 +5,8 @@ import Distribution.Types.PackageId import Distribution.Types.PackageName -import Distribution.Types.SourceRepo +import Distribution.Types.SourceRepo (SourceRepo (..), emptySourceRepo, RepoKind (..), RepoType (..)) +import Distribution.Client.SourceRepo (SourceRepositoryPackage (..)) import Distribution.Verbosity as Verbosity import Distribution.Version @@ -92,12 +93,20 @@ testUnsupportedRepoType = do e <- assertException $ clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos - e @?= ClonePackageUnsupportedRepoType pkgidfoo repo repotype + e @?= ClonePackageUnsupportedRepoType pkgidfoo repo' repotype where pkgrepos = [(pkgidfoo, [repo])] - repo = (emptySourceRepo RepoHead) { - repoType = Just repotype + repo = (emptySourceRepo RepoHead) + { repoType = Just repotype + , repoLocation = Just "loc" } + repo' = SourceRepositoryPackage + { srpType = repotype + , srpLocation = "loc" + , srpTag = Nothing + , srpBranch = Nothing + , srpSubdir = Proxy + } repotype = OtherRepoType "baz" @@ -169,10 +178,17 @@ repoType = Just Git, repoLocation = Just srcdir } + repo' = SourceRepositoryPackage + { srpType = Git + , srpLocation = srcdir + , srpTag = Nothing + , srpBranch = Nothing + , srpSubdir = Proxy + } pkgrepos = [(pkgidfoo, [repo])] e1 <- assertException $ clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos - e1 @?= ClonePackageFailedWithExitCode pkgidfoo repo "git" (ExitFailure 128) + e1 @?= ClonePackageFailedWithExitCode pkgidfoo repo' "git" (ExitFailure 128) testNetworkGitClone :: Assertion diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module UnitTests.Distribution.Client.ProjectConfig (tests) where @@ -16,7 +17,7 @@ import qualified Distribution.Deprecated.ReadP as Parse import Distribution.Package -import Distribution.PackageDescription hiding (Flag) +import Distribution.PackageDescription hiding (Flag, SourceRepo) import Distribution.Compiler import Distribution.Version import Distribution.Simple.Compiler @@ -33,6 +34,7 @@ import Distribution.Client.Dependency.Types import Distribution.Client.BuildReports.Types import Distribution.Client.Targets +import Distribution.Client.SourceRepo import Distribution.Utils.NubList import Network.URI @@ -173,7 +175,7 @@ prop_roundtrip_printparse_packages :: [PackageLocationString] -> [PackageLocationString] - -> [SourceRepo] + -> [SourceRepoList] -> [PackageVersionConstraint] -> Property prop_roundtrip_printparse_packages pkglocstrs1 pkglocstrs2 repos named = @@ -603,6 +605,7 @@ <*> arbitraryFlag arbitraryShortToken <*> arbitrary <*> shortListOf 5 arbitrary + <*> shortListOf 5 arbitrary where arbitraryProgramName :: Gen String arbitraryProgramName = @@ -662,7 +665,8 @@ , packageConfigTestKeepTix = x47 , packageConfigTestWrapper = x48 , packageConfigTestFailWhenNoTestSuites = x49 - , packageConfigTestTestOptions = x51 } = + , packageConfigTestTestOptions = x51 + , packageConfigBenchmarkOptions = x52 } = [ PackageConfig { packageConfigProgramPaths = postShrink_Paths x00' , packageConfigProgramArgs = postShrink_Args x01' , packageConfigProgramPathExtra = x02' @@ -716,7 +720,8 @@ , packageConfigTestKeepTix = x47' , packageConfigTestWrapper = x48' , packageConfigTestFailWhenNoTestSuites = x49' - , packageConfigTestTestOptions = x51' } + , packageConfigTestTestOptions = x51' + , packageConfigBenchmarkOptions = x52' } | (((x00', x01', x02', x03', x04'), (x05', x42', x06', x50', x07', x08', x09'), (x10', x11', x12', x13', x14'), @@ -726,7 +731,7 @@ (x30', x31', x32', (x33', x33_1'), x34'), (x35', x36', x37', x38', x43', x39'), (x40', x41'), - (x44', x45', x46', x47', x48', x49', x51'))) + (x44', x45', x46', x47', x48', x49', x51', x52'))) <- shrink (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04), (x05, x42, x06, x50, x07, x08, x09), @@ -740,7 +745,7 @@ (x30, x31, x32, (x33, x33_1), x34), (x35, x36, fmap NonEmpty x37, x38, x43, fmap NonEmpty x39), (x40, x41), - (x44, x45, x46, x47, x48, x49, x51))) + (x44, x45, x46, x47, x48, x49, x51, x52))) ] where preShrink_Paths = Map.map NonEmpty @@ -762,35 +767,24 @@ instance Arbitrary TestShowDetails where arbitrary = arbitraryBoundedEnum -instance Arbitrary SourceRepo where - arbitrary = (SourceRepo kind - <$> arbitrary - <*> (fmap getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> arbitrary)) - `suchThat` (/= emptySourceRepo kind) - where - kind = RepoKindUnknown "unused" +instance f ~ [] => Arbitrary (SourceRepositoryPackage f) where + arbitrary = SourceRepositoryPackage + <$> arbitrary + <*> (getShortToken <$> arbitrary) + <*> (fmap getShortToken <$> arbitrary) + <*> (fmap getShortToken <$> arbitrary) + <*> (fmap getShortToken <$> shortListOf 3 arbitrary) - shrink (SourceRepo _ x1 x2 x3 x4 x5 x6) = - [ repo - | ((x1', x2', x3'), (x4', x5', x6')) - <- shrink ((x1, - fmap ShortToken x2, - fmap ShortToken x3), - (fmap ShortToken x4, - fmap ShortToken x5, - fmap ShortToken x6)) - , let repo = SourceRepo RepoThis x1' - (fmap getShortToken x2') - (fmap getShortToken x3') - (fmap getShortToken x4') - (fmap getShortToken x5') - (fmap getShortToken x6') - , repo /= emptySourceRepo RepoThis - ] + shrink (SourceRepositoryPackage x1 x2 x3 x4 x5) = + [ SourceRepositoryPackage + x1' + (getShortToken x2') + (fmap getShortToken x3') + (fmap getShortToken x4') + (fmap getShortToken x5') + | (x1', x2', x3', x4', x5') <- shrink + (x1, ShortToken x2, fmap ShortToken x3, fmap ShortToken x4, fmap ShortToken x5) + ] instance Arbitrary RepoType where arbitrary = elements knownRepoTypes diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module UnitTests.Distribution.Client.TreeDiffInstances () where @@ -9,7 +10,7 @@ import Distribution.Simple.InstallDirs import Distribution.Simple.InstallDirs.Internal import Distribution.Simple.Setup (HaddockTarget, TestShowDetails) -import Distribution.Types.GenericPackageDescription (FlagName, FlagAssignment) +import Distribution.Types.Flag (FlagName, FlagAssignment) import Distribution.Types.PackageId import Distribution.Types.PackageName import Distribution.Types.PackageVersionConstraint @@ -33,6 +34,7 @@ import Distribution.Client.InstallSymlink import Distribution.Client.ProjectConfig.Types import Distribution.Client.Targets +import Distribution.Client.SourceRepo (SourceRepositoryPackage) import Distribution.Client.Types import UnitTests.Distribution.Client.GenericInstances () @@ -90,6 +92,7 @@ instance ToExpr ReportLevel instance ToExpr ShortText instance ToExpr SourceRepo +instance ToExpr (f FilePath) => ToExpr (SourceRepositoryPackage f) instance ToExpr StrongFlags instance ToExpr TestShowDetails instance ToExpr Timestamp diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs @@ -1,22 +1,19 @@ {-# LANGUAGE RecordWildCards, NamedFieldPuns #-} module UnitTests.Distribution.Client.VCS (tests) where +import Distribution.Client.Compat.Prelude import Distribution.Client.VCS import Distribution.Client.RebuildMonad ( execRebuild ) import Distribution.Simple.Program import Distribution.Verbosity as Verbosity -import Distribution.Types.SourceRepo +import Distribution.Client.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy) import Data.List import Data.Tuple import qualified Data.Map as Map -import Data.Map (Map) import qualified Data.Set as Set -import Data.Set (Set) -import Data.Char (isSpace) -import Control.Monad import qualified Control.Monad.State as State import Control.Monad.State (StateT, liftIO, execStateT) import Control.Exception @@ -196,11 +193,13 @@ removeDirectoryRecursiveHack verbosity destRepoPath where destRepoPath = tmpdir "dest" - repo = (emptySourceRepo RepoThis) { - repoType = Just (vcsRepoType vcsVCS), - repoLocation = Just vcsRepoRoot, - repoTag = Just tagname - } + repo = SourceRepositoryPackage + { srpType = vcsRepoType vcsVCS + , srpLocation = vcsRepoRoot + , srpTag = Just tagname + , srpBranch = Nothing + , srpSubdir = [] + } verbosity = silent @@ -264,7 +263,7 @@ (SyncTargetIterations syncTargetSetIterations) (PrngSeed seed) = mapM_ checkSyncTargetSet syncTargetSets where - checkSyncTargetSet :: [(SourceRepo, FilePath, RepoWorkingState)] -> IO () + checkSyncTargetSet :: [(SourceRepoProxy, FilePath, RepoWorkingState)] -> IO () checkSyncTargetSet syncTargets = do _ <- execRebuild "root-unused" $ syncSourceRepos verbosity vcs @@ -282,22 +281,24 @@ pickSyncTargetSets :: RepoType -> RepoState -> FilePath -> [FilePath] -> StdGen - -> [[(SourceRepo, FilePath, RepoWorkingState)]] + -> [[(SourceRepoProxy, FilePath, RepoWorkingState)]] pickSyncTargetSets repoType repoState srcRepoPath dstReposPath = assert (Map.size (allTags repoState) > 0) $ unfoldr (Just . swap . pickSyncTargetSet) where - pickSyncTargetSet :: Rand [(SourceRepo, FilePath, RepoWorkingState)] + pickSyncTargetSet :: Rand [(SourceRepoProxy, FilePath, RepoWorkingState)] pickSyncTargetSet = flip (mapAccumL (flip pickSyncTarget)) dstReposPath - pickSyncTarget :: FilePath -> Rand (SourceRepo, FilePath, RepoWorkingState) + pickSyncTarget :: FilePath -> Rand (SourceRepoProxy, FilePath, RepoWorkingState) pickSyncTarget destRepoPath prng = (prng', (repo, destRepoPath, workingState)) where - repo = (emptySourceRepo RepoThis) { - repoType = Just repoType, - repoLocation = Just srcRepoPath, - repoTag = Just tag + repo = SourceRepositoryPackage + { srpType = repoType + , srpLocation = srcRepoPath + , srpTag = Just tag + , srpBranch = Nothing + , srpSubdir = Proxy } (tag, workingState) = Map.elemAt tagIdx (allTags repoState) (tagIdx, prng') = randomR (0, Map.size (allTags repoState) - 1) prng @@ -631,7 +632,7 @@ return (Just commit') , vcsTagState = \_ tagname -> - git ["tag", "--force", tagname] + git ["tag", "--force", "--no-sign", tagname] , vcsSwitchBranch = \RepoState{allBranches} branchname -> do unless (branchname `Map.member` allBranches) $ diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -21,7 +21,7 @@ import Test.Tasty (TestTree) import Test.Tasty.QuickCheck -import Distribution.Types.GenericPackageDescription (FlagName) +import Distribution.Types.Flag (FlagName) import Distribution.Utils.ShortText (ShortText) import Distribution.Client.Setup (defaultMaxBackjumps) diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -478,7 +478,7 @@ ] -- In this example, we _can_ install C and D as independent goals, but we have --- to pick two diferent versions for B (arbitrarily) +-- to pick two different versions for B (arbitrarily) db2 :: ExampleDb db2 = [ Right $ exAv "A" 1 [] @@ -874,7 +874,7 @@ -- has a setup dependency on D, and D has a regular dependency on C-*. However, -- version C-1.0 is already available (perhaps it didn't have this setup dep). -- Thus, we should be able to break this cycle even if we are installing package --- E, which explictly depends on C-2.0. +-- E, which explicitly depends on C-2.0. db15 :: ExampleDb db15 = [ -- First example (real cycle, no solution) @@ -1211,7 +1211,7 @@ -- | Test the trace messages that we get when a package refers to an unknown pkg -- -- TODO: Currently we don't actually test the trace messages, and this particular --- test still suceeds. The trace can only be verified by hand. +-- test still succeeds. The trace can only be verified by hand. db21 :: ExampleDb db21 = [ Right $ exAv "A" 1 [ExAny "B"] diff --git a/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.test.hs b/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.test.hs --- a/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.test.hs +++ b/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.test.hs @@ -13,7 +13,7 @@ -- Calling sdist without running configure first makes test fail with: -- "Exception: Run the 'configure' command first." - -- This is becuase we are calling getPersistBuildConfig + -- This is because we are calling getPersistBuildConfig configureResult <- setup' "configure" [] sdistResult <- setup' "sdist" [] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs @@ -2,6 +2,7 @@ main = cabalTest $ do skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 withProjectFile "cabal.external.project" $ do cabal "v2-build" ["exe"] withPlan $ do diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs @@ -2,6 +2,7 @@ main = cabalTest $ do skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 withProjectFile "cabal.internal.project" $ do cabal "v2-build" ["exe"] withPlan $ do diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/Includes3.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/Includes3.cabal --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/Includes3.cabal +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/Includes3.cabal @@ -9,17 +9,17 @@ library sigs build-depends: base signatures: Data.Map - hs-source-dirs: sigs + hs-source-dirs: repo/sigs-0.1.0.0 default-language: Haskell2010 library indef build-depends: base, sigs exposed-modules: Foo - hs-source-dirs: indef + hs-source-dirs: repo/indef-0.1.0.0 default-language: Haskell2010 executable exe build-depends: base, containers, indef main-is: Main.hs - hs-source-dirs: exe + hs-source-dirs: repo/exe-0.1.0.0 default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs @@ -2,6 +2,7 @@ main = cabalTest $ do skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 withProjectFile "cabal.external.project" $ do cabal "v2-build" ["exe"] withPlan $ do diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs @@ -2,6 +2,7 @@ main = cabalTest $ do skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 withProjectFile "cabal.internal.project" $ do cabal "v2-build" ["exe"] withPlan $ do diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.out @@ -0,0 +1,29 @@ +# cabal v1-update +Downloading the latest package list from test-local-repo +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - sigs-0.1.0.0 (lib) (requires download & build) + - indef-0.1.0.0 (lib) (requires download & build) + - indef-0.1.0.0 (lib with Data.Map=containers-:Data.Map) (requires download & build) + - exe-0.1.0.0 (exe:exe) (first run) +Configuring library for sigs-0.1.0.0.. +Preprocessing library for sigs-0.1.0.0.. +Building library instantiated with Data.Map = +for sigs-0.1.0.0.. +Installing library in +Configuring library for indef-0.1.0.0.. +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with Data.Map = +for indef-0.1.0.0.. +Installing library in +Configuring library instantiated with Data.Map = containers-:Data.Map +for indef-0.1.0.0.. +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with Data.Map = containers-:Data.Map +for indef-0.1.0.0.. +Installing library in +Configuring executable 'exe' for exe-0.1.0.0.. +Preprocessing executable 'exe' for exe-0.1.0.0.. +Building executable 'exe' for exe-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-repo.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude +main = withShorterPathForNewBuildStore $ \storeDir -> + cabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + withProjectFile "cabal.repo.project" $ do + withRepo "repo" $ do + cabalG ["--store-dir=" ++ storeDir] "v2-build" ["exe"] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal.external.project b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal.external.project --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal.external.project +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal.external.project @@ -1,1 +1,1 @@ -packages: exe indef sigs +packages: repo/exe-0.1.0.0 repo/indef-0.1.0.0 repo/sigs-0.1.0.0 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal.repo.project b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal.repo.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal.repo.project @@ -0,0 +1,1 @@ +packages: repo/exe-0.1.0.0 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/exe/Main.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/exe/Main.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/exe/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -import qualified Data.Map as Map -import Data.Map (Map) -import Foo -main = print $ f (+1) (Map.fromList [(0,1),(2,3)] :: Map Int Int) diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/exe/exe.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/exe/exe.cabal deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/exe/exe.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: exe -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.25 - -executable exe - build-depends: base, containers, indef - main-is: Main.hs - default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/indef/Foo.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/indef/Foo.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/indef/Foo.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Foo where - -import Data.Map - -f :: (a -> b) -> Map k a -> Map k b -f = fmap diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/indef/indef.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/indef/indef.cabal deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/indef/indef.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: indef -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.25 - -library - build-depends: base, sigs - exposed-modules: Foo - default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/exe-0.1.0.0/Main.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/exe-0.1.0.0/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/exe-0.1.0.0/Main.hs @@ -0,0 +1,4 @@ +import qualified Data.Map as Map +import Data.Map (Map) +import Foo +main = print $ f (+1) (Map.fromList [(0,1),(2,3)] :: Map Int Int) diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/exe-0.1.0.0/exe.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/exe-0.1.0.0/exe.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/exe-0.1.0.0/exe.cabal @@ -0,0 +1,12 @@ +name: exe +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +executable exe + build-depends: base, containers, indef + main-is: Main.hs + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/indef-0.1.0.0/Foo.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/indef-0.1.0.0/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/indef-0.1.0.0/Foo.hs @@ -0,0 +1,6 @@ +module Foo where + +import Data.Map + +f :: (a -> b) -> Map k a -> Map k b +f = fmap diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/indef-0.1.0.0/indef.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/indef-0.1.0.0/indef.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/indef-0.1.0.0/indef.cabal @@ -0,0 +1,12 @@ +name: indef +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base, sigs + exposed-modules: Foo + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/sigs-0.1.0.0/Data/Map.hsig b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/sigs-0.1.0.0/Data/Map.hsig new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/sigs-0.1.0.0/Data/Map.hsig @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +signature Data.Map where +type role Map nominal representational +data Map k a +instance Functor (Map k) diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/sigs-0.1.0.0/sigs.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/sigs-0.1.0.0/sigs.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/repo/sigs-0.1.0.0/sigs.cabal @@ -0,0 +1,12 @@ +name: sigs +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + build-depends: base + signatures: Data.Map + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.out --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.out +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.out @@ -8,7 +8,7 @@ Preprocessing library for sigs-0.1.0.0.. Running Haddock on library instantiated with Data.Map = for sigs-0.1.0.0.. -Documentation created: ../setup-external-explicit.dist/work/sigs/dist/doc/html/sigs/index.html +Documentation created: ../../setup-external-explicit.dist/work/repo/sigs-0.1.0.0/dist/doc/html/sigs/index.html # Setup copy Installing library in # Setup register @@ -24,7 +24,7 @@ Preprocessing library for indef-0.1.0.0.. Running Haddock on library instantiated with Data.Map = for indef-0.1.0.0.. -Documentation created: ../setup-external-explicit.dist/work/indef/dist/doc/html/indef/index.html +Documentation created: ../../setup-external-explicit.dist/work/repo/indef-0.1.0.0/dist/doc/html/indef/index.html # Setup copy Installing library in # Setup register diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.test.hs @@ -3,5 +3,5 @@ main = setupTest $ do skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) withPackageDb $ do - withDirectory "sigs" $ setup_install_with_docs ["--cid", "sigs-0.1.0.0", "lib:sigs"] - withDirectory "indef" $ setup_install_with_docs ["--cid", "indef-0.1.0.0", "--dependency=sigs=sigs-0.1.0.0", "lib:indef"] + withDirectory "repo/sigs-0.1.0.0" $ setup_install_with_docs ["--cid", "sigs-0.1.0.0", "lib:sigs"] + withDirectory "repo/indef-0.1.0.0" $ setup_install_with_docs ["--cid", "indef-0.1.0.0", "--dependency=sigs=sigs-0.1.0.0", "lib:indef"] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.test.hs @@ -2,10 +2,10 @@ main = setupAndCabalTest $ do skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) withPackageDb $ do - withDirectory "sigs" $ setup_install [] - withDirectory "indef" $ setup_install [] + withDirectory "repo/sigs-0.1.0.0" $ setup_install [] + withDirectory "repo/indef-0.1.0.0" $ setup_install [] -- Forgot to build the instantiated versions! - withDirectory "exe" $ do + withDirectory "repo/exe-0.1.0.0" $ do -- Missing package message includes a unit identifier, -- which wobbles when version numbers change r <- recordMode DoNotRecord . fails $ setup' "configure" [] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.cabal.out --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.cabal.out +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.cabal.out @@ -9,7 +9,7 @@ Preprocessing library for sigs-0.1.0.0.. Running Haddock on library instantiated with Data.Map = for sigs-0.1.0.0.. -Documentation created: ../setup-external-ok.cabal.dist/work/sigs/dist/doc/html/sigs/index.html +Documentation created: ../../setup-external-ok.cabal.dist/work/repo/sigs-0.1.0.0/dist/doc/html/sigs/index.html # Setup copy Installing library in # Setup register @@ -26,7 +26,7 @@ Preprocessing library for indef-0.1.0.0.. Running Haddock on library instantiated with Data.Map = for indef-0.1.0.0.. -Documentation created: ../setup-external-ok.cabal.dist/work/indef/dist/doc/html/indef/index.html +Documentation created: ../../setup-external-ok.cabal.dist/work/repo/indef-0.1.0.0/dist/doc/html/indef/index.html # Setup copy Installing library in # Setup register @@ -44,7 +44,7 @@ Running Haddock on library instantiated with Data.Map = containers-:Data.Map for sigs-0.1.0.0.. -Documentation created: ../setup-external-ok.cabal.dist/work/sigs/dist/doc/html/sigs/index.html +Documentation created: ../../setup-external-ok.cabal.dist/work/repo/sigs-0.1.0.0/dist/doc/html/sigs/index.html # Setup copy Installing library in # Setup register @@ -62,7 +62,7 @@ Running Haddock on library instantiated with Data.Map = containers-:Data.Map for indef-0.1.0.0.. -Documentation created: ../setup-external-ok.cabal.dist/work/indef/dist/doc/html/indef/index.html +Documentation created: ../../setup-external-ok.cabal.dist/work/repo/indef-0.1.0.0/dist/doc/html/indef/index.html # Setup copy Installing library in # Setup register diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.out --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.out +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.out @@ -8,7 +8,7 @@ Preprocessing library for sigs-0.1.0.0.. Running Haddock on library instantiated with Data.Map = for sigs-0.1.0.0.. -Documentation created: ../setup-external-ok.dist/work/sigs/dist/doc/html/sigs/index.html +Documentation created: ../../setup-external-ok.dist/work/repo/sigs-0.1.0.0/dist/doc/html/sigs/index.html # Setup copy Installing library in # Setup register @@ -24,7 +24,7 @@ Preprocessing library for indef-0.1.0.0.. Running Haddock on library instantiated with Data.Map = for indef-0.1.0.0.. -Documentation created: ../setup-external-ok.dist/work/indef/dist/doc/html/indef/index.html +Documentation created: ../../setup-external-ok.dist/work/repo/indef-0.1.0.0/dist/doc/html/indef/index.html # Setup copy Installing library in # Setup register @@ -41,7 +41,7 @@ Running Haddock on library instantiated with Data.Map = containers-:Data.Map for sigs-0.1.0.0.. -Documentation created: ../setup-external-ok.dist/work/sigs/dist/doc/html/sigs/index.html +Documentation created: ../../setup-external-ok.dist/work/repo/sigs-0.1.0.0/dist/doc/html/sigs/index.html # Setup copy Installing library in # Setup register @@ -58,7 +58,7 @@ Running Haddock on library instantiated with Data.Map = containers-:Data.Map for indef-0.1.0.0.. -Documentation created: ../setup-external-ok.dist/work/indef/dist/doc/html/indef/index.html +Documentation created: ../../setup-external-ok.dist/work/repo/indef-0.1.0.0/dist/doc/html/indef/index.html # Setup copy Installing library in # Setup register diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.test.hs @@ -5,18 +5,18 @@ skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) withPackageDb $ do containers_id <- getIPID "containers" - withDirectory "sigs" $ setup_install_with_docs ["--ipid", "sigs-0.1.0.0"] - withDirectory "indef" $ setup_install_with_docs ["--ipid", "indef-0.1.0.0"] - withDirectory "sigs" $ do + withDirectory "repo/sigs-0.1.0.0" $ setup_install_with_docs ["--ipid", "sigs-0.1.0.0"] + withDirectory "repo/indef-0.1.0.0" $ setup_install_with_docs ["--ipid", "indef-0.1.0.0"] + withDirectory "repo/sigs-0.1.0.0" $ do -- NB: this REUSES the dist directory that we typechecked -- indefinitely, but it's OK; the recompile checker should get it. setup_install_with_docs ["--ipid", "sigs-0.1.0.0", "--instantiate-with", "Data.Map=" ++ containers_id ++ ":Data.Map"] - withDirectory "indef" $ do + withDirectory "repo/indef-0.1.0.0" $ do -- Ditto. setup_install_with_docs ["--ipid", "indef-0.1.0.0", "--instantiate-with", "Data.Map=" ++ containers_id ++ ":Data.Map"] - withDirectory "exe" $ do + withDirectory "repo/exe-0.1.0.0" $ do setup_install [] runExe' "exe" [] >>= assertOutputContains "fromList [(0,2),(2,4)]" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.test.hs @@ -3,7 +3,7 @@ skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) withPackageDb $ do setup_install [] - _ <- runM "touch" ["indef/Foo.hs"] + _ <- runM "touch" ["repo/indef-0.1.0.0/Foo.hs"] setup "build" [] runExe' "exe" [] >>= assertOutputContains "fromList [(0,2),(2,4)]" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/sigs/Data/Map.hsig b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/sigs/Data/Map.hsig deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/sigs/Data/Map.hsig +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} -signature Data.Map where -type role Map nominal representational -data Map k a -instance Functor (Map k) diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/sigs/sigs.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/sigs/sigs.cabal deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/sigs/sigs.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: sigs -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.25 - -library - build-depends: base - signatures: Data.Map - default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/bkpcabal01/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/bkpcabal01/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Backpack/bkpcabal01/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Backpack/bkpcabal01/cabal.test.hs @@ -2,4 +2,5 @@ main = cabalTest $ do -- GHC 8.2.2 had a regression ("unknown package: hole"), see also #4908 skipUnless =<< ghcVersionIs (\v -> v >= mkVersion [8,2] && v /= mkVersion [8,2,2]) + skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 cabal "v2-build" ["all"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/OptionsFlag.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/OptionsFlag.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/OptionsFlag.cabal @@ -0,0 +1,10 @@ +name: OptionsFlag +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +benchmark optionsflag + type: exitcode-stdio-1.0 + main-is: OptionsFlag.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/OptionsFlag.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/OptionsFlag.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/OptionsFlag.hs @@ -0,0 +1,12 @@ +module Main where + +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) + +main :: IO () +main = do + args <- getArgs + let allArgs = unwords args + if allArgs == "1 2 3 4 5 6" + then exitSuccess + else putStrLn ("Got: " ++ allArgs) >> exitFailure diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/cabal.out @@ -0,0 +1,11 @@ +# cabal v2-bench +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - OptionsFlag-1.0 (bench:optionsflag) (first run) +Configuring benchmark 'optionsflag' for OptionsFlag-1.0.. +Preprocessing benchmark 'optionsflag' for OptionsFlag-1.0.. +Building benchmark 'optionsflag' for OptionsFlag-1.0.. +Running 1 benchmarks... +Benchmark optionsflag: RUNNING... +Benchmark optionsflag: FINISH diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/OptionsFlag/cabal.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + cabal "v2-bench" + [ "--benchmark-option=1" + , "--benchmark-options=\"2 3\"" + , "--benchmark-option=4" + , "--benchmark-options=\"5 6\"" + ] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/OptionsFlag.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/OptionsFlag.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/OptionsFlag.cabal @@ -0,0 +1,10 @@ +name: OptionsFlag +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +test-suite optionsflag + type: exitcode-stdio-1.0 + main-is: OptionsFlag.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/OptionsFlag.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/OptionsFlag.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/OptionsFlag.hs @@ -0,0 +1,12 @@ +module Main where + +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) + +main :: IO () +main = do + args <- getArgs + let allArgs = unwords args + if allArgs == "1 2 3 4 5 6" + then exitSuccess + else putStrLn ("Got: " ++ allArgs) >> exitFailure diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/cabal.out @@ -0,0 +1,13 @@ +# cabal v2-test +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - OptionsFlag-1.0 (test:optionsflag) (first run) +Configuring test suite 'optionsflag' for OptionsFlag-1.0.. +Preprocessing test suite 'optionsflag' for OptionsFlag-1.0.. +Building test suite 'optionsflag' for OptionsFlag-1.0.. +Running 1 test suites... +Test suite optionsflag: RUNNING... +Test suite optionsflag: PASS +Test suite logged to: /cabal.dist/work/./dist/build//ghc-/OptionsFlag-1.0/t/optionsflag/test/OptionsFlag-1.0-optionsflag.log +1 of 1 test suites (1 of 1 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdTest/OptionsFlag/cabal.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + cabal "v2-test" + [ "--test-option=1" + , "--test-options=\"2 3\"" + , "--test-option=4" + , "--test-options=\"5 6\"" + ] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5309/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5309/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Regression/T5309/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5309/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude main = cabalTest $ do - cabal "v2-build" ["all"] - cabal "v2-test" ["all"] - cabal "v2-bench" ["all"] + skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 + cabal "v2-build" ["all"] + cabal "v2-test" ["all"] + cabal "v2-bench" ["all"] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5309/memoized-tcm/costMatrixWrapper.h b/cabal/cabal-testsuite/PackageTests/Regression/T5309/memoized-tcm/costMatrixWrapper.h --- a/cabal/cabal-testsuite/PackageTests/Regression/T5309/memoized-tcm/costMatrixWrapper.h +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5309/memoized-tcm/costMatrixWrapper.h @@ -5,7 +5,7 @@ #include "dynamicCharacterOperations.h" -/** Initialize a matrix (fill in all values for non-ambiguous chracter transition costs) using a TCM sent in from an outside source. */ +/** Initialize a matrix (fill in all values for non-ambiguous character transition costs) using a TCM sent in from an outside source. */ costMatrix_p matrixInit(size_t alphSize, int *tcm); /** C wrapper for cpp destructor */ diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T5677/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T5677/cabal.test.hs --- a/cabal/cabal-testsuite/PackageTests/Regression/T5677/cabal.test.hs +++ b/cabal/cabal-testsuite/PackageTests/Regression/T5677/cabal.test.hs @@ -2,4 +2,5 @@ main = cabalTest $ do -- -Wmissing-export-lists is new in 8.4. skipUnless =<< ghcVersionIs (>= mkVersion [8,3]) + skipIf =<< isWindows -- TODO: https://github.com/haskell/cabal/issues/6271 cabal "v2-build" ["all"] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6334/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T6334/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6334/cabal.out @@ -0,0 +1,8 @@ +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - foo-0 (lib) (first run) +Configuring library for foo-0.. +Preprocessing library for foo-0.. +Building library for foo-0.. diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6334/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T6334/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6334/cabal.project @@ -0,0 +1,1 @@ +packages: foo diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6334/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6334/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6334/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = cabalTest $ + cabal "v2-build" ["all"] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6334/foo/README.md b/cabal/cabal-testsuite/PackageTests/Regression/T6334/foo/README.md new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6334/foo/README.md @@ -0,0 +1,1 @@ +Some file diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6334/foo/foo.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T6334/foo/foo.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6334/foo/foo.cabal @@ -0,0 +1,13 @@ +cabal-version: 2.2 +name: foo +version: 0 +description: + https://github.com/haskell/cabal/issues/6334 +extra-source-files: + README.md + +library + default-language: Haskell2010 + hs-source-dirs: src + exposed-modules: Foo + build-depends: base <5 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T6334/foo/src/Foo.hs b/cabal/cabal-testsuite/PackageTests/Regression/T6334/foo/src/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T6334/foo/src/Foo.hs @@ -0,0 +1,1 @@ +module Foo () where diff --git a/cabal/cabal-testsuite/Test/Cabal/Prelude.hs b/cabal/cabal-testsuite/Test/Cabal/Prelude.hs --- a/cabal/cabal-testsuite/Test/Cabal/Prelude.hs +++ b/cabal/cabal-testsuite/Test/Cabal/Prelude.hs @@ -818,8 +818,8 @@ getOpenFilesLimit = liftIO $ do ResourceLimits { softLimit } <- getResourceLimit ResourceOpenFiles case softLimit of - ResourceLimit n -> return (Just n) - _ -> return Nothing + ResourceLimit n | n >= 0 && n <= 4096 -> return (Just n) + _ -> return Nothing #endif hasCabalForGhc :: TestM Bool diff --git a/cabal/cabal-testsuite/cabal-testsuite.cabal b/cabal/cabal-testsuite/cabal-testsuite.cabal --- a/cabal/cabal-testsuite/cabal-testsuite.cabal +++ b/cabal/cabal-testsuite/cabal-testsuite.cabal @@ -61,10 +61,10 @@ , directory ^>= 1.2.0.1 || ^>= 1.3.0.0 , exceptions ^>= 0.10.0 , filepath ^>= 1.3.0.1 || ^>= 1.4.0.0 - , optparse-applicative ^>= 0.14.3.0 + , optparse-applicative ^>= 0.14.3.0 || ^>=0.15.1.0 , process ^>= 1.1.0.2 || ^>= 1.2.0.0 || ^>= 1.4.2.0 || ^>= 1.6.1.0 , regex-compat-tdfa ^>= 0.95.1.4 - , regex-tdfa ^>= 1.2.3.1 + , regex-tdfa ^>= 1.2.3.1 || ^>=1.3.0 , temporary ^>= 1.3 , text ^>= 1.2.3.1 , transformers ^>= 0.3.0.0 || ^>= 0.4.2.0 || ^>= 0.5.2.0 @@ -91,7 +91,7 @@ , process , transformers -- dependencies specific to exe:cabal-tests - , clock ^>= 0.7.2 + , clock ^>= 0.7.2 || ^>=0.8 build-tool-depends: cabal-testsuite:setup diff --git a/cabal/cabal.project b/cabal/cabal.project --- a/cabal/cabal.project +++ b/cabal/cabal.project @@ -1,4 +1,6 @@ -packages: Cabal/ cabal-testsuite/ cabal-install/ solver-benchmarks/ +packages: Cabal/ cabal-testsuite/ +packages: cabal-install/ solver-benchmarks/ +tests: True -- Uncomment to allow picking up extra local unpacked deps: --optional-packages: */ diff --git a/cabal/cabal.project.libonly b/cabal/cabal.project.libonly new file mode 100644 --- /dev/null +++ b/cabal/cabal.project.libonly @@ -0,0 +1,19 @@ +packages: Cabal/ cabal-testsuite/ +tests: True + +-- Uncomment to allow picking up extra local unpacked deps: +--optional-packages: */ + +program-options + -- So us hackers get all the assertion failures early: + -- + -- NOTE: currently commented out, see + -- https://github.com/haskell/cabal/issues/3911 + -- + -- ghc-options: -fno-ignore-asserts + -- + -- as a workaround we specify it for each package individually: +package Cabal + ghc-options: -fno-ignore-asserts +package cabal-testsuite + ghc-options: -fno-ignore-asserts diff --git a/cabal/cabal.project.travis b/cabal/cabal.project.travis deleted file mode 100644 --- a/cabal/cabal.project.travis +++ /dev/null @@ -1,20 +0,0 @@ --- Force error messages to be better --- Parallel new-build error messages are non-existent. --- Turn off parallelization to get good errors. -jobs: 1 - --- We vendor a copy of hackage-repo-tool so that we can --- build it reliably. If we eventually get new-install --- in the bootstrap, this can go away. -optional-packages: hackage-repo-tool-*/ --- hackage-repo-tool has upper bound on Cabal -allow-newer: hackage-repo-tool:Cabal, hackage-repo-tool:time, hackage-repo-tool:directory - --- The -fno-warn-orphans is a hack to make Cabal-1.24 --- build properly (unfortunately the flags here get applied --- to the dependencies too!) -package Cabal - ghc-options: -Werror -fno-warn-orphans - -package cabal-install - ghc-options: -Werror diff --git a/cabal/cabal.project.travis.libonly b/cabal/cabal.project.travis.libonly deleted file mode 100644 --- a/cabal/cabal.project.travis.libonly +++ /dev/null @@ -1,24 +0,0 @@ --- A copy of cabal.project, but with a trimmed down 'packages' --- field. Needed for LIB_ONLY configurations that can't build cabal-install, --- only lib:Cabal. - -packages: Cabal/ cabal-testsuite/ - --- Uncomment to allow picking up extra local unpacked deps: ---optional-packages: */ - -program-options - -- So us hackers get all the assertion failures early: - -- - -- NOTE: currently commented out, see - -- https://github.com/haskell/cabal/issues/3911 - -- - -- ghc-options: -fno-ignore-asserts - -- - -- as a workaround we specify it for each package individually: -package Cabal - ghc-options: -fno-ignore-asserts -package cabal-testsuite - ghc-options: -fno-ignore-asserts -package cabal-install - ghc-options: -fno-ignore-asserts diff --git a/cabal/release-checklist.md b/cabal/release-checklist.md new file mode 100644 --- /dev/null +++ b/cabal/release-checklist.md @@ -0,0 +1,10 @@ +# For major release + +- Add new SPDX License list data + +# For release for new GHC version: + +- Update GHC flags in `normaliseGhcArgs`, and add the GHC version to + `supportedGHCVersions` (`Distribution.Simple.Program.GHC`) +- Update `Language.Haskell.Extension` list, if there are new GHC extensions +- Update `setupMinCabalVersionConstraint` (in `Distribution.Client.ProjectPlanning`) diff --git a/cabal/solver-benchmarks/solver-benchmarks.cabal b/cabal/solver-benchmarks/solver-benchmarks.cabal --- a/cabal/solver-benchmarks/solver-benchmarks.cabal +++ b/cabal/solver-benchmarks/solver-benchmarks.cabal @@ -33,7 +33,7 @@ optparse-applicative, process, time, - statistics >= 0.14 && < 0.15, + statistics >= 0.14 && < 0.16, vector default-language: Haskell2010 @@ -54,7 +54,7 @@ build-depends: base, solver-benchmarks, - statistics >= 0.14 && < 0.15, + statistics >= 0.14 && < 0.16, tasty, tasty-hunit default-language: Haskell2010 diff --git a/cabal/travis-common.sh b/cabal/travis-common.sh --- a/cabal/travis-common.sh +++ b/cabal/travis-common.sh @@ -1,6 +1,5 @@ set -e -HACKAGE_REPO_TOOL_VERSION="0.1.1.1" CABAL_VERSION="3.1.0.0" CABAL_INSTALL_VERSION="3.1.0.0" @@ -16,7 +15,6 @@ CABAL_TESTSUITE_BDIR="${TRAVIS_BUILD_DIR}/dist-newstyle/build/$ARCH/ghc-$GHCVER/cabal-testsuite-${CABAL_VERSION}" CABAL_INSTALL_BDIR="${TRAVIS_BUILD_DIR}/dist-newstyle/build/$ARCH/ghc-$GHCVER/cabal-install-${CABAL_INSTALL_VERSION}" SOLVER_BENCHMARKS_BDIR="${TRAVIS_BUILD_DIR}/dist-newstyle/build/$ARCH/ghc-$GHCVER/solver-benchmarks-${CABAL_VERSION}" -HACKAGE_REPO_TOOL_BDIR="${TRAVIS_BUILD_DIR}/dist-newstyle/build/$ARCH/ghc-$GHCVER/hackage-repo-tool-${HACKAGE_REPO_TOOL_VERSION}/x/hackage-repo-tool" CABAL_INSTALL_EXE=${CABAL_INSTALL_BDIR}/x/cabal/build/cabal/cabal # --------------------------------------------------------------------- diff --git a/cabal/travis-install.sh b/cabal/travis-install.sh --- a/cabal/travis-install.sh +++ b/cabal/travis-install.sh @@ -19,7 +19,7 @@ if [ "$SCRIPT" = "meta" ]; then # change to /tmp so cabal.project doesn't affect new-install cabal v2-update - (cd /tmp && cabal v2-install alex --constraint='alex ^>= 3.2.4' --overwrite=always) + (cd /tmp && cabal v2-install alex --constraint='alex ^>= 3.2.5' --overwrite=always) (cd /tmp && cabal v2-install happy --constraint='happy ^>= 1.19.9' --overwrite=always) fi diff --git a/cabal/travis-script.sh b/cabal/travis-script.sh --- a/cabal/travis-script.sh +++ b/cabal/travis-script.sh @@ -73,9 +73,7 @@ # Install executables if necessary # --------------------------------------------------------------------- -#if ! command -v happy; then - timed cabal install $jobs happy -#fi +timed cabal install $jobs happy # --------------------------------------------------------------------- # Setup our local project @@ -83,16 +81,10 @@ make cabal-install-monolithic if [ "x$CABAL_LIB_ONLY" = "xYES" ]; then - cp cabal.project.travis.libonly cabal.project + cp cabal.project.libonly cabal.project fi cp cabal.project.local.travis cabal.project.local -# hackage-repo-tool is a bit touchy to install on GHC 8.0, so instead we -# do it via new-build. See also cabal.project.local.travis. The downside of -# doing it this way is that the build product cannot be cached, but -# hackage-repo-tool is a relatively small package so it's good. -timed cabal unpack hackage-repo-tool-${HACKAGE_REPO_TOOL_VERSION} - # --------------------------------------------------------------------- # Cabal # --------------------------------------------------------------------- @@ -111,7 +103,12 @@ # Run haddock. if [ "$TRAVIS_OS_NAME" = "linux" ]; then # TODO: use new-haddock? - (cd Cabal && timed cabal act-as-setup --build-type=Simple -- haddock --builddir=${CABAL_BDIR}) || exit $? + + # haddock: internal error: synifyKind + # https://github.com/haskell/haddock/issues/242 + if [ "$GHCVER" != "7.6.3" ]; then + (cd Cabal && timed cabal act-as-setup --build-type=Simple -- haddock --builddir=${CABAL_BDIR}) || exit $? + fi fi # Check for package warnings @@ -162,7 +159,7 @@ # test suites are baked into the cabal binary timed cabal new-build $jobs $CABAL_INSTALL_FLAGS cabal-install:cabal -timed cabal new-build $jobs hackage-repo-tool +timed cabal new-install $jobs hackage-repo-tool --overwrite-policy=always if [ "x$SKIP_TESTS" = "xYES" ]; then exit 1; @@ -172,7 +169,7 @@ timed ${CABAL_INSTALL_EXE} update # Big tests -(cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/cabal-tests/cabal-tests --builddir=${CABAL_TESTSUITE_BDIR} -j3 --skip-setup-tests --with-cabal ${CABAL_INSTALL_EXE} --with-hackage-repo-tool ${HACKAGE_REPO_TOOL_BDIR}/build/hackage-repo-tool/hackage-repo-tool $TEST_OPTIONS) || exit $? +(cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/cabal-tests/cabal-tests --builddir=${CABAL_TESTSUITE_BDIR} -j3 --skip-setup-tests --with-cabal ${CABAL_INSTALL_EXE} --with-hackage-repo-tool hackage-repo-tool $TEST_OPTIONS) || exit $? # Cabal check # TODO: remove -main-is and re-enable me. diff --git a/cabal/travis/upload.sh b/cabal/travis/upload.sh --- a/cabal/travis/upload.sh +++ b/cabal/travis/upload.sh @@ -86,7 +86,7 @@ # Upload to S3 S3_URL=$(curl -X POST "https://s3-bouncer.herokuapp.com/put") -curl "$S3_URL" --upload-file binaries.tgz +travis_retry curl "$S3_URL" --upload-file binaries.tgz rm binaries.tgz # Don't check me in! echo "$S3_URL" | xargs basename | cut -d '?' -f 1 > s3-object.txt diff --git a/cabal/validate.dockerfile b/cabal/validate.dockerfile new file mode 100644 --- /dev/null +++ b/cabal/validate.dockerfile @@ -0,0 +1,48 @@ +FROM haskell:8.6.5 + +# We need prof GHC for some tests +RUN apt-get update +RUN apt-get install ghc-8.6.5-prof + +# Install cabal-plan +RUN cabal v2-update +RUN cabal v2-install cabal-plan --constraint 'cabal-plan ^>=0.6' + +# We install happy, so it's in the store; we (hopefully) don't use it directly. +RUN cabal v2-install happy --constraint 'happy ^>=1.19.12' + +# Install some other dependencies +# Remove $HOME/.ghc so there aren't any environments +RUN cabal v2-install -w ghc-8.6.5 --lib \ + aeson \ + async \ + base-compat \ + base16-bytestring \ + base64-bytestring \ + cryptohash-sha256 \ + Diff \ + echo \ + ed25519 \ + edit-distance \ + haskell-lexer \ + HTTP \ + network \ + optparse-applicative \ + pretty-show \ + regex-compat-tdfa \ + regex-tdfa \ + resolv \ + statistics \ + tar \ + tasty \ + tasty-golden \ + tasty-hunit \ + tasty-quickcheck \ + tree-diff \ + zlib \ + && rm -rf $HOME/.ghc + +# Validate +WORKDIR /build +COPY . /build +RUN sh ./validate.sh -w ghc-8.6.5 -v diff --git a/cabal/validate.sh b/cabal/validate.sh --- a/cabal/validate.sh +++ b/cabal/validate.sh @@ -191,12 +191,12 @@ PROJECTFILE=cabal.project.validate fi -BASEHC=$(basename $HC) +BASEHC=ghc-$($HC --numeric-version) BUILDDIR=dist-newstyle-validate-$BASEHC CABAL_TESTSUITE_BDIR="$(pwd)/$BUILDDIR/build/$ARCH/$BASEHC/cabal-testsuite-${CABAL_VERSION}" CABALNEWBUILD="${CABAL} v2-build $JOBS -w $HC --builddir=$BUILDDIR --project-file=$PROJECTFILE" -CABALPLAN="${CABALPLAN} --builddir=$BUILDDIR" +CABALPLANLISTBIN="${CABALPLAN} list-bin --builddir=$BUILDDIR" # SCRIPT ####################################################################### @@ -247,16 +247,16 @@ timed $CABALNEWBUILD Cabal:tests --enable-tests --disable-benchmarks --dep || exit 1 timed $CABALNEWBUILD Cabal:tests --enable-tests --disable-benchmarks || exit 1 -CMD="$($CABALPLAN list-bin Cabal:test:unit-tests) $TESTSUITEJOBS --hide-successes --with-ghc=$HC" +CMD="$($CABALPLANLISTBIN Cabal:test:unit-tests) $TESTSUITEJOBS --hide-successes --with-ghc=$HC" (cd Cabal && timed $CMD) || exit 1 -CMD="$($CABALPLAN list-bin Cabal:test:check-tests) $TESTSUITEJOBS --hide-successes" +CMD="$($CABALPLANLISTBIN Cabal:test:check-tests) $TESTSUITEJOBS --hide-successes" (cd Cabal && timed $CMD) || exit 1 -CMD="$($CABALPLAN list-bin Cabal:test:parser-tests) $TESTSUITEJOBS --hide-successes" +CMD="$($CABALPLANLISTBIN Cabal:test:parser-tests) $TESTSUITEJOBS --hide-successes" (cd Cabal && timed $CMD) || exit 1 -CMD=$($CABALPLAN list-bin Cabal:test:hackage-tests) +CMD=$($CABALPLANLISTBIN Cabal:test:hackage-tests) (cd Cabal && timed $CMD read-fields) || exit 1 (cd Cabal && timed $CMD parsec d) || exit 1 (cd Cabal && timed $CMD roundtrip k) || exit 1 @@ -273,7 +273,7 @@ echo "$CYAN=== cabal-testsuite: Cabal test ======================== $(date +%T) === $RESET" -CMD="$($CABALPLAN list-bin cabal-testsuite:exe:cabal-tests) --builddir=$CABAL_TESTSUITE_BDIR $TESTSUITEJOBS --with-ghc=$HC --hide-successes" +CMD="$($CABALPLANLISTBIN cabal-testsuite:exe:cabal-tests) --builddir=$CABAL_TESTSUITE_BDIR $TESTSUITEJOBS --with-ghc=$HC --hide-successes" (cd cabal-testsuite && timed $CMD) || exit 1 fi # CABALSUITETESTS (Cabal) @@ -300,19 +300,19 @@ echo "$CYAN=== cabal-install: test ================================ $(date +%T) === $RESET" # this are sorted in asc time used, quicker tests first. -CMD="$($CABALPLAN list-bin cabal-install:test:solver-quickcheck) $TESTSUITEJOBS --hide-successes" +CMD="$($CABALPLANLISTBIN cabal-install:test:solver-quickcheck) $TESTSUITEJOBS --hide-successes" (cd cabal-install && timed $CMD) || exit 1 # This doesn't work in parallel either -CMD="$($CABALPLAN list-bin cabal-install:test:unit-tests) -j1 --hide-successes" +CMD="$($CABALPLANLISTBIN cabal-install:test:unit-tests) -j1 --hide-successes" (cd cabal-install && timed $CMD) || exit 1 # Only single job, otherwise we fail with "Heap exhausted" -CMD="$($CABALPLAN list-bin cabal-install:test:memory-usage-tests) -j1 --hide-successes" +CMD="$($CABALPLANLISTBIN cabal-install:test:memory-usage-tests) -j1 --hide-successes" (cd cabal-install && timed $CMD) || exit 1 # This test-suite doesn't like concurrency -CMD="$($CABALPLAN list-bin cabal-install:test:integration-tests2) -j1 --hide-successes --with-ghc=$HC" +CMD="$($CABALPLANLISTBIN cabal-install:test:integration-tests2) -j1 --hide-successes --with-ghc=$HC" (cd cabal-install && timed $CMD) || exit 1 fi # CABALINSTALLTESTS @@ -321,7 +321,7 @@ if $CABALSUITETESTS; then echo "$CYAN=== cabal-testsuite: cabal-install test ================ $(date +%T) === $RESET" -CMD="$($CABALPLAN list-bin cabal-testsuite:exe:cabal-tests) --builddir=$CABAL_TESTSUITE_BDIR --with-cabal=$($CABALPLAN list-bin cabal-install:exe:cabal) $TESTSUITEJOBS --hide-successes" +CMD="$($CABALPLANLISTBIN cabal-testsuite:exe:cabal-tests) --builddir=$CABAL_TESTSUITE_BDIR --with-cabal=$($CABALPLANLISTBIN cabal-install:exe:cabal) $TESTSUITEJOBS --hide-successes" (cd cabal-testsuite && timed $CMD) || exit 1 fi # CABALSUITETESTS diff --git a/hackage-security/.travis.yml b/hackage-security/.travis.yml --- a/hackage-security/.travis.yml +++ b/hackage-security/.travis.yml @@ -1,69 +1,220 @@ -# See also https://github.com/hvr/multi-ghc-travis +# This Travis job script has been generated by a script via +# +# haskell-ci '--ghc-head' '--osx=8.4.4' 'cabal.project' +# +# For more information, see https://github.com/haskell-CI/haskell-ci +# +# version: 0.7.20191101 +# language: c -sudo: false - +dist: xenial +git: + # whether to recursively clone submodules + submodules: false cache: directories: - $HOME/.cabal/packages - $HOME/.cabal/store - + - $HOME/.ghc-install before_cache: - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log + - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update' - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx - + - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* + - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx + - rm -rfv $CABALHOME/packages/head.hackage matrix: include: - - compiler: "ghc-7.4.2" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.4.2], sources: [hvr-ghc]}} - - compiler: "ghc-7.6.3" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.6.3], sources: [hvr-ghc]}} - - compiler: "ghc-7.8.4" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.8.4], sources: [hvr-ghc]}} - - compiler: "ghc-7.10.3" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}} - - compiler: "ghc-8.0.2" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}} - - compiler: "ghc-8.2.2" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}} - - compiler: "ghc-8.4.3" - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.3], sources: [hvr-ghc]}} - + - compiler: ghc-8.8.1 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}} + - compiler: ghc-8.6.5 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}} + - compiler: ghc-8.4.4 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}} + - compiler: ghc-8.2.2 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}} + - compiler: ghc-8.0.2 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}} + - compiler: ghc-7.10.3 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.10.3","cabal-install-3.0"]}} + - compiler: ghc-7.8.4 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.8.4","cabal-install-3.0"]}} + - compiler: ghc-7.6.3 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.6.3","cabal-install-3.0"]}} + - compiler: ghc-7.4.2 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-7.4.2","cabal-install-3.0"]}} + - compiler: ghc-head + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-head","cabal-install-head"]}} + - compiler: ghc-8.4.4 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}} + os: osx + allow_failures: + - compiler: ghc-head before_install: - - HC=${CC} - - unset CC - - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH - + - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') + - WITHCOMPILER="-w $HC" + - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') + - if [ "$TRAVIS_OS_NAME" = "osx" ]; then HADDOCK=$(echo $HADDOCK | sed "s:^/opt:$HOME/.ghc-install:"); fi + - HCPKG="$HC-pkg" + - unset CC + - CABAL=/opt/ghc/bin/cabal + - CABALHOME=$HOME/.cabal + - export PATH="$CABALHOME/bin:$PATH" + - TOP=$(pwd) + - if [ "$TRAVIS_OS_NAME" = "osx" ]; then curl https://haskell.futurice.com/haskell-on-macos.py | python3 - --make-dirs --install-dir=$HOME/.ghc-install --cabal-alias=head install cabal-install-head ${TRAVIS_COMPILER}; fi + - if [ "$TRAVIS_OS_NAME" = "osx" ]; then HC=$HOME/.ghc-install/ghc/bin/$TRAVIS_COMPILER; WITHCOMPILER="-w $HC"; HCPKG=${HC/ghc/ghc-pkg}; CABAL=$HOME/.ghc-install/ghc/bin/cabal; fi + - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" + - echo $HCNUMVER + - CABAL="$CABAL -vnormal+nowrap+markoutput" + - set -o pipefail + - | + echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk + echo 'BEGIN { state = "output"; }' >> .colorful.awk + echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk + echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk + echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk + echo ' if (state == "cabal") {' >> .colorful.awk + echo ' print blue($0)' >> .colorful.awk + echo ' } else {' >> .colorful.awk + echo ' print $0' >> .colorful.awk + echo ' }' >> .colorful.awk + echo '}' >> .colorful.awk + - cat .colorful.awk + - | + color_cabal_output () { + awk -f $TOP/.colorful.awk + } + - echo text | color_cabal_output install: - - cabal --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - travis_retry cabal update -v - - cabal new-build -w ${HC} --dep ${XCABFLAGS} all - -# Here starts the actual work to be performed for the package under test; -# any command which exits with a non-zero exit code causes the build to fail. + - ${CABAL} --version + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - TEST=--enable-tests + - BENCH=--enable-benchmarks + - HEADHACKAGE=false + - if [ $HCNUMVER -gt 80801 ] ; then HEADHACKAGE=true ; fi + - rm -f $CABALHOME/config + - | + echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config + echo "remote-build-reporting: anonymous" >> $CABALHOME/config + echo "write-ghc-environment-files: always" >> $CABALHOME/config + echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config + echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config + echo "world-file: $CABALHOME/world" >> $CABALHOME/config + echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config + echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config + echo "installdir: $CABALHOME/bin" >> $CABALHOME/config + echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config + echo "store-dir: $CABALHOME/store" >> $CABALHOME/config + echo "install-dirs user" >> $CABALHOME/config + echo " prefix: $CABALHOME" >> $CABALHOME/config + echo "repository hackage.haskell.org" >> $CABALHOME/config + echo " url: http://hackage.haskell.org/" >> $CABALHOME/config + echo " secure: True" >> $CABALHOME/config + echo " key-threshold: 3" >> $CABALHOME/config + echo " root-keys:" >> $CABALHOME/config + echo " fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" >> $CABALHOME/config + echo " 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" >> $CABALHOME/config + echo " 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" >> $CABALHOME/config + echo " 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" >> $CABALHOME/config + echo " 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" >> $CABALHOME/config + - | + if $HEADHACKAGE; then + echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1/g')" >> $CABALHOME/config + echo "repository head.hackage.ghc.haskell.org" >> $CABALHOME/config + echo " url: https://ghc.gitlab.haskell.org/head.hackage/" >> $CABALHOME/config + echo " secure: True" >> $CABALHOME/config + echo " root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d" >> $CABALHOME/config + echo " 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329" >> $CABALHOME/config + echo " f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89" >> $CABALHOME/config + echo " key-threshold: 3" >> $CABALHOME/config + fi + - | + echo "program-default-options" >> $CABALHOME/config + echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config + - cat $CABALHOME/config + - rm -fv cabal.project cabal.project.local cabal.project.freeze + - travis_retry ${CABAL} v2-update -v + # Generate cabal.project + - rm -rf cabal.project cabal.project.local cabal.project.freeze + - touch cabal.project + - | + echo "packages: hackage-security" >> cabal.project + echo "packages: hackage-security-http-client" >> cabal.project + echo "packages: example-client" >> cabal.project + echo "packages: hackage-security-curl" >> cabal.project + echo "packages: hackage-root-tool" >> cabal.project + echo "packages: hackage-repo-tool" >> cabal.project + echo "packages: hackage-security-HTTP" >> cabal.project + - | + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(example-client|hackage-repo-tool|hackage-root-tool|hackage-security|hackage-security-HTTP|hackage-security-curl|hackage-security-http-client)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - cat cabal.project || true + - cat cabal.project.local || true + - if [ -f "hackage-security/configure.ac" ]; then (cd "hackage-security" && autoreconf -i); fi + - if [ -f "hackage-security-http-client/configure.ac" ]; then (cd "hackage-security-http-client" && autoreconf -i); fi + - if [ -f "example-client/configure.ac" ]; then (cd "example-client" && autoreconf -i); fi + - if [ -f "hackage-security-curl/configure.ac" ]; then (cd "hackage-security-curl" && autoreconf -i); fi + - if [ -f "hackage-root-tool/configure.ac" ]; then (cd "hackage-root-tool" && autoreconf -i); fi + - if [ -f "hackage-repo-tool/configure.ac" ]; then (cd "hackage-repo-tool" && autoreconf -i); fi + - if [ -f "hackage-security-HTTP/configure.ac" ]; then (cd "hackage-security-HTTP" && autoreconf -i); fi + - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output + - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" + - rm cabal.project.freeze + - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output script: -# prepare `cabal sdist` source-tree environment to make sure source-tarballs are complete - - read -a PKGS <<< "hackage-security hackage-security-http-client hackage-security-curl hackage-security-HTTP hackage-security hackage-root-tool hackage-repo-tool example-client" - - rm -rf sdists; mkdir sdists - - for PKG in "${PKGS[@]}"; do - cd "$PKG"; cabal sdist --output-directory="../sdists/$PKG" || break; cd ..; - done - - cd sdists/ - - # first build just hackage-security with installed constraints, with and without tests. - # silly yaml, seeing : colon - - "echo packages: hackage-security > cabal.project" - - cabal new-build --disable-tests --constraint "directory installed" --constraint "bytestring installed" ${XCABFLAGS} all - - cabal new-test --enable-tests --constraint "directory installed" --constraint "bytestring installed" ${XCABFLAGS} all - - # build all packages and run testsuite - - cp -v ../cabal.project ./ - - cabal new-build ${XCABFLAGS} -j1 all - - cabal new-test ${XCABFLAGS} -j1 all + - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) + # Packaging... + - ${CABAL} v2-sdist all | color_cabal_output + # Unpacking... + - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ + - cd ${DISTDIR} || false + - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; + - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; + - PKGDIR_hackage_security="$(find . -maxdepth 1 -type d -regex '.*/hackage-security-[0-9.]*')" + - PKGDIR_hackage_security_http_client="$(find . -maxdepth 1 -type d -regex '.*/hackage-security-http-client-[0-9.]*')" + - PKGDIR_example_client="$(find . -maxdepth 1 -type d -regex '.*/example-client-[0-9.]*')" + - PKGDIR_hackage_security_curl="$(find . -maxdepth 1 -type d -regex '.*/hackage-security-curl-[0-9.]*')" + - PKGDIR_hackage_root_tool="$(find . -maxdepth 1 -type d -regex '.*/hackage-root-tool-[0-9.]*')" + - PKGDIR_hackage_repo_tool="$(find . -maxdepth 1 -type d -regex '.*/hackage-repo-tool-[0-9.]*')" + - PKGDIR_hackage_security_HTTP="$(find . -maxdepth 1 -type d -regex '.*/hackage-security-HTTP-[0-9.]*')" + # Generate cabal.project + - rm -rf cabal.project cabal.project.local cabal.project.freeze + - touch cabal.project + - | + echo "packages: ${PKGDIR_hackage_security}" >> cabal.project + echo "packages: ${PKGDIR_hackage_security_http_client}" >> cabal.project + echo "packages: ${PKGDIR_example_client}" >> cabal.project + echo "packages: ${PKGDIR_hackage_security_curl}" >> cabal.project + echo "packages: ${PKGDIR_hackage_root_tool}" >> cabal.project + echo "packages: ${PKGDIR_hackage_repo_tool}" >> cabal.project + echo "packages: ${PKGDIR_hackage_security_HTTP}" >> cabal.project + - | + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(example-client|hackage-repo-tool|hackage-root-tool|hackage-security|hackage-security-HTTP|hackage-security-curl|hackage-security-http-client)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - cat cabal.project || true + - cat cabal.project.local || true + # Building... + # this builds all libraries and executables (without tests/benchmarks) + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output + # Building with tests and benchmarks... + # build & run tests, build benchmarks + - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output + # Testing... + - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output + # cabal check... + - (cd ${PKGDIR_hackage_security} && ${CABAL} -vnormal check) + - (cd ${PKGDIR_hackage_security_http_client} && ${CABAL} -vnormal check) + - (cd ${PKGDIR_example_client} && ${CABAL} -vnormal check) + - (cd ${PKGDIR_hackage_security_curl} && ${CABAL} -vnormal check) + - (cd ${PKGDIR_hackage_root_tool} && ${CABAL} -vnormal check) + - (cd ${PKGDIR_hackage_repo_tool} && ${CABAL} -vnormal check) + - (cd ${PKGDIR_hackage_security_HTTP} && ${CABAL} -vnormal check) + # haddock... + - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output + # Building without installed constraints for packages in global-db... + - rm -f cabal.project.local + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output +# REGENDATA ("0.7.20191101",["--ghc-head","--osx=8.4.4","cabal.project"]) # EOF diff --git a/hackage-security/cabal.haskell-ci b/hackage-security/cabal.haskell-ci new file mode 100644 --- /dev/null +++ b/hackage-security/cabal.haskell-ci @@ -0,0 +1,6 @@ +ghc-head: True +osx: 8.4.4 + +constraint-set no-lukko + ghc: >=8.2 + constraints: hackage-security -lukko diff --git a/hackage-security/cabal.project b/hackage-security/cabal.project --- a/hackage-security/cabal.project +++ b/hackage-security/cabal.project @@ -13,3 +13,5 @@ -- FIXME/TODO -- packages: precompute-fileinfo + +-- constraints: hackage-security -lukko diff --git a/hackage-security/example-client/example-client.cabal b/hackage-security/example-client/example-client.cabal --- a/hackage-security/example-client/example-client.cabal +++ b/hackage-security/example-client/example-client.cabal @@ -1,7 +1,7 @@ name: example-client version: 0.1.0.0 -synopsis: Example client using the Hackage security library --- description: +synopsis: Example hackage-security client +description: Example client using the hackage-security library. license: BSD3 license-file: LICENSE author: Edsko de Vries @@ -10,6 +10,8 @@ category: Distribution build-type: Simple cabal-version: >=1.10 +tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 flag use-network-uri description: Are we using network-uri? @@ -19,7 +21,7 @@ main-is: Main.hs other-modules: Prelude ExampleClient.Options - build-depends: base >= 4.4, + build-depends: base >= 4.5 && < 4.14, bytestring >= 0.9, Cabal >= 1.12, directory >= 1.1, @@ -43,6 +45,6 @@ -- see comments in hackage-security.cabal if flag(use-network-uri) build-depends: network-uri >= 2.6 && < 2.7, - network >= 2.6 && < 2.8 + network >= 2.6 && < 3.2 else build-depends: network >= 2.5 && < 2.6 diff --git a/hackage-security/hackage-repo-tool/hackage-repo-tool.cabal b/hackage-security/hackage-repo-tool/hackage-repo-tool.cabal --- a/hackage-security/hackage-repo-tool/hackage-repo-tool.cabal +++ b/hackage-security/hackage-repo-tool/hackage-repo-tool.cabal @@ -2,15 +2,18 @@ name: hackage-repo-tool version: 0.1.1.1 -synopsis: Utility to manage secure file-based package repositories +synopsis: Manage secure file-based package repositories description: This utility can be used to manage secure file-based package - repositories (creating [TUF](https://theupdateframework.github.io/) - metadata as well as a Hackage index tarball) which can be used by - clients such as [cabal-install](http://hackage.haskell.org/package/cabal-install). - Currently it also provides various lower level utilities for creating - and signing TUF files. + repositories (creating + [TUF](https://theupdateframework.github.io/) + metadata as well as a Hackage index tarball) which can be used + by clients such as + [cabal-install](http://hackage.haskell.org/package/cabal-install). + Currently it also provides various lower level utilities + for creating and signing TUF files. . - This is part of the [Hackage Security](https://github.com/haskell/hackage-security#readme) + This is part of the + [Hackage Security](https://github.com/haskell/hackage-security#readme) infrastructure. license: BSD3 license-file: LICENSE @@ -21,6 +24,8 @@ homepage: https://github.com/haskell/hackage-security bug-reports: https://github.com/haskell/hackage-security/issues build-type: Simple +tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 extra-source-files: ChangeLog.md @@ -48,15 +53,16 @@ Prelude build-depends: base >= 4.5 && < 5, - Cabal >= 1.14 && < 2.4, + Cabal >= 1.14 && < 3.1, bytestring >= 0.9 && < 0.11, directory >= 1.1 && < 1.4, filepath >= 1.2 && < 1.5, - optparse-applicative >= 0.11 && < 0.15, + microlens >= 0.4.11.2 && < 0.5, + optparse-applicative >= 0.11 && < 0.16, tar >= 0.4 && < 0.6, - time >= 1.2 && < 1.9, + time >= 1.2 && < 1.10, zlib >= 0.5 && < 0.7, - hackage-security >= 0.5 && < 0.6 + hackage-security >= 0.5 && < 0.7 if !os(windows) build-depends: unix >= 2.5 && < 2.8 @@ -69,7 +75,7 @@ -- see comments in hackage-security.cabal if flag(use-network-uri) build-depends: network-uri >= 2.6 && < 2.7, - network >= 2.6 && < 2.8 + network >= 2.6 && < 3.2 else build-depends: network >= 2.5 && < 2.6 diff --git a/hackage-security/hackage-repo-tool/src/Main.hs b/hackage-security/hackage-repo-tool/src/Main.hs --- a/hackage-security/hackage-repo-tool/src/Main.hs +++ b/hackage-security/hackage-repo-tool/src/Main.hs @@ -10,11 +10,13 @@ import Network.URI (URI) import System.Exit import qualified Data.ByteString.Lazy as BS.L +import qualified Lens.Micro as Lens import qualified System.FilePath as FilePath #ifndef mingw32_HOST_OS import System.IO.Error (isAlreadyExistsError) #endif +import System.IO.Error (isDoesNotExistError) -- Cabal import Distribution.Package @@ -23,12 +25,10 @@ -- hackage-security import Hackage.Security.Server import Hackage.Security.Util.Some -import Hackage.Security.Util.IO import Hackage.Security.Util.Path import Hackage.Security.Util.Pretty import qualified Hackage.Security.Key.Env as KeyEnv import qualified Hackage.Security.TUF.FileMap as FileMap -import qualified Hackage.Security.Util.Lens as Lens import Text.JSON.Canonical (JSValue) -- hackage-repo-tool @@ -678,3 +678,10 @@ throwErrors :: Exception e => Either e a -> IO a throwErrors (Left err) = throwIO err throwErrors (Right a) = return a + + +handleDoesNotExist :: IO a -> IO (Maybe a) +handleDoesNotExist act = handle aux (Just <$> act) + where + aux e | isDoesNotExistError e = return Nothing + | otherwise = throwIO e diff --git a/hackage-security/hackage-root-tool/hackage-root-tool.cabal b/hackage-security/hackage-root-tool/hackage-root-tool.cabal --- a/hackage-security/hackage-root-tool/hackage-root-tool.cabal +++ b/hackage-security/hackage-root-tool/hackage-root-tool.cabal @@ -1,6 +1,6 @@ name: hackage-root-tool version: 0.1.0.0 -synopsis: Utility for Hackage key holders to generate keys and sign root info. +synopsis: Generate Hackage keys and sign root info description: A command line tool for people who hold Hackage root keys. It can generate new keys, and can sign root information. . @@ -14,6 +14,8 @@ category: Distribution build-type: Simple cabal-version: >=1.10 +tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 extra-source-files: ChangeLog.md @@ -27,8 +29,8 @@ main-is: Main.hs build-depends: base >= 4.4 && < 5, filepath >= 1.2 && < 1.5, - optparse-applicative >= 0.11 && < 0.15, - hackage-security >= 0.5 && < 0.6 + optparse-applicative >= 0.11 && < 0.16, + hackage-security >= 0.5 && < 0.7 default-language: Haskell2010 other-extensions: CPP, ScopedTypeVariables, RecordWildCards ghc-options: -Wall diff --git a/hackage-security/hackage-security-HTTP/hackage-security-HTTP.cabal b/hackage-security/hackage-security-HTTP/hackage-security-HTTP.cabal --- a/hackage-security/hackage-security-HTTP/hackage-security-HTTP.cabal +++ b/hackage-security/hackage-security-HTTP/hackage-security-HTTP.cabal @@ -15,6 +15,8 @@ bug-reports: https://github.com/haskell/hackage-security/issues build-type: Simple cabal-version: >=1.10 +tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 extra-source-files: ChangeLog.md @@ -32,9 +34,9 @@ build-depends: base >= 4.4 && < 5, bytestring >= 0.9 && < 0.11, HTTP >= 4000.2.19 && < 4000.4, - mtl >= 2.2 && < 2.3, + mtl >= 2.1 && < 2.3, zlib >= 0.5 && < 0.7, - hackage-security >= 0.5 && < 0.6 + hackage-security >= 0.5 && < 0.7 hs-source-dirs: src default-language: Haskell2010 default-extensions: DeriveDataTypeable @@ -49,6 +51,6 @@ -- See comments in hackage-security.cabal if flag(use-network-uri) build-depends: network-uri >= 2.6 && < 2.7, - network >= 2.6 && < 2.8 + network >= 2.6 && < 3.2 else build-depends: network >= 2.5 && < 2.6 diff --git a/hackage-security/hackage-security-HTTP/src/Hackage/Security/Client/Repository/HttpLib/HTTP.hs b/hackage-security/hackage-security-HTTP/src/Hackage/Security/Client/Repository/HttpLib/HTTP.hs --- a/hackage-security/hackage-security-HTTP/src/Hackage/Security/Client/Repository/HttpLib/HTTP.hs +++ b/hackage-security/hackage-security-HTTP/src/Hackage/Security/Client/Repository/HttpLib/HTTP.hs @@ -31,7 +31,6 @@ import Hackage.Security.Client.Repository.HttpLib import Hackage.Security.Util.Checked import Hackage.Security.Util.Pretty -import qualified Hackage.Security.Util.Lens as Lens {------------------------------------------------------------------------------- Top-level API @@ -257,7 +256,14 @@ finalizeHeader (name, strs) = [(name, intercalate ", " (reverse strs))] insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] - insert x y = Lens.modify (Lens.lookupM x) (++ y) + insert x y = modifyAssocList x (++ y) + + -- modify the first maching element + modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)] + modifyAssocList a f = go where + go [] = [] + go (p@(a', b) : xs) | a == a' = (a', f b) : xs + | otherwise = p : go xs getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader] getResponseHeaders response = concat [ diff --git a/hackage-security/hackage-security-curl/hackage-security-curl.cabal b/hackage-security/hackage-security-curl/hackage-security-curl.cabal --- a/hackage-security/hackage-security-curl/hackage-security-curl.cabal +++ b/hackage-security/hackage-security-curl/hackage-security-curl.cabal @@ -1,6 +1,10 @@ name: hackage-security-curl version: 0.1.0.0 -synopsis: Hackage security bindings against curl (and other external downloaders) +synopsis: curl bindings for hackage-security +description: hackage-security bindings for curl (and other + external downloaders) + . + This is part of the Hackage Security infrastructure. homepage: http://github.com/well-typed/hackage-security/ license: BSD3 license-file: LICENSE @@ -10,6 +14,8 @@ category: Distribution build-type: Simple cabal-version: >=1.10 +tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 flag use-network-uri description: Are we using network-uri? @@ -17,7 +23,7 @@ library exposed-modules: Hackage.Security.Client.Repository.HttpLib.Curl - build-depends: base >= 4.4, + build-depends: base >= 4.5 && < 4.14, bytestring >= 0.9, process >= 1.1, hackage-security @@ -28,6 +34,6 @@ -- See comments in hackage-security.cabal if flag(use-network-uri) build-depends: network-uri >= 2.6 && < 2.7, - network >= 2.6 && < 2.8 + network >= 2.6 && < 3.2 else build-depends: network >= 2.5 && < 2.6 diff --git a/hackage-security/hackage-security-http-client/hackage-security-http-client.cabal b/hackage-security/hackage-security-http-client/hackage-security-http-client.cabal --- a/hackage-security/hackage-security-http-client/hackage-security-http-client.cabal +++ b/hackage-security/hackage-security-http-client/hackage-security-http-client.cabal @@ -1,6 +1,9 @@ name: hackage-security-http-client version: 0.1.1 -synopsis: Hackage security bindings for the http-client library +synopsis: hackage-security bindings for http-client +description: hackage-security bindings for the http-client library. + . + This is part of the Hackage Security infrastructure. homepage: http://github.com/well-typed/hackage-security/ license: BSD3 license-file: LICENSE @@ -10,6 +13,8 @@ category: Distribution build-type: Simple cabal-version: >=1.10 +tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 flag use-network-uri description: Are we using network-uri? @@ -17,12 +22,12 @@ library exposed-modules: Hackage.Security.Client.Repository.HttpLib.HttpClient - build-depends: base >= 4.4, + build-depends: base >= 4.5 && < 4.14, bytestring >= 0.9, data-default-class >= 0.0, - http-client >= 0.5 && < 0.6, + http-client >= 0.4 && < 0.7, http-types >= 0.8, - hackage-security >= 0.5 && < 0.6 + hackage-security >= 0.5 && < 0.7 hs-source-dirs: src default-language: Haskell2010 default-extensions: FlexibleContexts @@ -34,6 +39,6 @@ -- see comments in hackage-security.cabal if flag(use-network-uri) build-depends: network-uri >= 2.6 && < 2.7, - network >= 2.6 && < 2.8 + network >= 2.6 && < 3.2 else build-depends: network >= 2.5 && < 2.6 diff --git a/hackage-security/hackage-security-http-client/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs b/hackage-security/hackage-security-http-client/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs --- a/hackage-security/hackage-security-http-client/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs +++ b/hackage-security/hackage-security-http-client/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Hackage.Security.Client.Repository.HttpLib.HttpClient ( withClient @@ -20,7 +21,6 @@ import Hackage.Security.Client hiding (Header) import Hackage.Security.Client.Repository.HttpLib import Hackage.Security.Util.Checked -import qualified Hackage.Security.Util.Lens as Lens {------------------------------------------------------------------------------- Top-level API @@ -84,8 +84,15 @@ callback HttpStatus200OK (getResponseHeaders response) br _otherwise -> throwChecked $ +#if MIN_VERSION_http_client(0,5,0) HttpClient.HttpExceptionRequest request $ HttpClient.StatusCodeException (void response) BS.empty +#else + HttpClient.StatusCodeException + (HttpClient.responseStatus response) + (HttpClient.responseHeaders response) + (HttpClient.responseCookieJar response) +#endif -- | Wrap custom exceptions -- @@ -153,7 +160,14 @@ finalizeHeader (name, strs) = [(name, BS.intercalate ", " (reverse strs))] insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] - insert x y = Lens.modify (Lens.lookupM x) (++ y) + insert x y = modifyAssocList x (++ y) + + -- modify the first maching element + modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)] + modifyAssocList a f = go where + go [] = [] + go (p@(a', b) : xs) | a == a' = (a', f b) : xs + | otherwise = p : go xs -- | Extract the response headers getResponseHeaders :: HttpClient.Response a -> [HttpResponseHeader] diff --git a/hackage-security/hackage-security/ChangeLog.md b/hackage-security/hackage-security/ChangeLog.md --- a/hackage-security/hackage-security/ChangeLog.md +++ b/hackage-security/hackage-security/ChangeLog.md @@ -1,8 +1,17 @@ -unreleased ----------- +See also http://pvp.haskell.org/faq -* Allow `network-2.7.0.0` -* Allow `aeson-1.4.0.0` +0.6.0.0 +------- + +* Remove `Hackage.Security.TUF.FileMap.lookupM` +* Don't expose `Hackage.Security.Util.IO` module +* Don't expose `Hackage.Security.Util.Lens` module +* Report missing keys in `.meta` objects more appropriately as + `ReportSchemaErrors(expected)` instead of via `Monad(fail)` +* Add support for GHC 8.8 / base-4.13 +* Use `lukko` for file-locking +* Extend `LogMessage` to signal events for cache lock acquiring and release +* New `lockCacheWithLogger` operation 0.5.3.0 ------- diff --git a/hackage-security/hackage-security/hackage-security.cabal b/hackage-security/hackage-security/hackage-security.cabal --- a/hackage-security/hackage-security/hackage-security.cabal +++ b/hackage-security/hackage-security/hackage-security.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: hackage-security -version: 0.5.3.0 +version: 0.6.0.0 synopsis: Hackage security library description: The hackage security library provides both server and @@ -29,7 +29,10 @@ homepage: https://github.com/haskell/hackage-security bug-reports: https://github.com/haskell/hackage-security/issues build-type: Simple +tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 + extra-source-files: ChangeLog.md @@ -50,6 +53,16 @@ manual: False default: False +flag mtl21 + description: Use @mtl@ < 2.2 and @mtl-compat@ + manual: False + default: False + +flag lukko + description: Use @lukko@ for file-locking, otherwise use @GHC.IO.Handle.Lock@ + manual: True + default: True + library -- Most functionality is exported through the top-level entry points .Client -- and .Server; the other exported modules are intended for qualified imports. @@ -67,8 +80,6 @@ Hackage.Security.Trusted Hackage.Security.TUF.FileMap Hackage.Security.Util.Checked - Hackage.Security.Util.IO - Hackage.Security.Util.Lens Hackage.Security.Util.Path Hackage.Security.Util.Pretty Hackage.Security.Util.Some @@ -92,40 +103,52 @@ Hackage.Security.TUF.Timestamp Hackage.Security.Util.Base64 Hackage.Security.Util.Exit - Hackage.Security.Util.FileLock + Hackage.Security.Util.IO Hackage.Security.Util.JSON + Hackage.Security.Util.Lens Hackage.Security.Util.Stack Hackage.Security.Util.TypedEmbedded Prelude -- We support ghc 7.4 (bundled with Cabal 1.14) and up - build-depends: base >= 4.5 && < 4.13, + build-depends: base >= 4.5 && < 4.14, base16-bytestring >= 0.1.1 && < 0.2, base64-bytestring >= 1.0 && < 1.1, bytestring >= 0.9 && < 0.11, - Cabal >= 1.14 && < 2.6, + Cabal >= 1.14 && < 1.26 + || >= 2.0 && < 2.6 + || >= 3.0 && < 3.2, containers >= 0.4 && < 0.7, ed25519 >= 0.0 && < 0.1, filepath >= 1.2 && < 1.5, - mtl >= 2.2 && < 2.3, parsec >= 3.1 && < 3.2, pretty >= 1.0 && < 1.2, cryptohash-sha256 >= 0.11 && < 0.12, -- 0.4.2 introduces TarIndex, 0.4.4 introduces more -- functionality, 0.5.0 changes type of serialise tar >= 0.5 && < 0.6, - time >= 1.2 && < 1.9, - transformers >= 0.4 && < 0.6, + time >= 1.2 && < 1.10, + transformers >= 0.3 && < 0.6, zlib >= 0.5 && < 0.7, -- whatever versions are bundled with ghc: template-haskell, ghc-prim if flag(old-directory) - build-depends: directory >= 1.1.0.2 && < 1.2, - old-time >= 1 && < 1.2 + build-depends: directory >= 1.1.0.2 && < 1.2, + old-time >= 1 && < 1.2 else - build-depends: directory >= 1.2 && < 1.4 - build-tool-depends: hsc2hs:hsc2hs >= 0.67 && <0.69 + build-depends: directory >= 1.2 && < 1.4 + if flag(mtl21) + build-depends: mtl >= 2.1 && < 2.2, + mtl-compat >= 0.2 && < 0.3 + else + build-depends: mtl >= 2.2 && < 2.3 + + if flag(lukko) + build-depends: lukko >= 0.1 && < 0.2 + else + build-depends: base >= 4.10 + hs-source-dirs: src default-language: Haskell2010 default-extensions: DefaultSignatures @@ -201,6 +224,7 @@ if flag(use-network-uri) build-depends: network-uri >= 2.6 && < 2.7, network >= 2.6 && < 2.9 + || >= 3.0 && < 3.2 else build-depends: network >= 2.5 && < 2.6 @@ -234,14 +258,14 @@ zlib -- dependencies exclusive to test-suite - build-depends: tasty == 1.0.*, + build-depends: tasty == 1.2.*, tasty-hunit == 0.10.*, tasty-quickcheck == 0.10.*, - QuickCheck == 2.11.*, + QuickCheck >= 2.11 && <2.14, aeson == 1.4.*, vector == 0.12.*, unordered-containers >=0.2.8.0 && <0.3, - temporary == 1.2.* + temporary >= 1.2 && < 1.4 hs-source-dirs: tests default-language: Haskell2010 diff --git a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository.hs b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository.hs @@ -316,6 +316,27 @@ -- (we will try with a different mirror if any are available) | LogMirrorFailed MirrorDescription SomeException + -- | This log event is triggered before invoking a filesystem lock + -- operation that may block for a significant amount of time; once + -- the possibly blocking call completes successfully, + -- 'LogLockWaitDone' will be emitted. + -- + -- @since 0.6.0 + | LogLockWait (Path Absolute) + + -- | Denotes completion of the operation that advertised a + -- 'LogLockWait' event + -- + -- @since 0.6.0 + | LogLockWaitDone (Path Absolute) + + -- | Denotes the filesystem lock previously acquired (signaled by + -- 'LogLockWait') has been released. + -- + -- @since 0.6.0 + | LogUnlock (Path Absolute) + + -- | Records why we are downloading a file rather than updating it. data UpdateFailure = -- | Server does not support incremental downloads @@ -451,6 +472,12 @@ "Cannot update " ++ pretty file ++ " (" ++ pretty ex ++ ")" pretty (LogMirrorFailed mirror ex) = "Exception " ++ displayException ex ++ " when using mirror " ++ mirror + pretty (LogLockWait file) = + "Waiting to acquire cache lock on " ++ pretty file + pretty (LogLockWaitDone file) = + "Acquired cache lock on " ++ pretty file + pretty (LogUnlock file) = + "Released cache lock on " ++ pretty file instance Pretty UpdateFailure where pretty UpdateImpossibleUnsupported = diff --git a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Cache.hs b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Cache.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Cache.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Cache.hs @@ -12,6 +12,7 @@ , getIndexIdx , cacheRemoteFile , lockCache + , lockCacheWithLogger ) where import Control.Exception @@ -214,7 +215,18 @@ -- This avoids two concurrent processes updating the cache at the same time, -- provided they both take the lock. lockCache :: Cache -> IO () -> IO () -lockCache Cache{..} = withDirLock cacheRoot +lockCache Cache{..} = withDirLock (\_ -> return ()) cacheRoot + +-- | Variant of 'lockCache' which emits 'LogMessage's before and after +-- a possibly blocking file-locking system call +-- +-- @since 0.6.0 +lockCacheWithLogger :: (LogMessage -> IO ()) -> Cache -> IO () -> IO () +lockCacheWithLogger logger Cache{..} = withDirLock logger' cacheRoot + where + logger' (WithDirLockEventPre fn) = logger (LogLockWait fn) + logger' (WithDirLockEventPost fn) = logger (LogLockWaitDone fn) + logger' (WithDirLockEventUnlock fn) = logger (LogUnlock fn) {------------------------------------------------------------------------------- Auxiliary: tar diff --git a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Local.hs b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Local.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Local.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Local.hs @@ -51,7 +51,7 @@ , repClearCache = clearCache cache , repWithIndex = withIndex cache , repGetIndexIdx = getIndexIdx cache - , repLockCache = lockCache cache + , repLockCache = lockCacheWithLogger logger cache , repWithMirror = mirrorsUnsupported , repLog = logger , repLayout = repLayout diff --git a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Remote.hs b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Remote.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Remote.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Client/Repository/Remote.hs @@ -178,7 +178,7 @@ , repClearCache = Cache.clearCache cache , repWithIndex = Cache.withIndex cache , repGetIndexIdx = Cache.getIndexIdx cache - , repLockCache = Cache.lockCache cache + , repLockCache = Cache.lockCacheWithLogger logger cache , repWithMirror = withMirror httpLib selectedMirror logger diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/FileMap.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/FileMap.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/FileMap.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/FileMap.hs @@ -13,8 +13,6 @@ , (!) , insert , fromList - -- * Convenience accessors - , lookupM -- * Comparing file maps , FileChange(..) , fileMapChanges @@ -70,16 +68,6 @@ fromList :: [(TargetPath, FileInfo)] -> FileMap fromList = FileMap . Map.fromList - -{------------------------------------------------------------------------------- - Convenience accessors --------------------------------------------------------------------------------} - -lookupM :: Monad m => FileMap -> TargetPath -> m FileInfo -lookupM m fp = - case lookup fp m of - Nothing -> fail $ "No entry for " ++ pretty fp ++ " in filemap" - Just nfo -> return nfo {------------------------------------------------------------------------------- Comparing filemaps diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Snapshot.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Snapshot.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Snapshot.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Snapshot.hs @@ -13,6 +13,7 @@ import Hackage.Security.TUF.Layout.Repo import Hackage.Security.TUF.Signed import qualified Hackage.Security.TUF.FileMap as FileMap +import Hackage.Security.Util.Pretty (pretty) {------------------------------------------------------------------------------- Datatypes @@ -76,9 +77,12 @@ snapshotVersion <- fromJSField enc "version" snapshotExpires <- fromJSField enc "expires" snapshotMeta <- fromJSField enc "meta" - snapshotInfoRoot <- FileMap.lookupM snapshotMeta (pathRoot repoLayout) - snapshotInfoMirrors <- FileMap.lookupM snapshotMeta (pathMirrors repoLayout) - snapshotInfoTarGz <- FileMap.lookupM snapshotMeta (pathIndexTarGz repoLayout) + let lookupMeta k = case FileMap.lookup k snapshotMeta of + Nothing -> expected ("\"" ++ pretty k ++ "\" entry in .meta object") Nothing + Just v -> pure v + snapshotInfoRoot <- lookupMeta (pathRoot repoLayout) + snapshotInfoMirrors <- lookupMeta (pathMirrors repoLayout) + snapshotInfoTarGz <- lookupMeta (pathIndexTarGz repoLayout) let snapshotInfoTar = FileMap.lookup (pathIndexTar repoLayout) snapshotMeta return Snapshot{..} diff --git a/hackage-security/hackage-security/src/Hackage/Security/TUF/Timestamp.hs b/hackage-security/hackage-security/src/Hackage/Security/TUF/Timestamp.hs --- a/hackage-security/hackage-security/src/Hackage/Security/TUF/Timestamp.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/TUF/Timestamp.hs @@ -13,6 +13,7 @@ import Hackage.Security.TUF.Layout.Repo import Hackage.Security.TUF.Signed import qualified Hackage.Security.TUF.FileMap as FileMap +import Hackage.Security.Util.Pretty (pretty) {------------------------------------------------------------------------------- Datatypes @@ -56,7 +57,10 @@ timestampVersion <- fromJSField enc "version" timestampExpires <- fromJSField enc "expires" timestampMeta <- fromJSField enc "meta" - timestampInfoSnapshot <- FileMap.lookupM timestampMeta (pathSnapshot repoLayout) + let lookupMeta k = case FileMap.lookup k timestampMeta of + Nothing -> expected ("\"" ++ pretty k ++ "\" entry in .meta object") Nothing + Just v -> pure v + timestampInfoSnapshot <- lookupMeta (pathSnapshot repoLayout) return Timestamp{..} instance (MonadKeys m, MonadReader RepoLayout m) => FromJSON m (Signed Timestamp) where diff --git a/hackage-security/hackage-security/src/Hackage/Security/Util/FileLock.hsc b/hackage-security/hackage-security/src/Hackage/Security/Util/FileLock.hsc deleted file mode 100644 --- a/hackage-security/hackage-security/src/Hackage/Security/Util/FileLock.hsc +++ /dev/null @@ -1,202 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE InterruptibleFFI #-} -{-# LANGUAGE DeriveDataTypeable #-} - --- | This compat module can be removed once base-4.10 (ghc-8.2) is the minimum --- required version. Though note that the locking functionality is not in --- public modules in base-4.10, just in the "GHC.IO.Handle.Lock" module. --- --- Copied from @cabal-install@ codebase "Distribution.Client.Compat.FileLock". -module Hackage.Security.Util.FileLock ( - FileLockingNotSupported(..) - , LockMode(..) - , hLock - , hTryLock - ) where - -#if MIN_VERSION_base(4,10,0) - -import GHC.IO.Handle.Lock - -#else - --- The remainder of this file is a modified copy --- of GHC.IO.Handle.Lock from ghc-8.2.x --- --- The modifications were just to the imports and the CPP, since we do not have --- access to the HAVE_FLOCK from the ./configure script. We approximate the --- lack of HAVE_FLOCK with @defined(solaris2_HOST_OS) || defined(aix_HOST_OS)@ --- instead since those are known major Unix platforms lacking @flock()@ or --- having broken one. - -import Control.Exception (Exception) -import Data.Typeable - -#if defined(solaris2_HOST_OS) || defined(aix_HOST_OS) - -import Control.Exception (throwIO) -import System.IO (Handle) - -#else - -import Data.Bits -import Data.Function -import Control.Concurrent.MVar - -import Foreign.C.Error -import Foreign.C.Types - -import GHC.IO.Handle.Types -import GHC.IO.FD -import GHC.IO.Exception - -#if defined(mingw32_HOST_OS) - -#if defined(i386_HOST_ARCH) -## define WINDOWS_CCONV stdcall -#elif defined(x86_64_HOST_ARCH) -## define WINDOWS_CCONV ccall -#else -# error Unknown mingw32 arch -#endif - -#include - -import Foreign.Marshal.Alloc -import Foreign.Marshal.Utils -import Foreign.Ptr -import GHC.Windows - -#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */ - -#include - -#endif /* !defined(mingw32_HOST_OS) */ - -#endif /* !(defined(solaris2_HOST_OS) || defined(aix_HOST_OS)) */ - - --- | Exception thrown by 'hLock' on non-Windows platforms that don't support --- 'flock'. -data FileLockingNotSupported = FileLockingNotSupported - deriving (Typeable, Show) - -instance Exception FileLockingNotSupported - - --- | Indicates a mode in which a file should be locked. -data LockMode = SharedLock | ExclusiveLock - --- | If a 'Handle' references a file descriptor, attempt to lock contents of the --- underlying file in appropriate mode. If the file is already locked in --- incompatible mode, this function blocks until the lock is established. The --- lock is automatically released upon closing a 'Handle'. --- --- Things to be aware of: --- --- 1) This function may block inside a C call. If it does, in order to be able --- to interrupt it with asynchronous exceptions and/or for other threads to --- continue working, you MUST use threaded version of the runtime system. --- --- 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise, --- hence all of their caveats also apply here. --- --- 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this --- function throws 'FileLockingNotImplemented'. We deliberately choose to not --- provide fcntl based locking instead because of its broken semantics. --- --- @since 4.10.0.0 -hLock :: Handle -> LockMode -> IO () -hLock h mode = lockImpl h "hLock" mode True >> return () - --- | Non-blocking version of 'hLock'. --- --- @since 4.10.0.0 -hTryLock :: Handle -> LockMode -> IO Bool -hTryLock h mode = lockImpl h "hTryLock" mode False - ----------------------------------------- - -#if defined(solaris2_HOST_OS) || defined(aix_HOST_OS) - --- | No-op implementation. -lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool -lockImpl _ _ _ _ = throwIO FileLockingNotSupported - -#else /* !(defined(solaris2_HOST_OS) || defined(aix_HOST_OS)) */ - -#if defined(mingw32_HOST_OS) - -lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool -lockImpl h ctx mode block = do - FD{fdFD = fd} <- handleToFd h - wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd - allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do - fillBytes ovrlpd (fromIntegral sizeof_OVERLAPPED) 0 - let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY}) - -- We want to lock the whole file without looking up its size to be - -- consistent with what flock does. According to documentation of LockFileEx - -- "locking a region that goes beyond the current end-of-file position is - -- not an error", however e.g. Windows 10 doesn't accept maximum possible - -- value (a pair of MAXDWORDs) for mysterious reasons. Work around that by - -- trying 2^32-1. - fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x0 ovrlpd >>= \b -> case b of - True -> return True - False -> getLastError >>= \err -> case () of - () | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False - | err == #{const ERROR_OPERATION_ABORTED} -> retry - | otherwise -> failWith ctx err - where - sizeof_OVERLAPPED = #{size OVERLAPPED} - - cmode = case mode of - SharedLock -> 0 - ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK} - --- https://msdn.microsoft.com/en-us/library/aa297958.aspx -foreign import ccall unsafe "_get_osfhandle" - c_get_osfhandle :: CInt -> IO HANDLE - --- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx -foreign import WINDOWS_CCONV interruptible "LockFileEx" - c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL - -#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */ - -lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool -lockImpl h ctx mode block = do - FD{fdFD = fd} <- handleToFd h - let flags = cmode .|. (if block then 0 else #{const LOCK_NB}) - fix $ \retry -> c_flock fd flags >>= \n -> case n of - 0 -> return True - _ -> getErrno >>= \errno -> case () of - () | not block && errno == eWOULDBLOCK -> return False - | errno == eINTR -> retry - | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing - where - cmode = case mode of - SharedLock -> #{const LOCK_SH} - ExclusiveLock -> #{const LOCK_EX} - -foreign import ccall interruptible "flock" - c_flock :: CInt -> CInt -> IO CInt - -#endif /* !defined(mingw32_HOST_OS) */ - --- | Turn an existing Handle into a file descriptor. This function throws an --- IOError if the Handle does not reference a file descriptor. -handleToFd :: Handle -> IO FD -handleToFd h = case h of - FileHandle _ mv -> do - Handle__{haDevice = dev} <- readMVar mv - case cast dev of - Just fd -> return fd - Nothing -> throwErr "not a file descriptor" - DuplexHandle{} -> throwErr "not a file handle" - where - throwErr msg = ioException $ IOError (Just h) - InappropriateType "handleToFd" msg Nothing Nothing - -#endif /* defined(solaris2_HOST_OS) || defined(aix_HOST_OS) */ - -#endif /* MIN_VERSION_base */ diff --git a/hackage-security/hackage-security/src/Hackage/Security/Util/IO.hs b/hackage-security/hackage-security/src/Hackage/Security/Util/IO.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Util/IO.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Util/IO.hs @@ -1,21 +1,31 @@ +{-# LANGUAGE CPP #-} module Hackage.Security.Util.IO ( -- * Miscelleneous getFileSize , handleDoesNotExist + , WithDirLockEvent(..) , withDirLock -- * Debugging , timedIO ) where -import Control.Monad (unless) +import Control.Concurrent (threadDelay) import Control.Exception import Data.Time import System.IO hiding (openTempFile, withFile) import System.IO.Error import Hackage.Security.Util.Path -import Hackage.Security.Util.FileLock (hTryLock, LockMode(ExclusiveLock), FileLockingNotSupported) +#ifdef MIN_VERSION_lukko +import Lukko (FD, fileLockingSupported, fdOpen, fdClose, fdLock, fdUnlock, LockMode(ExclusiveLock)) +#else +import GHC.IO.Handle.Lock (hLock, LockMode(ExclusiveLock), FileLockingNotSupported) +#if MIN_VERSION_base(4,11,0) +import GHC.IO.Handle.Lock (hUnlock) +#endif +#endif + {------------------------------------------------------------------------------- Miscelleneous -------------------------------------------------------------------------------} @@ -32,21 +42,32 @@ then return Nothing else throwIO e + +data WithDirLockEvent + = WithDirLockEventPre (Path Absolute) + | WithDirLockEventPost (Path Absolute) + | WithDirLockEventUnlock (Path Absolute) + -- | Attempt to create a filesystem lock in the specified directory. -- -- This will use OS-specific file locking primitives: "GHC.IO.Handle.Lock" with -- @base-4.10" and later or a shim for @base@ versions. -- --- Throws an exception if the lock is already present. +-- Blocks if the lock is already present. -- +-- The logger callback passed as first argument is invoked before and +-- after acquiring a lock, and after unlocking. +-- -- May fallback to locking via creating a directory: -- Given a file @/path/to@, we do this by attempting to create the directory -- @//path/to/hackage-security-lock@, and deleting the directory again -- afterwards. Creating a directory that already exists will throw an exception -- on most OSs (certainly Linux, OSX and Windows) and is a reasonably common way -- to implement a lock file. -withDirLock :: Path Absolute -> IO a -> IO a -withDirLock dir = bracket takeLock releaseLock . const +withDirLock :: (WithDirLockEvent -> IO ()) -> Path Absolute -> IO a -> IO a +withDirLock logger dir + = bracket takeLock (\h -> releaseLock h >> logger (WithDirLockEventUnlock lock)) + . const where lock :: Path Absolute lock = dir fragment "hackage-security-lock" @@ -54,29 +75,78 @@ lock' :: FilePath lock' = toFilePath lock + me = "Hackage.Security.Util.IO.withDirLock: " + + wrapLog :: IO a -> IO a + wrapLog op = do + logger (WithDirLockEventPre lock) + h <- op + logger (WithDirLockEventPost lock) + return h + +#ifdef MIN_VERSION_lukko + takeLock :: IO FD + takeLock + | fileLockingSupported = do + h <- fdOpen lock' + wrapLog (fdLock h ExclusiveLock `onException` fdClose h) + return h + | otherwise = wrapLog takeDirLock + where + takeDirLock :: IO FD + takeDirLock = handle onCreateDirError $ do + createDirectory lock + return (undefined :: FD) + + onCreateDirError :: IOError -> IO FD + onCreateDirError ioe + | isAlreadyExistsError ioe = threadDelay (1*1000*1000) >> takeDirLock + | otherwise = fail (me++"error creating directory lock: "++show ioe) + + releaseLock h + | fileLockingSupported = do + fdUnlock h + fdClose h + | otherwise = + removeDirectory lock + +#else takeLock = do h <- openFile lock' ReadWriteMode - handle (takeDirLock h) $ do - gotlock <- hTryLock h ExclusiveLock - unless gotlock $ - fail $ "hTryLock: lock already exists: " ++ lock' + wrapLog $ handle (fallbackToDirLock h) $ do + hLock h ExclusiveLock return (Just h) - takeDirLock :: Handle -> FileLockingNotSupported -> IO (Maybe Handle) - takeDirLock h _ = do - -- We fallback to directory locking - -- so we need to cleanup lock file first: close and remove - hClose h - handle onIOError (removeFile lock) - createDirectory lock - return Nothing - onIOError :: IOError -> IO () - onIOError _ = hPutStrLn stderr - "withDirLock: cannot remove lock file before directory lock fallback" + -- If file locking isn't supported then we fallback to directory locking, + -- polling if necessary. + fallbackToDirLock :: Handle -> FileLockingNotSupported -> IO (Maybe Handle) + fallbackToDirLock h _ = takeDirLock >> return Nothing + where + takeDirLock :: IO () + takeDirLock = do + -- We fallback to directory locking + -- so we need to cleanup lock file first: close and remove + hClose h + handle onIOError (removeFile lock) + handle onCreateDirError (createDirectory lock) - releaseLock (Just h) = hClose h + onCreateDirError :: IOError -> IO () + onCreateDirError ioe + | isAlreadyExistsError ioe = threadDelay (1*1000*1000) >> takeDirLock + | otherwise = fail (me++"error creating directory lock: "++show ioe) + + onIOError :: IOError -> IO () + onIOError _ = hPutStrLn stderr + (me++"cannot remove lock file before directory lock fallback") + + releaseLock (Just h) = + hClose h +#if MIN_VERSION_base(4,11,0) + >> hUnlock h +#endif releaseLock Nothing = removeDirectory lock +#endif {------------------------------------------------------------------------------- Debugging diff --git a/hackage-security/hackage-security/src/Hackage/Security/Util/Lens.hs b/hackage-security/hackage-security/src/Hackage/Security/Util/Lens.hs --- a/hackage-security/hackage-security/src/Hackage/Security/Util/Lens.hs +++ b/hackage-security/hackage-security/src/Hackage/Security/Util/Lens.hs @@ -7,11 +7,11 @@ -- * Generic definitions Lens , Lens' + , Traversal + , Traversal' , get - , modify + , over , set - -- * Specific lenses - , lookupM ) where import Control.Applicative @@ -22,27 +22,25 @@ -------------------------------------------------------------------------------} -- | Polymorphic lens -type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t +type Lens s t a b = forall f. Functor f => LensLike f s t a b -- | Monomorphic lens type Lens' s a = Lens s s a a -get :: Lens' s a -> s -> a -get l = getConst . l Const +-- | Polymorphic traversal +type Traversal s t a b = forall f. Applicative f => LensLike f s t a b -modify :: Lens s t a b -> (a -> b) -> s -> t -modify l f = runIdentity . l (Identity . f) +-- | Monomorphic traversal +type Traversal' s a = Traversal s s a a -set :: Lens s t a b -> b -> s -> t -set l = modify l . const +type LensLike f s t a b = (a -> f b) -> s -> f t +type LensLike' f s a = LensLike f s s a a -{------------------------------------------------------------------------------- - Specific lenses --------------------------------------------------------------------------------} +get :: LensLike' (Const a) s a -> s -> a +get l = getConst . l Const -lookupM :: forall a b. (Eq a, Monoid b) => a -> Lens' [(a, b)] b -lookupM a f = go - where - go [] = (\b' -> [(a, b')] ) <$> f mempty - go ((a', b):xs) | a == a' = (\b' -> (a, b'):xs ) <$> f b - | otherwise = (\xs' -> (a', b):xs') <$> go xs +over :: LensLike Identity s t a b -> (a -> b) -> s -> t +over l f = runIdentity . l (Identity . f) + +set :: LensLike Identity s t a b -> b -> s -> t +set l = over l . const diff --git a/hackage-security/hackage-security/tests/TestSuite.hs b/hackage-security/hackage-security/tests/TestSuite.hs --- a/hackage-security/hackage-security/tests/TestSuite.hs +++ b/hackage-security/hackage-security/tests/TestSuite.hs @@ -284,6 +284,9 @@ , downloading isMirrors , noLocalCopy , downloading isIndex + , lockingWait + , lockingWaitDone + , lockingRelease ] -- | Log messages when we do a check for updates and there are no changes @@ -291,6 +294,9 @@ msgsNoUpdates = [ selectedMirror inMemURI , downloading isTimestamp + , lockingWait + , lockingWaitDone + , lockingRelease ] -- | Log messages we expect when the timestamp and snapshot have been resigned @@ -299,6 +305,9 @@ selectedMirror inMemURI , downloading isTimestamp , downloading isSnapshot + , lockingWait + , lockingWaitDone + , lockingRelease ] -- | Log messages we expect when the timestamp key has been rolled over @@ -308,12 +317,18 @@ , downloading isTimestamp , verificationError $ unknownKeyError timestampPath , downloading isRoot + , lockingWait + , lockingWaitDone + , lockingRelease , downloading isTimestamp , downloading isSnapshot -- Since we delete the timestamp and snapshot on a root info change, -- we will then conclude that we need to update the mirrors and the index. , downloading isMirrors , updating isIndex + , lockingWait + , lockingWaitDone + , lockingRelease ] {------------------------------------------------------------------------------- @@ -336,6 +351,14 @@ updating isFile (LogUpdating file) = isFile file updating _ _ = False +lockingWait, lockingWaitDone, lockingRelease :: LogMessage -> Bool +lockingWait (LogLockWait _) = True +lockingWait _ = False +lockingWaitDone (LogLockWaitDone _) = True +lockingWaitDone _ = False +lockingRelease (LogUnlock _) = True +lockingRelease _ = False + expired :: TargetPath -> VerificationError -> Bool expired f (VerificationErrorExpired f') = f == f' expired _ _ = False @@ -494,6 +517,9 @@ bootstrapMsgs :: [LogMessage -> Bool] bootstrapMsgs = [ selectedMirror inMemURI , downloading isRoot + , lockingWait + , lockingWaitDone + , lockingRelease ] layout :: RepoLayout diff --git a/hackage-security/hackage-security/tests/TestSuite/JSON.hs b/hackage-security/hackage-security/tests/TestSuite/JSON.hs --- a/hackage-security/hackage-security/tests/TestSuite/JSON.hs +++ b/hackage-security/hackage-security/tests/TestSuite/JSON.hs @@ -18,12 +18,12 @@ import Text.JSON.Canonical -- aeson -import Data.Aeson (Value (..), eitherDecode, FromJSON (..)) +import Data.Aeson (Value (..), eitherDecode) import Data.String (fromString) import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM -prop_roundtrip_canonical, prop_roundtrip_pretty, prop_canonical_pretty +prop_aeson_canonical, prop_roundtrip_canonical, prop_roundtrip_pretty, prop_canonical_pretty :: JSValue -> Bool prop_roundtrip_canonical jsval = diff --git a/hackage-security/precompute-fileinfo/precompute-fileinfo.cabal b/hackage-security/precompute-fileinfo/precompute-fileinfo.cabal --- a/hackage-security/precompute-fileinfo/precompute-fileinfo.cabal +++ b/hackage-security/precompute-fileinfo/precompute-fileinfo.cabal @@ -1,6 +1,10 @@ name: precompute-fileinfo version: 0.1.0.0 synopsis: Precompute fileinfo for faster Hackage migration +description: Utility for precomputing fileinfo + for faster Hackage migration. + . + This is part of the Hackage Security infrastructure. license: BSD3 license-file: LICENSE author: Edsko de Vries @@ -9,6 +13,8 @@ category: Distribution build-type: Simple cabal-version: >=1.10 +tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, + GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 executable precompute-fileinfo main-is: Main.hs diff --git a/hackport.cabal b/hackport.cabal --- a/hackport.cabal +++ b/hackport.cabal @@ -1,5 +1,5 @@ Name: hackport -Version: 0.6.4 +Version: 0.6.5 License: GPL License-file: LICENSE Author: Henning Günther, Duncan Coutts, Lennart Kolmodin @@ -27,41 +27,44 @@ cabal/cabal-install, hackage-security/hackage-security/src Build-Depends: - array, - base >= 2.0 && < 5, - deepseq >= 1.3, + array >= 0.4.0.1, + base >= 4.8 && < 5, + bytestring >= 0.10, + containers >= 0.5, + deepseq >= 1.3.0.1, + directory >= 1.2, extensible-exceptions, - filepath, - HTTP >= 4000.0.3, - MissingH, + filepath >= 1.3.0.1, + HTTP >= 4000.1.5, network >= 2.6, network-uri >= 2.6, - parsec, - pretty, - old-locale, - regex-compat, + parsec >= 3.1.13, + pretty >= 1.1.1, + process >= 1.1.0.2, + old-locale >= 1.0, split, tar >= 0.5, - time, - zlib, + time >= 1.4.0.1, + zlib >= 0.5.3, xml >= 1.3.7, -- cabal depends - binary, - random, - stm, - text, - unix, + binary >= 0.5.1.1, + text >= 1.2.3.0, + transformers >= 0.3, + unix >= 2.5, -- cabal-install depends - async, + async >= 2.0, + hashable >= 1.0, + random >= 1.0, + stm >= 2.0, -- hackage-security depends - base16-bytestring, - base64-bytestring, - cryptohash, + base16-bytestring >= 0.1.1, + base64-bytestring >= 1.0, + cryptohash-sha256 >= 0.11, ed25519, ghc-prim, - hashable, - mtl, - template-haskell, - transformers + lukko >= 0.1, + mtl >= 2.1, + template-haskell default-extensions: -- hackage-security @@ -100,37 +103,349 @@ RecordWildCards, TypeOperators - Build-Depends: - base >= 3 && < 5, - directory, - containers, - process, - old-time, - bytestring - other-modules: + -- hackport modules AnsiColor Cabal2Ebuild Error + HackPort.GlobalFlags + Merge + Merge.Dependencies Overlays Paths_hackport - Portage.Version + Portage.Cabal Portage.Dependency + Portage.Dependency.Builder + Portage.Dependency.Normalize + Portage.Dependency.Print + Portage.Dependency.Types Portage.EBuild Portage.EBuild.CabalFeature Portage.EBuild.Render + Portage.EMeta Portage.GHCCore - Portage.PackageId + Portage.Host + Portage.Metadata Portage.Overlay + Portage.PackageId Portage.Resolve - Portage.Host Portage.Tables - Merge.Dependencies + Portage.Use + Portage.Version Status - Merge Util - -- hsc files - Hackage.Security.Util.FileLock + -- cabal modules + Distribution.Backpack + Distribution.Backpack.ComponentsGraph + Distribution.Backpack.Configure + Distribution.Backpack.ConfiguredComponent + Distribution.Backpack.DescribeUnitId + Distribution.Backpack.FullUnitId + Distribution.Backpack.Id + Distribution.Backpack.LinkedComponent + Distribution.Backpack.MixLink + Distribution.Backpack.ModSubst + Distribution.Backpack.ModuleScope + Distribution.Backpack.ModuleShape + Distribution.Backpack.PreExistingComponent + Distribution.Backpack.PreModuleShape + Distribution.Backpack.ReadyComponent + Distribution.Backpack.UnifyM + Distribution.CabalSpecVersion + Distribution.Client.BuildReports.Types + Distribution.Client.CmdInstall.ClientInstallFlags + Distribution.Client.Compat.Directory + Distribution.Client.Compat.Prelude + Distribution.Client.Compat.Semaphore + Distribution.Client.Config + Distribution.Client.Dependency.Types + Distribution.Client.FetchUtils + Distribution.Client.GZipUtils + Distribution.Client.GlobalFlags + Distribution.Client.HttpUtils + Distribution.Client.IndexUtils + Distribution.Client.IndexUtils.Timestamp + Distribution.Client.Init.Types + Distribution.Client.InstallPlan + Distribution.Client.InstallSymlink + Distribution.Client.JobControl + Distribution.Client.ParseUtils + Distribution.Client.Security.DNS + Distribution.Client.Security.HTTP + Distribution.Client.Setup + Distribution.Client.SolverInstallPlan + Distribution.Client.SourceRepo + Distribution.Client.Tar + Distribution.Client.Targets + Distribution.Client.Types + Distribution.Client.Update + Distribution.Client.Utils + Distribution.Client.World + Distribution.Compat.Async + Distribution.Compat.Binary + Distribution.Compat.CharParsing + Distribution.Compat.CopyFile + Distribution.Compat.CreatePipe + Distribution.Compat.DList + Distribution.Compat.Directory + Distribution.Compat.Environment + Distribution.Compat.Exception + Distribution.Compat.FilePath + Distribution.Compat.Graph + Distribution.Compat.Internal.TempFile + Distribution.Compat.Lens + Distribution.Compat.MD5 + Distribution.Compat.MonadFail + Distribution.Compat.Newtype + Distribution.Compat.Parsing + Distribution.Compat.Prelude + Distribution.Compat.Prelude.Internal + Distribution.Compat.Semigroup + Distribution.Compat.Stack + Distribution.Compat.Time + Distribution.Compiler + Distribution.Deprecated.ParseUtils + Distribution.Deprecated.ReadP + Distribution.Deprecated.Text + Distribution.Deprecated.ViewAsFieldDescr + Distribution.FieldGrammar + Distribution.FieldGrammar.Class + Distribution.FieldGrammar.FieldDescrs + Distribution.FieldGrammar.Parsec + Distribution.FieldGrammar.Pretty + Distribution.Fields + Distribution.Fields.ConfVar + Distribution.Fields.Field + Distribution.Fields.Lexer + Distribution.Fields.LexerMonad + Distribution.Fields.ParseResult + Distribution.Fields.Parser + Distribution.Fields.Pretty + Distribution.GetOpt + Distribution.InstalledPackageInfo + Distribution.Lex + Distribution.License + Distribution.ModuleName + Distribution.Package + Distribution.PackageDescription + Distribution.PackageDescription.Check + Distribution.PackageDescription.Configuration + Distribution.PackageDescription.FieldGrammar + Distribution.PackageDescription.Parsec + Distribution.PackageDescription.PrettyPrint + Distribution.PackageDescription.Quirks + Distribution.PackageDescription.Utils + Distribution.Parsec + Distribution.Parsec.Error + Distribution.Parsec.FieldLineStream + Distribution.Parsec.Newtypes + Distribution.Parsec.Position + Distribution.Parsec.Warning + Distribution.Pretty + Distribution.ReadE + Distribution.SPDX + Distribution.SPDX.License + Distribution.SPDX.LicenseExceptionId + Distribution.SPDX.LicenseExpression + Distribution.SPDX.LicenseId + Distribution.SPDX.LicenseListVersion + Distribution.SPDX.LicenseReference + Distribution.Simple.Build.PathsModule + Distribution.Simple.BuildPaths + Distribution.Simple.BuildTarget + Distribution.Simple.BuildToolDepends + Distribution.Simple.CCompiler + Distribution.Simple.Command + Distribution.Simple.Compiler + Distribution.Simple.Configure + Distribution.Simple.Flag + Distribution.Simple.GHC + Distribution.Simple.GHC.EnvironmentParser + Distribution.Simple.GHC.ImplInfo + Distribution.Simple.GHC.Internal + Distribution.Simple.GHCJS + Distribution.Simple.Glob + Distribution.Simple.HaskellSuite + Distribution.Simple.Hpc + Distribution.Simple.InstallDirs + Distribution.Simple.InstallDirs.Internal + Distribution.Simple.LocalBuildInfo + Distribution.Simple.PackageIndex + Distribution.Simple.PreProcess + Distribution.Simple.PreProcess.Unlit + Distribution.Simple.Program + Distribution.Simple.Program.Ar + Distribution.Simple.Program.Builtin + Distribution.Simple.Program.Db + Distribution.Simple.Program.Find + Distribution.Simple.Program.GHC + Distribution.Simple.Program.HcPkg + Distribution.Simple.Program.Hpc + Distribution.Simple.Program.Internal + Distribution.Simple.Program.Ld + Distribution.Simple.Program.ResponseFile + Distribution.Simple.Program.Run + Distribution.Simple.Program.Strip + Distribution.Simple.Program.Types + Distribution.Simple.Setup + Distribution.Simple.Test.LibV09 + Distribution.Simple.Test.Log + Distribution.Simple.UHC + Distribution.Simple.Utils + Distribution.Solver.Compat.Prelude + Distribution.Solver.Types.ComponentDeps + Distribution.Solver.Types.ConstraintSource + Distribution.Solver.Types.InstSolverPackage + Distribution.Solver.Types.LabeledPackageConstraint + Distribution.Solver.Types.OptionalStanza + Distribution.Solver.Types.PackageConstraint + Distribution.Solver.Types.PackageFixedDeps + Distribution.Solver.Types.PackageIndex + Distribution.Solver.Types.PackagePath + Distribution.Solver.Types.ResolverPackage + Distribution.Solver.Types.Settings + Distribution.Solver.Types.SolverId + Distribution.Solver.Types.SolverPackage + Distribution.Solver.Types.SourcePackage + Distribution.System + Distribution.TestSuite + Distribution.Text + Distribution.Types.AbiDependency + Distribution.Types.AbiHash + Distribution.Types.AnnotatedId + Distribution.Types.Benchmark + Distribution.Types.Benchmark.Lens + Distribution.Types.BenchmarkInterface + Distribution.Types.BenchmarkType + Distribution.Types.BuildInfo + Distribution.Types.BuildInfo.Lens + Distribution.Types.BuildType + Distribution.Types.Component + Distribution.Types.ComponentId + Distribution.Types.ComponentInclude + Distribution.Types.ComponentLocalBuildInfo + Distribution.Types.ComponentName + Distribution.Types.ComponentRequestedSpec + Distribution.Types.CondTree + Distribution.Types.Condition + Distribution.Types.ConfVar + Distribution.Types.Dependency + Distribution.Types.DependencyMap + Distribution.Types.ExeDependency + Distribution.Types.Executable + Distribution.Types.Executable.Lens + Distribution.Types.ExecutableScope + Distribution.Types.ExposedModule + Distribution.Types.Flag + Distribution.Types.ForeignLib + Distribution.Types.ForeignLib.Lens + Distribution.Types.ForeignLibOption + Distribution.Types.ForeignLibType + Distribution.Types.GenericPackageDescription + Distribution.Types.GenericPackageDescription.Lens + Distribution.Types.GivenComponent + Distribution.Types.HookedBuildInfo + Distribution.Types.IncludeRenaming + Distribution.Types.InstalledPackageInfo + Distribution.Types.InstalledPackageInfo.FieldGrammar + Distribution.Types.InstalledPackageInfo.Lens + Distribution.Types.LegacyExeDependency + Distribution.Types.Lens + Distribution.Types.Library + Distribution.Types.Library.Lens + Distribution.Types.LibraryName + Distribution.Types.LibraryVisibility + Distribution.Types.LocalBuildInfo + Distribution.Types.Mixin + Distribution.Types.Module + Distribution.Types.ModuleReexport + Distribution.Types.ModuleRenaming + Distribution.Types.MungedPackageId + Distribution.Types.MungedPackageName + Distribution.Types.PackageDescription + Distribution.Types.PackageDescription.Lens + Distribution.Types.PackageId + Distribution.Types.PackageId.Lens + Distribution.Types.PackageName + Distribution.Types.PackageName.Magic + Distribution.Types.PackageVersionConstraint + Distribution.Types.PkgconfigDependency + Distribution.Types.PkgconfigName + Distribution.Types.PkgconfigVersion + Distribution.Types.PkgconfigVersionRange + Distribution.Types.SetupBuildInfo + Distribution.Types.SetupBuildInfo.Lens + Distribution.Types.SourceRepo + Distribution.Types.SourceRepo.Lens + Distribution.Types.TargetInfo + Distribution.Types.TestSuite + Distribution.Types.TestSuite.Lens + Distribution.Types.TestSuiteInterface + Distribution.Types.TestType + Distribution.Types.UnitId + Distribution.Types.UnqualComponentName + Distribution.Types.Version + Distribution.Types.VersionInterval + Distribution.Types.VersionRange + Distribution.Types.VersionRange.Internal + Distribution.Utils.Base62 + Distribution.Utils.Generic + Distribution.Utils.IOData + Distribution.Utils.LogProgress + Distribution.Utils.MapAccum + Distribution.Utils.NubList + Distribution.Utils.Progress + Distribution.Utils.ShortText + Distribution.Utils.String + Distribution.Utils.UnionFind + Distribution.Verbosity + Distribution.Verbosity.Internal + Distribution.Version + Language.Haskell.Extension + Paths_cabal_install + -- hackage-security modules + Hackage.Security.Client + Hackage.Security.Client.Formats + Hackage.Security.Client.Repository + Hackage.Security.Client.Repository.Cache + Hackage.Security.Client.Repository.HttpLib + Hackage.Security.Client.Repository.Local + Hackage.Security.Client.Repository.Remote + Hackage.Security.Client.Verify + Hackage.Security.JSON + Hackage.Security.Key + Hackage.Security.Key.Env + Hackage.Security.TUF + Hackage.Security.TUF.Common + Hackage.Security.TUF.FileInfo + Hackage.Security.TUF.FileMap + Hackage.Security.TUF.Header + Hackage.Security.TUF.Layout.Cache + Hackage.Security.TUF.Layout.Index + Hackage.Security.TUF.Layout.Repo + Hackage.Security.TUF.Mirrors + Hackage.Security.TUF.Paths + Hackage.Security.TUF.Patterns + Hackage.Security.TUF.Root + Hackage.Security.TUF.Signed + Hackage.Security.TUF.Snapshot + Hackage.Security.TUF.Targets + Hackage.Security.TUF.Timestamp + Hackage.Security.Trusted + Hackage.Security.Trusted.TCB + Hackage.Security.Util.Base64 + Hackage.Security.Util.Checked + Hackage.Security.Util.Exit + Hackage.Security.Util.IO + Hackage.Security.Util.JSON + Hackage.Security.Util.Lens + Hackage.Security.Util.Path + Hackage.Security.Util.Pretty + Hackage.Security.Util.Some + Hackage.Security.Util.Stack + Hackage.Security.Util.TypedEmbedded + Prelude + Text.JSON.Canonical Test-Suite test-resolve-category ghc-options: -Wall @@ -139,9 +454,9 @@ Main-Is: tests/resolveCat.hs Hs-Source-Dirs: ., cabal, cabal/Cabal, cabal/cabal-install, tests Build-Depends: array, - base >= 3 && < 5, + base, binary, - deepseq >= 1.3, + deepseq, bytestring, containers, directory, @@ -169,9 +484,9 @@ Main-Is: tests/print_deps.hs Hs-Source-Dirs: ., cabal, cabal/Cabal, cabal/cabal-install, tests Build-Depends: array, - base >= 3 && < 5, + base, binary, - deepseq >= 1.3, + deepseq, bytestring, containers, directory, @@ -198,9 +513,9 @@ Main-Is: tests/normalize_deps.hs Hs-Source-Dirs: ., cabal, cabal/Cabal, cabal/cabal-install, tests Build-Depends: array, - base >= 3 && < 5, + base, binary, - deepseq >= 1.3, + deepseq, bytestring, containers, directory,