diff --git a/HackPort/GlobalFlags.hs b/HackPort/GlobalFlags.hs --- a/HackPort/GlobalFlags.hs +++ b/HackPort/GlobalFlags.hs @@ -6,6 +6,7 @@ import qualified Distribution.Verbosity as DV import qualified Distribution.Simple.Setup as DSS +import qualified Distribution.Client.Config as DCC import qualified Distribution.Client.GlobalFlags as DCG import qualified Distribution.Client.Types as DCT import qualified Distribution.Utils.NubList as DUN @@ -32,7 +33,7 @@ } defaultRemoteRepo :: DCT.RemoteRepo -defaultRemoteRepo = (DCT.emptyRemoteRepo name) { DCT.remoteRepoURI = uri } +defaultRemoteRepo = DCC.addInfoForKnownRepos $ (DCT.emptyRemoteRepo name) { DCT.remoteRepoURI = uri } where Just uri = NU.parseURI "https://hackage.haskell.org/" name = "hackage.haskell.org" diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -21,8 +21,9 @@ import Distribution.Verbosity (Verbosity, normal) import Distribution.Text (display, simpleParse) -import Distribution.Client.Types -import Distribution.Client.Update +import qualified Distribution.Client.Setup as CabalInstall +import qualified Distribution.Client.Types as CabalInstall +import qualified Distribution.Client.Update as CabalInstall import qualified Distribution.Client.IndexUtils as CabalInstall import qualified Distribution.Solver.Types.SourcePackage as CabalInstall @@ -94,7 +95,7 @@ let verbosity = fromFlag (listVerbosity flags) H.withHackPortContext verbosity globalFlags $ \repoContext -> do overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags) - index <- fmap packageIndex (CabalInstall.getSourcePackages verbosity repoContext) + index <- fmap CabalInstall.packageIndex (CabalInstall.getSourcePackages verbosity repoContext) overlay <- Overlay.loadLazy overlayPath let pkgs | null extraArgs = CabalInstall.allPackages index | otherwise = concatMap (concatMap snd . CabalInstall.searchByNameSubstring index) extraArgs @@ -221,7 +222,11 @@ let verbosity = fromFlag (updateVerbosity flags) H.withHackPortContext verbosity globalFlags $ \repoContext -> - update verbosity repoContext + -- TODO: parse user's flags as cabal-iinstall does. + -- Currently I'm lazy to adapt new flag and user: + -- defaultUpdateFlags + let updateFlags = commandDefaultFlags CabalInstall.updateCommand + in CabalInstall.update verbosity updateFlags repoContext ----------------------------------------------------------------------- -- Status @@ -378,7 +383,7 @@ ++ "\n" ++ "Advanced usage:\n" ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" - | x <- ["update", "make-ebuild "]], + | x <- ["update", "make-ebuild "]], commandNotes = Nothing, commandUsage = \pname -> "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n", diff --git a/Merge.hs b/Merge.hs --- a/Merge.hs +++ b/Merge.hs @@ -156,6 +156,9 @@ first_just_of :: [Maybe a] -> Maybe a first_just_of = msum +-- used to be FlagAssignment in Cabal but now it's an opaque type +type CabalFlags = [(Cabal.FlagName, Bool)] + mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> Cabal.GenericPackageDescription -> Bool -> Maybe String -> IO () mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch users_cabal_flags = do overlay <- Overlay.loadLazy overlayPath @@ -166,7 +169,7 @@ let requested_cabal_flags = first_just_of [users_cabal_flags, EM.cabal_flags existing_meta] -- accepts things, like: "cabal_flag:iuse_name", "+cabal_flag", "-cabal_flag" - read_fas :: Maybe String -> (Cabal.FlagAssignment, [(String, String)]) + read_fas :: Maybe String -> (CabalFlags, [(String, String)]) read_fas Nothing = ([], []) read_fas (Just user_fas_s) = (user_fas, user_renames) where user_fas = [ (cf, b) @@ -194,7 +197,7 @@ (user_specified_fas, cf_to_iuse_rename) = read_fas requested_cabal_flags debug verbosity "searching for minimal suitable ghc version" - (compiler_info, ghc_packages, pkgDesc0, _flags, pix) <- case GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc user_specified_fas of + (compiler_info, ghc_packages, pkgDesc0, _flags, pix) <- case GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc (Cabal.mkFlagAssignment user_specified_fas) of Just v -> return v Nothing -> let pn = display merged_cabal_pkg_name cn = display cat @@ -210,7 +213,7 @@ pkgDesc = pkgDesc0 { Cabal.buildDepends = accepted_deps } cabal_flag_descs = Cabal.genPackageFlags pkgGenericDesc all_flags = map Cabal.flagName cabal_flag_descs - make_fas :: [Cabal.Flag] -> [Cabal.FlagAssignment] + make_fas :: [Cabal.Flag] -> [CabalFlags] make_fas [] = [[]] make_fas (f:rest) = [ (fn, is_enabled) : fas | fas <- make_fas rest @@ -220,10 +223,10 @@ (\b -> [b]) users_choice ] - all_possible_flag_assignments :: [Cabal.FlagAssignment] + all_possible_flag_assignments :: [CabalFlags] all_possible_flag_assignments = make_fas cabal_flag_descs - pp_fa :: Cabal.FlagAssignment -> String + pp_fa :: CabalFlags -> String pp_fa fa = L.intercalate ", " [ (if b then '+' else '-') : f | (cabal_f, b) <- fa , let f = Cabal.unFlagName cabal_f @@ -237,10 +240,12 @@ Just ein -> ein -- key idea is to generate all possible list of flags - deps1 :: [(Cabal.FlagAssignment, Merge.EDep)] - deps1 = [ (f `updateFa` fr, cabal_to_emerge_dep pkgDesc_filtered_bdeps) + deps1 :: [(CabalFlags, Merge.EDep)] + deps1 = [ ( f `updateFa` Cabal.unFlagAssignment fr + , cabal_to_emerge_dep pkgDesc_filtered_bdeps) | f <- all_possible_flag_assignments - , Right (pkgDesc1,fr) <- [GHCCore.finalizePackageDescription f + -- TODO: move from 'finalizePackageDescription' to 'finalizePD' + , Right (pkgDesc1,fr) <- [GHCCore.finalizePackageDescription (Cabal.mkFlagAssignment f) (GHCCore.dependencySatisfiable pix) GHCCore.platform compiler_info @@ -253,7 +258,7 @@ , let pkgDesc_filtered_bdeps = pkgDesc1 { Cabal.buildDepends = ad } ] where - updateFa :: Cabal.FlagAssignment -> Cabal.FlagAssignment -> Cabal.FlagAssignment + updateFa :: CabalFlags -> CabalFlags -> CabalFlags updateFa [] _ = [] updateFa (x:xs) y = case lookup (fst x) y of -- TODO: when does this code get triggered? @@ -270,7 +275,7 @@ -- if flag(foo) -- ghc-options: -O2 (irrelevant_flags, deps1') = L.foldl' drop_irrelevant ([], deps1) active_flags - where drop_irrelevant :: ([Cabal.FlagName], [(Cabal.FlagAssignment, Merge.EDep)]) -> Cabal.FlagName -> ([Cabal.FlagName], [(Cabal.FlagAssignment, Merge.EDep)]) + where drop_irrelevant :: ([Cabal.FlagName], [(CabalFlags, Merge.EDep)]) -> Cabal.FlagName -> ([Cabal.FlagName], [(CabalFlags, Merge.EDep)]) drop_irrelevant (ifs, ds) f = case fenabled_ds' == fdisabled_ds' of True -> (f:ifs, fenabled_ds') @@ -278,10 +283,10 @@ where (fenabled_ds', fdisabled_ds') = ( L.sort $ map drop_f fenabled_ds , L.sort $ map drop_f fdisabled_ds ) - drop_f :: (Cabal.FlagAssignment, Merge.EDep) -> (Cabal.FlagAssignment, Merge.EDep) + drop_f :: (CabalFlags, Merge.EDep) -> (CabalFlags, Merge.EDep) drop_f (fas, d) = (filter ((f /=) . fst) fas, d) (fenabled_ds, fdisabled_ds) = L.partition is_fe ds - is_fe :: (Cabal.FlagAssignment, Merge.EDep) -> Bool + is_fe :: (CabalFlags, Merge.EDep) -> Bool is_fe (fas, _d) = case lookup f fas of Just v -> v @@ -293,7 +298,7 @@ ] -- and finally prettify all deps: - leave_only_dynamic_fa :: Cabal.FlagAssignment -> Cabal.FlagAssignment + leave_only_dynamic_fa :: CabalFlags -> CabalFlags leave_only_dynamic_fa fa = filter (\(fn, _) -> all (fn /=) irrelevant_flags) $ fa L.\\ common_fa -- build roughly balanced complete dependency tree instead of skewed one @@ -310,12 +315,12 @@ tdeps :: Merge.EDep tdeps = bimerge $ map set_fa_to_ed deps1' - set_fa_to_ed :: (Cabal.FlagAssignment, Merge.EDep) -> Merge.EDep + set_fa_to_ed :: (CabalFlags, Merge.EDep) -> Merge.EDep set_fa_to_ed (fa, ed) = ed { Merge.rdep = liftFlags (leave_only_dynamic_fa fa) $ Merge.rdep ed , Merge.dep = liftFlags (leave_only_dynamic_fa fa) $ Merge.dep ed } - liftFlags :: Cabal.FlagAssignment -> Portage.Dependency -> Portage.Dependency + liftFlags :: CabalFlags -> Portage.Dependency -> Portage.Dependency liftFlags fs e = let k = foldr (\(y,b) x -> Portage.mkUseDependency (b, Portage.Use . cfn_to_iuse . Cabal.unFlagName $ y) . x) id fs in k e @@ -355,7 +360,7 @@ map ('\t':) conf_args -- returns list USE-parameters to './setup configure' - selected_flags :: ([Cabal.FlagName], Cabal.FlagAssignment) -> [String] + selected_flags :: ([Cabal.FlagName], CabalFlags) -> [String] selected_flags ([], []) = [] selected_flags (active_fns, users_fas) = map snd (L.sortBy (compare `on` fst) flag_pairs) where flag_pairs :: [(String, String)] diff --git a/Merge/Dependencies.hs b/Merge/Dependencies.hs --- a/Merge/Dependencies.hs +++ b/Merge/Dependencies.hs @@ -14,6 +14,8 @@ import qualified Distribution.PackageDescription as Cabal import qualified Distribution.Version as Cabal import qualified Distribution.Text as Cabal +import qualified Distribution.Types.LegacyExeDependency as Cabal +import qualified Distribution.Types.PkgconfigDependency as Cabal import qualified Distribution.Compiler as Cabal diff --git a/Portage/Cabal.hs b/Portage/Cabal.hs --- a/Portage/Cabal.hs +++ b/Portage/Cabal.hs @@ -1,25 +1,13 @@ module Portage.Cabal - ( fromOverlay - , convertLicense + ( convertLicense , partition_depends ) where import qualified Data.List as L -import qualified Data.Map as Map -import qualified Distribution.Simple.PackageIndex as Cabal import qualified Distribution.License as Cabal import qualified Distribution.Package as Cabal import qualified Distribution.Text as Cabal - -import qualified Portage.Overlay as Portage - -fromOverlay :: Portage.Overlay -> Cabal.PackageIndex Portage.ExistingEbuild -fromOverlay overlay = Cabal.fromList $ - [ ebuild - | (_pn, ebuilds) <- Map.toAscList (Portage.overlayMap overlay) - , ebuild <- ebuilds - ] -- map the cabal license type to the gentoo license string format convertLicense :: Cabal.License -> Either String String diff --git a/cabal/.github/PULL_REQUEST_TEMPLATE.md b/cabal/.github/PULL_REQUEST_TEMPLATE.md new file mode 100644 --- /dev/null +++ b/cabal/.github/PULL_REQUEST_TEMPLATE.md @@ -0,0 +1,8 @@ +Please include the following checklist in your PR: + +* [ ] Patches conform to the [coding conventions](https://github.com/haskell/cabal/#conventions). +* [ ] Any changes that could be relevant to users have been recorded in the changelog. +* [ ] The documentation has been updated, if necessary. +* [ ] If the change is docs-only, `[ci skip]` is used to avoid triggering the build bots. + +Please also shortly describe how you tested your change. Bonus points for added tests! diff --git a/cabal/.gitignore b/cabal/.gitignore --- a/cabal/.gitignore +++ b/cabal/.gitignore @@ -10,10 +10,11 @@ *.p_hi *.prof *.tix -cabal.config dist dist-* register.sh +./cabal.config +cabal-tests.log /Cabal/dist/ /Cabal/tests/Setup @@ -53,10 +54,7 @@ progress.txt # test files -dist-test register.sh -/Cabal/tests/PackageTests/Configure/include/HsZlibConfig.h -/Cabal/tests/PackageTests/Configure/zlib.buildinfo # python artifacts from documentation builds *.pyc diff --git a/cabal/.mailmap b/cabal/.mailmap --- a/cabal/.mailmap +++ b/cabal/.mailmap @@ -7,12 +7,12 @@ Adam Langley Alistair Bailey alistair Alson Kemp alson -Andy Craze Andres Löh Andres Löh Andres Löh Andres Löh Andres Löh +Andy Craze Audrey Tang audreyt Austin Seipp Austin Seipp @@ -30,10 +30,12 @@ Brendan Hay Brent Yorgey Brian Smith brianlsmith +Daniel Wagner David Himmelstrup David Luposchainsky David Waern David Waern Dennis Gosnell +Don Stewart Duncan Coutts Duncan Coutts Duncan Coutts @@ -44,6 +46,7 @@ Edward Z. Yang Einar Karttunen Federico Mastellone +Francesco Gazzetta Ganesh Sittampalam Geoff Nixon Gershom Bazerman @@ -70,16 +73,20 @@ Jeremy Shaw Jeremy Shaw Jim Burton +Joel Bitrauser +Joel Bitrauser Bitrauser Joe Quinn Joel Stanley Joeri van Eekelen John D. Ramsdell John Dias dias +John Ericson +John Ericson Josh Hoyt Judah Jacobson Jürgen Nicklisch-Franken -Ken Bateman Keegan McAllister mcallister.keegan +Ken Bateman Kido Takahiro Krasimir Angelov Krasimir Angelov ka2_mail @@ -91,6 +98,7 @@ Mark Weber marco-oweber Martin Sjögren md9ms Mikhail Glushenkov +Mikhail Glushenkov Mikhail Glushenkov Neil Mitchell Neil Mitchell Niklas Broberg @@ -98,8 +106,11 @@ Peter Higley Peter Simons Peter Trško Peter Trsko +Philipp Schumann metaleap Philipp Schuster Randy Polen +Robert Henderson +Robert Henderson Ryan Scott Samuel Gélineau Sergei Trofimovich diff --git a/cabal/.travis.yml b/cabal/.travis.yml --- a/cabal/.travis.yml +++ b/cabal/.travis.yml @@ -2,6 +2,8 @@ # We specify language: c, so it doesn't default to e.g. ruby language: c +dist: trusty + sudo: false # Remember to add release branches @@ -9,6 +11,7 @@ branches: only: - master + - "2.0" - "1.24" - "1.22" - "1.20" @@ -17,56 +20,68 @@ # 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 # lines listings versions you don't need/want testing for. +# +# NB: If you test the same GHC version/OS combo multiple times with +# SCRIPT=script (e.g., see PARSEC=YES below), you MUST supply a +# TAGSUFFIX to help travis/upload.sh disambiguate the matrix entry. matrix: include: - - env: GHCVER=8.0.1 SCRIPT=meta BUILDER=none + - env: GHCVER=8.2.1 SCRIPT=meta BUILDER=none os: linux sudo: required # These don't have -dyn/-prof whitelisted yet, so we have to # do the old-style installation - - env: GHCVER=7.4.2 SCRIPT=script CABAL_LIB_ONLY=YES + - env: GHCVER=7.4.2 SCRIPT=script CABAL_LIB_ONLY=YES TEST_OTHER_VERSIONS=YES os: linux sudo: required - env: GHCVER=7.6.3 SCRIPT=script os: linux sudo: required - - env: GHCVER=7.8.4 SCRIPT=script + - env: GHCVER=7.8.4 SCRIPT=script USE_GOLD=YES os: linux sudo: required # Ugh, we'd like to drop 'sudo: required' and use the # apt plugin for the next two # but the GCE instance we get has more memory, which makes # a big difference - - env: GHCVER=7.10.3 SCRIPT=script + - env: GHCVER=7.10.3 SCRIPT=script USE_GOLD=YES os: linux sudo: required - - env: GHCVER=8.0.1 SCRIPT=script DEPLOY_DOCS=YES TEST_OTHER_VERSIONS=YES + - env: GHCVER=8.0.2 SCRIPT=script DEPLOY_DOCS=YES USE_GOLD=YES TEST_SOLVER_BENCHMARKS=YES sudo: required os: linux - - env: GHCVER=8.0.1 SCRIPT=solver-debug-flags + + - env: GHCVER=8.0.2 SCRIPT=solver-debug-flags USE_GOLD=YES sudo: required os: linux - - env: GHCVER=8.0.1 SCRIPT=script PARSEC=YES TEST_OTHER_VERSIONS=YES + - env: GHCVER=8.0.2 SCRIPT=script DEBUG_EXPENSIVE_ASSERTIONS=YES TAGSUFFIX="-fdebug-expensive-assertions" USE_GOLD=YES os: linux sudo: required - - env: GHCVER=8.0.1 SCRIPT=bootstrap + - env: GHCVER=8.0.2 SCRIPT=bootstrap USE_GOLD=YES sudo: required os: linux + - env: GHCVER=8.2.2 SCRIPT=bootstrap USE_GOLD=YES + sudo: required + os: linux + - env: GHCVER=8.2.1 SCRIPT=script + os: linux + sudo: required # We axed GHC 7.6 and earlier because it's not worth the trouble to # make older GHC work with clang's cpp. See # https://ghc.haskell.org/trac/ghc/ticket/8493 - env: GHCVER=7.8.4 SCRIPT=script os: osx + # Keep this synced with travis/upload.sh osx_image: xcode6.4 # We need 10.10 # TODO: We might want to specify OSX version # https://docs.travis-ci.com/user/osx-ci-environment/#OS-X-Version - env: GHCVER=7.10.3 SCRIPT=script os: osx - - env: GHCVER=8.0.1 SCRIPT=script + - env: GHCVER=8.0.2 SCRIPT=script os: osx - - env: GHCVER=8.0.1 SCRIPT=bootstrap + - env: GHCVER=8.0.2 SCRIPT=bootstrap os: osx - env: GHCVER=via-stack SCRIPT=stack STACKAGE_RESOLVER=lts @@ -90,17 +105,14 @@ - export PATH=$HOME/bin:$PATH - export PATH=$HOME/.cabal/bin:$PATH - export PATH=$HOME/.local/bin:$PATH - - export PATH=/opt/cabal/1.24/bin:$PATH + - export PATH=/opt/cabal/2.0/bin:$PATH - export PATH=/opt/happy/1.19.5/bin:$PATH - export PATH=/opt/alex/3.1.7/bin:$PATH + - if [ "$USE_GOLD" = "YES" ]; then sudo update-alternatives --install "/usr/bin/ld" "ld" "/usr/bin/ld.gold" 20; fi + - if [ "$USE_GOLD" = "YES" ]; then sudo update-alternatives --install "/usr/bin/ld" "ld" "/usr/bin/ld.bfd" 10; fi + - ld -v - ./travis-install.sh - # Set up deployment to the haskell/cabal-website repo. - # NB: these commands MUST be in .travis.yml, otherwise the secret key can be - # leaked! See https://github.com/travis-ci/travis.rb/issues/423. - # umask to get the permissions to be 400. - - if [ "x$TRAVIS_REPO_SLUG" = "xhaskell/cabal" -a "x$TRAVIS_PULL_REQUEST" = "xfalse" -a "x$TRAVIS_BRANCH" = "xmaster" -a "x$DEPLOY_DOCS" = "xYES" ]; then (umask 377 && openssl aes-256-cbc -K $encrypted_edaf6551664d_key -iv $encrypted_edaf6551664d_iv -in id_rsa_cabal_website.aes256.enc -out ~/.ssh/id_rsa -d); fi - install: # We intentionally do not install anything before trying to build Cabal because # it should build with each supported GHC version out-of-the-box. @@ -110,7 +122,8 @@ # ./dist/setup/setup here instead of cabal-install to avoid breakage when the # build config format changed. script: - - ./travis-${SCRIPT}.sh + - rm -rf dist-newstyle + - ./travis-${SCRIPT}.sh -j2 cache: directories: @@ -130,10 +143,16 @@ before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index* + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index* - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json # Deploy Haddocks to the haskell/cabal-website repo. after_success: + # Set up deployment to the haskell/cabal-website repo. + # NB: these commands MUST be in .travis.yml, otherwise the secret key can be + # leaked! See https://github.com/travis-ci/travis.rb/issues/423. + # umask to get the permissions to be 600. + - if [ "x$TRAVIS_REPO_SLUG" = "xhaskell/cabal" -a "x$TRAVIS_PULL_REQUEST" = "xfalse" -a "x$TRAVIS_BRANCH" = "xmaster" -a "x$DEPLOY_DOCS" = "xYES" ]; then (umask 177 && openssl aes-256-cbc -K $encrypted_edaf6551664d_key -iv $encrypted_edaf6551664d_iv -in id_rsa_cabal_website.aes256.enc -out ~/.ssh/id_rsa -d); fi - ./travis-deploy.sh notifications: diff --git a/cabal/AUTHORS b/cabal/AUTHORS --- a/cabal/AUTHORS +++ b/cabal/AUTHORS @@ -6,10 +6,13 @@ Adam Sandberg Eriksson Alan Zimmerman Albert Krewinkel +Alex Biehl Alexander Kjeldaas Alexander Vershilov +Alexei Pastuchov Alistair Bailey Alson Kemp +Amir Mohammad Saied Anders Kaseorg Andrea Vezzosi Andres Löh @@ -24,6 +27,7 @@ Arun Tejasvi Chaganty Atze Dijkstra Audrey Tang +Auke Booij Austin Seipp Bardur Arantsson Bartosz Nitka @@ -51,10 +55,12 @@ Christiaan Baaij Clemens Fruhwirth Clint Adams +Colin Wahl Conal Elliott Curtis Gagliardi Dan Burton Daniel Buckmaster +Daniel Gröber Daniel Trstenjak Daniel Velkov Daniel Wagner @@ -71,8 +77,9 @@ Dino Morelli Dmitry Astapov Dominic Steinitz -Don Stewart +Don Stewart Doug Beardsley +Douglas Wilson Duncan Coutts Echo Nolan Edsko de Vries @@ -89,6 +96,7 @@ Fabián Orccón Federico Mastellone Florian Hartwig +Francesco Gazzetta Franz Thoma Fujimura Daisuke Gabor Greif @@ -115,6 +123,7 @@ Isaac Potoczny-Jones Isamu Mogi Iustin Pop +Ivan Lazar Miljenovic Iñaki García Etxebarria JP Moresmau Jacco Krijnen @@ -127,12 +136,14 @@ Jim Burton Joachim Breitner Joe Quinn +Joel Bitrauser Joel Stanley Joeri van Eekelen Johan Tibell John Chee John D. Ramsdell John Dias +John Ericson John Ericson John Lato John Wiegley @@ -184,6 +195,7 @@ Misty De Meo Miëtek Bak Mohit Agarwal +Moritz Angermann Moritz Kiefer Nathan Howell Neil Mitchell @@ -201,6 +213,7 @@ Paolo G. Giarrusso Paolo Losi Paolo Martini +Patrick Chilton Patrick Premont Patryk Zadarnowski Pepe Iborra @@ -210,13 +223,16 @@ Peter Simons Peter Trško Phil Ruffwind +Philipp Schumann Philipp Schuster +Pranit Bauva Prayag Verma Randy Polen Reid Barton Richard Eisenberg Ricky Elrod Robert Collins +Robert Henderson Roberto Zunino Robin Green Robin KAY @@ -241,8 +257,10 @@ Simon Peyton Jones Spencer Janssen Stephen Blackheath +Stuart Popejoy Sven Panne Sönke Hahn +Tamar Christina Taru Karttunen Thomas Dziedzic Thomas M. DuBuisson diff --git a/cabal/Cabal/Cabal.cabal b/cabal/Cabal/Cabal.cabal --- a/cabal/Cabal/Cabal.cabal +++ b/cabal/Cabal/Cabal.cabal @@ -1,6 +1,6 @@ name: Cabal -version: 1.25.0.0 -copyright: 2003-2016, Cabal Development Team (see AUTHORS file) +version: 2.1.0.0 +copyright: 2003-2017, Cabal Development Team (see AUTHORS file) license: BSD3 license-file: LICENSE author: Cabal Development Team @@ -32,6 +32,15 @@ -- Generated with 'misc/gen-extra-source-files.sh' -- Do NOT edit this section manually; instead, run the script. -- BEGIN gen-extra-source-files + tests/ParserTests/regressions/Octree-0.5.cabal + tests/ParserTests/regressions/elif.cabal + tests/ParserTests/regressions/elif2.cabal + tests/ParserTests/regressions/encoding-0.8.cabal + tests/ParserTests/regressions/generics-sop.cabal + tests/ParserTests/regressions/haddock-api-2.18.1-check.cabal + tests/ParserTests/regressions/issue-774.cabal + tests/ParserTests/regressions/nothing-unicode.cabal + tests/ParserTests/regressions/shake.cabal tests/ParserTests/warnings/bom.cabal tests/ParserTests/warnings/bool.cabal tests/ParserTests/warnings/deprecatedfield.cabal @@ -64,11 +73,6 @@ description: Use directory < 1.2 and old-time default: False -flag parsec - description: Use parsec parser - default: False - manual: True - flag parsec-struct-diff description: Use StructDiff in parsec tests. Affects only parsec tests. default: False @@ -83,15 +87,15 @@ deepseq >= 1.3 && < 1.5, filepath >= 1.3 && < 1.5, pretty >= 1.1 && < 1.2, - process >= 1.1.0.1 && < 1.5, - time >= 1.4 && < 1.7 + process >= 1.1.0.1 && < 1.7, + time >= 1.4 && < 1.9 if flag(old-directory) build-depends: directory >= 1.1 && < 1.2, old-time >= 1 && < 1.2, process >= 1.0.1.1 && < 1.1.0.2 else - build-depends: directory >= 1.2 && < 1.3, - process >= 1.1.0.2 && < 1.5 + build-depends: directory >= 1.2 && < 1.4, + process >= 1.1.0.2 && < 1.7 if flag(bundled-binary-generic) build-depends: binary >= 0.5 && < 0.7 @@ -108,7 +112,7 @@ if os(windows) build-depends: - Win32 >= 2.2 && < 2.4 + Win32 >= 2.2 && < 2.7 ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs if impl(ghc >= 8.0) @@ -120,10 +124,13 @@ Distribution.Backpack.Configure Distribution.Backpack.ComponentsGraph Distribution.Backpack.ConfiguredComponent + Distribution.Backpack.DescribeUnitId Distribution.Backpack.FullUnitId Distribution.Backpack.LinkedComponent Distribution.Backpack.ModSubst Distribution.Backpack.ModuleShape + Distribution.Backpack.PreModuleShape + Distribution.Utils.IOData Distribution.Utils.LogProgress Distribution.Utils.MapAccum Distribution.Compat.CreatePipe @@ -131,6 +138,8 @@ Distribution.Compat.Exception Distribution.Compat.Graph Distribution.Compat.Internal.TempFile + Distribution.Compat.Map.Strict + Distribution.Compat.Newtype Distribution.Compat.Prelude.Internal Distribution.Compat.ReadP Distribution.Compat.Semigroup @@ -143,7 +152,6 @@ Distribution.Make Distribution.ModuleName Distribution.Package - Distribution.Package.TextClass Distribution.PackageDescription Distribution.PackageDescription.Check Distribution.PackageDescription.Configuration @@ -160,6 +168,7 @@ Distribution.Simple.Build.PathsModule Distribution.Simple.BuildPaths Distribution.Simple.BuildTarget + Distribution.Simple.BuildToolDepends Distribution.Simple.CCompiler Distribution.Simple.Command Distribution.Simple.Compiler @@ -167,6 +176,7 @@ Distribution.Simple.GHC Distribution.Simple.GHCJS Distribution.Simple.Haddock + Distribution.Simple.Doctest Distribution.Simple.HaskellSuite Distribution.Simple.Hpc Distribution.Simple.Install @@ -187,6 +197,7 @@ Distribution.Simple.Program.Hpc Distribution.Simple.Program.Internal Distribution.Simple.Program.Ld + Distribution.Simple.Program.ResponseFile Distribution.Simple.Program.Run Distribution.Simple.Program.Script Distribution.Simple.Program.Strip @@ -204,26 +215,47 @@ Distribution.System Distribution.TestSuite Distribution.Text + Distribution.Pretty + Distribution.Types.AbiHash + Distribution.Types.AnnotatedId Distribution.Types.Benchmark Distribution.Types.BenchmarkInterface Distribution.Types.BenchmarkType Distribution.Types.BuildInfo Distribution.Types.BuildType + Distribution.Types.ComponentInclude + Distribution.Types.Dependency + Distribution.Types.ExeDependency + Distribution.Types.LegacyExeDependency + Distribution.Types.PkgconfigDependency + Distribution.Types.DependencyMap + Distribution.Types.ComponentId + Distribution.Types.MungedPackageId + Distribution.Types.PackageId + Distribution.Types.UnitId Distribution.Types.Executable + Distribution.Types.ExecutableScope Distribution.Types.Library Distribution.Types.ForeignLib Distribution.Types.ForeignLibType Distribution.Types.ForeignLibOption + Distribution.Types.Module Distribution.Types.ModuleReexport Distribution.Types.ModuleRenaming + Distribution.Types.ComponentName + Distribution.Types.MungedPackageName + Distribution.Types.PackageName + Distribution.Types.PkgconfigName + Distribution.Types.UnqualComponentName Distribution.Types.IncludeRenaming Distribution.Types.Mixin Distribution.Types.SetupBuildInfo Distribution.Types.TestSuite Distribution.Types.TestSuiteInterface Distribution.Types.TestType - Distribution.Types.ComponentName Distribution.Types.GenericPackageDescription + Distribution.Types.Condition + Distribution.Types.CondTree Distribution.Types.HookedBuildInfo Distribution.Types.PackageDescription Distribution.Types.SourceRepo @@ -232,36 +264,58 @@ Distribution.Types.LocalBuildInfo Distribution.Types.ComponentRequestedSpec Distribution.Types.TargetInfo + Distribution.Types.Version + Distribution.Types.VersionRange + Distribution.Types.VersionInterval + Distribution.Utils.Generic Distribution.Utils.NubList Distribution.Utils.ShortText Distribution.Utils.Progress - Distribution.Utils.BinaryWithFingerprint Distribution.Verbosity Distribution.Version Language.Haskell.Extension Distribution.Compat.Binary - if flag(parsec) - cpp-options: -DCABAL_PARSEC - build-depends: - transformers, - parsec >= 3.1.9 && <3.2 - build-tools: - alex >=3.1.4 && <3.3 - exposed-modules: - Distribution.Compat.Parsec - Distribution.PackageDescription.Parsec - Distribution.PackageDescription.Parsec.FieldDescr - Distribution.Parsec.Class - Distribution.Parsec.ConfVar - Distribution.Parsec.Lexer - Distribution.Parsec.LexerMonad - Distribution.Parsec.Parser - Distribution.Parsec.Types.Common - Distribution.Parsec.Types.Field - Distribution.Parsec.Types.FieldDescr - Distribution.Parsec.Types.ParseResult + -- Parsec parser relatedmodules + build-depends: + transformers, + mtl >= 2.1 && <2.3, + parsec >= 3.1.9 && <3.2 + exposed-modules: + Distribution.Compat.Parsec + Distribution.FieldGrammar + Distribution.FieldGrammar.Class + Distribution.FieldGrammar.Parsec + Distribution.FieldGrammar.Pretty + Distribution.PackageDescription.FieldGrammar + Distribution.PackageDescription.Parsec + Distribution.PackageDescription.Quirks + Distribution.Parsec.Class + Distribution.Parsec.Common + Distribution.Parsec.ConfVar + Distribution.Parsec.Field + Distribution.Parsec.Lexer + Distribution.Parsec.LexerMonad + Distribution.Parsec.Newtypes + Distribution.Parsec.ParseResult + Distribution.Parsec.Parser + -- Lens functionality + exposed-modules: + Distribution.Compat.Lens + Distribution.Types.Lens + Distribution.Types.Benchmark.Lens + Distribution.Types.BuildInfo.Lens + Distribution.Types.Executable.Lens + Distribution.Types.ForeignLib.Lens + Distribution.Types.GenericPackageDescription.Lens + Distribution.Types.Library.Lens + Distribution.Types.PackageDescription.Lens + Distribution.Types.PackageId.Lens + Distribution.Types.SetupBuildInfo.Lens + Distribution.Types.SourceRepo.Lens + Distribution.Types.TestSuite.Lens + other-modules: Distribution.Backpack.PreExistingComponent Distribution.Backpack.ReadyComponent @@ -335,6 +389,7 @@ UnitTests.Distribution.Simple.Program.Internal UnitTests.Distribution.Simple.Utils UnitTests.Distribution.System + UnitTests.Distribution.Utils.Generic UnitTests.Distribution.Utils.NubList UnitTests.Distribution.Utils.ShortText UnitTests.Distribution.Version @@ -342,26 +397,27 @@ build-depends: array, base, + bytestring, containers, directory, filepath, + integer-logarithms >= 1.0.2 && <1.1, tasty, tasty-hunit, tasty-quickcheck, tagged, + text, pretty, - QuickCheck >= 2.7 && < 2.10, + QuickCheck >= 2.7 && < 2.11, Cabal ghc-options: -Wall default-language: Haskell2010 test-suite parser-tests - if !flag(parsec) - buildable: False - type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: ParserTests.hs + build-depends: containers build-depends: base, bytestring, @@ -369,20 +425,40 @@ tasty, tasty-hunit, tasty-quickcheck, + tasty-golden >=2.3.1.1 && <2.4, + Diff >=0.3.4 && <0.4, Cabal ghc-options: -Wall default-language: Haskell2010 -test-suite parser-hackage-tests - if !flag(parsec) - buildable: False +test-suite check-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: CheckTests.hs + build-depends: + base, + bytestring, + filepath, + tasty, + tasty-golden >=2.3.1.1 && <2.4, + Diff >=0.3.4 && <0.4, + Cabal + ghc-options: -Wall + default-language: Haskell2010 +test-suite parser-hackage-tests type: exitcode-stdio-1.0 main-is: ParserHackageTests.hs + -- TODO: need to get 01-index.tar on appveyor + if os(windows) + buildable: False + hs-source-dirs: tests build-depends: base, + base-orphans == 0.6.*, + base-compat >=0.9.3 && <0.10, containers, tar >=0.5 && <0.6, bytestring, @@ -392,7 +468,7 @@ if flag(parsec-struct-diff) build-depends: - generics-sop ==0.2.*, + generics-sop >= 0.3.1.0 && <0.4, these >=0.7.1 && <0.8, singleton-bool >=0.1.1.0 && <0.2, keys 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 @@ -46,8 +46,10 @@ import Text.PrettyPrint (hcat) import Distribution.ModuleName -import Distribution.Package import Distribution.Text +import Distribution.Types.ComponentId +import Distribution.Types.UnitId +import Distribution.Types.Module import Distribution.Utils.Base62 import qualified Data.Map as Map 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 @@ -1,18 +1,23 @@ -- | See - module Distribution.Backpack.ComponentsGraph ( ComponentsGraph, - dispComponentsGraph, - toComponentsGraph, + ComponentsWithDeps, + mkComponentsGraph, + componentsGraphToList, + dispComponentsWithDeps, componentCycleMsg ) where +import Prelude () +import Distribution.Compat.Prelude + import Distribution.Package import Distribution.PackageDescription as PD hiding (Flag) +import Distribution.Simple.BuildToolDepends import Distribution.Simple.LocalBuildInfo import Distribution.Types.ComponentRequestedSpec -import Distribution.Simple.Utils -import Distribution.Compat.Graph (Node(..)) +import Distribution.Types.UnqualComponentName +import Distribution.Compat.Graph (Graph, Node(..)) import qualified Distribution.Compat.Graph as Graph import Distribution.Text @@ -23,38 +28,42 @@ -- Components graph ------------------------------------------------------------------------------ --- | A components graph is a source level graph tracking the --- dependencies between components in a package. -type ComponentsGraph = [(Component, [ComponentName])] +-- | A graph of source-level components by their source-level +-- dependencies +-- +type ComponentsGraph = Graph (Node ComponentName Component) --- | Pretty-print a 'ComponentsGraph'. -dispComponentsGraph :: ComponentsGraph -> Doc -dispComponentsGraph graph = +-- | A list of components associated with the source level +-- dependencies between them. +-- +type ComponentsWithDeps = [(Component, [ComponentName])] + +-- | Pretty-print 'ComponentsWithDeps'. +-- +dispComponentsWithDeps :: ComponentsWithDeps -> Doc +dispComponentsWithDeps graph = vcat [ hang (text "component" <+> disp (componentName c)) 4 (vcat [ text "dependency" <+> disp cdep | cdep <- cdeps ]) | (c, cdeps) <- graph ] --- | Given the package description and a 'PackageDescription' (used --- to determine if a package name is internal or not), create a graph of --- dependencies between the components. This is NOT necessarily the --- build order (although it is in the absence of Backpack.) -toComponentsGraph :: ComponentRequestedSpec +-- | Create a 'Graph' of 'Component', or report a cycle if there is a +-- problem. +-- +mkComponentsGraph :: ComponentRequestedSpec -> PackageDescription -> Either [ComponentName] ComponentsGraph -toComponentsGraph enabled pkg_descr = - let g = Graph.fromList [ N c (componentName c) (componentDeps c) +mkComponentsGraph enabled pkg_descr = + let g = Graph.fromDistinctList + [ N c (componentName c) (componentDeps c) | c <- pkgBuildableComponents pkg_descr , componentEnabled enabled c ] in case Graph.cycles g of - [] -> Right (map (\(N c _ cs) -> (c, cs)) (Graph.revTopSort g)) + [] -> Right g ccycles -> Left [ componentName c | N c _ _ <- concat ccycles ] where -- The dependencies for the given component componentDeps component = - [ CExeName toolname - | LegacyExeDependency name _ <- buildTools bi - , let toolname = mkUnqualComponentName name - , toolname `elem` map exeName (executables pkg_descr) ] + (CExeName <$> getAllInternalToolDependencies pkg_descr bi) ++ [ if pkgname == packageName pkg_descr then CLibName @@ -67,6 +76,17 @@ internalPkgDeps = map (conv . libName) (allLibraries pkg_descr) conv Nothing = packageNameToUnqualComponentName $ packageName pkg_descr conv (Just s) = s + +-- | Given the package description and a 'PackageDescription' (used +-- to determine if a package name is internal or not), sort the +-- components in dependency order (fewest dependencies first). This is +-- NOT necessarily the build order (although it is in the absence of +-- Backpack.) +-- +componentsGraphToList :: ComponentsGraph + -> ComponentsWithDeps +componentsGraphToList = + map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort -- | Error message when there is a cycle; takes the SCC of components. componentCycleMsg :: [ComponentName] -> Doc diff --git a/cabal/Cabal/Distribution/Backpack/Configure.hs b/cabal/Cabal/Distribution/Backpack/Configure.hs --- a/cabal/Cabal/Distribution/Backpack/Configure.hs +++ b/cabal/Cabal/Distribution/Backpack/Configure.hs @@ -25,6 +25,7 @@ import Distribution.Backpack.LinkedComponent import Distribution.Backpack.ReadyComponent import Distribution.Backpack.ComponentsGraph +import Distribution.Backpack.Id import Distribution.Simple.Compiler hiding (Flag) import Distribution.Package @@ -37,11 +38,12 @@ import Distribution.ModuleName import Distribution.Simple.Setup as Setup import Distribution.Simple.LocalBuildInfo +import Distribution.Types.AnnotatedId import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.ComponentInclude import Distribution.Verbosity import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (Graph, IsNode(..)) -import Distribution.Utils.Progress import Distribution.Utils.LogProgress import Data.Either @@ -49,7 +51,6 @@ import qualified Data.Set as Set import qualified Data.Map as Map import Distribution.Text - ( display ) import Text.PrettyPrint ------------------------------------------------------------------------------ @@ -60,6 +61,7 @@ :: Verbosity -> Bool -- use_external_internal_deps -> ComponentRequestedSpec + -> Bool -- deterministic -> Flag String -- configIPID -> Flag ComponentId -- configCID -> PackageDescription @@ -70,22 +72,28 @@ -> Compiler -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) configureComponentLocalBuildInfos - verbosity use_external_internal_deps enabled ipid_flag cid_flag pkg_descr + verbosity use_external_internal_deps enabled deterministic ipid_flag cid_flag pkg_descr prePkgDeps flagAssignment instantiate_with installedPackageSet comp = do -- NB: In single component mode, this returns a *single* component. -- In this graph, the graph is NOT closed. - graph0 <- case toComponentsGraph enabled pkg_descr of - Left ccycle -> failProgress (componentCycleMsg ccycle) - Right comps -> return comps + graph0 <- case mkComponentsGraph enabled pkg_descr of + Left ccycle -> dieProgress (componentCycleMsg ccycle) + Right g -> return (componentsGraphToList g) infoProgress $ hang (text "Source component graph:") 4 - (dispComponentsGraph graph0) + (dispComponentsWithDeps graph0) - let conf_pkg_map = Map.fromList - [(pc_pkgname pkg, (pc_cid pkg, pc_pkgid pkg)) + let conf_pkg_map = Map.fromListWith Map.union + [(pc_pkgname pkg, + Map.singleton (pc_compname pkg) + (AnnotatedId { + ann_id = pc_cid pkg, + ann_pid = packageId pkg, + ann_cname = pc_compname pkg + })) | pkg <- prePkgDeps] - graph1 = toConfiguredComponents use_external_internal_deps + graph1 <- toConfiguredComponents use_external_internal_deps flagAssignment - ipid_flag cid_flag pkg_descr + deterministic ipid_flag cid_flag pkg_descr conf_pkg_map (map fst graph0) infoProgress $ hang (text "Configured component graph:") 4 (vcat (map dispConfiguredComponent graph1)) @@ -107,15 +115,15 @@ (vcat (map dispLinkedComponent graph2)) let pid_map = Map.fromList $ - [ (pc_uid pkg, pc_pkgid pkg) + [ (pc_uid pkg, pc_munged_id pkg) | pkg <- prePkgDeps] ++ - [ (Installed.installedUnitId pkg, Installed.sourcePackageId pkg) + [ (Installed.installedUnitId pkg, mungedId pkg) | (_, Module uid _) <- instantiate_with , Just pkg <- [PackageIndex.lookupUnitId installedPackageSet (unDefUnitId uid)] ] subst = Map.fromList instantiate_with graph3 = toReadyComponents pid_map subst graph2 - graph4 = Graph.revTopSort (Graph.fromList graph3) + graph4 = Graph.revTopSort (Graph.fromDistinctList graph3) infoProgress $ hang (text "Ready component graph:") 4 (vcat (map dispReadyComponent graph4)) @@ -145,11 +153,11 @@ -- they are not related to what we are building. This was true -- in the old configure code. external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) - external_graph = Graph.fromList + external_graph = Graph.fromDistinctList . map Left $ PackageIndex.allPackages installedPackageSet internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) - internal_graph = Graph.fromList + internal_graph = Graph.fromDistinctList . map Right $ graph combined_graph = Graph.unionRight external_graph internal_graph @@ -167,12 +175,12 @@ -- the include paths and everything should be. -- packageDependsIndex = PackageIndex.fromList (lefts local_graph) - fullIndex = Graph.fromList local_graph + fullIndex = Graph.fromDistinctList local_graph case Graph.broken fullIndex of [] -> return () broken -> -- TODO: ppr this - failProgress . text $ + dieProgress . text $ "The following packages are broken because other" ++ " packages they depend on are missing. These broken " ++ "packages must be rebuilt before they can be used.\n" @@ -204,24 +212,24 @@ -- TODO: This is probably wrong for Backpack let pseudoTopPkg :: InstalledPackageInfo pseudoTopPkg = emptyInstalledPackageInfo { - Installed.installedUnitId = - mkLegacyUnitId (packageId pkg_descr), + Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr), Installed.sourcePackageId = packageId pkg_descr, - Installed.depends = - map pc_uid externalPkgDeps + Installed.depends = map pc_uid externalPkgDeps } case PackageIndex.dependencyInconsistencies . PackageIndex.insert pseudoTopPkg $ packageDependsIndex of [] -> return () inconsistencies -> - warnProgress . text $ - "This package indirectly depends on multiple versions of the same " - ++ "package. This is highly likely to cause a compile failure.\n" - ++ unlines [ "package " ++ display pkg ++ " requires " - ++ display (PackageIdentifier name ver) - | (name, uses) <- inconsistencies - , (pkg, ver) <- uses ] + warnProgress $ + hang (text "This package indirectly depends on multiple versions of the same" <+> + text "package. This is very likely to cause a compile failure.") 2 + (vcat [ text "package" <+> disp (packageName user) <+> + parens (disp (installedUnitId user)) <+> text "requires" <+> + disp inst + | (_dep_key, insts) <- inconsistencies + , (inst, users) <- insts + , user <- users ]) let clbis = mkLinkedComponentsLocalBuildInfo comp graph -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps) return (clbis, packageDependsIndex) @@ -240,7 +248,7 @@ isInternal x = Set.member x internalUnits go rc = case rc_component rc of - CLib _ -> + CLib lib -> let convModuleExport (modname', (Module uid modname)) | this_uid == unDefUnitId uid , modname' == modname @@ -268,6 +276,10 @@ Left indefc -> [ (m, OpenModuleVar m) | m <- indefc_requires indefc ] Right instc -> [ (m, OpenModule (DefiniteUnitId uid') m') | (m, Module uid' m') <- instc_insts instc ] + + compat_name = computeCompatPackageName (packageName rc) (libName lib) + compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid + in LibComponentLocalBuildInfo { componentPackageDeps = cpds, componentUnitId = this_uid, @@ -276,12 +288,12 @@ componentIsIndefinite_ = is_indefinite, componentLocalName = cname, componentInternalDeps = internal_deps, - componentExeDeps = map unDefUnitId (rc_internal_build_tools rc), + componentExeDeps = exe_deps, componentIncludes = includes, componentExposedModules = exports, componentIsPublic = rc_public rc, - componentCompatPackageKey = rc_compat_key rc comp, - componentCompatPackageName = rc_compat_name rc + componentCompatPackageKey = compat_key, + componentCompatPackageName = compat_name } CFLib _ -> FLibComponentLocalBuildInfo { @@ -289,7 +301,7 @@ componentComponentId = this_cid, componentLocalName = cname, componentPackageDeps = cpds, - componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc, + componentExeDeps = exe_deps, componentInternalDeps = internal_deps, componentIncludes = includes } @@ -299,7 +311,7 @@ componentComponentId = this_cid, componentLocalName = cname, componentPackageDeps = cpds, - componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc, + componentExeDeps = exe_deps, componentInternalDeps = internal_deps, componentIncludes = includes } @@ -309,7 +321,7 @@ componentComponentId = this_cid, componentLocalName = cname, componentPackageDeps = cpds, - componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc, + componentExeDeps = exe_deps, componentInternalDeps = internal_deps, componentIncludes = includes } @@ -319,7 +331,7 @@ componentComponentId = this_cid, componentLocalName = cname, componentPackageDeps = cpds, - componentExeDeps = map unDefUnitId $ rc_internal_build_tools rc, + componentExeDeps = exe_deps, componentInternalDeps = internal_deps, componentIncludes = includes } @@ -329,18 +341,17 @@ this_cid = rc_cid rc cname = componentName (rc_component rc) cpds = rc_depends rc + exe_deps = map ann_id $ rc_exe_deps rc is_indefinite = case rc_i rc of Left _ -> True Right _ -> False includes = - case rc_i rc of - Left indefc -> - indefc_includes indefc - Right instc -> - map (\(x,y) -> (DefiniteUnitId x,y)) (instc_includes instc) - internal_deps = - filter isInternal (nodeNeighbors rc) - ++ map unDefUnitId (rc_internal_build_tools rc) - - + map (\ci -> (ci_id ci, ci_renaming ci)) $ + case rc_i rc of + Left indefc -> + indefc_includes indefc + Right instc -> + map (\ci -> ci { ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci) }) + (instc_includes instc) + internal_deps = filter isInternal (nodeNeighbors rc) diff --git a/cabal/Cabal/Distribution/Backpack/ConfiguredComponent.hs b/cabal/Cabal/Distribution/Backpack/ConfiguredComponent.hs --- a/cabal/Cabal/Distribution/Backpack/ConfiguredComponent.hs +++ b/cabal/Cabal/Distribution/Backpack/ConfiguredComponent.hs @@ -2,6 +2,9 @@ -- | See module Distribution.Backpack.ConfiguredComponent ( ConfiguredComponent(..), + cc_name, + cc_cid, + cc_pkgid, toConfiguredComponent, toConfiguredComponents, dispConfiguredComponent, @@ -18,18 +21,29 @@ import Distribution.Backpack.Id +import Distribution.Types.AnnotatedId +import Distribution.Types.Dependency +import Distribution.Types.ExeDependency import Distribution.Types.IncludeRenaming +import Distribution.Types.ComponentId +import Distribution.Types.PackageId +import Distribution.Types.PackageName import Distribution.Types.Mixin +import Distribution.Types.ComponentName +import Distribution.Types.UnqualComponentName +import Distribution.Types.ComponentInclude import Distribution.Package import Distribution.PackageDescription as PD hiding (Flag) +import Distribution.Simple.BuildToolDepends import Distribution.Simple.Setup as Setup import Distribution.Simple.LocalBuildInfo import Distribution.Version +import Distribution.Utils.LogProgress +import Distribution.Utils.MapAccum +import Control.Monad import qualified Data.Set as Set import qualified Data.Map as Map -import Data.Traversable - ( mapAccumL ) import Distribution.Text import Text.PrettyPrint @@ -37,111 +51,156 @@ -- and the 'ComponentId's of the things it depends on. data ConfiguredComponent = ConfiguredComponent { - cc_cid :: ComponentId, - -- The package this component came from. - cc_pkgid :: PackageId, + -- | Unique identifier of component, plus extra useful info. + cc_ann_id :: AnnotatedId ComponentId, + -- | The fragment of syntax from the Cabal file describing this + -- component. cc_component :: Component, - cc_public :: Bool, - -- ^ Is this the public library component of the package? - -- (THIS is what the hole instantiation applies to.) + -- | Is this the public library component of the package? + -- (If we invoke Setup with an instantiation, this is the + -- component the instantiation applies to.) -- Note that in one-component configure mode, this is -- always True, because any component is the "public" one.) - cc_internal_build_tools :: [ComponentId], - -- Not resolved yet; component configuration only looks at ComponentIds. - cc_includes :: [(ComponentId, PackageId, IncludeRenaming)] + cc_public :: Bool, + -- | Dependencies on executables from @build-tools@ and + -- @build-tool-depends@. + cc_exe_deps :: [AnnotatedId ComponentId], + -- | The mixins of this package, including both explicit (from + -- the @mixins@ field) and implicit (from @build-depends@). Not + -- mix-in linked yet; component configuration only looks at + -- 'ComponentId's. + cc_includes :: [ComponentInclude ComponentId IncludeRenaming] } + +-- | Uniquely identifies a configured component. +cc_cid :: ConfiguredComponent -> ComponentId +cc_cid = ann_id . cc_ann_id + +-- | The package this component came from. +cc_pkgid :: ConfiguredComponent -> PackageId +cc_pkgid = ann_pid . cc_ann_id + +-- | The 'ComponentName' of a component; this uniquely identifies +-- a fragment of syntax within a specified Cabal file describing the +-- component. cc_name :: ConfiguredComponent -> ComponentName -cc_name = componentName . cc_component +cc_name = ann_cname . cc_ann_id +-- | Pretty-print a 'ConfiguredComponent'. dispConfiguredComponent :: ConfiguredComponent -> Doc dispConfiguredComponent cc = hang (text "component" <+> disp (cc_cid cc)) 4 - (vcat [ hsep $ [ text "include", disp cid, disp incl_rn ] - | (cid, _, incl_rn) <- cc_includes cc + (vcat [ hsep $ [ text "include", disp (ci_id incl), disp (ci_renaming incl) ] + | incl <- cc_includes cc ]) - -- | Construct a 'ConfiguredComponent', given that the 'ComponentId' -- and library/executable dependencies are known. The primary -- work this does is handling implicit @backpack-include@ fields. mkConfiguredComponent - :: PackageId + :: PackageDescription -> ComponentId - -> [(PackageName, (ComponentId, PackageId))] - -> [ComponentId] + -> [AnnotatedId ComponentId] -- lib deps + -> [AnnotatedId ComponentId] -- exe deps -> Component - -> ConfiguredComponent -mkConfiguredComponent this_pid this_cid lib_deps exe_deps component = - ConfiguredComponent { - cc_cid = this_cid, - cc_pkgid = this_pid, - cc_component = component, - cc_public = is_public, - cc_internal_build_tools = exe_deps, - cc_includes = explicit_includes ++ implicit_includes - } - where - bi = componentBuildInfo component - deps = map snd lib_deps - deps_map = Map.fromList lib_deps - - -- Resolve each @backpack-include@ into the actual dependency + -> LogProgress ConfiguredComponent +mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do + -- Resolve each @mixins@ into the actual dependency -- from @lib_deps@. - explicit_includes - = [ (cid, pid { pkgName = name }, rns) - | Mixin name rns <- mixins bi - , Just (cid, pid) <- [Map.lookup name deps_map] ] + explicit_includes <- forM (mixins bi) $ \(Mixin name rns) -> do + let keys = fixFakePkgName pkg_descr name + aid <- case Map.lookup keys deps_map of + Nothing -> + dieProgress $ + text "Mix-in refers to non-existent package" <+> + quotes (disp name) $$ + text "(did you forget to add the package to build-depends?)" + Just r -> return r + return ComponentInclude { + ci_ann_id = aid, + ci_renaming = rns, + ci_implicit = False + } - -- Any @build-depends@ which is not explicitly mentioned in - -- @backpack-include@ is converted into an "implicit" include. - used_explicitly = Set.fromList (map (\(cid,_,_) -> cid) explicit_includes) - implicit_includes - = map (\(cid, pid) -> (cid, pid, defaultIncludeRenaming)) - $ filter (flip Set.notMember used_explicitly . fst) deps + -- Any @build-depends@ which is not explicitly mentioned in + -- @backpack-include@ is converted into an "implicit" include. + let used_explicitly = Set.fromList (map ci_id explicit_includes) + implicit_includes + = map (\aid -> ComponentInclude { + ci_ann_id = aid, + ci_renaming = defaultIncludeRenaming, + ci_implicit = True + }) + $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps + return ConfiguredComponent { + cc_ann_id = AnnotatedId { + ann_id = this_cid, + ann_pid = package pkg_descr, + ann_cname = componentName component + }, + cc_component = component, + cc_public = is_public, + cc_exe_deps = exe_deps, + cc_includes = explicit_includes ++ implicit_includes + } + where + bi = componentBuildInfo component + deps_map = Map.fromList [ ((packageName dep, ann_cname dep), dep) + | dep <- lib_deps ] is_public = componentName component == CLibName type ConfiguredComponentMap = - (Map PackageName (ComponentId, PackageId), -- libraries - Map UnqualComponentName ComponentId) -- executables - --- Executable map must be different because an executable can --- have the same name as a library. Ew. + Map PackageName (Map ComponentName (AnnotatedId ComponentId)) --- | Given some ambient environment of package names that --- are "in scope", looks at the 'BuildInfo' to decide --- what the packages actually resolve to, and then builds --- a 'ConfiguredComponent'. toConfiguredComponent :: PackageDescription -> ComponentId - -> Map PackageName (ComponentId, PackageId) -- external -> ConfiguredComponentMap -> Component - -> ConfiguredComponent -toConfiguredComponent pkg_descr this_cid - external_lib_map (lib_map, exe_map) component = + -> LogProgress ConfiguredComponent +toConfiguredComponent pkg_descr this_cid dep_map component = do + lib_deps <- + if newPackageDepsBehaviour pkg_descr + then forM (targetBuildDepends bi) $ \(Dependency name _) -> do + let (pn, cn) = fixFakePkgName pkg_descr name + value <- case Map.lookup cn =<< Map.lookup pn dep_map of + Nothing -> + dieProgress $ + text "Dependency on unbuildable" <+> + text (showComponentName cn) <+> + text "from" <+> disp pn + Just v -> return v + return value + else return old_style_lib_deps mkConfiguredComponent - (package pkg_descr) this_cid + pkg_descr this_cid lib_deps exe_deps component where bi = componentBuildInfo component - find_it :: PackageName -> (ComponentId, PackageId) - find_it name = - fromMaybe (error ("toConfiguredComponent: " ++ display (packageName pkg_descr) ++ - " " ++ display name)) $ - Map.lookup name lib_map <|> - Map.lookup name external_lib_map - lib_deps - | newPackageDepsBehaviour pkg_descr - = [ (name, find_it name) - | Dependency name _ <- targetBuildDepends bi ] - | otherwise - = Map.toList external_lib_map - exe_deps = [ cid - | LegacyExeDependency name _ <- buildTools bi - , Just cid <- [ Map.lookup (mkUnqualComponentName name) exe_map ] ] + -- dep_map contains a mix of internal and external deps. + -- We want all the public libraries (dep_cn == CLibName) + -- of all external deps (dep /= pn). Note that this + -- excludes the public library of the current package: + -- this is not supported by old-style deps behavior + -- because it would imply a cyclic dependency for the + -- library itself. + old_style_lib_deps = [ e + | (pn, comp_map) <- Map.toList dep_map + , pn /= packageName pkg_descr + , (cn, e) <- Map.toList comp_map + , cn == CLibName ] + exe_deps = + [ exe + | ExeDependency pn cn _ <- getAllToolDependencies pkg_descr bi + -- The error suppression here is important, because in general + -- we won't know about external dependencies (e.g., 'happy') + -- which the package is attempting to use (those deps are only + -- fed in when cabal-install uses this codepath.) + -- TODO: Let cabal-install request errors here + , Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn dep_map] + ] -- | Also computes the 'ComponentId', and sets cc_public if necessary. -- This is Cabal-only; cabal-install won't use this. @@ -149,47 +208,36 @@ :: Bool -- use_external_internal_deps -> FlagAssignment -> PackageDescription + -> Bool -- deterministic -> Flag String -- configIPID (todo: remove me) -> Flag ComponentId -- configCID - -> Map PackageName (ComponentId, PackageId) -- external -> ConfiguredComponentMap -> Component - -> ConfiguredComponent + -> LogProgress ConfiguredComponent toConfiguredComponent' use_external_internal_deps flags - pkg_descr ipid_flag cid_flag - external_lib_map (lib_map, exe_map) component = - let cc = toConfiguredComponent + pkg_descr deterministic ipid_flag cid_flag + dep_map component = do + cc <- toConfiguredComponent pkg_descr this_cid - external_lib_map (lib_map, exe_map) component - in if use_external_internal_deps - then cc { cc_public = True } - else cc + dep_map component + return $ if use_external_internal_deps + then cc { cc_public = True } + else cc where - this_cid = computeComponentId ipid_flag cid_flag (package pkg_descr) + -- TODO: pass component names to it too! + this_cid = computeComponentId deterministic ipid_flag cid_flag (package pkg_descr) (componentName component) (Just (deps, flags)) - deps = [ cid | (cid, _) <- Map.elems external_lib_map ] + deps = [ ann_id aid | m <- Map.elems dep_map + , aid <- Map.elems m ] extendConfiguredComponentMap :: ConfiguredComponent -> ConfiguredComponentMap -> ConfiguredComponentMap -extendConfiguredComponentMap cc (lib_map, exe_map) = - (lib_map', exe_map') - where - lib_map' - = case cc_name cc of - CLibName -> - Map.insert (pkgName (cc_pkgid cc)) - (cc_cid cc, cc_pkgid cc) lib_map - CSubLibName str -> - Map.insert (unqualComponentNameToPackageName str) - (cc_cid cc, cc_pkgid cc) lib_map - _ -> lib_map - exe_map' - = case cc_name cc of - CExeName str -> - Map.insert str (cc_cid cc) exe_map - _ -> exe_map +extendConfiguredComponentMap cc = + Map.insertWith Map.union + (pkgName (cc_pkgid cc)) + (Map.singleton (cc_name cc) (cc_ann_id cc)) -- Compute the 'ComponentId's for a graph of 'Component's. The -- list of internal components must be topologically sorted @@ -198,22 +246,24 @@ toConfiguredComponents :: Bool -- use_external_internal_deps -> FlagAssignment + -> Bool -- deterministic -> Flag String -- configIPID -> Flag ComponentId -- configCID -> PackageDescription - -> Map PackageName (ComponentId, PackageId) + -> ConfiguredComponentMap -> [Component] - -> [ConfiguredComponent] + -> LogProgress [ConfiguredComponent] toConfiguredComponents - use_external_internal_deps flags ipid_flag cid_flag pkg_descr - external_lib_map comps - = snd (mapAccumL go (Map.empty, Map.empty) comps) + use_external_internal_deps flags deterministic ipid_flag cid_flag pkg_descr + dep_map comps + = fmap snd (mapAccumM go dep_map comps) where - go m component = (extendConfiguredComponentMap cc m, cc) - where cc = toConfiguredComponent' - use_external_internal_deps flags pkg_descr ipid_flag cid_flag - external_lib_map m component - + go m component = do + cc <- toConfiguredComponent' + use_external_internal_deps flags pkg_descr + deterministic ipid_flag cid_flag + m component + return (extendConfiguredComponentMap cc m, cc) newPackageDepsBehaviourMinVersion :: Version newPackageDepsBehaviourMinVersion = mkVersion [1,7,1] @@ -227,3 +277,16 @@ newPackageDepsBehaviour :: PackageDescription -> Bool newPackageDepsBehaviour pkg = specVersion pkg >= newPackageDepsBehaviourMinVersion + +-- | 'build-depends:' stanzas are currently ambiguous as the external packages +-- and internal libraries are specified the same. For now, we assume internal +-- libraries shadow, and this function disambiguates accordingly, but soon the +-- underlying ambiguity will be addressed. +fixFakePkgName :: PackageDescription -> PackageName -> (PackageName, ComponentName) +fixFakePkgName pkg_descr pn = + if subLibName `elem` internalLibraries + then (packageName pkg_descr, CSubLibName subLibName) + else (pn, CLibName) + where + subLibName = packageNameToUnqualComponentName pn + internalLibraries = mapMaybe libName (allLibraries pkg_descr) diff --git a/cabal/Cabal/Distribution/Backpack/DescribeUnitId.hs b/cabal/Cabal/Distribution/Backpack/DescribeUnitId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Backpack/DescribeUnitId.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} +module Distribution.Backpack.DescribeUnitId where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.PackageId +import Distribution.Types.ComponentName +import Distribution.Compat.Stack +import Distribution.Verbosity +import Distribution.ModuleName +import Distribution.Text +import Distribution.Simple.Utils + +import Text.PrettyPrint + +-- Unit identifiers have a well defined, machine-readable format, +-- but this format isn't very user-friendly for users. This +-- module defines some functions for solving common rendering +-- problems one has for displaying these. +-- +-- There are three basic problems we tackle: +-- +-- - Users don't want to see pkg-0.5-inplace-libname, +-- they want to see "library 'libname' from 'pkg-0.5'" +-- +-- - Users don't want to see the raw component identifier, which +-- usually contains a wordy hash that doesn't matter. +-- +-- - Users don't want to see a hash of the instantiation: they +-- want to see the actual instantiation, and they want it in +-- interpretable form. +-- + +-- | Print a Setup message stating (1) what operation we are doing, +-- for (2) which component (with enough details to uniquely identify +-- the build in question.) +-- +setupMessage' :: Text a => Verbosity + -> String -- ^ Operation being done (capitalized), on: + -> PackageIdentifier -- ^ Package + -> ComponentName -- ^ Component name + -> Maybe [(ModuleName, a)] -- ^ Instantiation, if available. + -- Polymorphic to take + -- 'OpenModule' or 'Module' + -> IO () +setupMessage' verbosity msg pkgid cname mb_insts = withFrozenCallStack $ do + noticeDoc verbosity $ + case mb_insts of + Just insts | not (null insts) -> + hang (msg_doc <+> text "instantiated with") 2 + (vcat [ disp k <+> text "=" <+> disp v + | (k,v) <- insts ]) $$ + for_doc + _ -> + msg_doc <+> for_doc + + where + msg_doc = text msg <+> text (showComponentName cname) + for_doc = text "for" <+> disp pkgid <<>> text ".." diff --git a/cabal/Cabal/Distribution/Backpack/FullUnitId.hs b/cabal/Cabal/Distribution/Backpack/FullUnitId.hs --- a/cabal/Cabal/Distribution/Backpack/FullUnitId.hs +++ b/cabal/Cabal/Distribution/Backpack/FullUnitId.hs @@ -7,7 +7,7 @@ ) where import Distribution.Backpack -import Distribution.Package +import Distribution.Types.ComponentId import Distribution.Compat.Prelude -- Unlike OpenUnitId, which could direct to a UnitId. diff --git a/cabal/Cabal/Distribution/Backpack/Id.hs b/cabal/Cabal/Distribution/Backpack/Id.hs --- a/cabal/Cabal/Distribution/Backpack/Id.hs +++ b/cabal/Cabal/Distribution/Backpack/Id.hs @@ -11,12 +11,16 @@ import Prelude () import Distribution.Compat.Prelude +import Distribution.Types.UnqualComponentName import Distribution.Simple.Compiler hiding (Flag) -import Distribution.Package import Distribution.PackageDescription as PD hiding (Flag) import Distribution.Simple.Setup as Setup import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo +import Distribution.Types.ComponentId +import Distribution.Types.PackageId +import Distribution.Types.UnitId +import Distribution.Types.MungedPackageName import Distribution.Utils.Base62 import Distribution.Version @@ -27,14 +31,15 @@ -- for a package. The intent is that cabal-install (or the user) will -- specify a more detailed IPID via the @--ipid@ flag if necessary. computeComponentId - :: Flag String + :: Bool -- deterministic mode + -> Flag String -> Flag ComponentId -> PackageIdentifier -> ComponentName -- This is used by cabal-install's legacy codepath -> Maybe ([ComponentId], FlagAssignment) -> ComponentId -computeComponentId mb_ipid mb_cid pid cname mb_details = +computeComponentId deterministic mb_ipid mb_cid pid cname mb_details = -- show is found to be faster than intercalate and then replacement of -- special character used in intercalating. We cannot simply hash by -- doubly concating list, as it just flatten out the nested list, so @@ -57,7 +62,8 @@ where env = packageTemplateEnv pid (mkUnitId "") actual_base = case mb_ipid of Flag ipid0 -> explicit_base ipid0 - NoFlag -> generated_base + NoFlag | deterministic -> display pid + | otherwise -> generated_base in case mb_cid of Flag cid -> cid NoFlag -> mkComponentId $ actual_base @@ -65,55 +71,6 @@ Nothing -> "" Just s -> "-" ++ unUnqualComponentName s) --- | Computes the package name for a library. If this is the public --- library, it will just be the original package name; otherwise, --- it will be a munged package name recording the original package --- name as well as the name of the internal library. --- --- A lot of tooling in the Haskell ecosystem assumes that if something --- is installed to the package database with the package name 'foo', --- then it actually is an entry for the (only public) library in package --- 'foo'. With internal packages, this is not necessarily true: --- a public library as well as arbitrarily many internal libraries may --- come from the same package. To prevent tools from getting confused --- in this case, the package name of these internal libraries is munged --- so that they do not conflict the public library proper. A particular --- case where this matters is ghc-pkg: if we don't munge the package --- name, the inplace registration will OVERRIDE a different internal --- library. --- --- We munge into a reserved namespace, "z-", and encode both the --- component name and the package name of an internal library using the --- following format: --- --- compat-pkg-name ::= "z-" package-name "-z-" library-name --- --- where package-name and library-name have "-" ( "z" + ) "-" --- segments encoded by adding an extra "z". --- --- When we have the public library, the compat-pkg-name is just the --- package-name, no surprises there! --- -computeCompatPackageName :: PackageName -> ComponentName -> PackageName --- First handle the cases where we can just use the original 'PackageName'. --- This is for the PRIMARY library, and it is non-Backpack, or the --- indefinite package for us. -computeCompatPackageName pkg_name CLibName = pkg_name -computeCompatPackageName pkg_name cname - = mkPackageName $ "z-" ++ zdashcode (display pkg_name) - ++ (case componentNameString cname of - Just cname_u -> "-z-" ++ zdashcode cname_str - where cname_str = unUnqualComponentName cname_u - Nothing -> "") - -zdashcode :: String -> String -zdashcode s = go s (Nothing :: Maybe Int) [] - where go [] _ r = reverse r - go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r) - go ('-':z) _ r = go z (Just 0) ('-':r) - go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r) - go (c:z) _ r = go z Nothing (c:r) - -- | In GHC 8.0, the string we pass to GHC to use for symbol -- names for a package can be an arbitrary, IPID-compatible string. -- However, prior to GHC 8.0 there are some restrictions on what @@ -163,7 +120,7 @@ -- computeCompatPackageKey :: Compiler - -> PackageName + -> MungedPackageName -> Version -> UnitId -> String diff --git a/cabal/Cabal/Distribution/Backpack/LinkedComponent.hs b/cabal/Cabal/Distribution/Backpack/LinkedComponent.hs --- a/cabal/Cabal/Distribution/Backpack/LinkedComponent.hs +++ b/cabal/Cabal/Distribution/Backpack/LinkedComponent.hs @@ -3,6 +3,10 @@ -- | See module Distribution.Backpack.LinkedComponent ( LinkedComponent(..), + lc_insts, + lc_uid, + lc_cid, + lc_pkgid, toLinkedComponent, toLinkedComponents, dispLinkedComponent, @@ -16,21 +20,25 @@ import Distribution.Backpack import Distribution.Backpack.FullUnitId import Distribution.Backpack.ConfiguredComponent -import Distribution.Backpack.ModSubst import Distribution.Backpack.ModuleShape +import Distribution.Backpack.PreModuleShape import Distribution.Backpack.ModuleScope import Distribution.Backpack.UnifyM import Distribution.Backpack.MixLink import Distribution.Utils.MapAccum +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentName import Distribution.Types.ModuleRenaming import Distribution.Types.IncludeRenaming +import Distribution.Types.ComponentInclude +import Distribution.Types.ComponentId +import Distribution.Types.PackageId import Distribution.Package import Distribution.PackageDescription as PD hiding (Flag) import Distribution.ModuleName import Distribution.Simple.LocalBuildInfo import Distribution.Verbosity -import Distribution.Utils.Progress import Distribution.Utils.LogProgress import qualified Data.Set as Set @@ -40,60 +48,73 @@ import Distribution.Text ( Text(disp) ) import Text.PrettyPrint +import Data.Either --- | A linked component, we know how it is instantiated and thus how we are --- going to build it. +-- | A linked component is a component that has been mix-in linked, at +-- which point we have determined how all the dependencies of the +-- component are explicitly instantiated (in the form of an OpenUnitId). +-- 'ConfiguredComponent' is mix-in linked into 'LinkedComponent', which +-- is then instantiated into 'ReadyComponent'. data LinkedComponent = LinkedComponent { - lc_uid :: OpenUnitId, - lc_cid :: ComponentId, - lc_pkgid :: PackageId, - lc_insts :: [(ModuleName, OpenModule)], + -- | Uniquely identifies linked component + lc_ann_id :: AnnotatedId ComponentId, + -- | Corresponds to 'cc_component'. lc_component :: Component, - lc_shape :: ModuleShape, - -- | Local buildTools dependencies - lc_internal_build_tools :: [OpenUnitId], + -- | @build-tools@ and @build-tool-depends@ dependencies. + -- Corresponds to 'cc_exe_deps'. + lc_exe_deps :: [AnnotatedId OpenUnitId], + -- | Is this the public library of a package? Corresponds to + -- 'cc_public'. lc_public :: Bool, - lc_includes :: [(OpenUnitId, ModuleRenaming)], - -- PackageId here is a bit dodgy, but its just for - -- BC so it shouldn't matter. - lc_depends :: [(OpenUnitId, PackageId)] + -- | Corresponds to 'cc_includes', but (1) this does not contain + -- includes of signature packages (packages with no exports), + -- and (2) the 'ModuleRenaming' for requirements (stored in + -- 'IncludeRenaming') has been removed, as it is reflected in + -- 'OpenUnitId'.) + lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming], + -- | Like 'lc_includes', but this specifies includes on + -- signature packages which have no exports. + lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming], + -- | The module shape computed by mix-in linking. This is + -- newly computed from 'ConfiguredComponent' + lc_shape :: ModuleShape } +-- | Uniquely identifies a 'LinkedComponent'. Corresponds to +-- 'cc_cid'. +lc_cid :: LinkedComponent -> ComponentId +lc_cid = ann_id . lc_ann_id + +-- | Corresponds to 'cc_pkgid'. +lc_pkgid :: LinkedComponent -> PackageId +lc_pkgid = ann_pid . lc_ann_id + +-- | The 'OpenUnitId' of this component in the "default" instantiation. +-- See also 'lc_insts'. 'LinkedComponent's cannot be instantiated +-- (e.g., there is no 'ModSubst' instance for them). +lc_uid :: LinkedComponent -> OpenUnitId +lc_uid lc = IndefFullUnitId (lc_cid lc) . Map.fromList $ lc_insts lc + +-- | The instantiation of 'lc_uid'; this always has the invariant +-- that it is a mapping from a module name @A@ to @@ (the hole A). +lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)] +lc_insts lc = [ (req, OpenModuleVar req) + | req <- Set.toList (modShapeRequires (lc_shape lc)) ] + dispLinkedComponent :: LinkedComponent -> Doc dispLinkedComponent lc = hang (text "unit" <+> disp (lc_uid lc)) 4 $ - vcat [ text "include" <+> disp uid <+> disp prov_rn - | (uid, prov_rn) <- lc_includes lc ] - -- YARRR $+$ dispModSubst (modShapeProvides (lc_shape lc)) + vcat [ text "include" <+> disp (ci_id incl) <+> disp (ci_renaming incl) + | incl <- lc_includes lc ] + $+$ + vcat [ text "signature include" <+> disp (ci_id incl) + | incl <- lc_sig_includes lc ] + $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc)) instance Package LinkedComponent where packageId = lc_pkgid -instance ModSubst LinkedComponent where - modSubst subst lc - = lc { - lc_uid = modSubst subst (lc_uid lc), - lc_insts = modSubst subst (lc_insts lc), - lc_shape = modSubst subst (lc_shape lc), - lc_includes = map (\(uid, rns) -> (modSubst subst uid, rns)) (lc_includes lc), - lc_depends = map (\(uid, pkgid) -> (modSubst subst uid, pkgid)) (lc_depends lc) - } - -{- -instance IsNode LinkedComponent where - type Key LinkedComponent = UnitId - nodeKey = lc_uid - nodeNeighbors n = - if Set.null (openUnitIdFreeHoles (lc_uid n)) - then map fst (lc_depends n) - else ordNub (map (generalizeUnitId . fst) (lc_depends n)) --} - --- We can't cache these values because they need to be changed --- when we substitute over a 'LinkedComponent'. By varying --- these over 'UnitId', we can support old GHCs. Nice! - toLinkedComponent :: Verbosity -> FullDb @@ -102,10 +123,9 @@ -> ConfiguredComponent -> LogProgress LinkedComponent toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { - cc_cid = this_cid, - cc_pkgid = pkgid, + cc_ann_id = aid@AnnotatedId { ann_id = this_cid }, cc_component = component, - cc_internal_build_tools = btools, + cc_exe_deps = exe_deps, cc_public = is_public, cc_includes = cid_includes } = do @@ -121,108 +141,150 @@ exposedModules lib, reexportedModules lib) _ -> ([], [], []) + src_hidden = otherModules (componentBuildInfo component) -- Take each included ComponentId and resolve it into an -- *unlinked* unit identity. We will use unification (relying -- on the ModuleShape) to resolve these into linked identities. - unlinked_includes :: [((OpenUnitId, ModuleShape), PackageId, IncludeRenaming)] - unlinked_includes = [ (lookupUid cid, pid, rns) - | (cid, pid, rns) <- cid_includes ] + unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming] + unlinked_includes = [ ComponentInclude (fmap lookupUid dep_aid) rns i + | ComponentInclude dep_aid rns i <- cid_includes ] lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) lookupUid cid = fromMaybe (error "linkComponent: lookupUid") (Map.lookup cid pkg_map) let orErr (Right x) = return x - orErr (Left err) = failProgress (text err) + orErr (Left [err]) = dieProgress err + orErr (Left errs) = do + dieProgress (vcat (intersperse (text "") -- double newline! + [ hang (text "-") 2 err | err <- errs])) + -- Pre-shaping + let pre_shape = mixLinkPreModuleShape $ + PreModuleShape { + preModShapeProvides = Set.fromList (src_provs ++ src_hidden), + preModShapeRequires = Set.fromList src_reqs + } : [ renamePreModuleShape (toPreModuleShape sh) rns + | ComponentInclude (AnnotatedId { ann_id = (_, sh) }) rns _ <- unlinked_includes ] + reqs = preModShapeRequires pre_shape + insts = [ (req, OpenModuleVar req) + | req <- Set.toList reqs ] + this_uid = IndefFullUnitId this_cid . Map.fromList $ insts + -- OK, actually do unification -- TODO: the unification monad might return errors, in which -- case we have to deal. Use monadic bind for now. - (linked_shape0 :: ModuleScope, - linked_deps :: [(OpenUnitId, PackageId)], - linked_includes :: [(OpenUnitId, ModuleRenaming)]) <- orErr $ runUnifyM verbosity db $ do + (linked_shape0 :: ModuleScope, + linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming], + linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]) + <- orErr $ runUnifyM verbosity this_cid db $ do -- The unification monad is implemented using mutable -- references. Thus, we must convert our *pure* data -- structures into mutable ones to perform unification. - -- + + let convertMod :: (ModuleName -> ModuleSource) -> ModuleName -> UnifyM s (ModuleScopeU s) + convertMod from m = do + m_u <- convertModule (OpenModule this_uid m) + return (Map.singleton m [WithSource (from m) m_u], Map.empty) + -- Handle 'exposed-modules' + exposed_mod_shapes_u <- mapM (convertMod FromExposedModules) src_provs + -- Handle 'other-modules' + other_mod_shapes_u <- mapM (convertMod FromOtherModules) src_hidden + + -- Handle 'signatures' let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s) convertReq req = do req_u <- convertModule (OpenModuleVar req) - return (Map.empty, Map.singleton req req_u) - -- NB: We DON'T convert locally defined modules, as in the - -- absence of mutual recursion across packages they - -- cannot participate in mix-in linking. - (shapes_u, includes_u) <- fmap unzip (mapM convertInclude unlinked_includes) - src_reqs_u <- mapM convertReq src_reqs + return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u]) + req_shapes_u <- mapM convertReq src_reqs + + -- Handle 'mixins' + (incl_shapes_u, all_includes_u) <- fmap unzip (mapM convertInclude unlinked_includes) + + failIfErrs -- Prevent error cascade -- Mix-in link everything! mixLink is the real workhorse. - shape_u <- foldM mixLink emptyModuleScopeU (shapes_u ++ src_reqs_u) + shape_u <- mixLink $ exposed_mod_shapes_u + ++ other_mod_shapes_u + ++ req_shapes_u + ++ incl_shapes_u + + -- src_reqs_u <- mapM convertReq src_reqs -- Read out all the final results by converting back -- into a pure representation. - let convertIncludeU (uid_u, pid, rns) = do - uid <- convertUnitIdU uid_u - return ((uid, rns), (uid, pid)) + let convertIncludeU (ComponentInclude dep_aid rns i) = do + uid <- convertUnitIdU (ann_id dep_aid) + return (ComponentInclude { + ci_ann_id = dep_aid { ann_id = uid }, + ci_renaming = rns, + ci_implicit = i + }) shape <- convertModuleScopeU shape_u - includes_deps <- mapM convertIncludeU includes_u - let (incls, deps) = unzip includes_deps - return (shape, deps, incls) + let (includes_u, sig_includes_u) = partitionEithers all_includes_u + incls <- mapM convertIncludeU includes_u + sig_incls <- mapM convertIncludeU sig_includes_u + return (shape, incls, sig_incls) - -- linked_shape0 is almost complete, but it doesn't contain - -- the actual modules we export ourselves. Add them! - let reqs = modScopeRequires linked_shape0 - -- check that there aren't pre-filled requirements... - insts = [ (req, OpenModuleVar req) - | req <- Set.toList reqs ] - this_uid = IndefFullUnitId this_cid . Map.fromList $ insts + let isNotLib (CLib _) = False + isNotLib _ = True + when (not (Set.null reqs) && isNotLib component) $ + dieProgress $ + hang (text "Non-library component has unfilled requirements:") + 4 (vcat [disp req | req <- Set.toList reqs]) - -- add the local exports to the scope - local_exports = Map.fromListWith (++) $ - [ (mod_name, [ModuleSource (packageName this_pid) - defaultIncludeRenaming - (OpenModule this_uid mod_name)]) - | mod_name <- src_provs ] - -- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg - -- won't allow it (since someone could directly synthesize - -- an 'InstalledPackageInfo' that violates abstraction.) - -- Though, maybe it should be relaxed? + -- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg + -- won't allow it (since someone could directly synthesize + -- an 'InstalledPackageInfo' that violates abstraction.) + -- Though, maybe it should be relaxed? + let src_hidden_set = Set.fromList src_hidden linked_shape = linked_shape0 { - modScopeProvides = - Map.unionWith (++) - local_exports - (modScopeProvides linked_shape0) - } + modScopeProvides = + -- Would rather use withoutKeys but need BC + Map.filterWithKey + (\k _ -> not (k `Set.member` src_hidden_set)) + (modScopeProvides linked_shape0) + } -- OK, compute the reexports -- TODO: This code reports the errors for reexports one reexport at -- a time. Better to collect them all up and report them all at -- once. - reexports_list <- for src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do - let err :: Doc -> LogProgress a - err s = failProgress - $ hang (text "Problem with module re-export" <> quotes (disp reex) - <+> colon) 2 s + let hdl :: [Either Doc a] -> LogProgress [a] + hdl es = + case partitionEithers es of + ([], rs) -> return rs + (ls, _) -> + dieProgress $ + hang (text "Problem with module re-exports:") 2 + (vcat [hang (text "-") 2 l | l <- ls]) + reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do case Map.lookup from (modScopeProvides linked_shape) of Just cands@(x0:xs0) -> do -- Make sure there is at least one candidate (x, xs) <- case mb_pn of Just pn -> - case filter ((pn==) . msrc_pkgname) cands of - (x1:xs1) -> return (x1, xs1) - _ -> err (brokenReexportMsg reex) + let matches_pn (FromMixins pn' _ _) = pn == pn' + matches_pn (FromBuildDepends pn' _) = pn == pn' + matches_pn (FromExposedModules _) = pn == packageName this_pid + matches_pn (FromOtherModules _) = pn == packageName this_pid + matches_pn (FromSignatures _) = pn == packageName this_pid + in case filter (matches_pn . getSource) cands of + (x1:xs1) -> return (x1, xs1) + _ -> Left (brokenReexportMsg reex) Nothing -> return (x0, xs0) -- Test that all the candidates are consistent - case filter (\x' -> msrc_module x /= msrc_module x') xs of + case filter (\x' -> unWithSource x /= unWithSource x') xs of [] -> return () - _ -> err $ ambiguousReexportMsg reex (x:xs) - return (to, msrc_module x) + _ -> Left $ ambiguousReexportMsg reex x xs + return (to, unWithSource x) _ -> - err (brokenReexportMsg reex) + Left (brokenReexportMsg reex) -- TODO: maybe check this earlier; it's syntactically obvious. let build_reexports m (k, v) | Map.member k m = - failProgress $ hsep + dieProgress $ hsep [ text "Module name ", disp k, text " is exported multiple times." ] | otherwise = return (Map.insert k v m) provs <- foldM build_reexports Map.empty $ @@ -231,22 +293,47 @@ [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++ reexports_list - let final_linked_shape = ModuleShape provs (modScopeRequires linked_shape) + let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape)) + -- See Note Note [Signature package special case] + let (linked_includes, linked_sig_includes) + | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, []) + | otherwise = (linked_includes0, linked_sig_includes0) + return $ LinkedComponent { - lc_uid = this_uid, - lc_cid = this_cid, - lc_insts = insts, - lc_pkgid = pkgid, + lc_ann_id = aid, lc_component = component, lc_public = is_public, -- These must be executables - lc_internal_build_tools = map (\cid -> IndefFullUnitId cid Map.empty) btools, + lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps, lc_shape = final_linked_shape, lc_includes = linked_includes, - lc_depends = linked_deps + lc_sig_includes = linked_sig_includes } +-- Note [Signature package special case] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Suppose we have p-indef, which depends on str-sig and inherits +-- the hole from that signature package. When we instantiate p-indef, +-- it's a bit pointless to also go ahead and build str-sig, because +-- str-sig cannot possibly have contributed any code to the package +-- in question. Furthermore, because the signature was inherited to +-- p-indef, if we test matching against p-indef, we also have tested +-- matching against p-sig. In fact, skipping p-sig is *mandatory*, +-- because p-indef may have thinned it (so that an implementation may +-- match p-indef but not p-sig.) +-- +-- However, suppose that we have a package which mixes together str-sig +-- and str-bytestring, with the intent of *checking* that str-sig is +-- implemented by str-bytestring. Here, it's quite important to +-- build an instantiated str-sig, since that is the only way we will +-- actually end up testing if the matching works. Note that this +-- admonition only applies if the package has NO requirements; if it +-- has any requirements, we will typecheck it as an indefinite +-- package, at which point the signature includes will be passed to +-- GHC who will in turn actually do the checking to make sure they +-- are instantiated correctly. + -- Handle mix-in linking for components. In the absence of Backpack, -- every ComponentId gets converted into a UnitId by way of SimpleUnitId. toLinkedComponents @@ -263,7 +350,8 @@ -> ConfiguredComponent -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) go lc_map cc = do - lc <- toLinkedComponent verbosity db this_pid lc_map cc + lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $ + toLinkedComponent verbosity db this_pid lc_map cc return (extendLinkedComponentMap lc lc_map, lc) type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape) @@ -276,32 +364,36 @@ brokenReexportMsg :: ModuleReexport -> Doc brokenReexportMsg (ModuleReexport (Just pn) from _to) = - text "The package" <+> disp pn <+> - text "does not export a module" <+> disp from + vcat [ text "The package" <+> quotes (disp pn) + , text "does not export a module" <+> quotes (disp from) ] brokenReexportMsg (ModuleReexport Nothing from _to) = - text "The module" <+> disp from <+> - text "is not exported by any suitable package." <+> - text "It occurs in neither the 'exposed-modules' of this package," <+> - text "nor any of its 'build-depends' dependencies." + vcat [ text "The module" <+> quotes (disp from) + , text "is not exported by any suitable package." + , text "It occurs in neither the 'exposed-modules' of this package," + , text "nor any of its 'build-depends' dependencies." ] -ambiguousReexportMsg :: ModuleReexport -> [ModuleSource] -> Doc -ambiguousReexportMsg (ModuleReexport mb_pn from _to) ys = - text "The module" <+> disp from <+> - text "is (differently) exported by more than one package" <+> - parens (hsep (punctuate comma [displaySource y | y <- ys])) <+> - text "making the re-export ambiguous." <+> help_msg mb_pn +ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc +ambiguousReexportMsg (ModuleReexport mb_pn from _to) y1 ys = + vcat [ text "Ambiguous reexport" <+> quotes (disp from) + , hang (text "It could refer to either:") 2 + (vcat (msg : msgs)) + , help_msg mb_pn ] where + msg = text " " <+> displayModuleWithSource y1 + msgs = [text "or" <+> displayModuleWithSource y | y <- ys] help_msg Nothing = - text "The ambiguity can be resolved by qualifying the" <+> - text "re-export with a package name." <+> - text "The syntax is 'packagename:ModuleName [as NewName]'." + -- TODO: This advice doesn't help if the ambiguous exports + -- come from a package named the same thing + vcat [ text "The ambiguity can be resolved by qualifying the" + , text "re-export with a package name." + , text "The syntax is 'packagename:ModuleName [as NewName]'." ] -- Qualifying won't help that much. help_msg (Just _) = - text "The ambiguity can be resolved by introducing a" <+> - text "backpack-include field to rename one of the module" <+> - text "names differently." - displaySource y - | not (isDefaultIncludeRenaming (msrc_renaming y)) - = disp (msrc_pkgname y) <+> text "with renaming" <+> - disp (includeProvidesRn (msrc_renaming y)) - | otherwise = disp (msrc_pkgname y) + vcat [ text "The ambiguity can be resolved by using the" + , text "mixins field to rename one of the module" + , text "names differently." ] + displayModuleWithSource y + = vcat [ quotes (disp (unWithSource y)) + , text "brought into scope by" <+> + dispModuleSource (getSource y) + ] diff --git a/cabal/Cabal/Distribution/Backpack/MixLink.hs b/cabal/Cabal/Distribution/Backpack/MixLink.hs --- a/cabal/Cabal/Distribution/Backpack/MixLink.hs +++ b/cabal/Cabal/Distribution/Backpack/MixLink.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NondecreasingIndentation #-} -- | See module Distribution.Backpack.MixLink ( mixLink, @@ -9,13 +10,14 @@ import Distribution.Backpack import Distribution.Backpack.UnifyM import Distribution.Backpack.FullUnitId +import Distribution.Backpack.ModuleScope import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.ModuleName import Distribution.Text -import Distribution.Types.IncludeRenaming -import Distribution.Package +import Distribution.Types.ComponentId +import Text.PrettyPrint import Control.Monad import qualified Data.Map as Map import qualified Data.Foldable as F @@ -24,46 +26,77 @@ -- Linking -- | Given to scopes of provisions and requirements, link them together. -mixLink :: ModuleScopeU s -> ModuleScopeU s -> UnifyM s (ModuleScopeU s) -mixLink (provs1, reqs1) (provs2, reqs2) = do - F.sequenceA_ (Map.intersectionWithKey linkProvision provs1 reqs2) - F.sequenceA_ (Map.intersectionWithKey linkProvision provs2 reqs1) - -- TODO: would be more efficient to collapse provision lists when we - -- unify them. - return (Map.unionWith (++) provs1 provs2, - -- NB: NOT the difference of the unions. That implies - -- self-unification not allowed. (But maybe requirement prov is disjoint - -- from reqs makes this a moot point?) - Map.union (Map.difference reqs1 provs2) - (Map.difference reqs2 provs1)) - -displaySource :: ModuleSourceU s -> String -displaySource src - | isDefaultIncludeRenaming (usrc_renaming src) - = display (usrc_pkgname src) - | otherwise - = display (usrc_pkgname src) ++ " with renaming " ++ display (usrc_renaming src) +mixLink :: [ModuleScopeU s] -> UnifyM s (ModuleScopeU s) +mixLink scopes = do + let provs = Map.unionsWith (++) (map fst scopes) + -- Invariant: any identically named holes refer to same mutable cell + reqs = Map.unionsWith (++) (map snd scopes) + filled = Map.intersectionWithKey linkProvision provs reqs + F.sequenceA_ filled + let remaining = Map.difference reqs filled + return (provs, remaining) -- | Link a list of possibly provided modules to a single -- requirement. This applies a side-condition that all -- of the provided modules at the same name are *actually* -- the same module. -linkProvision :: ModuleName -> [ModuleSourceU s] -> ModuleU s - -> UnifyM s [ModuleSourceU s] -linkProvision _ [] _reqs = error "linkProvision" -linkProvision mod_name ret@(prov:provs) req = do +linkProvision :: ModuleName + -> [ModuleWithSourceU s] -- provs + -> [ModuleWithSourceU s] -- reqs + -> UnifyM s [ModuleWithSourceU s] +linkProvision mod_name ret@(prov:provs) (req:reqs) = do + -- TODO: coalesce all the non-unifying modules together forM_ provs $ \prov' -> do - let msg = "Ambiguous module " ++ display mod_name ++ " " ++ - "when trying to fill requirement. It could refer to " ++ - "a module included from " ++ displaySource prov ++ " " ++ - "or module included from " ++ displaySource prov' ++ ". " ++ - "Ambiguity occurred because " - withContext msg (usrc_module prov) (usrc_module prov') $ - unifyModule (usrc_module prov) (usrc_module prov') - let msg = "Could not fill requirement " ++ display mod_name ++ "because " - withContext msg (usrc_module prov) req $ - unifyModule (usrc_module prov) req + -- Careful: read it out BEFORE unifying, because the + -- unification algorithm preemptively unifies modules + mod <- convertModuleU (unWithSource prov) + mod' <- convertModuleU (unWithSource prov') + r <- unify prov prov' + case r of + Just () -> return () + Nothing -> do + addErr $ + text "Ambiguous module" <+> quotes (disp mod_name) $$ + text "It could refer to" <+> + ( text " " <+> (quotes (disp mod) $$ in_scope_by (getSource prov)) $$ + text "or" <+> (quotes (disp mod') $$ in_scope_by (getSource prov')) ) $$ + link_doc + mod <- convertModuleU (unWithSource prov) + req_mod <- convertModuleU (unWithSource req) + self_cid <- fmap unify_self_cid getUnifEnv + case mod of + OpenModule (IndefFullUnitId cid _) _ + | cid == self_cid -> addErr $ + text "Cannot instantiate requirement" <+> quotes (disp mod_name) <+> + in_scope_by (getSource req) $$ + text "with locally defined module" <+> in_scope_by (getSource prov) $$ + text "as this would create a cyclic dependency, which GHC does not support." $$ + text "Try moving this module to a separate library, e.g.," $$ + text "create a new stanza: library 'sublib'." + _ -> return () + r <- unify prov req + case r of + Just () -> return () + Nothing -> do + -- TODO: Record and report WHERE the bad constraint came from + addErr $ text "Could not instantiate requirement" <+> quotes (disp mod_name) $$ + nest 4 (text "Expected:" <+> disp mod $$ + text "Actual: " <+> disp req_mod) $$ + parens (text "This can occur if an exposed module of" <+> + text "a libraries shares a name with another module.") $$ + link_doc return ret + where + unify s1 s2 = tryM $ addErrContext short_link_doc + $ unifyModule (unWithSource s1) (unWithSource s2) + in_scope_by s = text "brought into scope by" <+> dispModuleSource s + short_link_doc = text "While filling requirement" <+> quotes (disp mod_name) + link_doc = text "While filling requirements of" <+> reqs_doc + reqs_doc + | null reqs = dispModuleSource (getSource req) + | otherwise = ( text " " <+> dispModuleSource (getSource req) $$ + vcat [ text "and" <+> dispModuleSource (getSource r) | r <- reqs]) +linkProvision _ _ _ = error "linkProvision" @@ -83,9 +116,9 @@ (UnitIdThunkU u1, UnitIdThunkU u2) | u1 == u2 -> return () | otherwise -> - unifyFail $ - "pre-installed unit IDs " ++ display u1 ++ - " and " ++ display u2 ++ " do not match." + failWith $ hang (text "Couldn't match unit IDs:") 4 + (text " " <+> disp u1 $$ + text "and" <+> disp u2) (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) -> unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) @@ -116,9 +149,10 @@ when (cid1 /= cid2) $ -- TODO: if we had a package identifier, could be an -- easier to understand error message. - unifyFail $ - "component IDs " ++ - display cid1 ++ " and " ++ display cid2 ++ " do not match." + failWith $ + hang (text "Couldn't match component IDs:") 4 + (text " " <+> disp cid1 $$ + text "and" <+> disp cid2) -- The KEY STEP which makes this a Huet-style unification -- algorithm. (Also a payoff of using union-find.) -- We can build infinite unit IDs this way, which is necessary @@ -140,10 +174,10 @@ (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do when (mod_name1 /= mod_name2) $ - unifyFail $ - "module names " ++ - display mod_name1 ++ " and " ++ - display mod_name2 ++ " disagree." + failWith $ + hang (text "Cannot match module names") 4 $ + text " " <+> disp mod_name1 $$ + text "and" <+> disp mod_name2 -- NB: this is not actually necessary (because we'll -- detect loops eventually in 'unifyUnitId'), but it -- seems harmless enough diff --git a/cabal/Cabal/Distribution/Backpack/ModuleScope.hs b/cabal/Cabal/Distribution/Backpack/ModuleScope.hs --- a/cabal/Cabal/Distribution/Backpack/ModuleScope.hs +++ b/cabal/Cabal/Distribution/Backpack/ModuleScope.hs @@ -1,25 +1,35 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} -- | See module Distribution.Backpack.ModuleScope ( -- * Module scopes ModuleScope(..), ModuleProvides, + ModuleRequires, ModuleSource(..), + dispModuleSource, + WithSource(..), + unWithSource, + getSource, + ModuleWithSource, emptyModuleScope, ) where import Prelude () +import Distribution.Compat.Prelude import Distribution.ModuleName -import Distribution.Package import Distribution.Types.IncludeRenaming +import Distribution.Types.PackageName +import Distribution.Types.ComponentName import Distribution.Backpack import Distribution.Backpack.ModSubst +import Distribution.Text -import Data.Map (Map) import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set +import Text.PrettyPrint ----------------------------------------------------------------------- @@ -58,29 +68,64 @@ -- can influence the 'ModuleShape' via a reexport. data ModuleScope = ModuleScope { modScopeProvides :: ModuleProvides, - modScopeRequires :: Set ModuleName + modScopeRequires :: ModuleRequires } +-- | An empty 'ModuleScope'. +emptyModuleScope :: ModuleScope +emptyModuleScope = ModuleScope Map.empty Map.empty + -- | Every 'Module' in scope at a 'ModuleName' is annotated with -- the 'PackageName' it comes from. -type ModuleProvides = Map ModuleName [ModuleSource] -data ModuleSource = - ModuleSource { - -- We don't have line numbers, but if we did the - -- package name and renaming could be associated - -- with that as well - msrc_pkgname :: PackageName, - msrc_renaming :: IncludeRenaming, - msrc_module :: OpenModule - } +type ModuleProvides = Map ModuleName [ModuleWithSource] +-- | INVARIANT: entries for ModuleName m, have msrc_module is OpenModuleVar m +type ModuleRequires = Map ModuleName [ModuleWithSource] +-- TODO: consider newtping the two types above. -instance ModSubst ModuleScope where - modSubst subst (ModuleScope provs reqs) - = ModuleScope (modSubst subst provs) (modSubst subst reqs) +-- | Description of where a module participating in mixin linking came +-- from. +data ModuleSource + = FromMixins PackageName ComponentName IncludeRenaming + | FromBuildDepends PackageName ComponentName + | FromExposedModules ModuleName + | FromOtherModules ModuleName + | FromSignatures ModuleName +-- We don't have line numbers, but if we did, we'd want to record that +-- too --- | An empty 'ModuleScope'. -emptyModuleScope :: ModuleScope -emptyModuleScope = ModuleScope Map.empty Set.empty +-- TODO: Deduplicate this with Distribution.Backpack.UnifyM.ci_msg +dispModuleSource :: ModuleSource -> Doc +dispModuleSource (FromMixins pn cn incls) + = text "mixins:" <+> dispComponent pn cn <+> disp incls +dispModuleSource (FromBuildDepends pn cn) + = text "build-depends:" <+> dispComponent pn cn +dispModuleSource (FromExposedModules m) + = text "exposed-modules:" <+> disp m +dispModuleSource (FromOtherModules m) + = text "other-modules:" <+> disp m +dispModuleSource (FromSignatures m) + = text "signatures:" <+> disp m -instance ModSubst ModuleSource where - modSubst subst src = src { msrc_module = modSubst subst (msrc_module src) } +-- Dependency +dispComponent :: PackageName -> ComponentName -> Doc +dispComponent pn cn = + -- NB: This syntax isn't quite the source syntax, but it + -- should be clear enough. To do source syntax, we'd + -- need to know what the package we're linking is. + case cn of + CLibName -> disp pn + CSubLibName ucn -> disp pn <<>> colon <<>> disp ucn + -- Case below shouldn't happen + _ -> disp pn <+> parens (disp cn) + +-- | An 'OpenModule', annotated with where it came from in a Cabal file. +data WithSource a = WithSource ModuleSource a + deriving (Functor, Foldable, Traversable) +unWithSource :: WithSource a -> a +unWithSource (WithSource _ x) = x +getSource :: WithSource a -> ModuleSource +getSource (WithSource s _) = s +type ModuleWithSource = WithSource OpenModule + +instance ModSubst a => ModSubst (WithSource a) where + modSubst subst (WithSource s m) = WithSource s (modSubst subst m) diff --git a/cabal/Cabal/Distribution/Backpack/PreExistingComponent.hs b/cabal/Cabal/Distribution/Backpack/PreExistingComponent.hs --- a/cabal/Cabal/Distribution/Backpack/PreExistingComponent.hs +++ b/cabal/Cabal/Distribution/Backpack/PreExistingComponent.hs @@ -5,12 +5,19 @@ ) where import Prelude () +import Distribution.Compat.Prelude import Distribution.Backpack.ModuleShape import Distribution.Backpack +import Distribution.Types.ComponentId +import Distribution.Types.MungedPackageId +import Distribution.Types.PackageId +import Distribution.Types.UnitId +import Distribution.Types.ComponentName +import Distribution.Types.PackageName +import Distribution.Package import qualified Data.Map as Map -import Distribution.Package import qualified Distribution.InstalledPackageInfo as Installed import Distribution.InstalledPackageInfo (InstalledPackageInfo) @@ -18,13 +25,14 @@ -- we don't need to know how to build. data PreExistingComponent = PreExistingComponent { - -- | The 'PackageName' that, when we see it in 'PackageDescription', - -- we should map this to. This may DISAGREE with 'pc_pkgid' for - -- internal dependencies: e.g., an internal component @lib@ - -- may be munged to @z-pkg-z-lib@, but we still want to use - -- it when we see @lib@ in @build-depends@ + -- | The actual name of the package. This may DISAGREE with 'pc_pkgid' + -- for internal dependencies: e.g., an internal component @lib@ may be + -- munged to @z-pkg-z-lib@, but we still want to use it when we see + -- @lib@ in @build-depends@ pc_pkgname :: PackageName, - pc_pkgid :: PackageId, + -- | The actual name of the component. + pc_compname :: ComponentName, + pc_munged_id :: MungedPackageId, pc_uid :: UnitId, pc_cid :: ComponentId, pc_open_uid :: OpenUnitId, @@ -34,11 +42,12 @@ -- | Convert an 'InstalledPackageInfo' into a 'PreExistingComponent', -- which was brought into scope under the 'PackageName' (important for -- a package qualified reference.) -ipiToPreExistingComponent :: (PackageName, InstalledPackageInfo) -> PreExistingComponent -ipiToPreExistingComponent (pn, ipi) = +ipiToPreExistingComponent :: InstalledPackageInfo -> PreExistingComponent +ipiToPreExistingComponent ipi = PreExistingComponent { - pc_pkgname = pn, - pc_pkgid = Installed.sourcePackageId ipi, + pc_pkgname = packageName ipi, + pc_compname = libraryComponentName $ Installed.sourceLibName ipi, + pc_munged_id = mungedId ipi, pc_uid = Installed.installedUnitId ipi, pc_cid = Installed.installedComponentId ipi, pc_open_uid = @@ -47,3 +56,12 @@ pc_shape = shapeInstalledPackage ipi } +instance HasMungedPackageId PreExistingComponent where + mungedId = pc_munged_id + +instance Package PreExistingComponent where + packageId pec = PackageIdentifier (pc_pkgname pec) v + where MungedPackageId _ v = pc_munged_id pec + +instance HasUnitId PreExistingComponent where + installedUnitId = pc_uid diff --git a/cabal/Cabal/Distribution/Backpack/PreModuleShape.hs b/cabal/Cabal/Distribution/Backpack/PreModuleShape.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Backpack/PreModuleShape.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Backpack.PreModuleShape ( + PreModuleShape(..), + toPreModuleShape, + renamePreModuleShape, + mixLinkPreModuleShape, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Map as Map + +import Distribution.Backpack.ModuleShape +import Distribution.Types.IncludeRenaming +import Distribution.Types.ModuleRenaming +import Distribution.ModuleName + +data PreModuleShape = PreModuleShape { + preModShapeProvides :: Set ModuleName, + preModShapeRequires :: Set ModuleName + } + deriving (Eq, Show, Generic) + +toPreModuleShape :: ModuleShape -> PreModuleShape +toPreModuleShape (ModuleShape provs reqs) = PreModuleShape (Map.keysSet provs) reqs + +renamePreModuleShape :: PreModuleShape -> IncludeRenaming -> PreModuleShape +renamePreModuleShape (PreModuleShape provs reqs) (IncludeRenaming prov_rn req_rn) = + PreModuleShape + (Set.fromList (mapMaybe prov_fn (Set.toList provs))) + (Set.map req_fn reqs) + where + prov_fn = interpModuleRenaming prov_rn + req_fn k = fromMaybe k (interpModuleRenaming req_rn k) + +mixLinkPreModuleShape :: [PreModuleShape] -> PreModuleShape +mixLinkPreModuleShape shapes = PreModuleShape provs (Set.difference reqs provs) + where + provs = Set.unions (map preModShapeProvides shapes) + reqs = Set.unions (map preModShapeRequires shapes) diff --git a/cabal/Cabal/Distribution/Backpack/ReadyComponent.hs b/cabal/Cabal/Distribution/Backpack/ReadyComponent.hs --- a/cabal/Cabal/Distribution/Backpack/ReadyComponent.hs +++ b/cabal/Cabal/Distribution/Backpack/ReadyComponent.hs @@ -5,8 +5,9 @@ ReadyComponent(..), InstantiatedComponent(..), IndefiniteComponent(..), - rc_compat_name, - rc_compat_key, + rc_depends, + rc_uid, + rc_pkgid, dispReadyComponent, toReadyComponents, ) where @@ -15,18 +16,26 @@ import Distribution.Compat.Prelude hiding ((<>)) import Distribution.Backpack -import Distribution.Backpack.Id import Distribution.Backpack.LinkedComponent import Distribution.Backpack.ModuleShape +import Distribution.Types.AnnotatedId import Distribution.Types.ModuleRenaming import Distribution.Types.Component +import Distribution.Types.ComponentInclude +import Distribution.Types.ComponentId +import Distribution.Types.ComponentName +import Distribution.Types.PackageId +import Distribution.Types.UnitId import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Types.Module +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.Library import Distribution.ModuleName import Distribution.Package import Distribution.Simple.Utils -import Distribution.Simple.Compiler import qualified Control.Applicative as A import qualified Data.Traversable as T @@ -38,45 +47,113 @@ import Distribution.Version import Distribution.Text --- | An instantiated component is simply a linked component which --- may have a fully instantiated 'UnitId'. When we do mix-in linking, --- we only do each component in its most general form; instantiation --- then takes all of the fully instantiated components and recursively --- discovers what other instantiated components we need to build --- before we can build them. +-- | A 'ReadyComponent' is one that we can actually generate build +-- products for. We have a ready component for the typecheck-only +-- products of every indefinite package, as well as a ready component +-- for every way these packages can be fully instantiated. -- +data ReadyComponent + = ReadyComponent { + rc_ann_id :: AnnotatedId UnitId, + -- | The 'OpenUnitId' for this package. At the moment, this + -- is used in only one case, which is to determine if an + -- export is of a module from this library (indefinite + -- libraries record these exports as 'OpenModule'); + -- 'rc_open_uid' can be conveniently used to test for + -- equality, whereas 'UnitId' cannot always be used in this + -- case. + rc_open_uid :: OpenUnitId, + -- | Corresponds to 'lc_cid'. Invariant: if 'rc_open_uid' + -- records a 'ComponentId', it coincides with this one. + rc_cid :: ComponentId, + -- | Corresponds to 'lc_component'. + rc_component :: Component, + -- | Corresponds to 'lc_exe_deps'. + -- Build-tools don't participate in mix-in linking. + -- (but what if they could?) + rc_exe_deps :: [AnnotatedId UnitId], + -- | Corresponds to 'lc_public'. + rc_public :: Bool, + -- | Extra metadata depending on whether or not this is an + -- indefinite library (typechecked only) or an instantiated + -- component (can be compiled). + rc_i :: Either IndefiniteComponent InstantiatedComponent + } +-- | The final, string 'UnitId' that will uniquely identify +-- the compilation products of this component. +rc_uid :: ReadyComponent -> UnitId +rc_uid = ann_id . rc_ann_id + +-- | Corresponds to 'lc_pkgid'. +rc_pkgid :: ReadyComponent -> PackageId +rc_pkgid = ann_pid . rc_ann_id + +-- | An 'InstantiatedComponent' is a library which is fully instantiated +-- (or, possibly, has no requirements at all.) data InstantiatedComponent = InstantiatedComponent { + -- | How this library was instantiated. instc_insts :: [(ModuleName, Module)], + -- | Dependencies induced by 'instc_insts'. These are recorded + -- here because there isn't a convenient way otherwise to get + -- the 'PackageId' we need to fill 'componentPackageDeps' as needed. + instc_insts_deps :: [(UnitId, MungedPackageId)], + -- | The modules exported/reexported by this library. instc_provides :: Map ModuleName Module, - instc_includes :: [(DefUnitId, ModuleRenaming)] + -- | The dependencies which need to be passed to the compiler + -- to bring modules into scope. These always refer to installed + -- fully instantiated libraries. + instc_includes :: [ComponentInclude DefUnitId ModuleRenaming] } +-- | An 'IndefiniteComponent' is a library with requirements +-- which we will typecheck only. data IndefiniteComponent = IndefiniteComponent { + -- | The requirements of the library. indefc_requires :: [ModuleName], + -- | The modules exported/reexported by this library. indefc_provides :: Map ModuleName OpenModule, - indefc_includes :: [(OpenUnitId, ModuleRenaming)] + -- | The dependencies which need to be passed to the compiler + -- to bring modules into scope. These are 'OpenUnitId' because + -- these may refer to partially instantiated libraries. + indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] } -data ReadyComponent - = ReadyComponent { - rc_uid :: UnitId, - rc_open_uid :: OpenUnitId, - rc_cid :: ComponentId, - rc_pkgid :: PackageId, - rc_component :: Component, - -- build-tools don't participate in mix-in linking. - -- (but what if they cold?) - rc_internal_build_tools :: [DefUnitId], - rc_public :: Bool, - -- PackageId here is a bit dodgy, but its just for - -- BC so it shouldn't matter. - rc_depends :: [(UnitId, PackageId)], - rc_i :: Either IndefiniteComponent InstantiatedComponent - } +-- | Compute the dependencies of a 'ReadyComponent' that should +-- be recorded in the @depends@ field of 'InstalledPackageInfo'. +rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)] +rc_depends rc = ordNub $ + case rc_i rc of + Left indefc -> + map (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci)) + (indefc_includes indefc) + Right instc -> + map (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci)) + (instc_includes instc) + ++ instc_insts_deps instc + where + toMungedPackageId :: Text id => ComponentInclude id rn -> MungedPackageId + toMungedPackageId ci = + computeCompatPackageId + (ci_pkgid ci) + (case ci_cname ci of + CLibName -> Nothing + CSubLibName uqn -> Just uqn + _ -> error $ display (rc_cid rc) ++ + " depends on non-library " ++ display (ci_id ci)) +-- | Get the 'MungedPackageId' of a 'ReadyComponent' IF it is +-- a library. +rc_munged_id :: ReadyComponent -> MungedPackageId +rc_munged_id rc = + computeCompatPackageId + (rc_pkgid rc) + (case rc_component rc of + CLib lib -> libName lib + _ -> error "rc_munged_id: not library") + instance Package ReadyComponent where packageId = rc_pkgid @@ -93,22 +170,8 @@ | otherwise -> [newSimpleUnitId (rc_cid rc)] _ -> []) ++ - ordNub (map fst (rc_depends rc)) - -rc_compat_name :: ReadyComponent -> PackageName -rc_compat_name ReadyComponent{ - rc_pkgid = PackageIdentifier pkg_name _, - rc_component = component - } - = computeCompatPackageName pkg_name (componentName component) - -rc_compat_key :: ReadyComponent -> Compiler -> String -rc_compat_key rc@ReadyComponent { - rc_pkgid = PackageIdentifier _ pkg_ver, - rc_uid = uid - } comp -- TODO: A wart. But the alternative is to store - -- the Compiler in the LinkedComponent - = computeCompatPackageKey comp (rc_compat_name rc) pkg_ver uid + ordNub (map fst (rc_depends rc)) ++ + map ann_id (rc_exe_deps rc) dispReadyComponent :: ReadyComponent -> Doc dispReadyComponent rc = @@ -162,7 +225,7 @@ -- instantiated components are given 'HashedUnitId'. -- toReadyComponents - :: Map UnitId PackageId + :: Map UnitId MungedPackageId -> Map ModuleName Module -- subst for the public component -> [LinkedComponent] -> [ReadyComponent] @@ -194,14 +257,13 @@ -> InstM (Maybe ReadyComponent) instantiateComponent uid cid insts | Just lc <- Map.lookup cid cmap = do - deps <- forM (lc_depends lc) $ \(x, y) -> do - x' <- substUnitId insts x - return (x', y) provides <- T.mapM (substModule insts) (modShapeProvides (lc_shape lc)) - includes <- forM (lc_includes lc) $ \(x, y) -> do - x' <- substUnitId insts x - return (x', y) - build_tools <- mapM (substUnitId insts) (lc_internal_build_tools lc) + -- NB: lc_sig_includes is omitted here, because we don't + -- need them to build + includes <- forM (lc_includes lc) $ \ci -> do + uid' <- substUnitId insts (ci_id ci) + return ci { ci_ann_id = fmap (const uid') (ci_ann_id ci) } + exe_deps <- mapM (substExeDep insts) (lc_exe_deps lc) s <- InstM $ \s -> (s, s) let getDep (Module dep_def_uid _) | let dep_uid = unDefUnitId dep_def_uid @@ -209,31 +271,31 @@ = [(dep_uid, fromMaybe err_pid $ Map.lookup dep_uid pid_map A.<|> - fmap rc_pkgid (join (Map.lookup dep_uid s)))] + fmap rc_munged_id (join (Map.lookup dep_uid s)))] where - err_pid = - PackageIdentifier - (mkPackageName "nonexistent-package-this-is-a-cabal-bug") + err_pid = MungedPackageId + (mkMungedPackageName "nonexistent-package-this-is-a-cabal-bug") (mkVersion [0]) instc = InstantiatedComponent { instc_insts = Map.toList insts, + instc_insts_deps = concatMap getDep (Map.elems insts), instc_provides = provides, instc_includes = includes + -- NB: there is no dependency on the + -- indefinite version of this instantiated package here, + -- as (1) it doesn't go in depends in the + -- IPI: it's not a run time dep, and (2) + -- we don't have to tell GHC about it, it + -- will match up the ComponentId + -- automatically } return $ Just ReadyComponent { - rc_uid = uid, + rc_ann_id = (lc_ann_id lc) { ann_id = uid }, rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid), rc_cid = lc_cid lc, - rc_pkgid = lc_pkgid lc, rc_component = lc_component lc, - rc_internal_build_tools = build_tools, + rc_exe_deps = exe_deps, rc_public = lc_public lc, - rc_depends = ordNub $ - -- NB: don't put the dep on the indef - -- package here, since we DO NOT want - -- to put it in 'depends' in the IPI - map (\(x,y) -> (unDefUnitId x, y)) deps ++ - concatMap getDep (Map.elems insts), rc_i = Right instc } | otherwise = return Nothing @@ -259,6 +321,12 @@ uid' <- substUnitId subst uid return (Module uid' mod_name) + substExeDep :: Map ModuleName Module + -> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId) + substExeDep insts exe_aid = do + exe_uid' <- substUnitId insts (ann_id exe_aid) + return exe_aid { ann_id = unDefUnitId exe_uid' } + indefiniteUnitId :: ComponentId -> InstM UnitId indefiniteUnitId cid = do let uid = newSimpleUnitId cid @@ -268,22 +336,20 @@ indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent) indefiniteComponent uid cid | Just lc <- Map.lookup cid cmap = do - -- TODO: Goofy - build_tools <- mapM (substUnitId Map.empty) (lc_internal_build_tools lc) + exe_deps <- mapM (substExeDep Map.empty) (lc_exe_deps lc) let indefc = IndefiniteComponent { indefc_requires = map fst (lc_insts lc), indefc_provides = modShapeProvides (lc_shape lc), - indefc_includes = lc_includes lc + indefc_includes = lc_includes lc ++ lc_sig_includes lc } return $ Just ReadyComponent { - rc_uid = uid, + rc_ann_id = (lc_ann_id lc) { ann_id = uid }, + rc_cid = lc_cid lc, rc_open_uid = lc_uid lc, - rc_cid = lc_cid lc, - rc_pkgid = lc_pkgid lc, rc_component = lc_component lc, - rc_internal_build_tools = build_tools, + -- It's always fully built + rc_exe_deps = exe_deps, rc_public = lc_public lc, - rc_depends = ordNub (map (\(x,y) -> (abstractUnitId x, y)) (lc_depends lc)), rc_i = Left indefc } | otherwise = return Nothing diff --git a/cabal/Cabal/Distribution/Backpack/UnifyM.hs b/cabal/Cabal/Distribution/Backpack/UnifyM.hs --- a/cabal/Cabal/Distribution/Backpack/UnifyM.hs +++ b/cabal/Cabal/Distribution/Backpack/UnifyM.hs @@ -1,11 +1,16 @@ {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | See module Distribution.Backpack.UnifyM ( -- * Unification monad UnifyM, runUnifyM, - unifyFail, - withContext, + failWith, + addErr, + failIfErrs, + tryM, + addErrContext, + addErrContextM, liftST, UnifEnv(..), @@ -30,7 +35,7 @@ emptyModuleScopeU, convertModuleScopeU, - ModuleSourceU(..), + ModuleWithSourceU, convertInclude, convertModuleProvides, @@ -53,33 +58,61 @@ import Distribution.PackageDescription import Distribution.Text import Distribution.Types.IncludeRenaming +import Distribution.Types.ComponentInclude +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentName import Distribution.Verbosity import Data.STRef +import Data.Traversable import Control.Monad.ST -import Control.Monad import qualified Data.Map as Map import qualified Data.Set as Set import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import qualified Data.Traversable as T +import Text.PrettyPrint -- TODO: more detailed trace output on high verbosity would probably -- be appreciated by users debugging unification errors. Collect -- some good examples! +data ErrMsg = ErrMsg { + err_msg :: Doc, + err_ctx :: [Doc] + } +type MsgDoc = Doc + +renderErrMsg :: ErrMsg -> MsgDoc +renderErrMsg ErrMsg { err_msg = msg, err_ctx = ctx } = + msg $$ vcat ctx + -- | The unification monad, this monad encapsulates imperative -- unification. -newtype UnifyM s a = UnifyM { unUnifyM :: UnifEnv s -> ST s (Either String a) } +newtype UnifyM s a = UnifyM { unUnifyM :: UnifEnv s -> ST s (Maybe a) } -- | Run a computation in the unification monad. -runUnifyM :: Verbosity -> FullDb -> (forall s. UnifyM s a) -> Either String a -runUnifyM verbosity db m +runUnifyM :: Verbosity -> ComponentId -> FullDb -> (forall s. UnifyM s a) -> Either [MsgDoc] a +runUnifyM verbosity self_cid db m = runST $ do i <- newSTRef 0 hmap <- newSTRef Map.empty - unUnifyM m (UnifEnv i hmap verbosity Nothing db) + errs <- newSTRef [] + mb_r <- unUnifyM m UnifEnv { + unify_uniq = i, + unify_reqs = hmap, + unify_self_cid = self_cid, + unify_verbosity = verbosity, + unify_ctx = [], + unify_db = db, + unify_errs = errs } + final_errs <- readSTRef errs + case mb_r of + Just x | null final_errs -> return (Right x) + _ -> return (Left (map renderErrMsg (reverse final_errs))) -- NB: GHC 7.6 throws a hissy fit if you pattern match on 'm'. +type ErrCtx s = MsgDoc + -- | The unification environment. data UnifEnv s = UnifEnv { -- | A supply of unique integers to label 'UnitIdU' @@ -91,12 +124,19 @@ -- the requirement at the same module name to fill it. -- This mapping grows monotonically. unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)), + -- | Component id of the unit we're linking. We use this + -- to detect if we fill a requirement with a local module, + -- which in principle should be OK but is not currently + -- supported by GHC. + unify_self_cid :: ComponentId, -- | How verbose the error message should be unify_verbosity :: Verbosity, -- | The error reporting context - unify_ctx :: Maybe (String, ModuleU s, ModuleU s), + unify_ctx :: [ErrCtx s], -- | The package index for expanding unit identifiers - unify_db :: FullDb + unify_db :: FullDb, + -- | Accumulated errors + unify_errs :: UnifRef s [ErrMsg] } instance Functor (UnifyM s) where @@ -107,31 +147,64 @@ UnifyM f <*> UnifyM x = UnifyM $ \r -> do f' <- f r case f' of - Left err -> return (Left err) - Right f'' -> do + Nothing -> return Nothing + Just f'' -> do x' <- x r case x' of - Left err -> return (Left err) - Right x'' -> return (Right (f'' x'')) + Nothing -> return Nothing + Just x'' -> return (Just (f'' x'')) instance Monad (UnifyM s) where return = pure UnifyM m >>= f = UnifyM $ \r -> do x <- m r case x of - Left err -> return (Left err) - Right x' -> unUnifyM (f x') r + Nothing -> return Nothing + Just x' -> unUnifyM (f x') r -- | Lift a computation from 'ST' monad to 'UnifyM' monad. -- Internal use only. liftST :: ST s a -> UnifyM s a -liftST m = UnifyM $ \_ -> fmap Right m +liftST m = UnifyM $ \_ -> fmap Just m -unifyFail :: String -> UnifyM s a +addErr :: MsgDoc -> UnifyM s () +addErr msg = do + env <- getUnifEnv + let err = ErrMsg { + err_msg = msg, + err_ctx = unify_ctx env + } + liftST $ modifySTRef (unify_errs env) (\errs -> err:errs) + +failWith :: MsgDoc -> UnifyM s a +failWith msg = do + addErr msg + failM + +failM :: UnifyM s a +failM = UnifyM $ \_ -> return Nothing + +failIfErrs :: UnifyM s () +failIfErrs = do + env <- getUnifEnv + errs <- liftST $ readSTRef (unify_errs env) + when (not (null errs)) failM + +tryM :: UnifyM s a -> UnifyM s (Maybe a) +tryM m = + UnifyM (\env -> do + mb_r <- unUnifyM m env + return (Just mb_r)) + +{- +otherFail :: ErrMsg -> UnifyM s a +otherFail s = UnifyM $ \_ -> return (Left s) + +unifyFail :: ErrMsg -> UnifyM s a unifyFail err = do env <- getUnifEnv msg <- case unify_ctx env of - Nothing -> return ("Unspecified unification error: " ++ err) + Nothing -> return (text "Unspecified unification error:" <+> err) Just (ctx, mod1, mod2) | unify_verbosity env > normal -> do mod1' <- convertModuleU mod1 @@ -142,6 +215,7 @@ | otherwise -> return (ctx ++ err ++ " (for more information, pass -v flag)") UnifyM $ \_ -> return (Left msg) +-} -- | A convenient alias for mutable references in the unification monad. type UnifRef s a = STRef s a @@ -156,13 +230,18 @@ -- | Get the current unification environment. getUnifEnv :: UnifyM s (UnifEnv s) -getUnifEnv = UnifyM $ \r -> return (Right r) +getUnifEnv = UnifyM $ \r -> return (return r) --- | Run a unification in some context -withContext :: String -> ModuleU s -> ModuleU s -> UnifyM s a -> UnifyM s a -withContext ctx mod1 mod2 m = - UnifyM $ \r -> unUnifyM m r { unify_ctx = Just (ctx, mod1, mod2) } +-- | Add a fixed message to the error context. +addErrContext :: Doc -> UnifyM s a -> UnifyM s a +addErrContext ctx m = addErrContextM ctx m +-- | Add a message to the error context. It may make monadic queries. +addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a +addErrContextM ctx m = + UnifyM $ \r -> unUnifyM m r { unify_ctx = ctx : unify_ctx r } + + ----------------------------------------------------------------------- -- The "unifiable" variants of the data types -- @@ -317,7 +396,9 @@ UnitIdThunkU uid -> return (DefiniteUnitId uid) UnitIdU u cid insts_u -> case lookupMooEnv stk u of - Just _i -> error "convertUnitIdU': mutual recursion" -- return (UnitIdVar i) + Just _i -> + failWith (text "Unsupported mutually recursive unit identifier") + -- return (UnitIdVar i) Nothing -> do insts <- T.forM insts_u $ convertModuleU' (extendMooEnv stk u) return (IndefFullUnitId cid insts) @@ -345,26 +426,48 @@ -- | The mutable counterpart of 'ModuleScope'. -type ModuleScopeU s = (ModuleProvidesU s, ModuleSubstU s) +type ModuleScopeU s = (ModuleProvidesU s, ModuleRequiresU s) -- | The mutable counterpart of 'ModuleProvides' -type ModuleProvidesU s = Map ModuleName [ModuleSourceU s] -data ModuleSourceU s = - ModuleSourceU { - -- We don't have line numbers, but if we did the - -- package name and renaming could be associated - -- with that as well - usrc_pkgname :: PackageName, - usrc_renaming :: IncludeRenaming, - usrc_module :: ModuleU s - } +type ModuleProvidesU s = Map ModuleName [ModuleWithSourceU s] +type ModuleRequiresU s = ModuleProvidesU s +type ModuleWithSourceU s = WithSource (ModuleU s) +-- TODO: Deduplicate this with Distribution.Backpack.MixLink.dispSource +ci_msg :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming -> Doc +ci_msg ci + | ci_implicit ci = text "build-depends:" <+> pp_pn + | otherwise = text "mixins:" <+> pp_pn <+> disp (ci_renaming ci) + where + pn = pkgName (ci_pkgid ci) + pp_pn = + case ci_cname ci of + CLibName -> disp pn + CSubLibName cn -> disp pn <<>> colon <<>> disp cn + -- Shouldn't happen + cn -> disp pn <+> parens (disp cn) + -- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do -- unification on it. convertInclude - :: ((OpenUnitId, ModuleShape), PackageId, IncludeRenaming) - -> UnifyM s (ModuleScopeU s, (UnitIdU s, PackageId, ModuleRenaming)) -convertInclude ((uid, ModuleShape provs reqs), pid, incl@(IncludeRenaming prov_rns req_rns)) = do + :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming + -> UnifyM s (ModuleScopeU s, + Either (ComponentInclude (UnitIdU s) ModuleRenaming) {- normal -} + (ComponentInclude (UnitIdU s) ModuleRenaming) {- sig -}) +convertInclude ci@(ComponentInclude { + ci_ann_id = AnnotatedId { + ann_id = (uid, ModuleShape provs reqs), + ann_pid = pid, + ann_cname = compname + }, + ci_renaming = incl@(IncludeRenaming prov_rns req_rns), + ci_implicit = implicit + }) = addErrContext (text "In" <+> ci_msg ci) $ do let pn = packageName pid + the_source | implicit + = FromBuildDepends pn compname + | otherwise + = FromMixins pn compname incl + source = WithSource the_source -- Suppose our package has two requirements A and B, and -- we include it with @requires (A as X)@ @@ -383,16 +486,29 @@ -- are mapped to the same name, the intent is to merge them -- together. But they are *functions*, so @B as X, B as Y@ is -- illegal. - let insertDistinct m (k,v) = - if Map.member k m - then error ("Duplicate requirement renaming " ++ display k) - else return (Map.insert k v m) - req_rename <- foldM insertDistinct Map.empty =<< - case req_rns of - DefaultRenaming -> return [] - -- Not valid here, but whatever - HidingRenaming _ -> error "Cannot use hiding in requirement renaming" - ModuleRenaming rns -> return rns + + req_rename_list <- + case req_rns of + DefaultRenaming -> return [] + HidingRenaming _ -> do + -- Not valid here for requires! + addErr $ text "Unsupported syntax" <+> + quotes (text "requires hiding (...)") + return [] + ModuleRenaming rns -> return rns + + let req_rename_listmap :: Map ModuleName [ModuleName] + req_rename_listmap = + Map.fromListWith (++) [ (k,[v]) | (k,v) <- req_rename_list ] + req_rename <- sequenceA . flip Map.mapWithKey req_rename_listmap $ \k vs0 -> + case vs0 of + [] -> error "req_rename" + [v] -> return v + v:vs -> do addErr $ + text "Conflicting renamings of requirement" <+> quotes (disp k) $$ + text "Renamed to: " <+> vcat (map disp (v:vs)) + return v + let req_rename_fn k = case Map.lookup k req_rename of Nothing -> k Just v -> v @@ -410,11 +526,20 @@ -- mappings. -- -- A -> X ==> X -> , B -> - reqs_u <- convertModuleSubst . Map.fromList $ - [ (k, OpenModuleVar k) + reqs_u <- convertModuleRequires . Map.fromList $ + [ (k, [source (OpenModuleVar k)]) | k <- map req_rename_fn (Set.toList reqs) ] + -- Report errors if there were unused renamings + let leftover = Map.keysSet req_rename `Set.difference` reqs + unless (Set.null leftover) $ + addErr $ + hang (text "The" <+> text (showComponentName compname) <+> + text "from package" <+> quotes (disp pid) + <+> text "does not require:") 4 + (vcat (map disp (Set.toList leftover))) + -- Provision computation is more complex. -- For example, if we have: -- @@ -450,37 +575,54 @@ r <- sequence [ case Map.lookup from provs of Just m -> return (to, m) - Nothing -> error ("Tried to rename non-existent module " ++ display from) + Nothing -> failWith $ + text "Package" <+> quotes (disp pid) <+> + text "does not expose the module" <+> quotes (disp from) | (from, to) <- rns ] return (r, prov_rns) let prov_scope = modSubst req_subst $ Map.fromListWith (++) - [ (k, [ModuleSource pn incl v]) + [ (k, [source v]) | (k, v) <- pre_prov_scope ] provs_u <- convertModuleProvides prov_scope - return ((provs_u, reqs_u), (uid_u, pid, prov_rns')) + -- TODO: Assert that provs_u is empty if provs was empty + return ((provs_u, reqs_u), + -- NB: We test that requirements is not null so that + -- users can create packages with zero module exports + -- that cause some C library to linked in, etc. + (if Map.null provs && not (Set.null reqs) + then Right -- is sig + else Left) (ComponentInclude { + ci_ann_id = AnnotatedId { + ann_id = uid_u, + ann_pid = pid, + ann_cname = compname + }, + ci_renaming = prov_rns', + ci_implicit = ci_implicit ci + })) -- | Convert a 'ModuleScopeU' to a 'ModuleScope'. convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope convertModuleScopeU (provs_u, reqs_u) = do provs <- convertModuleProvidesU provs_u - reqs <- convertModuleSubstU reqs_u + reqs <- convertModuleRequiresU reqs_u -- TODO: Test that the requirements are still free. If they -- are not, they got unified, and that's dodgy at best. - return (ModuleScope provs (Map.keysSet reqs)) + return (ModuleScope provs reqs) -- | Convert a 'ModuleProvides' to a 'ModuleProvidesU' convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s) -convertModuleProvides = T.mapM $ \ms -> - mapM (\(ModuleSource pn incl m) - -> do m' <- convertModule m - return (ModuleSourceU pn incl m')) ms +convertModuleProvides = T.mapM (mapM (T.mapM convertModule)) -- | Convert a 'ModuleProvidesU' to a 'ModuleProvides' convertModuleProvidesU :: ModuleProvidesU s -> UnifyM s ModuleProvides -convertModuleProvidesU = T.mapM $ \ms -> - mapM (\(ModuleSourceU pn incl m) - -> do m' <- convertModuleU m - return (ModuleSource pn incl m')) ms +convertModuleProvidesU = T.mapM (mapM (T.mapM convertModuleU)) + +convertModuleRequires :: ModuleRequires -> UnifyM s (ModuleRequiresU s) +convertModuleRequires = convertModuleProvides + +convertModuleRequiresU :: ModuleRequiresU s -> UnifyM s ModuleRequires +convertModuleRequiresU = convertModuleProvidesU diff --git a/cabal/Cabal/Distribution/Compat/Binary/Class.hs b/cabal/Cabal/Distribution/Compat/Binary/Class.hs --- a/cabal/Cabal/Distribution/Compat/Binary/Class.hs +++ b/cabal/Cabal/Distribution/Compat/Binary/Class.hs @@ -30,7 +30,7 @@ import Data.Binary.Put import Data.Binary.Get -import Control.Monad +import Control.Applicative ((<$>), (<*>), (*>)) import Foreign import Data.ByteString.Lazy (ByteString) @@ -104,12 +104,12 @@ -- Bools are encoded as a byte in the range 0 .. 1 instance Binary Bool where put = putWord8 . fromIntegral . fromEnum - get = liftM (toEnum . fromIntegral) getWord8 + get = fmap (toEnum . fromIntegral) getWord8 -- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 instance Binary Ordering where put = putWord8 . fromIntegral . fromEnum - get = liftM (toEnum . fromIntegral) getWord8 + get = fmap (toEnum . fromIntegral) getWord8 ------------------------------------------------------------------------ -- Words and Ints @@ -137,34 +137,34 @@ -- Int8s are written as a single byte. instance Binary Int8 where put i = put (fromIntegral i :: Word8) - get = liftM fromIntegral (get :: Get Word8) + get = fmap fromIntegral (get :: Get Word8) -- Int16s are written as a 2 bytes in big endian format instance Binary Int16 where put i = put (fromIntegral i :: Word16) - get = liftM fromIntegral (get :: Get Word16) + get = fmap fromIntegral (get :: Get Word16) -- Int32s are written as a 4 bytes in big endian format instance Binary Int32 where put i = put (fromIntegral i :: Word32) - get = liftM fromIntegral (get :: Get Word32) + get = fmap fromIntegral (get :: Get Word32) -- Int64s are written as a 4 bytes in big endian format instance Binary Int64 where put i = put (fromIntegral i :: Word64) - get = liftM fromIntegral (get :: Get Word64) + get = fmap fromIntegral (get :: Get Word64) ------------------------------------------------------------------------ -- Words are are written as Word64s, that is, 8 bytes in big endian format instance Binary Word where put i = put (fromIntegral i :: Word64) - get = liftM fromIntegral (get :: Get Word64) + get = fmap fromIntegral (get :: Get Word64) -- Ints are are written as Int64s, that is, 8 bytes in big endian format instance Binary Int where put i = put (fromIntegral i :: Int64) - get = liftM fromIntegral (get :: Get Int64) + get = fmap fromIntegral (get :: Get Int64) ------------------------------------------------------------------------ -- @@ -200,7 +200,7 @@ get = do tag <- get :: Get Word8 case tag of - 0 -> liftM fromIntegral (get :: Get SmallInt) + 0 -> fmap fromIntegral (get :: Get SmallInt) _ -> do sign <- get bytes <- get let v = roll bytes @@ -237,7 +237,7 @@ import GHC.IOBase (IO(..)) instance Binary Integer where - put (S# i) = putWord8 0 >> put (I# i) + put (S# i) = putWord8 0 *> put (I# i) put (J# s ba) = do putWord8 1 put (I# s) @@ -263,7 +263,7 @@ -- Pretty scary. Should be quick though get = do - (fp, off, n@(I# sz)) <- liftM toForeignPtr get -- so decode a ByteString + (fp, off, n@(I# sz)) <- fmap toForeignPtr get -- so decode a ByteString assert (off == 0) $ return $ unsafePerformIO $ do (MBA arr) <- newByteArray sz -- and copy it into a ByteArray# let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe? @@ -287,8 +287,8 @@ -} instance (Binary a,Integral a) => Binary (R.Ratio a) where - put r = put (R.numerator r) >> put (R.denominator r) - get = liftM2 (R.%) get get + put r = put (R.numerator r) *> put (R.denominator r) + get = (R.%) <$> get <*> get ------------------------------------------------------------------------ @@ -314,23 +314,23 @@ w = fromIntegral (shiftR c 18 .&. 0x7) get = do - let getByte = liftM (fromIntegral :: Word8 -> Int) get + let getByte = fmap (fromIntegral :: Word8 -> Int) get shiftL6 = flip shiftL 6 :: Int -> Int w <- getByte r <- case () of _ | w < 0x80 -> return w | w < 0xe0 -> do - x <- liftM (xor 0x80) getByte + x <- fmap (xor 0x80) getByte return (x .|. shiftL6 (xor 0xc0 w)) | w < 0xf0 -> do - x <- liftM (xor 0x80) getByte - y <- liftM (xor 0x80) getByte + x <- fmap (xor 0x80) getByte + y <- fmap (xor 0x80) getByte return (y .|. shiftL6 (x .|. shiftL6 (xor 0xe0 w))) | otherwise -> do - x <- liftM (xor 0x80) getByte - y <- liftM (xor 0x80) getByte - z <- liftM (xor 0x80) getByte + x <- fmap (xor 0x80) getByte + y <- fmap (xor 0x80) getByte + z <- fmap (xor 0x80) getByte return (z .|. shiftL6 (y .|. shiftL6 (x .|. shiftL6 (xor 0xf0 w)))) return $! chr r @@ -339,20 +339,20 @@ -- Instances for the first few tuples instance (Binary a, Binary b) => Binary (a,b) where - put (a,b) = put a >> put b - get = liftM2 (,) get get + put (a,b) = put a *> put b + get = (,) <$> get <*> get instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where - put (a,b,c) = put a >> put b >> put c - get = liftM3 (,,) get get get + put (a,b,c) = put a *> put b *> put c + get = (,,) <$> get <*> get <*> get instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where - put (a,b,c,d) = put a >> put b >> put c >> put d - get = liftM4 (,,,) get get get get + put (a,b,c,d) = put a *> put b *> put c *> put d + get = (,,,) <$> get <*> get <*> get <*> get instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where - put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e - get = liftM5 (,,,,) get get get get get + put (a,b,c,d,e) = put a *> put b *> put c *> put d *> put e + get = (,,,,) <$> get <*> get <*> get <*> get <*> get -- -- and now just recurse: @@ -390,7 +390,7 @@ -- Container types instance Binary a => Binary [a] where - put l = put (length l) >> traverse_ put l + put l = put (length l) *> traverse_ put l get = do n <- get :: Get Int getMany n @@ -407,21 +407,21 @@ instance (Binary a) => Binary (Maybe a) where put Nothing = putWord8 0 - put (Just x) = putWord8 1 >> put x + put (Just x) = putWord8 1 *> put x get = do w <- getWord8 case w of 0 -> return Nothing - _ -> liftM Just get + _ -> fmap Just get instance (Binary a, Binary b) => Binary (Either a b) where - put (Left a) = putWord8 0 >> put a - put (Right b) = putWord8 1 >> put b + put (Left a) = putWord8 0 *> put a + put (Right b) = putWord8 1 *> put b get = do w <- getWord8 case w of - 0 -> liftM Left get - _ -> liftM Right get + 0 -> fmap Left get + _ -> fmap Right get ------------------------------------------------------------------------ -- ByteStrings (have specially efficient instances) @@ -445,26 +445,26 @@ -- Maps and Sets instance (Binary a) => Binary (Set.Set a) where - put s = put (Set.size s) >> traverse_ put (Set.toAscList s) - get = liftM Set.fromDistinctAscList get + put s = put (Set.size s) *> traverse_ put (Set.toAscList s) + get = fmap Set.fromDistinctAscList get instance (Binary k, Binary e) => Binary (Map.Map k e) where - put m = put (Map.size m) >> traverse_ put (Map.toAscList m) - get = liftM Map.fromDistinctAscList get + put m = put (Map.size m) *> traverse_ put (Map.toAscList m) + get = fmap Map.fromDistinctAscList get instance Binary IntSet.IntSet where - put s = put (IntSet.size s) >> traverse_ put (IntSet.toAscList s) - get = liftM IntSet.fromDistinctAscList get + put s = put (IntSet.size s) *> traverse_ put (IntSet.toAscList s) + get = fmap IntSet.fromDistinctAscList get instance (Binary e) => Binary (IntMap.IntMap e) where - put m = put (IntMap.size m) >> traverse_ put (IntMap.toAscList m) - get = liftM IntMap.fromDistinctAscList get + put m = put (IntMap.size m) *> traverse_ put (IntMap.toAscList m) + get = fmap IntMap.fromDistinctAscList get ------------------------------------------------------------------------ -- Queues and Sequences instance (Binary e) => Binary (Seq.Seq e) where - put s = put (Seq.length s) >> Fold.traverse_ put s + put s = put (Seq.length s) *> Fold.traverse_ put s get = do n <- get :: Get Int rep Seq.empty n get where rep xs 0 _ = return $! xs @@ -477,18 +477,18 @@ instance Binary Double where put d = put (decodeFloat d) - get = liftM2 encodeFloat get get + get = encodeFloat <$> get <*> get instance Binary Float where put f = put (decodeFloat f) - get = liftM2 encodeFloat get get + get = encodeFloat <$> get <*> get ------------------------------------------------------------------------ -- Trees instance (Binary e) => Binary (T.Tree e) where - put (T.Node r s) = put r >> put s - get = liftM2 T.Node get get + put (T.Node r s) = put r *> put s + get = T.Node <$> get <*> get ------------------------------------------------------------------------ -- Arrays diff --git a/cabal/Cabal/Distribution/Compat/CopyFile.hs b/cabal/Cabal/Distribution/Compat/CopyFile.hs --- a/cabal/Cabal/Distribution/Compat/CopyFile.hs +++ b/cabal/Cabal/Distribution/Compat/CopyFile.hs @@ -27,17 +27,16 @@ import System.FilePath ( takeDirectory ) import System.IO - ( IOMode(ReadMode), hClose, hGetBuf, hPutBuf + ( IOMode(ReadMode), hClose, hGetBuf, hPutBuf, hFileSize , withBinaryFile ) import Foreign ( allocaBytes ) #ifndef mingw32_HOST_OS -import System.Posix.Internals (withFilePath) import System.Posix.Types ( FileMode ) import System.Posix.Internals - ( c_chmod ) + ( c_chmod, withFilePath ) import Foreign.C ( throwErrnoPathIfMinus1_ ) #endif /* mingw32_HOST_OS */ @@ -94,7 +93,8 @@ unless equal $ copyFile src dest -- | Checks if two files are byte-identical. --- Returns False if either of the files do not exist. +-- Returns False if either of the files do not exist or if files +-- are of different size. filesEqual :: FilePath -> FilePath -> NoCallStackIO Bool filesEqual f1 f2 = do ex1 <- doesFileExist f1 @@ -102,6 +102,11 @@ if not (ex1 && ex2) then return False else withBinaryFile f1 ReadMode $ \h1 -> withBinaryFile f2 ReadMode $ \h2 -> do - c1 <- BSL.hGetContents h1 - c2 <- BSL.hGetContents h2 - return $! c1 == c2 + s1 <- hFileSize h1 + s2 <- hFileSize h2 + if s1 /= s2 + then return False + else do + c1 <- BSL.hGetContents h1 + c2 <- BSL.hGetContents h2 + return $! c1 == c2 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 @@ -13,6 +13,7 @@ DList, runDList, singleton, + fromList, snoc, ) where @@ -28,6 +29,9 @@ -- | Make 'DList' with containing single element. singleton :: a -> DList a singleton a = DList (a:) + +fromList :: [a] -> DList a +fromList as = DList (as ++) snoc :: DList a -> a -> DList a snoc xs x = xs <> singleton x 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 @@ -71,7 +71,7 @@ -- ** Maps toMap, -- ** Lists - fromList, + fromDistinctList, toList, keys, -- ** Sets @@ -83,13 +83,25 @@ nodeValue, ) where +-- For bootstrapping GHC +#ifdef MIN_VERSION_containers +#if MIN_VERSION_containers(0,5,0) +#define HAVE_containers_050 +#endif +#endif + import Prelude () import qualified Distribution.Compat.Prelude as Prelude import Distribution.Compat.Prelude hiding (lookup, null, empty) import Data.Graph (SCC(..)) import qualified Data.Graph as G + +#ifdef HAVE_containers_050 +import qualified Data.Map.Strict as Map +#else import qualified Data.Map as Map +#endif import qualified Data.Set as Set import qualified Data.Array as Array import Data.Array ((!)) @@ -121,12 +133,12 @@ instance Show a => Show (Graph a) where show = show . toList -instance (IsNode a, Read a) => Read (Graph a) where - readsPrec d s = map (\(a,r) -> (fromList a, r)) (readsPrec d s) +instance (IsNode a, Read a, Show (Key a)) => Read (Graph a) where + readsPrec d s = map (\(a,r) -> (fromDistinctList a, r)) (readsPrec d s) -instance (IsNode a, Binary a) => Binary (Graph a) where +instance (IsNode a, Binary a, Show (Key a)) => Binary (Graph a) where put x = put (toList x) - get = fmap fromList get + get = fmap fromDistinctList get instance (Eq (Key a), Eq a) => Eq (Graph a) where g1 == g2 = graphMap g1 == graphMap g2 @@ -368,12 +380,14 @@ nodeTable = Array.listArray bounds ns bounds = (0, Map.size m - 1) --- | /O(V log V)/. Convert a list of nodes into a graph. -fromList :: IsNode a => [a] -> Graph a -fromList ns = fromMap - . Map.fromList - . map (\n -> n `seq` (nodeKey n, n)) - $ ns +-- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph. +fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a +fromDistinctList = fromMap + . Map.fromListWith (\_ -> duplicateError) + . map (\n -> n `seq` (nodeKey n, n)) + where + duplicateError n = error $ "Graph.fromDistinctList: duplicate key: " + ++ show (nodeKey n) -- Map-like operations diff --git a/cabal/Cabal/Distribution/Compat/Lens.hs b/cabal/Cabal/Distribution/Compat/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Compat/Lens.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE RankNTypes #-} +-- | This module provides very basic lens functionality, without extra dependencies. +-- +-- For the documentation of the combinators see package. +-- This module uses the same vocabulary. +module Distribution.Compat.Lens ( + -- * Types + Lens, + Lens', + Traversal, + Traversal', + -- ** LensLike + LensLike, + LensLike', + -- ** rank-1 types + Getting, + AGetter, + ASetter, + ALens, + ALens', + -- * Getter + view, + use, + -- * Setter + set, + over, + -- * Fold + toDListOf, + toListOf, + toSetOf, + -- * Lens + cloneLens, + aview, + -- * Common lenses + _1, _2, + non, + fromNon, + -- * Operators + (&), + (^.), + (.~), (?~), (%~), + (.=), (?=), (%=), + (^#), + (#~), (#%~), + -- * Internal Comonads + Pretext (..), + -- * Cabal developer info + -- $development + ) where + +import Prelude() +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 +import qualified Data.Set as Set + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +type LensLike f s t a b = (a -> f b) -> s -> f t +type LensLike' f s a = (a -> f a) -> s -> f s + +type Lens s t a b = forall f. Functor f => LensLike f s t a b +type Traversal s t a b = forall f. Applicative f => LensLike f s t a b + +type Lens' s a = Lens s s a a +type Traversal' s a = Traversal s s a a + +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 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 + +type ALens' s a = ALens s s a a + +------------------------------------------------------------------------------- +-- Getter +------------------------------------------------------------------------------- + +view :: Getting a s a -> s -> a +view l s = getConst (l Const s) +{-# INLINE view #-} + +use :: MonadState s m => Getting a s a -> m a +use l = gets (view l) +{-# INLINE use #-} + +------------------------------------------------------------------------------- +-- Setter +------------------------------------------------------------------------------- + +set :: ASetter s t a b -> b -> s -> t +set l x = over l (const x) + +over :: ASetter s t a b -> (a -> b) -> s -> t +over l f s = runIdentity (l (\x -> Identity (f x)) s) + +------------------------------------------------------------------------------- +-- Fold +------------------------------------------------------------------------------- + +toDListOf :: Getting (DList.DList a) s a -> s -> DList.DList a +toDListOf l s = getConst (l (\x -> Const (DList.singleton x)) s) + +toListOf :: Getting (DList.DList a) s a -> s -> [a] +toListOf l = DList.runDList . toDListOf l + +toSetOf :: Getting (Set.Set a) s a -> s -> Set.Set a +toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s) + +------------------------------------------------------------------------------- +-- Lens +------------------------------------------------------------------------------- + +aview :: ALens s t a b -> s -> a +aview l = pretextPos . l pretextSell +{-# INLINE aview #-} +{- +lens :: (s -> a) -> (s -> a -> s) -> Lens' s a +lens sa sbt afb s = sbt s <$> afb (sa s) +-} + +------------------------------------------------------------------------------- +-- Common +------------------------------------------------------------------------------- + +_1 :: Lens (a, c) (b, c) a b +_1 f (a, c) = flip (,) c <$> f a + +_2 :: Lens (c, a) (c, b) a b +_2 f (c, a) = (,) c <$> f a + +-- | /Note:/ not an isomorphism here. +non :: Eq a => a -> Lens' (Maybe a) a +non def f s = wrap <$> f (unwrap s) + where + wrap x | x == def = Nothing + wrap x = Just x + + unwrap = fromMaybe def + + +fromNon :: Eq a => a -> Lens' a (Maybe a) +fromNon def f s = unwrap <$> f (wrap s) + where + wrap x | x == def = Nothing + wrap x = Just x + + unwrap = fromMaybe def + +------------------------------------------------------------------------------- +-- Operators +------------------------------------------------------------------------------- + +-- | '&' is a reverse application operator +(&) :: a -> (a -> b) -> b +(&) = flip ($) +{-# INLINE (&) #-} +infixl 1 & + +infixl 8 ^., ^# +infixr 4 .~, %~, ?~ +infixr 4 #~, #%~ +infixr 4 .=, %=, ?= + +(^.) :: s -> Getting a s a -> a +s ^. l = getConst (l Const s) +{-# INLINE (^.) #-} + +(.~) :: ASetter s t a b -> b -> s -> t +(.~) = set +{-# INLINE (.~) #-} + +(?~) :: ASetter s t a (Maybe b) -> b -> s -> t +l ?~ b = set l (Just b) +{-# INLINE (?~) #-} + +(%~) :: ASetter s t a b -> (a -> b) -> s -> t +(%~) = over +{-# INLINE (%~) #-} + +(.=) :: MonadState s m => ASetter s s a b -> b -> m () +l .= b = modify (l .~ b) +{-# INLINE (.=) #-} + +(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m () +l ?= b = modify (l ?~ b) +{-# INLINE (?=) #-} + +(%=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m () +l %= f = modify (l %~ f) +{-# INLINE (%=) #-} + +(^#) :: s -> ALens s t a b -> a +s ^# l = aview l s + +(#~) :: ALens s t a b -> b -> s -> t +(#~) l b s = pretextPeek b (l pretextSell s) +{-# INLINE (#~) #-} + +(#%~) :: ALens s t a b -> (a -> b) -> s -> t +(#%~) l f s = pretextPeeks f (l pretextSell s) +{-# INLINE (#%~) #-} + +pretextSell :: a -> Pretext a b b +pretextSell a = Pretext (\afb -> afb a) +{-# INLINE pretextSell #-} + +pretextPeeks :: (a -> b) -> Pretext a b t -> t +pretextPeeks f (Pretext m) = runIdentity $ m (\x -> Identity (f x)) +{-# INLINE pretextPeeks #-} + +pretextPeek :: b -> Pretext a b t -> t +pretextPeek b (Pretext m) = runIdentity $ m (\_ -> Identity b) +{-# INLINE pretextPeek #-} + +pretextPos :: Pretext a b t -> a +pretextPos (Pretext m) = getConst (m Const) +{-# INLINE pretextPos #-} + +cloneLens :: Functor f => ALens s t a b -> LensLike f s t a b +cloneLens l f s = runPretext (l pretextSell s) f +{-# INLINE cloneLens #-} + +------------------------------------------------------------------------------- +-- Comonads +------------------------------------------------------------------------------- + +-- | @lens@ variant is also parametrised by profunctor. +data Pretext a b t = Pretext { runPretext :: forall f. Functor f => (a -> f b) -> f t } + +instance Functor (Pretext a b) where + fmap f (Pretext pretext) = Pretext (\afb -> fmap f (pretext afb)) + +------------------------------------------------------------------------------- +-- Documentation +------------------------------------------------------------------------------- + +-- $development +-- +-- We cannot depend on @template-haskell@, because Cabal is a boot library. +-- This fact makes defining optics a manual task. Here is a small recipe to +-- make the process less tedious. +-- +-- First start a repl +-- +-- > cabal new-repl Cabal:parser-hackage-tests -fparsec-struct-diff +-- +-- Because @--extra-package@ isn't yet implemented, we use a test-suite +-- with @generics-sop@ dependency. +-- +-- In the repl, we load a helper script: +-- +-- > :l ../generics-sop-lens.hs +-- +-- Now we are set up to derive lenses! +-- +-- > :m +Distribution.Types.SourceRepo +-- > putStr $ genericLenses (Proxy :: Proxy SourceRepo) +-- +-- @ +-- repoKind :: Lens' SourceRepo RepoKind +-- repoKind f s = fmap (\\x -> s { T.repoKind = x }) (f (T.repoKind s)) +-- \{-# INLINE repoKind #-\} +-- ... +-- @ +-- +-- /Note:/ You may need to adjust type-aliases, e.g. `String` to `FilePath`. diff --git a/cabal/Cabal/Distribution/Compat/Map/Strict.hs b/cabal/Cabal/Distribution/Compat/Map/Strict.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Compat/Map/Strict.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} + +-- For bootstrapping GHC +#ifdef MIN_VERSION_containers +#if MIN_VERSION_containers(0,5,0) +#define HAVE_containers_050 +#endif +#endif + +module Distribution.Compat.Map.Strict + ( module X +#ifdef HAVE_containers_050 +#else + , insertWith + , fromSet +#endif + ) where + +#ifdef HAVE_containers_050 +import Data.Map.Strict as X +#else +import Data.Map as X hiding (insertWith, insertWith') +import qualified Data.Map +import qualified Data.Set + +insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a +insertWith = Data.Map.insertWith' + +fromSet :: (k -> a) -> Data.Set.Set k -> Map k a +fromSet f = Data.Map.fromDistinctAscList . Prelude.map (\k -> (k, f k)) . Data.Set.toList +#endif diff --git a/cabal/Cabal/Distribution/Compat/Newtype.hs b/cabal/Cabal/Distribution/Compat/Newtype.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Compat/Newtype.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +-- | Per Conor McBride, the 'Newtype' typeclass represents the packing and +-- unpacking of a newtype, and allows you to operatate under that newtype with +-- functions such as 'ala'. +module Distribution.Compat.Newtype ( + Newtype (..), + ala, + alaf, + pack', + unpack', + ) where + +import Data.Functor.Identity (Identity (..)) +import Data.Monoid (Sum (..), Product (..), Endo (..)) + +-- | The @FunctionalDependencies@ version of 'Newtype' type-class. +-- +-- /Note:/ for actual newtypes the implementation can be +-- @pack = coerce; unpack = coerce@. We don't have default implementation, +-- because @Cabal@ have to support older than @base >= 4.7@ compilers. +-- Also, 'Newtype' could witness a non-structural isomorphism. +class Newtype n o | n -> o where + pack :: o -> n + unpack :: n -> o + +instance Newtype (Identity a) a where + pack = Identity + unpack = runIdentity + +instance Newtype (Sum a) a where + pack = Sum + unpack = getSum + +instance Newtype (Product a) a where + pack = Product + unpack = getProduct + +instance Newtype (Endo a) (a -> a) where + pack = Endo + unpack = appEndo + +-- | +-- +-- >>> ala Sum foldMap [1, 2, 3, 4 :: Int] +-- 10 +-- +-- /Note:/ the user supplied function for the newtype is /ignored/. +-- +-- >>> ala (Sum . (+1)) foldMap [1, 2, 3, 4 :: Int] +-- 10 +ala :: (Newtype n o, Newtype n' o') => (o -> n) -> ((o -> n) -> b -> n') -> (b -> o') +ala pa hof = alaf pa hof id + +-- | +-- +-- >>> alaf Sum foldMap length ["cabal", "install"] +-- 12 +-- +-- /Note:/ as with 'ala', the user supplied function for the newtype is /ignored/. +alaf :: (Newtype n o, Newtype n' o') => (o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> (b -> o') +alaf _ hof f = unpack . hof (pack . f) + +-- | Variant of 'pack', which takes a phantom type. +pack' :: Newtype n o => (o -> n) -> o -> n +pack' _ = pack + +-- | Variant of 'pack', which takes a phantom type. +unpack' :: Newtype n o => (o -> n) -> n -> o +unpack' _ = unpack diff --git a/cabal/Cabal/Distribution/Compat/Parsec.hs b/cabal/Cabal/Distribution/Compat/Parsec.hs --- a/cabal/Cabal/Distribution/Compat/Parsec.hs +++ b/cabal/Cabal/Distribution/Compat/Parsec.hs @@ -16,6 +16,7 @@ P.sepBy, P.sepBy1, P.choice, + P.eof, -- * Char integral, @@ -24,6 +25,7 @@ P.satisfy, P.space, P.spaces, + skipSpaces1, P.string, munch, munch1, @@ -71,3 +73,6 @@ => (Char -> Bool) -> P.ParsecT s u m String munch = many . P.satisfy + +skipSpaces1 :: P.Stream s m Char => P.ParsecT s u m () +skipSpaces1 = P.skipMany1 P.space 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 @@ -40,6 +40,7 @@ Binary (..), Alternative (..), MonadPlus (..), + IsString (..), -- * Some types IO, NoCallStackIO, @@ -63,6 +64,7 @@ null, length, find, foldl', traverse_, for_, + any, all, -- * Data.Traversable Traversable, traverse, sequenceA, @@ -93,7 +95,7 @@ -- We also could hide few partial function import Prelude as BasePrelude hiding - ( IO, mapM, mapM_, sequence, null, length, foldr + ( IO, mapM, mapM_, sequence, null, length, foldr, any, all #if MINVER_base_48 , Word -- We hide them, as we import only some members @@ -109,7 +111,7 @@ import Data.Foldable (length, null) #endif -import Data.Foldable (Foldable (foldMap, foldr), find, foldl', for_, traverse_) +import Data.Foldable (Foldable (foldMap, foldr), find, foldl', for_, traverse_, any, all) import Data.Traversable (Traversable (traverse, sequenceA), for) import Control.Applicative (Alternative (..)) @@ -131,6 +133,7 @@ isSuffixOf, nub, nubBy, sort, sortBy, unfoldr) import Data.Maybe +import Data.String (IsString (..)) import Data.Int import Data.Word diff --git a/cabal/Cabal/Distribution/Compat/ReadP.hs b/cabal/Cabal/Distribution/Compat/ReadP.hs --- a/cabal/Cabal/Distribution/Compat/ReadP.hs +++ b/cabal/Cabal/Distribution/Compat/ReadP.hs @@ -44,6 +44,7 @@ munch, -- :: (Char -> Bool) -> ReadP String munch1, -- :: (Char -> Bool) -> ReadP String skipSpaces, -- :: ReadP () + skipSpaces1,-- :: ReadP () choice, -- :: [ReadP a] -> ReadP a count, -- :: Int -> ReadP a -> ReadP [a] between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a @@ -66,17 +67,23 @@ -- * Running a parser ReadS, -- :: *; = String -> [(a,String)] readP_to_S, -- :: ReadP a -> ReadS a - readS_to_P -- :: ReadS a -> ReadP a + readS_to_P, -- :: ReadS a -> ReadP a + + -- ** Parsec + parsecToReadP, ) where import Prelude () import Distribution.Compat.Prelude hiding (many, get) +import Control.Applicative (liftA2) import qualified Distribution.Compat.MonadFail as Fail import Control.Monad( replicateM, (>=>) ) +import qualified Text.Parsec as P + infixr 5 +++, <++ -- --------------------------------------------------------------------------- @@ -297,6 +304,11 @@ skip (c:s) | isSpace c = do _ <- get; skip s skip _ = do return () +skipSpaces1 :: ReadP r () +-- ^ Like 'skipSpaces' but succeeds only if there is at least one +-- whitespace character to skip. +skipSpaces1 = satisfy isSpace >> skipSpaces + count :: Int -> ReadP r a -> ReadP r [a] -- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of -- results is returned. @@ -408,3 +420,16 @@ -- parser, and therefore a possible inefficiency. readS_to_P r = R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s'])) + +-- --------------------------------------------------------------------------- +-- Converting from Parsec to ReadP +-- +-- | Convert @Parsec@ parser to 'ReadP'. +parsecToReadP + :: P.Parsec [Char] u a + -> u -- ^ initial user state + -> ReadP r a +parsecToReadP p u = R $ \k -> Look $ \s -> + case P.runParser (liftA2 (,) p P.getInput) u "" s of + Right (x, s') -> final (run (k x) s') + Left _ -> Fail diff --git a/cabal/Cabal/Distribution/Compat/Stack.hs b/cabal/Cabal/Distribution/Compat/Stack.hs --- a/cabal/Cabal/Distribution/Compat/Stack.hs +++ b/cabal/Cabal/Distribution/Compat/Stack.hs @@ -4,6 +4,7 @@ module Distribution.Compat.Stack ( WithCallStack, CallStack, + annotateCallStackIO, withFrozenCallStack, withLexicalCallStack, callStack, @@ -11,6 +12,8 @@ parentSrcLocPrefix ) where +import System.IO.Error + #ifdef MIN_VERSION_base #if MIN_VERSION_base(4,8,1) #define GHC_STACK_SUPPORTED 1 @@ -94,3 +97,17 @@ withLexicalCallStack f = f #endif + +-- | This function is for when you *really* want to add a call +-- stack to raised IO, but you don't have a +-- 'Distribution.Verbosity.Verbosity' so you can't use +-- 'Distribution.Simple.Utils.annotateIO'. If you have a 'Verbosity', +-- please use that function instead. +annotateCallStackIO :: WithCallStack (IO a -> IO a) +annotateCallStackIO = modifyIOError f + where + f ioe = ioeSetErrorString ioe + . wrapCallStack + $ ioeGetErrorString ioe + wrapCallStack s = + prettyCallStack callStack ++ "\n" ++ s diff --git a/cabal/Cabal/Distribution/Compiler.hs b/cabal/Cabal/Distribution/Compiler.hs --- a/cabal/Cabal/Distribution/Compiler.hs +++ b/cabal/Cabal/Distribution/Compiler.hs @@ -51,8 +51,11 @@ import Distribution.Version (Version, mkVersion', nullVersion) import qualified System.Info (compilerName, compilerVersion) +import Distribution.Parsec.Class (Parsec (..)) +import Distribution.Pretty (Pretty (..)) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P import qualified Text.PrettyPrint as Disp data CompilerFlavor = @@ -66,12 +69,20 @@ knownCompilerFlavors :: [CompilerFlavor] knownCompilerFlavors = [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC] -instance Text CompilerFlavor where - disp (OtherCompiler name) = Disp.text name - disp (HaskellSuite name) = Disp.text name - disp NHC = Disp.text "nhc98" - disp other = Disp.text (lowercase (show other)) +instance Pretty CompilerFlavor where + pretty (OtherCompiler name) = Disp.text name + pretty (HaskellSuite name) = Disp.text name + pretty NHC = Disp.text "nhc98" + pretty other = Disp.text (lowercase (show other)) +instance Parsec CompilerFlavor where + parsec = classifyCompilerFlavor <$> component + where + component = do + cs <- P.munch1 isAlphaNum + if all isDigit cs then fail "all digits compiler name" else return cs + +instance Text CompilerFlavor where parse = do comp <- Parse.munch1 isAlphaNum when (all isDigit comp) Parse.pfail @@ -81,7 +92,7 @@ classifyCompilerFlavor s = fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap where - compilerMap = [ (display compiler, compiler) + compilerMap = [ (lowercase (display compiler), compiler) | compiler <- knownCompilerFlavors ] diff --git a/cabal/Cabal/Distribution/FieldGrammar.hs b/cabal/Cabal/Distribution/FieldGrammar.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/FieldGrammar.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | This module provides a way to specify a grammar of @.cabal@ -like files. +module Distribution.FieldGrammar ( + -- * Field grammar type + FieldGrammar (..), + uniqueField, + optionalField, + optionalFieldDef, + optionalFieldDefAla, + monoidalField, + deprecatedField', + -- * Concrete grammar implementations + ParsecFieldGrammar, + ParsecFieldGrammar', + parseFieldGrammar, + fieldGrammarKnownFieldList, + PrettyFieldGrammar, + PrettyFieldGrammar', + prettyFieldGrammar, + -- * Auxlilary + (^^^), + Section(..), + Fields, + partitionFields, + takeFields, + runFieldParser, + runFieldParser', + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Distribution.Compat.Map.Strict as Map + +import Distribution.FieldGrammar.Class +import Distribution.FieldGrammar.Parsec +import Distribution.FieldGrammar.Pretty +import Distribution.Parsec.Field +import Distribution.Utils.Generic (spanMaybe) + +type ParsecFieldGrammar' a = ParsecFieldGrammar a a +type PrettyFieldGrammar' a = PrettyFieldGrammar a a + +infixl 5 ^^^ + +-- | Reverse function application which binds tighter than '<$>' and '<*>'. +-- Useful for refining grammar specification. +-- +-- @ +-- \<*\> 'monoidalFieldAla' "extensions" (alaList' FSep MQuoted) oldExtensions +-- ^^^ 'deprecatedSince' [1,12] "Please use 'default-extensions' or 'other-extensions' fields." +-- @ +(^^^) :: a -> (a -> b) -> b +x ^^^ f = f x + +-- | Partitioning state +data PS ann = PS (Fields ann) [Section ann] [[Section ann]] + +-- | Partition field list into field map and groups of sections. +partitionFields :: [Field ann] -> (Fields ann, [[Section ann]]) +partitionFields = finalize . foldl' f (PS mempty mempty mempty) + where + finalize :: PS ann -> (Fields ann, [[Section ann]]) + finalize (PS fs s ss) + | null s = (fs, reverse ss) + | otherwise = (fs, reverse (reverse s : ss)) + + f :: PS ann -> Field ann -> PS ann + f (PS fs s ss) (Field (Name ann name) fss) = + PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss' + where + ss' | null s = ss + | otherwise = reverse s : ss + f (PS fs s ss) (Section name sargs sfields) = + PS fs (MkSection name sargs sfields : s) ss + +-- | Take all fields from the front. +takeFields :: [Field ann] -> (Fields ann, [Field ann]) +takeFields = finalize . spanMaybe match + where + finalize (fs, rest) = (Map.fromListWith (flip (++)) fs, rest) + + match (Field (Name ann name) fs) = Just (name, [MkNamelessField ann fs]) + match _ = Nothing diff --git a/cabal/Cabal/Distribution/FieldGrammar/Class.hs b/cabal/Cabal/Distribution/FieldGrammar/Class.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/FieldGrammar/Class.hs @@ -0,0 +1,149 @@ +module Distribution.FieldGrammar.Class ( + FieldGrammar (..), + uniqueField, + optionalField, + optionalFieldDef, + optionalFieldDefAla, + monoidalField, + deprecatedField', + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Data.Functor.Identity (Identity (..)) + +import Distribution.Compat.Newtype (Newtype) +import Distribution.Parsec.Class (Parsec) +import Distribution.Parsec.Field +import Distribution.Pretty (Pretty) + +-- | 'FieldGrammar' is parametrised by +-- +-- * @s@ which is a structure we are parsing. We need this to provide prettyprinter +-- functionality +-- +-- * @a@ type of the field. +-- +-- /Note:/ We'd like to have @forall s. Applicative (f s)@ context. +-- +class FieldGrammar g where + -- | Unfocus, zoom out, /blur/ 'FieldGrammar'. + blurFieldGrammar :: ALens' a b -> g b c -> g a c + + -- | Field which should be defined, exactly once. + uniqueFieldAla + :: (Parsec b, Pretty b, Newtype b a) + => FieldName -- ^ field name + -> (a -> b) -- ^ 'Newtype' pack + -> ALens' s a -- ^ lens into the field + -> g s a + + -- | Boolean field with a default value. + booleanFieldDef + :: FieldName -- ^ field name + -> ALens' s Bool -- ^ lens into the field + -> Bool -- ^ default + -> g s Bool + + -- | Optional field. + optionalFieldAla + :: (Parsec b, Pretty b, Newtype b a) + => FieldName -- ^ field name + -> (a -> b) -- ^ 'pack' + -> ALens' s (Maybe a) -- ^ lens into the field + -> g s (Maybe a) + + -- | Monoidal field. + -- + -- Values are combined with 'mappend'. + -- + -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid. + -- + monoidalFieldAla + :: (Parsec b, Pretty b, Monoid a, Newtype b a) + => FieldName -- ^ field name + -> (a -> b) -- ^ 'pack' + -> ALens' s a -- ^ lens into the field + -> g s a + + -- | Parser matching all fields with a name starting with a prefix. + prefixedFields + :: FieldName -- ^ field name prefix + -> ALens' s [(String, String)] -- ^ lens into the field + -> g s [(String, String)] + + -- | Known field, which we don't parse, neither pretty print. + knownField :: FieldName -> g s () + + -- | Field which is parsed but not pretty printed. + hiddenField :: g s a -> g s a + + -- | Deprecated since + deprecatedSince + :: [Int] -- ^ version + -> String -- ^ deprecation message + -> g s a + -> g s a + + -- | Annotate field with since spec-version. + availableSince + :: [Int] -- ^ spec version + -> g s a + -> g s a + +-- | Field which can be defined at most once. +uniqueField + :: (FieldGrammar g, Parsec a, Pretty a) + => FieldName -- ^ field name + -> ALens' s a -- ^ lens into the field + -> g s a +uniqueField fn = uniqueFieldAla fn Identity + +-- | Field which can be defined at most once. +optionalField + :: (FieldGrammar g, Parsec a, Pretty a) + => FieldName -- ^ field name + -> ALens' s (Maybe a) -- ^ lens into the field + -> g s (Maybe a) +optionalField fn = optionalFieldAla fn Identity + +-- | Optional field with default value. +optionalFieldDef + :: (FieldGrammar g, Functor (g s), Parsec a, Pretty a, Eq a, Show a) + => FieldName -- ^ field name + -> LensLike' (Pretext (Maybe a) (Maybe a)) s a -- ^ @'Lens'' s a@: lens into the field + -> a -- ^ default value + -> g s a +optionalFieldDef fn = optionalFieldDefAla fn Identity + +-- | Optional field with default value. +optionalFieldDefAla + :: (FieldGrammar g, Functor (g s), Parsec b, Pretty b, Newtype b a, Eq a, Show a) + => FieldName -- ^ field name + -> (a -> b) -- ^ 'Newtype' pack + -> LensLike' (Pretext (Maybe a) (Maybe a)) s a -- ^ @'Lens'' s a@: lens into the field + -> a -- ^ default value + -> g s a +optionalFieldDefAla fn pack l def = + fromMaybe def <$> optionalFieldAla fn pack (l . fromNon def) + +-- | Field which can be define multiple times, and the results are @mappend@ed. +monoidalField + :: (FieldGrammar g, Parsec a, Pretty a, Monoid a) + => FieldName -- ^ field name + -> ALens' s a -- ^ lens into the field + -> g s a +monoidalField fn = monoidalFieldAla fn Identity + +-- | Deprecated field. If found, warning is issued. +-- +-- /Note:/ also it's not pretty printed! +-- +deprecatedField' + :: FieldGrammar g + => String -- ^ deprecation message + -> g s a + -> g s a +deprecatedField' = deprecatedSince [] diff --git a/cabal/Cabal/Distribution/FieldGrammar/Parsec.hs b/cabal/Cabal/Distribution/FieldGrammar/Parsec.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/FieldGrammar/Parsec.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides a 'FieldGrammarParser', one way to parse +-- @.cabal@ -like files. +-- +-- Fields can be specified multiple times in the .cabal files. The order of +-- such entries is important, but the mutual ordering of different fields is +-- not.Also conditional sections are considered after non-conditional data. +-- The example of this silent-commutation quirk is the fact that +-- +-- @ +-- buildable: True +-- if os(linux) +-- buildable: False +-- @ +-- +-- and +-- +-- @ +-- if os(linux) +-- buildable: False +-- buildable: True +-- @ +-- +-- behave the same! This is the limitation of 'GeneralPackageDescription' +-- structure. +-- +-- So we transform the list of fields @['Field' ann]@ into +-- a map of grouped ordinary fields and a list of lists of sections: +-- @'Fields' ann = 'Map' 'FieldName' ['NamelessField' ann]@ and @[['Section' ann]]@. +-- +-- We need list of list of sections, because we need to distinguish situations +-- where there are fields in between. For example +-- +-- @ +-- if flag(bytestring-lt-0_10_4) +-- build-depends: bytestring < 0.10.4 +-- +-- default-language: Haskell2020 +-- +-- else +-- build-depends: bytestring >= 0.10.4 +-- +-- @ +-- +-- 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, +-- to report unknown fields and save custom @x-fields@. +-- +module Distribution.FieldGrammar.Parsec ( + ParsecFieldGrammar, + parseFieldGrammar, + fieldGrammarKnownFieldList, + -- * Auxiliary + Fields, + NamelessField (..), + Section (..), + runFieldParser, + runFieldParser', + ) where + +import qualified Data.ByteString as BS +import Data.List (dropWhileEnd) +import Data.Ord (comparing) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Distribution.Compat.Map.Strict as Map +import Distribution.Compat.Prelude +import Distribution.Compat.Newtype +import Distribution.Simple.Utils (fromUTF8BS) +import Prelude () +import qualified Text.Parsec as P +import qualified Text.Parsec.Error as P + +import Distribution.FieldGrammar.Class +import Distribution.Parsec.Class +import Distribution.Parsec.Common +import Distribution.Parsec.Field +import Distribution.Parsec.ParseResult + +------------------------------------------------------------------------------- +-- Auxiliary types +------------------------------------------------------------------------------- + +type Fields ann = Map FieldName [NamelessField ann] + +-- | Single field, without name, but with its annotation. +data NamelessField ann = MkNamelessField !ann [FieldLine ann] + deriving (Eq, Show, Functor) + +-- | The 'Section' constructor of 'Field'. +data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann] + deriving (Eq, Show, Functor) + +------------------------------------------------------------------------------- +-- ParsecFieldGrammar +------------------------------------------------------------------------------- + +data ParsecFieldGrammar s a = ParsecFG + { fieldGrammarKnownFields :: !(Set FieldName) + , fieldGrammarKnownPrefixes :: !(Set FieldName) + , fieldGrammarParser :: !(Fields Position -> ParseResult a) + } + deriving (Functor) + +parseFieldGrammar :: Fields Position -> ParsecFieldGrammar s a -> ParseResult a +parseFieldGrammar fields grammar = do + for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) -> + for_ nfields $ \(MkNamelessField pos _) -> + parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name + -- TODO: fields allowed in this section + + -- parse + fieldGrammarParser grammar fields + + where + isUnknownField k _ = not $ + k `Set.member` fieldGrammarKnownFields grammar + || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar) + +fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName] +fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields + +instance Applicative (ParsecFieldGrammar s) where + pure x = ParsecFG mempty mempty (\_ -> pure x) + {-# INLINE pure #-} + + ParsecFG f f' f'' <*> ParsecFG x x' x'' = ParsecFG + (mappend f x) + (mappend f' x') + (\fields -> f'' fields <*> x'' fields) + {-# INLINE (<*>) #-} + +instance FieldGrammar ParsecFieldGrammar where + blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser + + uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser fields = case Map.lookup fn fields of + Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing:" + Just [] -> parseFatalFailure zeroPos $ show fn ++ " field foo" + Just [x] -> parseOne x + -- TODO: parse all + -- TODO: warn about duplicate fields? + Just xs-> parseOne (last xs) + + parseOne (MkNamelessField pos fls) = + unpack' _pack <$> runFieldParser pos parsec fls + + booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser + where + parser :: Fields Position -> ParseResult Bool + parser fields = case Map.lookup fn fields of + Nothing -> pure def + Just [] -> pure def + Just [x] -> parseOne x + -- TODO: parse all + -- TODO: warn about duplicate optional fields? + Just xs -> parseOne (last xs) + + parseOne (MkNamelessField pos fls) = runFieldParser pos parsec fls + + optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser fields = case Map.lookup fn fields of + Nothing -> pure Nothing + Just [] -> pure Nothing + Just [x] -> parseOne x + -- TODO: parse all! + Just xs -> parseOne (last xs) -- TODO: warn about duplicate optional fields? + + parseOne (MkNamelessField pos fls) + | null fls = pure Nothing + | otherwise = Just . (unpack' _pack) <$> runFieldParser pos parsec fls + + monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser fields = case Map.lookup fn fields of + Nothing -> pure mempty + Just xs -> foldMap (unpack' _pack) <$> traverse parseOne xs + + parseOne (MkNamelessField pos fls) = runFieldParser pos parsec fls + + prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (pure . parser) + where + parser :: Fields Position -> [(String, String)] + parser values = reorder $ concatMap convert $ filter match $ Map.toList values + + match (fn, _) = fnPfx `BS.isPrefixOf` fn + convert (fn, fields) = + -- TODO: warn about invalid UTF8 + [ (pos, (fromUTF8BS fn, trim $ fromUTF8BS $ fieldlinesToBS fls)) + | MkNamelessField pos fls <- fields + ] + -- hack: recover the order of prefixed fields + reorder = map snd . sortBy (comparing fst) + trim :: String -> String + trim = dropWhile isSpace . dropWhileEnd isSpace + + availableSince _ = id + + deprecatedSince (_ : _) _ grammar = grammar -- pass on non-empty version + deprecatedSince _ msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' values = do + let deprecatedFields = Map.intersection values $ Map.fromSet (const ()) names + for_ (Map.toList deprecatedFields) $ \(name, fields) -> + for_ fields $ \(MkNamelessField pos _) -> + parseWarning pos PWTDeprecatedField $ + "The field " <> show name <> " is deprecated. " ++ msg + + parser values + + knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ -> pure ()) + + hiddenField = id + +------------------------------------------------------------------------------- +-- Parsec +------------------------------------------------------------------------------- + +runFieldParser' :: Position -> FieldParser a -> String -> ParseResult a +runFieldParser' (Position row col) p str = case P.runParser p' [] "" str of + Right (pok, ws) -> do + -- TODO: map pos + traverse_ (\(PWarning t pos w) -> parseWarning pos t w) ws + pure pok + Left err -> do + let ppos = P.errorPos err + -- Positions start from 1:1, not 0:0 + let epos = Position (row - 1 + P.sourceLine ppos) (col - 1 + P.sourceColumn ppos) + let msg = P.showErrorMessages + "or" "unknown parse error" "expecting" "unexpected" "end of input" + (P.errorMessages err) + + parseFatalFailure epos $ msg ++ ": " ++ show str + where + p' = (,) <$ P.spaces <*> p <* P.spaces <* P.eof <*> P.getState + +runFieldParser :: Position -> FieldParser a -> [FieldLine Position] -> ParseResult a +runFieldParser pp p ls = runFieldParser' pos p =<< fieldlinesToString pos ls + where + -- TODO: make per line lookup + pos = case ls of + [] -> pp + (FieldLine pos' _ : _) -> pos' + +fieldlinesToBS :: [FieldLine ann] -> BS.ByteString +fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) + +-- TODO: Take position from FieldLine +-- TODO: Take field name +fieldlinesToString :: Position -> [FieldLine ann] -> ParseResult String +fieldlinesToString pos fls = + let str = intercalate "\n" . map (\(FieldLine _ bs') -> fromUTF8BS bs') $ fls + in if '\xfffd' `elem` str + then str <$ parseWarning pos PWTUTF "Invalid UTF8 encoding" + else pure str diff --git a/cabal/Cabal/Distribution/FieldGrammar/Pretty.hs b/cabal/Cabal/Distribution/FieldGrammar/Pretty.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/FieldGrammar/Pretty.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveFunctor #-} +module Distribution.FieldGrammar.Pretty ( + PrettyFieldGrammar, + prettyFieldGrammar, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Newtype +import Distribution.Compat.Prelude +import Distribution.Pretty (Pretty (..)) +import Distribution.Simple.Utils (fromUTF8BS) +import Prelude () +import Text.PrettyPrint (Doc) +import qualified Text.PrettyPrint as PP + +import Distribution.FieldGrammar.Class +import Distribution.ParseUtils (ppField) + +newtype PrettyFieldGrammar s a = PrettyFG + { fieldGrammarPretty :: s -> Doc + } + deriving (Functor) + +instance Applicative (PrettyFieldGrammar s) where + pure _ = PrettyFG (\_ -> mempty) + PrettyFG f <*> PrettyFG x = PrettyFG (\s -> f s PP.$$ x s) + +-- | We can use 'PrettyFieldGrammar' to pp print the @s@. +prettyFieldGrammar :: PrettyFieldGrammar s a -> s -> Doc +prettyFieldGrammar = fieldGrammarPretty + +instance FieldGrammar PrettyFieldGrammar where + blurFieldGrammar f (PrettyFG pp) = PrettyFG (pp . aview f) + + uniqueFieldAla fn _pack l = PrettyFG $ \s -> + ppField (fromUTF8BS fn) (pretty (pack' _pack (aview l s))) + + booleanFieldDef fn l def = PrettyFG pp + where + pp s + | b == def = mempty + | otherwise = ppField (fromUTF8BS fn) (PP.text (show b)) + where + b = aview l s + + optionalFieldAla fn _pack l = PrettyFG pp + where + pp s = case aview l s of + Nothing -> mempty + Just a -> ppField (fromUTF8BS fn) (pretty (pack' _pack a)) + + monoidalFieldAla fn _pack l = PrettyFG pp + where + pp s = ppField (fromUTF8BS fn) (pretty (pack' _pack (aview l s))) + + prefixedFields _fnPfx l = PrettyFG (pp . aview l) + where + pp xs = PP.vcat + -- always print the field, even its Doc is empty + -- i.e. don't use ppField + [ PP.text n <<>> PP.colon PP.<+> (PP.vcat $ map PP.text $ lines s) + | (n, s) <- xs + -- fnPfx `isPrefixOf` n + ] + + knownField _ = pure () + deprecatedSince [] _ _ = PrettyFG (\_ -> mempty) + deprecatedSince _ _ x = x + availableSince _ = id + hiddenField _ = PrettyFG (\_ -> mempty) 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 @@ -32,9 +32,11 @@ InstalledPackageInfo(..), installedPackageId, installedComponentId, - requiredSignatures, installedOpenUnitId, + sourceComponentName, + requiredSignatures, ExposedModule(..), + AbiDependency(..), ParseResult(..), PError(..), PWarning, emptyInstalledPackageInfo, parseInstalledPackageInfo, @@ -50,7 +52,6 @@ import Distribution.ParseUtils import Distribution.License import Distribution.Package hiding (installedUnitId, installedPackageId) -import Distribution.Package.TextClass () import Distribution.Backpack import qualified Distribution.Package as Package import Distribution.ModuleName @@ -58,6 +59,10 @@ import Distribution.Text import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.Graph +import Distribution.Types.MungedPackageId +import Distribution.Types.ComponentName +import Distribution.Types.MungedPackageName +import Distribution.Types.UnqualComponentName import Text.PrettyPrint as Disp import qualified Data.Char as Char @@ -80,6 +85,7 @@ -- indefinite, OpenModule is always an OpenModuleVar -- with the same ModuleName as the key. instantiatedWith :: [(ModuleName, OpenModule)], + sourceLibName :: Maybe UnqualComponentName, compatPackageKey :: String, license :: License, copyright :: String, @@ -112,6 +118,7 @@ -- INVARIANT: if the package is definite, UnitId is NOT -- a ComponentId of an indefinite package depends :: [UnitId], + abiDepends :: [AbiDependency], ccOptions :: [String], ldOptions :: [String], frameworkDirs :: [FilePath], @@ -144,6 +151,7 @@ {-# DEPRECATED installedPackageId "Use installedUnitId instead" #-} -- | Backwards compatibility with Cabal pre-1.24. +-- -- This type synonym is slightly awful because in cabal-install -- we define an 'InstalledPackageId' but it's a ComponentId, -- not a UnitId! @@ -152,6 +160,9 @@ instance Binary InstalledPackageInfo +instance Package.HasMungedPackageId InstalledPackageInfo where + mungedId = mungedPackageId + instance Package.Package InstalledPackageInfo where packageId = sourcePackageId @@ -173,6 +184,7 @@ installedUnitId = mkUnitId "", installedComponentId_ = mkComponentId "", instantiatedWith = [], + sourceLibName = Nothing, compatPackageKey = "", license = UnspecifiedLicense, copyright = "", @@ -200,6 +212,7 @@ includeDirs = [], includes = [], depends = [], + abiDepends = [], ccOptions = [], ldOptions = [], frameworkDirs = [], @@ -252,7 +265,90 @@ parseExposedModules :: Parse.ReadP r [ExposedModule] parseExposedModules = parseOptCommaList parse +dispMaybe :: Text a => Maybe a -> Disp.Doc +dispMaybe Nothing = Disp.empty +dispMaybe (Just x) = disp x + +parseMaybe :: Text a => Parse.ReadP r (Maybe a) +parseMaybe = fmap Just parse Parse.<++ return Nothing + -- ----------------------------------------------------------------------------- +-- ABI dependency + +-- | An ABI dependency is a dependency on a library which also +-- records the ABI hash ('abiHash') of the library it depends +-- on. +-- +-- The primary utility of this is to enable an extra sanity when +-- GHC loads libraries: it can check if the dependency has a matching +-- ABI and if not, refuse to load this library. This information +-- is critical if we are shadowing libraries; differences in the +-- ABI hash let us know what packages get shadowed by the new version +-- of a package. +data AbiDependency = AbiDependency { + depUnitId :: UnitId, + depAbiHash :: AbiHash + } + deriving (Eq, Generic, Read, Show) + +instance Text AbiDependency where + disp (AbiDependency uid abi) = + disp uid <<>> Disp.char '=' <<>> disp abi + parse = do + uid <- parse + _ <- Parse.char '=' + abi <- parse + return (AbiDependency uid abi) + +instance Binary AbiDependency + +-- ----------------------------------------------------------------------------- +-- Munging + +sourceComponentName :: InstalledPackageInfo -> ComponentName +sourceComponentName ipi = + case sourceLibName ipi of + Nothing -> CLibName + Just qn -> CSubLibName qn + +-- | Returns @Just@ if the @name@ field of the IPI record would not contain +-- the package name verbatim. This helps us avoid writing @package-name@ +-- when it's redundant. +maybePackageName :: InstalledPackageInfo -> Maybe PackageName +maybePackageName ipi = + case sourceLibName ipi of + Nothing -> Nothing + Just _ -> Just (packageName ipi) + +-- | Setter for the @package-name@ field. It should be acceptable for this +-- to be a no-op. +setMaybePackageName :: Maybe PackageName -> InstalledPackageInfo -> InstalledPackageInfo +setMaybePackageName Nothing ipi = ipi +setMaybePackageName (Just pn) ipi = ipi { + sourcePackageId=(sourcePackageId ipi){pkgName=pn} + } + +-- | Returns the munged package name, which we write into @name@ for +-- compatibility with old versions of GHC. +mungedPackageName :: InstalledPackageInfo -> MungedPackageName +mungedPackageName ipi = + computeCompatPackageName + (packageName ipi) + (sourceLibName ipi) + +setMungedPackageName :: MungedPackageName -> InstalledPackageInfo -> InstalledPackageInfo +setMungedPackageName mpn ipi = + let (pn, mb_uqn) = decodeCompatPackageName mpn + in ipi { + sourcePackageId = (sourcePackageId ipi) {pkgName=pn}, + sourceLibName = mb_uqn + } + +mungedPackageId :: InstalledPackageInfo -> MungedPackageId +mungedPackageId ipi = + MungedPackageId (mungedPackageName ipi) (packageVersion ipi) + +-- ----------------------------------------------------------------------------- -- Parsing parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo @@ -288,17 +384,23 @@ basicFieldDescrs :: [FieldDescr InstalledPackageInfo] basicFieldDescrs = [ simpleField "name" - disp parsePackageNameQ - packageName (\name pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgName=name}}) + disp (parseMaybeQuoted parse) + mungedPackageName setMungedPackageName , simpleField "version" disp parseOptVersion packageVersion (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}}) , simpleField "id" disp parse - installedUnitId (\pk pkg -> pkg{installedUnitId=pk}) + installedUnitId (\pk pkg -> pkg{installedUnitId=pk}) , simpleField "instantiated-with" (dispOpenModuleSubst . Map.fromList) (fmap Map.toList parseOpenModuleSubst) instantiatedWith (\iw pkg -> pkg{instantiatedWith=iw}) + , simpleField "package-name" + dispMaybe parseMaybe + maybePackageName setMaybePackageName + , simpleField "lib-name" + dispMaybe parseMaybe + sourceLibName (\n pkg -> pkg{sourceLibName=n}) , simpleField "key" dispCompatPackageKey parseCompatPackageKey compatPackageKey (\pk pkg -> pkg{compatPackageKey=pk}) @@ -381,6 +483,9 @@ , listField "depends" disp parse depends (\xs pkg -> pkg{depends=xs}) + , listField "abi-depends" + disp parse + abiDepends (\xs pkg -> pkg{abiDepends=xs}) , listField "cc-options" showToken parseTokenQ ccOptions (\path pkg -> pkg{ccOptions=path}) diff --git a/cabal/Cabal/Distribution/License.hs b/cabal/Cabal/Distribution/License.hs --- a/cabal/Cabal/Distribution/License.hs +++ b/cabal/Cabal/Distribution/License.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | @@ -47,14 +47,18 @@ knownLicenses, ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Version +import Distribution.Parsec.Class +import Distribution.Pretty import Distribution.Text -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp +import Distribution.Version +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp + -- | Indicates the license under which a package's source code is released. -- Versions of the licenses not listed here will be rejected by Hackage and -- cause @cabal check@ to issue a warning. @@ -136,15 +140,37 @@ unversioned = Nothing version = Just . mkVersion -instance Text License where - disp (GPL version) = Disp.text "GPL" <<>> dispOptVersion version - disp (LGPL version) = Disp.text "LGPL" <<>> dispOptVersion version - disp (AGPL version) = Disp.text "AGPL" <<>> dispOptVersion version - disp (MPL version) = Disp.text "MPL" <<>> dispVersion version - disp (Apache version) = Disp.text "Apache" <<>> dispOptVersion version - disp (UnknownLicense other) = Disp.text other - disp other = Disp.text (show other) +instance Pretty License where + pretty (GPL version) = Disp.text "GPL" <<>> dispOptVersion version + pretty (LGPL version) = Disp.text "LGPL" <<>> dispOptVersion version + pretty (AGPL version) = Disp.text "AGPL" <<>> dispOptVersion version + pretty (MPL version) = Disp.text "MPL" <<>> dispVersion version + pretty (Apache version) = Disp.text "Apache" <<>> dispOptVersion version + pretty (UnknownLicense other) = Disp.text other + pretty other = Disp.text (show other) +instance Parsec License where + parsec = do + name <- P.munch1 isAlphaNum + version <- P.optionMaybe (P.char '-' *> parsec) + return $! case (name, version :: Maybe Version) of + ("GPL", _ ) -> GPL version + ("LGPL", _ ) -> LGPL version + ("AGPL", _ ) -> AGPL version + ("BSD2", Nothing) -> BSD2 + ("BSD3", Nothing) -> BSD3 + ("BSD4", Nothing) -> BSD4 + ("ISC", Nothing) -> ISC + ("MIT", Nothing) -> MIT + ("MPL", Just version') -> MPL version' + ("Apache", _ ) -> Apache version + ("PublicDomain", Nothing) -> PublicDomain + ("AllRightsReserved", Nothing) -> AllRightsReserved + ("OtherLicense", Nothing) -> OtherLicense + _ -> UnknownLicense $ name ++ + maybe "" (('-':) . display) version + +instance Text License where parse = do name <- Parse.munch1 (\c -> isAlphaNum c && c /= '-') version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse) 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 @@ -28,11 +28,15 @@ import Distribution.Compat.Prelude import Distribution.Utils.ShortText +import System.FilePath ( pathSeparator ) + +import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text -import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp -import System.FilePath ( pathSeparator ) -- | A valid Haskell module name. -- @@ -44,10 +48,19 @@ instance NFData ModuleName where rnf (ModuleName ms) = rnf ms -instance Text ModuleName where - disp (ModuleName ms) = +instance Pretty ModuleName where + pretty (ModuleName ms) = Disp.hcat (intersperse (Disp.char '.') (map Disp.text $ stlToStrings ms)) +instance Parsec ModuleName where + parsec = fromComponents <$> P.sepBy1 component (P.char '.') + where + component = do + c <- P.satisfy isUpper + cs <- P.munch validModuleChar + return (c:cs) + +instance Text ModuleName where parse = do ms <- Parse.sepBy1 component (Parse.char '.') return (ModuleName $ stlFromStrings ms) @@ -76,12 +89,12 @@ -- an error if it is used with a string that is not a valid module name. If you -- are parsing user input then use 'Distribution.Text.simpleParse' instead. -- -fromString :: String -> ModuleName -fromString string = fromComponents (split string) - where - split cs = case break (=='.') cs of - (chunk,[]) -> chunk : [] - (chunk,_:rest) -> chunk : split rest +instance IsString ModuleName where + fromString string = fromComponents (split string) + where + split cs = case break (=='.') cs of + (chunk,[]) -> chunk : [] + (chunk,_:rest) -> chunk : split rest -- | Construct a 'ModuleName' from valid module components, i.e. parts -- separated by dots. diff --git a/cabal/Cabal/Distribution/Package.hs b/cabal/Cabal/Distribution/Package.hs --- a/cabal/Cabal/Distribution/Package.hs +++ b/cabal/Cabal/Distribution/Package.hs @@ -16,427 +16,38 @@ -- a 'Dependency' data type. A dependency is a package name and a version -- range, like @\"foo >= 1.2 && < 2\"@. -module Distribution.Package ( - -- * Package ids - UnqualComponentName, unUnqualComponentName, mkUnqualComponentName, - PackageName, unPackageName, mkPackageName, - packageNameToUnqualComponentName, unqualComponentNameToPackageName, - PackageIdentifier(..), - PackageId, - PkgconfigName, unPkgconfigName, mkPkgconfigName, - - -- * Package keys/installed package IDs (used for linker symbols) - ComponentId, unComponentId, mkComponentId, - UnitId, unUnitId, mkUnitId, - DefUnitId, - unsafeMkDefUnitId, - unDefUnitId, - newSimpleUnitId, - mkLegacyUnitId, - getHSLibraryName, - InstalledPackageId, -- backwards compat - - -- * Modules - Module(..), - - -- * ABI hash - AbiHash, unAbiHash, mkAbiHash, - - -- * Package source dependencies - Dependency(..), - LegacyExeDependency(..), - PkgconfigDependency(..), - thisPackageVersion, - notThisPackageVersion, - simplifyDependency, - - -- * Package classes - Package(..), packageName, packageVersion, - HasUnitId(..), - installedPackageId, - PackageInstalled(..), +module Distribution.Package + ( module Distribution.Types.AbiHash + , module Distribution.Types.ComponentId + , module Distribution.Types.PackageId + , module Distribution.Types.UnitId + , module Distribution.Types.Module + , module Distribution.Types.PackageName + , module Distribution.Types.PkgconfigName + , module Distribution.Types.Dependency + , Package(..), packageName, packageVersion + , HasMungedPackageId(..), mungedName', mungedVersion' + , HasUnitId(..) + , installedPackageId + , PackageInstalled(..) ) where import Prelude () import Distribution.Compat.Prelude -import Distribution.Utils.ShortText import Distribution.Version - ( Version, VersionRange, thisVersion - , notThisVersion, simplifyVersionRange - , nullVersion ) - -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp -import Distribution.Compat.ReadP -import Distribution.Text -import Distribution.ModuleName - -import Text.PrettyPrint (text) - --- | An unqualified component name, for any kind of component. --- --- This is distinguished from a 'ComponentName' and 'ComponentId'. The former --- also states which of a library, executable, etc the name refers too. The --- later uniquely identifiers a component and its closure. --- --- @since 2.0 -newtype UnqualComponentName = UnqualComponentName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, - Semigroup, Monoid) -- TODO: bad enabler of bad monoids - --- | Convert 'UnqualComponentName' to 'String' --- --- @since 2.0 -unUnqualComponentName :: UnqualComponentName -> String -unUnqualComponentName (UnqualComponentName s) = fromShortText s - --- | Construct a 'UnqualComponentName' from a 'String' --- --- 'mkUnqualComponentName' is the inverse to 'unUnqualComponentName' --- --- Note: No validations are performed to ensure that the resulting --- 'UnqualComponentName' is valid --- --- @since 2.0 -mkUnqualComponentName :: String -> UnqualComponentName -mkUnqualComponentName = UnqualComponentName . toShortText - -instance Binary UnqualComponentName - -parsePackageName :: Parse.ReadP r String -parsePackageName = do - ns <- Parse.sepBy1 component (Parse.char '-') - return $ intercalate "-" ns - where - component = do - cs <- Parse.munch1 isAlphaNum - if all isDigit cs then Parse.pfail else return cs - -- each component must contain an alphabetic character, to avoid - -- ambiguity in identifiers like foo-1 (the 1 is the version number). - -instance Text UnqualComponentName where - disp = Disp.text . unUnqualComponentName - parse = mkUnqualComponentName <$> parsePackageName - -instance NFData UnqualComponentName where - rnf (UnqualComponentName pkg) = rnf pkg - --- | A package name. --- --- Use 'mkPackageName' and 'unPackageName' to convert from/to a --- 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0 -newtype PackageName = PackageName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - --- | Convert 'PackageName' to 'String' -unPackageName :: PackageName -> String -unPackageName (PackageName s) = fromShortText s - --- | Construct a 'PackageName' from a 'String' --- --- 'mkPackageName' is the inverse to 'unPackageName' --- --- Note: No validations are performed to ensure that the resulting --- 'PackageName' is valid --- --- @since 2.0 -mkPackageName :: String -> PackageName -mkPackageName = PackageName . toShortText - --- | Converts a package name to an unqualified component name --- --- Useful in legacy situations where a package name may refer to an internal --- component, if one is defined with that name. --- --- @since 2.0 -packageNameToUnqualComponentName :: PackageName -> UnqualComponentName -packageNameToUnqualComponentName (PackageName s) = UnqualComponentName s - --- | Converts an unqualified component name to a package name --- --- `packageNameToUnqualComponentName` is the inverse of --- `unqualComponentNameToPackageName`. --- --- Useful in legacy situations where a package name may refer to an internal --- component, if one is defined with that name. --- --- @since 2.0 -unqualComponentNameToPackageName :: UnqualComponentName -> PackageName -unqualComponentNameToPackageName (UnqualComponentName s) = PackageName s - -instance Binary PackageName - -instance Text PackageName where - disp = Disp.text . unPackageName - parse = mkPackageName <$> parsePackageName - -instance NFData PackageName where - rnf (PackageName pkg) = rnf pkg - --- | A pkg-config library name --- --- This is parsed as any valid argument to the pkg-config utility. --- --- @since 2.0 -newtype PkgconfigName = PkgconfigName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - --- | Convert 'PkgconfigName' to 'String' --- --- @since 2.0 -unPkgconfigName :: PkgconfigName -> String -unPkgconfigName (PkgconfigName s) = fromShortText s - --- | Construct a 'PkgconfigName' from a 'String' --- --- 'mkPkgconfigName' is the inverse to 'unPkgconfigName' --- --- Note: No validations are performed to ensure that the resulting --- 'PkgconfigName' is valid --- --- @since 2.0 -mkPkgconfigName :: String -> PkgconfigName -mkPkgconfigName = PkgconfigName . toShortText - -instance Binary PkgconfigName - --- pkg-config allows versions and other letters in package names, eg --- "gtk+-2.0" is a valid pkg-config package _name_. It then has a package --- version number like 2.10.13 -instance Text PkgconfigName where - disp = Disp.text . unPkgconfigName - parse = mkPkgconfigName - <$> munch1 (\c -> isAlphaNum c || c `elem` "+-._") - -instance NFData PkgconfigName where - rnf (PkgconfigName pkg) = rnf pkg - --- | Type alias so we can use the shorter name PackageId. -type PackageId = PackageIdentifier - --- | The name and version of a package. -data PackageIdentifier - = PackageIdentifier { - pkgName :: PackageName, -- ^The name of this package, eg. foo - pkgVersion :: Version -- ^the version of this package, eg 1.2 - } - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary PackageIdentifier - -instance Text PackageIdentifier where - disp (PackageIdentifier n v) - | v == nullVersion = disp n -- if no version, don't show version. - | otherwise = disp n <<>> Disp.char '-' <<>> disp v - - parse = do - n <- parse - v <- (Parse.char '-' >> parse) <++ return nullVersion - return (PackageIdentifier n v) - -instance NFData PackageIdentifier where - rnf (PackageIdentifier name version) = rnf name `seq` rnf version - --- | A module identity uniquely identifies a Haskell module by --- qualifying a 'ModuleName' with the 'UnitId' which defined --- it. This type distinguishes between two packages --- which provide a module with the same name, or a module --- from the same package compiled with different dependencies. --- There are a few cases where Cabal needs to know about --- module identities, e.g., when writing out reexported modules in --- the 'InstalledPackageInfo'. -data Module = - Module DefUnitId ModuleName - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary Module - -instance Text Module where - disp (Module uid mod_name) = - disp uid <<>> Disp.text ":" <<>> disp mod_name - parse = do - uid <- parse - _ <- Parse.char ':' - mod_name <- parse - return (Module uid mod_name) - -instance NFData Module where - rnf (Module uid mod_name) = rnf uid `seq` rnf mod_name - --- | A 'ComponentId' uniquely identifies the transitive source --- code closure of a component (i.e. libraries, executables). --- --- For non-Backpack components, this corresponds one to one with --- the 'UnitId', which serves as the basis for install paths, --- linker symbols, etc. --- --- Use 'mkComponentId' and 'unComponentId' to convert from/to a --- 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0 -newtype ComponentId = ComponentId ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - --- | Construct a 'ComponentId' from a 'String' --- --- 'mkComponentId' is the inverse to 'unComponentId' --- --- Note: No validations are performed to ensure that the resulting --- 'ComponentId' is valid --- --- @since 2.0 -mkComponentId :: String -> ComponentId -mkComponentId = ComponentId . toShortText - --- | Convert 'ComponentId' to 'String' --- --- @since 2.0 -unComponentId :: ComponentId -> String -unComponentId (ComponentId s) = fromShortText s - -{-# DEPRECATED InstalledPackageId "Use UnitId instead" #-} -type InstalledPackageId = UnitId - -instance Binary ComponentId - -instance Text ComponentId where - disp = text . unComponentId - - parse = mkComponentId `fmap` Parse.munch1 abi_char - where abi_char c = isAlphaNum c || c `elem` "-_." - -instance NFData ComponentId where - rnf = rnf . unComponentId - --- | Returns library name prefixed with HS, suitable for filenames -getHSLibraryName :: UnitId -> String -getHSLibraryName uid = "HS" ++ display uid - --- | A unit identifier identifies a (possibly instantiated) --- package/component that can be installed the installed package --- database. There are several types of components that can be --- installed: --- --- * A traditional library with no holes, so that 'unitIdHash' --- is @Nothing@. In the absence of Backpack, 'UnitId' --- is the same as a 'ComponentId'. --- --- * An indefinite, Backpack library with holes. In this case, --- 'unitIdHash' is still @Nothing@, but in the install, --- there are only interfaces, no compiled objects. --- --- * An instantiated Backpack library with all the holes --- filled in. 'unitIdHash' is a @Just@ a hash of the --- instantiating mapping. --- --- A unit is a component plus the additional information on how the --- holes are filled in. Thus there is a one to many relationship: for a --- particular component there are many different ways of filling in the --- holes, and each different combination is a unit (and has a separate --- 'UnitId'). --- --- 'UnitId' is distinct from 'OpenUnitId', in that it is always --- installed, whereas 'OpenUnitId' are intermediate unit identities --- that arise during mixin linking, and don't necessarily correspond --- to any actually installed unit. Since the mapping is not actually --- recorded in a 'UnitId', you can't actually substitute over them --- (but you can substitute over 'OpenUnitId'). See also --- "Distribution.Backpack.FullUnitId" for a mechanism for expanding an --- instantiated 'UnitId' to retrieve its mapping. --- -newtype UnitId = UnitId ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, NFData) - -instance Binary UnitId - -instance Text UnitId where - disp = text . unUnitId - parse = mkUnitId <$> Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") - -unUnitId :: UnitId -> String -unUnitId (UnitId s) = fromShortText s - -mkUnitId :: String -> UnitId -mkUnitId = UnitId . toShortText - --- | A 'UnitId' for a definite package. The 'DefUnitId' invariant says --- that a 'UnitId' identified this way is definite; i.e., it has no --- unfilled holes. -newtype DefUnitId = DefUnitId { unDefUnitId :: UnitId } - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Text) - --- | Unsafely create a 'DefUnitId' from a 'UnitId'. Your responsibility --- is to ensure that the 'DefUnitId' invariant holds. -unsafeMkDefUnitId :: UnitId -> DefUnitId -unsafeMkDefUnitId = DefUnitId - --- | Create a unit identity with no associated hash directly --- from a 'ComponentId'. -newSimpleUnitId :: ComponentId -> UnitId -newSimpleUnitId (ComponentId s) = UnitId s - --- | Make an old-style UnitId from a package identifier -mkLegacyUnitId :: PackageId -> UnitId -mkLegacyUnitId = newSimpleUnitId . mkComponentId . display - --- ------------------------------------------------------------ --- * Package source dependencies --- ------------------------------------------------------------ - --- | Describes a dependency on a source package (API) --- -data Dependency = Dependency PackageName VersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - --- | Describes a legacy `build-tools`-style dependency on an executable --- --- It is "legacy" because we do not know what the build-tool referred to. It --- could refer to a pkg-config executable (PkgconfigName), or an internal --- executable (UnqualComponentName). Thus the name is stringly typed. --- --- @since 2.0 -data LegacyExeDependency = LegacyExeDependency - String - VersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - --- | Describes a dependency on a pkg-config library --- --- @since 2.0 -data PkgconfigDependency = PkgconfigDependency - PkgconfigName - VersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary Dependency -instance Binary LegacyExeDependency -instance Binary PkgconfigDependency - -instance NFData Dependency where rnf = genericRnf -instance NFData LegacyExeDependency where rnf = genericRnf -instance NFData PkgconfigDependency where rnf = genericRnf - -thisPackageVersion :: PackageIdentifier -> Dependency -thisPackageVersion (PackageIdentifier n v) = - Dependency n (thisVersion v) - -notThisPackageVersion :: PackageIdentifier -> Dependency -notThisPackageVersion (PackageIdentifier n v) = - Dependency n (notThisVersion v) + ( Version ) --- | Simplify the 'VersionRange' expression in a 'Dependency'. --- See 'simplifyVersionRange'. --- -simplifyDependency :: Dependency -> Dependency -simplifyDependency (Dependency name range) = - Dependency name (simplifyVersionRange range) +import Distribution.Types.AbiHash +import Distribution.Types.ComponentId +import Distribution.Types.Dependency +import Distribution.Types.MungedPackageId +import Distribution.Types.PackageId +import Distribution.Types.UnitId +import Distribution.Types.Module +import Distribution.Types.MungedPackageName +import Distribution.Types.PackageName +import Distribution.Types.PkgconfigName -- | Class of things that have a 'PackageIdentifier' -- @@ -449,16 +60,28 @@ -- many installed instances of the same source package. -- class Package pkg where - packageId :: pkg -> PackageIdentifier + packageId :: pkg -> PackageIdentifier +mungedName' :: HasMungedPackageId pkg => pkg -> MungedPackageName +mungedName' = mungedName . mungedId + +mungedVersion' :: HasMungedPackageId munged => munged -> Version +mungedVersion' = mungedVersion . mungedId + +class HasMungedPackageId pkg where + mungedId :: pkg -> MungedPackageId + +instance Package PackageIdentifier where + packageId = id + packageName :: Package pkg => pkg -> PackageName packageName = pkgName . packageId packageVersion :: Package pkg => pkg -> Version packageVersion = pkgVersion . packageId -instance Package PackageIdentifier where - packageId = id +instance HasMungedPackageId MungedPackageId where + mungedId = id -- | Packages that have an installed unit ID class Package pkg => HasUnitId pkg where @@ -477,40 +100,3 @@ -- Installed packages have exact dependencies 'installedDepends'. class (HasUnitId pkg) => PackageInstalled pkg where installedDepends :: pkg -> [UnitId] - --- ----------------------------------------------------------------------------- --- ABI hash - --- | ABI Hashes --- --- Use 'mkAbiHash' and 'unAbiHash' to convert from/to a --- 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0 -newtype AbiHash = AbiHash ShortText - deriving (Eq, Show, Read, Generic) - --- | Construct a 'AbiHash' from a 'String' --- --- 'mkAbiHash' is the inverse to 'unAbiHash' --- --- Note: No validations are performed to ensure that the resulting --- 'AbiHash' is valid --- --- @since 2.0 -unAbiHash :: AbiHash -> String -unAbiHash (AbiHash h) = fromShortText h - --- | Convert 'AbiHash' to 'String' --- --- @since 2.0 -mkAbiHash :: String -> AbiHash -mkAbiHash = AbiHash . toShortText - -instance Binary AbiHash - -instance Text AbiHash where - disp = Disp.text . unAbiHash - parse = fmap mkAbiHash (Parse.munch isAlphaNum) diff --git a/cabal/Cabal/Distribution/Package/TextClass.hs b/cabal/Cabal/Distribution/Package/TextClass.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Package/TextClass.hs +++ /dev/null @@ -1,56 +0,0 @@ --- | *Dependency Text instances moved from Distribution.Package -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Distribution.Package.TextClass () where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Package -import Distribution.ParseUtils -import Distribution.Version (anyVersion) - -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp -import Distribution.Compat.ReadP -import Distribution.Text - -import Text.PrettyPrint ((<+>)) - - -instance Text Dependency where - disp (Dependency name ver) = - disp name <+> disp ver - - parse = do name <- parse - Parse.skipSpaces - ver <- parse <++ return anyVersion - Parse.skipSpaces - return (Dependency name ver) - -instance Text LegacyExeDependency where - disp (LegacyExeDependency name ver) = - Disp.text name <+> disp ver - - parse = do name <- parseMaybeQuoted parseBuildToolName - Parse.skipSpaces - ver <- parse <++ return anyVersion - Parse.skipSpaces - return $ LegacyExeDependency name ver - where - -- like parsePackageName but accepts symbols in components - parseBuildToolName :: Parse.ReadP r String - parseBuildToolName = do ns <- sepBy1 component (Parse.char '-') - return (intercalate "-" ns) - where component = do - cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_') - if all isDigit cs then pfail else return cs - -instance Text PkgconfigDependency where - disp (PkgconfigDependency name ver) = - disp name <+> disp ver - - parse = do name <- parse - Parse.skipSpaces - ver <- parse <++ return anyVersion - Parse.skipSpaces - return $ PkgconfigDependency name ver 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 @@ -78,9 +78,11 @@ allLanguages, allExtensions, usedExtensions, + usesTemplateHaskellOrQQ, hcOptions, hcProfOptions, hcSharedOptions, + hcStaticOptions, -- ** Supplementary build information ComponentName(..), @@ -93,7 +95,10 @@ GenericPackageDescription(..), Flag(..), emptyFlag, FlagName, mkFlagName, unFlagName, - FlagAssignment, + FlagAssignment, mkFlagAssignment, unFlagAssignment, + nullFlagAssignment, showFlagValue, + diffFlagAssignment, lookupFlagAssignment, insertFlagAssignment, + dispFlagAssignment, parseFlagAssignment, parsecFlagAssignment, CondTree(..), ConfVar(..), Condition(..), cNot, cAnd, cOr, @@ -125,6 +130,8 @@ import Distribution.Types.SetupBuildInfo import Distribution.Types.BuildType import Distribution.Types.GenericPackageDescription +import Distribution.Types.CondTree +import Distribution.Types.Condition import Distribution.Types.PackageDescription import Distribution.Types.ComponentName import Distribution.Types.HookedBuildInfo 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 @@ -39,35 +39,48 @@ import Distribution.PackageDescription import Distribution.PackageDescription.Configuration +import qualified Distribution.Compat.DList as DList import Distribution.Compiler import Distribution.System import Distribution.License import Distribution.Simple.BuildPaths (autogenPathsModuleName) +import Distribution.Simple.BuildToolDepends import Distribution.Simple.CCompiler import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.CondTree +import Distribution.Types.Dependency +import Distribution.Types.ExeDependency +import Distribution.Types.PackageName +import Distribution.Types.ExecutableScope +import Distribution.Types.UnqualComponentName import Distribution.Simple.Utils hiding (findPackageDesc, notice) import Distribution.Version import Distribution.Package import Distribution.Text +import Distribution.Utils.Generic (isAscii) import Language.Haskell.Extension import Control.Monad (mapM) +import qualified Data.ByteString.Lazy as BS import Data.List (group) import qualified System.Directory as System ( doesFileExist, doesDirectoryExist ) import qualified Data.Map as Map -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<+>)) - import qualified System.Directory (getDirectoryContents) -import System.IO (openBinaryFile, IOMode(ReadMode), hGetContents) import System.FilePath - ( (), takeExtension, splitDirectories, splitPath, splitExtension ) + ( (), (<.>), takeExtension, takeFileName, splitDirectories + , splitPath, splitExtension ) import System.FilePath.Windows as FilePath.Windows ( isValid ) +import qualified Data.Set as Set +import Distribution.Compat.Lens +import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.PackageDescription.Lens as L +import qualified Distribution.Types.GenericPackageDescription.Lens as L + -- | Results of some kind of failed package check. -- -- There are a range of severities, from merely dubious to totally insane. @@ -139,6 +152,9 @@ ++ checkConditionals gpkg ++ checkPackageVersions gpkg ++ checkDevelopmentOnlyFlags gpkg + ++ checkFlagNames gpkg + ++ checkUnusedFlags gpkg + ++ checkUnicodeXFields gpkg where pkg = fromMaybe (flattenPackageDescription gpkg) mpkg @@ -304,6 +320,11 @@ "On executable '" ++ display (exeName exe) ++ "' an 'autogen-module' is not " ++ "on 'other-modules'" + , checkSpecVersion pkg [2,0] (exeScope exe /= ExecutableScopeUnknown) $ + PackageDistSuspiciousWarn $ + "To use the 'scope' field the package needs to specify " + ++ "at least 'cabal-version: >= 2.0'." + ] where moduleDuplicates = dups (exeModules exe) @@ -525,13 +546,42 @@ ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." - , check (not (null buildDependsRangeOnInternalLibrary)) $ + , check (not (null depInternalLibraryWithExtraVersion)) $ PackageBuildWarning $ - "The package has a version range for a dependency on an " + "The package has an extraneous version range for a dependency on an " ++ "internal library: " - ++ commaSep (map display buildDependsRangeOnInternalLibrary) - ++ ". This version range has no semantic meaning and can be " - ++ "removed." + ++ commaSep (map display depInternalLibraryWithExtraVersion) + ++ ". This version range includes the current package but isn't needed " + ++ "as the current package's library will always be used." + + , check (not (null depInternalLibraryWithImpossibleVersion)) $ + PackageBuildImpossible $ + "The package has an impossible version range for a dependency on an " + ++ "internal library: " + ++ commaSep (map display depInternalLibraryWithImpossibleVersion) + ++ ". This version range does not include the current package, and must " + ++ "be removed as the current package's library will always be used." + + , check (not (null depInternalExecutableWithExtraVersion)) $ + PackageBuildWarning $ + "The package has an extraneous version range for a dependency on an " + ++ "internal executable: " + ++ commaSep (map display depInternalExecutableWithExtraVersion) + ++ ". This version range includes the current package but isn't needed " + ++ "as the current package's executable will always be used." + + , check (not (null depInternalExecutableWithImpossibleVersion)) $ + PackageBuildImpossible $ + "The package has an impossible version range for a dependency on an " + ++ "internal executable: " + ++ commaSep (map display depInternalExecutableWithImpossibleVersion) + ++ ". This version range does not include the current package, and must " + ++ "be removed as the current package's executable will always be used." + + , check (not (null depMissingInternalExecutable)) $ + PackageBuildImpossible $ + "The package depends on a missing internal executable: " + ++ commaSep (map display depInternalExecutableWithImpossibleVersion) ] where unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] @@ -557,15 +607,56 @@ internalLibraries = map (maybe (packageName pkg) (unqualComponentNameToPackageName) . libName) (allLibraries pkg) - buildDependsRangeOnInternalLibrary = + + internalExecutables = map exeName $ executables pkg + + internalLibDeps = [ dep | bi <- allBuildInfo pkg - , dep@(Dependency name versionRange) <- targetBuildDepends bi - , not (isAnyVersion versionRange) + , dep@(Dependency name _) <- targetBuildDepends bi , name `elem` internalLibraries ] + internalExeDeps = + [ dep + | bi <- allBuildInfo pkg + , dep <- getAllToolDependencies pkg bi + , isInternal pkg dep + ] + depInternalLibraryWithExtraVersion = + [ dep + | dep@(Dependency _ versionRange) <- internalLibDeps + , not $ isAnyVersion versionRange + , packageVersion pkg `withinRange` versionRange + ] + + depInternalLibraryWithImpossibleVersion = + [ dep + | dep@(Dependency _ versionRange) <- internalLibDeps + , not $ packageVersion pkg `withinRange` versionRange + ] + + depInternalExecutableWithExtraVersion = + [ dep + | dep@(ExeDependency _ _ versionRange) <- internalExeDeps + , not $ isAnyVersion versionRange + , packageVersion pkg `withinRange` versionRange + ] + + depInternalExecutableWithImpossibleVersion = + [ dep + | dep@(ExeDependency _ _ versionRange) <- internalExeDeps + , not $ packageVersion pkg `withinRange` versionRange + ] + + depMissingInternalExecutable = + [ dep + | dep@(ExeDependency _ eName _) <- internalExeDeps + , not $ eName `elem` internalExecutables + ] + + checkLicense :: PackageDescription -> [PackageCheck] checkLicense pkg = catMaybes [ @@ -721,6 +812,11 @@ ++ "Check that it is giving a real benefit " ++ "and not just imposing longer compile times on your users." + , checkFlags ["-split-sections"] $ + PackageBuildWarning $ + "'ghc-options: -split-sections' is not needed. " + ++ "Use the --enable-split-sections configure flag." + , checkFlags ["-split-objs"] $ PackageBuildWarning $ "'ghc-options: -split-objs' is not needed. " @@ -936,7 +1032,10 @@ ++ [ (path, "data-dir") | path <- [dataDir pkg]] ++ [ (path, "license-file") | path <- licenseFiles pkg ] ++ concat - [ [ (path, "c-sources") | path <- cSources bi ] + [ [ (path, "asm-sources") | path <- asmSources bi ] + ++ [ (path, "cmm-sources") | path <- cmmSources bi ] + ++ [ (path, "c-sources") | path <- cSources bi ] + ++ [ (path, "cxx-sources") | path <- cxxSources bi ] ++ [ (path, "js-sources") | path <- jsSources bi ] ++ [ (path, "install-includes") | path <- installIncludes bi ] ++ [ (path, "hs-source-dirs") | path <- hsSourceDirs bi ] @@ -1093,6 +1192,23 @@ [ display (Dependency name (eliminateMajorBoundSyntax versionRange)) | Dependency name versionRange <- depsUsingMajorBoundSyntax ] + , checkVersion [2,1] (any (not . null) + (concatMap buildInfoField + [ asmSources + , cmmSources + , extraBundledLibs + , extraLibFlavours ])) $ + PackageDistInexcusable $ + "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' " + ++ " and 'extra-library-flavours' requires the package " + ++ " to specify at least 'cabal-version: >= 2.1'." + + , checkVersion [2,1] (any (not . null) + (buildInfoField virtualModules)) $ + PackageDistInexcusable $ + "The use of 'virtual-modules' requires the package " + ++ " to specify at least 'cabal-version: >= 2.1'." + -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax , checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $ PackageDistInexcusable $ @@ -1226,35 +1342,24 @@ , usesNewVersionRangeSyntax vr ] simpleSpecVersionRangeSyntax = - either (const True) - (foldVersionRange' - True - (\_ -> False) - (\_ -> False) (\_ -> False) - (\_ -> True) -- >= - (\_ -> False) - (\_ _ -> False) - (\_ _ -> False) - (\_ _ -> False) (\_ _ -> False) - id) - (specVersionRaw pkg) + either (const True) (cataVersionRange alg) (specVersionRaw pkg) + where + alg (OrLaterVersionF _) = True + alg _ = False -- is the cabal-version field a simple version number, rather than a range simpleSpecVersionSyntax = either (const True) (const False) (specVersionRaw pkg) usesNewVersionRangeSyntax :: VersionRange -> Bool - usesNewVersionRangeSyntax = - (> 2) -- uses the new syntax if depth is more than 2 - . foldVersionRange' - (1 :: Int) - (const 1) - (const 1) (const 1) - (const 1) (const 1) - (const (const 1)) - (const (const 1)) - (+) (+) - (const 3) -- uses new ()'s syntax + usesNewVersionRangeSyntax + = (> 2) -- uses the new syntax if depth is more than 2 + . cataVersionRange alg + where + alg (UnionVersionRangesF a b) = a + b + alg (IntersectVersionRangesF a b) = a + b + alg (VersionRangeParensF _) = 3 + alg _ = 1 :: Int depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg , usesWildcardSyntax vr ] @@ -1270,45 +1375,38 @@ , usesWildcardSyntax vr ] usesWildcardSyntax :: VersionRange -> Bool - usesWildcardSyntax = - foldVersionRange' - False (const False) - (const False) (const False) - (const False) (const False) - (\_ _ -> True) -- the wildcard case - (\_ _ -> False) - (||) (||) id + usesWildcardSyntax = cataVersionRange alg + where + alg (WildcardVersionF _) = True + alg (UnionVersionRangesF a b) = a || b + alg (IntersectVersionRangesF a b) = a || b + alg (VersionRangeParensF a) = a + alg _ = False -- NB: this eliminates both, WildcardVersion and MajorBoundVersion -- because when WildcardVersion is not support, neither is MajorBoundVersion - eliminateWildcardSyntax = - foldVersionRange' - anyVersion thisVersion - laterVersion earlierVersion - orLaterVersion orEarlierVersion - (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v')) - (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v')) - intersectVersionRanges unionVersionRanges id + eliminateWildcardSyntax = hyloVersionRange embed projectVersionRange + where + embed (WildcardVersionF v) = intersectVersionRanges + (orLaterVersion v) (earlierVersion (wildcardUpperBound v)) + embed (MajorBoundVersionF v) = intersectVersionRanges + (orLaterVersion v) (earlierVersion (majorUpperBound v)) + embed vr = embedVersionRange vr usesMajorBoundSyntax :: VersionRange -> Bool - usesMajorBoundSyntax = - foldVersionRange' - False (const False) - (const False) (const False) - (const False) (const False) - (\_ _ -> False) - (\_ _ -> True) -- MajorBoundVersion - (||) (||) id - - eliminateMajorBoundSyntax = - foldVersionRange' - anyVersion thisVersion - laterVersion earlierVersion - orLaterVersion orEarlierVersion - (\v _ -> withinVersion v) - (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v')) - intersectVersionRanges unionVersionRanges id + usesMajorBoundSyntax = cataVersionRange alg + where + alg (MajorBoundVersionF _) = True + alg (UnionVersionRangesF a b) = a || b + alg (IntersectVersionRangesF a b) = a || b + alg (VersionRangeParensF a) = a + alg _ = False + eliminateMajorBoundSyntax = hyloVersionRange embed projectVersionRange + where + embed (MajorBoundVersionF v) = intersectVersionRanges + (orLaterVersion v) (earlierVersion (majorUpperBound v)) + embed vr = embedVersionRange vr compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4 , PublicDomain, AllRightsReserved @@ -1364,41 +1462,9 @@ allModuleNamesAutogen = concatMap autogenModules (allBuildInfo pkg) --- | A variation on the normal 'Text' instance, shows any ()'s in the original --- textual syntax. We need to show these otherwise it's confusing to users when --- we complain of their presence but do not pretty print them! --- -displayRawVersionRange :: VersionRange -> String -displayRawVersionRange = - Disp.render - . fst - . foldVersionRange' -- precedence: - -- All the same as the usual pretty printer, except for the parens - ( Disp.text "-any" , 0 :: Int) - (\v -> (Disp.text "==" <<>> disp v , 0)) - (\v -> (Disp.char '>' <<>> disp v , 0)) - (\v -> (Disp.char '<' <<>> disp v , 0)) - (\v -> (Disp.text ">=" <<>> disp v , 0)) - (\v -> (Disp.text "<=" <<>> disp v , 0)) - (\v _ -> (Disp.text "==" <<>> dispWild v , 0)) - (\v _ -> (Disp.text "^>=" <<>> disp v , 0)) - (\(r1, p1) (r2, p2) -> - (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) - (\(r1, p1) (r2, p2) -> - (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) - (\(r, _ ) -> (Disp.parens r, 0)) -- parens - - where - dispWild v = - Disp.hcat (Disp.punctuate (Disp.char '.') - (map Disp.int $ versionNumbers v)) - <<>> Disp.text ".*" - punct p p' | p < p' = Disp.parens - | otherwise = id - displayRawDependency :: Dependency -> String displayRawDependency (Dependency pkg vr) = - display pkg ++ " " ++ displayRawVersionRange vr + display pkg ++ " " ++ display vr -- ------------------------------------------------------------ @@ -1438,7 +1504,7 @@ -- open upper bound. To get a typical configuration we finalise -- using no package index and the current platform. finalised = finalizePD - [] defaultComponentRequestedSpec (const True) + mempty defaultComponentRequestedSpec (const True) buildPlatform (unknownCompilerInfo (CompilerId buildCompilerFlavor nullVersion) @@ -1490,11 +1556,12 @@ unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] conditions = concatMap fvs (maybeToList (condLibrary pkg)) ++ concatMap (fvs . snd) (condSubLibraries pkg) + ++ concatMap (fvs . snd) (condForeignLibs pkg) ++ concatMap (fvs . snd) (condExecutables pkg) ++ concatMap (fvs . snd) (condTestSuites pkg) ++ concatMap (fvs . snd) (condBenchmarks pkg) fvs (CondNode _ _ ifs) = concatMap compfv ifs -- free variables - compfv (c, ct, mct) = condfv c ++ fvs ct ++ maybe [] fvs mct + compfv (CondBranch c ct mct) = condfv c ++ fvs ct ++ maybe [] fvs mct condfv c = case c of Var v -> [v] Lit _ -> [] @@ -1502,6 +1569,69 @@ COr c1 c2 -> condfv c1 ++ condfv c2 CAnd c1 c2 -> condfv c1 ++ condfv c2 +checkFlagNames :: GenericPackageDescription -> [PackageCheck] +checkFlagNames gpd + | null invalidFlagNames = [] + | otherwise = [ PackageDistInexcusable + $ "Suspicious flag names: " ++ unwords invalidFlagNames ++ ". " + ++ "To avoid ambiguity in command line interfaces, flag shouldn't " + ++ "start with a dash. Also for better compatibility, flag names " + ++ "shouldn't contain non-ascii characters." + ] + where + invalidFlagNames = + [ fn + | flag <- genPackageFlags gpd + , let fn = unFlagName (flagName flag) + , invalidFlagName fn + ] + -- starts with dash + invalidFlagName ('-':_) = True + -- mon ascii letter + invalidFlagName cs = any (not . isAscii) cs + +checkUnusedFlags :: GenericPackageDescription -> [PackageCheck] +checkUnusedFlags gpd + | declared == used = [] + | otherwise = [ PackageDistSuspicious + $ "Declared and used flag sets differ: " + ++ s declared ++ " /= " ++ s used ++ ". " + ] + where + s :: Set.Set FlagName -> String + s = commaSep . map unFlagName . Set.toList + + declared :: Set.Set FlagName + declared = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd + + used :: Set.Set FlagName + used = mconcat + [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._Flag) gpd + , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._Flag) gpd + , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._Flag) gpd + , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._Flag) gpd + , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._Flag) gpd + , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._Flag) gpd + ] + +checkUnicodeXFields :: GenericPackageDescription -> [PackageCheck] +checkUnicodeXFields gpd + | null nonAsciiXFields = [] + | otherwise = [ PackageDistInexcusable + $ "Non ascii custom fields: " ++ unwords nonAsciiXFields ++ ". " + ++ "For better compatibility, custom field names " + ++ "shouldn't contain non-ascii characters." + ] + where + nonAsciiXFields :: [String] + nonAsciiXFields = [ n | (n, _) <- xfields, any (not . isAscii) n ] + + xfields :: [(String,String)] + xfields = DList.runDList $ mconcat + [ toDListOf (L.packageDescription . L.customFieldsPD . traverse) gpd + , toDListOf (L.buildInfos . L.customFieldsBI . traverse) gpd + ] + checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck] checkDevelopmentOnlyFlagsBuildInfo bi = catMaybes [ @@ -1538,7 +1668,7 @@ "-fprof-cafs", "-fno-prof-count-entries", "-auto-all", "-auto", "-caf-all"] $ PackageDistSuspicious $ - "'ghc-options: -fprof*' profiling flags are typically not " + "'ghc-options/ghc-prof-options: -fprof*' profiling flags are typically not " ++ "appropriate for a distributed library package. These flags are " ++ "useful to profile this package, but when profiling other packages " ++ "that use this one these flags clutter the profile output with " @@ -1623,11 +1753,11 @@ : concat [ go (condition:conditions) ifThen - | (condition, ifThen, _) <- condTreeComponents condNode ] + | (CondBranch condition ifThen _) <- condTreeComponents condNode ] ++ concat [ go (condition:conditions) elseThen - | (condition, _, Just elseThen) <- condTreeComponents condNode ] + | (CondBranch condition _ (Just elseThen)) <- condTreeComponents condNode ] -- ------------------------------------------------------------ @@ -1644,8 +1774,7 @@ doesFileExist = System.doesFileExist . relative, doesDirectoryExist = System.doesDirectoryExist . relative, getDirectoryContents = System.Directory.getDirectoryContents . relative, - getFileContents = \f -> openBinaryFile (relative f) ReadMode - >>= hGetContents + getFileContents = BS.readFile } relative path = root path @@ -1656,7 +1785,7 @@ doesFileExist :: FilePath -> m Bool, doesDirectoryExist :: FilePath -> m Bool, getDirectoryContents :: FilePath -> m [FilePath], - getFileContents :: FilePath -> m String + getFileContents :: FilePath -> m BS.ByteString } -- | Sanity check things that requires looking at files in the package. @@ -1671,6 +1800,7 @@ -> m [PackageCheck] checkPackageContent ops pkg = do cabalBomError <- checkCabalFileBOM ops + cabalNameError <- checkCabalFileName ops pkg licenseErrors <- checkLicensesExist ops pkg setupError <- checkSetupExists ops pkg configureError <- checkConfigureExists ops pkg @@ -1678,7 +1808,7 @@ vcsLocation <- checkMissingVcsInfo ops pkg return $ licenseErrors - ++ catMaybes [cabalBomError, setupError, configureError] + ++ catMaybes [cabalBomError, cabalNameError, setupError, configureError] ++ localPathErrors ++ vcsLocation @@ -1694,12 +1824,37 @@ -- --cabal-file is specified. So if you can't find the file, -- just don't bother with this check. Left _ -> return $ Nothing - Right pdfile -> (flip check pc . startsWithBOM . fromUTF8) + Right pdfile -> (flip check pc . BS.isPrefixOf bomUtf8) `liftM` (getFileContents ops pdfile) where pc = PackageDistInexcusable $ pdfile ++ " starts with an Unicode byte order mark (BOM)." ++ " This may cause problems with older cabal versions." + where + bomUtf8 :: BS.ByteString + bomUtf8 = BS.pack [0xef,0xbb,0xbf] -- U+FEFF encoded as UTF8 + +checkCabalFileName :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkCabalFileName ops pkg = do + -- findPackageDesc already takes care to detect missing/multiple + -- .cabal files; we don't include this check in 'findPackageDesc' in + -- order not to short-cut other checks which call 'findPackageDesc' + epdfile <- findPackageDesc ops + case epdfile of + -- see "MASSIVE HACK" note in 'checkCabalFileBOM' + Left _ -> return Nothing + Right pdfile + | takeFileName pdfile == expectedCabalname -> return Nothing + | otherwise -> return $ Just $ PackageDistInexcusable $ + "The filename " ++ pdfile ++ " does not match package name " ++ + "(expected: " ++ expectedCabalname ++ ")" + where + pkgname = unPackageName . packageName $ pkg + expectedCabalname = pkgname <.> "cabal" + + -- |Find a package description file in the given directory. Looks for -- @.cabal@ files. Like 'Distribution.Simple.Utils.findPackageDesc', -- but generalized over monads. @@ -1815,6 +1970,7 @@ repoTypeDirname Bazaar = [".bzr"] repoTypeDirname Monotone = ["_MTN"] repoTypeDirname _ = [] + -- ------------------------------------------------------------ -- * Checks involving files in the package 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 @@ -37,7 +37,6 @@ import Prelude () import Distribution.Compat.Prelude -import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Utils import Distribution.Version @@ -50,46 +49,18 @@ import Distribution.Types.ComponentRequestedSpec import Distribution.Types.ForeignLib import Distribution.Types.Component +import Distribution.Types.Dependency +import Distribution.Types.PackageName +import Distribution.Types.UnqualComponentName +import Distribution.Types.CondTree +import Distribution.Types.Condition +import Distribution.Types.DependencyMap import qualified Data.Map as Map import Data.Tree ( Tree(Node) ) ------------------------------------------------------------------------------ --- | Simplify the condition and return its free variables. -simplifyCondition :: Condition c - -> (c -> Either d Bool) -- ^ (partial) variable assignment - -> (Condition d, [d]) -simplifyCondition cond i = fv . walk $ cond - where - walk cnd = case cnd of - Var v -> either Var Lit (i v) - Lit b -> Lit b - CNot c -> case walk c of - Lit True -> Lit False - Lit False -> Lit True - c' -> CNot c' - COr c d -> case (walk c, walk d) of - (Lit False, d') -> d' - (Lit True, _) -> Lit True - (c', Lit False) -> c' - (_, Lit True) -> Lit True - (c',d') -> COr c' d' - CAnd c d -> case (walk c, walk d) of - (Lit False, _) -> Lit False - (Lit True, d') -> d' - (_, Lit False) -> Lit False - (c', Lit True) -> c' - (c',d') -> CAnd c' d' - -- gather free vars - fv c = (c, fv' c) - fv' c = case c of - Var v -> [v] - Lit _ -> [] - CNot c' -> fv' c' - COr c1 c2 -> fv' c1 ++ fv' c2 - CAnd c1 c2 -> fv' c1 ++ fv' c2 - -- | Simplify a configuration condition using the OS and arch names. Returns -- the names of all the flags occurring in the condition. simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar @@ -154,23 +125,6 @@ ------------------------------------------------------------------------------ -mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) - -> CondTree v c a -> CondTree w d b -mapCondTree fa fc fcnd (CondNode a c ifs) = - CondNode (fa a) (fc c) (map g ifs) - where - g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t, - fmap (mapCondTree fa fc fcnd) me) - -mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a -mapTreeConstrs f = mapCondTree id f id - -mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a -mapTreeConds f = mapCondTree id id f - -mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b -mapTreeData f = mapCondTree f id id - -- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for -- clarity. data DepTestRslt d = DepOk | MissingDeps d @@ -220,7 +174,7 @@ -- ^ Either the missing dependencies (error case), or a pair of -- (set of build targets with dependencies, chosen flag assignments) resolveWithFlags dom enabled os arch impl constrs trees checkDeps = - either (Left . fromDepMapUnion) Right $ explore (build [] dom) + either (Left . fromDepMapUnion) Right $ explore (build mempty dom) where extraConstrs = toDepMap constrs @@ -228,7 +182,7 @@ -- dependencies to dependency maps. simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged] simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps - . addBuildableCondition pdTaggedBuildInfo + . addBuildableConditionPDTagged . mapTreeConds (fst . simplifyWithSysParams os arch impl)) trees @@ -255,7 +209,7 @@ build :: FlagAssignment -> [(FlagName, [Bool])] -> Tree FlagAssignment build assigned [] = Node assigned [] build assigned ((fn, vals) : unassigned) = - Node assigned $ map (\v -> build ((fn, v) : assigned) unassigned) vals + Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a tryAll = foldr mp mz @@ -275,12 +229,7 @@ mz = Left (DepMapUnion Map.empty) env :: FlagAssignment -> FlagName -> Either FlagName Bool - env flags flag = (maybe (Left flag) Right . lookup flag) flags - - pdTaggedBuildInfo :: PDTagged -> BuildInfo - pdTaggedBuildInfo (Lib l) = libBuildInfo l - pdTaggedBuildInfo (SubComp _ c) = componentBuildInfo c - pdTaggedBuildInfo PDNull = mempty + env flags flag = (maybe (Left flag) Right . lookupFlagAssignment flag) flags -- | Transforms a 'CondTree' by putting the input under the "then" branch of a -- conditional that is True when Buildable is True. If 'addBuildableCondition' @@ -293,8 +242,35 @@ case extractCondition (buildable . getInfo) t of Lit True -> t Lit False -> CondNode mempty mempty [] - c -> CondNode mempty mempty [(c, t, Nothing)] + c -> CondNode mempty mempty [condIfThen c t] +-- | This is a special version of 'addBuildableCondition' for the 'PDTagged' +-- type. +-- +-- It is not simply a specialisation. It is more complicated than it +-- ought to be because of the way the 'PDTagged' monoid instance works. The +-- @mempty = 'PDNull'@ forgets the component type, which has the effect of +-- completely deleting components that are not buildable. +-- +-- See for more details. +-- +addBuildableConditionPDTagged :: (Eq v, Monoid c) => + CondTree v c PDTagged + -> CondTree v c PDTagged +addBuildableConditionPDTagged t = + case extractCondition (buildable . getInfo) t of + Lit True -> t + Lit False -> deleteConstraints t + c -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)] + where + deleteConstraints = mapTreeConstrs (const mempty) + + getInfo :: PDTagged -> BuildInfo + getInfo (Lib l) = libBuildInfo l + getInfo (SubComp _ c) = componentBuildInfo c + getInfo PDNull = mempty + + -- Note: extracting buildable conditions. -- -------------------------------------- -- @@ -308,25 +284,6 @@ -- extract the condition under which Buildable is True. The predicate determines -- whether data under a 'CondTree' is buildable. - --- | Extract the condition matched by the given predicate from a cond tree. --- --- We use this mainly for extracting buildable conditions (see the Note above), --- but the function is in fact more general. -extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v -extractCondition p = go - where - go (CondNode x _ cs) | not (p x) = Lit False - | otherwise = goList cs - - goList [] = Lit True - goList ((c, t, e) : cs) = - let - ct = go t - ce = maybe (Lit True) go e - in - ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs - -- | Extract conditions matched by the given predicate from all cond trees in a -- 'GenericPackageDescription'. extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription @@ -351,54 +308,11 @@ fromDepMapUnion :: DepMapUnion -> [Dependency] fromDepMapUnion m = [ Dependency p vr | (p,vr) <- Map.toList (unDepMapUnion m) ] --- | A map of dependencies. Newtyped since the default monoid instance is not --- appropriate. The monoid instance uses 'intersectVersionRanges'. -newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange } - deriving (Show, Read) - -instance Monoid DependencyMap where - mempty = DependencyMap Map.empty - mappend = (<>) - -instance Semigroup DependencyMap where - (DependencyMap a) <> (DependencyMap b) = - DependencyMap (Map.unionWith intersectVersionRanges a b) - -toDepMap :: [Dependency] -> DependencyMap -toDepMap ds = - DependencyMap $ Map.fromListWith intersectVersionRanges [ (p,vr) | Dependency p vr <- ds ] - -fromDepMap :: DependencyMap -> [Dependency] -fromDepMap m = [ Dependency p vr | (p,vr) <- Map.toList (unDependencyMap m) ] - --- | Flattens a CondTree using a partial flag assignment. When a condition --- cannot be evaluated, both branches are ignored. -simplifyCondTree :: (Monoid a, Monoid d) => - (v -> Either v Bool) - -> CondTree v d a - -> (d, a) -simplifyCondTree env (CondNode a d ifs) = - mconcat $ (d, a) : mapMaybe simplifyIf ifs - where - simplifyIf (cnd, t, me) = - case simplifyCondition cnd env of - (Lit True, _) -> Just $ simplifyCondTree env t - (Lit False, _) -> fmap (simplifyCondTree env) me - _ -> Nothing - --- | Flatten a CondTree. This will resolve the CondTree by taking all --- possible paths into account. Note that since branches represent exclusive --- choices this may not result in a \"sane\" result. -ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c) -ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs) - where f (_, t, me) = ignoreConditions t - : maybeToList (fmap ignoreConditions me) - freeVars :: CondTree ConfVar c a -> [FlagName] freeVars t = [ f | Flag f <- freeVars' t ] where freeVars' (CondNode _ _ ifs) = concatMap compfv ifs - compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct + compfv (CondBranch c ct mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct condfv c = case c of Var v -> [v] Lit _ -> [] @@ -434,47 +348,18 @@ CBench _ -> CBenchName t removeDisabledSections PDNull = True --- Apply extra constraints to a dependency map. --- Combines dependencies where the result will only contain keys from the left --- (first) map. If a key also exists in the right map, both constraints will --- be intersected. -constrainBy :: DependencyMap -- ^ Input map - -> DependencyMap -- ^ Extra constraints - -> DependencyMap -constrainBy left extra = - DependencyMap $ - Map.foldWithKey tightenConstraint (unDependencyMap left) - (unDependencyMap extra) - where tightenConstraint n c l = - case Map.lookup n l of - Nothing -> l - Just vr -> Map.insert n (intersectVersionRanges vr c) l - -- | Collect up the targets in a TargetSet of tagged targets, storing the -- dependencies as we go. flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(UnqualComponentName, Component)]) flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets where untag (_, Lib _) (Just _, _) = userBug "Only one library expected" - untag (deps, Lib l) (Nothing, comps) = - (Just l', comps) - where - l' = l { - libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps } - } - untag (deps, SubComp n c) (mb_lib, comps) + untag (_, Lib l) (Nothing, comps) = (Just l, comps) + untag (_, SubComp n c) (mb_lib, comps) | any ((== n) . fst) comps = userBug $ "There exist several components with the same name: '" ++ unUnqualComponentName n ++ "'" - | otherwise = (mb_lib, (n, c') : comps) - where - updBI bi = bi { targetBuildDepends = fromDepMap deps } - c' = case c of - CLib x -> CLib x { libBuildInfo = updBI (libBuildInfo x) } - CFLib x -> CFLib x { foreignLibBuildInfo = updBI (foreignLibBuildInfo x) } - CExe x -> CExe x { buildInfo = updBI (buildInfo x) } - CTest x -> CTest x { testBuildInfo = updBI (testBuildInfo x) } - CBench x -> CBench x { benchmarkBuildInfo = updBI (benchmarkBuildInfo x) } + | otherwise = (mb_lib, (n, c) : comps) untag (_, PDNull) x = x -- actually this should not happen, but let's be liberal @@ -541,21 +426,30 @@ -- description along with the flag assignments chosen. finalizePD userflags enabled satisfyDep (Platform arch os) impl constraints - (GenericPackageDescription pkg flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) = - case resolveFlags of - Right ((mb_lib', comps'), targetSet, flagVals) -> - let (sub_libs', flibs', exes', tests', bms') = partitionComponents comps' in - Right ( pkg { library = mb_lib' - , subLibraries = sub_libs' - , foreignLibs = flibs' - , executables = exes' - , testSuites = tests' - , benchmarks = bms' - , buildDepends = fromDepMap (overallDependencies enabled targetSet) - } - , flagVals ) - - Left missing -> Left missing + (GenericPackageDescription pkg flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) = do + (targetSet, flagVals) <- + resolveWithFlags flagChoices enabled os arch impl constraints condTrees check + let + (mb_lib, comps) = flattenTaggedTargets targetSet + mb_lib' = fmap libFillInDefaults mb_lib + comps' = flip map comps $ \(n,c) -> foldComponent + (\l -> CLib (libFillInDefaults l) { libName = Just n + , libExposed = False }) + (\l -> CFLib (flibFillInDefaults l) { foreignLibName = n }) + (\e -> CExe (exeFillInDefaults e) { exeName = n }) + (\t -> CTest (testFillInDefaults t) { testName = n }) + (\b -> CBench (benchFillInDefaults b) { benchmarkName = n }) + c + (sub_libs', flibs', exes', tests', bms') = partitionComponents comps' + return ( pkg { library = mb_lib' + , subLibraries = sub_libs' + , foreignLibs = flibs' + , executables = exes' + , testSuites = tests' + , benchmarks = bms' + , buildDepends = fromDepMap (overallDependencies enabled targetSet) + } + , flagVals ) where -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data condTrees = maybeToList (fmap (mapTreeData Lib) mb_lib0) @@ -565,25 +459,8 @@ ++ map (\(name,tree) -> mapTreeData (SubComp name . CTest) tree) tests0 ++ map (\(name,tree) -> mapTreeData (SubComp name . CBench) tree) bms0 - resolveFlags = - case resolveWithFlags flagChoices enabled os arch impl constraints condTrees check of - Right (targetSet, fs) -> - let (mb_lib, comps) = flattenTaggedTargets targetSet in - Right ( (fmap libFillInDefaults mb_lib, - map (\(n,c) -> - foldComponent - (\l -> CLib (libFillInDefaults l) { libName = Just n - , libExposed = False }) - (\l -> CFLib (flibFillInDefaults l) { foreignLibName = n }) - (\e -> CExe (exeFillInDefaults e) { exeName = n }) - (\t -> CTest (testFillInDefaults t) { testName = n }) - (\b -> CBench (benchFillInDefaults b) { benchmarkName = n }) - c) comps), - targetSet, fs) - Left missing -> Left missing - flagChoices = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags - d2c manual n b = case lookup n userflags of + d2c manual n b = case lookupFlagAssignment n userflags of Just val -> [val] Nothing | manual -> [b] diff --git a/cabal/Cabal/Distribution/PackageDescription/FieldGrammar.hs b/cabal/Cabal/Distribution/PackageDescription/FieldGrammar.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/PackageDescription/FieldGrammar.hs @@ -0,0 +1,514 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | 'GenericPackageDescription' Field descriptions +module Distribution.PackageDescription.FieldGrammar ( + -- * Package description + packageDescriptionFieldGrammar, + -- * Library + libraryFieldGrammar, + -- * Foreign library + foreignLibFieldGrammar, + -- * Executable + executableFieldGrammar, + -- * Test suite + TestSuiteStanza (..), + testSuiteFieldGrammar, + validateTestSuite, + unvalidateTestSuite, + -- ** Lenses + testStanzaTestType, + testStanzaMainIs, + testStanzaTestModule, + testStanzaBuildInfo, + -- * Benchmark + BenchmarkStanza (..), + benchmarkFieldGrammar, + validateBenchmark, + unvalidateBenchmark, + -- ** Lenses + benchmarkStanzaBenchmarkType, + benchmarkStanzaMainIs, + benchmarkStanzaBenchmarkModule, + benchmarkStanzaBuildInfo, + -- * Flag + flagFieldGrammar, + -- * Source repository + sourceRepoFieldGrammar, + -- * Setup build info + setupBInfoFieldGrammar, + -- * Component build info + buildInfoFieldGrammar, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compiler (CompilerFlavor (..)) +import Distribution.FieldGrammar +import Distribution.License (License (..)) +import Distribution.ModuleName (ModuleName) +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Parsec.Common +import Distribution.Parsec.Newtypes +import Distribution.Parsec.ParseResult +import Distribution.Text (display) +import Distribution.Types.ForeignLib +import Distribution.Types.ForeignLibType +import Distribution.Types.UnqualComponentName +import Distribution.Version (anyVersion) + +import qualified Distribution.Types.Lens as L + +------------------------------------------------------------------------------- +-- PackageDescription +------------------------------------------------------------------------------- + +packageDescriptionFieldGrammar + :: (FieldGrammar g, Applicative (g PackageDescription), Applicative (g PackageIdentifier)) + => g PackageDescription PackageDescription +packageDescriptionFieldGrammar = PackageDescription + <$> blurFieldGrammar L.package packageIdentifierGrammar + <*> optionalFieldDef "license" L.license UnspecifiedLicense + <*> licenseFilesGrammar + <*> optionalFieldDefAla "copyright" FreeText L.copyright "" + <*> optionalFieldDefAla "maintainer" FreeText L.maintainer "" + <*> optionalFieldDefAla "author" FreeText L.author "" + <*> optionalFieldDefAla "stability" FreeText L.stability "" + <*> monoidalFieldAla "tested-with" (alaList' FSep TestedWith) L.testedWith + <*> optionalFieldDefAla "homepage" FreeText L.homepage "" + <*> optionalFieldDefAla "package-url" FreeText L.pkgUrl "" + <*> optionalFieldDefAla "bug-reports" FreeText L.bugReports "" + <*> pure [] -- source-repos are stanza + <*> optionalFieldDefAla "synopsis" FreeText L.synopsis "" + <*> optionalFieldDefAla "description" FreeText L.description "" + <*> optionalFieldDefAla "category" FreeText L.category "" + <*> prefixedFields "x-" L.customFieldsPD + <*> pure [] -- build-depends + <*> optionalFieldDefAla "cabal-version" SpecVersion L.specVersionRaw (Right anyVersion) + <*> optionalField "build-type" L.buildType + <*> pure Nothing -- custom-setup + -- components + <*> pure Nothing -- lib + <*> pure [] -- sub libs + <*> pure [] -- executables + <*> pure [] -- foreign libs + <*> pure [] -- test suites + <*> pure [] -- benchmarks + -- * Files + <*> monoidalFieldAla "data-files" (alaList' VCat FilePathNT) L.dataFiles + <*> optionalFieldDefAla "data-dir" FilePathNT L.dataDir "" + <*> monoidalFieldAla "extra-source-files" (alaList' VCat FilePathNT) L.extraSrcFiles + <*> monoidalFieldAla "extra-tmp-files" (alaList' VCat FilePathNT) L.extraTmpFiles + <*> monoidalFieldAla "extra-doc-files" (alaList' VCat FilePathNT) L.extraDocFiles + where + packageIdentifierGrammar = PackageIdentifier + <$> uniqueField "name" L.pkgName + <*> uniqueField "version" L.pkgVersion + + licenseFilesGrammar = (++) + -- TODO: neither field is deprecated + -- should we pretty print license-file if there's single license file + -- and license-files when more + <$> monoidalFieldAla "license-file" (alaList' FSep FilePathNT) L.licenseFiles + <*> monoidalFieldAla "license-files" (alaList' FSep FilePathNT) L.licenseFiles + ^^^ hiddenField + +------------------------------------------------------------------------------- +-- Library +------------------------------------------------------------------------------- + +libraryFieldGrammar + :: (FieldGrammar g, Applicative (g Library), Applicative (g BuildInfo)) + => Maybe UnqualComponentName -> g Library Library +libraryFieldGrammar n = Library n + <$> monoidalFieldAla "exposed-modules" (alaList' VCat MQuoted) L.exposedModules + <*> monoidalFieldAla "reexported-modules" (alaList CommaVCat) L.reexportedModules + <*> monoidalFieldAla "signatures" (alaList' VCat MQuoted) L.signatures + <*> booleanFieldDef "exposed" L.libExposed True + <*> blurFieldGrammar L.libBuildInfo buildInfoFieldGrammar +{-# SPECIALIZE libraryFieldGrammar :: Maybe UnqualComponentName -> ParsecFieldGrammar' Library #-} +{-# SPECIALIZE libraryFieldGrammar :: Maybe UnqualComponentName -> PrettyFieldGrammar' Library #-} + +------------------------------------------------------------------------------- +-- Foreign library +------------------------------------------------------------------------------- + +foreignLibFieldGrammar + :: (FieldGrammar g, Applicative (g ForeignLib), Applicative (g BuildInfo)) + => UnqualComponentName -> g ForeignLib ForeignLib +foreignLibFieldGrammar n = ForeignLib n + <$> optionalFieldDef "type" L.foreignLibType ForeignLibTypeUnknown + <*> monoidalFieldAla "options" (alaList FSep) L.foreignLibOptions + <*> blurFieldGrammar L.foreignLibBuildInfo buildInfoFieldGrammar + <*> optionalField "lib-version-info" L.foreignLibVersionInfo + <*> optionalField "lib-version-linux" L.foreignLibVersionLinux + <*> monoidalFieldAla "mod-def-file" (alaList' FSep FilePathNT) L.foreignLibModDefFile +{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' ForeignLib #-} +{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' ForeignLib #-} + +------------------------------------------------------------------------------- +-- Executable +------------------------------------------------------------------------------- + +executableFieldGrammar + :: (FieldGrammar g, Applicative (g Executable), Applicative (g BuildInfo)) + => UnqualComponentName -> g Executable Executable +executableFieldGrammar n = Executable n + -- main-is is optional as conditional blocks don't have it + <$> optionalFieldDefAla "main-is" FilePathNT L.modulePath "" + <*> monoidalField "scope" L.exeScope + <*> blurFieldGrammar L.buildInfo buildInfoFieldGrammar +{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' Executable #-} +{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' Executable #-} + +------------------------------------------------------------------------------- +-- TestSuite +------------------------------------------------------------------------------- + +-- | An intermediate type just used for parsing the test-suite stanza. +-- After validation it is converted into the proper 'TestSuite' type. +data TestSuiteStanza = TestSuiteStanza + { _testStanzaTestType :: Maybe TestType + , _testStanzaMainIs :: Maybe FilePath + , _testStanzaTestModule :: Maybe ModuleName + , _testStanzaBuildInfo :: BuildInfo + } + +testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType) +testStanzaTestType f s = fmap (\x -> s { _testStanzaTestType = x }) (f (_testStanzaTestType s)) +{-# INLINE testStanzaTestType #-} + +testStanzaMainIs :: Lens' TestSuiteStanza (Maybe FilePath) +testStanzaMainIs f s = fmap (\x -> s { _testStanzaMainIs = x }) (f (_testStanzaMainIs s)) +{-# INLINE testStanzaMainIs #-} + +testStanzaTestModule :: Lens' TestSuiteStanza (Maybe ModuleName) +testStanzaTestModule f s = fmap (\x -> s { _testStanzaTestModule = x }) (f (_testStanzaTestModule s)) +{-# INLINE testStanzaTestModule #-} + +testStanzaBuildInfo :: Lens' TestSuiteStanza BuildInfo +testStanzaBuildInfo f s = fmap (\x -> s { _testStanzaBuildInfo = x }) (f (_testStanzaBuildInfo s)) +{-# INLINE testStanzaBuildInfo #-} + +testSuiteFieldGrammar + :: (FieldGrammar g, Applicative (g TestSuiteStanza), Applicative (g BuildInfo)) + => g TestSuiteStanza TestSuiteStanza +testSuiteFieldGrammar = TestSuiteStanza + <$> optionalField "type" testStanzaTestType + <*> optionalFieldAla "main-is" FilePathNT testStanzaMainIs + <*> optionalField "test-module" testStanzaTestModule + <*> blurFieldGrammar testStanzaBuildInfo buildInfoFieldGrammar + +validateTestSuite :: Position -> TestSuiteStanza -> ParseResult TestSuite +validateTestSuite pos stanza = case _testStanzaTestType stanza of + Nothing -> return $ + emptyTestSuite { testBuildInfo = _testStanzaBuildInfo stanza } + + Just tt@(TestTypeUnknown _ _) -> + pure emptyTestSuite + { testInterface = TestSuiteUnsupported tt + , testBuildInfo = _testStanzaBuildInfo stanza + } + + Just tt | tt `notElem` knownTestTypes -> + pure emptyTestSuite + { testInterface = TestSuiteUnsupported tt + , testBuildInfo = _testStanzaBuildInfo stanza + } + + Just tt@(TestTypeExe ver) -> case _testStanzaMainIs stanza of + Nothing -> do + parseFailure pos (missingField "main-is" tt) + pure emptyTestSuite + Just file -> do + when (isJust (_testStanzaTestModule stanza)) $ + parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt) + pure emptyTestSuite + { testInterface = TestSuiteExeV10 ver file + , testBuildInfo = _testStanzaBuildInfo stanza + } + + Just tt@(TestTypeLib ver) -> case _testStanzaTestModule stanza of + Nothing -> do + parseFailure pos (missingField "test-module" tt) + pure emptyTestSuite + Just module_ -> do + when (isJust (_testStanzaMainIs stanza)) $ + parseWarning pos PWTExtraMainIs (extraField "main-is" tt) + pure emptyTestSuite + { testInterface = TestSuiteLibV09 ver module_ + , testBuildInfo = _testStanzaBuildInfo stanza + } + + where + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ display tt ++ " test suite type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ display tt ++ "' test suite type." + +unvalidateTestSuite :: TestSuite -> TestSuiteStanza +unvalidateTestSuite t = TestSuiteStanza + { _testStanzaTestType = ty + , _testStanzaMainIs = ma + , _testStanzaTestModule = mo + , _testStanzaBuildInfo = testBuildInfo t + } + where + (ty, ma, mo) = case testInterface t of + TestSuiteExeV10 ver file -> (Just $ TestTypeExe ver, Just file, Nothing) + TestSuiteLibV09 ver modu -> (Just $ TestTypeLib ver, Nothing, Just modu) + _ -> (Nothing, Nothing, Nothing) + +------------------------------------------------------------------------------- +-- Benchmark +------------------------------------------------------------------------------- + +-- | An intermediate type just used for parsing the benchmark stanza. +-- After validation it is converted into the proper 'Benchmark' type. +data BenchmarkStanza = BenchmarkStanza + { _benchmarkStanzaBenchmarkType :: Maybe BenchmarkType + , _benchmarkStanzaMainIs :: Maybe FilePath + , _benchmarkStanzaBenchmarkModule :: Maybe ModuleName + , _benchmarkStanzaBuildInfo :: BuildInfo + } + +benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType) +benchmarkStanzaBenchmarkType f s = fmap (\x -> s { _benchmarkStanzaBenchmarkType = x }) (f (_benchmarkStanzaBenchmarkType s)) +{-# INLINE benchmarkStanzaBenchmarkType #-} + +benchmarkStanzaMainIs :: Lens' BenchmarkStanza (Maybe FilePath) +benchmarkStanzaMainIs f s = fmap (\x -> s { _benchmarkStanzaMainIs = x }) (f (_benchmarkStanzaMainIs s)) +{-# INLINE benchmarkStanzaMainIs #-} + +benchmarkStanzaBenchmarkModule :: Lens' BenchmarkStanza (Maybe ModuleName) +benchmarkStanzaBenchmarkModule f s = fmap (\x -> s { _benchmarkStanzaBenchmarkModule = x }) (f (_benchmarkStanzaBenchmarkModule s)) +{-# INLINE benchmarkStanzaBenchmarkModule #-} + +benchmarkStanzaBuildInfo :: Lens' BenchmarkStanza BuildInfo +benchmarkStanzaBuildInfo f s = fmap (\x -> s { _benchmarkStanzaBuildInfo = x }) (f (_benchmarkStanzaBuildInfo s)) +{-# INLINE benchmarkStanzaBuildInfo #-} + +benchmarkFieldGrammar + :: (FieldGrammar g, Applicative (g BenchmarkStanza), Applicative (g BuildInfo)) + => g BenchmarkStanza BenchmarkStanza +benchmarkFieldGrammar = BenchmarkStanza + <$> optionalField "type" benchmarkStanzaBenchmarkType + <*> optionalFieldAla "main-is" FilePathNT benchmarkStanzaMainIs + <*> optionalField "benchmark-module" benchmarkStanzaBenchmarkModule + <*> blurFieldGrammar benchmarkStanzaBuildInfo buildInfoFieldGrammar + +validateBenchmark :: Position -> BenchmarkStanza -> ParseResult Benchmark +validateBenchmark pos stanza = case _benchmarkStanzaBenchmarkType stanza of + Nothing -> pure emptyBenchmark + { benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza } + + Just tt@(BenchmarkTypeUnknown _ _) -> pure emptyBenchmark + { benchmarkInterface = BenchmarkUnsupported tt + , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza + } + + Just tt | tt `notElem` knownBenchmarkTypes -> pure emptyBenchmark + { benchmarkInterface = BenchmarkUnsupported tt + , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza + } + + Just tt@(BenchmarkTypeExe ver) -> case _benchmarkStanzaMainIs stanza of + Nothing -> do + parseFailure pos (missingField "main-is" tt) + pure emptyBenchmark + Just file -> do + when (isJust (_benchmarkStanzaBenchmarkModule stanza)) $ + parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt) + pure emptyBenchmark + { benchmarkInterface = BenchmarkExeV10 ver file + , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza + } + + where + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ display tt ++ " benchmark type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ display tt ++ "' benchmark type." + +unvalidateBenchmark :: Benchmark -> BenchmarkStanza +unvalidateBenchmark b = BenchmarkStanza + { _benchmarkStanzaBenchmarkType = ty + , _benchmarkStanzaMainIs = ma + , _benchmarkStanzaBenchmarkModule = mo + , _benchmarkStanzaBuildInfo = benchmarkBuildInfo b + } + where + (ty, ma, mo) = case benchmarkInterface b of + BenchmarkExeV10 ver "" -> (Just $ BenchmarkTypeExe ver, Nothing, Nothing) + BenchmarkExeV10 ver ma' -> (Just $ BenchmarkTypeExe ver, Just ma', Nothing) + _ -> (Nothing, Nothing, Nothing) + +------------------------------------------------------------------------------- +-- Build info +------------------------------------------------------------------------------- + +buildInfoFieldGrammar + :: (FieldGrammar g, Applicative (g BuildInfo)) + => g BuildInfo BuildInfo +buildInfoFieldGrammar = BuildInfo + <$> booleanFieldDef "buildable" L.buildable True + <*> monoidalFieldAla "build-tools" (alaList CommaFSep) L.buildTools + ^^^ deprecatedSince [2,0] "Please use 'build-tool-depends' field" + <*> monoidalFieldAla "build-tool-depends" (alaList CommaFSep) L.buildToolDepends + ^^^ availableSince [2,0] + <*> monoidalFieldAla "cpp-options" (alaList' NoCommaFSep Token') L.cppOptions + <*> monoidalFieldAla "asm-options" (alaList' NoCommaFSep Token') L.asmOptions + <*> monoidalFieldAla "cmm-options" (alaList' NoCommaFSep Token') L.cmmOptions + <*> monoidalFieldAla "cc-options" (alaList' NoCommaFSep Token') L.ccOptions + <*> monoidalFieldAla "cxx-options" (alaList' NoCommaFSep Token') L.cxxOptions + <*> monoidalFieldAla "ld-options" (alaList' NoCommaFSep Token') L.ldOptions + <*> monoidalFieldAla "pkgconfig-depends" (alaList CommaFSep) L.pkgconfigDepends + <*> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks + <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep FilePathNT) L.extraFrameworkDirs + <*> monoidalFieldAla "asm-sources" (alaList' VCat FilePathNT) L.asmSources + <*> monoidalFieldAla "cmm-sources" (alaList' VCat FilePathNT) L.cmmSources + <*> monoidalFieldAla "c-sources" (alaList' VCat FilePathNT) L.cSources + <*> monoidalFieldAla "cxx-sources" (alaList' VCat FilePathNT) L.cxxSources + <*> monoidalFieldAla "js-sources" (alaList' VCat FilePathNT) L.jsSources + <*> hsSourceDirsGrammar + <*> monoidalFieldAla "other-modules" (alaList' VCat MQuoted) L.otherModules + <*> monoidalFieldAla "virtual-modules" (alaList' VCat MQuoted) L.virtualModules + <*> monoidalFieldAla "autogen-modules" (alaList' VCat MQuoted) L.autogenModules + <*> optionalFieldAla "default-language" MQuoted L.defaultLanguage + <*> monoidalFieldAla "other-languages" (alaList' FSep MQuoted) L.otherLanguages + <*> monoidalFieldAla "default-extensions" (alaList' FSep MQuoted) L.defaultExtensions + <*> monoidalFieldAla "other-extensions" (alaList' FSep MQuoted) L.otherExtensions + <*> monoidalFieldAla "extensions" (alaList' FSep MQuoted) L.oldExtensions + ^^^ deprecatedSince [1,12] "Please use 'default-extensions' or 'other-extensions' fields." + <*> monoidalFieldAla "extra-libraries" (alaList' VCat Token) L.extraLibs + <*> monoidalFieldAla "extra-ghci-libraries" (alaList' VCat Token) L.extraGHCiLibs + <*> monoidalFieldAla "extra-bundled-libraries" (alaList' VCat Token) L.extraBundledLibs + <*> monoidalFieldAla "extra-library-flavours" (alaList' VCat Token) L.extraLibFlavours + <*> monoidalFieldAla "extra-lib-dirs" (alaList' FSep FilePathNT) L.extraLibDirs + <*> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs + <*> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes + <*> monoidalFieldAla "install-includes" (alaList' FSep FilePathNT) L.installIncludes + <*> optionsFieldGrammar + <*> profOptionsFieldGrammar + <*> sharedOptionsFieldGrammar + <*> pure [] -- static-options ??? + <*> prefixedFields "x-" L.customFieldsBI + <*> monoidalFieldAla "build-depends" (alaList CommaVCat) L.targetBuildDepends + <*> monoidalFieldAla "mixins" (alaList CommaVCat) L.mixins +{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfo #-} +{-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfo #-} + +hsSourceDirsGrammar + :: (FieldGrammar g, Applicative (g BuildInfo)) + => g BuildInfo [FilePath] +hsSourceDirsGrammar = (++) + <$> monoidalFieldAla "hs-source-dirs" (alaList' FSep FilePathNT) L.hsSourceDirs + <*> monoidalFieldAla "hs-source-dir" (alaList' FSep FilePathNT) L.hsSourceDirs + ^^^ deprecatedField' "Please use 'hs-source-dirs'" + +optionsFieldGrammar + :: (FieldGrammar g, Applicative (g BuildInfo)) + => g BuildInfo [(CompilerFlavor, [String])] +optionsFieldGrammar = combine + <$> monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (extract GHC) + <*> monoidalFieldAla "ghcjs-options" (alaList' NoCommaFSep Token') (extract GHCJS) + <*> monoidalFieldAla "jhc-options" (alaList' NoCommaFSep Token') (extract JHC) + -- NOTE: Hugs and NHC are not supported anymore, but these fields are kept + -- around for backwards compatibility. + <* knownField "hugs-options" + <* knownField "nhc98-options" + where + extract :: CompilerFlavor -> ALens' BuildInfo [String] + extract flavor = L.options . lookupLens flavor + + combine ghc ghcjs jhs = + f GHC ghc ++ f GHCJS ghcjs ++ f JHC jhs + where + f _flavor [] = [] + f flavor opts = [(flavor, opts)] + +profOptionsFieldGrammar + :: (FieldGrammar g, Applicative (g BuildInfo)) + => g BuildInfo [(CompilerFlavor, [String])] +profOptionsFieldGrammar = combine + <$> monoidalFieldAla "ghc-prof-options" (alaList' NoCommaFSep Token') (extract GHC) + <*> monoidalFieldAla "ghcjs-prof-options" (alaList' NoCommaFSep Token') (extract GHCJS) + where + extract :: CompilerFlavor -> ALens' BuildInfo [String] + extract flavor = L.profOptions . lookupLens flavor + + combine ghc ghcjs = f GHC ghc ++ f GHCJS ghcjs + where + f _flavor [] = [] + f flavor opts = [(flavor, opts)] + +sharedOptionsFieldGrammar + :: (FieldGrammar g, Applicative (g BuildInfo)) + => g BuildInfo [(CompilerFlavor, [String])] +sharedOptionsFieldGrammar = combine + <$> monoidalFieldAla "ghc-shared-options" (alaList' NoCommaFSep Token') (extract GHC) + <*> monoidalFieldAla "ghcjs-shared-options" (alaList' NoCommaFSep Token') (extract GHCJS) + where + extract :: CompilerFlavor -> ALens' BuildInfo [String] + extract flavor = L.sharedOptions . lookupLens flavor + + combine ghc ghcjs = f GHC ghc ++ f GHCJS ghcjs + where + f _flavor [] = [] + f flavor opts = [(flavor, opts)] + +lookupLens :: (Functor f, Ord k) => k -> LensLike' f [(k, [v])] [v] +lookupLens k f kvs = str kvs <$> f (gtr kvs) + where + gtr = fromMaybe [] . lookup k + + str [] v = [(k, v)] + str (x@(k',_):xs) v + | k == k' = (k, v) : xs + | otherwise = x : str xs v + +------------------------------------------------------------------------------- +-- Flag +------------------------------------------------------------------------------- + +flagFieldGrammar + :: (FieldGrammar g, Applicative (g Flag)) + => FlagName -> g Flag Flag +flagFieldGrammar name = MkFlag name + <$> optionalFieldDefAla "description" FreeText L.flagDescription "" + <*> booleanFieldDef "default" L.flagDefault True + <*> booleanFieldDef "manual" L.flagManual False +{-# SPECIALIZE flagFieldGrammar :: FlagName -> ParsecFieldGrammar' Flag #-} +{-# SPECIALIZE flagFieldGrammar :: FlagName -> PrettyFieldGrammar' Flag #-} + +------------------------------------------------------------------------------- +-- SourceRepo +------------------------------------------------------------------------------- + +sourceRepoFieldGrammar + :: (FieldGrammar g, Applicative (g SourceRepo)) + => RepoKind -> g SourceRepo SourceRepo +sourceRepoFieldGrammar kind = SourceRepo kind + <$> optionalField "type" L.repoType + <*> optionalFieldAla "location" FreeText L.repoLocation + <*> optionalFieldAla "module" Token L.repoModule + <*> optionalFieldAla "branch" Token L.repoBranch + <*> optionalFieldAla "tag" Token L.repoTag + <*> optionalFieldAla "subdir" FilePathNT L.repoSubdir +{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> ParsecFieldGrammar' SourceRepo #-} +{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind ->PrettyFieldGrammar' SourceRepo #-} + +------------------------------------------------------------------------------- +-- SetupBuildInfo +------------------------------------------------------------------------------- + +setupBInfoFieldGrammar + :: (FieldGrammar g, Functor (g SetupBuildInfo)) + => Bool -> g SetupBuildInfo SetupBuildInfo +setupBInfoFieldGrammar def = flip SetupBuildInfo def + <$> monoidalFieldAla "setup-depends" (alaList CommaVCat) L.setupDepends +{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-} +{-# SPECIALIZE setupBInfoFieldGrammar :: Bool ->PrettyFieldGrammar' SetupBuildInfo #-} diff --git a/cabal/Cabal/Distribution/PackageDescription/Parse.hs b/cabal/Cabal/Distribution/PackageDescription/Parse.hs --- a/cabal/Cabal/Distribution/PackageDescription/Parse.hs +++ b/cabal/Cabal/Distribution/PackageDescription/Parse.hs @@ -19,6 +19,10 @@ module Distribution.PackageDescription.Parse ( -- * Package descriptions + readGenericPackageDescription, + parseGenericPackageDescription, + + -- ** Deprecated names readPackageDescription, parsePackageDescription, @@ -49,13 +53,16 @@ import Prelude () import Distribution.Compat.Prelude +import Distribution.Types.Dependency import Distribution.Types.ForeignLib import Distribution.Types.ForeignLibType +import Distribution.Types.UnqualComponentName +import Distribution.Types.CondTree +import Distribution.Types.PackageId import Distribution.ParseUtils hiding (parseFields) import Distribution.PackageDescription import Distribution.PackageDescription.Utils import Distribution.Package -import Distribution.Package.TextClass () import Distribution.ModuleName import Distribution.Version import Distribution.Verbosity @@ -111,7 +118,7 @@ (\pkg -> case licenseFiles pkg of [_] -> [] xs -> xs) - (\ls pkg -> pkg{licenseFiles=ls}) + (\ls pkg -> pkg{licenseFiles=licenseFiles pkg ++ ls}) , simpleField "copyright" showFreeText parseFreeText copyright (\val pkg -> pkg{copyright=val}) @@ -206,6 +213,12 @@ , listField "options" disp parse foreignLibOptions (\x flib -> flib { foreignLibOptions = x }) + , simpleField "lib-version-info" + (maybe mempty disp) (fmap Just parse) + foreignLibVersionInfo (\x flib -> flib { foreignLibVersionInfo = x }) + , simpleField "lib-version-linux" + (maybe mempty disp) (fmap Just parse) + foreignLibVersionLinux (\x flib -> flib { foreignLibVersionLinux = x }) , listField "mod-def-file" showFilePath parseFilePathQ foreignLibModDefFile (\x flib -> flib { foreignLibModDefFile = x }) @@ -232,6 +245,9 @@ [ simpleField "main-is" showFilePath parseFilePathQ modulePath (\xs exe -> exe{modulePath=xs}) + , simpleField "scope" + disp parse + exeScope (\sc exe -> exe{exeScope=sc}) ] ++ map biToExe binfoFieldDescrs where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) @@ -410,18 +426,30 @@ , commaListField "build-tools" disp parse buildTools (\xs binfo -> binfo{buildTools=xs}) + , commaListField "build-tool-depends" + disp parse + buildToolDepends (\xs binfo -> binfo{buildToolDepends=xs}) , commaListFieldWithSep vcat "build-depends" - disp parse + disp parse targetBuildDepends (\xs binfo -> binfo{targetBuildDepends=xs}) , commaListFieldWithSep vcat "mixins" - disp parse - mixins (\xs binfo -> binfo{mixins=xs}) + disp parse + mixins (\xs binfo -> binfo{mixins=xs}) , spaceListField "cpp-options" showToken parseTokenQ' - cppOptions (\val binfo -> binfo{cppOptions=val}) + cppOptions (\val binfo -> binfo{cppOptions=val}) + , spaceListField "asm-options" + showToken parseTokenQ' + asmOptions (\val binfo -> binfo{asmOptions=val}) + , spaceListField "cmm-options" + showToken parseTokenQ' + cmmOptions (\val binfo -> binfo{cmmOptions=val}) , spaceListField "cc-options" showToken parseTokenQ' ccOptions (\val binfo -> binfo{ccOptions=val}) + , spaceListField "cxx-options" + showToken parseTokenQ' + cxxOptions (\val binfo -> binfo{cxxOptions=val}) , spaceListField "ld-options" showToken parseTokenQ' ldOptions (\val binfo -> binfo{ldOptions=val}) @@ -434,9 +462,18 @@ , listField "extra-framework-dirs" showToken parseFilePathQ extraFrameworkDirs (\val binfo -> binfo{extraFrameworkDirs=val}) + , listFieldWithSep vcat "asm-sources" + showFilePath parseFilePathQ + asmSources (\paths binfo -> binfo{asmSources=paths}) + , listFieldWithSep vcat "cmm-sources" + showFilePath parseFilePathQ + cmmSources (\paths binfo -> binfo{cmmSources=paths}) , listFieldWithSep vcat "c-sources" showFilePath parseFilePathQ cSources (\paths binfo -> binfo{cSources=paths}) + , listFieldWithSep vcat "cxx-sources" + showFilePath parseFilePathQ + cxxSources (\paths binfo -> binfo{cxxSources=paths}) , listFieldWithSep vcat "js-sources" showFilePath parseFilePathQ jsSources (\paths binfo -> binfo{jsSources=paths}) @@ -462,6 +499,12 @@ , listFieldWithSep vcat "extra-ghci-libraries" showToken parseTokenQ extraGHCiLibs (\xs binfo -> binfo{extraGHCiLibs=xs}) + , listFieldWithSep vcat "extra-bundled-libraries" + showToken parseTokenQ + extraBundledLibs (\xs binfo -> binfo{extraBundledLibs=xs}) + , listFieldWithSep vcat "extra-library-flavours" + showToken parseTokenQ + extraLibFlavours (\xs binfo -> binfo{extraLibFlavours=xs}) , listField "extra-lib-dirs" showFilePath parseFilePathQ extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) @@ -480,6 +523,9 @@ , listFieldWithSep vcat "other-modules" disp parseModuleNameQ otherModules (\val binfo -> binfo{otherModules=val}) + , listFieldWithSep vcat "virtual-modules" + disp parseModuleNameQ + virtualModules (\val binfo -> binfo{virtualModules=val}) , listFieldWithSep vcat "autogen-modules" disp parseModuleNameQ autogenModules (\val binfo -> binfo{autogenModules=val}) @@ -567,12 +613,13 @@ -> FilePath -> IO a readAndParseFile withFileContents' parser verbosity fpath = do exists <- doesFileExist fpath - unless exists - (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.") + unless exists $ + die' verbosity $ + "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." withFileContents' fpath $ \str -> case parser str of ParseFailed e -> do let (line, message) = locatedErrorMsg e - dieWithLocation fpath line message + dieWithLocation' verbosity fpath line message ParseOk warnings x -> do traverse_ (warn verbosity . showPWarning fpath) $ reverse warnings return x @@ -581,11 +628,15 @@ readHookedBuildInfo = readAndParseFile withFileContents parseHookedBuildInfo --- |Parse the given package file. readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription -readPackageDescription = - readAndParseFile withUTF8FileContents parsePackageDescription +readPackageDescription = readGenericPackageDescription +{-# DEPRECATED readPackageDescription "Use readGenericPackageDescription, old name is misleading." #-} +-- | Parse the given package file. +readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription +readGenericPackageDescription = + readAndParseFile withUTF8FileContents parseGenericPackageDescription + stanzas :: [Field] -> [[Field]] stanzas [] = [] stanzas (f:fields) = (f:this) : stanzas rest @@ -702,12 +753,16 @@ --FIXME: this should take a ByteString, not a String. We have to be able to -- decode UTF8 and handle the BOM. +parsePackageDescription :: String -> ParseResult GenericPackageDescription +parsePackageDescription = parseGenericPackageDescription +{-# DEPRECATED parsePackageDescription "Use parseGenericPackageDescription, old name is misleading" #-} + -- | Parses the given file into a 'GenericPackageDescription'. -- -- In Cabal 1.2 the syntax for package descriptions was changed to a format -- with sections and possibly indented property descriptions. -parsePackageDescription :: String -> ParseResult GenericPackageDescription -parsePackageDescription file = do +parseGenericPackageDescription :: String -> ParseResult GenericPackageDescription +parseGenericPackageDescription file = do -- This function is quite complex because it needs to be able to parse -- both pre-Cabal-1.2 and post-Cabal-1.2 files. Additionally, it contains @@ -1110,7 +1165,7 @@ [] -> return Nothing es -> do fs <- collectFields parser es return (Just fs) - return (cnd, t', e') + return (CondBranch cnd t' e') processIfs _ = cabalBug "processIfs called with wrong field type" parseLibFields :: [Field] -> PM Library @@ -1174,9 +1229,9 @@ in p acc' || any (goBranch acc') (condTreeComponents ct) -- Both the 'true' and the 'false' block must satisfy the property. - goBranch :: a -> (cond, CondTree v c a, Maybe (CondTree v c a)) -> Bool - goBranch _ (_, _, Nothing) = False - goBranch acc (_, t, Just e) = go acc t && go acc e + goBranch :: a -> CondBranch v c a -> Bool + goBranch _ (CondBranch _ _ Nothing) = False + goBranch acc (CondBranch _ t (Just e)) = go acc t && go acc e -- | Parse a list of fields, given a list of field descriptions, -- a structure to accumulate the parsed fields, and a function diff --git a/cabal/Cabal/Distribution/PackageDescription/Parsec.hs b/cabal/Cabal/Distribution/PackageDescription/Parsec.hs --- a/cabal/Cabal/Distribution/PackageDescription/Parsec.hs +++ b/cabal/Cabal/Distribution/PackageDescription/Parsec.hs @@ -1,9 +1,9 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.PackageDescription.Parsec @@ -19,47 +19,52 @@ -- * Package descriptions readGenericPackageDescription, parseGenericPackageDescription, + parseGenericPackageDescriptionMaybe, -- ** Parsing ParseResult, + runParseResult, -- ** Supplementary build information - -- readHookedBuildInfo, - -- parseHookedBuildInfo, + readHookedBuildInfo, + parseHookedBuildInfo, ) where -import Prelude () -import Distribution.Compat.Prelude -import qualified Data.ByteString as BS -import Data.List (partition) -import qualified Data.Map as Map -import qualified Distribution.Compat.SnocList as SnocList -import Distribution.Package +import Distribution.Compat.Prelude +import Prelude () + +import Control.Monad.State.Strict (StateT, execStateT) +import Control.Monad.Trans.Class (lift) +import qualified Data.ByteString as BS +import Data.List (partition) +import qualified Distribution.Compat.Map.Strict as Map +import Distribution.FieldGrammar import Distribution.PackageDescription -import Distribution.PackageDescription.Parsec.FieldDescr -import Distribution.Parsec.Class (parsec) -import Distribution.Parsec.ConfVar - (parseConditionConfVar) -import Distribution.Parsec.LexerMonad - (LexWarning, toPWarning) +import Distribution.PackageDescription.FieldGrammar +import Distribution.PackageDescription.Quirks (patchQuirks) +import Distribution.Parsec.Class (parsec) +import Distribution.Parsec.Common +import Distribution.Parsec.ConfVar (parseConditionConfVar) +import Distribution.Parsec.Field (FieldName, getName) +import Distribution.Parsec.LexerMonad (LexWarning, toPWarning) import Distribution.Parsec.Parser -import Distribution.Parsec.Types.Common -import Distribution.Parsec.Types.Field (getName) -import Distribution.Parsec.Types.FieldDescr -import Distribution.Parsec.Types.ParseResult -import Distribution.Simple.Utils - (die, fromUTF8BS, warn) -import Distribution.Text (display) +import Distribution.Parsec.ParseResult +import Distribution.Simple.Utils (die', fromUTF8BS, warn) +import Distribution.Text (display) +import Distribution.Types.CondTree import Distribution.Types.ForeignLib -import Distribution.Verbosity (Verbosity) +import Distribution.Types.UnqualComponentName + (UnqualComponentName, mkUnqualComponentName) +import Distribution.Utils.Generic (breakMaybe, unfoldrM) +import Distribution.Verbosity (Verbosity) import Distribution.Version - (LowerBound (..), Version, asVersionIntervals, mkVersion, - orLaterVersion) -import System.Directory - (doesFileExist) -import qualified Text.Parsec as P -import qualified Text.Parsec.Error as P + (LowerBound (..), Version, asVersionIntervals, mkVersion, orLaterVersion) +import System.Directory (doesFileExist) +import Distribution.Compat.Lens +import qualified Distribution.Types.GenericPackageDescription.Lens as L +import qualified Distribution.Types.PackageDescription.Lens as L + -- --------------------------------------------------------------- -- Parsing @@ -76,14 +81,15 @@ -> IO a readAndParseFile parser verbosity fpath = do exists <- doesFileExist fpath - unless exists - (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.") + unless exists $ + die' verbosity $ + "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." bs <- BS.readFile fpath let (warnings, errors, result) = runParseResult (parser bs) traverse_ (warn verbosity . showPWarning fpath) warnings traverse_ (warn verbosity . showPError fpath) errors case result of - Nothing -> die $ "Failing parsing \"" ++ fpath ++ "\"." + Nothing -> die' verbosity $ "Failing parsing \"" ++ fpath ++ "\"." Just x -> return x -- | Parse the given package file. @@ -96,50 +102,29 @@ -- In Cabal 1.2 the syntax for package descriptions was changed to a format -- with sections and possibly indented property descriptions. -- --- TODO: add lex warnings parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription -parseGenericPackageDescription bs = case readFields' bs of - Right (fs, lexWarnings) -> parseGenericPackageDescription' lexWarnings fs +parseGenericPackageDescription bs = case readFields' bs' of + Right (fs, lexWarnings) -> do + when patched $ + parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file" + parseGenericPackageDescription' lexWarnings fs -- TODO: better marshalling of errors - Left perr -> parseFatalFailure (Position 0 0) (show perr) + Left perr -> parseFatalFailure zeroPos (show perr) + where + (patched, bs') = patchQuirks bs -runFieldParser :: FieldParser a -> [FieldLine Position] -> ParseResult a -runFieldParser p ls = runFieldParser' pos p =<< fieldlinesToString pos ls +-- | 'Maybe' variant of 'parseGenericPackageDescription' +parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription +parseGenericPackageDescriptionMaybe = + trdOf3 . runParseResult . parseGenericPackageDescription where - -- TODO: make per line lookup - pos = case ls of - [] -> Position 0 0 - (FieldLine pos' _ : _) -> pos' + trdOf3 (_, _, x) = x fieldlinesToBS :: [FieldLine ann] -> BS.ByteString fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) --- TODO: Take position from FieldLine --- TODO: Take field name -fieldlinesToString :: Position -> [FieldLine ann] -> ParseResult String -fieldlinesToString pos fls = - let str = intercalate "\n" . map (\(FieldLine _ bs') -> fromUTF8BS bs') $ fls - in if '\xfffd' `elem` str - then str <$ parseWarning pos PWTUTF "Invalid UTF8 encoding" - else pure str - -runFieldParser' :: Position -> FieldParser a -> String -> ParseResult a -runFieldParser' (Position row col) p str = case P.runParser p' [] "" str of - Right (pok, ws) -> do - -- TODO: map pos - traverse_ (\(PWarning t pos w) -> parseWarning pos t w) ws - pure pok - Left err -> do - let ppos = P.errorPos err - -- Positions start from 1:1, not 0:0 - let epos = Position (row - 1 + P.sourceLine ppos) (col - 1 + P.sourceColumn ppos) - let msg = P.showErrorMessages - "or" "unknown parse error" "expecting" "unexpected" "end of input" - (P.errorMessages err) - - parseFatalFailure epos $ msg ++ ": " ++ show str - where - p' = (,) <$ P.spaces <*> p <* P.spaces <* P.eof <*> P.getState +-- Monad in which sections are parsed +type SectionParser = StateT GenericPackageDescription ParseResult -- Note [Accumulating parser] -- @@ -151,326 +136,218 @@ -> [Field Position] -> ParseResult GenericPackageDescription parseGenericPackageDescription' lexWarnings fs = do - parseWarnings' (fmap toPWarning lexWarnings) + parseWarnings (fmap toPWarning lexWarnings) let (syntax, fs') = sectionizeFields fs - gpd <- goFields emptyGpd fs' - -- Various post checks - maybeWarnCabalVersion syntax (packageDescription gpd) - checkForUndefinedFlags gpd - -- TODO: do other validations - return gpd - where - -- First fields - goFields - :: GenericPackageDescription - -> [Field Position] - -> ParseResult GenericPackageDescription - goFields gpd [] = pure gpd - goFields gpd (Field (Name pos name) fieldLines : fields) = - case Map.lookup name pdFieldParsers of - -- TODO: can be more elegant - Nothing -> fieldlinesToString pos fieldLines >>= \value -> case storeXFieldsPD name value (packageDescription gpd) of - Nothing -> do - parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name - goFields gpd fields - Just pd -> - goFields (gpd { packageDescription = pd }) fields - Just parser -> do - pd <- runFieldParser (parser $ packageDescription gpd) fieldLines - let gpd' = gpd { packageDescription = pd } - goFields gpd' fields - goFields gpd fields@(Section _ _ _ : _) = goSections gpd fields + -- PackageDescription + let (fields, sectionFields) = takeFields fs' + pd <- parseFieldGrammar fields packageDescriptionFieldGrammar + maybeWarnCabalVersion syntax pd + -- Sections - goSections - :: GenericPackageDescription - -> [Field Position] - -> ParseResult GenericPackageDescription - goSections gpd [] = pure gpd - goSections gpd (Field (Name pos name) _ : fields) = do - parseWarning pos PWTTrailingFields $ "Ignoring trailing fields after sections: " ++ show name - goSections gpd fields - goSections gpd (Section name args secFields : fields) = do - gpd' <- parseSection gpd name args secFields - goSections gpd' fields + let gpd = emptyGpd & L.packageDescription .~ pd + -- elif conditional is accepted if spec version is >= 2.1 + let hasElif = if specVersion pd >= mkVersion [2,1] then HasElif else NoElif + execStateT (goSections hasElif sectionFields) gpd + where emptyGpd :: GenericPackageDescription emptyGpd = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] [] - pdFieldParsers :: Map FieldName (PackageDescription -> FieldParser PackageDescription) - pdFieldParsers = Map.fromList $ - map (\x -> (fieldName x, fieldParser x)) pkgDescrFieldDescrs + newSyntaxVersion :: Version + newSyntaxVersion = mkVersion [1, 2] - parseSection - :: GenericPackageDescription - -> Name Position - -> [SectionArg Position] - -> [Field Position] - -> ParseResult GenericPackageDescription - parseSection gpd (Name pos name) args fields + maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult () + maybeWarnCabalVersion syntax pkg + | syntax == NewSyntax && specVersion pkg < newSyntaxVersion + = parseWarning (Position 0 0) PWTNewSyntax $ + "A package using section syntax must specify at least\n" + ++ "'cabal-version: >= 1.2'." + + maybeWarnCabalVersion syntax pkg + | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion + = parseWarning (Position 0 0) PWTOldSyntax $ + "A package using 'cabal-version: " + ++ displaySpecVersion (specVersionRaw pkg) + ++ "' must use section syntax. See the Cabal user guide for details." + where + displaySpecVersion (Left version) = display version + displaySpecVersion (Right versionRange) = + case asVersionIntervals versionRange of + [] {- impossible -} -> display versionRange + ((LowerBound version _, _):_) -> display (orLaterVersion version) + + maybeWarnCabalVersion _ _ = return () + + -- Sections +goSections :: HasElif -> [Field Position] -> SectionParser () +goSections hasElif = traverse_ process + where + process (Field (Name pos name) _) = + lift $ parseWarning pos PWTTrailingFields $ + "Ignoring trailing fields after sections: " ++ show name + process (Section name args secFields) = + parseSection name args secFields + + snoc x xs = xs ++ [x] + + parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser () + parseSection (Name pos name) args fields | name == "library" && null args = do + lib <- lift $ parseCondTree hasElif (libraryFieldGrammar Nothing) (targetBuildDepends . libBuildInfo) fields -- TODO: check that library is defined once - l <- parseCondTree libFieldDescrs storeXFieldsLib (targetBuildDepends . libBuildInfo) emptyLibrary fields - let gpd' = gpd { condLibrary = Just l } - pure gpd' + L.condLibrary ?= lib -- Sublibraries | name == "library" = do + -- TODO: check cabal-version name' <- parseUnqualComponentName pos args - lib <- parseCondTree libFieldDescrs storeXFieldsLib (targetBuildDepends . libBuildInfo) emptyLibrary fields + lib <- lift $ parseCondTree hasElif (libraryFieldGrammar $ Just name') (targetBuildDepends . libBuildInfo) fields -- TODO check duplicate name here? - let gpd' = gpd { condSubLibraries = condSubLibraries gpd ++ [(name', lib)] } - pure gpd' + L.condSubLibraries %= snoc (name', lib) | name == "foreign-library" = do name' <- parseUnqualComponentName pos args - flib <- parseCondTree foreignLibFieldDescrs storeXFieldsForeignLib (targetBuildDepends . foreignLibBuildInfo) emptyForeignLib fields + flib <- lift $ parseCondTree hasElif (foreignLibFieldGrammar name') (targetBuildDepends . foreignLibBuildInfo) fields -- TODO check duplicate name here? - let gpd' = gpd { condForeignLibs = condForeignLibs gpd ++ [(name', flib)] } - pure gpd' + L.condForeignLibs %= snoc (name', flib) | name == "executable" = do name' <- parseUnqualComponentName pos args - -- Note: we don't parse the "executable" field here, hence the tail hack. Duncan 2010 - exe <- parseCondTree (tail executableFieldDescrs) storeXFieldsExe (targetBuildDepends . buildInfo) emptyExecutable fields + exe <- lift $ parseCondTree hasElif (executableFieldGrammar name') (targetBuildDepends . buildInfo) fields -- TODO check duplicate name here? - let gpd' = gpd { condExecutables = condExecutables gpd ++ [(name', exe)] } - pure gpd' + L.condExecutables %= snoc (name', exe) | name == "test-suite" = do - name' <- parseUnqualComponentName pos args - testStanza <- parseCondTree testSuiteFieldDescrs storeXFieldsTest (targetBuildDepends . testStanzaBuildInfo) emptyTestStanza fields - testSuite <- traverse (validateTestSuite pos) testStanza + name' <- parseUnqualComponentName pos args + testStanza <- lift $ parseCondTree hasElif testSuiteFieldGrammar (targetBuildDepends . _testStanzaBuildInfo) fields + testSuite <- lift $ traverse (validateTestSuite pos) testStanza -- TODO check duplicate name here? - let gpd' = gpd { condTestSuites = condTestSuites gpd ++ [(name', testSuite)] } - pure gpd' + L.condTestSuites %= snoc (name', testSuite) | name == "benchmark" = do - name' <- parseUnqualComponentName pos args - benchStanza <- parseCondTree benchmarkFieldDescrs storeXFieldsBenchmark (targetBuildDepends . benchmarkStanzaBuildInfo) emptyBenchmarkStanza fields - bench <- traverse (validateBenchmark pos) benchStanza + name' <- parseUnqualComponentName pos args + benchStanza <- lift $ parseCondTree hasElif benchmarkFieldGrammar (targetBuildDepends . _benchmarkStanzaBuildInfo) fields + bench <- lift $ traverse (validateBenchmark pos) benchStanza -- TODO check duplicate name here? - let gpd' = gpd { condBenchmarks = condBenchmarks gpd ++ [(name', bench)] } - pure gpd' + L.condBenchmarks %= snoc (name', bench) | name == "flag" = do - name' <- parseName pos args - name'' <- runFieldParser' pos parsec name' `recoverWith` mkFlagName "" - flag <- parseFields flagFieldDescrs warnUnrec (emptyFlag name'') fields + name' <- parseName pos args + name'' <- lift $ runFieldParser' pos parsec name' `recoverWith` mkFlagName "" + flag <- lift $ parseFields fields (flagFieldGrammar name'') -- Check default flag - let gpd' = gpd { genPackageFlags = genPackageFlags gpd ++ [flag] } - pure gpd' + L.genPackageFlags %= snoc flag | name == "custom-setup" && null args = do - sbi <- parseFields setupBInfoFieldDescrs warnUnrec mempty fields - let pd = packageDescription gpd - -- TODO: what if already defined? - let gpd' = gpd { packageDescription = pd { setupBuildInfo = Just sbi } } - pure gpd' + sbi <- lift $ parseFields fields (setupBInfoFieldGrammar False) + L.packageDescription . L.setupBuildInfo ?= sbi | name == "source-repository" = do - kind <- case args of + kind <- lift $ case args of [SecArgName spos secName] -> runFieldParser' spos parsec (fromUTF8BS secName) `recoverWith` RepoHead [] -> do - parseFailure pos $ "'source-repository' needs one argument" + parseFailure pos "'source-repository' requires exactly one argument" pure RepoHead _ -> do parseFailure pos $ "Invalid source-repository kind " ++ show args pure RepoHead - sr <- parseFields sourceRepoFieldDescrs warnUnrec (emptySourceRepo kind) fields - -- I want lens - let pd = packageDescription gpd - let srs = sourceRepos pd - let gpd' = gpd { packageDescription = pd { sourceRepos = srs ++ [sr] } } - pure gpd' - | otherwise = do - parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name - pure gpd - - newSyntaxVersion :: Version - newSyntaxVersion = mkVersion [1, 2] - - maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult () - maybeWarnCabalVersion syntax pkg - | syntax == NewSyntax && specVersion pkg < newSyntaxVersion - = parseWarning (Position 0 0) PWTNewSyntax $ - "A package using section syntax must specify at least\n" - ++ "'cabal-version: >= 1.2'." - - maybeWarnCabalVersion syntax pkg - | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion - = parseWarning (Position 0 0) PWTOldSyntax $ - "A package using 'cabal-version: " - ++ displaySpecVersion (specVersionRaw pkg) - ++ "' must use section syntax. See the Cabal user guide for details." - where - displaySpecVersion (Left version) = display version - displaySpecVersion (Right versionRange) = - case asVersionIntervals versionRange of - [] {- impossible -} -> display versionRange - ((LowerBound version _, _):_) -> display (orLaterVersion version) - - maybeWarnCabalVersion _ _ = return () - -{- - handleFutureVersionParseFailure :: Version -> ParseResult a -> ParseResult GenericPackageDescription - handleFutureVersionParseFailure _cabalVersionNeeded _parseBody = - error "handleFutureVersionParseFailure" --} - - {- - undefined (unless versionOk (warning message) >> parseBody) - `catchParseError` \parseError -> case parseError of - TabsError _ -> parseFail parseError - _ | versionOk -> parseFail parseError - | otherwise -> fail message - where versionOk = cabalVersionNeeded <= cabalVersion - message = "This package requires at least Cabal version " - ++ display cabalVersionNeeded - -} - - checkForUndefinedFlags - :: GenericPackageDescription - -> ParseResult () - checkForUndefinedFlags _gpd = pure () -{- - let definedFlags = map flagName flags - mapM_ (checkCondTreeFlags definedFlags) (maybeToList mlib) - mapM_ (checkCondTreeFlags definedFlags . snd) sub_libs - mapM_ (checkCondTreeFlags definedFlags . snd) exes - mapM_ (checkCondTreeFlags definedFlags . snd) tests + sr <- lift $ parseFields fields (sourceRepoFieldGrammar kind) + L.packageDescription . L.sourceRepos %= snoc sr - checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM () - checkCondTreeFlags definedFlags ct = do - let fv = nub $ freeVars ct - unless (all (`elem` definedFlags) fv) $ - fail $ "These flags are used without having been defined: " - ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] --} + | otherwise = lift $ + parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name -parseName :: Position -> [SectionArg Position] -> ParseResult String +parseName :: Position -> [SectionArg Position] -> SectionParser String parseName pos args = case args of [SecArgName _pos secName] -> pure $ fromUTF8BS secName [SecArgStr _pos secName] -> - pure secName + pure $ fromUTF8BS secName [] -> do - parseFailure pos $ "name required" + lift $ parseFailure pos $ "name required" pure "" _ -> do -- TODO: pretty print args - parseFailure pos $ "Invalid name " ++ show args + lift $ parseFailure pos $ "Invalid name " ++ show args pure "" -parseUnqualComponentName :: Position -> [SectionArg Position] -> ParseResult UnqualComponentName +parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args - --- | Parse a non-recursive list of fields, given a list of field descriptions, --- a structure to accumulate the parsed fields, and a function --- that can decide what to do with fields which don't match any --- of the field descriptions. +-- | Parse a non-recursive list of fields. parseFields - :: forall a. - [FieldDescr a] -- ^ descriptions of fields we know how to parse - -> UnknownFieldParser a -- ^ possibly do something with unrecognized fields - -> a -- ^ accumulator - -> [Field Position] -- ^ fields to be parsed + :: [Field Position] -- ^ fields to be parsed + -> ParsecFieldGrammar' a -> ParseResult a -parseFields descrs _unknown = foldM go - where - go :: a -> Field Position -> ParseResult a - go x (Section (Name pos name) _ _) = do - -- Even we occur a subsection, we can continue parsing - parseFailure pos $ "invalid subsection " ++ show name - return x - go x (Field (Name pos name) fieldLines) = - case Map.lookup name fieldParsers of - Nothing -> do - -- TODO: use 'unknown' - parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name - return x - Just parser -> - runFieldParser (parser x) fieldLines +parseFields fields grammar = do + let (fs0, ss) = partitionFields fields + traverse_ (traverse_ warnInvalidSubsection) ss + parseFieldGrammar fs0 grammar - fieldParsers :: Map FieldName (a -> FieldParser a) - fieldParsers = Map.fromList $ - map (\x -> (fieldName x, fieldParser x)) descrs +warnInvalidSubsection :: Section Position -> ParseResult () +warnInvalidSubsection (MkSection (Name pos name) _ _) = + void (parseFailure pos $ "invalid subsection " ++ show name) -type C c a = (Condition ConfVar, CondTree ConfVar c a, Maybe (CondTree ConfVar c a)) +data HasElif = HasElif | NoElif + deriving (Eq, Show) + parseCondTree :: forall a c. - [FieldDescr a] -- ^ Field descriptions - -> UnknownFieldParser a -- ^ How to parse unknown fields - -> (a -> c) -- ^ Condition extractor - -> a -- ^ Initial value - -> [Field Position] -- ^ Fields to parse + HasElif -- ^ accept @elif@ + -> ParsecFieldGrammar' a -- ^ grammar + -> (a -> c) -- ^ condition extractor + -> [Field Position] -> ParseResult (CondTree ConfVar c a) -parseCondTree descs unknown cond ini = impl +parseCondTree hasElif grammar cond = go where - impl :: [Field Position] -> ParseResult (CondTree ConfVar c a) - impl fields = do - (x, xs) <- goFields (ini, mempty) fields - return $ CondNode x (cond x) (SnocList.runSnocList xs) - - goFields - :: (a, SnocList.SnocList (C c a)) - -> [Field Position] - -> ParseResult (a, SnocList.SnocList (C c a)) - goFields xss [] = return xss - - goFields xxs (Section (Name _pos name) tes con : fields) | name == "if" = do - tes' <- parseConditionConfVar tes - con' <- impl con - -- Jump to 'else' state - goElse tes' con' xxs fields + go fields = do + let (fs, ss) = partitionFields fields + x <- parseFieldGrammar fs grammar + branches <- concat <$> traverse parseIfs ss + return (CondNode x (cond x) branches) -- TODO: branches - goFields xxs (Section (Name pos name) _ _ : fields) = do - -- Even we occur a subsection, we can continue parsing - -- http://hackage.haskell.org/package/constraints-0.1/constraints.cabal + parseIfs :: [Section Position] -> ParseResult [CondBranch ConfVar c a] + parseIfs [] = return [] + parseIfs (MkSection (Name _ name) test fields : sections) | name == "if" = do + test' <- parseConditionConfVar test + fields' <- go fields + -- TODO: else + (elseFields, sections') <- parseElseIfs sections + return (CondBranch test' fields' elseFields : sections') + parseIfs (MkSection (Name pos name) _ _ : sections) = do parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name - goFields xxs fields + parseIfs sections - goFields (x, xs) (Field (Name pos name) fieldLines : fields) = - case Map.lookup name fieldParsers of - Nothing -> fieldlinesToString pos fieldLines >>= \value -> case unknown name value x of - Nothing -> do - parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name - goFields (x, xs) fields - Just x' -> do - goFields (x', xs) fields - Just parser -> do - x' <- runFieldParser (parser x) fieldLines - goFields (x', xs) fields + parseElseIfs + :: [Section Position] + -> ParseResult (Maybe (CondTree ConfVar c a), [CondBranch ConfVar c a]) + parseElseIfs [] = return (Nothing, []) + parseElseIfs (MkSection (Name pos name) args fields : sections) | name == "else" = do + unless (null args) $ + parseFailure pos $ "`else` section has section arguments " ++ show args + elseFields <- go fields + sections' <- parseIfs sections + return (Just elseFields, sections') - -- Try to parse else branch - goElse - :: Condition ConfVar - -> CondTree ConfVar c a - -> (a, SnocList.SnocList (C c a)) - -> [Field Position] - -> ParseResult (a, SnocList.SnocList (C c a)) - goElse tes con (x, xs) (Section (Name pos name) secArgs alt : fields) | name == "else" = do - when (not . null $ secArgs) $ do - parseFailure pos $ "`else` section has section arguments " ++ show secArgs - alt' <- case alt of - [] -> pure Nothing - _ -> Just <$> impl alt - let ieb = (tes, con, alt') - goFields (x, SnocList.snoc xs ieb) fields - goElse tes con (x, xs) fields = do - let ieb = (tes, con, Nothing) - goFields (x, SnocList.snoc xs ieb) fields + parseElseIfs (MkSection (Name _ name) test fields : sections) | hasElif == HasElif, name == "elif" = do + -- TODO: check cabal-version + test' <- parseConditionConfVar test + fields' <- go fields + (elseFields, sections') <- parseElseIfs sections + -- we parse an empty 'Fields', to get empty value for a node + a <- parseFieldGrammar mempty grammar + return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections') - fieldParsers :: Map FieldName (a -> FieldParser a) - fieldParsers = Map.fromList $ - map (\x -> (fieldName x, fieldParser x)) descs + parseElseIfs sections = (,) Nothing <$> parseIfs sections {- Note [Accumulating parser] +Note: Outdated a bit + In there parser, @'FieldDescr' a@ is transformed into @Map FieldName (a -> FieldParser a)@. The weird value is used because we accumulate structure of @a@ by folding over the fields. There are various reasons for that: @@ -493,6 +370,8 @@ -- Old syntax ------------------------------------------------------------------------------- +-- TODO: move to own module + -- | "Sectionize" an old-style Cabal file. A sectionized file has: -- -- * all global fields at the beginning, followed by @@ -554,4 +433,70 @@ deriving (Eq, Show) libFieldNames :: [FieldName] -libFieldNames = map fieldName libFieldDescrs +libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar Nothing) + +------------------------------------------------------------------------------- +-- Suplementary build information +------------------------------------------------------------------------------- + +readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo +readHookedBuildInfo = readAndParseFile parseHookedBuildInfo + +parseHookedBuildInfo :: BS.ByteString -> ParseResult HookedBuildInfo +parseHookedBuildInfo bs = case readFields' bs' of + Right (fs, lexWarnings) -> do + when patched $ + parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file" + parseHookedBuildInfo' lexWarnings fs + -- TODO: better marshalling of errors + Left perr -> parseFatalFailure zeroPos (show perr) + where + (patched, bs') = patchQuirks bs + +parseHookedBuildInfo' + :: [LexWarning] + -> [Field Position] + -> ParseResult HookedBuildInfo +parseHookedBuildInfo' lexWarnings fs = do + parseWarnings (fmap toPWarning lexWarnings) + (mLibFields, exes) <- stanzas fs + mLib <- parseLib mLibFields + biExes <- traverse parseExe exes + return (mLib, biExes) + where + parseLib :: Fields Position -> ParseResult (Maybe BuildInfo) + parseLib fields + | Map.null fields = pure Nothing + | otherwise = Just <$> parseFieldGrammar fields buildInfoFieldGrammar + + parseExe :: (UnqualComponentName, Fields Position) -> ParseResult (UnqualComponentName, BuildInfo) + parseExe (n, fields) = do + bi <- parseFieldGrammar fields buildInfoFieldGrammar + pure (n, bi) + + stanzas :: [Field Position] -> ParseResult (Fields Position, [(UnqualComponentName, Fields Position)]) + stanzas fields = do + let (hdr0, exes0) = breakMaybe isExecutableField fields + hdr <- toFields hdr0 + exes <- unfoldrM (traverse toExe) exes0 + pure (hdr, exes) + + toFields :: [Field Position] -> ParseResult (Fields Position) + toFields fields = do + let (fields', ss) = partitionFields fields + traverse_ (traverse_ warnInvalidSubsection) ss + pure fields' + + toExe + :: ([FieldLine Position], [Field Position]) + -> ParseResult ((UnqualComponentName, Fields Position), Maybe ([FieldLine Position], [Field Position])) + toExe (fss, fields) = do + name <- runFieldParser zeroPos parsec fss + let (hdr0, rest) = breakMaybe isExecutableField fields + hdr <- toFields hdr0 + pure ((name, hdr), rest) + + isExecutableField (Field (Name _ name) fss) + | name == "executable" = Just fss + | otherwise = Nothing + isExecutableField _ = Nothing diff --git a/cabal/Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs b/cabal/Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/PackageDescription/Parsec/FieldDescr.hs +++ /dev/null @@ -1,607 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | 'GenericPackageDescription' Field descriptions -module Distribution.PackageDescription.Parsec.FieldDescr ( - -- * Package description - pkgDescrFieldDescrs, - storeXFieldsPD, - -- * Library - libFieldDescrs, - storeXFieldsLib, - -- * Foreign library - foreignLibFieldDescrs, - storeXFieldsForeignLib, - -- * Executable - executableFieldDescrs, - storeXFieldsExe, - -- * Test suite - TestSuiteStanza (..), - emptyTestStanza, - testSuiteFieldDescrs, - storeXFieldsTest, - validateTestSuite, - -- * Benchmark - BenchmarkStanza (..), - emptyBenchmarkStanza, - benchmarkFieldDescrs, - storeXFieldsBenchmark, - validateBenchmark, - -- * Flag - flagFieldDescrs, - -- * Source repository - sourceRepoFieldDescrs, - -- * Setup build info - setupBInfoFieldDescrs, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import qualified Data.ByteString as BS -import Data.List (dropWhileEnd) -import qualified Distribution.Compat.Parsec as Parsec -import Distribution.Compiler (CompilerFlavor (..)) -import Distribution.ModuleName (ModuleName) -import Distribution.Package -import Distribution.Package.TextClass () -import Distribution.PackageDescription -import Distribution.Types.ForeignLib -import Distribution.Parsec.Class -import Distribution.Parsec.Types.Common -import Distribution.Parsec.Types.FieldDescr -import Distribution.Parsec.Types.ParseResult -import Distribution.PrettyUtils -import Distribution.Simple.Utils (fromUTF8BS) -import Distribution.Text (disp, display) -import Text.PrettyPrint (vcat) - -------------------------------------------------------------------------------- --- common FieldParsers -------------------------------------------------------------------------------- - --- | This is /almost/ @'many' 'Distribution.Compat.Parsec.anyChar'@, but it --- --- * trims whitespace from ends of the lines, --- --- * converts lines with only single dot into empty line. --- -freeTextFieldParser :: FieldParser String -freeTextFieldParser = dropDotLines <$ Parsec.spaces <*> many Parsec.anyChar - where - -- Example package with dot lines - -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal - dropDotLines "." = "." - dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x - dotToEmpty x | trim' x == "." = "" - dotToEmpty x = trim x - - trim' = dropWhileEnd (`elem` (" \t" :: String)) - -------------------------------------------------------------------------------- --- PackageDescription -------------------------------------------------------------------------------- - --- TODO: other-files isn't used in any cabal file on Hackage. -pkgDescrFieldDescrs :: [FieldDescr PackageDescription] -pkgDescrFieldDescrs = - [ simpleField "name" - disp parsec - packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) - , simpleField "version" - disp parsec - packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) - , simpleField "cabal-version" - (either disp disp) (Left <$> parsec <|> Right <$> parsec) - specVersionRaw (\v pkg -> pkg{specVersionRaw=v}) - , simpleField "build-type" - (maybe mempty disp) (Just <$> parsec) - buildType (\t pkg -> pkg{buildType=t}) - , simpleField "license" - disp (parsecMaybeQuoted parsec) - license (\l pkg -> pkg{license=l}) - , simpleField "license-file" - showFilePath parsecFilePath - (\pkg -> case licenseFiles pkg of - [x] -> x - _ -> "") - (\l pkg -> pkg{licenseFiles=licenseFiles pkg ++ [l]}) - -- We have both 'license-file' and 'license-files' fields. - -- Rather than declaring license-file to be deprecated, we will continue - -- to allow both. The 'license-file' will continue to only allow single - -- tokens, while 'license-files' allows multiple. On pretty-printing, we - -- will use 'license-file' if there's just one, and use 'license-files' - -- otherwise. - , listField "license-files" - showFilePath parsecFilePath - (\pkg -> case licenseFiles pkg of - [_] -> [] - xs -> xs) - (\ls pkg -> pkg{licenseFiles=ls}) - , simpleField "copyright" - showFreeText freeTextFieldParser - copyright (\val pkg -> pkg{copyright=val}) - , simpleField "maintainer" - showFreeText freeTextFieldParser - maintainer (\val pkg -> pkg{maintainer=val}) - , simpleField "stability" - showFreeText freeTextFieldParser - stability (\val pkg -> pkg{stability=val}) - , simpleField "homepage" - showFreeText freeTextFieldParser - homepage (\val pkg -> pkg{homepage=val}) - , simpleField "package-url" - showFreeText freeTextFieldParser - pkgUrl (\val pkg -> pkg{pkgUrl=val}) - , simpleField "bug-reports" - showFreeText freeTextFieldParser - bugReports (\val pkg -> pkg{bugReports=val}) - , simpleField "synopsis" - showFreeText freeTextFieldParser - synopsis (\val pkg -> pkg{synopsis=val}) - , simpleField "description" - showFreeText freeTextFieldParser - description (\val pkg -> pkg{description=val}) - , simpleField "category" - showFreeText freeTextFieldParser - category (\val pkg -> pkg{category=val}) - , simpleField "author" - showFreeText freeTextFieldParser - author (\val pkg -> pkg{author=val}) - , listField "tested-with" - showTestedWith parsecTestedWith - testedWith (\val pkg -> pkg{testedWith=val}) - , listFieldWithSep vcat "data-files" - showFilePath parsecFilePath - dataFiles (\val pkg -> pkg{dataFiles=val}) - , simpleField "data-dir" - showFilePath parsecFilePath - dataDir (\val pkg -> pkg{dataDir=val}) - , listFieldWithSep vcat "extra-source-files" - showFilePath parsecFilePath - extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val}) - , listFieldWithSep vcat "extra-tmp-files" - showFilePath parsecFilePath - extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val}) - , listFieldWithSep vcat "extra-doc-files" - showFilePath parsecFilePath - extraDocFiles (\val pkg -> pkg{extraDocFiles=val}) - ] - --- | Store any fields beginning with "x-" in the customFields field of --- a PackageDescription. All other fields will generate a warning. -storeXFieldsPD :: UnknownFieldParser PackageDescription -storeXFieldsPD f val pkg | beginsWithX f = - Just pkg { customFieldsPD = customFieldsPD pkg ++ [(fromUTF8BS f, trim val)] } -storeXFieldsPD _ _ _ = Nothing - -------------------------------------------------------------------------------- --- Library -------------------------------------------------------------------------------- - -libFieldDescrs :: [FieldDescr Library] -libFieldDescrs = - [ listFieldWithSep vcat "exposed-modules" disp (parsecMaybeQuoted parsec) - exposedModules (\mods lib -> lib{exposedModules=mods}) - , commaListFieldWithSep vcat "reexported-modules" disp parsec - reexportedModules (\mods lib -> lib{reexportedModules=mods}) - - , listFieldWithSep vcat "signatures" disp (parsecMaybeQuoted parsec) - signatures (\mods lib -> lib{signatures=mods}) - - , boolField "exposed" - libExposed (\val lib -> lib{libExposed=val}) - ] ++ map biToLib binfoFieldDescrs - where - biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi}) - -storeXFieldsLib :: UnknownFieldParser Library -storeXFieldsLib f val l@Library { libBuildInfo = bi } | beginsWithX f = - Just $ l {libBuildInfo = - bi{ customFieldsBI = customFieldsBI bi ++ [(fromUTF8BS f, trim val)]}} -storeXFieldsLib _ _ _ = Nothing - -------------------------------------------------------------------------------- --- Foreign library -------------------------------------------------------------------------------- - -foreignLibFieldDescrs :: [FieldDescr ForeignLib] -foreignLibFieldDescrs = - [ simpleField "type" - disp parsec - foreignLibType (\x flib -> flib { foreignLibType = x }) - , listField "options" - disp parsec - foreignLibOptions (\x flib -> flib { foreignLibOptions = x }) - , listField "mod-def-file" - showFilePath parsecFilePath - foreignLibModDefFile (\x flib -> flib { foreignLibModDefFile = x }) - ] ++ map biToFLib binfoFieldDescrs - where - biToFLib = liftField foreignLibBuildInfo (\bi flib -> flib{foreignLibBuildInfo=bi}) - -storeXFieldsForeignLib :: UnknownFieldParser ForeignLib -storeXFieldsForeignLib f val l@ForeignLib { foreignLibBuildInfo = bi } | beginsWithX f = - Just $ l {foreignLibBuildInfo = - bi{ customFieldsBI = customFieldsBI bi ++ [(fromUTF8BS f, trim val)]}} -storeXFieldsForeignLib _ _ _ = Nothing - -------------------------------------------------------------------------------- --- Executable -------------------------------------------------------------------------------- - -executableFieldDescrs :: [FieldDescr Executable] -executableFieldDescrs = - [ -- note ordering: configuration must come first, for - -- showPackageDescription. - simpleField "executable" - disp parsec - exeName (\xs exe -> exe{exeName=xs}) - , simpleField "main-is" - showFilePath parsecFilePath - modulePath (\xs exe -> exe{modulePath=xs}) - ] - ++ map biToExe binfoFieldDescrs - where - biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) - -storeXFieldsExe :: UnknownFieldParser Executable -storeXFieldsExe f val e@Executable { buildInfo = bi } | beginsWithX f = - Just $ e {buildInfo = bi{ customFieldsBI = (fromUTF8BS f, trim val) : customFieldsBI bi}} -storeXFieldsExe _ _ _ = Nothing - -------------------------------------------------------------------------------- --- TestSuite -------------------------------------------------------------------------------- - --- | An intermediate type just used for parsing the test-suite stanza. --- After validation it is converted into the proper 'TestSuite' type. -data TestSuiteStanza = TestSuiteStanza - { testStanzaTestType :: Maybe TestType - , testStanzaMainIs :: Maybe FilePath - , testStanzaTestModule :: Maybe ModuleName - , testStanzaBuildInfo :: BuildInfo - } - -emptyTestStanza :: TestSuiteStanza -emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty - -testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza] -testSuiteFieldDescrs = - [ simpleField "type" - (maybe mempty disp) (Just <$> parsec) - testStanzaTestType (\x suite -> suite { testStanzaTestType = x }) - , simpleField "main-is" - (maybe mempty showFilePath) (Just <$> parsecFilePath) - testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x }) - , simpleField "test-module" - (maybe mempty disp) (Just <$> parsecMaybeQuoted parsec) - testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x }) - ] - ++ map biToTest binfoFieldDescrs - where - biToTest = liftField - testStanzaBuildInfo - (\bi suite -> suite { testStanzaBuildInfo = bi }) - -storeXFieldsTest :: UnknownFieldParser TestSuiteStanza -storeXFieldsTest f val t@TestSuiteStanza { testStanzaBuildInfo = bi } - | beginsWithX f = - Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (fromUTF8BS f,val):customFieldsBI bi}} -storeXFieldsTest _ _ _ = Nothing - -validateTestSuite :: Position -> TestSuiteStanza -> ParseResult TestSuite -validateTestSuite pos stanza = case testStanzaTestType stanza of - Nothing -> return $ - emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza } - - Just tt@(TestTypeUnknown _ _) -> - pure emptyTestSuite - { testInterface = TestSuiteUnsupported tt - , testBuildInfo = testStanzaBuildInfo stanza - } - - Just tt | tt `notElem` knownTestTypes -> - pure emptyTestSuite - { testInterface = TestSuiteUnsupported tt - , testBuildInfo = testStanzaBuildInfo stanza - } - - Just tt@(TestTypeExe ver) -> case testStanzaMainIs stanza of - Nothing -> do - parseFailure pos (missingField "main-is" tt) - pure emptyTestSuite - Just file -> do - when (isJust (testStanzaTestModule stanza)) $ - parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt) - pure emptyTestSuite - { testInterface = TestSuiteExeV10 ver file - , testBuildInfo = testStanzaBuildInfo stanza - } - - Just tt@(TestTypeLib ver) -> case testStanzaTestModule stanza of - Nothing -> do - parseFailure pos (missingField "test-module" tt) - pure emptyTestSuite - Just module_ -> do - when (isJust (testStanzaMainIs stanza)) $ - parseWarning pos PWTExtraMainIs (extraField "main-is" tt) - pure emptyTestSuite - { testInterface = TestSuiteLibV09 ver module_ - , testBuildInfo = testStanzaBuildInfo stanza - } - - where - missingField name tt = "The '" ++ name ++ "' field is required for the " - ++ display tt ++ " test suite type." - - extraField name tt = "The '" ++ name ++ "' field is not used for the '" - ++ display tt ++ "' test suite type." - -------------------------------------------------------------------------------- --- Benchmark -------------------------------------------------------------------------------- - --- | An intermediate type just used for parsing the benchmark stanza. --- After validation it is converted into the proper 'Benchmark' type. -data BenchmarkStanza = BenchmarkStanza - { benchmarkStanzaBenchmarkType :: Maybe BenchmarkType - , benchmarkStanzaMainIs :: Maybe FilePath - , benchmarkStanzaBenchmarkModule :: Maybe ModuleName - , benchmarkStanzaBuildInfo :: BuildInfo - } - -emptyBenchmarkStanza :: BenchmarkStanza -emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty - -benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza] -benchmarkFieldDescrs = - [ simpleField "type" - (maybe mempty disp) (Just <$> parsec) - benchmarkStanzaBenchmarkType - (\x suite -> suite { benchmarkStanzaBenchmarkType = x }) - , simpleField "main-is" - (maybe mempty showFilePath) (Just <$> parsecFilePath) - benchmarkStanzaMainIs - (\x suite -> suite { benchmarkStanzaMainIs = x }) - ] - ++ map biToBenchmark binfoFieldDescrs - where - biToBenchmark = liftField benchmarkStanzaBuildInfo - (\bi suite -> suite { benchmarkStanzaBuildInfo = bi }) - -storeXFieldsBenchmark :: UnknownFieldParser BenchmarkStanza -storeXFieldsBenchmark f val t@BenchmarkStanza { benchmarkStanzaBuildInfo = bi } | beginsWithX f = - Just $ t {benchmarkStanzaBuildInfo = - bi{ customFieldsBI = (fromUTF8BS f, trim val):customFieldsBI bi}} -storeXFieldsBenchmark _ _ _ = Nothing - -validateBenchmark :: Position -> BenchmarkStanza -> ParseResult Benchmark -validateBenchmark pos stanza = case benchmarkStanzaBenchmarkType stanza of - Nothing -> pure emptyBenchmark - { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza } - - Just tt@(BenchmarkTypeUnknown _ _) -> pure emptyBenchmark - { benchmarkInterface = BenchmarkUnsupported tt - , benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza - } - - Just tt | tt `notElem` knownBenchmarkTypes -> pure emptyBenchmark - { benchmarkInterface = BenchmarkUnsupported tt - , benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza - } - - Just tt@(BenchmarkTypeExe ver) -> case benchmarkStanzaMainIs stanza of - Nothing -> do - parseFailure pos (missingField "main-is" tt) - pure emptyBenchmark - Just file -> do - when (isJust (benchmarkStanzaBenchmarkModule stanza)) $ - parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt) - pure emptyBenchmark - { benchmarkInterface = BenchmarkExeV10 ver file - , benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza - } - - where - missingField name tt = "The '" ++ name ++ "' field is required for the " - ++ display tt ++ " benchmark type." - - extraField name tt = "The '" ++ name ++ "' field is not used for the '" - ++ display tt ++ "' benchmark type." - -------------------------------------------------------------------------------- --- BuildInfo -------------------------------------------------------------------------------- - -binfoFieldDescrs :: [FieldDescr BuildInfo] -binfoFieldDescrs = - [ boolField "buildable" - buildable (\val binfo -> binfo{buildable=val}) - , commaListField "build-tools" - disp parsec - buildTools (\xs binfo -> binfo{buildTools=xs}) - , commaListFieldWithSep vcat "build-depends" - disp parsec - targetBuildDepends (\xs binfo -> binfo{targetBuildDepends=xs}) - , commaListFieldWithSep vcat "mixins" - disp parsec - mixins (\xs binfo -> binfo{mixins=xs}) - , spaceListField "cpp-options" - showToken parsecToken' - cppOptions (\val binfo -> binfo{cppOptions=val}) - , spaceListField "cc-options" - showToken parsecToken' - ccOptions (\val binfo -> binfo{ccOptions=val}) - , spaceListField "ld-options" - showToken parsecToken' - ldOptions (\val binfo -> binfo{ldOptions=val}) - , commaListField "pkgconfig-depends" - disp parsec - pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs}) - , listField "frameworks" - showToken parsecToken - frameworks (\val binfo -> binfo{frameworks=val}) - , listField "extra-framework-dirs" - showToken parsecFilePath - extraFrameworkDirs (\val binfo -> binfo{extraFrameworkDirs=val}) - , listFieldWithSep vcat "c-sources" - showFilePath parsecFilePath - cSources (\paths binfo -> binfo{cSources=paths}) - , listFieldWithSep vcat "js-sources" - showFilePath parsecFilePath - jsSources (\paths binfo -> binfo{jsSources=paths}) - , simpleField "default-language" - (maybe mempty disp) (Parsec.optionMaybe $ parsecMaybeQuoted parsec) - defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang}) - , listField "other-languages" - disp (parsecMaybeQuoted parsec) - otherLanguages (\langs binfo -> binfo{otherLanguages=langs}) - , listField "default-extensions" - disp (parsecMaybeQuoted parsec) - defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts}) - , listField "other-extensions" - disp (parsecMaybeQuoted parsec) - otherExtensions (\exts binfo -> binfo{otherExtensions=exts}) - , listField "extensions" - -- TODO: this is deprecated field, isn't it? - disp (parsecMaybeQuoted parsec) - oldExtensions (\exts binfo -> binfo{oldExtensions=exts}) - , listFieldWithSep vcat "extra-libraries" - showToken parsecToken - extraLibs (\xs binfo -> binfo{extraLibs=xs}) - , listFieldWithSep vcat "extra-ghci-libraries" - showToken parsecToken - extraGHCiLibs (\xs binfo -> binfo{extraGHCiLibs=xs}) - , listField "extra-lib-dirs" - showFilePath parsecFilePath - extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) - , listFieldWithSep vcat "includes" - showFilePath parsecFilePath - includes (\paths binfo -> binfo{includes=paths}) - , listFieldWithSep vcat "install-includes" - showFilePath parsecFilePath - installIncludes (\paths binfo -> binfo{installIncludes=paths}) - , listField "include-dirs" - showFilePath parsecFilePath - includeDirs (\paths binfo -> binfo{includeDirs=paths}) - , listField "hs-source-dirs" - showFilePath parsecFilePath - hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths}) - , deprecatedField "hs-source-dirs" $ listField "hs-source-dir" - showFilePath parsecFilePath - (const []) (\paths binfo -> binfo{hsSourceDirs=paths}) - , listFieldWithSep vcat "other-modules" - disp (parsecMaybeQuoted parsec) - otherModules (\val binfo -> binfo{otherModules=val}) - , listFieldWithSep vcat "autogen-modules" - disp (parsecMaybeQuoted parsec) - autogenModules (\val binfo -> binfo{autogenModules=val}) - , optsField "ghc-prof-options" GHC - profOptions (\val binfo -> binfo{profOptions=val}) - , optsField "ghcjs-prof-options" GHCJS - profOptions (\val binfo -> binfo{profOptions=val}) - , optsField "ghc-shared-options" GHC - sharedOptions (\val binfo -> binfo{sharedOptions=val}) - , optsField "ghcjs-shared-options" GHCJS - sharedOptions (\val binfo -> binfo{sharedOptions=val}) - , optsField "ghc-options" GHC - options (\path binfo -> binfo{options=path}) - , optsField "ghcjs-options" GHCJS - options (\path binfo -> binfo{options=path}) - , optsField "jhc-options" JHC - options (\path binfo -> binfo{options=path}) - -- NOTE: Hugs and NHC are not supported anymore, but these fields are kept - -- around for backwards compatibility. - -- - -- TODO: deprecate? - , optsField "hugs-options" Hugs - options (const id) - , optsField "nhc98-options" NHC - options (const id) - ] - -{- -storeXFieldsBI :: UnknownFieldParser BuildInfo ---storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):customFieldsBI bi } -storeXFieldsBI _ _ = Nothing --} - -------------------------------------------------------------------------------- --- Flag -------------------------------------------------------------------------------- - -flagFieldDescrs :: [FieldDescr Flag] -flagFieldDescrs = - [ simpleField "description" - showFreeText freeTextFieldParser - flagDescription (\val fl -> fl{ flagDescription = val }) - , boolField "default" - flagDefault (\val fl -> fl{ flagDefault = val }) - , boolField "manual" - flagManual (\val fl -> fl{ flagManual = val }) - ] - -------------------------------------------------------------------------------- --- SourceRepo -------------------------------------------------------------------------------- - -sourceRepoFieldDescrs :: [FieldDescr SourceRepo] -sourceRepoFieldDescrs = - [ simpleField "type" - (maybe mempty disp) (Just <$> parsec) - repoType (\val repo -> repo { repoType = val }) - , simpleField "location" - (maybe mempty showFreeText) (Just <$> freeTextFieldParser) - repoLocation (\val repo -> repo { repoLocation = val }) - , simpleField "module" - (maybe mempty showToken) (Just <$> parsecToken) - repoModule (\val repo -> repo { repoModule = val }) - , simpleField "branch" - (maybe mempty showToken) (Just <$> parsecToken) - repoBranch (\val repo -> repo { repoBranch = val }) - , simpleField "tag" - (maybe mempty showToken) (Just <$> parsecToken) - repoTag (\val repo -> repo { repoTag = val }) - , simpleField "subdir" - (maybe mempty showFilePath) (Just <$> parsecFilePath) - repoSubdir (\val repo -> repo { repoSubdir = val }) - ] - -------------------------------------------------------------------------------- --- SetupBuildInfo -------------------------------------------------------------------------------- - -setupBInfoFieldDescrs :: [FieldDescr SetupBuildInfo] -setupBInfoFieldDescrs = - [ commaListFieldWithSep vcat "setup-depends" - disp parsec - setupDepends (\xs binfo -> binfo{setupDepends=xs}) - ] - - -------------------------------------------------------------------------------- --- Utilities -------------------------------------------------------------------------------- - --- | Predicate to test field names beginning with "x-" -beginsWithX :: FieldName -> Bool -beginsWithX bs = BS.take 2 bs == "x-" - --- | Mark the field as deprecated. -deprecatedField - :: FieldName -- ^ alternative field - -> FieldDescr a - -> FieldDescr a -deprecatedField newFieldName fd = FieldDescr - { fieldName = oldFieldName - , fieldPretty = const mempty -- we don't print deprecated field - , fieldParser = \x -> do - parsecWarning PWTDeprecatedField $ - "The field " <> show oldFieldName <> - " is deprecated, please use " <> show newFieldName - fieldParser fd x - } - where - oldFieldName = fieldName fd - --- Used to trim x-fields -trim :: String -> String -trim = dropWhile isSpace . dropWhileEnd isSpace 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 @@ -29,26 +29,31 @@ import Prelude () import Distribution.Compat.Prelude -import Distribution.Types.ForeignLib +import Distribution.Types.Dependency +import Distribution.Types.ForeignLib (ForeignLib (foreignLibName)) +import Distribution.Types.UnqualComponentName +import Distribution.Types.CondTree import Distribution.PackageDescription import Distribution.Simple.Utils import Distribution.ParseUtils -import Distribution.PackageDescription.Parse -import Distribution.Package import Distribution.Text -import Distribution.ModuleName +import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar) +import Distribution.PackageDescription.FieldGrammar + (packageDescriptionFieldGrammar, buildInfoFieldGrammar, + flagFieldGrammar, foreignLibFieldGrammar, libraryFieldGrammar, + benchmarkFieldGrammar, testSuiteFieldGrammar, + setupBInfoFieldGrammar, sourceRepoFieldGrammar, executableFieldGrammar) + +import qualified Distribution.PackageDescription.FieldGrammar as FG + import Text.PrettyPrint - (hsep, space, parens, char, nest, isEmpty, ($$), (<+>), - colon, text, vcat, ($+$), Doc, render) + (hsep, space, parens, char, nest, ($$), (<+>), + text, vcat, ($+$), Doc, render) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 --- | Recompile with false for regression testing -simplifiedPrinting :: Bool -simplifiedPrinting = False - -- | Writes a .cabal file from a generic package description writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> NoCallStackIO () writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) @@ -60,157 +65,113 @@ ppGenericPackageDescription :: GenericPackageDescription -> Doc ppGenericPackageDescription gpd = ppPackageDescription (packageDescription gpd) + $+$ ppSetupBInfo (setupBuildInfo (packageDescription gpd)) $+$ ppGenPackageFlags (genPackageFlags gpd) $+$ ppCondLibrary (condLibrary gpd) $+$ ppCondSubLibraries (condSubLibraries gpd) + $+$ ppCondForeignLibs (condForeignLibs gpd) $+$ ppCondExecutables (condExecutables gpd) $+$ ppCondTestSuites (condTestSuites gpd) $+$ ppCondBenchmarks (condBenchmarks gpd) ppPackageDescription :: PackageDescription -> Doc -ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd - $+$ ppCustomFields (customFieldsPD pd) - $+$ ppSourceRepos (sourceRepos pd) +ppPackageDescription pd = + prettyFieldGrammar packageDescriptionFieldGrammar pd + $+$ ppSourceRepos (sourceRepos pd) ppSourceRepos :: [SourceRepo] -> Doc ppSourceRepos [] = mempty ppSourceRepos (hd:tl) = ppSourceRepo hd $+$ ppSourceRepos tl ppSourceRepo :: SourceRepo -> Doc -ppSourceRepo repo = - emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$ - (nest indentWith (ppFields sourceRepoFieldDescrs' repo)) - where - sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"] - --- TODO: this is a temporary hack. Ideally, fields containing default values --- would be filtered out when the @FieldDescr a@ list is generated. -ppFieldsFiltered :: [(String, String)] -> [FieldDescr a] -> a -> Doc -ppFieldsFiltered removable fields x = ppFields (filter nondefault fields) x +ppSourceRepo repo = + emptyLine $ text "source-repository" <+> disp kind $+$ + nest indentWith (prettyFieldGrammar (sourceRepoFieldGrammar kind) repo) where - nondefault (FieldDescr name getter _) = - maybe True (render (getter x) /=) (lookup name removable) - -binfoDefaults :: [(String, String)] -binfoDefaults = [("buildable", "True")] - -libDefaults :: [(String, String)] -libDefaults = ("exposed", "True") : binfoDefaults - -flagDefaults :: [(String, String)] -flagDefaults = [("default", "True"), ("manual", "False")] - -ppDiffFields :: [FieldDescr a] -> a -> a -> Doc -ppDiffFields fields x y = - vcat [ ppField name (getter x) - | FieldDescr name getter _ <- fields - , render (getter x) /= render (getter y) - ] - -ppCustomFields :: [(String,String)] -> Doc -ppCustomFields flds = vcat [ppCustomField f | f <- flds] + kind = repoKind repo -ppCustomField :: (String,String) -> Doc -ppCustomField (name,val) = text name <<>> colon <+> showFreeText val +ppSetupBInfo :: Maybe SetupBuildInfo -> Doc +ppSetupBInfo Nothing = mempty +ppSetupBInfo (Just sbi) + | defaultSetupDepends sbi = mempty + | otherwise = + emptyLine $ text "custom-setup" $+$ + nest indentWith (prettyFieldGrammar (setupBInfoFieldGrammar False) sbi) ppGenPackageFlags :: [Flag] -> Doc -ppGenPackageFlags flds = vcat [ppFlag f | f <- flds] +ppGenPackageFlags flds = vcat [ppFlag f | f <- flds] ppFlag :: Flag -> Doc -ppFlag flag@(MkFlag name _ _ _) = - emptyLine $ text "flag" <+> ppFlagName name $+$ nest indentWith fields +ppFlag flag@(MkFlag name _ _ _) = + emptyLine $ text "flag" <+> ppFlagName name $+$ + nest indentWith (prettyFieldGrammar (flagFieldGrammar name) flag) + +ppCondTree2 :: PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> Doc +ppCondTree2 grammar = go where - fields = ppFieldsFiltered flagDefaults flagFieldDescrs flag + -- TODO: recognise elif opportunities + go (CondNode it _ ifs) = + prettyFieldGrammar grammar it + $+$ vcat (map ppIf ifs) + ppIf (CondBranch c thenTree Nothing) +-- | isEmpty thenDoc = mempty + | otherwise = ppIfCondition c $$ nest indentWith thenDoc + where + 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 $$ nest indentWith thenDoc + (True, False) -> ppIfCondition (cNot c) $$ nest indentWith elseDoc + (False, False) -> (ppIfCondition c $$ nest indentWith thenDoc) + $+$ (text "else" $$ nest indentWith elseDoc) + where + thenDoc = go thenTree + elseDoc = go elseTree + ppCondLibrary :: Maybe (CondTree ConfVar [Dependency] Library) -> Doc ppCondLibrary Nothing = mempty ppCondLibrary (Just condTree) = - emptyLine $ text "library" - $+$ nest indentWith (ppCondTree condTree Nothing ppLib) + emptyLine $ text "library" $+$ + nest indentWith (ppCondTree2 (libraryFieldGrammar Nothing) condTree) + ppCondSubLibraries :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> Doc -ppCondSubLibraries libs = - vcat [emptyLine $ (text "library " <+> disp n) - $+$ nest indentWith (ppCondTree condTree Nothing ppLib)| (n,condTree) <- libs] +ppCondSubLibraries libs = vcat + [ emptyLine $ (text "library" <+> disp n) $+$ + nest indentWith (ppCondTree2 (libraryFieldGrammar $ Just n) condTree) + | (n, condTree) <- libs + ] -ppLib :: Library -> Maybe Library -> Doc -ppLib lib Nothing = ppFieldsFiltered libDefaults libFieldDescrs lib - $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) -ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib - $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) +ppCondForeignLibs :: [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> Doc +ppCondForeignLibs flibs = vcat + [ emptyLine $ (text "foreign-library" <+> disp n) $+$ + nest indentWith (ppCondTree2 (foreignLibFieldGrammar n) condTree) + | (n, condTree) <- flibs + ] ppCondExecutables :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> Doc -ppCondExecutables exes = - vcat [emptyLine $ (text "executable " <+> disp n) - $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes] - where - ppExe (Executable _ modulePath' buildInfo') Nothing = - (if modulePath' == "" then mempty else text "main-is:" <+> text modulePath') - $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs buildInfo' - $+$ ppCustomFields (customFieldsBI buildInfo') - ppExe (Executable _ modulePath' buildInfo') - (Just (Executable _ modulePath2 buildInfo2)) = - (if modulePath' == "" || modulePath' == modulePath2 - then mempty else text "main-is:" <+> text modulePath') - $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 - $+$ ppCustomFields (customFieldsBI buildInfo') +ppCondExecutables exes = vcat + [ emptyLine $ (text "executable" <+> disp n) $+$ + nest indentWith (ppCondTree2 (executableFieldGrammar n) condTree) + | (n, condTree) <- exes + ] ppCondTestSuites :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> Doc -ppCondTestSuites suites = - emptyLine $ vcat [ (text "test-suite " <+> disp n) - $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite) - | (n,condTree) <- suites] - where - ppTestSuite testsuite Nothing = - maybe mempty (\t -> text "type:" <+> disp t) - maybeTestType - $+$ maybe mempty (\f -> text "main-is:" <+> text f) - (testSuiteMainIs testsuite) - $+$ maybe mempty (\m -> text "test-module:" <+> disp m) - (testSuiteModule testsuite) - $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (testBuildInfo testsuite) - $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite)) - where - maybeTestType | testInterface testsuite == mempty = Nothing - | otherwise = Just (testType testsuite) - - ppTestSuite test' (Just test2) = - ppDiffFields binfoFieldDescrs - (testBuildInfo test') (testBuildInfo test2) - $+$ ppCustomFields (customFieldsBI (testBuildInfo test')) - - testSuiteMainIs test = case testInterface test of - TestSuiteExeV10 _ f -> Just f - _ -> Nothing - - testSuiteModule test = case testInterface test of - TestSuiteLibV09 _ m -> Just m - _ -> Nothing +ppCondTestSuites suites = vcat + [ emptyLine $ (text "test-suite" <+> disp n) $+$ + nest indentWith (ppCondTree2 testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree)) + | (n, condTree) <- suites + ] ppCondBenchmarks :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> Doc -ppCondBenchmarks suites = - emptyLine $ vcat [ (text "benchmark " <+> disp n) - $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark) - | (n,condTree) <- suites] - where - ppBenchmark benchmark Nothing = - maybe mempty (\t -> text "type:" <+> disp t) - maybeBenchmarkType - $+$ maybe mempty (\f -> text "main-is:" <+> text f) - (benchmarkMainIs benchmark) - $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (benchmarkBuildInfo benchmark) - $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark)) - where - maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing - | otherwise = Just (benchmarkType benchmark) - - ppBenchmark bench' (Just bench2) = - ppDiffFields binfoFieldDescrs - (benchmarkBuildInfo bench') (benchmarkBuildInfo bench2) - $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo bench')) - - benchmarkMainIs benchmark = case benchmarkInterface benchmark of - BenchmarkExeV10 _ f -> Just f - _ -> Nothing +ppCondBenchmarks suites = vcat + [ emptyLine $ (text "benchmark" <+> disp n) $+$ + nest indentWith (ppCondTree2 benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree)) + | (n, condTree) <- suites + ] ppCondition :: Condition ConfVar -> Doc ppCondition (Var x) = ppConfVar x @@ -229,156 +190,57 @@ ppFlagName :: FlagName -> Doc ppFlagName = text . unFlagName -ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) -> Doc -ppCondTree ct@(CondNode it _ ifs) mbIt ppIt = - let res = (vcat $ map ppIf ifs) - $+$ ppIt it mbIt - in if isJust mbIt && isEmpty res - then ppCondTree ct Nothing ppIt - else res - where - -- TODO: this ends up printing trailing spaces when combined with nest. - ppIf (c, thenTree, Just elseTree) = ppIfElse it ppIt c thenTree elseTree - ppIf (c, thenTree, Nothing) = ppIf' it ppIt c thenTree - ppIfCondition :: (Condition ConfVar) -> Doc ppIfCondition c = (emptyLine $ text "if" <+> ppCondition c) -ppIf' :: a -> (a -> Maybe a -> Doc) - -> Condition ConfVar - -> CondTree ConfVar [Dependency] a - -> Doc -ppIf' it ppIt c thenTree = - if isEmpty thenDoc - then mempty - else ppIfCondition c $$ nest indentWith thenDoc - where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt - -ppIfElse :: a -> (a -> Maybe a -> Doc) - -> Condition ConfVar - -> CondTree ConfVar [Dependency] a - -> CondTree ConfVar [Dependency] a - -> Doc -ppIfElse it ppIt c thenTree elseTree = - case (isEmpty thenDoc, isEmpty elseDoc) of - (True, True) -> mempty - (False, True) -> ppIfCondition c $$ nest indentWith thenDoc - (True, False) -> ppIfCondition (cNot c) $$ nest indentWith elseDoc - (False, False) -> (ppIfCondition c $$ nest indentWith thenDoc) - $+$ (text "else" $$ nest indentWith elseDoc) - where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt - elseDoc = ppCondTree elseTree (if simplifiedPrinting then (Just it) else Nothing) ppIt - emptyLine :: Doc -> Doc emptyLine d = text "" $+$ d --- | @since 1.26.0.0@ +-- | @since 2.0.0.2 writePackageDescription :: FilePath -> PackageDescription -> NoCallStackIO () writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) --TODO: make this use section syntax -- add equivalent for GenericPackageDescription --- | @since 1.26.0.0@ +-- | @since 2.0.0.2 showPackageDescription :: PackageDescription -> String -showPackageDescription pkg = render $ - ppPackageDescription pkg - $+$ ppMaybeLibrary (library pkg) - $+$ ppSubLibraries (subLibraries pkg) - $+$ ppForeignLibs (foreignLibs pkg) - $+$ ppExecutables (executables pkg) - $+$ ppTestSuites (testSuites pkg) - $+$ ppBenchmarks (benchmarks pkg) - -ppMaybeLibrary :: Maybe Library -> Doc -ppMaybeLibrary Nothing = mempty -ppMaybeLibrary (Just lib) = - emptyLine $ text "library" - $+$ nest indentWith (ppFields libFieldDescrs lib) - -ppSubLibraries :: [Library] -> Doc -ppSubLibraries libs = vcat [ - emptyLine $ text "library" <+> disp libname - $+$ nest indentWith (ppFields libFieldDescrs lib) - | lib@Library{ libName = Just libname } <- libs ] - -ppForeignLibs :: [ForeignLib] -> Doc -ppForeignLibs flibs = vcat [ - emptyLine $ text "foreign library" <+> disp flibname - $+$ nest indentWith (ppFields foreignLibFieldDescrs flib) - | flib@ForeignLib{ foreignLibName = flibname } <- flibs ] - -ppExecutables :: [Executable] -> Doc -ppExecutables exes = vcat [ - emptyLine $ text "executable" <+> disp (exeName exe) - $+$ nest indentWith (ppFields executableFieldDescrs exe) - | exe <- exes ] - -ppTestSuites :: [TestSuite] -> Doc -ppTestSuites tests = vcat [ - emptyLine $ text "test-suite" <+> disp (testName test) - $+$ nest indentWith (ppFields testSuiteFieldDescrs test_stanza) - | test <- tests - , let test_stanza - = TestSuiteStanza { - testStanzaTestType = Just (testSuiteInterfaceToTestType (testInterface test)), - testStanzaMainIs = testSuiteInterfaceToMaybeMainIs (testInterface test), - testStanzaTestModule = testSuiteInterfaceToMaybeModule (testInterface test), - testStanzaBuildInfo = testBuildInfo test - } - ] - -testSuiteInterfaceToTestType :: TestSuiteInterface -> TestType -testSuiteInterfaceToTestType (TestSuiteExeV10 ver _) = TestTypeExe ver -testSuiteInterfaceToTestType (TestSuiteLibV09 ver _) = TestTypeLib ver -testSuiteInterfaceToTestType (TestSuiteUnsupported ty) = ty - -testSuiteInterfaceToMaybeMainIs :: TestSuiteInterface -> Maybe FilePath -testSuiteInterfaceToMaybeMainIs (TestSuiteExeV10 _ fp) = Just fp -testSuiteInterfaceToMaybeMainIs TestSuiteLibV09{} = Nothing -testSuiteInterfaceToMaybeMainIs TestSuiteUnsupported{} = Nothing - -testSuiteInterfaceToMaybeModule :: TestSuiteInterface -> Maybe ModuleName -testSuiteInterfaceToMaybeModule (TestSuiteLibV09 _ mod_name) = Just mod_name -testSuiteInterfaceToMaybeModule TestSuiteExeV10{} = Nothing -testSuiteInterfaceToMaybeModule TestSuiteUnsupported{} = Nothing - -ppBenchmarks :: [Benchmark] -> Doc -ppBenchmarks benchs = vcat [ - emptyLine $ text "benchmark" <+> disp (benchmarkName bench) - $+$ nest indentWith (ppFields benchmarkFieldDescrs bench_stanza) - | bench <- benchs - , let bench_stanza = BenchmarkStanza { - benchmarkStanzaBenchmarkType = Just (benchmarkInterfaceToBenchmarkType (benchmarkInterface bench)), - benchmarkStanzaMainIs = benchmarkInterfaceToMaybeMainIs (benchmarkInterface bench), - benchmarkStanzaBenchmarkModule = Nothing, - benchmarkStanzaBuildInfo = benchmarkBuildInfo bench - }] - -benchmarkInterfaceToBenchmarkType :: BenchmarkInterface -> BenchmarkType -benchmarkInterfaceToBenchmarkType (BenchmarkExeV10 ver _) = BenchmarkTypeExe ver -benchmarkInterfaceToBenchmarkType (BenchmarkUnsupported ty) = ty +showPackageDescription = showGenericPackageDescription . pdToGpd -benchmarkInterfaceToMaybeMainIs :: BenchmarkInterface -> Maybe FilePath -benchmarkInterfaceToMaybeMainIs (BenchmarkExeV10 _ fp) = Just fp -benchmarkInterfaceToMaybeMainIs BenchmarkUnsupported{} = Nothing +pdToGpd :: PackageDescription -> GenericPackageDescription +pdToGpd pd = GenericPackageDescription + { packageDescription = pd + , genPackageFlags = [] + , condLibrary = mkCondTree <$> library pd + , condSubLibraries = mkCondTreeL <$> subLibraries pd + , condForeignLibs = mkCondTree' foreignLibName <$> foreignLibs pd + , condExecutables = mkCondTree' exeName <$> executables pd + , condTestSuites = mkCondTree' testName <$> testSuites pd + , condBenchmarks = mkCondTree' benchmarkName <$> benchmarks pd + } + where + -- We set CondTree's [Dependency] to an empty list, as it + -- is not pretty printed anyway. + mkCondTree x = CondNode x [] [] + mkCondTreeL l = (fromMaybe (mkUnqualComponentName "") (libName l), CondNode l [] []) + mkCondTree' + :: (a -> UnqualComponentName) + -> a -> (UnqualComponentName, CondTree ConfVar [Dependency] a) + mkCondTree' f x = (f x, CondNode x [] []) --- | @since 1.26.0.0@ +-- | @since 2.0.0.2 writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> NoCallStackIO () writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack . showHookedBuildInfo --- | @since 1.26.0.0@ +-- | @since 2.0.0.2 showHookedBuildInfo :: HookedBuildInfo -> String showHookedBuildInfo (mb_lib_bi, ex_bis) = render $ - (case mb_lib_bi of - Nothing -> mempty - Just bi -> ppBuildInfo bi) - $$ vcat [ space - $$ (text "executable:" <+> disp name) - $$ ppBuildInfo bi - | (name, bi) <- ex_bis ] - where - ppBuildInfo bi = ppFields binfoFieldDescrs bi - $$ ppCustomFields (customFieldsBI bi) + maybe mempty (prettyFieldGrammar buildInfoFieldGrammar) mb_lib_bi + $$ vcat + [ space + $$ (text "executable:" <+> disp name) + $$ prettyFieldGrammar buildInfoFieldGrammar bi + | (name, bi) <- ex_bis + ] diff --git a/cabal/Cabal/Distribution/PackageDescription/Quirks.hs b/cabal/Cabal/Distribution/PackageDescription/Quirks.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/PackageDescription/Quirks.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- +-- @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 qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS +import qualified Data.Map as Map + +-- | Patch legacy @.cabal@ file contents to allow parsec parser to accept +-- all of Hackage. +-- +-- Bool part of the result tells whether the output is modified. +-- +-- @since 2.2.0.0 +patchQuirks :: BS.ByteString -> (Bool, BS.ByteString) +patchQuirks bs = case Map.lookup (BS.take 256 bs, md5 bs) patches of + Nothing -> (False, bs) + Just (post, f) + | post /= md5 output -> (False, bs) + | otherwise -> (True, output) + 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 + -- other-modules: . + -- ReadP assumed dot is empty line + [ mk "-- This file has been generated from package.yaml by hpack version 0.17.0.\n--\n-- see: https://github.com/sol/hpack\n\nname: unicode-transforms\nversion: 0.3.3\nsynopsis: Unicode normalization\ndescription: Fast Unic" + (Fingerprint 15958160436627155571 10318709190730872881) + (Fingerprint 11008465475756725834 13815629925116264363) + (bsRemove " other-modules:\n .\n") -- TODO: remove traling \n to test structural-diff + -- http://hackage.haskell.org/package/DSTM-0.1.2 + -- http://hackage.haskell.org/package/DSTM-0.1.1 + -- http://hackage.haskell.org/package/DSTM-0.1 + -- Other Modules: no dash + -- ReadP parsed as section + , mk "Name: DSTM\nVersion: 0.1.2\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed " + (Fingerprint 6919263071548559054 9050746360708965827) + (Fingerprint 17015177514298962556 11943164891661867280) + (bsReplace "Other modules:" "-- ") + , mk "Name: DSTM\nVersion: 0.1.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed " + (Fingerprint 17313105789069667153 9610429408495338584) + (Fingerprint 17250946493484671738 17629939328766863497) + (bsReplace "Other modules:" "-- ") + , mk "Name: DSTM\nVersion: 0.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed sy" + (Fingerprint 10502599650530614586 16424112934471063115) + (Fingerprint 13562014713536696107 17899511905611879358) + (bsReplace "Other modules:" "-- ") + -- http://hackage.haskell.org/package/control-monad-exception-mtl-0.10.3 + , mk "name: control-monad-exception-mtl\nversion: 0.10.3\nCabal-Version: >= 1.10\nbuild-type: Simple\nlicense: PublicDomain\nauthor: Pepe Iborra\nmaintainer: pepeiborra@gmail.com\nhomepage: http://pepeiborra.github.com/control-monad-exception\nsynopsis: MTL instances f" + (Fingerprint 18274748422558568404 4043538769550834851) + (Fingerprint 11395257416101232635 4303318131190196308) + (bsReplace " default- extensions:" "unknown-section") + -- http://hackage.haskell.org/package/vacuum-opengl-0.0 + -- \DEL character + , mk "Name: vacuum-opengl\nVersion: 0.0\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n " + (Fingerprint 5946760521961682577 16933361639326309422) + (Fingerprint 14034745101467101555 14024175957788447824) + (bsRemove "\DEL") + , mk "Name: vacuum-opengl\nVersion: 0.0.1\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n " + (Fingerprint 10790950110330119503 1309560249972452700) + (Fingerprint 1565743557025952928 13645502325715033593) + (bsRemove "\DEL") + -- http://hackage.haskell.org/package/ixset-1.0.4 + -- {- comments -} + , mk "Name: ixset\nVersion: 1.0.4\nSynopsis: Efficient relational queries on Haskell sets.\nDescription:\n Create and query sets that are indexed by multiple indices.\nLicense: BSD3\nLicense-file: COPYING\nAut" + (Fingerprint 11886092342440414185 4150518943472101551) + (Fingerprint 5731367240051983879 17473925006273577821) + (bsRemoveStarting "{-") + -- : after section + -- http://hackage.haskell.org/package/ds-kanren + , mk "name: ds-kanren\nversion: 0.2.0.0\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the language.\n .\n == What's in ds-kanren?\n .\n ['dis" + (Fingerprint 2804006762382336875 9677726932108735838) + (Fingerprint 9830506174094917897 12812107316777006473) + (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"") + , mk "name: ds-kanren\nversion: 0.2.0.1\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the language.\n\nlicense: MIT\nlicense-file: " + (Fingerprint 9130259649220396193 2155671144384738932) + (Fingerprint 1847988234352024240 4597789823227580457) + (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"") + , mk "name: metric\nversion: 0.1.4\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:" + (Fingerprint 6150019278861565482 3066802658031228162) + (Fingerprint 9124826020564520548 15629704249829132420) + (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"") + , mk "name: metric\nversion: 0.2.0\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:" + (Fingerprint 4639805967994715694 7859317050376284551) + (Fingerprint 5566222290622325231 873197212916959151) + (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"") + , mk "name: phasechange\ncategory: Data\nversion: 0.1\nauthor: G\195\161bor Lehel\nmaintainer: G\195\161bor Lehel \nhomepage: http://github.com/glehel/phasechange\ncopyright: Copyright (C) 2012 G\195\161bor Lehel\nlicense: " + (Fingerprint 10546509771395401582 245508422312751943) + (Fingerprint 5169853482576003304 7247091607933993833) + (bsReplace "impl(ghc >= 7.4):" "erroneous-section" . bsReplace "impl(ghc >= 7.6):" "erroneous-section") + , mk "Name: smartword\nSynopsis: Web based flash card for Word Smart I and II vocabularies\nVersion: 0.0.0.5\nHomepage: http://kyagrd.dyndns.org/~kyagrd/project/smartword/\nCategory: Web,Education\nLicense: " + (Fingerprint 7803544783533485151 10807347873998191750) + (Fingerprint 1665635316718752601 16212378357991151549) + (bsReplace "build depends:" "--") + , mk "name: shelltestrunner\n-- sync with README.md, ANNOUNCE:\nversion: 1.3\ncategory: Testing\nsynopsis: A tool for testing command-line programs.\ndescription:\n shelltestrunner is a cross-platform tool for testing command-line\n program" + (Fingerprint 4403237110790078829 15392625961066653722) + (Fingerprint 10218887328390239431 4644205837817510221) + (bsReplace "other modules:" "--") + -- &&! + -- http://hackage.haskell.org/package/hblas-0.3.0.0 + , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " + (Fingerprint 8570120150072467041 18315524331351505945) + (Fingerprint 10838007242302656005 16026440017674974175) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " + (Fingerprint 5262875856214215155 10846626274067555320) + (Fingerprint 3022954285783401045 13395975869915955260) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " + (Fingerprint 54222628930951453 5526514916844166577) + (Fingerprint 1749630806887010665 8607076506606977549) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" + (Fingerprint 6817250511240350300 15278852712000783849) + (Fingerprint 15757717081429529536 15542551865099640223) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" + (Fingerprint 8310050400349211976 201317952074418615) + (Fingerprint 10283381191257209624 4231947623042413334) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" + (Fingerprint 7010988292906098371 11591884496857936132) + (Fingerprint 6158672440010710301 6419743768695725095) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)" + (Fingerprint 2076850805659055833 16615160726215879467) + (Fingerprint 10634706281258477722 5285812379517916984) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)" + (Fingerprint 11850020631622781099 11956481969231030830) + (Fingerprint 13702868780337762025 13383526367149067158) + (bsReplace "&&!" "&& !") + , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" + (Fingerprint 13690322768477779172 19704059263540994) + (Fingerprint 11189374824645442376 8363528115442591078) + (bsReplace "&&!" "&& !") + ] + where + mk a b c d = ((a, b), (c, d)) + +-- | Helper to create entries in patches +_makePatchKey :: FilePath -> (BS.ByteString -> BS.ByteString) -> NoCallStackIO () +_makePatchKey fp transform = do + contents <- BS.readFile fp + let output = transform contents + let Fingerprint hi lo = md5 contents + let Fingerprint hi' lo' = md5 output + putStrLn + $ showString " , mk " + . shows (BS.take 256 contents) + . showString "\n (Fingerprint " + . shows hi + . showString " " + . shows lo + . showString ")\n (Fingerprint " + . shows hi' + . showString " " + . shows lo' + . showString ")" + $ "" + +------------------------------------------------------------------------------- +-- Patch helpers +------------------------------------------------------------------------------- + +bsRemove + :: BS.ByteString -- ^ needle + -> BS.ByteString -> BS.ByteString +bsRemove needle haystack = case BS.breakSubstring needle haystack of + (h, t) -> BS.append h (BS.drop (BS.length needle) t) + +bsReplace + :: BS.ByteString -- ^ needle + -> BS.ByteString -- ^ replacement + -> BS.ByteString -> BS.ByteString +bsReplace needle repl haystack = case BS.breakSubstring needle haystack of + (h, t) + | not (BS.null t) -> BS.append h (BS.append repl (BS.drop (BS.length needle) t)) + | otherwise -> haystack + +bsRemoveStarting + :: BS.ByteString -- ^ needle + -> BS.ByteString -> BS.ByteString +bsRemoveStarting needle haystack = case BS.breakSubstring needle haystack of + (h, _) -> h diff --git a/cabal/Cabal/Distribution/ParseUtils.hs b/cabal/Cabal/Distribution/ParseUtils.hs --- a/cabal/Cabal/Distribution/ParseUtils.hs +++ b/cabal/Cabal/Distribution/ParseUtils.hs @@ -29,13 +29,14 @@ parseFields, parseFieldsFlat, parseFilePathQ, parseTokenQ, parseTokenQ', parseModuleNameQ, - parseOptVersion, parsePackageNameQ, + parseOptVersion, parsePackageName, parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ, parseSepList, parseCommaList, parseOptCommaList, showFilePath, showToken, showTestedWith, showFreeText, parseFreeText, field, simpleField, listField, listFieldWithSep, spaceListField, commaListField, commaListFieldWithSep, commaNewLineListField, optsField, liftField, boolField, parseQuoted, parseMaybeQuoted, indentWith, + readPToMaybe, UnrecFieldParser, warnUnrec, ignoreUnrec, ) where @@ -46,14 +47,15 @@ import Distribution.Compiler import Distribution.License import Distribution.Version -import Distribution.Package import Distribution.ModuleName import qualified Distribution.Compat.MonadFail as Fail import Distribution.Compat.ReadP as ReadP hiding (get) import Distribution.ReadE +import Distribution.Compat.Newtype +import Distribution.Parsec.Newtypes (TestedWith (..)) import Distribution.Text -import Distribution.Simple.Utils -import Distribution.PrettyUtils +import Distribution.Utils.Generic +import Distribution.Pretty import Language.Haskell.Extension import Text.PrettyPrint @@ -283,6 +285,8 @@ , "extra-source-files" , "extra-tmp-files" , "exposed-modules" + , "asm-sources" + , "cmm-sources" , "c-sources" , "js-sources" , "extra-libraries" @@ -625,8 +629,16 @@ skipSpaces return res -parsePackageNameQ :: ReadP r PackageName -parsePackageNameQ = parseMaybeQuoted parse +parsePackageName :: ReadP r String +parsePackageName = do + ns <- sepBy1 component (char '-') + return $ intercalate "-" ns + where + component = do + cs <- munch1 isAlphaNum + if all isDigit cs then pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). parseOptVersion :: ReadP r Version parseOptVersion = parseMaybeQuoted ver @@ -690,3 +702,14 @@ parseFreeText :: ReadP.ReadP s String parseFreeText = ReadP.munch (const True) + +readPToMaybe :: ReadP a a -> String -> Maybe a +readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str + , all isSpace s ] + +------------------------------------------------------------------------------- +-- Internal +------------------------------------------------------------------------------- + +showTestedWith :: (CompilerFlavor, VersionRange) -> Doc +showTestedWith = pretty . pack' TestedWith diff --git a/cabal/Cabal/Distribution/Parsec/Class.hs b/cabal/Cabal/Distribution/Parsec/Class.hs --- a/cabal/Cabal/Distribution/Parsec/Class.hs +++ b/cabal/Cabal/Distribution/Parsec/Class.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes, FlexibleContexts #-} module Distribution.Parsec.Class ( Parsec(..), + ParsecParser, + simpleParsec, -- * Warnings parsecWarning, + PWarnType (..), -- * Utilities - parsecTestedWith, parsecToken, parsecToken', parsecFilePath, @@ -12,56 +14,18 @@ parsecMaybeQuoted, parsecCommaList, parsecOptCommaList, + parsecStandard, + parsecUnqualComponentName, ) where -import Prelude () +import Data.Functor.Identity (Identity (..)) +import qualified Distribution.Compat.Parsec as P import Distribution.Compat.Prelude -import Data.Functor.Identity (Identity) -import qualified Distribution.Compat.Parsec as P -import Distribution.Parsec.Types.Common - (PWarnType (..), PWarning (..), Position (..)) -import qualified Text.Parsec as Parsec -import qualified Text.Parsec.Language as Parsec -import qualified Text.Parsec.Token as Parsec - --- Instances - -import Distribution.Compiler - (CompilerFlavor (..), classifyCompilerFlavor) -import Distribution.License (License (..)) -import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as ModuleName -import Distribution.Package - (Dependency (..), - LegacyExeDependency (..), PkgconfigDependency (..), - UnqualComponentName, mkUnqualComponentName, - PackageName, mkPackageName, - PkgconfigName, mkPkgconfigName) -import Distribution.System - (Arch (..), ClassificationStrictness (..), OS (..), - classifyArch, classifyOS) -import Distribution.Text (display) -import Distribution.Types.BenchmarkType - (BenchmarkType (..)) -import Distribution.Types.BuildType (BuildType (..)) -import Distribution.Types.GenericPackageDescription (FlagName, mkFlagName) -import Distribution.Types.ModuleReexport - (ModuleReexport (..)) -import Distribution.Types.SourceRepo - (RepoKind, RepoType, classifyRepoKind, classifyRepoType) -import Distribution.Types.TestType (TestType (..)) -import Distribution.Types.ForeignLibType (ForeignLibType (..)) -import Distribution.Types.ForeignLibOption (ForeignLibOption (..)) -import Distribution.Types.ModuleRenaming -import Distribution.Types.IncludeRenaming -import Distribution.Types.Mixin -import Distribution.Version - (Version, VersionRange (..), anyVersion, earlierVersion, - intersectVersionRanges, laterVersion, majorBoundVersion, - mkVersion, noVersion, orEarlierVersion, orLaterVersion, - thisVersion, unionVersionRanges, withinVersion) -import Language.Haskell.Extension - (Extension, Language, classifyExtension, classifyLanguage) +import Distribution.Parsec.Common (PWarnType (..), PWarning (..), Position (..)) +import Prelude () +import qualified Text.Parsec as Parsec +import qualified Text.Parsec.Language as Parsec +import qualified Text.Parsec.Token as Parsec ------------------------------------------------------------------------------- -- Class @@ -69,321 +33,62 @@ -- | -- --- TODO: implementation details: should be careful about consuming trailing whitespace? +-- TODO: implementation details: should be careful about consuming +-- trailing whitespace? -- Should we always consume it? class Parsec a where - parsec :: P.Stream s Identity Char => P.Parsec s [PWarning] a + parsec :: ParsecParser a -- | 'parsec' /could/ consume trailing spaces, this function /must/ consume. - lexemeParsec :: P.Stream s Identity Char => P.Parsec s [PWarning] a + lexemeParsec :: ParsecParser a lexemeParsec = parsec <* P.spaces +type ParsecParser a = forall s. P.Stream s Identity Char => P.Parsec s [PWarning] a + +-- | Parse a 'String' with 'lexemeParsec'. +simpleParsec :: Parsec a => String -> Maybe a +simpleParsec + = either (const Nothing) Just + . P.runParser (lexemeParsec <* P.eof) [] "" + parsecWarning :: PWarnType -> String -> P.Parsec s [PWarning] () parsecWarning t w = Parsec.modifyState (PWarning t (Position 0 0) w :) -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - --- TODO: use lexemeParsec - --- TODO avoid String -parsecUnqualComponentName :: P.Stream s Identity Char => P.Parsec s [PWarning] String -parsecUnqualComponentName = intercalate "-" <$> P.sepBy1 component (P.char '-') - where - component :: P.Stream s Identity Char => P.Parsec s [PWarning] String - component = do - cs <- P.munch1 isAlphaNum - if all isDigit cs - then fail "all digits in portion of unqualified component name" - else return cs - -instance Parsec UnqualComponentName where - parsec = mkUnqualComponentName <$> parsecUnqualComponentName - -instance Parsec PackageName where - parsec = mkPackageName <$> parsecUnqualComponentName - -instance Parsec PkgconfigName where - parsec = mkPkgconfigName <$> P.munch1 (\c -> isAlphaNum c || c `elem` "+-._") - -instance Parsec ModuleName where - parsec = ModuleName.fromComponents <$> P.sepBy1 component (P.char '.') - where - component = do - c <- P.satisfy isUpper - cs <- P.munch validModuleChar - return (c:cs) - - validModuleChar :: Char -> Bool - validModuleChar c = isAlphaNum c || c == '_' || c == '\'' - -instance Parsec FlagName where - parsec = mkFlagName . map toLower . intercalate "-" <$> P.sepBy1 component (P.char '-') - where - -- http://hackage.haskell.org/package/cabal-debian-4.24.8/cabal-debian.cabal - -- has flag with all digit component: pretty-112 - component :: P.Stream s Identity Char => P.Parsec s [PWarning] String - component = P.munch1 (\c -> isAlphaNum c || c `elem` "_") - -instance Parsec Dependency where - parsec = do - name <- lexemeParsec - ver <- parsec <|> pure anyVersion - return (Dependency name ver) - -instance Parsec LegacyExeDependency where - parsec = do - name <- parsecMaybeQuoted nameP - P.spaces - verRange <- parsecMaybeQuoted parsec <|> pure anyVersion - pure $ LegacyExeDependency name verRange - where - nameP = intercalate "-" <$> P.sepBy1 component (P.char '-') - component = do - cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_') - if all isDigit cs then fail "invalid component" else return cs - -instance Parsec PkgconfigDependency where - parsec = do - name <- parsec - P.spaces - verRange <- parsec <|> pure anyVersion - pure $ PkgconfigDependency name verRange - -instance Parsec Version where - parsec = mkVersion <$> - P.sepBy1 P.integral (P.char '.') - <* tags - where - tags = do - ts <- P.optionMaybe $ some $ P.char '-' *> some (P.satisfy isAlphaNum) - case ts of - Nothing -> pure () - -- TODO: make this warning severe - Just _ -> parsecWarning PWTVersionTag "version with tags" - --- TODO: this is not good parsec code --- use lexer, also see D.P.ConfVar -instance Parsec VersionRange where - parsec = expr - where - expr = do P.spaces - t <- term - P.spaces - (do _ <- P.string "||" - P.spaces - e <- expr - return (unionVersionRanges t e) - <|> - return t) - term = do f <- factor - P.spaces - (do _ <- P.string "&&" - P.spaces - t <- term - return (intersectVersionRanges f t) - <|> - return f) - factor = P.choice - $ parens expr - : parseAnyVersion - : parseNoVersion - : parseWildcardRange - : map parseRangeOp rangeOps - parseAnyVersion = P.string "-any" >> return anyVersion - parseNoVersion = P.string "-none" >> return noVersion - - parseWildcardRange = P.try $ do - _ <- P.string "==" - P.spaces - branch <- some (P.integral <* P.char '.') - _ <- P.char '*' - return (withinVersion (mkVersion branch)) - - parens p = P.between - (P.char '(' >> P.spaces) - (P.char ')' >> P.spaces) - (do a <- p - P.spaces - return (VersionRangeParens a)) - - -- TODO: make those non back-tracking - parseRangeOp (s,f) = P.try (P.string s *> P.spaces *> fmap f parsec) - rangeOps = [ ("<", earlierVersion), - ("<=", orEarlierVersion), - (">", laterVersion), - (">=", orLaterVersion), - ("^>=", majorBoundVersion), - ("==", thisVersion) ] - -instance Parsec Language where - parsec = classifyLanguage <$> P.munch1 isAlphaNum - -instance Parsec Extension where - parsec = classifyExtension <$> P.munch1 isAlphaNum - -instance Parsec RepoType where - parsec = classifyRepoType <$> P.munch1 isIdent - -instance Parsec RepoKind where - parsec = classifyRepoKind <$> P.munch1 isIdent - -instance Parsec License where - parsec = do - name <- P.munch1 isAlphaNum - version <- P.optionMaybe (P.char '-' *> parsec) - return $! case (name, version :: Maybe Version) of - ("GPL", _ ) -> GPL version - ("LGPL", _ ) -> LGPL version - ("AGPL", _ ) -> AGPL version - ("BSD2", Nothing) -> BSD2 - ("BSD3", Nothing) -> BSD3 - ("BSD4", Nothing) -> BSD4 - ("ISC", Nothing) -> ISC - ("MIT", Nothing) -> MIT - ("MPL", Just version') -> MPL version' - ("Apache", _ ) -> Apache version - ("PublicDomain", Nothing) -> PublicDomain - ("AllRightsReserved", Nothing) -> AllRightsReserved - ("OtherLicense", Nothing) -> OtherLicense - _ -> UnknownLicense $ name ++ - maybe "" (('-':) . display) version - -instance Parsec BuildType where - parsec = do - name <- P.munch1 isAlphaNum - return $ case name of - "Simple" -> Simple - "Configure" -> Configure - "Custom" -> Custom - "Make" -> Make - _ -> UnknownBuildType name - -instance Parsec TestType where - parsec = stdParse $ \ver name -> case name of - "exitcode-stdio" -> TestTypeExe ver - "detailed" -> TestTypeLib ver - _ -> TestTypeUnknown name ver - -instance Parsec BenchmarkType where - parsec = stdParse $ \ver name -> case name of - "exitcode-stdio" -> BenchmarkTypeExe ver - _ -> BenchmarkTypeUnknown name ver - -instance Parsec ForeignLibType where - parsec = do - name <- P.munch1 (\c -> isAlphaNum c || c == '-') - return $ case name of - "native-shared" -> ForeignLibNativeShared - "native-static" -> ForeignLibNativeStatic - _ -> ForeignLibTypeUnknown - -instance Parsec ForeignLibOption where - parsec = do - name <- P.munch1 (\c -> isAlphaNum c || c == '-') - case name of - "standalone" -> return ForeignLibStandalone - _ -> fail "unrecognized foreign-library option" - -instance Parsec OS where - parsec = classifyOS Compat <$> parsecIdent - -instance Parsec Arch where - parsec = classifyArch Strict <$> parsecIdent - -instance Parsec CompilerFlavor where - parsec = classifyCompilerFlavor <$> component - where - component :: P.Stream s Identity Char => P.Parsec s [PWarning] String - component = do - cs <- P.munch1 isAlphaNum - if all isDigit cs then fail "all digits compiler name" else return cs - -instance Parsec ModuleReexport where - parsec = do - mpkgname <- P.optionMaybe (P.try $ parsec <* P.char ':') - origname <- parsec - newname <- P.option origname $ P.try $ do - P.spaces - _ <- P.string "as" - P.spaces - parsec - return (ModuleReexport mpkgname origname newname) +instance Parsec a => Parsec (Identity a) where + parsec = Identity <$> parsec -instance Parsec ModuleRenaming where - -- NB: try not necessary as the first token is obvious - parsec = P.choice [ parseRename, parseHiding, return DefaultRenaming ] +instance Parsec Bool where + parsec = P.munch1 isAlpha >>= postprocess where - parseRename = do - rns <- P.between (P.char '(') (P.char ')') parseList - P.spaces - return (ModuleRenaming rns) - parseHiding = do - _ <- P.string "hiding" - P.spaces - hides <- P.between (P.char '(') (P.char ')') - (P.sepBy parsec (P.char ',' >> P.spaces)) - return (HidingRenaming hides) - parseList = - P.sepBy parseEntry (P.char ',' >> P.spaces) - parseEntry = do - orig <- parsec - P.spaces - P.option (orig, orig) $ do - _ <- P.string "as" - P.spaces - new <- parsec - P.spaces - return (orig, new) - -instance Parsec IncludeRenaming where - parsec = do - prov_rn <- parsec - req_rn <- P.option defaultRenaming $ P.try $ do - P.spaces - _ <- P.string "requires" - P.spaces - parsec - return (IncludeRenaming prov_rn req_rn) - -instance Parsec Mixin where - parsec = do - mod_name <- parsec - P.spaces - incl <- parsec - return (Mixin mod_name incl) - -------------------------------------------------------------------------------- --- Utilities -------------------------------------------------------------------------------- - -isIdent :: Char -> Bool -isIdent c = isAlphaNum c || c == '_' || c == '-' - -parsecTestedWith :: P.Stream s Identity Char => P.Parsec s [PWarning] (CompilerFlavor, VersionRange) -parsecTestedWith = do - name <- lexemeParsec - ver <- parsec <|> pure anyVersion - return (name, ver) + postprocess str + | str == "True" = pure True + | str == "False" = pure False + | lstr == "true" = parsecWarning PWTBoolCase caseWarning *> pure True + | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False + | otherwise = fail $ "Not a boolean: " ++ str + where + lstr = map toLower str + caseWarning = + "Boolean values are case sensitive, use 'True' or 'False'." +-- | @[^ ,]@ parsecToken :: P.Stream s Identity Char => P.Parsec s [PWarning] String parsecToken = parsecHaskellString <|> (P.munch1 (\x -> not (isSpace x) && x /= ',') P. "identifier" ) +-- | @[^ ]@ parsecToken' :: P.Stream s Identity Char => P.Parsec s [PWarning] String parsecToken' = parsecHaskellString <|> (P.munch1 (not . isSpace) P. "token") -parsecFilePath :: P.Stream s Identity Char => P.Parsec s [PWarning] String +parsecFilePath :: P.Stream s Identity Char => P.Parsec s [PWarning] FilePath parsecFilePath = parsecToken -- | Parse a benchmark/test-suite types. -stdParse - :: P.Stream s Identity Char - => (Version -> String -> a) +parsecStandard + :: (Parsec ver, P.Stream s Identity Char) + => (ver -> String -> a) -> P.Parsec s [PWarning] a -stdParse f = do - -- TODO: this backtracks +parsecStandard f = do cs <- some $ P.try (component <* P.char '-') ver <- parsec let name = map toLower (intercalate "-" cs) @@ -409,7 +114,6 @@ where comma = P.char ',' *> P.spaces - -- | Content isn't unquoted parsecQuoted :: P.Stream s Identity Char @@ -441,8 +145,12 @@ where opl = P.oneOf ":!#$%&*+./<=>?@\\^|-~" -parsecIdent :: P.Stream s Identity Char => P.Parsec s [PWarning] String -parsecIdent = (:) <$> firstChar <*> rest +parsecUnqualComponentName :: P.Stream s Identity Char => P.Parsec s [PWarning] String +parsecUnqualComponentName = intercalate "-" <$> P.sepBy1 component (P.char '-') where - firstChar = P.satisfy isAlpha - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') + component :: P.Stream s Identity Char => P.Parsec s [PWarning] String + component = do + cs <- P.munch1 isAlphaNum + if all isDigit cs + then fail "all digits in portion of unqualified component name" + else return cs diff --git a/cabal/Cabal/Distribution/Parsec/Common.hs b/cabal/Cabal/Distribution/Parsec/Common.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Parsec/Common.hs @@ -0,0 +1,93 @@ +-- | Module containing small types +module Distribution.Parsec.Common ( + -- * Diagnostics + PError (..), + showPError, + PWarning (..), + PWarnType (..), + showPWarning, + -- * Field parser + FieldParser, + -- * Position + Position (..), + incPos, + retPos, + showPos, + zeroPos, + ) where + +import Prelude () +import Distribution.Compat.Prelude +import System.FilePath (normalise) +import qualified Text.Parsec as Parsec + +-- | Parser error. +data PError = PError Position String + deriving (Show) + +-- | Type of parser warning. We do classify warnings. +-- +-- Different application may decide not to show some, or have fatal behaviour on others +data PWarnType + = PWTOther -- ^ Unclassified warning + | PWTUTF -- ^ Invalid UTF encoding + | PWTBoolCase -- ^ @true@ or @false@, not @True@ or @False@ + | PWTVersionTag -- ^ there are version with tags + | PWTNewSyntax -- ^ New syntax used, but no @cabal-version: >= 1.2@ specified + | PWTOldSyntax -- ^ Old syntax used, and @cabal-version >= 1.2@ specified + | PWTDeprecatedField + | PWTInvalidSubsection + | PWTUnknownField + | PWTUnknownSection + | PWTTrailingFields + | PWTExtraMainIs -- ^ extra main-is field + | PWTExtraTestModule -- ^ extra test-module field + | PWTExtraBenchmarkModule -- ^ extra benchmark-module field + | PWTLexNBSP + | PWTLexBOM + | PWTQuirkyCabalFile -- ^ legacy cabal file that we know how to patch + deriving (Eq, Ord, Show, Enum, Bounded) + +-- | Parser warning. +data PWarning = PWarning !PWarnType !Position String + deriving (Show) + +showPWarning :: FilePath -> PWarning -> String +showPWarning fpath (PWarning _ pos msg) = + normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg + +showPError :: FilePath -> PError -> String +showPError fpath (PError pos msg) = + normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg + +------------------------------------------------------------------------------- +-- Field parser +------------------------------------------------------------------------------- + +-- | Field value parsers. +type FieldParser = Parsec.Parsec String [PWarning] -- :: * -> * + + +------------------------------------------------------------------------------- +-- Position +------------------------------------------------------------------------------- + +-- | 1-indexed row and column positions in a file. +data Position = Position + {-# UNPACK #-} !Int -- row + {-# UNPACK #-} !Int -- column + deriving (Eq, Ord, Show) + +-- | Shift position by n columns to the right. +incPos :: Int -> Position -> Position +incPos n (Position row col) = Position row (col + n) + +-- | Shift position to beginning of next row. +retPos :: Position -> Position +retPos (Position row _col) = Position (row + 1) 1 + +showPos :: Position -> String +showPos (Position row col) = show row ++ ":" ++ show col + +zeroPos :: Position +zeroPos = Position 0 0 diff --git a/cabal/Cabal/Distribution/Parsec/ConfVar.hs b/cabal/Cabal/Distribution/Parsec/ConfVar.hs --- a/cabal/Cabal/Distribution/Parsec/ConfVar.hs +++ b/cabal/Cabal/Distribution/Parsec/ConfVar.hs @@ -1,32 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonoLocalBinds #-} module Distribution.Parsec.ConfVar (parseConditionConfVar) where -import Prelude () -import Distribution.Compat.Prelude import Distribution.Compat.Parsec (integral) +import Distribution.Compat.Prelude import Distribution.Parsec.Class (Parsec (..)) -import Distribution.Parsec.Types.Common -import Distribution.Parsec.Types.Field (SectionArg (..)) -import Distribution.Parsec.Types.ParseResult +import Distribution.Parsec.Common +import Distribution.Parsec.Field (SectionArg (..)) +import Distribution.Parsec.ParseResult import Distribution.Simple.Utils (fromUTF8BS) -import Distribution.Types.GenericPackageDescription - (Condition (..), ConfVar (..)) +import Distribution.Types.Condition +import Distribution.Types.GenericPackageDescription (ConfVar (..)) import Distribution.Version - (anyVersion, earlierVersion, intersectVersionRanges, - laterVersion, majorBoundVersion, mkVersion, noVersion, - orEarlierVersion, orLaterVersion, thisVersion, - unionVersionRanges, withinVersion) + (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, + majorBoundVersion, mkVersion, noVersion, orEarlierVersion, orLaterVersion, + thisVersion, unionVersionRanges, withinVersion) +import Prelude () import qualified Text.Parsec as P import qualified Text.Parsec.Error as P -- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec -- based outline parser. parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar) -parseConditionConfVar args = do - -- preprocess glued operators - args' <- preprocess args +parseConditionConfVar args = -- The name of the input file is irrelevant, as we reformat the error message. - case P.runParser (parser <* P.eof) () "" args' of + case P.runParser (parser <* P.eof) () "" args of Right x -> pure x Left err -> do -- Mangle the position to the actual one @@ -38,18 +36,6 @@ parseFailure epos msg pure $ Lit True --- This is a hack, as we have "broken" .cabal files on Hackage --- --- There are glued operators "&&!" (no whitespace) in some cabal files. --- E.g. http://hackage.haskell.org/package/hblas-0.2.0.0/hblas.cabal -preprocess :: [SectionArg Position] -> ParseResult [SectionArg Position] -preprocess (SecArgOther pos "&&!" : rest) = do - parseWarning pos PWTGluedOperators "Glued operators: &&!" - (\rest' -> SecArgOther pos "&&" : SecArgOther pos "!" : rest') <$> preprocess rest -preprocess (x : rest) = - (x: ) <$> preprocess rest -preprocess [] = pure [] - type Parser = P.Parsec [SectionArg Position] () parser :: Parser (Condition ConfVar) @@ -104,7 +90,6 @@ -- Number token can have many dots in it: SecArgNum (Position 65 15) "7.6.1" ident = tokenPrim $ \t -> case t of SecArgName _ s -> Just $ fromUTF8BS s - SecArgNum _ s -> Just $ fromUTF8BS s _ -> Nothing boolLiteral' = tokenPrim $ \t -> case t of diff --git a/cabal/Cabal/Distribution/Parsec/Field.hs b/cabal/Cabal/Distribution/Parsec/Field.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Parsec/Field.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveFunctor #-} +-- | Cabal-like file AST types: 'Field', 'Section' etc +-- +-- These types are parametrized by an annotation. +module Distribution.Parsec.Field ( + -- * Cabal file + Field (..), + fieldName, + fieldAnn, + fieldUniverse, + FieldLine (..), + SectionArg (..), + sectionArgAnn, + -- * Name + FieldName, + Name (..), + mkName, + getName, + nameAnn, + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.Char as Char + +------------------------------------------------------------------------------- +-- Cabal file +------------------------------------------------------------------------------- + +-- | A Cabal-like file consists of a series of fields (@foo: bar@) and sections (@library ...@). +data Field ann + = Field !(Name ann) [FieldLine ann] + | Section !(Name ann) [SectionArg ann] [Field ann] + deriving (Eq, Show, Functor) + +-- | Section of field name +fieldName :: Field ann -> Name ann +fieldName (Field n _ ) = n +fieldName (Section n _ _) = n + +fieldAnn :: Field ann -> ann +fieldAnn = nameAnn . fieldName + +-- | All transitive descendands of 'Field', including itself. +-- +-- /Note:/ the resulting list is never empty. +-- +fieldUniverse :: Field ann -> [Field ann] +fieldUniverse f@(Section _ _ fs) = f : concatMap fieldUniverse fs +fieldUniverse f@(Field _ _) = [f] + +-- | A line of text representing the value of a field from a Cabal file. +-- A field may contain multiple lines. +-- +-- /Invariant:/ 'ByteString' has no newlines. +data FieldLine ann = FieldLine !ann !ByteString + deriving (Eq, Show, Functor) + +-- | Section arguments, e.g. name of the library +data SectionArg ann + = SecArgName !ann !ByteString + -- ^ identifier, or omething which loos like number. Also many dot numbers, i.e. "7.6.3" + | SecArgStr !ann !ByteString + -- ^ quoted string + | SecArgOther !ann !ByteString + -- ^ everything else, mm. operators (e.g. in if-section conditionals) + deriving (Eq, Show, Functor) + +-- | Extract annotation from 'SectionArg'. +sectionArgAnn :: SectionArg ann -> ann +sectionArgAnn (SecArgName ann _) = ann +sectionArgAnn (SecArgStr ann _) = ann +sectionArgAnn (SecArgOther ann _) = ann + +------------------------------------------------------------------------------- +-- Name +------------------------------------------------------------------------------- + +type FieldName = ByteString + +-- | A field name. +-- +-- /Invariant/: 'ByteString' is lower-case ASCII. +data Name ann = Name !ann !FieldName + deriving (Eq, Show, Functor) + +mkName :: ann -> FieldName -> Name ann +mkName ann bs = Name ann (B.map Char.toLower bs) + +getName :: Name ann -> FieldName +getName (Name _ bs) = bs + +nameAnn :: Name ann -> ann +nameAnn (Name ann _) = ann diff --git a/cabal/Cabal/Distribution/Parsec/Lexer.hs b/cabal/Cabal/Distribution/Parsec/Lexer.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Parsec/Lexer.hs @@ -0,0 +1,506 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} +{-# LANGUAGE CPP,MagicHash #-} +{-# LINE 1 "boot/Lexer.x" #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Parsec.Lexer +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Lexer for the cabal files. +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +#ifdef CABAL_PARSEC_DEBUG +{-# LANGUAGE PatternGuards #-} +#endif +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Distribution.Parsec.Lexer + (ltest, lexToken, Token(..), LToken(..) + ,bol_section, in_section, in_field_layout, in_field_braces + ,mkLexState) where + +-- [Note: boostrapping parsec parser] +-- +-- We manually produce the `Lexer.hs` file from `boot/Lexer.x` (make lexer) +-- because boostrapping cabal-install would be otherwise tricky. +-- Alex is (atm) tricky package to build, cabal-install has some magic +-- to move bundled generated files in place, so rather we don't depend +-- on it before we can build it ourselves. +-- Therefore there is one thing less to worry in bootstrap.sh, which is a win. +-- +-- See also https://github.com/haskell/cabal/issues/4633 +-- + +import Prelude () +import qualified Prelude as Prelude +import Distribution.Compat.Prelude + +import Distribution.Parsec.LexerMonad +import Distribution.Parsec.Common (Position (..), incPos, retPos) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B.Char8 +import qualified Data.Word as Word + +#ifdef CABAL_PARSEC_DEBUG +import Debug.Trace +import qualified Data.Vector as V +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +#endif + + +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Array.Base (unsafeAt) +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif +alex_tab_size :: Int +alex_tab_size = 8 +alex_base :: AlexAddr +alex_base = AlexA# "\x12\xff\xff\xff\xf9\xff\xff\xff\xfb\xff\xff\xff\x01\x00\x00\x00\x2f\x00\x00\x00\x50\x00\x00\x00\xd0\x00\x00\x00\x48\xff\xff\xff\xdc\xff\xff\xff\x51\xff\xff\xff\x6d\xff\xff\xff\x6f\xff\xff\xff\x50\x01\x00\x00\x74\x01\x00\x00\x70\xff\xff\xff\x68\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\xa3\x01\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\xd1\x01\x00\x00\xfb\x01\x00\x00\x7b\x02\x00\x00\xfb\x02\x00\x00\x00\x00\x00\x00\x7b\x03\x00\x00\x7d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x6d\x00\x00\x00\x6b\x00\x00\x00\xfc\x03\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x6f\x00\x00\x00\x1c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# "\x00\x00\x09\x00\x0f\x00\x11\x00\x02\x00\x11\x00\x12\x00\x00\x00\x12\x00\x13\x00\x03\x00\x11\x00\x07\x00\x10\x00\x12\x00\x25\x00\x14\x00\x11\x00\x10\x00\x11\x00\x14\x00\x11\x00\x12\x00\x23\x00\x12\x00\x0f\x00\x28\x00\x02\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x08\x00\x10\x00\x00\x00\x14\x00\x00\x00\x00\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x2e\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x0f\x00\x11\x00\x17\x00\x26\x00\x12\x00\x25\x00\x11\x00\x2a\x00\x00\x00\x12\x00\x00\x00\x15\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x17\x00\x26\x00\x00\x00\x25\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0e\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\x23\x00\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\x1e\x00\x0d\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x1f\x00\x1f\x00\x1e\x00\x1e\x00\x1e\x00\x19\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x1f\x00\x1e\x00\x1f\x00\x1e\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x1e\x00\x22\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1d\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1e\x00\xff\xff\xff\xff\xff\xff\x1e\x00\x1e\x00\x1e\x00\x18\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\xff\xff\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1a\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1c\x00\x1e\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x1e\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# "\xff\xff\xef\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\x0d\x00\xbf\x00\x0d\x00\x2d\x00\x09\x00\x0a\x00\xbb\x00\xa0\x00\x0d\x00\xa0\x00\xa0\x00\x0a\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\x0d\x00\x0a\x00\x0d\x00\x20\x00\x0a\x00\x20\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\x2d\x00\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\x2d\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x09\x00\x0a\x00\x09\x00\x09\x00\x0d\x00\x09\x00\x0a\x00\x09\x00\xff\xff\x0d\x00\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x20\x00\x20\x00\xff\xff\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xc2\x00\xff\xff\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x5c\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\x5c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x7f\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7f\x00\x7e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x27\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xff\xff\x18\x00\x1b\x00\x1b\x00\x1b\x00\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0::Int,47) [AlexAcc (alex_action_0),AlexAcc (alex_action_20),AlexAcc (alex_action_16),AlexAcc (alex_action_3),AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAcc (alex_action_1),AlexAcc (alex_action_1),AlexAccSkip,AlexAcc (alex_action_3),AlexAcc (alex_action_4),AlexAcc (alex_action_5),AlexAccSkip,AlexAccSkip,AlexAcc (alex_action_8),AlexAcc (alex_action_8),AlexAcc (alex_action_8),AlexAcc (alex_action_9),AlexAcc (alex_action_9),AlexAcc (alex_action_10),AlexAcc (alex_action_11),AlexAcc (alex_action_12),AlexAcc (alex_action_13),AlexAcc (alex_action_14),AlexAcc (alex_action_15),AlexAcc (alex_action_15),AlexAcc (alex_action_16),AlexAccSkip,AlexAcc (alex_action_18),AlexAcc (alex_action_19),AlexAcc (alex_action_19),AlexAccSkip,AlexAcc (alex_action_22),AlexAcc (alex_action_23),AlexAcc (alex_action_24),AlexAcc (alex_action_25),AlexAcc (alex_action_25)] +{-# LINE 152 "boot/Lexer.x" #-} + + +-- | Tokens of outer cabal file structure. Field values are treated opaquely. +data Token = TokSym !ByteString -- ^ Haskell-like identifier, number or operator + | TokStr !ByteString -- ^ String in quotes + | TokOther !ByteString -- ^ Operators and parens + | Indent !Int -- ^ Indentation token + | TokFieldLine !ByteString -- ^ Lines after @:@ + | Colon + | OpenBrace + | CloseBrace + | EOF + | LexicalError InputStream --TODO: add separate string lexical error + deriving Show + +data LToken = L !Position !Token + deriving Show + +toki :: (ByteString -> Token) -> Position -> Int -> ByteString -> Lex LToken +toki t pos len input = return $! L pos (t (B.take len input)) + +tok :: Token -> Position -> Int -> ByteString -> Lex LToken +tok t pos _len _input = return $! L pos t + +checkWhitespace :: Int -> ByteString -> Lex Int +checkWhitespace len bs + | B.any (== 194) (B.take len bs) = do + addWarning LexWarningNBSP "Non-breaking space found" + return $ len - B.count 194 (B.take len bs) + | otherwise = return len + +-- ----------------------------------------------------------------------------- +-- The input type + +type AlexInput = InputStream + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar _ = error "alexInputPrevChar not used" + +alexGetByte :: AlexInput -> Maybe (Word.Word8,AlexInput) +alexGetByte = B.uncons + +lexicalError :: Position -> InputStream -> Lex LToken +lexicalError pos inp = do + setInput B.empty + return $! L pos (LexicalError inp) + +lexToken :: Lex LToken +lexToken = do + pos <- getPos + inp <- getInput + st <- getStartCode + case alexScan inp st of + AlexEOF -> return (L pos EOF) + AlexError inp' -> + let !len_bytes = B.length inp - B.length inp' in + --FIXME: we want len_chars here really + -- need to decode utf8 up to this point + lexicalError (incPos len_bytes pos) inp' + AlexSkip inp' len_chars -> do + checkPosition pos inp inp' len_chars + adjustPos (incPos len_chars) + setInput inp' + lexToken + AlexToken inp' len_chars action -> do + checkPosition pos inp inp' len_chars + adjustPos (incPos len_chars) + setInput inp' + let !len_bytes = B.length inp - B.length inp' + t <- action pos len_bytes inp + --traceShow t $ return tok + return t + + +checkPosition :: Position -> ByteString -> ByteString -> Int -> Lex () +#ifdef CABAL_PARSEC_DEBUG +checkPosition pos@(Position lineno colno) inp inp' len_chars = do + text_lines <- getDbgText + let len_bytes = B.length inp - B.length inp' + pos_txt | lineno-1 < V.length text_lines = T.take len_chars (T.drop (colno-1) (text_lines V.! (lineno-1))) + | otherwise = T.empty + real_txt = B.take len_bytes inp + when (pos_txt /= T.decodeUtf8 real_txt) $ + traceShow (pos, pos_txt, T.decodeUtf8 real_txt) $ + traceShow (take 3 (V.toList text_lines)) $ return () + where + getDbgText = Lex $ \s@LexState{ dbgText = txt } -> LexResult s txt +#else +checkPosition _ _ _ _ = return () +#endif + +lexAll :: Lex [LToken] +lexAll = do + t <- lexToken + case t of + L _ EOF -> return [t] + _ -> do ts <- lexAll + return (t : ts) + +ltest :: Int -> String -> Prelude.IO () +ltest code s = + let (ws, xs) = execLexer (setStartCode code >> lexAll) (B.Char8.pack s) + in traverse_ print ws >> traverse_ print xs + + +mkLexState :: ByteString -> LexState +mkLexState input = LexState + { curPos = Position 1 1 + , curInput = input + , curCode = 0 + , warnings = [] +#ifdef CABAL_PARSEC_DEBUG + , dbgText = V.fromList . lines' . T.decodeUtf8With T.lenientDecode $ input +#endif + } + +#ifdef CABAL_PARSEC_DEBUG +lines' :: T.Text -> [T.Text] +lines' s1 + | T.null s1 = [] + | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of + (l, s2) | Just (c,s3) <- T.uncons s2 + -> case T.uncons s3 of + Just ('\n', s4) | c == '\r' -> l `T.snoc` '\r' `T.snoc` '\n' : lines' s4 + _ -> l `T.snoc` c : lines' s3 + + | otherwise + -> [l] +#endif + + +bol_field_braces,bol_field_layout,bol_section,in_field_braces,in_field_layout,in_section :: Int +bol_field_braces = 1 +bol_field_layout = 2 +bol_section = 3 +in_field_braces = 4 +in_field_layout = 5 +in_section = 6 +alex_action_0 = \_ len _ -> do + when (len /= 0) $ addWarning LexWarningBOM "Byte-order mark found at the beginning of the file" + setStartCode bol_section + lexToken + +alex_action_1 = \_pos len inp -> checkWhitespace len inp >> adjustPos retPos >> lexToken +alex_action_3 = \pos len inp -> checkWhitespace len inp >> + if B.length inp == len + then return (L pos EOF) + else setStartCode in_section + >> return (L pos (Indent len)) +alex_action_4 = tok OpenBrace +alex_action_5 = tok CloseBrace +alex_action_8 = toki TokSym +alex_action_9 = \pos len inp -> return $! L pos (TokStr (B.take (len - 2) (B.tail inp))) +alex_action_10 = toki TokOther +alex_action_11 = toki TokOther +alex_action_12 = tok Colon +alex_action_13 = tok OpenBrace +alex_action_14 = tok CloseBrace +alex_action_15 = \_ _ _ -> adjustPos retPos >> setStartCode bol_section >> lexToken +alex_action_16 = \pos len inp -> checkWhitespace len inp >>= \len' -> + if B.length inp == len + then return (L pos EOF) + else setStartCode in_field_layout + >> return (L pos (Indent len')) +alex_action_18 = toki TokFieldLine +alex_action_19 = \_ _ _ -> adjustPos retPos >> setStartCode bol_field_layout >> lexToken +alex_action_20 = \_ _ _ -> setStartCode in_field_braces >> lexToken +alex_action_22 = toki TokFieldLine +alex_action_23 = tok OpenBrace +alex_action_24 = tok CloseBrace +alex_action_25 = \_ _ _ -> adjustPos retPos >> setStartCode bol_field_braces >> lexToken +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 10 "" #-} +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{-# LINE 10 "" #-} +{-# LINE 1 "/opt/ghc/7.10.3/lib/ghc-7.10.3/include/ghcversion.h" #-} + + + + + + + + + + + + + + + + + +{-# LINE 10 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +{-# LINE 21 "templates/GenericTemplate.hs" #-} + + + + + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define GTE(n,m) (tagToEnum# (n >=# m)) +#define EQ(n,m) (tagToEnum# (n ==# m)) +#else +#define GTE(n,m) (n >=# m) +#define EQ(n,m) (n ==# m) +#endif +{-# LINE 51 "templates/GenericTemplate.hs" #-} + + +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input (I# (sc)) + = alexScanUser undefined input (I# (sc)) + +alexScanUser user input (I# (sc)) + = case alex_scan_tkn user input 0# input sc AlexNone of + (AlexNone, input') -> + case alexGetByte input of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input' + + (AlexLastSkip input'' len, _) -> + + + + AlexSkip input'' len + + (AlexLastAcc k input''' len, _) -> + + + + AlexToken input''' len k + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user orig_input len input s last_acc = + input `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) + in + new_acc `seq` + case alexGetByte input of + Nothing -> (new_acc, input) + Just (c, new_input) -> + + + + case fromIntegral c of { (I# (ord_c)) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if GTE(offset,0#) && EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + -1# -> (new_acc, input) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input (I# (len)) + check_accs (AlexAccSkip) = AlexLastSkip input (I# (len)) +{-# LINE 198 "templates/GenericTemplate.hs" #-} + +data AlexLastAcc a + = AlexNone + | AlexLastAcc a !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +instance Functor AlexLastAcc where + fmap _ AlexNone = AlexNone + fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z + fmap _ (AlexLastSkip x y) = AlexLastSkip x y + +data AlexAcc a user + = AlexAccNone + | AlexAcc a + | AlexAccSkip diff --git a/cabal/Cabal/Distribution/Parsec/Lexer.x b/cabal/Cabal/Distribution/Parsec/Lexer.x deleted file mode 100644 --- a/cabal/Cabal/Distribution/Parsec/Lexer.x +++ /dev/null @@ -1,269 +0,0 @@ -{ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Parsec.Lexer --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Lexer for the cabal files. -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -#ifdef CABAL_PARSEC_DEBUG -{-# LANGUAGE PatternGuards #-} -#endif -module Distribution.Parsec.Lexer - (ltest, lexToken, Token(..), LToken(..) - ,bol_section, in_section, in_field_layout, in_field_braces - ,mkLexState) where - -import Prelude () -import qualified Prelude as Prelude -import Distribution.Compat.Prelude - -import Distribution.Parsec.LexerMonad -import Distribution.Parsec.Types.Common (Position (..), incPos, retPos) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B.Char8 -import qualified Data.Word as Word - -#ifdef CABAL_PARSEC_DEBUG -import Debug.Trace -import qualified Data.Vector as V -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -#endif - -} --- Various character classes - -$space = \ -- single space char -$digit = 0-9 -- digits -$alpha = [a-z A-Z] -- alphabetic characters -$symbol = [\= \< \> \+ \* \- \& \| \! \$ \% \^ \@ \# \? \/ \\ \~] -$ctlchar = [\x0-\x1f \x7f] -$printable = \x0-\x10ffff # $ctlchar -- so no \n \r -$nbsp = \xa0 -$spacetab = [$space \t] -$bom = \xfeff -$nbspspacetab = [$nbsp $space \t] - -$paren = [ \( \) \[ \] ] -$field_layout = [$printable \t] -$field_layout' = [$printable] # [$space] -$field_braces = [$printable \t] # [\{ \}] -$field_braces' = [$printable] # [\{ \} $space] -$comment = [$printable \t] -$namecore = [$alpha] -$nameextra = [$namecore $digit \- \_ \. \'] -$instr = [$printable $space] # [\"] -$instresc = $printable - -@nl = \n | \r\n | \r -@name = $nameextra* $namecore $nameextra* -@string = \" ( $instr | \\ $instresc )* \" -@numlike = $digit [$digit \.]* -@oplike = [ \, \. \= \< \> \+ \* \- \& \| \! \$ \% \^ \@ \# \? \/ \\ \~ ]+ - -tokens :- - -<0> { - $bom { \_ _ _ -> addWarning LexWarningBOM "Byte-order mark found at the beginning of the file" >> lexToken } - () ; -} - - { - $nbspspacetab* @nl { \_pos len inp -> checkWhitespace len inp >> adjustPos retPos >> lexToken } - -- no @nl here to allow for comments on last line of the file with no trailing \n - $spacetab* "--" $comment* ; -- TODO: check the lack of @nl works here - -- including counting line numbers -} - - { - $nbspspacetab* --TODO prevent or record leading tabs - { \pos len inp -> checkWhitespace len inp >> - if B.length inp == len - then return (L pos EOF) - else setStartCode in_section - >> return (L pos (Indent len)) } - $spacetab* \{ { tok OpenBrace } - $spacetab* \} { tok CloseBrace } -} - - { - $spacetab+ ; --TODO: don't allow tab as leading space - - "--" $comment* ; - - @name { toki TokSym } - @string { \p l i -> case reads (B.Char8.unpack (B.take l i)) of - [(str,[])] -> return (L p (TokStr str)) - _ -> lexicalError p i } - @numlike { toki TokNum } - @oplike { toki TokOther } - $paren { toki TokOther } - \: { tok Colon } - \{ { tok OpenBrace } - \} { tok CloseBrace } - @nl { \_ _ _ -> adjustPos retPos >> setStartCode bol_section >> lexToken } -} - - { - $spacetab* --TODO prevent or record leading tabs - { \pos len inp -> if B.length inp == len - then return (L pos EOF) - else setStartCode in_field_layout - >> return (L pos (Indent len)) } -} - - { - $spacetab+; --TODO prevent or record leading tabs - $field_layout' $field_layout* { toki TokFieldLine } - @nl { \_ _ _ -> adjustPos retPos >> setStartCode bol_field_layout >> lexToken } -} - - { - () { \_ _ _ -> setStartCode in_field_braces >> lexToken } -} - - { - $spacetab+; --TODO prevent or record leading tabs - $field_braces' $field_braces* { toki TokFieldLine } - \{ { tok OpenBrace } - \} { tok CloseBrace } - @nl { \_ _ _ -> adjustPos retPos >> setStartCode bol_field_braces >> lexToken } -} - -{ - --- | Tokens of outer cabal file structure. Field values are treated opaquely. -data Token = TokSym !ByteString -- ^ Haskell-like identifier - | TokStr !String -- ^ String in quotes - | TokNum !ByteString -- ^ Integral - | TokOther !ByteString -- ^ Operator like token - | Indent !Int -- ^ Indentation token - | TokFieldLine !ByteString -- ^ Lines after @:@ - | Colon - | OpenBrace - | CloseBrace - | EOF - | LexicalError InputStream --TODO: add separate string lexical error - deriving Show - -data LToken = L !Position !Token - deriving Show - -toki :: Monad m => (ByteString -> Token) -> Position -> Int -> ByteString -> m LToken -toki t pos len input = return $! L pos (t (B.take len input)) - -tok :: Monad m => Token -> Position -> t -> t1 -> m LToken -tok t pos _len _input = return $! L pos t - -checkWhitespace :: Int -> ByteString -> Lex () -checkWhitespace len bs - | B.any (== 194) (B.take len bs) = - addWarning LexWarningNBSP "Non-breaking space found" - | otherwise = return () - --- ----------------------------------------------------------------------------- --- The input type - -type AlexInput = InputStream - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar _ = error "alexInputPrevChar not used" - -alexGetByte :: AlexInput -> Maybe (Word.Word8,AlexInput) -alexGetByte = B.uncons - -lexicalError :: Position -> InputStream -> Lex LToken -lexicalError pos inp = do - setInput B.empty - return $! L pos (LexicalError inp) - -lexToken :: Lex LToken -lexToken = do - pos <- getPos - inp <- getInput - st <- getStartCode - case alexScan inp st of - AlexEOF -> return (L pos EOF) - AlexError inp' -> - let !len_bytes = B.length inp - B.length inp' in - --FIXME: we want len_chars here really - -- need to decode utf8 up to this point - lexicalError (incPos len_bytes pos) inp' - AlexSkip inp' len_chars -> do - checkPosition pos inp inp' len_chars - adjustPos (incPos len_chars) - setInput inp' - lexToken - AlexToken inp' len_chars action -> do - checkPosition pos inp inp' len_chars - adjustPos (incPos len_chars) - setInput inp' - let !len_bytes = B.length inp - B.length inp' - t <- action pos len_bytes inp - --traceShow t $ return tok - return t - - -checkPosition :: Position -> ByteString -> ByteString -> Int -> Lex () -#ifdef CABAL_PARSEC_DEBUG -checkPosition pos@(Position lineno colno) inp inp' len_chars = do - text_lines <- getDbgText - let len_bytes = B.length inp - B.length inp' - pos_txt | lineno-1 < V.length text_lines = T.take len_chars (T.drop (colno-1) (text_lines V.! (lineno-1))) - | otherwise = T.empty - real_txt = B.take len_bytes inp - when (pos_txt /= T.decodeUtf8 real_txt) $ - traceShow (pos, pos_txt, T.decodeUtf8 real_txt) $ - traceShow (take 3 (V.toList text_lines)) $ return () - where - getDbgText = Lex $ \s@LexState{ dbgText = txt } -> LexResult s txt -#else -checkPosition _ _ _ _ = return () -#endif - -lexAll :: Lex [LToken] -lexAll = do - t <- lexToken - case t of - L _ EOF -> return [t] - _ -> do ts <- lexAll - return (t : ts) - -ltest :: Int -> String -> Prelude.IO () -ltest code s = - let (ws, xs) = execLexer (setStartCode code >> lexAll) (B.Char8.pack s) - in traverse_ print ws >> traverse_ print xs - - -mkLexState :: ByteString -> LexState -mkLexState input = LexState - { curPos = Position 1 1 - , curInput = input - , curCode = bol_section - , warnings = [] -#ifdef CABAL_PARSEC_DEBUG - , dbgText = V.fromList . lines' . T.decodeUtf8With T.lenientDecode $ input -#endif - } - -#ifdef CABAL_PARSEC_DEBUG -lines' :: T.Text -> [T.Text] -lines' s1 - | T.null s1 = [] - | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of - (l, s2) | Just (c,s3) <- T.uncons s2 - -> case T.uncons s3 of - Just ('\n', s4) | c == '\r' -> l `T.snoc` '\r' `T.snoc` '\n' : lines' s4 - _ -> l `T.snoc` c : lines' s3 - - | otherwise - -> [l] -#endif -} diff --git a/cabal/Cabal/Distribution/Parsec/LexerMonad.hs b/cabal/Cabal/Distribution/Parsec/LexerMonad.hs --- a/cabal/Cabal/Distribution/Parsec/LexerMonad.hs +++ b/cabal/Cabal/Distribution/Parsec/LexerMonad.hs @@ -31,17 +31,16 @@ ) where -import Prelude () +import qualified Data.ByteString as B import Distribution.Compat.Prelude -import qualified Data.ByteString as B -import Distribution.Parsec.Types.Common - (PWarnType (..), PWarning (..), Position (..)) +import Distribution.Parsec.Common (PWarnType (..), PWarning (..), Position (..)) +import Prelude () #ifdef CABAL_PARSEC_DEBUG -- testing only: -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Vector as V +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V #endif -- simple state monad diff --git a/cabal/Cabal/Distribution/Parsec/Newtypes.hs b/cabal/Cabal/Distribution/Parsec/Newtypes.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Parsec/Newtypes.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar". +module Distribution.Parsec.Newtypes ( + -- * List + alaList, + alaList', + -- ** Modifiers + CommaVCat (..), + CommaFSep (..), + VCat (..), + FSep (..), + NoCommaFSep (..), + -- ** Type + List, + -- * Version + SpecVersion (..), + TestedWith (..), + -- * Identifiers + Token (..), + Token' (..), + MQuoted (..), + FreeText (..), + FilePathNT (..), + ) where + +import Distribution.Compat.Newtype +import Distribution.Compat.Prelude +import Prelude () + +import Data.Functor.Identity (Identity (..)) +import Data.List (dropWhileEnd) +import qualified Distribution.Compat.Parsec as P +import Distribution.Compiler (CompilerFlavor) +import Distribution.Parsec.Class +import Distribution.Parsec.Common (PWarning) +import Distribution.Pretty +import Distribution.Version (Version, VersionRange, anyVersion) +import Text.PrettyPrint (Doc, comma, fsep, punctuate, vcat, (<+>)) + +-- | Vertical list with commas. Displayed with 'vcat' +data CommaVCat = CommaVCat + +-- | Paragraph fill list with commas. Displayed with 'fsep' +data CommaFSep = CommaFSep + +-- | Vertical list with optional commas. Displayed with 'vcat'. +data VCat = VCat + +-- | Paragraph fill list with optional commas. Displayed with 'fsep'. +data FSep = FSep + +-- | 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 + parseSep + :: P sep -> P.Stream s Identity Char + => P.Parsec s [PWarning] a + -> P.Parsec s [PWarning] [a] + +instance Sep CommaVCat where + prettySep _ = vcat . punctuate comma + parseSep _ = parsecCommaList +instance Sep CommaFSep where + prettySep _ = fsep . punctuate comma + parseSep _ = parsecCommaList +instance Sep VCat where + prettySep _ = vcat + parseSep _ = parsecOptCommaList +instance Sep FSep where + prettySep _ = fsep + parseSep _ = parsecOptCommaList +instance Sep NoCommaFSep where + prettySep _ = fsep + parseSep _ p = many (p <* P.spaces) + +-- | List separated with optional commas. Displayed with @sep@, arguments of +-- type @a@ are parsed and pretty-printed as @b@. +newtype List sep b a = List { getList :: [a] } + +-- | 'alaList' and 'alaList'' are simply 'List', with additional phantom +-- arguments to constraint the resulting type +-- +-- >>> :t alaList VCat +-- alaList VCat :: [a] -> List VCat (Identity a) a +-- +-- >>> :t alaList' FSep Token +-- alaList' FSep Token :: [String] -> List FSep Token String +-- +alaList :: sep -> [a] -> List sep (Identity a) a +alaList _ = List + +-- | More general version of 'alaList'. +alaList' :: sep -> (a -> b) -> [a] -> List sep b a +alaList' _ _ = List + +instance Newtype (List sep wrapper a) [a] where + pack = List + unpack = getList + +instance (Newtype b a, Sep sep, Parsec b) => Parsec (List sep b a) where + parsec = pack . map (unpack :: b -> a) <$> parseSep (P :: P sep) parsec + +instance (Newtype b a, Sep sep, Pretty b) => Pretty (List sep b a) where + pretty = prettySep (P :: P sep) . map (pretty . (pack :: a -> b)) . unpack + +-- | Haskell string or @[^ ,]+@ +newtype Token = Token { getToken :: String } + +instance Newtype Token String where + pack = Token + unpack = getToken + +instance Parsec Token where + parsec = pack <$> parsecToken + +instance Pretty Token where + pretty = showToken . unpack + +-- | Haskell string or @[^ ]+@ +newtype Token' = Token' { getToken' :: String } + +instance Newtype Token' String where + pack = Token' + unpack = getToken' + +instance Parsec Token' where + parsec = pack <$> parsecToken' + +instance Pretty Token' where + pretty = showToken . unpack + +-- | Either @"quoted"@ or @un-quoted@. +newtype MQuoted a = MQuoted { getMQuoted :: a } + +instance Newtype (MQuoted a) a where + pack = MQuoted + unpack = getMQuoted + +instance Parsec a => Parsec (MQuoted a) where + parsec = pack <$> parsecMaybeQuoted parsec + +instance Pretty a => Pretty (MQuoted a) where + pretty = pretty . unpack + +-- | Version range or just version +newtype SpecVersion = SpecVersion { getSpecVersion :: Either Version VersionRange } + +instance Newtype SpecVersion (Either Version VersionRange) where + pack = SpecVersion + unpack = getSpecVersion + +instance Parsec SpecVersion where + parsec = pack <$> parsecSpecVersion + where + parsecSpecVersion = Left <$> parsec <|> Right <$> parsec + +instance Pretty SpecVersion where + pretty = either pretty pretty . unpack + +-- | Version range or just version +newtype TestedWith = TestedWith { getTestedWith :: (CompilerFlavor, VersionRange) } + +instance Newtype TestedWith (CompilerFlavor, VersionRange) where + pack = TestedWith + unpack = getTestedWith + +instance Parsec TestedWith where + parsec = pack <$> parsecTestedWith + +instance Pretty TestedWith where + pretty x = case unpack x of + (compiler, vr) -> pretty compiler <+> pretty vr + +-- | This is /almost/ @'many' 'Distribution.Compat.P.anyChar'@, but it +-- +-- * trims whitespace from ends of the lines, +-- +-- * converts lines with only single dot into empty line. +-- +newtype FreeText = FreeText { getFreeText :: String } + +instance Newtype FreeText String where + pack = FreeText + unpack = getFreeText + +instance Parsec FreeText where + parsec = pack . dropDotLines <$ P.spaces <*> many P.anyChar + where + -- Example package with dot lines + -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal + dropDotLines "." = "." + dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x + dotToEmpty x | trim' x == "." = "" + dotToEmpty x = trim x + + trim' :: String -> String + trim' = dropWhileEnd (`elem` (" \t" :: String)) + + trim :: String -> String + trim = dropWhile isSpace . dropWhileEnd isSpace + +instance Pretty FreeText where + pretty = showFreeText . unpack + +-- | Filepath are parsed as 'Token'. +newtype FilePathNT = FilePathNT { getFilePathNT :: String } + +instance Newtype FilePathNT String where + pack = FilePathNT + unpack = getFilePathNT + +instance Parsec FilePathNT where + parsec = pack <$> parsecToken + +instance Pretty FilePathNT where + pretty = showFilePath . unpack + +------------------------------------------------------------------------------- +-- Internal +------------------------------------------------------------------------------- + +parsecTestedWith :: P.Stream s Identity Char => P.Parsec s [PWarning] (CompilerFlavor, VersionRange) +parsecTestedWith = do + name <- lexemeParsec + ver <- parsec <|> pure anyVersion + return (name, ver) diff --git a/cabal/Cabal/Distribution/Parsec/ParseResult.hs b/cabal/Cabal/Distribution/Parsec/ParseResult.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Parsec/ParseResult.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +-- | A parse result type for parsers from AST to Haskell types. +module Distribution.Parsec.ParseResult ( + ParseResult, + runParseResult, + recoverWith, + parseWarning, + parseWarnings, + parseFailure, + parseFatalFailure, + parseFatalFailure', + ) where + +import Distribution.Compat.Prelude +import Distribution.Parsec.Common + (PError (..), PWarnType (..), PWarning (..), Position (..), zeroPos) +import Prelude () + +#if MIN_VERSION_base(4,10,0) +import Control.Applicative (Applicative (..)) +#endif + +-- | A monad with failure and accumulating errors and warnings. +newtype ParseResult a = PR + { unPR + :: forall r. PRState + -> (PRState -> r) -- failure + -> (PRState -> a -> r) -- success + -> r + } + +data PRState = PRState ![PWarning] ![PError] + +emptyPRState :: PRState +emptyPRState = PRState [] [] + +-- | Destruct a 'ParseResult' into the emitted warnings and errors, and +-- possibly the final result if there were no errors. +runParseResult :: ParseResult a -> ([PWarning], [PError], Maybe a) +runParseResult pr = unPR pr emptyPRState failure success + where + failure (PRState warns errs) = (warns, errs, Nothing) + success (PRState warns []) x = (warns, [], Just x) + -- If there are any errors, don't return the result + success (PRState warns errs) _ = (warns, errs, Nothing) + +instance Functor ParseResult where + fmap f (PR pr) = PR $ \ !s failure success -> + pr s failure $ \ !s' a -> + success s' (f a) + {-# INLINE fmap #-} + +instance Applicative ParseResult where + pure x = PR $ \ !s _ success -> success s x + {-# INLINE pure #-} + + f <*> x = PR $ \ !s0 failure success -> + unPR f s0 failure $ \ !s1 f' -> + unPR x s1 failure $ \ !s2 x' -> + success s2 (f' x') + {-# INLINE (<*>) #-} + + x *> y = PR $ \ !s0 failure success -> + unPR x s0 failure $ \ !s1 _ -> + unPR y s1 failure success + {-# INLINE (*>) #-} + + x <* y = PR $ \ !s0 failure success -> + unPR x s0 failure $ \ !s1 x' -> + unPR y s1 failure $ \ !s2 _ -> + success s2 x' + {-# INLINE (<*) #-} + +#if MIN_VERSION_base(4,10,0) + liftA2 f x y = PR $ \ !s0 failure success -> + unPR x s0 failure $ \ !s1 x' -> + unPR y s1 failure $ \ !s2 y' -> + success s2 (f x' y') + {-# INLINE liftA2 #-} +#endif + +instance Monad ParseResult where + return = pure + (>>) = (*>) + + m >>= k = PR $ \ !s failure success -> + unPR m s failure $ \ !s' a -> + unPR (k a) s' failure success + {-# INLINE (>>=) #-} + +-- | "Recover" the parse result, so we can proceed parsing. +-- 'runParseResult' will still result in 'Nothing', if there are recorded errors. +recoverWith :: ParseResult a -> a -> ParseResult a +recoverWith (PR pr) x = PR $ \ !s _failure success -> + pr s (\ !s' -> success s' x) success + +-- | Add a warning. This doesn't fail the parsing process. +parseWarning :: Position -> PWarnType -> String -> ParseResult () +parseWarning pos t msg = PR $ \(PRState warns errs) _failure success -> + success (PRState (PWarning t pos msg : warns) errs) () + +-- | Add multiple warnings at once. +parseWarnings :: [PWarning] -> ParseResult () +parseWarnings newWarns = PR $ \(PRState warns errs) _failure success -> + success (PRState (newWarns ++ warns) errs) () + +-- | Add an error, but not fail the parser yet. +-- +-- For fatal failure use 'parseFatalFailure' +parseFailure :: Position -> String -> ParseResult () +parseFailure pos msg = PR $ \(PRState warns errs) _failure success -> + success (PRState warns (PError pos msg : errs)) () + +-- | Add an fatal error. +parseFatalFailure :: Position -> String -> ParseResult a +parseFatalFailure pos msg = PR $ \(PRState warns errs) failure _success -> + failure (PRState warns (PError pos msg : errs)) + +-- | A 'mzero'. +parseFatalFailure' :: ParseResult a +parseFatalFailure' = PR pr + where + pr (PRState warns []) failure _success = failure (PRState warns [err]) + pr s failure _success = failure s + + err = PError zeroPos "Unknown fatal error" diff --git a/cabal/Cabal/Distribution/Parsec/Parser.hs b/cabal/Cabal/Distribution/Parsec/Parser.hs --- a/cabal/Cabal/Distribution/Parsec/Parser.hs +++ b/cabal/Cabal/Distribution/Parsec/Parser.hs @@ -27,28 +27,25 @@ #endif ) where -import Prelude () -import Distribution.Compat.Prelude -import Control.Monad (guard) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 +import Control.Monad (guard) +import qualified Data.ByteString.Char8 as B8 import Data.Functor.Identity +import Distribution.Compat.Prelude +import Distribution.Parsec.Common +import Distribution.Parsec.Field import Distribution.Parsec.Lexer import Distribution.Parsec.LexerMonad - (LexResult (..), LexState (..), LexWarning (..), - LexWarningType (..), unLex) -import Distribution.Parsec.Types.Common -import Distribution.Parsec.Types.Field -import Distribution.Utils.String -import Text.Parsec.Combinator hiding (eof, notFollowedBy) + (LexResult (..), LexState (..), LexWarning (..), unLex) +import Prelude () +import Text.Parsec.Combinator hiding (eof, notFollowedBy) import Text.Parsec.Error import Text.Parsec.Pos -import Text.Parsec.Prim hiding (many, (<|>)) +import Text.Parsec.Prim hiding (many, (<|>)) #ifdef CABAL_PARSEC_DEBUG -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T #endif -- | The 'LexState'' (with a prime) is an instance of parsec's 'Stream' @@ -90,10 +87,9 @@ describeToken :: Token -> String describeToken t = case t of - TokSym s -> "name " ++ show s - TokStr s -> "string " ++ show s - TokNum s -> "number " ++ show s - TokOther s -> "symbol " ++ show s + TokSym s -> "symbol " ++ show s + TokStr s -> "string " ++ show s + TokOther s -> "operator " ++ show s Indent _ -> "new line" TokFieldLine _ -> "field content" Colon -> "\":\"" @@ -103,16 +99,15 @@ EOF -> "end of file" LexicalError is -> "character in input " ++ show (B8.head is) -tokName :: Parser (Name Position) -tokName', tokStr, tokNum, tokOther :: Parser (SectionArg Position) +tokSym :: Parser (Name Position) +tokSym', tokStr, tokOther :: Parser (SectionArg Position) tokIndent :: Parser Int tokColon, tokOpenBrace, tokCloseBrace :: Parser () tokFieldLine :: Parser (FieldLine Position) -tokName = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (mkName pos x); _ -> Nothing -tokName' = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (SecArgName pos x); _ -> Nothing +tokSym = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (mkName pos x); _ -> Nothing +tokSym' = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (SecArgName pos x); _ -> Nothing tokStr = getTokenWithPos $ \t -> case t of L pos (TokStr x) -> Just (SecArgStr pos x); _ -> Nothing -tokNum = getTokenWithPos $ \t -> case t of L pos (TokNum x) -> Just (SecArgNum pos x); _ -> Nothing tokOther = getTokenWithPos $ \t -> case t of L pos (TokOther x) -> Just (SecArgOther pos x); _ -> Nothing tokIndent = getToken $ \t -> case t of Indent x -> Just x; _ -> Nothing tokColon = getToken $ \t -> case t of Colon -> Just (); _ -> Nothing @@ -123,11 +118,10 @@ colon, openBrace, closeBrace :: Parser () sectionArg :: Parser (SectionArg Position) -sectionArg = tokName' <|> tokStr - <|> tokNum <|> tokOther "section parameter" +sectionArg = tokSym' <|> tokStr <|> tokOther "section parameter" fieldSecName :: Parser (Name Position) -fieldSecName = tokName "field or section name" +fieldSecName = tokSym "field or section name" colon = tokColon "\":\"" openBrace = tokOpenBrace "\"{\"" @@ -326,28 +320,9 @@ parser = do fields <- cabalStyleFile ws <- getLexerWarnings - pure (fields, maybeToList w ++ ws) - - (w, s') = fmap B.pack . recodeStringUtf8 . B.unpack $ s - lexSt = mkLexState' (mkLexState s') + pure (fields, ws) --- TODO: For some reason alex parser cannot handle BOM. --- --- There is $bom token in the lexer, but for some reason it's not matched, --- and alex chockes. --- --- It might be that I (phadej) don't have enough alex-fu --- --- Anyway, we probably should operate alex in the byte mode, and do utf8 decoding --- later in the fields where it's required (as we actually do atm). We'd need --- alex-3.2 for that. -recodeStringUtf8 :: [Word8] -> (Maybe LexWarning, [Word8]) -recodeStringUtf8 (0xef : 0xbb : 0xbf : bytes) = - ( Just $ LexWarning LexWarningBOM (Position 1 1) "Byte-order mark found" - , encodeStringUtf8 (decodeStringUtf8 bytes) - ) -recodeStringUtf8 bytes = - (Nothing, encodeStringUtf8 (decodeStringUtf8 bytes)) + lexSt = mkLexState' (mkLexState s) #ifdef CABAL_PARSEC_DEBUG parseTest' :: Show a => Parsec LexState' () a -> SourceName -> B8.ByteString -> IO () diff --git a/cabal/Cabal/Distribution/Parsec/Types/Common.hs b/cabal/Cabal/Distribution/Parsec/Types/Common.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Parsec/Types/Common.hs +++ /dev/null @@ -1,89 +0,0 @@ --- | Module containing small types -module Distribution.Parsec.Types.Common ( - -- * Diagnostics - PError (..), - showPError, - PWarning (..), - PWarnType (..), - showPWarning, - -- * Field parser - FieldParser, - -- * Position - Position (..), - incPos, - retPos, - showPos, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import System.FilePath (normalise) -import qualified Text.Parsec as Parsec - --- | Parser error. -data PError = PError Position String - deriving (Show) - --- | Type of parser warning. We do classify warnings. --- --- Different application may decide not to show some, or have fatal behaviour on others -data PWarnType - = PWTOther -- ^ Unclassified warning - | PWTUTF -- ^ Invalid UTF encoding - | PWTBoolCase -- ^ @true@ or @false@, not @True@ or @False@ - | PWTGluedOperators -- ^ @&&!@ - | PWTVersionTag -- ^ there are version with tags - | PWTNewSyntax -- ^ New syntax used, but no @cabal-version: >= 1.2@ specified - | PWTOldSyntax -- ^ Old syntax used, and @cabal-version >= 1.2@ specified - | PWTDeprecatedField - | PWTInvalidSubsection - | PWTUnknownField - | PWTUnknownSection - | PWTTrailingFields - | PWTExtraMainIs -- ^ extra main-is field - | PWTExtraTestModule -- ^ extra test-module field - | PWTExtraBenchmarkModule -- ^ extra benchmark-module field - | PWTLexNBSP - | PWTLexBOM - deriving (Eq, Ord, Show, Enum, Bounded) - --- | Parser warning. -data PWarning = PWarning !PWarnType !Position String - deriving (Show) - -showPWarning :: FilePath -> PWarning -> String -showPWarning fpath (PWarning _ pos msg) = - normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg - -showPError :: FilePath -> PError -> String -showPError fpath (PError pos msg) = - normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg - -------------------------------------------------------------------------------- --- Field parser -------------------------------------------------------------------------------- - --- | Field value parsers. -type FieldParser = Parsec.Parsec String [PWarning] -- :: * -> * - - -------------------------------------------------------------------------------- --- Position -------------------------------------------------------------------------------- - --- | 1-indexed row and column positions in a file. -data Position = Position - {-# UNPACK #-} !Int -- row - {-# UNPACK #-} !Int -- column - deriving (Eq, Show) - --- | Shift position by n columns to the right. -incPos :: Int -> Position -> Position -incPos n (Position row col) = Position row (col + n) - --- | Shift position to beginning of next row. -retPos :: Position -> Position -retPos (Position row _col) = Position (row + 1) 1 - -showPos :: Position -> String -showPos (Position row col) = show row ++ ":" ++ show col diff --git a/cabal/Cabal/Distribution/Parsec/Types/Field.hs b/cabal/Cabal/Distribution/Parsec/Types/Field.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Parsec/Types/Field.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} --- | Cabal-like file AST types: 'Field', 'Section' etc --- --- These types are parametrized by an annotation. -module Distribution.Parsec.Types.Field ( - -- * Cabal file - Field (..), - fieldAnn, - FieldLine (..), - SectionArg (..), - sectionArgAnn, - -- * Name - Name (..), - mkName, - getName, - nameAnn, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Data.Char as Char - -------------------------------------------------------------------------------- --- Cabal file -------------------------------------------------------------------------------- - --- | A Cabal-like file consists of a series of fields (@foo: bar@) and sections (@library ...@). -data Field ann - = Field !(Name ann) [FieldLine ann] - | Section !(Name ann) [SectionArg ann] [Field ann] - deriving (Eq, Show, Functor) - -fieldAnn :: Field ann -> ann -fieldAnn (Field (Name ann _) _) = ann -fieldAnn (Section (Name ann _) _ _) = ann - --- | A line of text representing the value of a field from a Cabal file. --- A field may contain multiple lines. --- --- /Invariant:/ 'ByteString' has no newlines. -data FieldLine ann = FieldLine !ann !ByteString - deriving (Eq, Show, Functor) - --- | Section arguments, e.g. name of the library -data SectionArg ann - = SecArgName !ann !ByteString - -- ^ identifier - | SecArgStr !ann !String - -- ^ quoted string - | SecArgNum !ann !ByteString - -- ^ Something which loos like number. Also many dot numbers, i.e. "7.6.3" - | SecArgOther !ann !ByteString - -- ^ everything else, mm. operators (e.g. in if-section conditionals) - deriving (Eq, Show, Functor) - --- | Extract annotation from 'SectionArg'. -sectionArgAnn :: SectionArg ann -> ann -sectionArgAnn (SecArgName ann _) = ann -sectionArgAnn (SecArgStr ann _) = ann -sectionArgAnn (SecArgNum ann _) = ann -sectionArgAnn (SecArgOther ann _) = ann - -------------------------------------------------------------------------------- --- Name -------------------------------------------------------------------------------- - --- | A field name. --- --- /Invariant/: 'ByteString' is lower-case ASCII. -data Name ann = Name !ann !ByteString - deriving (Eq, Show, Functor) - -mkName :: ann -> ByteString -> Name ann -mkName ann bs = Name ann (B.map Char.toLower bs) - -getName :: Name ann -> ByteString -getName (Name _ bs) = bs - -nameAnn :: Name ann -> ann -nameAnn (Name ann _) = ann diff --git a/cabal/Cabal/Distribution/Parsec/Types/FieldDescr.hs b/cabal/Cabal/Distribution/Parsec/Types/FieldDescr.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Parsec/Types/FieldDescr.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Parsec.Types.FieldDescr --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- -module Distribution.Parsec.Types.FieldDescr ( - -- * Field name - FieldName, - -- * Field description - FieldDescr (..), - liftField, - simpleField, - boolField, - optsField, - listField, - listFieldWithSep, - commaListField, - commaListFieldWithSep, - spaceListField, - -- ** Pretty printing - ppFields, - ppField, - -- * Unknown fields - UnknownFieldParser, - warnUnrec, - ignoreUnrec, - ) where - -import Prelude () -import Distribution.Compat.Prelude hiding (get) -import qualified Data.ByteString as BS -import Data.Ord (comparing) -import qualified Distribution.Compat.Parsec as P -import Distribution.Compiler (CompilerFlavor) -import Distribution.Parsec.Class -import Distribution.Parsec.Types.Common -import Distribution.PrettyUtils -import Text.PrettyPrint - (Doc, colon, comma, fsep, hsep, isEmpty, nest, punctuate, - text, vcat, ($+$), (<+>)) - -type FieldName = BS.ByteString - -------------------------------------------------------------------------------- --- Unrecoginsed fields -------------------------------------------------------------------------------- - --- | How to handle unknown fields. -type UnknownFieldParser a = FieldName -> String -> a -> Maybe a - --- | A default unrecognized field parser which simply returns Nothing, --- i.e. ignores all unrecognized fields, so warnings will be generated. -warnUnrec :: UnknownFieldParser a -warnUnrec _ _ _ = Nothing - --- | A default unrecognized field parser which silently (i.e. no --- warnings will be generated) ignores unrecognized fields, by --- returning the structure being built unmodified. -ignoreUnrec :: UnknownFieldParser a -ignoreUnrec _ _ = Just - -------------------------------------------------------------------------------- --- Field description -------------------------------------------------------------------------------- - -data FieldDescr a = FieldDescr - { fieldName :: FieldName - , fieldPretty :: a -> Doc - , fieldParser :: a -> FieldParser a - } - -liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b -liftField get set fd = FieldDescr - (fieldName fd) - (fieldPretty fd . get) - (\b -> flip set b <$> fieldParser fd (get b)) - -simpleField - :: FieldName -- ^ fieldname - -> (a -> Doc) -- ^ show - -> FieldParser a -- ^ parser - -> (b -> a) -- ^ getter - -> (a -> b -> b) -- ^ setter - -> FieldDescr b -simpleField name pretty parse get set = FieldDescr - name - (pretty . get) - (\a -> flip set a <$> parse) - -boolField - :: FieldName - -> (b -> Bool) - -> (Bool -> b -> b) - -> FieldDescr b -boolField name get set = liftField get set (FieldDescr name showF parseF) - where - showF = text . show - parseF _ = P.munch1 isAlpha >>= postprocess - postprocess str - | str == "True" = pure True - | str == "False" = pure False - | lstr == "true" = parsecWarning PWTBoolCase caseWarning *> pure True - | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False - | otherwise = fail $ "Not a boolena: " ++ str - where - lstr = map toLower str - caseWarning = - "The " ++ show name ++ " field is case sensitive, use 'True' or 'False'." - -optsField - :: FieldName - -> CompilerFlavor - -> (b -> [(CompilerFlavor,[String])]) - -> ([(CompilerFlavor,[String])] -> b -> b) - -> FieldDescr b -optsField name flavor get set = liftField - (fromMaybe [] . lookup flavor . get) - (\opts b -> set (reorder (update flavor opts (get b))) b) - $ field name showF (many $ parsecToken' <* P.munch isSpace) - where - update _ opts l | all null opts = l --empty opts as if no opts - update f opts [] = [(f,opts)] - update f opts ((f',opts'):rest) - | f == f' = (f, opts' ++ opts) : rest - | otherwise = (f',opts') : update f opts rest - reorder = sortBy (comparing fst) - showF = hsep . map text - -listField - :: FieldName - -> (a -> Doc) - -> FieldParser a - -> (b -> [a]) - -> ([a] -> b -> b) - -> FieldDescr b -listField = listFieldWithSep fsep - -listFieldWithSep - :: Separator - -> FieldName - -> (a -> Doc) - -> FieldParser a - -> (b -> [a]) - -> ([a] -> b -> b) - -> FieldDescr b -listFieldWithSep separator name showF parseF get set = - liftField get set' $ - field name showF' (parsecOptCommaList parseF) - where - set' xs b = set (get b ++ xs) b - showF' = separator . map showF - - -commaListField - :: FieldName -> (a -> Doc) -> FieldParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -commaListField = commaListFieldWithSep fsep - -commaListFieldWithSep - :: Separator -> FieldName -> (a -> Doc) -> FieldParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -commaListFieldWithSep separator name showF parseF get set = - liftField get set' $ - field name showF' (parsecCommaList parseF) - where - set' xs b = set (get b ++ xs) b - showF' = separator . punctuate comma . map showF - -spaceListField - :: FieldName -> (a -> Doc) -> FieldParser a - -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b -spaceListField name showF parseF get set = liftField get set' $ - field name showF' (many $ parseF <* P.spaces) - where - set' xs b = set (get b ++ xs) b - showF' = fsep . map showF - --- Overriding field -field :: FieldName -> (a -> Doc) -> FieldParser a -> FieldDescr a -field name showF parseF = - FieldDescr name showF (const parseF) - -------------------------------------------------------------------------------- --- Pretty printing -------------------------------------------------------------------------------- - -ppFields :: [FieldDescr a] -> a -> Doc -ppFields fields x = - vcat [ ppField name (getter x) | FieldDescr name getter _ <- fields ] - -ppField :: FieldName -> Doc -> Doc -ppField name fielddoc - | isEmpty fielddoc = mempty - | name `elem` nestedFields = text namestr <<>> colon $+$ nest indentWith fielddoc - | otherwise = text namestr <<>> colon <+> fielddoc - where - namestr = show name -- TODO: do this - nestedFields :: [BS.ByteString] - nestedFields = - [ "description" - , "build-depends" - , "data-files" - , "extra-source-files" - , "extra-tmp-files" - , "exposed-modules" - , "c-sources" - , "js-sources" - , "extra-libraries" - , "includes" - , "install-includes" - , "other-modules" - , "depends" - ] - --- | Handle deprecated fields --- --- *TODO:* use Parsec -{- -deprecField :: Field Position -> Parsec (Field Position) -deprecField = undefined {- --} - - (Field (Name pos fld) val) = do - fld' <- case lookup fld deprecatedFields of - Nothing -> return fld - Just newName -> do - warning $ "The field " ++ show fld - ++ " is deprecated, please use " ++ show newName - return newName - return (Field (Name pos fld') val) -deprecField _ = cabalBug "'deprecField' called on a non-field" --} diff --git a/cabal/Cabal/Distribution/Parsec/Types/ParseResult.hs b/cabal/Cabal/Distribution/Parsec/Types/ParseResult.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Parsec/Types/ParseResult.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE CPP #-} --- | A parse result type for parsers from AST to Haskell types. -module Distribution.Parsec.Types.ParseResult ( - ParseResult, - runParseResult, - recoverWith, - parseWarning, - parseFailure, - parseFatalFailure, - parseFatalFailure', - parseWarnings', - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Parsec.Types.Common - (PError (..), PWarnType (..), PWarning (..), Position (..)) - --- | A monad with failure and accumulating errors and warnings. -newtype ParseResult a = PR { runPR :: PRState -> (Maybe a, PRState) } - -data PRState = PRState ![PWarning] ![PError] - -emptyPRState :: PRState -emptyPRState = PRState [] [] - --- | Destruct a 'ParseResult' into the emitted warnings and errors, and --- possibly the final result if there were no errors. -runParseResult :: ParseResult a -> ([PWarning], [PError], Maybe a) -runParseResult pr = case runPR pr emptyPRState of - (res, PRState warns errs) - -- If there are any errors, don't return the result - | null errs -> (warns, [], res) - | otherwise -> (warns, errs, Nothing) - -instance Functor ParseResult where - fmap f (PR pr) = PR $ \s -> case pr s of - (r, s') -> (fmap f r, s') - -instance Applicative ParseResult where - pure x = PR $ \s -> (Just x, s) - -- | Make it concat perrors - (<*>) = ap - PR a *> PR b = PR $ \s0 -> case a s0 of - (x, s1) -> case b s1 of - (y, s2) -> (x *> y, s2) - -instance Monad ParseResult where - return = pure - (>>) = (*>) - PR m >>= k = PR $ \s -> case m s of - (Nothing, s') -> (Nothing, s') - (Just x, s') -> runPR (k x) s' - --- | "Recover" the parse result, so we can proceed parsing. --- 'runParseResult' will still result in 'Nothing', if there are recorded errors. -recoverWith :: ParseResult a -> a -> ParseResult a -recoverWith (PR f) x = PR $ \s -> case f s of - (Nothing, s') -> (Just x, s') - r -> r - -parseWarning :: Position -> PWarnType -> String -> ParseResult () -parseWarning pos t msg = PR $ \(PRState warns errs) -> - (Just (), PRState (PWarning t pos msg : warns) errs) - -parseWarnings' :: [PWarning] -> ParseResult () -parseWarnings' newWarns = PR $ \(PRState warns errs) -> - (Just (), PRState (warns ++ newWarns) errs) - --- | Add an error, but not fail the parser yet. --- --- For fatal failure use 'parseFatalFailure' -parseFailure :: Position -> String -> ParseResult () -parseFailure pos msg = PR $ \(PRState warns errs) -> - (Just (), PRState warns (PError pos msg : errs)) - --- | Add an fatal error. -parseFatalFailure :: Position -> String -> ParseResult a -parseFatalFailure pos msg = PR $ \(PRState warns errs) -> - (Nothing, PRState warns (PError pos msg : errs)) - -parseFatalFailure' :: ParseResult a -parseFatalFailure' = PR f - where - f s@(PRState warns errs) - | null errs = (Nothing, PRState warns [PError (Position 0 0) "Unknown failure"]) - | otherwise = (Nothing, s) diff --git a/cabal/Cabal/Distribution/Pretty.hs b/cabal/Cabal/Distribution/Pretty.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Pretty.hs @@ -0,0 +1,95 @@ +module Distribution.Pretty ( + Pretty (..), + prettyShow, + defaultStyle, + flatStyle, + -- * Utilities + showFilePath, + showToken, + showFreeText, + indentWith, + -- * Deprecated + Separator, + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Data.Functor.Identity (Identity (..)) + +import qualified Text.PrettyPrint as PP + +class Pretty a where + pretty :: a -> PP.Doc + +instance Pretty Bool where + pretty = PP.text . show + +instance Pretty Int where + pretty = PP.text . show + +instance Pretty a => Pretty (Identity a) where + pretty = pretty . runIdentity + +prettyShow :: Pretty a => a -> String +prettyShow = PP.renderStyle defaultStyle . pretty + +-- | The default rendering style used in Cabal for console +-- output. It has a fixed page width and adds line breaks +-- automatically. +defaultStyle :: PP.Style +defaultStyle = PP.Style { PP.mode = PP.PageMode + , PP.lineLength = 79 + , PP.ribbonsPerLine = 1.0 + } + +-- | A style for rendering all on one line. +flatStyle :: PP.Style +flatStyle = PP.Style { PP.mode = PP.LeftMode + , PP.lineLength = err "lineLength" + , PP.ribbonsPerLine = err "ribbonsPerLine" + } + where + err x = error ("flatStyle: tried to access " ++ x ++ " in LeftMode. " ++ + "This should never happen and indicates a bug in Cabal.") + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +-- TODO: remove when ReadP parser is gone. +type Separator = [PP.Doc] -> PP.Doc + +showFilePath :: FilePath -> PP.Doc +showFilePath = showToken + +showToken :: String -> PP.Doc +showToken str + -- if token looks like a comment (starts with --), print it in quotes + | "--" `isPrefixOf` str = PP.text (show str) + -- also if token ends with a colon (e.g. executable name), print it in quotes + | ":" `isSuffixOf` str = PP.text (show str) + | not (any dodgy str) && not (null str) = PP.text str + | otherwise = PP.text (show str) + where + dodgy c = isSpace c || c == ',' + + +-- | Pretty-print free-format text, ensuring that it is vertically aligned, +-- and with blank lines replaced by dots for correct re-parsing. +showFreeText :: String -> PP.Doc +showFreeText "" = mempty +showFreeText s = PP.vcat [ PP.text (if null l then "." else l) | l <- lines_ s ] + +-- | 'lines_' breaks a string up into a list of strings at newline +-- characters. The resulting strings do not contain newlines. +lines_ :: String -> [String] +lines_ [] = [""] +lines_ s = + let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines_ s'' + +-- | the indentation used for pretty printing +indentWith :: Int +indentWith = 4 diff --git a/cabal/Cabal/Distribution/PrettyUtils.hs b/cabal/Cabal/Distribution/PrettyUtils.hs --- a/cabal/Cabal/Distribution/PrettyUtils.hs +++ b/cabal/Cabal/Distribution/PrettyUtils.hs @@ -9,7 +9,7 @@ -- -- Utilities for pretty printing. {-# OPTIONS_HADDOCK hide #-} -module Distribution.PrettyUtils ( +module Distribution.PrettyUtils {-# DEPRECATED "Use Distribution.Pretty" #-} ( Separator, -- * Internal showFilePath, @@ -19,46 +19,5 @@ indentWith, ) where -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Compiler (CompilerFlavor) -import Distribution.Version (VersionRange) - -import Distribution.Text (disp) -import Text.PrettyPrint (Doc, text, vcat, (<+>)) - -type Separator = ([Doc] -> Doc) - -showFilePath :: FilePath -> Doc -showFilePath "" = mempty -showFilePath x = showToken x - -showToken :: String -> Doc -showToken str - | not (any dodgy str) && not (null str) = text str - | otherwise = text (show str) - where - dodgy c = isSpace c || c == ',' - -showTestedWith :: (CompilerFlavor, VersionRange) -> Doc -showTestedWith (compiler, vr) = text (show compiler) <+> disp vr - --- | Pretty-print free-format text, ensuring that it is vertically aligned, --- and with blank lines replaced by dots for correct re-parsing. -showFreeText :: String -> Doc -showFreeText "" = mempty -showFreeText s = vcat [text (if null l then "." else l) | l <- lines_ s] - --- | 'lines_' breaks a string up into a list of strings at newline --- characters. The resulting strings do not contain newlines. -lines_ :: String -> [String] -lines_ [] = [""] -lines_ s = let (l, s') = break (== '\n') s - in l : case s' of - [] -> [] - (_:s'') -> lines_ s'' - --- | the indentation used for pretty printing -indentWith :: Int -indentWith = 4 +import Distribution.Pretty +import Distribution.ParseUtils diff --git a/cabal/Cabal/Distribution/ReadE.hs b/cabal/Cabal/Distribution/ReadE.hs --- a/cabal/Cabal/Distribution/ReadE.hs +++ b/cabal/Cabal/Distribution/ReadE.hs @@ -14,13 +14,15 @@ ReadE(..), succeedReadE, failReadE, -- * Projections parseReadE, readEOrFail, - readP_to_E + readP_to_E, + parsecToReadE, ) where import Prelude () import Distribution.Compat.Prelude import Distribution.Compat.ReadP +import qualified Distribution.Compat.Parsec as P -- | Parser with simple error reporting newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} @@ -45,9 +47,17 @@ readEOrFail :: ReadE a -> String -> a readEOrFail r = either error id . runReadE r +-- {-# DEPRECATED readP_to_E "Use parsecToReadE" #-} readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a readP_to_E err r = ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt , all isSpace s ] of [] -> Left (err txt) (p:_) -> Right p + +parsecToReadE :: (String -> ErrorMsg) -> P.Parsec String [w] a -> ReadE a +parsecToReadE err p = ReadE $ \txt -> + case P.runParser (p <* P.spaces <* P.eof) [] "" txt of + Right x -> Right x + Left _e -> Left (err txt) +-- TODO: use parsec error to make 'ErrorMsg'. 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 @@ -49,7 +49,7 @@ -- * Customization UserHooks(..), Args, defaultMainWithHooks, defaultMainWithHooksArgs, - defaultMainWithHooksNoRead, + defaultMainWithHooksNoRead, defaultMainWithHooksNoReadArgs, -- ** Standard sets of hooks simpleUserHooks, autoconfUserHooks, @@ -85,6 +85,7 @@ import Distribution.Simple.Test import Distribution.Simple.Install import Distribution.Simple.Haddock +import Distribution.Simple.Doctest import Distribution.Simple.Utils import Distribution.Utils.NubList import Distribution.Verbosity @@ -104,12 +105,7 @@ import Data.List (unionBy, (\\)) -#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec -import Distribution.PackageDescription.Parse (readHookedBuildInfo) -#else -import Distribution.PackageDescription.Parse -#endif -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the @@ -142,6 +138,14 @@ getArgs >>= defaultMainHelper hooks { readDesc = return (Just pkg_descr) } +-- | A customizable version of 'defaultMainNoRead' that also takes the +-- command line arguments. +-- +-- @since 2.2.0.0 +defaultMainWithHooksNoReadArgs :: UserHooks -> GenericPackageDescription -> [String] -> IO () +defaultMainWithHooksNoReadArgs hooks pkg_descr = + defaultMainHelper hooks { readDesc = return (Just pkg_descr) } + defaultMainHelper :: UserHooks -> Args -> IO () defaultMainHelper hooks args = topHandler $ case commandsRun (globalCommand commands) commands args of @@ -175,6 +179,7 @@ ,replCommand progs `commandAddAction` replAction hooks ,installCommand `commandAddAction` installAction hooks ,copyCommand `commandAddAction` copyAction hooks + ,doctestCommand `commandAddAction` doctestAction hooks ,haddockCommand `commandAddAction` haddockAction hooks ,cleanCommand `commandAddAction` cleanAction hooks ,sdistCommand `commandAddAction` sdistAction hooks @@ -235,12 +240,8 @@ pdfile <- case mb_path of Nothing -> defaultPackageDesc verbosity Just path -> return path -#ifdef CABAL_PARSEC info verbosity "Using Parsec parser" descr <- readGenericPackageDescription verbosity pdfile -#else - descr <- readPackageDescription verbosity pdfile -#endif return (Just pdfile, descr) buildAction :: UserHooks -> BuildFlags -> Args -> IO () @@ -292,6 +293,22 @@ (getBuildConfig hooks verbosity distPref) hooks flags' args +doctestAction :: UserHooks -> DoctestFlags -> Args -> IO () +doctestAction hooks flags args = do + distPref <- findDistPrefOrDefault (doctestDistPref flags) + let verbosity = fromFlag $ doctestVerbosity flags + flags' = flags { doctestDistPref = toFlag distPref } + + lbi <- getBuildConfig hooks verbosity distPref + progs <- reconfigurePrograms verbosity + (doctestProgramPaths flags') + (doctestProgramArgs flags') + (withPrograms lbi) + + hookedAction preDoctest doctestHook postDoctest + (return lbi { withPrograms = progs }) + hooks flags' args + haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () haddockAction hooks flags args = do distPref <- findDistPrefOrDefault (haddockDistPref flags) @@ -564,6 +581,7 @@ cleanHook = \p _ _ f -> clean p f, hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f, haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f, + doctestHook = \p l h f -> doctest p l (allSuffixHandlers h) f, regHook = defaultRegHook, unregHook = \p l _ f -> unregister p l f } diff --git a/cabal/Cabal/Distribution/Simple/Bench.hs b/cabal/Cabal/Distribution/Simple/Bench.hs --- a/cabal/Cabal/Distribution/Simple/Bench.hs +++ b/cabal/Cabal/Distribution/Simple/Bench.hs @@ -21,7 +21,7 @@ import Prelude () import Distribution.Compat.Prelude -import Distribution.Package +import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler @@ -58,7 +58,7 @@ benchmarkOptions flags -- Check that the benchmark executable exists. exists <- doesFileExist cmd - unless exists $ die $ + unless exists $ die' verbosity $ "Error: Could not find benchmark program \"" ++ cmd ++ "\". Did you build the package first?" @@ -81,7 +81,7 @@ exitSuccess when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ - die $ "No benchmarks enabled. Did you remember to configure with " + die' verbosity $ "No benchmarks enabled. Did you remember to configure with " ++ "\'--enable-benchmarks\'?" bmsToRun <- case benchmarkNames of @@ -93,9 +93,9 @@ in case lookup (mkUnqualComponentName bmName) benchmarkMap of Just t -> return t _ | mkUnqualComponentName bmName `elem` allNames -> - die $ "Package configured with benchmark " + die' verbosity $ "Package configured with benchmark " ++ bmName ++ " disabled." - | otherwise -> die $ "no such benchmark: " ++ bmName + | otherwise -> die' verbosity $ "no such benchmark: " ++ bmName let totalBenchmarks = length bmsToRun notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." 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 @@ -23,19 +23,27 @@ startInterpreter, initialBuildSteps, + componentInitialBuildSteps, writeAutogenFiles, ) where import Prelude () import Distribution.Compat.Prelude +import Distribution.Types.Dependency import Distribution.Types.LocalBuildInfo import Distribution.Types.TargetInfo import Distribution.Types.ComponentRequestedSpec import Distribution.Types.ForeignLib +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.UnqualComponentName +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ExecutableScope import Distribution.Package import Distribution.Backpack +import Distribution.Backpack.DescribeUnitId import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.JHC as JHC @@ -56,6 +64,7 @@ import Distribution.Simple.Setup import Distribution.Simple.BuildTarget +import Distribution.Simple.BuildToolDepends import Distribution.Simple.PreProcess import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program.Types @@ -74,7 +83,6 @@ import Control.Monad import qualified Data.Set as Set -import Data.List ( intersect ) import System.FilePath ( (), (<.>), takeDirectory ) import System.Directory ( getCurrentDirectory ) @@ -103,7 +111,7 @@ (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do let comp = targetComponent target clbi = targetCLBI target - initialBuildSteps distPref pkg_descr lbi clbi verbosity + componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity let bi = componentBuildInfo comp progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) lbi' = lbi { @@ -134,7 +142,7 @@ -- This seems DEEPLY questionable. [] -> return (head (allTargetsInBuildOrder' pkg_descr lbi)) [target] -> return target - _ -> die $ "The 'repl' command does not support multiple targets at once." + _ -> die' verbosity $ "The 'repl' command does not support multiple targets at once." let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] debug verbosity $ "Component build order: " ++ intercalate ", " @@ -155,7 +163,7 @@ [ do let clbi = targetCLBI subtarget comp = targetComponent subtarget lbi' = lbiForComponent comp lbi - initialBuildSteps distPref pkg_descr lbi clbi verbosity + componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity buildComponent verbosity NoFlag pkg_descr lbi' suffixes comp clbi distPref | subtarget <- init componentsToBuild ] @@ -164,7 +172,7 @@ let clbi = targetCLBI target comp = targetComponent target lbi' = lbiForComponent comp lbi - initialBuildSteps distPref pkg_descr lbi clbi verbosity + componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity replComponent verbosity pkg_descr lbi' suffixes comp clbi distPref @@ -175,7 +183,7 @@ case compilerFlavor comp of GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs - _ -> die "A REPL is not supported with this compiler." + _ -> die' verbosity "A REPL is not supported with this compiler." buildComponent :: Verbosity -> Flag (Maybe Int) @@ -189,12 +197,11 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes comp@(CLib lib) clbi distPref = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi - case libName lib of - Nothing -> info verbosity $ "Building library..." - Just n -> info verbosity $ "Building library " ++ display n ++ "..." + extras <- preprocessExtras verbosity comp lbi + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = addExtraCSources libbi extras } + lib' = lib { libBuildInfo = addExtraCxxSources (addExtraCSources libbi extras) extras } buildLib verbosity numJobs pkg_descr lbi lib' clbi let oneComponentRequested (OneComponentRequestedSpec _) = True @@ -209,26 +216,33 @@ pwd <- getCurrentDirectory let -- The in place registration uses the "-inplace" suffix, not an ABI hash installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr - (mkAbiHash "") lib' lbi clbi + -- NB: Use a fake ABI hash to avoid + -- needing to recompute it every build. + (mkAbiHash "inplace") lib' lbi clbi debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo) - registerPackage verbosity (compiler lbi) (withPrograms lbi) HcPkg.MultiInstance + registerPackage verbosity (compiler lbi) (withPrograms lbi) (withPackageDB lbi) installedPkgInfo + HcPkg.defaultRegisterOptions { + HcPkg.registerMultiInstance = True + } return (Just installedPkgInfo) else return Nothing buildComponent verbosity numJobs pkg_descr lbi suffixes comp@(CFLib flib) clbi _distPref = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - info verbosity $ "Building foreign library " ++ display (foreignLibName flib) ++ "..." + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) buildFLib verbosity numJobs pkg_descr lbi flib clbi return Nothing buildComponent verbosity numJobs pkg_descr lbi suffixes comp@(CExe exe) clbi _ = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi - info verbosity $ "Building executable " ++ display (exeName exe) ++ "..." + extras <- preprocessExtras verbosity comp lbi + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) let ebi = buildInfo exe exe' = exe { buildInfo = addExtraCSources ebi extras } buildExe verbosity numJobs pkg_descr lbi exe' clbi @@ -240,8 +254,9 @@ clbi _distPref = do let exe = testSuiteExeV10AsExe test preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi - info verbosity $ "Building test suite " ++ display (testName test) ++ "..." + extras <- preprocessExtras verbosity comp lbi + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) let ebi = buildInfo exe exe' = exe { buildInfo = addExtraCSources ebi extras } buildExe verbosity numJobs pkg_descr lbi exe' clbi @@ -261,24 +276,31 @@ let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi - info verbosity $ "Building test suite " ++ display (testName test) ++ "..." + extras <- preprocessExtras verbosity comp lbi + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) buildLib verbosity numJobs pkg lbi lib libClbi -- NB: need to enable multiple instances here, because on 7.10+ -- the package name is the same as the library, and we still -- want the registration to go through. - registerPackage verbosity (compiler lbi) (withPrograms lbi) HcPkg.MultiInstance + registerPackage verbosity (compiler lbi) (withPrograms lbi) (withPackageDB lbi) ipi + HcPkg.defaultRegisterOptions { + HcPkg.registerMultiInstance = True + } let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } + -- NB: The stub executable is linked against the test-library + -- which already contains all `other-modules`, so we need + -- to remove those from the stub-exe's build-info + exe' = exe { buildInfo = (addExtraCSources ebi extras) { otherModules = [] } } buildExe verbosity numJobs pkg_descr lbi exe' exeClbi return Nothing -- Can't depend on test suite -buildComponent _ _ _ _ _ +buildComponent verbosity _ _ _ _ (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) _ _ = - die $ "No support for building test suite type " ++ display tt + die' verbosity $ "No support for building test suite type " ++ display tt buildComponent verbosity numJobs pkg_descr lbi suffixes @@ -286,18 +308,19 @@ clbi _ = do let (exe, exeClbi) = benchmarkExeV10asExe bm clbi preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi - info verbosity $ "Building benchmark " ++ display (benchmarkName bm) ++ "..." + extras <- preprocessExtras verbosity comp lbi + setupMessage' verbosity "Building" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) let ebi = buildInfo exe exe' = exe { buildInfo = addExtraCSources ebi extras } buildExe verbosity numJobs pkg_descr lbi exe' exeClbi return Nothing -buildComponent _ _ _ _ _ +buildComponent verbosity _ _ _ _ (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) _ _ = - die $ "No support for building benchmark type " ++ display tt + die' verbosity $ "No support for building benchmark type " ++ display tt -- | Add extra C sources generated by preprocessing to build @@ -309,6 +332,15 @@ exs = Set.fromList extras +-- | Add extra C++ sources generated by preprocessing to build +-- information. +addExtraCxxSources :: BuildInfo -> [FilePath] -> BuildInfo +addExtraCxxSources bi extras = bi { cxxSources = new } + where new = Set.toList $ old `Set.union` exs + old = Set.fromList $ cxxSources bi + exs = Set.fromList extras + + replComponent :: Verbosity -> PackageDescription -> LocalBuildInfo @@ -320,7 +352,7 @@ replComponent verbosity pkg_descr lbi suffixes comp@(CLib lib) clbi _ = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi let libbi = libBuildInfo lib lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } replLib verbosity pkg_descr lbi lib' clbi @@ -333,7 +365,7 @@ replComponent verbosity pkg_descr lbi suffixes comp@(CExe exe) clbi _ = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi let ebi = buildInfo exe exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } replExe verbosity pkg_descr lbi exe' clbi @@ -344,7 +376,7 @@ clbi _distPref = do let exe = testSuiteExeV10AsExe test preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi let ebi = buildInfo exe exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } replExe verbosity pkg_descr lbi exe' clbi @@ -358,16 +390,16 @@ let (pkg, lib, libClbi, lbi, _, _, _) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi let libbi = libBuildInfo lib lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } replLib verbosity pkg lbi lib' libClbi -replComponent _ _ _ _ +replComponent verbosity _ _ _ (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) _ _ = - die $ "No support for building test suite type " ++ display tt + die' verbosity $ "No support for building test suite type " ++ display tt replComponent verbosity pkg_descr lbi suffixes @@ -375,16 +407,16 @@ clbi _ = do let (exe, exeClbi) = benchmarkExeV10asExe bm clbi preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi let ebi = buildInfo exe exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } replExe verbosity pkg_descr lbi exe' exeClbi -replComponent _ _ _ _ +replComponent verbosity _ _ _ (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) _ _ = - die $ "No support for building benchmark type " ++ display tt + die' verbosity $ "No support for building benchmark type " ++ display tt ---------------------------------------------------- -- Shared code for buildComponent and replComponent @@ -396,6 +428,7 @@ Executable { exeName = testName test, modulePath = mainFile, + exeScope = ExecutablePublic, buildInfo = testBuildInfo test } testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind" @@ -429,7 +462,7 @@ -- This is, like, the one place where we use a CTestName for a library. -- Should NOT use library name, since that could conflict! PackageIdentifier pkg_name pkg_ver = package pkg_descr - compat_name = computeCompatPackageName pkg_name (CTestName (testName test)) + compat_name = computeCompatPackageName pkg_name (Just (testName test)) compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi) libClbi = LibComponentLocalBuildInfo { componentPackageDeps = componentPackageDeps clbi @@ -447,7 +480,7 @@ , componentExposedModules = [IPI.ExposedModule m Nothing] } pkg = pkg_descr { - package = (package pkg_descr) { pkgName = compat_name } + package = (package pkg_descr) { pkgName = mkPackageName $ unMungedPackageName compat_name } , buildDepends = targetBuildDepends $ testBuildInfo test , executables = [] , testSuites = [] @@ -460,6 +493,7 @@ exe = Executable { exeName = mkUnqualComponentName $ stubName test, modulePath = stubFilePath test, + exeScope = ExecutablePublic, buildInfo = (testBuildInfo test) { hsSourceDirs = [ testDir ], targetBuildDepends = testLibDep @@ -468,8 +502,8 @@ } -- | The stub executable needs a new 'ComponentLocalBuildInfo' -- that exposes the relevant test suite library. - deps = (IPI.installedUnitId ipi, packageId ipi) - : (filter (\(_, x) -> let name = unPackageName $ pkgName x + deps = (IPI.installedUnitId ipi, mungedId ipi) + : (filter (\(_, x) -> let name = unMungedPackageName $ mungedName x in name == "Cabal" || name == "base") (componentPackageDeps clbi)) exeClbi = ExeComponentLocalBuildInfo { @@ -500,6 +534,7 @@ exe = Executable { exeName = benchmarkName bm, modulePath = f, + exeScope = ExecutablePublic, buildInfo = benchmarkBuildInfo bm } exeClbi = ExeComponentLocalBuildInfo { @@ -531,14 +566,10 @@ foldr updateProgram progs internalBuildTools where internalBuildTools = - [ simpleConfiguredProgram toolName (FoundOnSystem toolLocation) - | toolName <- toolNames - , let toolLocation = buildDir lbi toolName toolName <.> exeExtension ] - toolNames = intersect buildToolNames internalExeNames - internalExeNames = map (unUnqualComponentName . exeName) (executables pkg) - buildToolNames = map buildToolName (buildTools bi) - where - buildToolName (LegacyExeDependency pname _) = pname + [ simpleConfiguredProgram toolName' (FoundOnSystem toolLocation) + | toolName <- getAllInternalToolDependencies pkg bi + , let toolName' = unUnqualComponentName toolName + , let toolLocation = buildDir lbi toolName' toolName' <.> exeExtension ] -- TODO: build separate libs in separate dirs so that we can build @@ -554,7 +585,7 @@ LHC -> LHC.buildLib verbosity pkg_descr lbi lib clbi UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi - _ -> die "Building is not supported with this compiler." + _ -> die' verbosity "Building is not supported with this compiler." -- | Build a foreign library -- @@ -566,7 +597,7 @@ buildFLib verbosity numJobs pkg_descr lbi flib clbi = case compilerFlavor (compiler lbi) of GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi - _ -> die "Building is not supported with this compiler." + _ -> die' verbosity "Building is not supported with this compiler." buildExe :: Verbosity -> Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo @@ -578,7 +609,7 @@ JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi - _ -> die "Building is not supported with this compiler." + _ -> die' verbosity "Building is not supported with this compiler." replLib :: Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () @@ -588,7 +619,7 @@ -- NoFlag as the numJobs parameter. GHC -> GHC.replLib verbosity NoFlag pkg_descr lbi lib clbi GHCJS -> GHCJS.replLib verbosity NoFlag pkg_descr lbi lib clbi - _ -> die "A REPL is not supported for this compiler." + _ -> die' verbosity "A REPL is not supported for this compiler." replExe :: Verbosity -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () @@ -596,22 +627,33 @@ case compilerFlavor (compiler lbi) of GHC -> GHC.replExe verbosity NoFlag pkg_descr lbi exe clbi GHCJS -> GHCJS.replExe verbosity NoFlag pkg_descr lbi exe clbi - _ -> die "A REPL is not supported for this compiler." + _ -> die' verbosity "A REPL is not supported for this compiler." replFLib :: Verbosity -> PackageDescription -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo -> IO () replFLib verbosity pkg_descr lbi exe clbi = case compilerFlavor (compiler lbi) of GHC -> GHC.replFLib verbosity NoFlag pkg_descr lbi exe clbi - _ -> die "A REPL is not supported for this compiler." + _ -> die' verbosity "A REPL is not supported for this compiler." +-- | Runs 'componentInitialBuildSteps' on every configured component. initialBuildSteps :: FilePath -- ^"dist" prefix -> PackageDescription -- ^mostly information from the .cabal file -> LocalBuildInfo -- ^Configuration information + -> Verbosity -- ^The verbosity to use + -> IO () +initialBuildSteps distPref pkg_descr lbi verbosity = + withAllComponentsInBuildOrder pkg_descr lbi $ \_comp clbi -> + componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity + +-- | Creates the autogenerated files for a particular configured component. +componentInitialBuildSteps :: FilePath -- ^"dist" prefix + -> PackageDescription -- ^mostly information from the .cabal file + -> LocalBuildInfo -- ^Configuration information -> ComponentLocalBuildInfo -> Verbosity -- ^The verbosity to use -> IO () -initialBuildSteps _distPref pkg_descr lbi clbi verbosity = do +componentInitialBuildSteps _distPref pkg_descr lbi clbi verbosity = do createDirectoryIfMissingVerbose verbosity True (componentBuildDir lbi clbi) writeAutogenFiles verbosity pkg_descr lbi clbi @@ -628,7 +670,10 @@ let pathsModulePath = autogenComponentModulesDir lbi clbi ModuleName.toFilePath (autogenPathsModuleName pkg) <.> "hs" - rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi clbi) + pathsModuleDir = takeDirectory pathsModulePath + -- Ensure that the directory exists! + createDirectoryIfMissingVerbose verbosity True pathsModuleDir + rewriteFile verbosity pathsModulePath (Build.PathsModule.generate pkg lbi clbi) --TODO: document what we're doing here, and move it to its own function case clbi of @@ -643,8 +688,10 @@ let sigPath = autogenComponentModulesDir lbi clbi ModuleName.toFilePath mod_name <.> "hsig" createDirectoryIfMissingVerbose verbosity True (takeDirectory sigPath) - rewriteFile sigPath $ "signature " ++ display mod_name ++ " where" + rewriteFile verbosity sigPath $ + "{-# LANGUAGE NoImplicitPrelude #-}\n" ++ + "signature " ++ display mod_name ++ " where" _ -> return () let cppHeaderPath = autogenComponentModulesDir lbi clbi cppHeaderName - rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi clbi) + rewriteFile verbosity cppHeaderPath (Build.Macros.generate pkg lbi clbi) diff --git a/cabal/Cabal/Distribution/Simple/Build/Macros.hs b/cabal/Cabal/Distribution/Simple/Build/Macros.hs --- a/cabal/Cabal/Distribution/Simple/Build/Macros.hs +++ b/cabal/Cabal/Distribution/Simple/Build/Macros.hs @@ -17,6 +17,8 @@ -- /package/ in use is @>= A.B.C@, using the normal ordering on version -- numbers. -- +-- TODO Figure out what to do about backpack and internal libraries. It is very +-- suspecious that this stuff works with munged package identifiers module Distribution.Simple.Build.Macros ( generate, generatePackageVersionMacros, @@ -25,12 +27,14 @@ import Prelude () import Distribution.Compat.Prelude -import Distribution.Package import Distribution.Version import Distribution.PackageDescription import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program.Db import Distribution.Simple.Program.Types +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.PackageId import Distribution.Text -- ------------------------------------------------------------ @@ -73,15 +77,24 @@ generate pkg_descr lbi clbi = "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" ++ generatePackageVersionMacros - (package pkg_descr : map snd (componentPackageDeps clbi)) ++ + (package pkg_descr : map getPid (componentPackageDeps clbi)) ++ generateToolVersionMacros (configuredPrograms . withPrograms $ lbi) ++ - generateComponentIdMacro lbi clbi + generateComponentIdMacro lbi clbi ++ + generateCurrentPackageVersion pkg_descr + where + getPid (_, MungedPackageId mpn v) = + PackageIdentifier pn v + where + -- NB: Drop the component name! We're just reporting package versions. + -- This would have to be revisited if you are allowed to depend + -- on different versions of the same package + pn = fst (decodeCompatPackageName mpn) -- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@ -- macros for a list of package ids (usually used with the specific deps of -- a configured package). -- -generatePackageVersionMacros :: [PackageIdentifier] -> String +generatePackageVersionMacros :: [PackageId] -> String generatePackageVersionMacros pkgids = concat [ line ("/* package " ++ display pkgid ++ " */") ++ generateMacros "" pkgname version @@ -133,6 +146,12 @@ _ -> "" ,ifndefDefineStr "CURRENT_COMPONENT_ID" (display (componentComponentId clbi)) ] + +-- | Generate the @CURRENT_PACKAGE_VERSION@ definition for the declared version +-- of the current package. +generateCurrentPackageVersion :: PackageDescription -> String +generateCurrentPackageVersion pd = + ifndefDefineStr "CURRENT_PACKAGE_VERSION" (display (pkgVersion (package pd))) fixchar :: Char -> Char fixchar '-' = '_' diff --git a/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs b/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs --- a/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs +++ b/cabal/Cabal/Distribution/Simple/Build/PathsModule.hs @@ -108,7 +108,7 @@ "\n\nbindirrel :: FilePath\n" ++ "bindirrel = " ++ show flat_bindirreloc ++ "\n"++ - "\ngetBinDir, getLibDir, genDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++ + "\ngetBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++ "getBinDir = "++mkGetEnvOrReloc "bindir" flat_bindirreloc++"\n"++ "getLibDir = "++mkGetEnvOrReloc "libdir" flat_libdirreloc++"\n"++ "getDynLibDir = "++mkGetEnvOrReloc "libdir" flat_dynlibdirreloc++"\n"++ diff --git a/cabal/Cabal/Distribution/Simple/BuildPaths.hs b/cabal/Cabal/Distribution/Simple/BuildPaths.hs --- a/cabal/Cabal/Distribution/Simple/BuildPaths.hs +++ b/cabal/Cabal/Distribution/Simple/BuildPaths.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.BuildPaths @@ -23,19 +25,27 @@ cppHeaderName, haddockName, + mkGenericStaticLibName, mkLibName, mkProfLibName, + mkGenericSharedLibName, mkSharedLibName, - + mkStaticLibName, + exeExtension, objExtension, dllExtension, staticLibExtension, + -- * Source files & build directories + getSourceFiles, getLibSourceFiles, getExeSourceFiles, + getFLibSourceFiles, exeBuildDir, flibBuildDir, ) where import Prelude () import Distribution.Compat.Prelude +import Distribution.Types.ForeignLib +import Distribution.Types.UnqualComponentName (unUnqualComponentName) import Distribution.Package import Distribution.ModuleName as ModuleName import Distribution.Compiler @@ -44,8 +54,10 @@ import Distribution.Simple.Setup import Distribution.Text import Distribution.System +import Distribution.Verbosity +import Distribution.Simple.Utils -import System.FilePath ((), (<.>)) +import System.FilePath ((), (<.>), normalise) -- --------------------------------------------------------------------------- -- Build directories and files @@ -104,23 +116,106 @@ haddockName :: PackageDescription -> FilePath haddockName pkg_descr = display (packageName pkg_descr) <.> "haddock" +-- ----------------------------------------------------------------------------- +-- Source File helper + +getLibSourceFiles :: Verbosity + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, FilePath)] +getLibSourceFiles verbosity lbi lib clbi = getSourceFiles verbosity searchpaths modules + where + bi = libBuildInfo lib + modules = allLibModules lib clbi + searchpaths = componentBuildDir lbi clbi : hsSourceDirs bi ++ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi ] + +getExeSourceFiles :: Verbosity + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, FilePath)] +getExeSourceFiles verbosity lbi exe clbi = do + moduleFiles <- getSourceFiles verbosity searchpaths modules + srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe) + return ((ModuleName.main, srcMainPath) : moduleFiles) + where + bi = buildInfo exe + modules = otherModules bi + searchpaths = autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : exeBuildDir lbi exe : hsSourceDirs bi + +getFLibSourceFiles :: Verbosity + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, FilePath)] +getFLibSourceFiles verbosity lbi flib clbi = getSourceFiles verbosity searchpaths modules + where + bi = foreignLibBuildInfo flib + modules = otherModules bi + searchpaths = autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : flibBuildDir lbi flib : hsSourceDirs bi + +getSourceFiles :: Verbosity -> [FilePath] + -> [ModuleName.ModuleName] + -> IO [(ModuleName.ModuleName, FilePath)] +getSourceFiles verbosity dirs modules = flip traverse modules $ \m -> fmap ((,) m) $ + findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m) + >>= maybe (notFound m) (return . normalise) + where + notFound module_ = die' verbosity $ "can't find source for module " ++ display module_ + +-- | The directory where we put build results for an executable +exeBuildDir :: LocalBuildInfo -> Executable -> FilePath +exeBuildDir lbi exe = buildDir lbi nm nm ++ "-tmp" + where + nm = unUnqualComponentName $ exeName exe + +-- | The directory where we put build results for a foreign library +flibBuildDir :: LocalBuildInfo -> ForeignLib -> FilePath +flibBuildDir lbi flib = buildDir lbi nm nm ++ "-tmp" + where + nm = unUnqualComponentName $ foreignLibName flib + -- --------------------------------------------------------------------------- -- Library file names --- TODO: Should this use staticLibExtension? +-- | Create a library name for a static library from a given name. +-- Prepends 'lib' and appends the static library extension ('.a'). +mkGenericStaticLibName :: String -> String +mkGenericStaticLibName lib = "lib" ++ lib <.> "a" + mkLibName :: UnitId -> String -mkLibName lib = "lib" ++ getHSLibraryName lib <.> "a" +mkLibName lib = mkGenericStaticLibName (getHSLibraryName lib) --- TODO: Should this use staticLibExtension? mkProfLibName :: UnitId -> String -mkProfLibName lib = "lib" ++ getHSLibraryName lib ++ "_p" <.> "a" +mkProfLibName lib = mkGenericStaticLibName (getHSLibraryName lib ++ "_p") +-- | Create a library name for a shared lirbary from a given name. +-- Prepends 'lib' and appends the '-' +-- as well as the shared library extension. +mkGenericSharedLibName :: CompilerId -> String -> String +mkGenericSharedLibName (CompilerId compilerFlavor compilerVersion) lib + = mconcat [ "lib", lib, "-", comp <.> dllExtension ] + where comp = display compilerFlavor ++ display compilerVersion + -- Implement proper name mangling for dynamical shared objects -- libHS- -- e.g. libHSbase-2.1-ghc6.6.1.so mkSharedLibName :: CompilerId -> UnitId -> String -mkSharedLibName (CompilerId compilerFlavor compilerVersion) lib - = "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> dllExtension +mkSharedLibName comp lib + = mkGenericSharedLibName comp (getHSLibraryName lib) + +-- Static libs are named the same as shared libraries, only with +-- a different extension. +mkStaticLibName :: CompilerId -> UnitId -> String +mkStaticLibName (CompilerId compilerFlavor compilerVersion) lib + = "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension where comp = display compilerFlavor ++ display compilerVersion -- ------------------------------------------------------------ diff --git a/cabal/Cabal/Distribution/Simple/BuildTarget.hs b/cabal/Cabal/Distribution/Simple/BuildTarget.hs --- a/cabal/Cabal/Distribution/Simple/BuildTarget.hs +++ b/cabal/Cabal/Distribution/Simple/BuildTarget.hs @@ -43,6 +43,7 @@ import Distribution.Types.LocalBuildInfo import Distribution.Types.ComponentRequestedSpec import Distribution.Types.ForeignLib +import Distribution.Types.UnqualComponentName import Distribution.Package import Distribution.PackageDescription @@ -54,6 +55,7 @@ import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ( (+++), (<++) ) +import Distribution.ParseUtils ( readPToMaybe ) import Control.Monad ( msum ) import Data.List ( stripPrefix, groupBy, partition ) @@ -68,7 +70,7 @@ -- into actual 'TargetInfo's to be built/registered/whatever. readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo] readTargetInfos verbosity pkg_descr lbi args = do - build_targets <- readBuildTargets pkg_descr args + build_targets <- readBuildTargets verbosity pkg_descr args checkBuildTargets verbosity pkg_descr lbi build_targets -- ------------------------------------------------------------ @@ -140,15 +142,15 @@ -- 'BuildTarget's according to a 'PackageDescription'. If there are problems -- with any of the targets e.g. they don't exist or are misformatted, throw an -- 'IOException'. -readBuildTargets :: PackageDescription -> [String] -> IO [BuildTarget] -readBuildTargets pkg targetStrs = do +readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget] +readBuildTargets verbosity pkg targetStrs = do let (uproblems, utargets) = readUserBuildTargets targetStrs - reportUserBuildTargetProblems uproblems + reportUserBuildTargetProblems verbosity uproblems utargets' <- traverse checkTargetExistsAsFile utargets let (bproblems, btargets) = resolveBuildTargets pkg utargets' - reportBuildTargetProblems bproblems + reportBuildTargetProblems verbosity bproblems return btargets @@ -206,20 +208,16 @@ parseHaskellString :: Parse.ReadP r String parseHaskellString = Parse.readS_to_P reads - readPToMaybe :: Parse.ReadP a a -> String -> Maybe a - readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str - , all isSpace s ] - data UserBuildTargetProblem = UserBuildTargetUnrecognised String deriving Show -reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO () -reportUserBuildTargetProblems problems = do +reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO () +reportUserBuildTargetProblems verbosity problems = do case [ target | UserBuildTargetUnrecognised target <- problems ] of [] -> return () target -> - die $ unlines + die' verbosity $ unlines [ "Unrecognised build target '" ++ name ++ "'." | name <- target ] ++ "Examples:\n" @@ -362,13 +360,13 @@ dispCName = componentStringName pkgid dispKind = showComponentKindShort . componentKind -reportBuildTargetProblems :: [BuildTargetProblem] -> IO () -reportBuildTargetProblems problems = do +reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO () +reportBuildTargetProblems verbosity problems = do case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of [] -> return () targets -> - die $ unlines + die' verbosity $ unlines [ "Unrecognised build target '" ++ showUserBuildTarget target ++ "'.\n" ++ "Expected a " ++ intercalate " or " expected @@ -378,7 +376,7 @@ case [ (t, e) | BuildTargetNoSuch t e <- problems ] of [] -> return () targets -> - die $ unlines + die' verbosity $ unlines [ "Unknown build target '" ++ showUserBuildTarget target ++ "'.\nThere is no " ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" @@ -391,7 +389,7 @@ case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of [] -> return () targets -> - die $ unlines + die' verbosity $ unlines [ "Ambiguous build target '" ++ showUserBuildTarget target ++ "'. It could be:\n " ++ unlines [ " "++ showUserBuildTarget ut ++ @@ -452,6 +450,8 @@ cinfoSrcDirs :: [FilePath], cinfoModules :: [ModuleName], cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) + cinfoAsmFiles:: [FilePath], + cinfoCmmFiles:: [FilePath], cinfoCFiles :: [FilePath], cinfoJsFiles :: [FilePath] } @@ -466,6 +466,8 @@ cinfoSrcDirs = hsSourceDirs bi, cinfoModules = componentModules c, cinfoHsFiles = componentHsFiles c, + cinfoAsmFiles= asmSources bi, + cinfoCmmFiles= cmmSources bi, cinfoCFiles = cSources bi, cinfoJsFiles = jsSources bi } @@ -539,7 +541,7 @@ matchComponentKind :: String -> Match ComponentKind matchComponentKind s | s `elem` ["lib", "library"] = return' LibKind - | s `elem` ["foreign-lib", "foreign-library"] = return' FLibKind + | s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind | s `elem` ["exe", "executable"] = return' ExeKind | s `elem` ["tst", "test", "test-suite"] = return' TestKind | s `elem` ["bench", "benchmark"] = return' BenchKind @@ -998,7 +1000,7 @@ case disabled of [] -> return () - ((cname,reason):_) -> die $ formatReason (showComponentName cname) reason + ((cname,reason):_) -> die' verbosity $ formatReason (showComponentName cname) reason for_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) -> warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole " diff --git a/cabal/Cabal/Distribution/Simple/BuildToolDepends.hs b/cabal/Cabal/Distribution/Simple/BuildToolDepends.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/BuildToolDepends.hs @@ -0,0 +1,96 @@ +-- | +-- +-- This modules provides functions for working with both the legacy +-- "build-tools" field, and its replacement, "build-tool-depends". Prefer using +-- the functions contained to access those fields directly. +module Distribution.Simple.BuildToolDepends where + +import Prelude () +import Distribution.Compat.Prelude + +import qualified Data.Map as Map + +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Types.ExeDependency +import Distribution.Types.LegacyExeDependency +import Distribution.Types.UnqualComponentName + +-- | Desugar a "build-tools" entry into proper a executable dependency if +-- possible. +-- +-- An entry can be so desguared in two cases: +-- +-- 1. The name in build-tools matches a locally defined executable. The +-- executable dependency produced is on that exe in the current package. +-- +-- 2. The name in build-tools matches a hard-coded set of known tools. For now, +-- the executable dependency produced is one an executable in a package of +-- the same, but the hard-coding could just as well be per-key. +-- +-- The first cases matches first. +desugarBuildTool :: PackageDescription + -> LegacyExeDependency + -> Maybe ExeDependency +desugarBuildTool pkg led = + if foundLocal + then Just $ ExeDependency (packageName pkg) toolName reqVer + else Map.lookup name whiteMap + where + LegacyExeDependency name reqVer = led + toolName = mkUnqualComponentName name + foundLocal = toolName `elem` map exeName (executables pkg) + whitelist = [ "hscolour", "haddock", "happy", "alex", "hsc2hs", "c2hs" + , "cpphs", "greencard", "hspec-discover" + ] + whiteMap = Map.fromList $ flip map whitelist $ \n -> + (n, ExeDependency (mkPackageName n) (mkUnqualComponentName n) reqVer) + +-- | Get everything from "build-tool-depends", along with entries from +-- "build-tools" that we know how to desugar. +-- +-- This should almost always be used instead of just accessing the +-- `buildToolDepends` field directly. +getAllToolDependencies :: PackageDescription + -> BuildInfo + -> [ExeDependency] +getAllToolDependencies pkg bi = + buildToolDepends bi ++ mapMaybe (desugarBuildTool pkg) (buildTools bi) + +-- | Does the given executable dependency map to this current package? +-- +-- This is a tiny function, but used in a number of places. +-- +-- This function is only sound to call on `BuildInfo`s from the given package +-- description. This is because it just filters the package names of each +-- dependency, and does not check whether version bounds in fact exclude the +-- current package, or the referenced components in fact exist in the current +-- package. +-- +-- This is OK because when a package is loaded, it is checked (in +-- `Distribution.Package.Check`) that dependencies matching internal components +-- do indeed have version bounds accepting the current package, and any +-- depended-on component in the current package actually exists. In fact this +-- check is performed by gathering the internal tool dependencies of each +-- component of the package according to this module, and ensuring those +-- properties on each so-gathered dependency. +-- +-- version bounds and components of the package are unchecked. This is because +-- we sanitize exe deps so that the matching name implies these other +-- conditions. +isInternal :: PackageDescription -> ExeDependency -> Bool +isInternal pkg (ExeDependency n _ _) = n == packageName pkg + + +-- | Get internal "build-tool-depends", along with internal "build-tools" +-- +-- This is a tiny function, but used in a number of places. The same +-- restrictions that apply to `isInternal` also apply to this function. +getAllInternalToolDependencies :: PackageDescription + -> BuildInfo + -> [UnqualComponentName] +getAllInternalToolDependencies pkg bi = + [ toolname + | dep@(ExeDependency _ toolname _) <- getAllToolDependencies pkg bi + , isInternal pkg dep + ] diff --git a/cabal/Cabal/Distribution/Simple/Command.hs b/cabal/Cabal/Distribution/Simple/Command.hs --- a/cabal/Cabal/Distribution/Simple/Command.hs +++ b/cabal/Cabal/Distribution/Simple/Command.hs @@ -585,7 +585,7 @@ noExtraFlags :: [String] -> IO () noExtraFlags [] = return () noExtraFlags extraFlags = - die $ "Unrecognised flags: " ++ intercalate ", " extraFlags + dieNoVerbosity $ "Unrecognised flags: " ++ intercalate ", " extraFlags --TODO: eliminate this function and turn it into a variant on commandAddAction -- instead like commandAddActionNoArgs that doesn't supply the [String] 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 @@ -61,6 +61,7 @@ coverageSupported, profilingSupported, backpackSupported, + arResponseFilesSupported, libraryDynDirSupported, -- * Support for profiling detail levels @@ -338,6 +339,11 @@ _ -> False where v = compilerVersion comp + +-- | Does this compiler's "ar" command supports response file +-- arguments (i.e. @file-style arguments). +arResponseFilesSupported :: Compiler -> Bool +arResponseFilesSupported = ghcSupported "ar supports at file" -- | Does this compiler support Haskell program coverage? coverageSupported :: Compiler -> Bool 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 @@ -54,7 +54,6 @@ ConfigStateFileError(..), tryGetConfigStateFile, platformDefines, - relaxPackageDeps, ) where @@ -76,16 +75,22 @@ import Distribution.PackageDescription.PrettyPrint import Distribution.PackageDescription.Configuration import Distribution.PackageDescription.Check hiding (doesFileExist) +import Distribution.Simple.BuildToolDepends import Distribution.Simple.Program import Distribution.Simple.Setup as Setup import Distribution.Simple.BuildTarget import Distribution.Simple.LocalBuildInfo +import Distribution.Types.ExeDependency +import Distribution.Types.LegacyExeDependency +import Distribution.Types.PkgconfigDependency +import Distribution.Types.MungedPackageName import Distribution.Types.LocalBuildInfo import Distribution.Types.ComponentRequestedSpec import Distribution.Types.ForeignLib import Distribution.Types.ForeignLibType import Distribution.Types.ForeignLibOption import Distribution.Types.Mixin +import Distribution.Types.UnqualComponentName import Distribution.Simple.Utils import Distribution.System import Distribution.Version @@ -93,6 +98,7 @@ import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Stack import Distribution.Backpack.Configure +import Distribution.Backpack.DescribeUnitId import Distribution.Backpack.PreExistingComponent import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour) import Distribution.Backpack.Id @@ -107,7 +113,7 @@ import Control.Exception ( ErrorCall, Exception, evaluate, throw, throwIO, try ) -import Distribution.Utils.BinaryWithFingerprint +import Distribution.Compat.Binary ( decodeOrFailIO, encode ) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as BLC8 @@ -196,7 +202,7 @@ Right x -> x let getStoredValue = do - result <- decodeWithFingerprintOrFailIO (BLC8.tail body) + result <- decodeOrFailIO (BLC8.tail body) case result of Left _ -> throw ConfigStateFileNoParse Right x -> return x @@ -241,7 +247,7 @@ writePersistBuildConfig distPref lbi = do createDirectoryIfMissing False distPref writeFileAtomic (localBuildInfoFile distPref) $ - BLC8.unlines [showHeader pkgId, encodeWithFingerprint lbi] + BLC8.unlines [showHeader pkgId, encode lbi] where pkgId = localPackage lbi @@ -283,8 +289,8 @@ -- | Check that localBuildInfoFile is up-to-date with respect to the -- .cabal file. checkPersistBuildConfigOutdated :: FilePath -> FilePath -> NoCallStackIO Bool -checkPersistBuildConfigOutdated distPref pkg_descr_file = do - pkg_descr_file `moreRecentFile` (localBuildInfoFile distPref) +checkPersistBuildConfigOutdated distPref pkg_descr_file = + pkg_descr_file `moreRecentFile` localBuildInfoFile distPref -- | Get the path of @dist\/setup-config@. localBuildInfoFile :: FilePath -- ^ The @dist@ directory path. @@ -324,18 +330,7 @@ -- Returns the @.setup-config@ file. configure :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo -configure (pkg_descr0', pbi) cfg = do - let pkg_descr0 = - -- Ignore '--allow-{older,newer}' when we're given - -- '--exact-configuration'. - if fromFlagOrDefault False (configExactConfiguration cfg) - then pkg_descr0' - else relaxPackageDeps removeLowerBound - (maybe RelaxDepsNone unAllowOlder $ configAllowOlder cfg) $ - relaxPackageDeps removeUpperBound - (maybe RelaxDepsNone unAllowNewer $ configAllowNewer cfg) - pkg_descr0' - +configure (pkg_descr0, pbi) cfg = do -- Determine the component we are configuring, if a user specified -- one on the command line. We use a fake, flattened version of -- the package since at this point, we're not really sure what @@ -343,28 +338,27 @@ -- configure everything (the old behavior). (mb_cname :: Maybe ComponentName) <- do let flat_pkg_descr = flattenPackageDescription pkg_descr0 - targets <- readBuildTargets flat_pkg_descr (configArgs cfg) + targets <- readBuildTargets verbosity flat_pkg_descr (configArgs cfg) -- TODO: bleat if you use the module/file syntax let targets' = [ cname | BuildTargetComponent cname <- targets ] case targets' of _ | null (configArgs cfg) -> return Nothing [cname] -> return (Just cname) - [] -> die "No valid component targets found" - _ -> die "Can only configure either single component or all of them" + [] -> die' verbosity "No valid component targets found" + _ -> die' verbosity "Can only configure either single component or all of them" let use_external_internal_deps = isJust mb_cname case mb_cname of Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0) - Just cname -> notice verbosity - ("Configuring component " ++ display cname ++ - " from " ++ display (packageId pkg_descr0)) + Just cname -> setupMessage' verbosity "Configuring" (packageId pkg_descr0) + cname (Just (configInstantiateWith cfg)) -- configCID is only valid for per-component configure when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ - die "--cid is only supported for per-component configure" + die' verbosity "--cid is only supported for per-component configure" checkDeprecatedFlags verbosity cfg - checkExactConfiguration pkg_descr0 cfg + checkExactConfiguration verbosity pkg_descr0 cfg -- Where to build the package let buildDir :: FilePath -- e.g. dist/build @@ -401,7 +395,7 @@ -- The set of package names which are "shadowed" by internal -- packages, and which component they map to - let internalPackageSet :: Map PackageName ComponentName + let internalPackageSet :: Map PackageName (Maybe UnqualComponentName) internalPackageSet = getInternalPackages pkg_descr0 -- Make a data structure describing what components are enabled. @@ -422,7 +416,7 @@ -- Some sanity checks related to enabling components. when (isJust mb_cname && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg))) $ - die $ "--enable-tests/--enable-benchmarks are incompatible with" ++ + die' verbosity $ "--enable-tests/--enable-benchmarks are incompatible with" ++ " explicitly specifying a component to configure." -- allConstraints: The set of all 'Dependency's we have. Used ONLY @@ -440,7 +434,7 @@ -- version of a dependency, and the executable to use another. (allConstraints :: [Dependency], requiredDepsMap :: Map PackageName InstalledPackageInfo) - <- either die return $ + <- either (die' verbosity) return $ combinedConstraints (configConstraints cfg) (configDependencies cfg) installedPackageSet @@ -465,8 +459,9 @@ <- configureFinalizedPackage verbosity cfg enabled allConstraints (dependencySatisfiable + use_external_internal_deps (fromFlagOrDefault False (configExactConfiguration cfg)) - (packageVersion pkg_descr0) + (packageName pkg_descr0) installedPackageSet internalPackageSet requiredDepsMap) @@ -486,7 +481,7 @@ debug verbosity $ "Finalized build-depends: " ++ intercalate ", " (map display (buildDepends pkg_descr)) - checkCompilerProblems comp pkg_descr enabled + checkCompilerProblems verbosity comp pkg_descr enabled checkPackageProblems verbosity pkg_descr0 (updatePackageDescription pbi pkg_descr) @@ -511,7 +506,7 @@ -- For one it's deterministic; for two, we need to associate -- them with renamings which would require a far more complicated -- input scheme than what we have today.) - externalPkgDeps :: [(PackageName, InstalledPackageInfo)] + externalPkgDeps :: [PreExistingComponent] <- configureDependencies verbosity use_external_internal_deps @@ -539,14 +534,14 @@ (enabledBuildInfos pkg_descr enabled) let langs = unsupportedLanguages comp langlist when (not (null langs)) $ - die $ "The package " ++ display (packageId pkg_descr0) + die' verbosity $ "The package " ++ display (packageId pkg_descr0) ++ " requires the following languages which are not " ++ "supported by " ++ display (compilerId comp) ++ ": " ++ intercalate ", " (map display langs) let extlist = nub $ concatMap allExtensions (enabledBuildInfos pkg_descr enabled) let exts = unsupportedExtensions comp extlist when (not (null exts)) $ - die $ "The package " ++ display (packageId pkg_descr0) + die' verbosity $ "The package " ++ display (packageId pkg_descr0) ++ " requires the following language extensions which are not " ++ "supported by " ++ display (compilerId comp) ++ ": " ++ intercalate ", " (map display exts) @@ -555,25 +550,31 @@ let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled] let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs when (not (null unsupportedFLibs)) $ - die $ "Cannot build some foreign libraries: " + die' verbosity $ "Cannot build some foreign libraries: " ++ intercalate "," unsupportedFLibs - -- Configure known/required programs & external build tools. - -- Exclude build-tool deps on "internal" exes in the same package - -- - -- TODO: Factor this into a helper package. - let requiredBuildTools = - [ buildTool - | let exeNames = map (unUnqualComponentName . exeName) (executables pkg_descr) - , bi <- enabledBuildInfos pkg_descr enabled - , buildTool@(LegacyExeDependency toolPName reqVer) - <- buildTools bi - , let isInternal = - toolPName `elem` exeNames - -- we assume all internal build-tools are - -- versioned with the package: - && packageVersion pkg_descr `withinRange` reqVer - , not isInternal ] + -- Configure certain external build tools, see below for which ones. + let requiredBuildTools = do + bi <- enabledBuildInfos pkg_descr enabled + -- First, we collect any tool dep that we know is external. This is, + -- in practice: + -- + -- 1. `build-tools` entries on the whitelist + -- + -- 2. `build-tool-depends` that aren't from the current package. + let externBuildToolDeps = + [ LegacyExeDependency (unUnqualComponentName eName) versionRange + | buildTool@(ExeDependency _ eName versionRange) + <- getAllToolDependencies pkg_descr bi + , not $ isInternal pkg_descr buildTool ] + -- Second, we collect any build-tools entry we don't know how to + -- desugar. We'll never have any idea how to build them, so we just + -- hope they are already on the PATH. + let unknownBuildTools = + [ buildTool + | buildTool <- buildTools bi + , Nothing == desugarBuildTool pkg_descr buildTool ] + externBuildToolDeps ++ unknownBuildTools programDb' <- configureAllKnownPrograms (lessVerbose verbosity) programDb @@ -592,25 +593,45 @@ -- use_external_internal_deps (buildComponents :: [ComponentLocalBuildInfo], packageDependsIndex :: InstalledPackageIndex) <- - let prePkgDeps = map ipiToPreExistingComponent externalPkgDeps - in runLogProgress verbosity $ configureComponentLocalBuildInfos + runLogProgress verbosity $ configureComponentLocalBuildInfos verbosity use_external_internal_deps enabled + (fromFlagOrDefault False (configDeterministic cfg)) (configIPID cfg) (configCID cfg) pkg_descr - prePkgDeps + externalPkgDeps (configConfigurationsFlags cfg) (configInstantiateWith cfg) installedPackageSet comp + -- Decide if we're going to compile with split sections. + split_sections :: Bool <- + if not (fromFlag $ configSplitSections cfg) + then return False + else case compilerFlavor comp of + GHC | compilerVersion comp >= mkVersion [8,0] + -> return True + GHCJS + -> return True + _ -> do warn verbosity + ("this compiler does not support " ++ + "--enable-split-sections; ignoring") + return False + -- Decide if we're going to compile with split objects. split_objs :: Bool <- if not (fromFlag $ configSplitObjs cfg) then return False else case compilerFlavor comp of + _ | split_sections + -> do warn verbosity + ("--enable-split-sections and " ++ + "--enable-split-objs are mutually" ++ + "exclusive; ignoring the latter") + return False GHC | compilerVersion comp >= mkVersion [6,5] -> return True GHCJS @@ -655,6 +676,12 @@ -- building only static library archives with -- --disable-shared. fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg + + withStaticLib_ = + -- build a static library (all dependent libraries rolled + -- into a huge .a archive) via GHCs -staticlib flag. + fromFlagOrDefault False $ configStaticLib cfg + withDynExe_ = fromFlag $ configDynExe cfg when (withDynExe_ && not withSharedLib_) $ warn verbosity $ "Executables will use dynamic linking, but a shared library " @@ -665,10 +692,7 @@ setCoverageLBI <- configureCoverage verbosity cfg comp - reloc <- - if not (fromFlag $ configRelocatable cfg) - then return False - else return True + let reloc = fromFlagOrDefault False $ configRelocatable cfg let buildComponentsMap = foldl' (\m clbi -> Map.insertWith (++) @@ -687,7 +711,7 @@ compiler = comp, hostPlatform = compPlatform, buildDir = buildDir, - componentGraph = Graph.fromList buildComponents, + componentGraph = Graph.fromDistinctList buildComponents, componentNameMap = buildComponentsMap, installedPkgs = packageDependsIndex, pkgDescrFile = Nothing, @@ -695,6 +719,7 @@ withPrograms = programDb'', withVanillaLib = fromFlag $ configVanillaLib cfg, withSharedLib = withSharedLib_, + withStaticLib = withStaticLib_, withDynExe = withDynExe_, withProfLib = False, withProfLibDetail = ProfDetailNone, @@ -704,6 +729,7 @@ withDebugInfo = fromFlag $ configDebugInfo cfg, withGHCiLib = fromFlagOrDefault ghciLibByDefault $ configGHCiLib cfg, + splitSections = split_sections, splitObjs = split_objs, stripExes = fromFlag $ configStripExes cfg, stripLibs = fromFlag $ configStripLibs cfg, @@ -722,7 +748,7 @@ let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi - unless (isAbsolute (prefix dirs)) $ die $ + unless (isAbsolute (prefix dirs)) $ die' verbosity $ "expected an absolute directory name for --prefix: " ++ prefix dirs info verbosity $ "Using " ++ display currentCabalId @@ -738,10 +764,10 @@ -> " (fixed location)" _ -> "" - dirinfo "Binaries" (bindir dirs) (bindir relative) + dirinfo "Executables" (bindir dirs) (bindir relative) dirinfo "Libraries" (libdir dirs) (libdir relative) dirinfo "Dynamic Libraries" (dynlibdir dirs) (dynlibdir relative) - dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative) + dirinfo "Private executables" (libexecdir dirs) (libexecdir relative) dirinfo "Data files" (datadir dirs) (datadir relative) dirinfo "Documentation" (docdir dirs) (docdir relative) dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative) @@ -761,7 +787,7 @@ . userSpecifyPaths (configProgramPaths cfg) . setProgramSearchPath searchpath $ initialProgramDb - searchpath = getProgramSearchPath (initialProgramDb) + searchpath = getProgramSearchPath initialProgramDb ++ map ProgramSearchPathDir (fromNubList $ configProgramPathExtra cfg) @@ -787,14 +813,14 @@ -- | Sanity check: if '--exact-configuration' was given, ensure that the -- complete flag assignment was specified on the command line. -checkExactConfiguration :: GenericPackageDescription -> ConfigFlags -> IO () -checkExactConfiguration pkg_descr0 cfg = do +checkExactConfiguration :: Verbosity -> GenericPackageDescription -> ConfigFlags -> IO () +checkExactConfiguration verbosity pkg_descr0 cfg = when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do - let cmdlineFlags = map fst (configConfigurationsFlags cfg) + let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg)) allFlags = map flagName . genPackageFlags $ pkg_descr0 diffFlags = allFlags \\ cmdlineFlags when (not . null $ diffFlags) $ - die $ "'--exact-configuration' was given, " + die' verbosity $ "'--exact-configuration' was given, " ++ "but the following flags were not specified: " ++ intercalate ", " (map show diffFlags) @@ -808,86 +834,75 @@ -- does the resolution of conditionals, and it takes internalPackageSet -- as part of its input. getInternalPackages :: GenericPackageDescription - -> Map PackageName ComponentName + -> Map PackageName (Maybe UnqualComponentName) getInternalPackages pkg_descr0 = -- TODO: some day, executables will be fair game here too! let pkg_descr = flattenPackageDescription pkg_descr0 f lib = case libName lib of - Nothing -> (packageName pkg_descr, CLibName) - Just n' -> (unqualComponentNameToPackageName n', CSubLibName n') + Nothing -> (packageName pkg_descr, Nothing) + Just n' -> (unqualComponentNameToPackageName n', Just n') in Map.fromList (map f (allLibraries pkg_descr)) --- | Returns true if a dependency is satisfiable. This function --- may report a dependency satisfiable even when it is not, --- but not vice versa. This is to be passed --- to finalizePD. +-- | Returns true if a dependency is satisfiable. This function may +-- report a dependency satisfiable even when it is not, but not vice +-- versa. This is to be passed to finalizePD. dependencySatisfiable - :: Bool - -> Version + :: Bool -- ^ use external internal deps? + -> Bool -- ^ exact configuration? + -> PackageName -> InstalledPackageIndex -- ^ installed set - -> Map PackageName ComponentName -- ^ internal set + -> Map PackageName (Maybe UnqualComponentName) -- ^ internal set -> Map PackageName InstalledPackageInfo -- ^ required dependencies -> (Dependency -> Bool) dependencySatisfiable - exact_config _ installedPackageSet internalPackageSet requiredDepsMap - d@(Dependency depName _) - | exact_config = - -- When we're given '--exact-configuration', we assume that all - -- dependencies and flags are exactly specified on the command - -- line. Thus we only consult the 'requiredDepsMap'. Note that - -- we're not doing the version range check, so if there's some - -- dependency that wasn't specified on the command line, - -- 'finalizePD' will fail. - -- - -- TODO: mention '--exact-configuration' in the error message - -- when this fails? - -- - -- (However, note that internal deps don't have to be - -- specified!) - -- - -- NB: Just like the case below, we might incorrectly - -- determine an external internal dep is satisfiable - -- when it actually isn't. - (depName `Map.member` requiredDepsMap) || isInternalDep + use_external_internal_deps + exact_config pn installedPackageSet internalPackageSet requiredDepsMap + d@(Dependency depName vr) - | isInternalDep = - -- If a 'PackageName' is defined by an internal component, the - -- dep is satisfiable (and we are going to use the internal - -- dependency.) Note that this doesn't mean we are actually - -- going to SUCCEED when we configure the package, if - -- UseExternalInternalDeps is True. - True + | exact_config + -- When we're given '--exact-configuration', we assume that all + -- dependencies and flags are exactly specified on the command + -- line. Thus we only consult the 'requiredDepsMap'. Note that + -- we're not doing the version range check, so if there's some + -- dependency that wasn't specified on the command line, + -- 'finalizePD' will fail. + -- TODO: mention '--exact-configuration' in the error message + -- when this fails? + = if isInternalDep && not use_external_internal_deps + -- Except for internal deps, when we're NOT per-component mode; + -- those are just True. + then True + else depName `Map.member` requiredDepsMap - | otherwise = - -- Normal operation: just look up dependency in the - -- package index. - not . null . PackageIndex.lookupDependency installedPackageSet $ d - where - isInternalDep = Map.member depName internalPackageSet + | isInternalDep + = if use_external_internal_deps + -- When we are doing per-component configure, we now need to + -- test if the internal dependency is in the index. This has + -- DIFFERENT semantics from normal dependency satisfiability. + then internalDepSatisfiable + -- If a 'PackageName' is defined by an internal component, the dep is + -- satisfiable (we're going to build it ourselves) + else True --- | Relax the dependencies of this package if needed. -relaxPackageDeps :: (VersionRange -> VersionRange) - -> RelaxDeps - -> GenericPackageDescription -> GenericPackageDescription -relaxPackageDeps _ RelaxDepsNone gpd = gpd -relaxPackageDeps vrtrans RelaxDepsAll gpd = transformAllBuildDepends relaxAll gpd - where - relaxAll = \(Dependency pkgName verRange) -> - Dependency pkgName (vrtrans verRange) -relaxPackageDeps vrtrans (RelaxDepsSome allowNewerDeps') gpd = - transformAllBuildDepends relaxSome gpd + | otherwise + = depSatisfiable + where - thisPkgName = packageName gpd - allowNewerDeps = mapMaybe f allowNewerDeps' + isInternalDep = Map.member depName internalPackageSet - f (Setup.RelaxedDep p) = Just p - f (Setup.RelaxedDepScoped scope p) | scope == thisPkgName = Just p - | otherwise = Nothing + depSatisfiable = + not . null $ PackageIndex.lookupDependency installedPackageSet d - relaxSome = \d@(Dependency depName verRange) -> - if depName `elem` allowNewerDeps - then Dependency depName (vrtrans verRange) - else d + internalDepSatisfiable = + not . null $ PackageIndex.lookupInternalDependency + installedPackageSet (Dependency pn vr) cn + where + cn | pn == depName + = Nothing + | otherwise + -- Reinterpret the "package name" as an unqualified component + -- name + = Just (mkUnqualComponentName (unPackageName depName)) -- | Finalize a generic package description. The workhorse is -- 'finalizePD' but there's a bit of other nattering @@ -920,7 +935,7 @@ pkg_descr0 of Right r -> return r Left missing -> - die $ "Encountered missing dependencies:\n" + die' verbosity $ "Encountered missing dependencies:\n" ++ (render . nest 4 . sep . punctuate comma . map (disp . simplifyDependency) $ missing) @@ -929,10 +944,10 @@ -- we do it here so that those get checked too let pkg_descr = addExtraIncludeLibDirs pkg_descr0' - when (not (null flags)) $ + unless (nullFlagAssignment flags) $ info verbosity $ "Flags chosen: " ++ intercalate ", " [ unFlagName fn ++ "=" ++ display value - | (fn, value) <- flags ] + | (fn, value) <- unFlagAssignment flags ] return (pkg_descr, flags) where @@ -950,64 +965,62 @@ executables pkg_descr} -- | Check for use of Cabal features which require compiler support -checkCompilerProblems :: Compiler -> PackageDescription -> ComponentRequestedSpec -> IO () -checkCompilerProblems comp pkg_descr enabled = do +checkCompilerProblems :: Verbosity -> Compiler -> PackageDescription -> ComponentRequestedSpec -> IO () +checkCompilerProblems verbosity comp pkg_descr enabled = do unless (renamingPackageFlagsSupported comp || all (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins) (enabledBuildInfos pkg_descr enabled)) $ - die $ "Your compiler does not support thinning and renaming on " + die' verbosity $ "Your compiler does not support thinning and renaming on " ++ "package flags. To use this feature you must use " ++ "GHC 7.9 or later." when (any (not.null.PD.reexportedModules) (PD.allLibraries pkg_descr) - && not (reexportedModulesSupported comp)) $ do - die $ "Your compiler does not support module re-exports. To use " + && not (reexportedModulesSupported comp)) $ + die' verbosity $ "Your compiler does not support module re-exports. To use " ++ "this feature you must use GHC 7.9 or later." when (any (not.null.PD.signatures) (PD.allLibraries pkg_descr) - && not (backpackSupported comp)) $ do - die $ "Your compiler does not support Backpack. To use " + && not (backpackSupported comp)) $ + die' verbosity $ "Your compiler does not support Backpack. To use " ++ "this feature you must use GHC 8.1 or later." -- | Select dependencies for the package. configureDependencies :: Verbosity -> UseExternalInternalDeps - -> Map PackageName ComponentName -- ^ internal packages + -> Map PackageName (Maybe UnqualComponentName) -- ^ internal packages -> InstalledPackageIndex -- ^ installed packages -> Map PackageName InstalledPackageInfo -- ^ required deps -> PackageDescription - -> IO [(PackageName, InstalledPackageInfo)] + -> IO [PreExistingComponent] configureDependencies verbosity use_external_internal_deps internalPackageSet installedPackageSet requiredDepsMap pkg_descr = do - let selectDependencies :: [Dependency] -> - ([FailedDependency], [ResolvedDependency]) - selectDependencies = - partitionEithers - . map (selectDependency (package pkg_descr) - internalPackageSet installedPackageSet - requiredDepsMap use_external_internal_deps) - - (failedDeps, allPkgDeps) = - selectDependencies (buildDepends pkg_descr) + let failedDeps :: [FailedDependency] + allPkgDeps :: [ResolvedDependency] + (failedDeps, allPkgDeps) = partitionEithers + [ (\s -> (dep, s)) <$> status + | dep <- buildDepends pkg_descr + , let status = selectDependency (package pkg_descr) + internalPackageSet installedPackageSet + requiredDepsMap use_external_internal_deps dep ] internalPkgDeps = [ pkgid - | InternalDependency _ pkgid <- allPkgDeps ] + | (_, InternalDependency pkgid) <- allPkgDeps ] -- NB: we have to SAVE the package name, because this is the only -- way we can be able to resolve package names in the package -- description. - externalPkgDeps = [ (pn, pkg) - | ExternalDependency (Dependency pn _) pkg <- allPkgDeps ] + externalPkgDeps = [ pec + | (_, ExternalDependency pec) <- allPkgDeps ] when (not (null internalPkgDeps) && not (newPackageDepsBehaviour pkg_descr)) $ - die $ "The field 'build-depends: " + die' verbosity $ "The field 'build-depends: " ++ intercalate ", " (map (display . packageName) internalPkgDeps) ++ "' refers to a library which is defined within the same " ++ "package. To use this feature the package must specify at " ++ "least 'cabal-version: >= 1.8'." - reportFailedDependencies failedDeps + reportFailedDependencies verbosity failedDeps reportSelectedDependencies verbosity allPkgDeps return externalPkgDeps @@ -1129,16 +1142,18 @@ hackageUrl :: String hackageUrl = "http://hackage.haskell.org/package/" -data ResolvedDependency +type ResolvedDependency = (Dependency, DependencyResolution) + +data DependencyResolution -- | An external dependency from the package database, OR an -- internal dependency which we are getting from the package -- database. - = ExternalDependency Dependency InstalledPackageInfo + = ExternalDependency PreExistingComponent -- | An internal dependency ('PackageId' should be a library name) -- which we are going to have to build. (The -- 'PackageId' here is a hack to get a modest amount of -- polymorphism out of the 'Package' typeclass.) - | InternalDependency Dependency PackageId + | InternalDependency PackageId data FailedDependency = DependencyNotExists PackageName | DependencyMissingInternal PackageName PackageName @@ -1146,7 +1161,7 @@ -- | Test for a package dependency and record the version we have installed. selectDependency :: PackageId -- ^ Package id of current package - -> Map PackageName ComponentName + -> Map PackageName (Maybe UnqualComponentName) -> InstalledPackageIndex -- ^ Installed packages -> Map PackageName InstalledPackageInfo -- ^ Packages for which we have been given specific deps to @@ -1154,7 +1169,7 @@ -> UseExternalInternalDeps -- ^ Are we configuring a -- single component? -> Dependency - -> Either FailedDependency ResolvedDependency + -> Either FailedDependency DependencyResolution selectDependency pkgid internalIndex installedIndex requiredDepsMap use_external_internal_deps dep@(Dependency dep_pkgname vr) = @@ -1177,43 +1192,51 @@ else do_internal _ -> do_external Nothing where - do_internal = Right (InternalDependency dep - (PackageIdentifier dep_pkgname (packageVersion pkgid))) - do_external is_internal = case Map.lookup dep_pkgname requiredDepsMap of - -- If we know the exact pkg to use, then use it. - Just pkginstance -> Right (ExternalDependency dep pkginstance) - -- Otherwise we just pick an arbitrary instance of the latest version. - Nothing -> case PackageIndex.lookupDependency installedIndex dep' of - [] -> Left $ - case is_internal of - Just cname -> DependencyMissingInternal dep_pkgname - (computeCompatPackageName (packageName pkgid) cname) - Nothing -> DependencyNotExists dep_pkgname - pkgs -> Right $ ExternalDependency dep $ - case last pkgs of - (_ver, pkginstances) -> head pkginstances - where - dep' | Just cname <- is_internal - = Dependency (computeCompatPackageName (packageName pkgid) cname) vr - | otherwise = dep - -- NB: here computeCompatPackageName we want to pick up the INDEFINITE ones - -- which is why we pass 'Nothing' as 'UnitId' + -- It's an internal library, and we're not per-component build + do_internal = Right $ InternalDependency + $ PackageIdentifier dep_pkgname $ packageVersion pkgid + + -- We have to look it up externally + do_external is_internal = do + ipi <- case Map.lookup dep_pkgname requiredDepsMap of + -- If we know the exact pkg to use, then use it. + Just pkginstance -> Right pkginstance + -- Otherwise we just pick an arbitrary instance of the latest version. + Nothing -> + case is_internal of + Nothing -> do_external_external + Just mb_uqn -> do_external_internal mb_uqn + return $ ExternalDependency $ ipiToPreExistingComponent ipi + + -- It's an external package, normal situation + do_external_external = + case PackageIndex.lookupDependency installedIndex dep of + [] -> Left (DependencyNotExists dep_pkgname) + pkgs -> Right $ head $ snd $ last pkgs + + -- It's an internal library, being looked up externally + do_external_internal mb_uqn = + case PackageIndex.lookupInternalDependency installedIndex + (Dependency (packageName pkgid) vr) mb_uqn of + [] -> Left (DependencyMissingInternal dep_pkgname (packageName pkgid)) + pkgs -> Right $ head $ snd $ last pkgs + reportSelectedDependencies :: Verbosity -> [ResolvedDependency] -> IO () reportSelectedDependencies verbosity deps = info verbosity $ unlines [ "Dependency " ++ display (simplifyDependency dep) ++ ": using " ++ display pkgid - | resolved <- deps - , let (dep, pkgid) = case resolved of - ExternalDependency dep' pkg' -> (dep', packageId pkg') - InternalDependency dep' pkgid' -> (dep', pkgid') ] + | (dep, resolution) <- deps + , let pkgid = case resolution of + ExternalDependency pkg' -> packageId pkg' + InternalDependency pkgid' -> pkgid' ] -reportFailedDependencies :: [FailedDependency] -> IO () -reportFailedDependencies [] = return () -reportFailedDependencies failed = - die (intercalate "\n\n" (map reportFailedDependency failed)) +reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO () +reportFailedDependencies _ [] = return () +reportFailedDependencies verbosity failed = + die' verbosity (intercalate "\n\n" (map reportFailedDependency failed)) where reportFailedDependency (DependencyNotExists pkgname) = @@ -1224,8 +1247,7 @@ reportFailedDependency (DependencyMissingInternal pkgname real_pkgname) = "internal dependency " ++ display pkgname ++ " not installed.\n" ++ "Perhaps you need to configure and install it first?\n" - ++ "(Munged package name we searched for was " - ++ display real_pkgname ++ ")" + ++ "(This library was defined by " ++ display real_pkgname ++ ")" reportFailedDependency (DependencyNoVersion dep) = "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n" @@ -1237,7 +1259,7 @@ -> IO InstalledPackageIndex getInstalledPackages verbosity comp packageDBs progdb = do when (null packageDBs) $ - die $ "No package databases have been specified. If you use " + die' verbosity $ "No package databases have been specified. If you use " ++ "--package-db=clear, you must follow it with --package-db= " ++ "with 'global', 'user' or a specific file." @@ -1250,7 +1272,7 @@ UHC -> UHC.getInstalledPackages verbosity comp packageDBs progdb HaskellSuite {} -> HaskellSuite.getInstalledPackages verbosity packageDBs progdb - flv -> die $ "don't know how to find the installed packages for " + flv -> die' verbosity $ "don't know how to find the installed packages for " ++ display flv -- | Like 'getInstalledPackages', but for a single package DB. @@ -1337,8 +1359,10 @@ idConstraintMap :: Map PackageName InstalledPackageInfo idConstraintMap = Map.fromList - [ (packageName pkg, pkg) - | (_, _, Just pkg) <- dependenciesPkgInfo ] + -- NB: do NOT use the packageName from + -- dependenciesPkgInfo! + [ (pn, pkg) + | (pn, _, Just pkg) <- dependenciesPkgInfo ] -- The dependencies along with the installed package info, if it exists dependenciesPkgInfo :: [(PackageName, ComponentId, @@ -1460,11 +1484,11 @@ requirePkg dep@(PkgconfigDependency pkgn range) = do version <- pkgconfig ["--modversion", pkg] - `catchIO` (\_ -> die notFound) - `catchExit` (\_ -> die notFound) + `catchIO` (\_ -> die' verbosity notFound) + `catchExit` (\_ -> die' verbosity notFound) case simpleParse version of - Nothing -> die "parsing output of pkg-config --modversion failed" - Just v | not (withinRange v range) -> die (badVersion v) + Nothing -> die' verbosity "parsing output of pkg-config --modversion failed" + Just v | not (withinRange v range) -> die' verbosity (badVersion v) | otherwise -> info verbosity (depSatisfied v) where notFound = "The pkg-config package '" ++ pkg ++ "'" @@ -1551,7 +1575,7 @@ configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath -> ProgramDb -> Verbosity -> IO (Compiler, Platform, ProgramDb) -configCompilerEx Nothing _ _ _ _ = die "Unknown compiler" +configCompilerEx Nothing _ _ _ verbosity = die' verbosity "Unknown compiler" configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do (comp, maybePlatform, programDb) <- case hcFlavor of GHC -> GHC.configure verbosity hcPath hcPkg progdb @@ -1561,7 +1585,7 @@ LHC.configure verbosity hcPath Nothing ghcConf UHC -> UHC.configure verbosity hcPath hcPkg progdb HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg progdb - _ -> die "Unknown compiler" + _ -> die' verbosity "Unknown compiler" return (comp, fromMaybe buildPlatform maybePlatform, programDb) -- Ideally we would like to not have separate configCompiler* and @@ -1592,7 +1616,7 @@ -- generic error message. -- TODO: produce a log file from the compiler errors, if any. checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () -checkForeignDeps pkg lbi verbosity = do +checkForeignDeps pkg lbi verbosity = ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling -- lucky (return ()) @@ -1661,8 +1685,10 @@ commonLdArgs = [ "-L" ++ dir | dir <- collectField PD.extraLibDirs ] ++ collectField PD.ldOptions ++ [ "-L" ++ dir - | dep <- deps - , dir <- Installed.libraryDirs dep ] + | dir <- ordNub [ dir + | dep <- deps + , dir <- Installed.libraryDirs dep ] + ] --TODO: do we also need dependent packages' ld options? makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs @@ -1691,14 +1717,14 @@ explainErrors _ _ | isNothing . lookupProgram gccProgram . withPrograms $ lbi - = die $ unlines $ + = die' verbosity $ unlines [ "No working gcc", "This package depends on foreign library but we cannot " ++ "find a working C compiler. If you have it in a " ++ "non-standard location you can use the --with-gcc " ++ "flag to specify it." ] - explainErrors hdr libs = die $ unlines $ + explainErrors hdr libs = die' verbosity $ unlines $ [ if plural then "Missing dependencies on foreign libraries:" else "Missing dependency on a foreign library:" @@ -1708,8 +1734,8 @@ _ -> [] ++ case libs of [] -> [] - [lib] -> ["* Missing C library: " ++ lib] - _ -> ["* Missing C libraries: " ++ intercalate ", " libs] + [lib] -> ["* Missing (or bad) C library: " ++ lib] + _ -> ["* Missing (or bad) C libraries: " ++ intercalate ", " libs] ++ [if plural then messagePlural else messageSingular | missing] ++ case hdr of Just (Left _) -> [ headerCppMessage ] @@ -1731,6 +1757,10 @@ ++ "but in a non-standard location then you can use the flags " ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " ++ "where it is." + ++ "If the library file does exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." messagePlural = "This problem can usually be solved by installing the system " ++ "packages that provide these libraries (you may need the " @@ -1738,6 +1768,10 @@ ++ "but in a non-standard location then you can use the flags " ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " ++ "where they are." + ++ "If the library files do exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." headerCppMessage = "If the header file does exist, it may contain errors that " ++ "are caught by the C compiler at the preprocessing stage. " @@ -1760,7 +1794,7 @@ warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ] if null errors then traverse_ (warn verbosity) warnings - else die (intercalate "\n\n" errors) + else die' verbosity (intercalate "\n\n" errors) -- | Preform checks if a relocatable build is allowed checkRelocatable :: Verbosity @@ -1781,7 +1815,7 @@ -- Distribution.Simple.GHC.getRPaths checkOS = unless (os `elem` [ OSX, Linux ]) - $ die $ "Operating system: " ++ display os ++ + $ die' verbosity $ "Operating system: " ++ display os ++ ", does not support relocatable builds" where (Platform _ os) = hostPlatform lbi @@ -1789,7 +1823,7 @@ -- Check if the Compiler support relocatable builds checkCompiler = unless (compilerFlavor comp `elem` [ GHC ]) - $ die $ "Compiler: " ++ show comp ++ + $ die' verbosity $ "Compiler: " ++ show comp ++ ", does not support relocatable builds" where comp = compiler lbi @@ -1797,7 +1831,7 @@ -- Check if all the install dirs are relative to same prefix packagePrefixRelative = unless (relativeInstallDirs installDirs) - $ die $ "Installation directories are not prefix_relative:\n" ++ + $ die' verbosity $ "Installation directories are not prefix_relative:\n" ++ show installDirs where -- NB: should be good enough to check this against the default @@ -1820,7 +1854,7 @@ where doCheck pkgr ipkg | maybe False (== pkgr) (Installed.pkgRoot ipkg) - = traverse_ (\l -> when (isNothing $ stripPrefix p l) (die (msg l))) + = traverse_ (\l -> when (isNothing $ stripPrefix p l) (die' verbosity (msg l))) (Installed.libraryDirs ipkg) | otherwise = return () @@ -1873,6 +1907,9 @@ | not (null (foreignLibModDefFile flib)) = unsupported [ "Module definition file not supported on OSX" ] + | not (null (foreignLibVersionInfo flib)) = unsupported [ + "Foreign library versioning not currently supported on OSX" + ] | otherwise = Nothing goGhcOsx _ = unsupported [ @@ -1882,11 +1919,15 @@ goGhcLinux :: ForeignLibType -> Maybe String goGhcLinux ForeignLibNativeShared | standalone = unsupported [ - "We cannot build standalone libraries on OSX" + "We cannot build standalone libraries on Linux" ] | not (null (foreignLibModDefFile flib)) = unsupported [ - "Module definition file not supported on OSX" + "Module definition file not supported on Linux" ] + | not (null (foreignLibVersionInfo flib)) + && not (null (foreignLibVersionLinux flib)) = unsupported [ + "You must not specify both lib-version-info and lib-version-linux" + ] | otherwise = Nothing goGhcLinux _ = unsupported [ @@ -1900,6 +1941,10 @@ , " if os(Windows)\n" , " options: standalone\n" , "in your foreign-library stanza." + ] + | not (null (foreignLibVersionInfo flib)) = unsupported [ + "Foreign library versioning not currently supported on Windows.\n" + , "You can specify module definition files in the mod-def-file field." ] | otherwise = Nothing diff --git a/cabal/Cabal/Distribution/Simple/Doctest.hs b/cabal/Cabal/Distribution/Simple/Doctest.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Doctest.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Doctest +-- Copyright : Moritz Angermann 2017 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module deals with the @doctest@ command. + +-- Note: this module is modelled after Distribution.Simple.Haddock + +module Distribution.Simple.Doctest ( + doctest + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS + +-- local +import Distribution.PackageDescription as PD hiding (Flag) +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.Simple.Program.GHC +import Distribution.Simple.Program +import Distribution.Simple.PreProcess +import Distribution.Simple.Setup +import Distribution.Simple.Build +import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate) +import Distribution.Simple.Register (internalPackageDBPath) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Utils.NubList +import Distribution.Version +import Distribution.Verbosity + +-- ----------------------------------------------------------------------------- +-- Types + +-- | A record that represents the arguments to the doctest executable. +data DoctestArgs = DoctestArgs { + argTargets :: [FilePath] + -- ^ Modules to process + , argGhcOptions :: Flag (GhcOptions, Version) +} deriving (Show, Generic) + +-- ----------------------------------------------------------------------------- +-- Doctest support + +doctest :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> DoctestFlags + -> IO () +doctest pkg_descr lbi suffixes doctestFlags = do + let verbosity = flag doctestVerbosity + distPref = flag doctestDistPref + flag f = fromFlag $ f doctestFlags + tmpFileOpts = defaultTempFileOptions + lbi' = lbi { withPackageDB = withPackageDB lbi + ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)] } + + (doctestProg, _version, _) <- + requireProgramVersion verbosity doctestProgram + (orLaterVersion (mkVersion [0,11,3])) (withPrograms lbi) + + withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do + componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity + preprocessComponent pkg_descr component lbi clbi False verbosity suffixes + + case component of + CLib lib -> do + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ + \tmp -> do + inFiles <- map snd <$> getLibSourceFiles verbosity lbi lib clbi + args <- mkDoctestArgs verbosity tmp lbi' clbi inFiles (libBuildInfo lib) + runDoctest verbosity (compiler lbi) (hostPlatform lbi) doctestProg args + CExe exe -> do + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ + \tmp -> do + inFiles <- map snd <$> getExeSourceFiles verbosity lbi exe clbi + args <- mkDoctestArgs verbosity tmp lbi' clbi inFiles (buildInfo exe) + runDoctest verbosity (compiler lbi) (hostPlatform lbi) doctestProg args + CFLib _ -> return () -- do not doctest foreign libs + CTest _ -> return () -- do not doctest tests + CBench _ -> return () -- do not doctest benchmarks + +-- ----------------------------------------------------------------------------- +-- Contributions to DoctestArgs (see also Haddock.hs for very similar code). + +componentGhcOptions :: Verbosity -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo -> FilePath + -> GhcOptions +componentGhcOptions verbosity lbi bi clbi odir = + let f = case compilerFlavor (compiler lbi) of + GHC -> GHC.componentGhcOptions + GHCJS -> GHCJS.componentGhcOptions + _ -> error $ + "Distribution.Simple.Doctest.componentGhcOptions:" ++ + "doctest only supports GHC and GHCJS" + in f verbosity lbi bi clbi odir + +mkDoctestArgs :: Verbosity + -> FilePath + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> [FilePath] + -> BuildInfo + -> IO DoctestArgs +mkDoctestArgs verbosity tmp lbi clbi inFiles bi = do + let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) + { ghcOptOptimisation = mempty -- no optimizations when runnign doctest + -- disable -Wmissing-home-modules + , ghcOptWarnMissingHomeModules = mempty + -- clear out ghc-options: these are likely not meant for doctest. + -- If so, should be explicitly specified via doctest-ghc-options: again. + , ghcOptExtra = mempty + , ghcOptCabal = toFlag False + + , ghcOptObjDir = toFlag tmp + , ghcOptHiDir = toFlag tmp + , ghcOptStubDir = toFlag tmp } + sharedOpts = vanillaOpts + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = toNubListR (hcSharedOptions GHC bi)} + opts <- if withVanillaLib lbi + then return vanillaOpts + else if withSharedLib lbi + then return sharedOpts + else die' verbosity $ "Must have vanilla or shared lirbaries " + ++ "enabled in order to run doctest" + ghcVersion <- maybe (die' verbosity "Compiler has no GHC version") + return + (compilerCompatVersion GHC (compiler lbi)) + return $ DoctestArgs + { argTargets = inFiles + , argGhcOptions = toFlag (opts, ghcVersion) + } + + +-- ----------------------------------------------------------------------------- +-- Call doctest with the specified arguments. +runDoctest :: Verbosity + -> Compiler + -> Platform + -> ConfiguredProgram + -> DoctestArgs + -> IO () +runDoctest verbosity comp platform doctestProg args = do + renderArgs verbosity comp platform args $ + \(flags, files) -> do + runProgram verbosity doctestProg (flags <> files) + +renderArgs :: Verbosity + -> Compiler + -> Platform + -> DoctestArgs + -> (([String],[FilePath]) -> IO a) + -> IO a +renderArgs _verbosity comp platform args k = do + k (flags, argTargets args) + where + flags :: [String] + flags = mconcat + [ pure "--no-magic" -- disable doctests automagic discovery heuristics + , pure "-fdiagnostics-color=never" -- disable ghc's color diagnostics. + , [ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args) + , opt <- renderGhcOptions comp platform opts ] + ] + +-- ------------------------------------------------------------------------------ +-- Boilerplate Monoid instance. +instance Monoid DoctestArgs where + mempty = gmempty + mappend = (<>) + +instance Semigroup DoctestArgs where + (<>) = gmappend 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 @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | @@ -82,6 +83,7 @@ import qualified Distribution.ModuleName as ModuleName import Distribution.ModuleName (ModuleName) import Distribution.Simple.Program +import Distribution.Simple.Program.Builtin (runghcProgram) import qualified Distribution.Simple.Program.HcPkg as HcPkg import qualified Distribution.Simple.Program.Ar as Ar import qualified Distribution.Simple.Program.Ld as Ld @@ -97,17 +99,23 @@ import Distribution.Types.ForeignLib import Distribution.Types.ForeignLibType import Distribution.Types.ForeignLibOption +import Distribution.Types.UnqualComponentName import Distribution.Utils.NubList import Language.Haskell.Extension +import Control.Monad (msum) +import Data.Char (isLower) import qualified Data.Map as Map import System.Directory ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing - , canonicalizePath, removeFile ) + , canonicalizePath, removeFile, renameFile ) import System.FilePath ( (), (<.>), takeExtension , takeDirectory, replaceExtension ,isRelative ) import qualified System.Info +#ifndef mingw32_HOST_OS +import System.Posix (createSymbolicLink) +#endif /* mingw32_HOST_OS */ -- ----------------------------------------------------------------------------- -- Configuring @@ -132,7 +140,7 @@ } anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1) - when (ghcVersion /= ghcPkgVersion) $ die $ + when (ghcVersion /= ghcPkgVersion) $ die' verbosity $ "Version mismatch between ghc and ghc-pkg: " ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " " ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion @@ -147,9 +155,13 @@ hpcProgram' = hpcProgram { programFindLocation = guessHpcFromGhcPath ghcProg } + runghcProgram' = runghcProgram { + programFindLocation = guessRunghcFromGhcPath ghcProg + } progdb3 = addKnownProgram haddockProgram' $ addKnownProgram hsc2hsProgram' $ - addKnownProgram hpcProgram' progdb2 + addKnownProgram hpcProgram' $ + addKnownProgram runghcProgram' progdb2 languages <- Internal.getLanguages verbosity implInfo ghcProg extensions0 <- Internal.getExtensions verbosity implInfo ghcProg @@ -282,7 +294,12 @@ -> IO (Maybe (FilePath, [FilePath])) guessHpcFromGhcPath = guessToolFromGhcPath hpcProgram +guessRunghcFromGhcPath :: ConfiguredProgram + -> Verbosity -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessRunghcFromGhcPath = guessToolFromGhcPath runghcProgram + getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg where @@ -301,8 +318,8 @@ -> ProgramDb -> IO InstalledPackageIndex getInstalledPackages verbosity comp packagedbs progdb = do - checkPackageDbEnvVar - checkPackageDbStack comp packagedbs + checkPackageDbEnvVar verbosity + checkPackageDbStack verbosity comp packagedbs pkgss <- getInstalledPackages' verbosity packagedbs progdb index <- toPackageIndex verbosity pkgss progdb return $! hackRtsPackage index @@ -368,35 +385,36 @@ | otherwise = "package.conf" Just ghcVersion = programVersion ghcProg -checkPackageDbEnvVar :: IO () -checkPackageDbEnvVar = - Internal.checkPackageDbEnvVar "GHC" "GHC_PACKAGE_PATH" +checkPackageDbEnvVar :: Verbosity -> IO () +checkPackageDbEnvVar verbosity = + Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH" -checkPackageDbStack :: Compiler -> PackageDBStack -> IO () -checkPackageDbStack comp = if flagPackageConf implInfo - then checkPackageDbStackPre76 - else checkPackageDbStackPost76 +checkPackageDbStack :: Verbosity -> Compiler -> PackageDBStack -> IO () +checkPackageDbStack verbosity comp = + if flagPackageConf implInfo + then checkPackageDbStackPre76 verbosity + else checkPackageDbStackPost76 verbosity where implInfo = ghcVersionImplInfo (compilerVersion comp) -checkPackageDbStackPost76 :: PackageDBStack -> IO () -checkPackageDbStackPost76 (GlobalPackageDB:rest) +checkPackageDbStackPost76 :: Verbosity -> PackageDBStack -> IO () +checkPackageDbStackPost76 _ (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () -checkPackageDbStackPost76 rest +checkPackageDbStackPost76 verbosity rest | GlobalPackageDB `elem` rest = - die $ "If the global package db is specified, it must be " + die' verbosity $ "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times" -checkPackageDbStackPost76 _ = return () +checkPackageDbStackPost76 _ _ = return () -checkPackageDbStackPre76 :: PackageDBStack -> IO () -checkPackageDbStackPre76 (GlobalPackageDB:rest) +checkPackageDbStackPre76 :: Verbosity -> PackageDBStack -> IO () +checkPackageDbStackPre76 _ (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () -checkPackageDbStackPre76 rest +checkPackageDbStackPre76 verbosity rest | GlobalPackageDB `notElem` rest = - die $ "With current ghc versions the global package db is always used " + die' verbosity $ "With current ghc versions the global package db is always used " ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6," ++ "see http://hackage.haskell.org/trac/ghc/ticket/5977" -checkPackageDbStackPre76 _ = - die $ "If the global package db is specified, it must be " +checkPackageDbStackPre76 verbosity _ = + die' verbosity $ "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times" -- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This @@ -431,7 +449,7 @@ (UserPackageDB, _global:user:_) -> return $ Just user (UserPackageDB, _global:_) -> return $ Nothing (SpecificPackageDB specific, _) -> return $ Just specific - _ -> die "cannot read ghc-pkg package listing" + _ -> die' verbosity "cannot read ghc-pkg package listing" pkgFiles' <- traverse dbFile packagedbs sequenceA [ withFileContents file $ \content -> do pkgs <- readPackages file content @@ -451,7 +469,7 @@ = \file _ -> failToRead file Just ghcProg = lookupProgram ghcProgram progdb Just ghcVersion = programVersion ghcProg - failToRead file = die $ "cannot read ghc package database " ++ file + failToRead file = die' verbosity $ "cannot read ghc package database " ++ file getInstalledPackagesMonitorFiles :: Verbosity -> Platform -> ProgramDb @@ -501,6 +519,8 @@ whenProfLib = when (withProfLib lbi) whenSharedLib forceShared = when (forceShared || withSharedLib lbi) + whenStaticLib forceStatic = + when (forceStatic || withStaticLib lbi) whenGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) ifReplLib = when forRepl comp = compiler lbi @@ -517,7 +537,7 @@ let isGhcDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp - doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi + doingTH = usesTemplateHaskellOrQQ libBi forceVanillaLib = doingTH && not isGhcDynamic forceSharedLib = doingTH && isGhcDynamic -- TH always needs default libs, even when building for profiling @@ -539,7 +559,8 @@ createDirectoryIfMissingVerbose verbosity True libTargetDir -- TODO: do we need to put hs-boot files into place for mutually recursive -- modules? - let cObjs = map (`replaceExtension` objExtension) (cSources libBi) + let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) + cObjs = map (`replaceExtension` objExtension) cLikeFiles baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir vanillaOpts = baseOpts `mappend` mempty { ghcOptMode = toFlag GhcModeMake, @@ -622,9 +643,43 @@ else if isGhcDynamic then do shared; vanilla else do vanilla; shared - when has_code $ whenProfLib (runGhcProg profOpts) + whenProfLib (runGhcProg profOpts) + -- build any C++ sources seperately + unless (not has_code || null (cxxSources libBi)) $ do + info verbosity "Building C++ Sources..." + sequence_ + [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename + vanillaCxxOpts = if isGhcDynamic + then baseCxxOpts { ghcOptFPic = toFlag True } + else baseCxxOpts + profCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCxxOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded cxxOpts = do + needsRecomp <- checkNeedsRecompilation filename cxxOpts + when needsRecomp $ runGhcProg cxxOpts + runGhcProgIfNeeded vanillaCxxOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) + | filename <- cxxSources libBi] + + when has_code . ifReplLib $ do + when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" + 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_ @@ -659,21 +714,18 @@ -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. - when has_code . ifReplLib $ do - when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" - ifReplLib (runGhcProg replOpts) - -- link: when has_code . unless forRepl $ do info verbosity "Linking..." let cProfObjs = map (`replaceExtension` ("p_" ++ objExtension)) - (cSources libBi) + (cSources libBi ++ cxxSources libBi) cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) - (cSources libBi) + (cSources libBi ++ cxxSources libBi) compiler_id = compilerId (compiler lbi) vanillaLibFilePath = libTargetDir mkLibName uid profileLibFilePath = libTargetDir mkProfLibName uid sharedLibFilePath = libTargetDir mkSharedLibName compiler_id uid + staticLibFilePath = libTargetDir mkStaticLibName compiler_id uid ghciLibFilePath = libTargetDir Internal.mkGHCiLibName uid libInstallPath = libdir $ absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest sharedLibInstallPath = libInstallPath mkSharedLibName compiler_id uid @@ -770,6 +822,35 @@ toNubListR $ PD.extraFrameworkDirs libBi, ghcOptRPaths = rpaths } + ghcStaticLinkArgs = + mempty { + ghcOptStaticLib = toFlag True, + ghcOptInputFiles = toNubListR staticObjectFiles, + ghcOptOutputFile = toFlag staticLibFilePath, + ghcOptExtra = toNubListR $ + hcStaticOptions GHC libBi, + ghcOptHideAllPackages = toFlag True, + ghcOptNoAutoLinkPackages = toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo { componentCompatPackageKey = pk } + -> toFlag pk + _ -> mempty, + ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty, + ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } + -> insts + _ -> [], + ghcOptPackages = toNubListR $ + Internal.mkGhcOptPackages clbi , + ghcOptLinkLibs = toNubListR $ extraLibs libBi, + ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi + } info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) @@ -781,12 +862,15 @@ whenGHCiLib $ do (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity ldProg + Ld.combineObjectFiles verbosity lbi ldProg ghciLibFilePath ghciObjFiles whenSharedLib False $ runGhcProg ghcSharedLinkArgs + whenStaticLib False $ + runGhcProg ghcStaticLinkArgs + -- | Start a REPL without loading any source files. startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform -> PackageDBStack -> IO () @@ -795,7 +879,7 @@ ghcOptMode = toFlag GhcModeInteractive, ghcOptPackageDBs = packageDBs } - checkPackageDbStack comp packageDBs + checkPackageDbStack verbosity comp packageDBs (ghcProg, _) <- requireProgram verbosity ghcProgram progdb runGHC verbosity ghcProg comp platform replOpts @@ -860,9 +944,10 @@ -- than the target OS (but this is wrong elsewhere in Cabal as well). flibTargetName :: LocalBuildInfo -> ForeignLib -> String flibTargetName lbi flib = - case (platformOS (hostPlatform lbi), foreignLibType flib) of + case (os, foreignLibType flib) of (Windows, ForeignLibNativeShared) -> nm <.> "dll" (Windows, ForeignLibNativeStatic) -> nm <.> "lib" + (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" @@ -870,9 +955,52 @@ nm :: String nm = unUnqualComponentName $ foreignLibName flib - platformOS :: Platform -> OS - platformOS (Platform _arch os) = os + os :: OS + os = let (Platform _ os') = hostPlatform lbi + in os' + -- If a foreign lib foo has lib-version-info 5:1:2 or + -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 + -- Libtool's version-info data is translated into library versions in a + -- nontrivial way: so refer to libtool documentation. + versionedExt :: String + versionedExt = + let nums = foreignLibVersion flib os + in foldl (<.>) "so" (map show nums) + +-- | Name for the library when building. +-- +-- If the `lib-version-info` field or the `lib-version-linux` field of +-- a foreign library target is set, we need to incorporate that +-- version into the SONAME field. +-- +-- If a foreign library foo has lib-version-info 5:1:2, it should be +-- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. +-- However, GHC does not allow overriding soname by setting linker +-- options, as it sets a soname of its own (namely the output +-- filename), after the user-supplied linker options. Hence, we have +-- to compile the library with the soname as its filename. We rename +-- the compiled binary afterwards. +-- +-- This method allows to adjust the name of the library at build time +-- such that the correct soname can be set. +flibBuildName :: LocalBuildInfo -> ForeignLib -> String +flibBuildName lbi flib + -- On linux, if a foreign-library has version data, the first digit is used + -- to produce the SONAME. + | (os, foreignLibType flib) == + (Linux, ForeignLibNativeShared) + = let nums = foreignLibVersion flib os + in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) + | otherwise = flibTargetName lbi flib + where + os :: OS + os = let (Platform _ os') = hostPlatform lbi + in os' + + nm :: String + nm = unUnqualComponentName $ foreignLibName flib + gbuildIsRepl :: GBuildMode -> Bool gbuildIsRepl (GBuildExe _) = False gbuildIsRepl (GReplExe _) = True @@ -902,11 +1030,59 @@ gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib gbuildModDefFiles (GReplFLib flib) = foreignLibModDefFile flib +-- | "Main" module name when overridden by @ghc-options: -main-is ...@ +-- or 'Nothing' if no @-main-is@ flag could be found. +-- +-- 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 + -- + -- Moreover, -main-is when parsed left-to-right can update either + -- the "Main" module name, or the "main" function name, or both, + -- see also 'decodeMainIsArg'. + msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts + where + ghcopts = hcOptions GHC bnfo + + findIsMainArgs [] = [] + findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest + findIsMainArgs (_:rest) = findIsMainArgs rest + +-- | Decode argument to '-main-is' +-- +-- Returns 'Nothing' if argument set only the function name. +-- +-- This code has been stolen/refactored from GHC's DynFlags.setMainIs +-- function. The logic here is deliberately imperfect as it is +-- intended to be bug-compatible with GHC's parser. See discussion in +-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. +decodeMainIsArg :: String -> Maybe ModuleName +decodeMainIsArg arg + | not (null main_fn) && isLower (head main_fn) + -- The arg looked like "Foo.Bar.baz" + = Just (ModuleName.fromString main_mod) + | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" + = Just (ModuleName.fromString arg) + | otherwise -- The arg looked like "baz" + = Nothing + where + (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' + where (r_suf, r_pre) = break pred' (reverse str) + -- | Return C sources, GHC input files and GHC input modules -gbuildSources :: FilePath +gbuildSources :: Verbosity + -> Version -- ^ specVersion + -> FilePath -> GBuildMode -> IO ([FilePath], [FilePath], [ModuleName]) -gbuildSources tmpDir bm = +gbuildSources verbosity specVer tmpDir bm = case bm of GBuildExe exe -> exeSources exe GReplExe exe -> exeSources exe @@ -916,10 +1092,34 @@ exeSources :: Executable -> IO ([FilePath], [FilePath], [ModuleName]) exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do main <- findFile (tmpDir : hsSourceDirs bnfo) modPath - return $ if isHaskell main - then (cSources bnfo , [main] , [] ) - else (main : cSources bnfo , [] , exeModules exe) + let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe + otherModNames = exeModules exe + if isHaskell main + then + if specVer < mkVersion [2] && (mainModName `elem` otherModNames) + then do + -- The cabal manual clearly states that `other-modules` is + -- intended for non-main modules. However, there's at least one + -- important package on Hackage (happy-1.19.5) which + -- violates this. We workaround this here so that we don't + -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which + -- would result in GHC complaining about duplicate Main + -- modules. + -- + -- Finally, we only enable this workaround for + -- specVersion < 2, as 'cabal-version:>=2.0' cabal files + -- have no excuse anymore to keep doing it wrong... ;-) + warn verbosity $ "Enabling workaround for Main module '" + ++ display mainModName + ++ "' listed in 'other-modules' illegally!" + + return (cSources bnfo, [main], + filter (/= mainModName) (exeModules exe)) + + else return (cSources bnfo, [main], exeModules exe) + else return (main : cSources bnfo, [], exeModules exe) + flibSources :: ForeignLib -> ([FilePath], [FilePath], [ModuleName]) flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = (cSources bnfo, [], foreignLibModules flib) @@ -931,7 +1131,7 @@ gbuild :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> GBuildMode -> ComponentLocalBuildInfo -> IO () -gbuild verbosity numJobs _pkg_descr lbi bm clbi = do +gbuild verbosity numJobs pkg_descr lbi bm clbi = do (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) let comp = compiler lbi platform = hostPlatform lbi @@ -961,7 +1161,8 @@ | otherwise = mempty rpaths <- getRPaths lbi clbi - (cSrcs, inputFiles, inputModules) <- gbuildSources tmpDir bm + (cSrcs, inputFiles, inputModules) <- gbuildSources verbosity + (specVersion pkg_descr) tmpDir bm let isGhcDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp @@ -1049,7 +1250,7 @@ -- by the compiler. -- With dynamic-by-default GHC the TH object files loaded at compile-time -- need to be .dyn_o instead of .o. - doingTH = EnableExtension TemplateHaskell `elem` allExtensions bnfo + doingTH = usesTemplateHaskellOrQQ bnfo -- Should we use -dynamic-too instead of compiling twice? useDynToo = dynamicTooSupported && isGhcDynamic && doingTH && withStaticExe @@ -1067,7 +1268,11 @@ runGhcProg compileTHOpts { ghcOptNoLink = toFlag True , ghcOptNumJobs = numJobs } - unless (gbuildIsRepl bm) $ + -- Do not try to build anything if there are no input files. + -- This can happen if the cabal file ends up with only cSrcs + -- but no Haskell modules. + unless ((null inputFiles && null inputModules) + || gbuildIsRepl bm) $ runGhcProg compileOpts { ghcOptNoLink = toFlag True , ghcOptNumJobs = numJobs } @@ -1152,8 +1357,13 @@ cabalBug "static libraries not yet implemented" ForeignLibTypeUnknown -> cabalBug "unknown foreign lib type" + -- We build under a (potentially) different filename to set a + -- soname on supported platforms. See also the note for + -- @flibBuildName@. info verbosity "Linking..." - runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir targetName) } + let buildName = flibBuildName lbi flib + runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir buildName) } + renameFile (targetDir buildName) (targetDir targetName) {- Note [RPATH] @@ -1287,6 +1497,7 @@ return rpaths where (Platform _ hostOS) = hostPlatform lbi + compid = compilerId . compiler $ lbi -- The list of RPath-supported operating systems below reflects the -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ @@ -1298,7 +1509,10 @@ supportRPaths Linux   = True supportRPaths Windows = False supportRPaths OSX   = True - supportRPaths FreeBSD   = False + supportRPaths FreeBSD   = + case compid of + CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True + _ -> False supportRPaths OpenBSD   = False supportRPaths NetBSD   = False supportRPaths DragonFly = False @@ -1386,7 +1600,11 @@ componentGhcOptions :: Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> GhcOptions -componentGhcOptions = Internal.componentGhcOptions +componentGhcOptions verbosity lbi = + Internal.componentGhcOptions verbosity implInfo lbi + where + comp = compiler lbi + implInfo = getImplInfo comp componentCcGhcOptions :: Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -1404,15 +1622,14 @@ -- |Install executables for GHC. installExe :: Verbosity -> LocalBuildInfo - -> InstallDirs FilePath -- ^Where to copy the files to + -> FilePath -- ^Where to copy the files to -> FilePath -- ^Build location -> (FilePath, FilePath) -- ^Executable (prefix,suffix) -> PackageDescription -> Executable -> IO () -installExe verbosity lbi installDirs buildPref +installExe verbosity lbi binDir buildPref (progprefix, progsuffix) _pkg exe = do - let binDir = bindir installDirs createDirectoryIfMissingVerbose verbosity True binDir let exeName' = unUnqualComponentName $ exeName exe exeFileName = exeTargetName exe @@ -1446,9 +1663,35 @@ createDirectoryIfMissingVerbose verbosity True targetDir -- TODO: Should we strip? (stripLibs lbi) if isShared - then do installExecutableFile verbosity src dst - else do installOrdinaryFile verbosity src dst + then installExecutableFile verbosity src dst + else installOrdinaryFile verbosity src dst + -- Now install appropriate symlinks if library is versioned + let (Platform _ os) = hostPlatform lbi + when (not (null (foreignLibVersion flib os))) $ do + when (os /= Linux) $ die' verbosity + -- It should be impossible to get here. + "Can't install foreign-library symlink on non-Linux OS" +#ifndef mingw32_HOST_OS + -- 'createSymbolicLink file1 file2' creates a symbolic link + -- named 'file2' which points to the file 'file1'. + -- Note that we do want a symlink to 'name' rather than + -- 'dst', because the symlink will be relative to the + -- directory it's created in. + -- Finally, we first create the symlinks in a temporary + -- directory and then rename to simulate 'ln --force'. + withTempDirectory verbosity dstDir nm $ \tmpDir -> do + let link1 = flibBuildName lbi flib + link2 = "lib" ++ nm <.> "so" + createSymbolicLink name (tmpDir link1) + renameFile (tmpDir link1) (dstDir link1) + createSymbolicLink name (tmpDir link2) + renameFile (tmpDir link2) (dstDir link2) + where + nm :: String + nm = unUnqualComponentName $ foreignLibName flib +#endif /* mingw32_HOST_OS */ + -- |Install for ghc, .hi, .a and, if --with-ghci given, .o installLib :: Verbosity -> LocalBuildInfo @@ -1467,7 +1710,11 @@ -- copy the built library files over: whenHasCode $ do - whenVanilla $ installOrdinary builtDir targetDir vanillaLibName + whenVanilla $ do + sequence_ [ installOrdinary builtDir targetDir (mkGenericStaticLibName (l ++ f)) + | l <- getHSLibraryName (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib)) + , f <- "":extraLibFlavours (libBuildInfo lib) + ] whenProf $ installOrdinary builtDir targetDir profileLibName whenGHCi $ installOrdinary builtDir targetDir ghciLibName whenShared $ installShared builtDir dynlibTargetDir sharedLibName @@ -1478,6 +1725,7 @@ install isShared srcDir dstDir name = do let src = srcDir name dst = dstDir name + createDirectoryIfMissingVerbose verbosity True dstDir if isShared @@ -1496,7 +1744,6 @@ compiler_id = compilerId (compiler lbi) uid = componentUnitId clbi - vanillaLibName = mkLibName uid profileLibName = mkProfLibName uid ghciLibName = Internal.mkGHCiLibName uid sharedLibName = (mkSharedLibName compiler_id) uid @@ -1522,6 +1769,7 @@ , HcPkg.requiresDirDbs = v >= [7,10] , HcPkg.nativeMultiInstance = v >= [7,10] , HcPkg.recacheMultiInstance = v >= [6,12] + , HcPkg.suppressFilesCheck = v >= [6,6] } where v = versionNumbers ver @@ -1531,18 +1779,13 @@ registerPackage :: Verbosity -> ProgramDb - -> HcPkg.MultiInstance -> PackageDBStack -> InstalledPackageInfo + -> HcPkg.RegisterOptions -> IO () -registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo - | HcPkg.MultiInstance <- multiInstance - = HcPkg.registerMultiInstance (hcPkgInfo progdb) verbosity - packageDbs installedPkgInfo - - | otherwise - = HcPkg.reregister (hcPkgInfo progdb) verbosity - packageDbs (Right installedPkgInfo) +registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = + HcPkg.register (hcPkgInfo progdb) verbosity packageDbs + installedPkgInfo registerOptions pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath pkgRoot verbosity lbi = pkgRoot' diff --git a/cabal/Cabal/Distribution/Simple/GHC/IPI642.hs b/cabal/Cabal/Distribution/Simple/GHC/IPI642.hs --- a/cabal/Cabal/Distribution/Simple/GHC/IPI642.hs +++ b/cabal/Cabal/Distribution/Simple/GHC/IPI642.hs @@ -17,7 +17,9 @@ import Distribution.Compat.Prelude import qualified Distribution.InstalledPackageInfo as Current -import qualified Distribution.Package as Current hiding (installedUnitId) +import qualified Distribution.Types.AbiHash as Current +import qualified Distribution.Types.ComponentId as Current +import qualified Distribution.Types.UnitId as Current import Distribution.Simple.GHC.IPIConvert import Distribution.Text @@ -65,13 +67,15 @@ toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo toCurrent ipi@InstalledPackageInfo{} = - let pid = convertPackageId (package ipi) - mkExposedModule m = Current.ExposedModule m Nothing + let mkExposedModule m = Current.ExposedModule m Nothing + pid = convertPackageId (package ipi) in Current.InstalledPackageInfo { Current.sourcePackageId = pid, Current.installedUnitId = Current.mkLegacyUnitId pid, Current.installedComponentId_ = Current.mkComponentId (display pid), Current.instantiatedWith = [], + -- Internal libraries not supported! + Current.sourceLibName = Nothing, Current.compatPackageKey = "", Current.abiHash = Current.mkAbiHash "", -- bogus but old GHCs don't care. Current.license = convertLicense (license ipi), @@ -99,6 +103,7 @@ Current.includeDirs = includeDirs ipi, Current.includes = includes ipi, Current.depends = map (Current.mkLegacyUnitId . convertPackageId) (depends ipi), + Current.abiDepends = [], Current.ccOptions = ccOptions ipi, Current.ldOptions = ldOptions ipi, Current.frameworkDirs = frameworkDirs ipi, diff --git a/cabal/Cabal/Distribution/Simple/GHC/IPIConvert.hs b/cabal/Cabal/Distribution/Simple/GHC/IPIConvert.hs --- a/cabal/Cabal/Distribution/Simple/GHC/IPIConvert.hs +++ b/cabal/Cabal/Distribution/Simple/GHC/IPIConvert.hs @@ -17,20 +17,23 @@ import Prelude () import Distribution.Compat.Prelude -import qualified Distribution.Package as Current hiding (installedUnitId) +import qualified Distribution.Types.PackageId as Current +import qualified Distribution.Types.PackageName as Current import qualified Distribution.License as Current import Distribution.Version import Distribution.ModuleName import Distribution.Text +-- | This is a indeed a munged package id, but the constructor name cannot be +-- changed or the Read instance (the entire point of this type) will break. data PackageIdentifier = PackageIdentifier { pkgName :: String, pkgVersion :: Version } deriving Read -convertPackageId :: PackageIdentifier -> Current.PackageIdentifier +convertPackageId :: PackageIdentifier -> Current.PackageId convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } = Current.PackageIdentifier (Current.mkPackageName n) v diff --git a/cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs b/cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs --- a/cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs +++ b/cabal/Cabal/Distribution/Simple/GHC/ImplInfo.hs @@ -41,7 +41,9 @@ , flagProfAuto :: Bool -- ^ new style -fprof-auto* flags , flagPackageConf :: Bool -- ^ use package-conf instead of package-db , flagDebugInfo :: Bool -- ^ -g flag supported + , supportsDebugLevels :: Bool -- ^ supports numeric @-g@ levels , supportsPkgEnvFiles :: Bool -- ^ picks up @.ghc.environment@ files + , flagWarnMissingHomeModules :: Bool -- ^ -Wmissing-home-modules is supported } getImplInfo :: Compiler -> GhcImplInfo @@ -66,7 +68,9 @@ , flagProfAuto = v >= [7,4] , flagPackageConf = v < [7,5] , flagDebugInfo = v >= [7,10] + , supportsDebugLevels = v >= [8,0] , supportsPkgEnvFiles = v >= [8,0,1,20160901] -- broken in 8.0.1, fixed in 8.0.2 + , flagWarnMissingHomeModules = v >= [8,2] } where v = versionNumbers ver @@ -82,7 +86,9 @@ , flagProfAuto = True , flagPackageConf = False , flagDebugInfo = False + , supportsDebugLevels = ghcv >= [8,0] , supportsPkgEnvFiles = ghcv >= [8,0,2] --TODO: check this works in ghcjs + , flagWarnMissingHomeModules = False } where ghcv = versionNumbers ghcver 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,6 +19,7 @@ targetPlatform, getGhcInfo, componentCcGhcOptions, + componentCxxGhcOptions, componentGhcOptions, mkGHCiLibName, filterGhciFlags, @@ -45,7 +46,6 @@ import Distribution.Compat.Prelude import Distribution.Simple.GHC.ImplInfo -import Distribution.Package import Distribution.Types.ComponentLocalBuildInfo import Distribution.Backpack import Distribution.InstalledPackageInfo @@ -59,6 +59,7 @@ import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program import Distribution.Simple.LocalBuildInfo +import Distribution.Types.UnitId import Distribution.Types.LocalBuildInfo import Distribution.Types.TargetInfo import Distribution.Simple.Utils @@ -228,7 +229,7 @@ | all isSpace ss -> return i _ -> - die "Can't parse --info output of GHC" + die' verbosity "Can't parse --info output of GHC" getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram -> IO [(Extension, String)] @@ -290,10 +291,44 @@ ghcOptObjDir = toFlag odir } -componentGhcOptions :: Verbosity -> LocalBuildInfo + +componentCxxGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo + -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath + -> GhcOptions +componentCxxGhcOptions verbosity _implInfo lbi bi cxxlbi 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 cxxlbi + ,autogenPackageModulesDir lbi + ,odir] + ++ PD.includeDirs bi, + ghcOptHideAllPackages= toFlag True, + ghcOptPackageDBs = withPackageDB lbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages cxxlbi, + ghcOptCxxOptions = toNubListR $ + (case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"]) ++ + (case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"]) ++ + PD.cxxOptions bi, + ghcOptObjDir = toFlag odir + } + + +componentGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> GhcOptions -componentGhcOptions verbosity lbi bi clbi odir = +componentGhcOptions verbosity implInfo lbi bi clbi odir = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! @@ -316,8 +351,10 @@ _ -> [], ghcOptNoCode = toFlag $ componentIsIndefinite clbi, ghcOptHideAllPackages = toFlag True, + ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo, ghcOptPackageDBs = withPackageDB lbi, ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptSplitSections = toFlag (splitSections lbi), ghcOptSplitObjs = toFlag (splitObjs lbi), ghcOptSourcePathClear = toFlag True, ghcOptSourcePath = toNubListR $ [odir] ++ (hsSourceDirs bi) @@ -336,7 +373,7 @@ ghcOptStubDir = toFlag odir, ghcOptOutputDir = toFlag odir, ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), - ghcOptDebugInfo = toGhcDebugInfo (withDebugInfo lbi), + ghcOptDebugInfo = toFlag (withDebugInfo lbi), ghcOptExtra = toNubListR $ hcOptions GHC bi, ghcOptExtraPath = toNubListR $ exe_paths, ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)), @@ -349,12 +386,6 @@ toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation - -- GHC doesn't support debug info levels yet. - toGhcDebugInfo NoDebugInfo = mempty - toGhcDebugInfo MinimalDebugInfo = toFlag True - toGhcDebugInfo NormalDebugInfo = toFlag True - toGhcDebugInfo MaximalDebugInfo = toFlag True - exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt) | uid <- componentExeDeps clbi -- TODO: Ugh, localPkgDescr @@ -435,8 +466,8 @@ -- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set -- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow -- GHC{,JS}_PACKAGE_PATH. -checkPackageDbEnvVar :: String -> String -> IO () -checkPackageDbEnvVar compilerName packagePathEnvVar = do +checkPackageDbEnvVar :: Verbosity -> String -> String -> IO () +checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do mPP <- lookupEnv packagePathEnvVar when (isJust mPP) $ do mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH" @@ -446,7 +477,7 @@ lookupEnv name = (Just `fmap` getEnv name) `catchIO` const (return Nothing) abort = - die $ "Use of " ++ compilerName ++ "'s environment variable " + die' verbosity $ "Use of " ++ compilerName ++ "'s environment variable " ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the " ++ "flag --package-db to specify a package database (it can be " ++ "used multiple times)." @@ -525,13 +556,15 @@ -- -- The 'Platform' and GHC 'Version' are needed as part of the file name. -- +-- Returns the name of the file written. writeGhcEnvironmentFile :: FilePath -- ^ directory in which to put it -> Platform -- ^ the GHC target platform -> Version -- ^ the GHC version -> [GhcEnvironmentFileEntry] -- ^ the content - -> NoCallStackIO () -writeGhcEnvironmentFile directory platform ghcversion = - writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile + -> NoCallStackIO FilePath +writeGhcEnvironmentFile directory platform ghcversion entries = do + writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries + return envfile where envfile = directory ghcEnvironmentFileName platform ghcversion 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 @@ -20,11 +20,11 @@ import Prelude () import Distribution.Compat.Prelude +import Distribution.Types.UnqualComponentName import Distribution.Simple.GHC.ImplInfo import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.PackageDescription as PD import Distribution.InstalledPackageInfo -import Distribution.Package import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo @@ -45,7 +45,7 @@ import Distribution.Verbosity import Distribution.Utils.NubList import Distribution.Text -import Language.Haskell.Extension +import Distribution.Types.UnitId import qualified Data.Map as Map import System.Directory ( doesFileExist ) @@ -75,12 +75,12 @@ Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion verbosity (programPath ghcjsPkgProg) - when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die $ + when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die' verbosity $ "Version mismatch between ghcjs and ghcjs-pkg: " ++ programPath ghcjsProg ++ " is version " ++ display ghcjsVersion ++ " " ++ programPath ghcjsPkgProg ++ " is version " ++ display ghcjsPkgGhcjsVersion - when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die $ + when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die' verbosity $ "Version mismatch between ghcjs and ghcjs-pkg: " ++ programPath ghcjsProg ++ " was built with GHC version " ++ display ghcjsGhcVersion ++ " " @@ -189,8 +189,8 @@ getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb -> IO InstalledPackageIndex getInstalledPackages verbosity packagedbs progdb = do - checkPackageDbEnvVar - checkPackageDbStack packagedbs + checkPackageDbEnvVar verbosity + checkPackageDbStack verbosity packagedbs pkgss <- getInstalledPackages' verbosity packagedbs progdb index <- toPackageIndex verbosity pkgss progdb return $! index @@ -211,20 +211,20 @@ where Just ghcjsProg = lookupProgram ghcjsProgram progdb -checkPackageDbEnvVar :: IO () -checkPackageDbEnvVar = - Internal.checkPackageDbEnvVar "GHCJS" "GHCJS_PACKAGE_PATH" +checkPackageDbEnvVar :: Verbosity -> IO () +checkPackageDbEnvVar verbosity = + Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH" -checkPackageDbStack :: PackageDBStack -> IO () -checkPackageDbStack (GlobalPackageDB:rest) +checkPackageDbStack :: Verbosity -> PackageDBStack -> IO () +checkPackageDbStack _ (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () -checkPackageDbStack rest +checkPackageDbStack verbosity rest | GlobalPackageDB `notElem` rest = - die $ "With current ghc versions the global package db is always used " + die' verbosity $ "With current ghc versions the global package db is always used " ++ "and must be listed first. This ghc limitation may be lifted in " ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977" -checkPackageDbStack _ = - die $ "If the global package db is specified, it must be " +checkPackageDbStack verbosity _ = + die' verbosity $ "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times" getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb @@ -288,7 +288,7 @@ libBi = libBuildInfo lib isGhcjsDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp - doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi + doingTH = usesTemplateHaskellOrQQ libBi forceVanillaLib = doingTH && not isGhcjsDynamic forceSharedLib = doingTH && isGhcjsDynamic -- TH always needs default libs, even when building for profiling @@ -484,7 +484,7 @@ whenGHCiLib $ do (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity ldProg + Ld.combineObjectFiles verbosity lbi ldProg ghciLibFilePath ghciObjFiles whenSharedLib False $ @@ -498,7 +498,7 @@ ghcOptMode = toFlag GhcModeInteractive, ghcOptPackageDBs = packageDBs } - checkPackageDbStack packageDBs + checkPackageDbStack verbosity packageDBs (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb runGHC verbosity ghcjsProg comp platform replOpts @@ -623,7 +623,7 @@ -- by the compiler. -- With dynamic-by-default GHC the TH object files loaded at compile-time -- need to be .dyn_o instead of .o. - doingTH = EnableExtension TemplateHaskell `elem` allExtensions exeBi + doingTH = usesTemplateHaskellOrQQ exeBi -- Should we use -dynamic-too instead of compiling twice? useDynToo = dynamicTooSupported && isGhcjsDynamic && doingTH && withStaticExe && null (ghcjsSharedOptions exeBi) @@ -746,15 +746,14 @@ installExe :: Verbosity -> LocalBuildInfo - -> InstallDirs FilePath -- ^Where to copy the files to + -> FilePath -- ^Where to copy the files to -> FilePath -- ^Build location -> (FilePath, FilePath) -- ^Executable (prefix,suffix) -> PackageDescription -> Executable -> IO () -installExe verbosity lbi installDirs buildPref +installExe verbosity lbi binDir buildPref (progprefix, progsuffix) _pkg exe = do - let binDir = bindir installDirs createDirectoryIfMissingVerbose verbosity True binDir let exeName' = unUnqualComponentName $ exeName exe exeFileName = exeName' @@ -787,9 +786,9 @@ ghcOptProfilingMode = toFlag True, ghcOptExtra = toNubListR (ghcjsProfOptions libBi) } - ghcArgs = if withVanillaLib lbi then vanillaArgs - else if withProfLib lbi then profArgs - else error "libAbiHash: Can't find an enabled library way" + ghcArgs | withVanillaLib lbi = vanillaArgs + | withProfLib lbi = profArgs + | otherwise = error "libAbiHash: Can't find an enabled library way" -- (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) hash <- getProgramInvocationOutput verbosity @@ -805,24 +804,21 @@ registerPackage :: Verbosity -> ProgramDb - -> HcPkg.MultiInstance -> PackageDBStack -> InstalledPackageInfo + -> HcPkg.RegisterOptions -> IO () -registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo - | HcPkg.MultiInstance <- multiInstance - = HcPkg.registerMultiInstance (hcPkgInfo progdb) verbosity - packageDbs installedPkgInfo - - | otherwise - = HcPkg.reregister (hcPkgInfo progdb) verbosity - packageDbs (Right installedPkgInfo) +registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = + HcPkg.register (hcPkgInfo progdb) verbosity packageDbs + installedPkgInfo registerOptions componentGhcOptions :: Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> GhcOptions componentGhcOptions verbosity lbi bi clbi odir = - let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir + let opts = Internal.componentGhcOptions verbosity implInfo lbi bi clbi odir + comp = compiler lbi + implInfo = getImplInfo comp in opts { ghcOptExtra = ghcOptExtra opts `mappend` toNubListR (hcOptions GHCJS bi) } @@ -861,6 +857,7 @@ , HcPkg.requiresDirDbs = ver >= v7_10 , HcPkg.nativeMultiInstance = ver >= v7_10 , HcPkg.recacheMultiInstance = True + , HcPkg.suppressFilesCheck = True } where v7_10 = mkVersion [7,10] diff --git a/cabal/Cabal/Distribution/Simple/Haddock.hs b/cabal/Cabal/Distribution/Simple/Haddock.hs --- a/cabal/Cabal/Distribution/Simple/Haddock.hs +++ b/cabal/Cabal/Distribution/Simple/Haddock.hs @@ -31,12 +31,17 @@ import qualified Distribution.Simple.GHCJS as GHCJS -- local +import Distribution.Backpack.DescribeUnitId import Distribution.Types.ForeignLib +import Distribution.Types.UnqualComponentName +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ExecutableScope import Distribution.Package import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD hiding (Flag) import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.Program.GHC +import Distribution.Simple.Program.ResponseFile import Distribution.Simple.Program import Distribution.Simple.PreProcess import Distribution.Simple.Setup @@ -60,9 +65,8 @@ import Data.Either ( rights ) import System.Directory (doesFileExist) -import System.FilePath ( (), (<.>), normalise, splitPath, joinPath - , isAbsolute ) -import System.IO (hClose, hPutStr, hPutStrLn, hSetEncoding, utf8) +import System.FilePath ( (), (<.>), normalise, isAbsolute ) +import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) -- ------------------------------------------------------------------------------ -- Types @@ -107,7 +111,7 @@ newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord) unDir :: Directory -> FilePath -unDir = joinPath . filter (\p -> p /="./" && p /= ".") . splitPath . unDir' +unDir = normalise . unDir' type Template = String @@ -157,7 +161,6 @@ haddockTarget = fromFlagOrDefault ForDevelopment (haddockForHackage flags') - setupMessage verbosity "Running Haddock for" (packageId pkg_descr) (haddockProg, version, _) <- requireProgramVersion verbosity haddockProgram (orLaterVersion (mkVersion [2,0])) (withPrograms lbi) @@ -165,16 +168,16 @@ -- various sanity checks when ( flag haddockHoogle && version < mkVersion [2,2]) $ - die "haddock 2.0 and 2.1 do not support the --hoogle flag." + die' verbosity "haddock 2.0 and 2.1 do not support the --hoogle flag." haddockGhcVersionStr <- getProgramOutput verbosity haddockProg ["--ghc-version"] case (simpleParse haddockGhcVersionStr, compilerCompatVersion GHC comp) of - (Nothing, _) -> die "Could not get GHC version from Haddock" - (_, Nothing) -> die "Could not get GHC version from compiler" + (Nothing, _) -> die' verbosity "Could not get GHC version from Haddock" + (_, Nothing) -> die' verbosity "Could not get GHC version from compiler" (Just haddockGhcVersion, Just ghcVersion) | haddockGhcVersion == ghcVersion -> return () - | otherwise -> die $ + | otherwise -> die' verbosity $ "Haddock's internal GHC version must match the configured " ++ "GHC version.\n" ++ "The GHC version is " ++ display ghcVersion ++ " but " @@ -193,7 +196,7 @@ , fromPackageDescription haddockTarget pkg_descr ] withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do - initialBuildSteps (flag haddockDistPref) pkg_descr lbi clbi verbosity + componentInitialBuildSteps (flag haddockDistPref) pkg_descr lbi clbi verbosity preprocessComponent pkg_descr component lbi clbi False verbosity suffixes let doExe com = case (compToExe com) of @@ -209,31 +212,39 @@ warn (fromFlag $ haddockVerbosity flags) "Unsupported component, skipping..." return () + -- We define 'smsg' once and then reuse it inside the case, so that + -- we don't say we are running Haddock when we actually aren't + -- (e.g., Haddock is not run on non-libraries) + smsg :: IO () + smsg = setupMessage' verbosity "Running Haddock on" (packageId pkg_descr) + (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) case component of CLib lib -> do withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do + smsg libArgs <- fromLibrary verbosity tmp lbi clbi htmlTemplate version lib let libArgs' = commonArgs `mappend` libArgs runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs' - CFLib flib -> do + CFLib flib -> when (flag haddockForeignLibs) $ do withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do + smsg flibArgs <- fromForeignLib verbosity tmp lbi clbi htmlTemplate version flib let libArgs' = commonArgs `mappend` flibArgs runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs' - CExe _ -> when (flag haddockExecutables) $ doExe component - CTest _ -> when (flag haddockTestSuites) $ doExe component - CBench _ -> when (flag haddockBenchmarks) $ doExe component + CExe _ -> when (flag haddockExecutables) $ smsg >> doExe component + CTest _ -> when (flag haddockTestSuites) $ smsg >> doExe component + CBench _ -> when (flag haddockBenchmarks) $ smsg >> doExe component for_ (extraDocFiles pkg_descr) $ \ fpath -> do files <- matchFileGlob fpath for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs) -- ------------------------------------------------------------------------------ --- Contributions to HaddockArgs. +-- Contributions to HaddockArgs (see also Doctest.hs for very similar code). fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs fromFlags env flags = @@ -319,9 +330,9 @@ then return vanillaOpts else if withSharedLib lbi then return sharedOpts - else die $ "Must have vanilla or shared libraries " + else die' verbosity $ "Must have vanilla or shared libraries " ++ "enabled in order to run haddock" - ghcVersion <- maybe (die "Compiler has no GHC version") + ghcVersion <- maybe (die' verbosity "Compiler has no GHC version") return (compilerCompatVersion GHC (compiler lbi)) @@ -339,7 +350,7 @@ -> Library -> IO HaddockArgs fromLibrary verbosity tmp lbi clbi htmlTemplate haddockVersion lib = do - inFiles <- map snd `fmap` getLibSourceFiles lbi lib clbi + inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles (libBuildInfo lib) return args { @@ -355,7 +366,7 @@ -> Executable -> IO HaddockArgs fromExecutable verbosity tmp lbi clbi htmlTemplate haddockVersion exe = do - inFiles <- map snd `fmap` getExeSourceFiles lbi exe clbi + inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles (buildInfo exe) return args { @@ -372,7 +383,7 @@ -> ForeignLib -> IO HaddockArgs fromForeignLib verbosity tmp lbi clbi htmlTemplate haddockVersion flib = do - inFiles <- map snd `fmap` getFLibSourceFiles lbi flib clbi + inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles (foreignLibBuildInfo flib) return args { @@ -387,12 +398,14 @@ Just Executable { exeName = testName test, modulePath = f, + exeScope = ExecutablePublic, buildInfo = testBuildInfo test } CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } -> Just Executable { exeName = benchmarkName bench, modulePath = f, + exeScope = ExecutablePublic, buildInfo = benchmarkBuildInfo bench } CExe exe -> Just exe @@ -404,8 +417,8 @@ -> Maybe PathTemplate -- ^ template for HTML location -> IO HaddockArgs getInterfaces verbosity lbi clbi htmlTemplate = do - (packageFlags, warnings) <- haddockPackageFlags lbi clbi htmlTemplate - traverse_ (warn verbosity) warnings + (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate + traverse_ (warn (verboseUnmarkOutput verbosity)) warnings return $ mempty { argInterfaces = packageFlags } @@ -477,18 +490,14 @@ renderedArgs = pflag : renderPureArgs version comp platform args if haddockSupportsResponseFiles then - withTempFileEx tmpFileOpts outputDir "haddock-response.txt" $ - \responseFileName hf -> do - when haddockSupportsUTF8 (hSetEncoding hf utf8) - let responseContents = - unlines $ map escapeArg renderedArgs - hPutStr hf responseContents - hClose hf - info verbosity $ responseFileName ++ " contents: <<<" - info verbosity responseContents - info verbosity $ ">>> " ++ responseFileName - let respFile = "@" ++ responseFileName - k ([respFile], result) + withResponseFile + verbosity + tmpFileOpts + outputDir + "haddock-response.txt" + (if haddockSupportsUTF8 then Just utf8 else Nothing) + renderedArgs + (\responseFileName -> k (["@" ++ responseFileName], result)) else k (renderedArgs, result) where @@ -503,19 +512,6 @@ pkgstr = display $ packageName pkgid pkgid = arg argPackageName arg f = fromFlag $ f args - -- Support a gcc-like response file syntax. Each separate - -- argument and its possible parameter(s), will be separated in the - -- response file by an actual newline; all other whitespace, - -- single quotes, double quotes, and the character used for escaping - -- (backslash) are escaped. The called program will need to do a similar - -- inverse operation to de-escape and re-constitute the argument list. - escape cs c - | isSpace c - || '\\' == c - || '\'' == c - || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result - | otherwise = c:cs - escapeArg = reverse . foldl' escape [] renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String] renderPureArgs version comp platform args = concat @@ -625,16 +621,17 @@ fixFileUrl f | isAbsolute f = "file://" ++ f | otherwise = f -haddockPackageFlags :: LocalBuildInfo +haddockPackageFlags :: Verbosity + -> LocalBuildInfo -> ComponentLocalBuildInfo -> Maybe PathTemplate -> IO ([(FilePath, Maybe FilePath)], Maybe String) -haddockPackageFlags lbi clbi htmlTemplate = do +haddockPackageFlags verbosity lbi clbi htmlTemplate = do let allPkgs = installedPkgs lbi directDeps = map fst (componentPackageDeps clbi) transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of Left x -> return x - Right inf -> die $ "internal error when calculating transitive " + Right inf -> die' verbosity $ "internal error when calculating transitive " ++ "package dependencies.\nDebug info: " ++ show inf haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath where @@ -649,8 +646,11 @@ (PrefixVar, prefix (installDirTemplates lbi)) -- We want the legacy unit ID here, because it gives us nice paths -- (Haddock people don't care about the dependencies) - : initialPathTemplateEnv pkg_id (mkLegacyUnitId pkg_id) (compilerInfo (compiler lbi)) - (hostPlatform lbi) + : initialPathTemplateEnv + pkg_id + (mkLegacyUnitId pkg_id) + (compilerInfo (compiler lbi)) + (hostPlatform lbi) -- ------------------------------------------------------------------------------ -- hscolour support. @@ -660,7 +660,7 @@ -> [PPSuffixHandler] -> HscolourFlags -> IO () -hscolour = hscolour' die ForDevelopment +hscolour = hscolour' dieNoVerbosity ForDevelopment hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. -> HaddockTarget @@ -681,14 +681,14 @@ hscolourPref haddockTarget distPref pkg_descr withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do - initialBuildSteps distPref pkg_descr lbi clbi verbosity + componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes let doExe com = case (compToExe com) of Just exe -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr unUnqualComponentName (exeName exe) "src" - runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe clbi + runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi Nothing -> do warn (fromFlag $ hscolourVerbosity flags) "Unsupported component, skipping..." @@ -696,11 +696,11 @@ case comp of CLib lib -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr "src" - runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib clbi + runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi CFLib flib -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr unUnqualComponentName (foreignLibName flib) "src" - runHsColour hscolourProg outputDir =<< getFLibSourceFiles lbi flib clbi + runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp @@ -738,68 +738,6 @@ hscolourVerbosity = haddockVerbosity flags, hscolourDistPref = haddockDistPref flags } ---------------------------------------------------------------------------------- --- TODO these should be moved elsewhere. - -getLibSourceFiles :: LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] -getLibSourceFiles lbi lib clbi = getSourceFiles searchpaths modules - where - bi = libBuildInfo lib - modules = allLibModules lib clbi - searchpaths = componentBuildDir lbi clbi : hsSourceDirs bi ++ - [ autogenComponentModulesDir lbi clbi - , autogenPackageModulesDir lbi ] - -getExeSourceFiles :: LocalBuildInfo - -> Executable - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] -getExeSourceFiles lbi exe clbi = do - moduleFiles <- getSourceFiles searchpaths modules - srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe) - return ((ModuleName.main, srcMainPath) : moduleFiles) - where - bi = buildInfo exe - modules = otherModules bi - searchpaths = autogenComponentModulesDir lbi clbi - : autogenPackageModulesDir lbi - : exeBuildDir lbi exe : hsSourceDirs bi - -getFLibSourceFiles :: LocalBuildInfo - -> ForeignLib - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] -getFLibSourceFiles lbi flib clbi = getSourceFiles searchpaths modules - where - bi = foreignLibBuildInfo flib - modules = otherModules bi - searchpaths = autogenComponentModulesDir lbi clbi - : autogenPackageModulesDir lbi - : flibBuildDir lbi flib : hsSourceDirs bi - -getSourceFiles :: [FilePath] - -> [ModuleName.ModuleName] - -> IO [(ModuleName.ModuleName, FilePath)] -getSourceFiles dirs modules = flip traverse modules $ \m -> fmap ((,) m) $ - findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m) - >>= maybe (notFound m) (return . normalise) - where - notFound module_ = die $ "haddock: can't find source for module " ++ display module_ - --- | The directory where we put build results for an executable -exeBuildDir :: LocalBuildInfo -> Executable -> FilePath -exeBuildDir lbi exe = buildDir lbi nm nm ++ "-tmp" - where - nm = unUnqualComponentName $ exeName exe - --- | The directory where we put build results for a foreign library -flibBuildDir :: LocalBuildInfo -> ForeignLib -> FilePath -flibBuildDir lbi flib = buildDir lbi nm nm ++ "-tmp" - where - nm = unUnqualComponentName $ foreignLibName flib -- ------------------------------------------------------------------------------ -- Boilerplate Monoid instance. 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 @@ -34,7 +34,7 @@ -- least some information from the user. hcPath <- let msg = "You have to provide name or path of a haskell-suite tool (-w PATH)" - in maybe (die msg) return mbHcPath + in maybe (die' verbosity msg) return mbHcPath when (isJust hcPkgPath) $ warn verbosity "--with-hc-pkg option is ignored for haskell-suite" @@ -98,7 +98,7 @@ name = concat $ init parts -- there shouldn't be any spaces in the name anyway versionStr = last parts version <- - maybe (die "haskell-suite: couldn't determine compiler version") return $ + maybe (die' verbosity "haskell-suite: couldn't determine compiler version") return $ simpleParse versionStr return (name, version) @@ -127,10 +127,10 @@ do str <- getDbProgramOutput verbosity haskellSuitePkgProgram progdb ["dump", packageDbOpt packagedb] - `catchExit` \_ -> die $ "pkg dump failed" + `catchExit` \_ -> die' verbosity $ "pkg dump failed" case parsePackages str of Right ok -> return ok - _ -> die "failed to parse output of 'pkg dump'" + _ -> die' verbosity "failed to parse output of 'pkg dump'" where parsePackages str = diff --git a/cabal/Cabal/Distribution/Simple/Hpc.hs b/cabal/Cabal/Distribution/Simple/Hpc.hs --- a/cabal/Cabal/Distribution/Simple/Hpc.hs +++ b/cabal/Cabal/Distribution/Simple/Hpc.hs @@ -27,8 +27,8 @@ import Prelude () import Distribution.Compat.Prelude +import Distribution.Types.UnqualComponentName import Distribution.ModuleName ( main ) -import Distribution.Package import Distribution.PackageDescription ( TestSuite(..) , testModules diff --git a/cabal/Cabal/Distribution/Simple/Install.hs b/cabal/Cabal/Distribution/Simple/Install.hs --- a/cabal/Cabal/Distribution/Simple/Install.hs +++ b/cabal/Cabal/Distribution/Simple/Install.hs @@ -26,6 +26,8 @@ import Distribution.Types.LocalBuildInfo import Distribution.Types.ForeignLib import Distribution.Types.PackageDescription +import Distribution.Types.UnqualComponentName +import Distribution.Types.ExecutableScope import Distribution.Package import Distribution.PackageDescription @@ -34,7 +36,7 @@ import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose , installDirectoryContents, installOrdinaryFile, isInSearchPath - , die, info, notice, warn, matchDirFileGlob ) + , die', info, noticeNoWrap, warn, matchDirFileGlob ) import Distribution.Simple.Compiler ( CompilerFlavor(..), compilerFlavor ) import Distribution.Simple.Setup @@ -86,7 +88,7 @@ checkHasLibsOrExes = unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $ - die "No executables and no library found. Nothing to do." + die' verbosity "No executables and no library found. Nothing to do." -- | Copy package global files. copyPackage :: Verbosity -> PackageDescription @@ -164,12 +166,12 @@ buildPref = componentBuildDir lbi clbi case libName lib of - Nothing -> notice verbosity ("Installing library in " ++ libPref) - Just n -> notice verbosity ("Installing internal library " ++ display n ++ " in " ++ libPref) + Nothing -> noticeNoWrap verbosity ("Installing library in " ++ libPref) + Just n -> noticeNoWrap verbosity ("Installing internal library " ++ display n ++ " in " ++ libPref) -- install include files for all compilers - they may be needed to compile -- haskell files (using the CPP extension) - installIncludeFiles verbosity lib incPref + installIncludeFiles verbosity lib buildPref incPref case compilerFlavor (compiler lbi) of GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi @@ -179,7 +181,7 @@ UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi HaskellSuite _ -> HaskellSuite.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - _ -> die $ "installing with " + _ -> die' verbosity $ "installing with " ++ display (compilerFlavor (compiler lbi)) ++ " is not implemented" @@ -189,37 +191,40 @@ } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest buildPref = componentBuildDir lbi clbi - notice verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref) + noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref) case compilerFlavor (compiler lbi) of GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib - _ -> die $ "installing foreign lib with " + _ -> die' verbosity $ "installing foreign lib with " ++ display (compilerFlavor (compiler lbi)) ++ " is not implemented" copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do - let installDirs@InstallDirs { - bindir = binPref - } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest + let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest -- the installers know how to find the actual location of the -- binaries buildPref = buildDir lbi uid = componentUnitId clbi - progPrefixPref = substPathTemplate (packageId pkg_descr) lbi uid (progPrefix lbi) - progSuffixPref = substPathTemplate (packageId pkg_descr) lbi uid (progSuffix lbi) - notice verbosity ("Installing executable " ++ display (exeName exe) ++ " in " ++ binPref) + pkgid = packageId pkg_descr + binPref | ExecutablePrivate <- exeScope exe = libexecdir installDirs + | otherwise = bindir installDirs + progPrefixPref = substPathTemplate pkgid lbi uid (progPrefix lbi) + progSuffixPref = substPathTemplate pkgid lbi uid (progSuffix lbi) + progFix = (progPrefixPref, progSuffixPref) + noticeNoWrap verbosity ("Installing executable " ++ display (exeName exe) + ++ " in " ++ binPref) inPath <- isInSearchPath binPref when (not inPath) $ warn verbosity ("The directory " ++ binPref ++ " is not in the system search path.") case compilerFlavor (compiler lbi) of - GHC -> GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr exe - GHCJS -> GHCJS.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr exe - LHC -> LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr exe - JHC -> JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr exe + GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe + GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe + LHC -> LHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe + JHC -> JHC.installExe verbosity binPref buildPref progFix pkg_descr exe UHC -> return () HaskellSuite {} -> return () - _ -> die $ "installing with " + _ -> die' verbosity $ "installing with " ++ display (compilerFlavor (compiler lbi)) ++ " is not implemented" @@ -242,11 +247,12 @@ -- | Install the files listed in install-includes for a library -- -installIncludeFiles :: Verbosity -> Library -> FilePath -> IO () -installIncludeFiles verbosity lib destIncludeDir = do +installIncludeFiles :: Verbosity -> Library -> FilePath -> FilePath -> IO () +installIncludeFiles verbosity lib buildPref destIncludeDir = do let relincdirs = "." : filter isRelative (includeDirs lbi) lbi = libBuildInfo lib - incs <- traverse (findInc relincdirs) (installIncludes lbi) + incdirs = relincdirs ++ [ buildPref dir | dir <- relincdirs ] + incs <- traverse (findInc incdirs) (installIncludes lbi) sequence_ [ do createDirectoryIfMissingVerbose verbosity True destDir installOrdinaryFile verbosity srcFile destFile @@ -255,7 +261,7 @@ destDir = takeDirectory destFile ] where - findInc [] file = die ("can't find include file " ++ file) + findInc [] file = die' verbosity ("can't find include file " ++ file) findInc (dir:dirs) file = do let path = dir file exists <- doesFileExist path diff --git a/cabal/Cabal/Distribution/Simple/InstallDirs.hs b/cabal/Cabal/Distribution/Simple/InstallDirs.hs --- a/cabal/Cabal/Distribution/Simple/InstallDirs.hs +++ b/cabal/Cabal/Distribution/Simple/InstallDirs.hs @@ -38,6 +38,7 @@ PathTemplateEnv, toPathTemplate, fromPathTemplate, + combinePathTemplate, substPathTemplate, initialPathTemplateEnv, platformTemplateEnv, @@ -56,8 +57,9 @@ import Distribution.Text import System.Directory (getAppUserDataDirectory) -import System.FilePath ((), isPathSeparator, pathSeparator) -import System.FilePath (dropDrive) +import System.FilePath + ( (), isPathSeparator + , pathSeparator, dropDrive ) #ifdef mingw32_HOST_OS import qualified Prelude @@ -84,6 +86,7 @@ dynlibdir :: dir, flibdir :: dir, -- ^ foreign libraries libexecdir :: dir, + libexecsubdir:: dir, includedir :: dir, datadir :: dir, datasubdir :: dir, @@ -115,6 +118,7 @@ dynlibdir = dynlibdir a `combine` dynlibdir b, flibdir = flibdir a `combine` flibdir b, libexecdir = libexecdir a `combine` libexecdir b, + libexecsubdir= libexecsubdir a `combine` libexecsubdir b, includedir = includedir a `combine` includedir b, datadir = datadir a `combine` datadir b, datasubdir = datasubdir a `combine` datasubdir b, @@ -128,8 +132,10 @@ appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a appendSubdirs append dirs = dirs { libdir = libdir dirs `append` libsubdir dirs, + libexecdir = libexecdir dirs `append` libexecsubdir dirs, datadir = datadir dirs `append` datasubdir dirs, libsubdir = error "internal error InstallDirs.libsubdir", + libexecsubdir = error "internal error InstallDirs.libexecsubdir", datasubdir = error "internal error InstallDirs.datasubdir" } @@ -199,6 +205,7 @@ LHC -> "$compiler" UHC -> "$pkgid" _other -> "$abi", + libexecsubdir= "$abi" "$pkgid", flibdir = "$libdir", libexecdir = case buildOS of Windows -> "$prefix" "$libname" @@ -243,6 +250,7 @@ dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar], flibdir = subst flibdir [prefixVar, bindirVar, libdirVar], libexecdir = subst libexecdir prefixBinLibVars, + libexecsubdir = subst libexecsubdir [], includedir = subst includedir prefixBinLibVars, datadir = subst datadir prefixBinLibVars, datasubdir = subst datasubdir [], diff --git a/cabal/Cabal/Distribution/Simple/JHC.hs b/cabal/Cabal/Distribution/Simple/JHC.hs --- a/cabal/Cabal/Distribution/Simple/JHC.hs +++ b/cabal/Cabal/Distribution/Simple/JHC.hs @@ -32,6 +32,9 @@ import Distribution.Simple.Compiler import Language.Haskell.Extension import Distribution.Simple.Program +import Distribution.Types.MungedPackageId (mungedName) +import Distribution.Types.PackageId +import Distribution.Types.UnitId import Distribution.Version import Distribution.Package import Distribution.Simple.Utils @@ -153,7 +156,7 @@ -- It would be better if JHC would accept package names with versions, -- but JHC-0.7.2 doesn't accept this. -- Thus, we have to strip the version with 'pkgName'. - ++ (concat [ ["-p", display (pkgName pkgid)] + ++ (concat [ ["-p", display (mungedName pkgid)] | (_, pkgid) <- componentPackageDeps clbi ]) jhcPkgConf :: PackageDescription -> String diff --git a/cabal/Cabal/Distribution/Simple/LHC.hs b/cabal/Cabal/Distribution/Simple/LHC.hs --- a/cabal/Cabal/Distribution/Simple/LHC.hs +++ b/cabal/Cabal/Distribution/Simple/LHC.hs @@ -46,6 +46,7 @@ import Prelude () import Distribution.Compat.Prelude +import Distribution.Types.UnqualComponentName import Distribution.PackageDescription as PD hiding (Flag) import Distribution.InstalledPackageInfo import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo @@ -91,7 +92,7 @@ (orLaterVersion (mkVersion [0,7])) (userMaybeSpecifyPath "lhc-pkg" hcPkgPath progdb') - when (lhcVersion /= lhcPkgVersion) $ die $ + when (lhcVersion /= lhcPkgVersion) $ die' verbosity $ "Version mismatch between lhc and lhc-pkg: " ++ programPath lhcProg ++ " is version " ++ display lhcVersion ++ " " ++ programPath lhcPkgProg ++ " is version " ++ display lhcPkgVersion @@ -199,7 +200,7 @@ getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb -> IO InstalledPackageIndex getInstalledPackages verbosity packagedbs progdb = do - checkPackageDbStack packagedbs + checkPackageDbStack verbosity packagedbs pkgss <- getInstalledPackages' lhcPkg verbosity packagedbs progdb let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) | (_, pkgs) <- pkgss ] @@ -214,11 +215,12 @@ compilerDir = takeDirectory (programPath ghcProg) topDir = takeDirectory compilerDir -checkPackageDbStack :: PackageDBStack -> IO () -checkPackageDbStack (GlobalPackageDB:rest) +checkPackageDbStack :: Verbosity -> PackageDBStack -> IO () +checkPackageDbStack _ (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () -checkPackageDbStack _ = - die $ "GHC.getInstalledPackages: the global package db must be " +checkPackageDbStack verbosity _ = + die' verbosity $ + "GHC.getInstalledPackages: the global package db must be " ++ "specified first and cannot be specified multiple times" -- | Get the packages from specific PackageDBs, not cumulative. @@ -231,10 +233,10 @@ sequenceA [ do str <- getDbProgramOutput verbosity lhcPkgProgram progdb ["dump", packageDbGhcPkgFlag packagedb] - `catchExit` \_ -> die $ "ghc-pkg dump failed" + `catchExit` \_ -> die' verbosity $ "ghc-pkg dump failed" case parsePackages str of Left ok -> return (packagedb, ok) - _ -> die "failed to parse output of 'ghc-pkg dump'" + _ -> die' verbosity "failed to parse output of 'ghc-pkg dump'" | packagedb <- packagedbs ] where @@ -304,7 +306,7 @@ (compiler lbi) (withProfLib lbi) (libBuildInfo lib) let libTargetDir = pref - forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi + forceVanillaLib = usesTemplateHaskellOrQQ libBi -- TH always needs vanilla libs, even when building for profiling createDirectoryIfMissingVerbose verbosity True libTargetDir @@ -513,7 +515,7 @@ -- with profiling. This is because the code that TH needs to -- run at compile time needs to be the vanilla ABI so it can -- be loaded up and run by the compiler. - when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi) + when (withProfExe lbi && usesTemplateHaskellOrQQ exeBi) (runGhcProg $ lhcWrap (binArgs False False)) runGhcProg (binArgs True (withProfExe lbi)) @@ -667,14 +669,13 @@ -- |Install executables for GHC. installExe :: Verbosity -> LocalBuildInfo - -> InstallDirs FilePath -- ^Where to copy the files to + -> FilePath -- ^Where to copy the files to -> FilePath -- ^Build location -> (FilePath, FilePath) -- ^Executable (prefix,suffix) -> PackageDescription -> Executable -> IO () -installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do - let binDir = bindir installDirs +installExe verbosity lbi binDir buildPref (progprefix, progsuffix) _pkg exe = do createDirectoryIfMissingVerbose verbosity True binDir let exeFileName = unUnqualComponentName (exeName exe) <.> exeExtension fixedExeBaseName = progprefix ++ unUnqualComponentName (exeName exe) ++ progsuffix @@ -756,10 +757,11 @@ -> ProgramDb -> PackageDBStack -> InstalledPackageInfo + -> HcPkg.RegisterOptions -> IO () -registerPackage verbosity progdb packageDbs installedPkgInfo = - HcPkg.reregister (hcPkgInfo progdb) verbosity packageDbs - (Right installedPkgInfo) +registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = + HcPkg.register (hcPkgInfo progdb) verbosity packageDbs + installedPkgInfo registerOptions hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = lhcPkgProg @@ -770,6 +772,7 @@ , HcPkg.requiresDirDbs = True , HcPkg.nativeMultiInstance = False -- ? , HcPkg.recacheMultiInstance = False -- ? + , HcPkg.suppressFilesCheck = True } where Just lhcPkgProg = lookupProgram lhcPkgProgram progdb diff --git a/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs b/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs --- a/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs +++ b/cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs @@ -62,14 +62,17 @@ module Distribution.Simple.InstallDirs, absoluteInstallDirs, prefixRelativeInstallDirs, absoluteComponentInstallDirs, prefixRelativeComponentInstallDirs, - substPathTemplate + substPathTemplate, ) where import Prelude () import Distribution.Compat.Prelude import Distribution.Types.Component +import Distribution.Types.PackageId +import Distribution.Types.UnitId import Distribution.Types.ComponentName +import Distribution.Types.UnqualComponentName import Distribution.Types.PackageDescription import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.LocalBuildInfo @@ -380,3 +383,4 @@ uid (compilerInfo (compiler lbi)) (hostPlatform lbi) + 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 @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- -- | @@ -16,39 +18,25 @@ -- rename it to 'UnitIndex'); but in the absence of internal libraries -- or Backpack each unit is equivalent to a package. -- --- 'PackageIndex' is parametric over what it actually records, and it --- is used in two ways: --- --- * The 'InstalledPackageIndex' (defined here) contains a graph of --- 'InstalledPackageInfo's representing the packages in a --- package database stack. It is used in a variety of ways: --- --- * The primary use to let Cabal access the same installed --- package database which is used by GHC during compilation. --- For example, this data structure is used by 'ghc-pkg' --- and 'Cabal' to do consistency checks on the database --- (are the references closed). --- --- * Given a set of dependencies, we can compute the transitive --- closure of dependencies. This is to check if the versions --- of packages are consistent, and also needed by multiple --- tools (Haddock must be explicitly told about the every --- transitive package to do cross-package linking; --- preprocessors must know about the include paths of all --- transitive dependencies.) +-- While 'PackageIndex' is parametric over what it actually records, +-- it is in fact only ever instantiated with a single element: +-- The 'InstalledPackageIndex' (defined here) contains a graph of +-- 'InstalledPackageInfo's representing the packages in a +-- package database stack. It is used in a variety of ways: -- --- * The 'PlanIndex' (defined in 'Distribution.Client.InstallPlan'), --- contains a graph of 'GenericPlanPackage'. Ignoring its type --- parameters for a moment, a 'PlanIndex' is an extension of the --- 'InstalledPackageIndex' to also record nodes for packages --- which are *planned* to be installed, but not actually --- installed yet. A 'PlanIndex' containing only 'PreExisting' --- packages is essentially a 'PackageIndex'. +-- * The primary use to let Cabal access the same installed +-- package database which is used by GHC during compilation. +-- For example, this data structure is used by 'ghc-pkg' +-- and 'Cabal' to do consistency checks on the database +-- (are the references closed). -- --- 'PlanIndex'es actually require some auxiliary information, so --- most users interact with a 'GenericInstallPlan'. This type is --- specialized as an 'ElaboratedInstallPlan' (for @cabal --- new-build@) or an 'InstallPlan' (for @cabal install@). +-- * Given a set of dependencies, we can compute the transitive +-- closure of dependencies. This is to check if the versions +-- of packages are consistent, and also needed by multiple +-- tools (Haddock must be explicitly told about the every +-- transitive package to do cross-package linking; +-- preprocessors must know about the include paths of all +-- transitive dependencies.) -- -- This 'PackageIndex' is NOT to be confused with -- 'Distribution.Client.PackageIndex', which indexes packages only by @@ -82,6 +70,7 @@ lookupPackageId, lookupPackageName, lookupDependency, + lookupInternalDependency, -- ** Case-insensitive searches searchByName, @@ -92,6 +81,7 @@ allPackages, allPackagesByName, allPackagesBySourcePackageId, + allPackagesBySourcePackageIdAndLibName, -- ** Special queries brokenPackages, @@ -111,6 +101,7 @@ import Prelude () import Distribution.Compat.Prelude hiding (lookup) +import qualified Distribution.Compat.Map.Strict as Map import Distribution.Package import Distribution.Backpack @@ -118,14 +109,16 @@ import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Version import Distribution.Simple.Utils +import Distribution.Types.UnqualComponentName import Control.Exception (assert) import Data.Array ((!)) import qualified Data.Array as Array import qualified Data.Graph as Graph import Data.List as List ( groupBy, deleteBy, deleteFirstsBy ) -import qualified Data.Map as Map import qualified Data.Tree as Tree +import Control.Monad +import Distribution.Compat.Stack -- | The collection of information about packages from one or more 'PackageDB's. -- These packages generally should have an instance of 'PackageInstalled' @@ -150,7 +143,7 @@ -- -- FIXME: Clarify what "preference order" means. Check that this invariant is -- preserved. See #1463 for discussion. - packageIdIndex :: !(Map PackageName (Map Version [a])) + packageIdIndex :: !(Map (PackageName, Maybe UnqualComponentName) (Map Version [a])) } deriving (Eq, Generic, Show, Read) @@ -160,22 +153,26 @@ -- use this. type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo -instance HasUnitId a => Monoid (PackageIndex a) where +instance Monoid (PackageIndex IPI.InstalledPackageInfo) where mempty = PackageIndex Map.empty Map.empty mappend = (<>) --save one mappend with empty in the common case: mconcat [] = mempty mconcat xs = foldr1 mappend xs -instance HasUnitId a => Semigroup (PackageIndex a) where +instance Semigroup (PackageIndex IPI.InstalledPackageInfo) where (<>) = merge -invariant :: HasUnitId a => PackageIndex a -> Bool +{-# NOINLINE invariant #-} +invariant :: WithCallStack (InstalledPackageIndex -> Bool) invariant (PackageIndex pids pnames) = - map installedUnitId (Map.elems pids) - == sort + -- trace (show pids' ++ "\n" ++ show pnames') $ + pids' == pnames' + where + pids' = map installedUnitId (Map.elems pids) + pnames' = sort [ assert pinstOk (installedUnitId pinst) - | (pname, pvers) <- Map.toList pnames + | ((pname, plib), pvers) <- Map.toList pnames , let pversOk = not (Map.null pvers) , (pver, pinsts) <- assert pversOk $ Map.toList pvers , let pinsts' = sortBy (comparing installedUnitId) pinsts @@ -184,6 +181,7 @@ , pinst <- assert pinstsOk $ pinsts' , let pinstOk = packageName pinst == pname && packageVersion pinst == pver + && IPI.sourceLibName pinst == plib ] -- If you see this invariant failing (ie the assert in mkPackageIndex below) -- then one thing to check is if it is happening in fromList. Check if the @@ -196,10 +194,10 @@ -- * Internal helpers -- -mkPackageIndex :: HasUnitId a - => Map UnitId a - -> Map PackageName (Map Version [a]) - -> PackageIndex a +mkPackageIndex :: WithCallStack (Map UnitId IPI.InstalledPackageInfo + -> Map (PackageName, Maybe UnqualComponentName) + (Map Version [IPI.InstalledPackageInfo]) + -> InstalledPackageIndex) mkPackageIndex pids pnames = assert (invariant index) index where index = PackageIndex pids pnames @@ -213,15 +211,15 @@ -- If there are duplicates by 'UnitId' then later ones mask earlier -- ones. -- -fromList :: HasUnitId a => [a] -> PackageIndex a +fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex fromList pkgs = mkPackageIndex pids pnames where pids = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ] pnames = Map.fromList - [ (packageName (head pkgsN), pvers) - | pkgsN <- groupBy (equating packageName) - . sortBy (comparing packageId) + [ (liftM2 (,) packageName IPI.sourceLibName (head pkgsN), pvers) + | pkgsN <- groupBy (equating (liftM2 (,) packageName IPI.sourceLibName)) + . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion)) $ pkgs , let pvers = Map.fromList @@ -245,8 +243,8 @@ -- result when we do a lookup by source 'PackageId'. This is the mechanism we -- use to prefer user packages over global packages. -- -merge :: HasUnitId a => PackageIndex a -> PackageIndex a - -> PackageIndex a +merge :: InstalledPackageIndex -> InstalledPackageIndex + -> InstalledPackageIndex merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2) (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) @@ -262,7 +260,7 @@ -- This is equivalent to (but slightly quicker than) using 'mappend' or -- 'merge' with a singleton index. -- -insert :: HasUnitId a => a -> PackageIndex a -> PackageIndex a +insert :: IPI.InstalledPackageInfo -> InstalledPackageIndex -> InstalledPackageIndex insert pkg (PackageIndex pids pnames) = mkPackageIndex pids' pnames' @@ -270,12 +268,12 @@ pids' = Map.insert (installedUnitId pkg) pkg pids pnames' = insertPackageName pnames insertPackageName = - Map.insertWith' (\_ -> insertPackageVersion) - (packageName pkg) + Map.insertWith (\_ -> insertPackageVersion) + (packageName pkg, IPI.sourceLibName pkg) (Map.singleton (packageVersion pkg) [pkg]) insertPackageVersion = - Map.insertWith' (\_ -> insertPackageInstance) + Map.insertWith (\_ -> insertPackageInstance) (packageVersion pkg) [pkg] insertPackageInstance pkgs = @@ -284,9 +282,8 @@ -- | Removes a single installed package from the index. -- -deleteUnitId :: HasUnitId a - => UnitId -> PackageIndex a - -> PackageIndex a +deleteUnitId :: UnitId -> InstalledPackageIndex + -> InstalledPackageIndex deleteUnitId ipkgid original@(PackageIndex pids pnames) = case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of (Nothing, _) -> original @@ -295,7 +292,7 @@ where deletePkgName spkgid = - Map.update (deletePkgVersion spkgid) (packageName spkgid) + Map.update (deletePkgVersion spkgid) (packageName spkgid, IPI.sourceLibName spkgid) deletePkgVersion spkgid = (\m -> if Map.null m then Nothing else Just m) @@ -307,17 +304,17 @@ -- | Backwards compatibility wrapper for Cabal pre-1.24. {-# DEPRECATED deleteInstalledPackageId "Use deleteUnitId instead" #-} -deleteInstalledPackageId :: HasUnitId a - => UnitId -> PackageIndex a - -> PackageIndex a +deleteInstalledPackageId :: UnitId -> InstalledPackageIndex + -> InstalledPackageIndex deleteInstalledPackageId = deleteUnitId -- | Removes all packages with this source 'PackageId' from the index. -- -deleteSourcePackageId :: HasUnitId a => PackageId -> PackageIndex a - -> PackageIndex a +deleteSourcePackageId :: PackageId -> InstalledPackageIndex + -> InstalledPackageIndex deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = - case Map.lookup (packageName pkgid) pnames of + -- NB: Doesn't delete internal packages + case Map.lookup (packageName pkgid, Nothing) pnames of Nothing -> original Just pvers -> case Map.lookup (packageVersion pkgid) pvers of Nothing -> original @@ -326,7 +323,7 @@ (deletePkgName pnames) where deletePkgName = - Map.update deletePkgVersion (packageName pkgid) + Map.update deletePkgVersion (packageName pkgid, Nothing) deletePkgVersion = (\m -> if Map.null m then Nothing else Just m) @@ -335,15 +332,17 @@ -- | Removes all packages with this (case-sensitive) name from the index. -- -deletePackageName :: HasUnitId a => PackageName -> PackageIndex a - -> PackageIndex a +-- NB: Does NOT delete internal libraries from this package. +-- +deletePackageName :: PackageName -> InstalledPackageIndex + -> InstalledPackageIndex deletePackageName name original@(PackageIndex pids pnames) = - case Map.lookup name pnames of + case Map.lookup (name, Nothing) pnames of Nothing -> original Just pvers -> mkPackageIndex (foldl' (flip (Map.delete . installedUnitId)) pids (concat (Map.elems pvers))) - (Map.delete name pnames) + (Map.delete (name, Nothing) pnames) {- -- | Removes all packages satisfying this dependency from the index. @@ -366,23 +365,39 @@ -- -- They are grouped by package name (case-sensitively). -- +-- (Doesn't include private libraries.) +-- allPackagesByName :: PackageIndex a -> [(PackageName, [a])] allPackagesByName index = [ (pkgname, concat (Map.elems pvers)) - | (pkgname, pvers) <- Map.toList (packageIdIndex index) ] + | ((pkgname, Nothing), pvers) <- Map.toList (packageIdIndex index) ] -- | Get all the packages from the index. -- -- They are grouped by source package id (package name and version). -- +-- (Doesn't include private libraries) +-- allPackagesBySourcePackageId :: HasUnitId a => PackageIndex a -> [(PackageId, [a])] allPackagesBySourcePackageId index = [ (packageId ipkg, ipkgs) - | pvers <- Map.elems (packageIdIndex index) + | ((_, Nothing), pvers) <- Map.toList (packageIdIndex index) , ipkgs@(ipkg:_) <- Map.elems pvers ] +-- | Get all the packages from the index. -- +-- They are grouped by source package id and library name. +-- +-- This DOES include internal libraries. +allPackagesBySourcePackageIdAndLibName :: HasUnitId a => PackageIndex a + -> [((PackageId, Maybe UnqualComponentName), [a])] +allPackagesBySourcePackageIdAndLibName index = + [ ((packageId ipkg, ln), ipkgs) + | ((_, ln), pvers) <- Map.toList (packageIdIndex index) + , ipkgs@(ipkg:_) <- Map.elems pvers ] + +-- -- * Lookups -- @@ -418,7 +433,8 @@ -- lookupSourcePackageId :: PackageIndex a -> PackageId -> [a] lookupSourcePackageId index pkgid = - case Map.lookup (packageName pkgid) (packageIdIndex index) of + -- Do not lookup internal libraries + case Map.lookup (packageName pkgid, Nothing) (packageIdIndex index) of Nothing -> [] Just pvers -> case Map.lookup (packageVersion pkgid) pvers of Nothing -> [] @@ -437,7 +453,8 @@ lookupPackageName :: PackageIndex a -> PackageName -> [(Version, [a])] lookupPackageName index name = - case Map.lookup name (packageIdIndex index) of + -- Do not match internal libraries + case Map.lookup (name, Nothing) (packageIdIndex index) of Nothing -> [] Just pvers -> Map.toList pvers @@ -447,12 +464,29 @@ -- We get back any number of versions of the specified package name, all -- satisfying the version range constraint. -- +-- This does NOT work for internal dependencies, DO NOT use this +-- function on those; use 'lookupInternalDependency' instead. +-- -- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. -- lookupDependency :: InstalledPackageIndex -> Dependency -> [(Version, [IPI.InstalledPackageInfo])] -lookupDependency index (Dependency name versionRange) = - case Map.lookup name (packageIdIndex index) of +lookupDependency index dep = + -- Yes, a little bit of a misnomer here! + lookupInternalDependency index dep Nothing + +-- | Does a lookup by source package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. +-- +lookupInternalDependency :: InstalledPackageIndex -> Dependency + -> Maybe UnqualComponentName + -> [(Version, [IPI.InstalledPackageInfo])] +lookupInternalDependency index (Dependency name versionRange) libn = + case Map.lookup (name, libn) (packageIdIndex index) of Nothing -> [] Just pvers -> [ (ver, pkgs') | (ver, pkgs) <- Map.toList pvers @@ -468,6 +502,7 @@ -- later. eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg) + -- -- * Case insensitive name lookups -- @@ -486,11 +521,12 @@ -- searchByName :: PackageIndex a -> String -> SearchResult [a] searchByName index name = - case [ pkgs | pkgs@(pname,_) <- Map.toList (packageIdIndex index) + -- Don't match internal packages + case [ pkgs | pkgs@((pname, Nothing),_) <- Map.toList (packageIdIndex index) , lowercase (unPackageName pname) == lname ] of [] -> None [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) - pkgss -> case find ((mkPackageName name ==) . fst) pkgss of + pkgss -> case find ((mkPackageName name ==) . fst . fst) pkgss of Just (_,pvers) -> Unambiguous (concat (Map.elems pvers)) Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) where lname = lowercase name @@ -504,7 +540,8 @@ searchByNameSubstring :: PackageIndex a -> String -> [a] searchByNameSubstring index searchterm = [ pkg - | (pname, pvers) <- Map.toList (packageIdIndex index) + -- Don't match internal packages + | ((pname, Nothing), pvers) <- Map.toList (packageIdIndex index) , lsearchterm `isInfixOf` lowercase (unPackageName pname) , pkgs <- Map.elems pvers , pkg <- pkgs ] @@ -554,10 +591,10 @@ -- * Note that if the result is @Right []@ it is because at least one of -- the original given 'PackageId's do not occur in the index. -- -dependencyClosure :: PackageInstalled a => PackageIndex a +dependencyClosure :: InstalledPackageIndex -> [UnitId] - -> Either (PackageIndex a) - [(a, [UnitId])] + -> Either (InstalledPackageIndex) + [(IPI.InstalledPackageInfo, [UnitId])] dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of (completed, []) -> Left completed (completed, _) -> Right (brokenPackages completed) @@ -628,6 +665,10 @@ topBound = length pkgs - 1 bounds = (0, topBound) +-- | We maintain the invariant that, for any 'DepUniqueKey', there +-- is only one instance of the package in our database. +type DepUniqueKey = (PackageName, Maybe UnqualComponentName, Map ModuleName OpenModule) + -- | 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 -- if the dependencies within it use consistent versions of each package. @@ -638,40 +679,28 @@ -- depend on it and the versions they require. These are guaranteed to be -- distinct. -- -dependencyInconsistencies :: PackageInstalled a => PackageIndex a - -> [(PackageName, [(PackageId, Version)])] -dependencyInconsistencies index = - [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids]) - | (name, ipid_map) <- Map.toList inverseIndex - , let uses = Map.elems ipid_map - , reallyIsInconsistent (map fst uses) ] - - where -- for each PackageName, - -- for each package with that name, - -- the InstalledPackageInfo and the package Ids of packages - -- that depend on it. - inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) - [ (packageName dep, - Map.fromList [(ipid,(dep,[packageId pkg]))]) - | pkg <- allPackages index - , ipid <- installedDepends pkg - , Just dep <- [lookupUnitId index ipid] - ] - - -- Added in 991e52a474e2b8280432257c1771dc474a320a30, - -- this is a special case to handle the base 3 compatibility - -- package which shipped with GHC 6.10 and GHC 6.12 - -- (it was removed in GHC 7.0). Remove this when GHC 6.12 - -- goes out of our support window. - reallyIsInconsistent :: PackageInstalled a => [a] -> Bool - reallyIsInconsistent [] = False - reallyIsInconsistent [_p] = False - reallyIsInconsistent [p1, p2] = - let pid1 = installedUnitId p1 - pid2 = installedUnitId p2 - in pid1 `notElem` installedDepends p2 - && pid2 `notElem` installedDepends p1 - reallyIsInconsistent _ = True +dependencyInconsistencies :: InstalledPackageIndex + -- At DepUniqueKey... + -> [(DepUniqueKey, + -- There were multiple packages (BAD!) + [(UnitId, + -- And here are the packages which + -- immediately depended on it + [IPI.InstalledPackageInfo])])] +dependencyInconsistencies index = do + (dep_key, insts_map) <- Map.toList inverseIndex + let insts = Map.toList insts_map + guard (length insts >= 2) + return (dep_key, insts) + where + inverseIndex :: Map DepUniqueKey (Map UnitId [IPI.InstalledPackageInfo]) + inverseIndex = Map.fromListWith (Map.unionWith (++)) $ do + pkg <- allPackages index + dep_ipid <- installedDepends pkg + Just dep <- [lookupUnitId index dep_ipid] + let dep_key = (packageName dep, IPI.sourceLibName dep, + Map.fromList (IPI.instantiatedWith dep)) + return (dep_key, Map.singleton dep_ipid [pkg]) -- | A rough approximation of GHC's module finder, takes a -- 'InstalledPackageIndex' and turns it into a map from module names to their 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 @@ -34,8 +34,10 @@ import Distribution.Compat.Stack import Distribution.Simple.PreProcess.Unlit +import Distribution.Backpack.DescribeUnitId import Distribution.Package import qualified Distribution.ModuleName as ModuleName +import Distribution.ModuleName (ModuleName) import Distribution.PackageDescription as PD import qualified Distribution.InstalledPackageInfo as Installed import qualified Distribution.Simple.PackageIndex as PackageIndex @@ -51,6 +53,7 @@ import Distribution.Version import Distribution.Verbosity import Distribution.Types.ForeignLib +import Distribution.Types.UnqualComponentName import System.Directory (doesFileExist) import System.Info (os, arch) @@ -148,36 +151,35 @@ -> Verbosity -> [PPSuffixHandler] -> IO () -preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = case comp of +preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = do + -- NB: never report instantiation here; we'll report it properly when + -- building. + setupMessage' verbosity "Preprocessing" (packageId pd) + (componentLocalName clbi) (Nothing :: Maybe [(ModuleName, Module)]) + case comp of (CLib lib@Library{ libBuildInfo = bi }) -> do let dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi] - extra | componentIsPublic clbi = "" - | otherwise = " '" ++ display (componentUnitId clbi) ++ "' for" - setupMessage verbosity ("Preprocessing library" ++ extra) (packageId pd) for_ (map ModuleName.toFilePath $ allLibModules lib clbi) $ pre dirs (componentBuildDir lbi clbi) (localHandlers bi) (CFLib flib@ForeignLib { foreignLibBuildInfo = bi, foreignLibName = nm }) -> do let nm' = unUnqualComponentName nm - flibDir = buildDir lbi nm' nm' ++ "-tmp" + let flibDir = buildDir lbi nm' nm' ++ "-tmp" dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi] - setupMessage verbosity ("Preprocessing foreign library '" ++ nm' ++ "' for") (packageId pd) for_ (map ModuleName.toFilePath $ foreignLibModules flib) $ pre dirs flibDir (localHandlers bi) (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do let nm' = unUnqualComponentName nm - exeDir = buildDir lbi nm' nm' ++ "-tmp" + let exeDir = buildDir lbi nm' nm' ++ "-tmp" dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi] - setupMessage verbosity ("Preprocessing executable '" ++ nm' ++ "' for") (packageId pd) for_ (map ModuleName.toFilePath $ otherModules bi) $ pre dirs exeDir (localHandlers bi) pre (hsSourceDirs bi) exeDir (localHandlers bi) $ dropExtensions (modulePath exe) CTest test@TestSuite{ testName = nm } -> do let nm' = unUnqualComponentName nm - setupMessage verbosity ("Preprocessing test suite '" ++ nm' ++ "' for") (packageId pd) case testInterface test of TestSuiteExeV10 _ f -> preProcessTest test f $ buildDir lbi nm' nm' ++ "-tmp" @@ -186,16 +188,17 @@ stubName test ++ "-tmp" writeSimpleTestStub test testDir preProcessTest test (stubFilePath test) testDir - TestSuiteUnsupported tt -> die $ "No support for preprocessing test " - ++ "suite type " ++ display tt + TestSuiteUnsupported tt -> + die' verbosity $ "No support for preprocessing test " + ++ "suite type " ++ display tt CBench bm@Benchmark{ benchmarkName = nm } -> do let nm' = unUnqualComponentName nm - setupMessage verbosity ("Preprocessing benchmark '" ++ nm' ++ "' for") (packageId pd) case benchmarkInterface bm of BenchmarkExeV10 _ f -> preProcessBench bm f $ buildDir lbi nm' nm' ++ "-tmp" - BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark " - ++ "type " ++ display tt + BenchmarkUnsupported tt -> + die' verbosity $ "No support for preprocessing benchmark " + ++ "type " ++ display tt where builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"] builtinCSuffixes = cSourceExtensions @@ -249,8 +252,9 @@ Nothing -> do bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : searchLoc) baseFile case bsrcFiles of - Nothing -> die $ "can't find source for " ++ baseFile - ++ " in " ++ intercalate ", " searchLoc + Nothing -> + die' verbosity $ "can't find source for " ++ baseFile + ++ " in " ++ intercalate ", " searchLoc _ -> return () -- found a pre-processable file in one of the source dirs Just (psrcLoc, psrcRelFile) -> do @@ -328,9 +332,9 @@ ppUnlit = PreProcessor { platformIndependent = True, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> withUTF8FileContents inFile $ \contents -> - either (writeUTF8File outFile) die (unlit inFile contents) + either (writeUTF8File outFile) (die' verbosity) (unlit inFile contents) } ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor @@ -652,10 +656,11 @@ -- | Find any extra C sources generated by preprocessing that need to -- be added to the component (addresses issue #238). -preprocessExtras :: Component +preprocessExtras :: Verbosity + -> Component -> LocalBuildInfo -> IO [FilePath] -preprocessExtras comp lbi = case comp of +preprocessExtras verbosity comp lbi = case comp of CLib _ -> pp $ buildDir lbi (CExe Executable { exeName = nm }) -> do let nm' = unUnqualComponentName nm @@ -670,15 +675,16 @@ pp $ buildDir lbi nm' nm' ++ "-tmp" TestSuiteLibV09 _ _ -> pp $ buildDir lbi stubName test stubName test ++ "-tmp" - TestSuiteUnsupported tt -> die $ "No support for preprocessing test " + TestSuiteUnsupported tt -> die' verbosity $ "No support for preprocessing test " ++ "suite type " ++ display tt CBench bm -> do let nm' = unUnqualComponentName $ benchmarkName bm case benchmarkInterface bm of BenchmarkExeV10 _ _ -> pp $ buildDir lbi nm' nm' ++ "-tmp" - BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark " - ++ "type " ++ display tt + BenchmarkUnsupported tt -> + die' verbosity $ "No support for preprocessing benchmark " + ++ "type " ++ display tt where pp :: FilePath -> IO [FilePath] pp dir = (map (dir ) . filter not_sub . concat) 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 @@ -112,6 +112,7 @@ , c2hsProgram , cpphsProgram , hscolourProgram + , doctestProgram , haddockProgram , greencardProgram , ldProgram @@ -173,7 +174,7 @@ -> IO () runDbProgram verbosity prog programDb args = case lookupProgram prog programDb of - Nothing -> die notFound + Nothing -> die' verbosity notFound Just configuredProg -> runProgram verbosity configuredProg args where notFound = "The program '" ++ programName prog @@ -188,7 +189,7 @@ -> IO String getDbProgramOutput verbosity prog programDb args = case lookupProgram prog programDb of - Nothing -> die notFound + Nothing -> die' verbosity notFound Just configuredProg -> getProgramOutput verbosity configuredProg args where notFound = "The program '" ++ programName prog diff --git a/cabal/Cabal/Distribution/Simple/Program/Ar.hs b/cabal/Cabal/Distribution/Simple/Program/Ar.hs --- a/cabal/Cabal/Distribution/Simple/Program/Ar.hs +++ b/cabal/Cabal/Distribution/Simple/Program/Ar.hs @@ -25,14 +25,19 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Distribution.Compat.CopyFile (filesEqual) +import Distribution.Simple.Compiler (arResponseFilesSupported) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) import Distribution.Simple.Program - ( arProgram, requireProgram ) + ( ProgramInvocation, arProgram, requireProgram ) +import Distribution.Simple.Program.ResponseFile + ( withResponseFile ) import Distribution.Simple.Program.Run ( programInvocation, multiStageProgramInvocation , runProgramInvocation ) +import Distribution.Simple.Setup + ( fromFlagOrDefault, configUseResponseFiles ) import Distribution.Simple.Utils - ( dieWithLocation, withTempDirectory ) + ( defaultTempFileOptions, dieWithLocation', withTempDirectory ) import Distribution.System ( Arch(..), OS(..), Platform(..) ) import Distribution.Verbosity @@ -84,23 +89,39 @@ middle = initial final = programInvocation ar (finalArgs ++ extraArgs) - sequence_ + oldVersionManualOverride = + fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi + responseArgumentsNotSupported = + not (arResponseFilesSupported (compiler lbi)) + + invokeWithResponesFile :: FilePath -> ProgramInvocation + invokeWithResponesFile atFile = + programInvocation ar $ + simpleArgs ++ extraArgs ++ ['@' : atFile] + + if oldVersionManualOverride || responseArgumentsNotSupported + then + sequence_ [ runProgramInvocation verbosity inv | inv <- multiStageProgramInvocation simple (initial, middle, final) files ] + else + withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $ + \path -> runProgramInvocation verbosity $ invokeWithResponesFile path unless (hostArch == Arm -- See #1537 || hostOS == AIX) $ -- AIX uses its own "ar" format variant - wipeMetadata tmpPath + wipeMetadata verbosity tmpPath equal <- filesEqual tmpPath targetPath unless equal $ renameFile tmpPath targetPath where progDb = withPrograms lbi Platform hostArch hostOS = hostPlatform lbi - verbosityOpts v | v >= deafening = ["-v"] - | v >= verbose = [] - | otherwise = ["-c"] + verbosityOpts v + | v >= deafening = ["-v"] + | v >= verbose = [] + | otherwise = ["-c"] -- Do not warn if library had to be created. -- | @ar@ by default includes various metadata for each object file in their -- respective headers, so the output can differ for the same inputs, making @@ -108,15 +129,15 @@ -- (@-D@) flag that always writes zero for the mtime, UID and GID, and 0644 -- for the file mode. However detecting whether @-D@ is supported seems -- rather harder than just re-implementing this feature. -wipeMetadata :: FilePath -> IO () -wipeMetadata path = do +wipeMetadata :: Verbosity -> FilePath -> IO () +wipeMetadata verbosity path = do -- Check for existence first (ReadWriteMode would create one otherwise) exists <- doesFileExist path unless exists $ wipeError "Temporary file disappeared" withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h where - wipeError msg = dieWithLocation path Nothing $ + wipeError msg = dieWithLocation' verbosity path Nothing $ "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg archLF = "!\x0a" -- global magic, 8 bytes x60LF = "\x60\x0a" -- header magic, 2 bytes diff --git a/cabal/Cabal/Distribution/Simple/Program/Builtin.hs b/cabal/Cabal/Distribution/Simple/Program/Builtin.hs --- a/cabal/Cabal/Distribution/Simple/Program/Builtin.hs +++ b/cabal/Cabal/Distribution/Simple/Program/Builtin.hs @@ -18,6 +18,7 @@ -- * Programs that Cabal knows about ghcProgram, ghcPkgProgram, + runghcProgram, ghcjsProgram, ghcjsPkgProgram, lhcProgram, @@ -36,6 +37,7 @@ c2hsProgram, cpphsProgram, hscolourProgram, + doctestProgram, haddockProgram, greencardProgram, ldProgram, @@ -70,6 +72,7 @@ [ -- compilers and related progs ghcProgram + , runghcProgram , ghcPkgProgram , ghcjsProgram , ghcjsPkgProgram @@ -83,6 +86,7 @@ , hpcProgram -- preprocessors , hscolourProgram + , doctestProgram , haddockProgram , happyProgram , alexProgram @@ -121,6 +125,15 @@ (programVersion ghcProg) } +runghcProgram :: Program +runghcProgram = (simpleProgram "runghc") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "runghc 7.10.3" + (_:ver:_) -> ver + _ -> "" + } + ghcPkgProgram :: Program ghcPkgProgram = (simpleProgram "ghc-pkg") { programFindVersion = findProgramVersion "--version" $ \str -> @@ -296,6 +309,18 @@ case words str of (_:ver:_) -> ver _ -> "" + } + +-- TODO: Ensure that doctest is built against the same GHC as the one +-- that's being used. Same for haddock. @phadej pointed this out. +doctestProgram :: Program +doctestProgram = (simpleProgram "doctest") { + programFindLocation = \v p -> findProgramOnSearchPath v p "doctest" + , programFindVersion = findProgramVersion "--version" $ \str -> + -- "doctest version 0.11.2" + case words str of + (_:_:ver:_) -> ver + _ -> "" } haddockProgram :: Program 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 @@ -52,6 +52,7 @@ -- ** Query and manipulate the program db configureProgram, configureAllKnownPrograms, + unconfigureProgram, lookupProgramVersion, reconfigurePrograms, requireProgram, @@ -330,7 +331,7 @@ if absolute then return (Just (UserSpecified path, [])) else findProgramOnSearchPath verbosity (progSearchPath progdb) path - >>= maybe (die notFound) + >>= maybe (die' verbosity notFound) (return . Just . swap . fmap UserSpecified . swap) where notFound = "Cannot find the program '" ++ name ++ "'. User-specified path '" @@ -365,6 +366,13 @@ foldM (flip (configureProgram verbosity)) progdb progs +-- | Unconfigure a program. This is basically a hack and you shouldn't +-- use it, but it can be handy for making sure a 'requireProgram' +-- actually reconfigures. +unconfigureProgram :: String -> ProgramDb -> ProgramDb +unconfigureProgram progname = + updateConfiguredProgs $ Map.delete progname + -- | Try to configure all the known programs that have not yet been configured. -- configureAllKnownPrograms :: Verbosity @@ -412,7 +420,7 @@ Just _ -> return progdb case lookupProgram prog progdb' of - Nothing -> die notFound + Nothing -> die' verbosity notFound Just configuredProg -> return (configuredProg, progdb') where notFound = "The program '" ++ programName prog @@ -473,5 +481,5 @@ -> ProgramDb -> IO (ConfiguredProgram, Version, ProgramDb) requireProgramVersion verbosity prog range programDb = - join $ either die return `fmap` + join $ either (die' verbosity) return `fmap` lookupProgramVersion verbosity prog range programDb 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 @@ -15,12 +15,13 @@ runGHC, + packageDbArgsDb, + ) where import Prelude () import Distribution.Compat.Prelude -import Distribution.Package import Distribution.Backpack import Distribution.Simple.GHC.ImplInfo import Distribution.PackageDescription hiding (Flag) @@ -31,6 +32,7 @@ import Distribution.Simple.Program.Run import Distribution.System import Distribution.Text +import Distribution.Types.ComponentId import Distribution.Verbosity import Distribution.Utils.NubList import Language.Haskell.Extension @@ -111,6 +113,9 @@ -- | Start with a clean package set; the @ghc -hide-all-packages@ flag ghcOptHideAllPackages :: Flag Bool, + -- | Warn about modules, not listed in command line + ghcOptWarnMissingHomeModules :: Flag Bool, + -- | Don't automatically link in Haskell98 etc; the @ghc -- -no-auto-link-packages@ flag. ghcOptNoAutoLinkPackages :: Flag Bool, @@ -150,6 +155,9 @@ -- | Options to pass through to the C compiler; the @ghc -optc@ flag. ghcOptCcOptions :: NubListR String, + -- | Options to pass through to the C++ compiler. + ghcOptCxxOptions :: NubListR String, + -- | Options to pass through to CPP; the @ghc -optP@ flag. ghcOptCppOptions :: NubListR String, @@ -182,7 +190,7 @@ ghcOptOptimisation :: Flag GhcOptimisation, -- | Emit debug info; the @ghc -g@ flag. - ghcOptDebugInfo :: Flag Bool, + ghcOptDebugInfo :: Flag DebugInfoLevel, -- | Compile in profiling mode; the @ghc -prof@ flag. ghcOptProfilingMode :: Flag Bool, @@ -190,6 +198,9 @@ -- | Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags. ghcOptProfilingAuto :: Flag GhcProfAuto, + -- | Use the \"split sections\" feature; the @ghc -split-sections@ flag. + ghcOptSplitSections :: Flag Bool, + -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag. ghcOptSplitObjs :: Flag Bool, @@ -320,7 +331,12 @@ Just GhcMaximumOptimisation -> ["-O2"] Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph - , [ "-g" | flagDebugInfo implInfo && flagBool ghcOptDebugInfo ] + , case flagToMaybe (ghcOptDebugInfo opts) of + Nothing -> [] + Just NoDebugInfo -> [] + Just MinimalDebugInfo -> ["-g1"] + Just NormalDebugInfo -> ["-g2"] + Just MaximalDebugInfo -> ["-g3"] , [ "-prof" | flagBool ghcOptProfilingMode ] @@ -338,6 +354,7 @@ | flagProfAuto implInfo -> ["-fprof-auto-exported"] | otherwise -> ["-auto"] + , [ "-split-sections" | flagBool ghcOptSplitObjs ] , [ "-split-objs" | flagBool ghcOptSplitObjs ] , case flagToMaybe (ghcOptHPCDir opts) of @@ -383,13 +400,16 @@ , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ] -------------------- - -- C and CPP stuff + -------------------- + -- CPP, C, and C++ stuff + , [ "-I" ++ dir | dir <- flags ghcOptCppIncludePath ] , [ "-optP" ++ opt | opt <- flags ghcOptCppOptions ] , concat [ [ "-optP-include", "-optP" ++ inc] | inc <- flags ghcOptCppIncludes ] , [ "-optc" ++ opt | opt <- flags ghcOptCcOptions ] + , [ "-optc" ++ opt | opt <- flags ghcOptCxxOptions ] ----------------- -- Linker stuff @@ -435,6 +455,7 @@ , concat [ ["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode ] , [ "-hide-all-packages" | flagBool ghcOptHideAllPackages ] + , [ "-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules ] , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ] , packageDbArgs implInfo (ghcOptPackageDBs opts) 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 @@ -13,14 +13,15 @@ -- Currently only GHC, GHCJS and LHC have hc-pkg programs. module Distribution.Simple.Program.HcPkg ( + -- * Types HcPkgInfo(..), - MultiInstance(..), + RegisterOptions(..), + defaultRegisterOptions, + -- * Actions init, invoke, register, - reregister, - registerMultiInstance, unregister, recache, expose, @@ -32,8 +33,6 @@ -- * Program invocations initInvocation, registerInvocation, - reregisterInvocation, - registerMultiInstanceInvocation, unregisterInvocation, recacheInvocation, exposeInvocation, @@ -46,14 +45,16 @@ import Prelude () import Distribution.Compat.Prelude hiding (init) -import Distribution.Package hiding (installedUnitId) import Distribution.InstalledPackageInfo import Distribution.ParseUtils import Distribution.Simple.Compiler import Distribution.Simple.Program.Types import Distribution.Simple.Program.Run -import Distribution.Text import Distribution.Simple.Utils +import Distribution.Text +import Distribution.Types.ComponentId +import Distribution.Types.PackageId +import Distribution.Types.UnitId import Distribution.Verbosity import Distribution.Compat.Exception @@ -76,11 +77,9 @@ , requiresDirDbs :: Bool -- ^ requires directory style package databases , nativeMultiInstance :: Bool -- ^ supports --enable-multi-instance flag , recacheMultiInstance :: Bool -- ^ supports multi-instance via recache + , suppressFilesCheck :: Bool -- ^ supports --force-files or equivalent } --- | Whether or not use multi-instance functionality. -data MultiInstance = MultiInstance | NoMultiInstance - deriving (Show, Read, Eq, Ord) -- | Call @hc-pkg@ to initialise a package database at the location {path}. -- @@ -104,39 +103,50 @@ args = packageDbStackOpts hpi dbStack ++ extraArgs invocation = programInvocation (hcPkgProgram hpi) args +-- | Additional variations in the behaviour for 'register'. +data RegisterOptions = RegisterOptions { + -- | Allows re-registering \/ overwriting an existing package + registerAllowOverwrite :: Bool, + + -- | Insist on the ability to register multiple instances of a + -- single version of a single package. This will fail if the @hc-pkg@ + -- does not support it, see 'nativeMultiInstance' and + -- 'recacheMultiInstance'. + registerMultiInstance :: Bool, + + -- | Require that no checks are performed on the existence of package + -- files mentioned in the registration info. This must be used if + -- registering prior to putting the files in their final place. This will + -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'. + registerSuppressFilesCheck :: Bool + } + +-- | Defaults are @True@, @False@ and @False@ +defaultRegisterOptions :: RegisterOptions +defaultRegisterOptions = RegisterOptions { + registerAllowOverwrite = True, + registerMultiInstance = False, + registerSuppressFilesCheck = False + } + -- | Call @hc-pkg@ to register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-db] -- register :: HcPkgInfo -> Verbosity -> PackageDBStack - -> Either FilePath - InstalledPackageInfo + -> InstalledPackageInfo + -> RegisterOptions -> IO () -register hpi verbosity packagedb pkgFile = - runProgramInvocation verbosity - (registerInvocation hpi verbosity packagedb pkgFile) - - --- | Call @hc-pkg@ to re-register a package. --- --- > hc-pkg register {filename | -} [--user | --global | --package-db] --- -reregister :: HcPkgInfo -> Verbosity -> PackageDBStack - -> Either FilePath - InstalledPackageInfo - -> IO () -reregister hpi verbosity packagedb pkgFile = - runProgramInvocation verbosity - (reregisterInvocation hpi verbosity packagedb pkgFile) +register hpi verbosity packagedbs pkgInfo registerOptions + | registerMultiInstance registerOptions + , not (nativeMultiInstance hpi || recacheMultiInstance hpi) + = die' verbosity $ "HcPkg.register: the compiler does not support " + ++ "registering multiple instances of packages." -registerMultiInstance :: HcPkgInfo -> Verbosity - -> PackageDBStack - -> InstalledPackageInfo - -> IO () -registerMultiInstance hpi verbosity packagedbs pkgInfo - | nativeMultiInstance hpi - = runProgramInvocation verbosity - (registerMultiInstanceInvocation hpi verbosity packagedbs (Right pkgInfo)) + | registerSuppressFilesCheck registerOptions + , not (suppressFilesCheck hpi) + = die' verbosity $ "HcPkg.register: the compiler does not support " + ++ "suppressing checks on files." -- This is a trick. Older versions of GHC do not support the -- --enable-multi-instance flag for ghc-pkg register but it turns out that @@ -147,31 +157,33 @@ -- to write the package registration file directly into the package db and -- then call hc-pkg recache. -- - | recacheMultiInstance hpi + | registerMultiInstance registerOptions + , recacheMultiInstance hpi = do let pkgdb = last packagedbs - writeRegistrationFileDirectly hpi pkgdb pkgInfo + writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo recache hpi verbosity pkgdb | otherwise - = die $ "HcPkg.registerMultiInstance: the compiler does not support " - ++ "registering multiple instances of packages." + = runProgramInvocation verbosity + (registerInvocation hpi verbosity packagedbs pkgInfo registerOptions) -writeRegistrationFileDirectly :: HcPkgInfo +writeRegistrationFileDirectly :: Verbosity + -> HcPkgInfo -> PackageDB -> InstalledPackageInfo -> IO () -writeRegistrationFileDirectly hpi (SpecificPackageDB dir) pkgInfo +writeRegistrationFileDirectly verbosity hpi (SpecificPackageDB dir) pkgInfo | supportsDirDbs hpi = do let pkgfile = dir display (installedUnitId pkgInfo) <.> "conf" writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) | otherwise - = die $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" + = die' verbosity $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" -writeRegistrationFileDirectly _ _ _ = +writeRegistrationFileDirectly verbosity _ _ _ = -- We don't know here what the dir for the global or user dbs are, -- if that's needed it'll require a bit more plumbing to support. - die $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" + die' verbosity $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" -- | Call @hc-pkg@ to unregister a package @@ -216,7 +228,7 @@ case parsePackages output of Left ok -> return ok - _ -> die $ "failed to parse output of '" + _ -> die' verbosity $ "failed to parse output of '" ++ programId (hcPkgProgram hpi) ++ " describe " ++ display pid ++ "'" -- | Call @hc-pkg@ to hide a package. @@ -237,12 +249,12 @@ output <- getProgramInvocationOutput verbosity (dumpInvocation hpi verbosity packagedb) - `catchIO` \e -> die $ programId (hcPkgProgram hpi) ++ " dump failed: " + `catchIO` \e -> die' verbosity $ programId (hcPkgProgram hpi) ++ " dump failed: " ++ displayException e case parsePackages output of Left ok -> return ok - _ -> die $ "failed to parse output of '" + _ -> die' verbosity $ "failed to parse output of '" ++ programId (hcPkgProgram hpi) ++ " dump'" parsePackages :: String -> Either [InstalledPackageInfo] [PError] @@ -313,14 +325,15 @@ -- Older installed package info files did not have the installedUnitId -- field, so if it is missing then we fill it as the source package ID. +-- NB: Internal libraries not supported. setUnitId :: InstalledPackageInfo -> InstalledPackageInfo setUnitId pkginfo@InstalledPackageInfo { installedUnitId = uid, - sourcePackageId = pkgid + sourcePackageId = pid } | unUnitId uid == "" = pkginfo { - installedUnitId = mkLegacyUnitId pkgid, - installedComponentId_ = mkComponentId (display pkgid) + installedUnitId = mkLegacyUnitId pid, + installedComponentId_ = mkComponentId (display pid) } setUnitId pkginfo = pkginfo @@ -338,11 +351,11 @@ output <- getProgramInvocationOutput verbosity (listInvocation hpi verbosity packagedb) - `catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed" + `catchIO` \_ -> die' verbosity $ programId (hcPkgProgram hpi) ++ " list failed" case parsePackageIds output of Just ok -> return ok - _ -> die $ "failed to parse output of '" + _ -> die' verbosity $ "failed to parse output of '" ++ programId (hcPkgProgram hpi) ++ " list'" where @@ -359,35 +372,30 @@ args = ["init", path] ++ verbosityOpts hpi verbosity -registerInvocation, reregisterInvocation, registerMultiInstanceInvocation +registerInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack - -> Either FilePath InstalledPackageInfo + -> InstalledPackageInfo + -> RegisterOptions -> ProgramInvocation -registerInvocation = registerInvocation' "register" NoMultiInstance -reregisterInvocation = registerInvocation' "update" NoMultiInstance -registerMultiInstanceInvocation = registerInvocation' "update" MultiInstance - -registerInvocation' :: String -> MultiInstance - -> HcPkgInfo -> Verbosity -> PackageDBStack - -> Either FilePath InstalledPackageInfo - -> ProgramInvocation -registerInvocation' cmdname multiInstance hpi - verbosity packagedbs pkgFileOrInfo = - case pkgFileOrInfo of - Left pkgFile -> - programInvocation (hcPkgProgram hpi) (args pkgFile) - - Right pkgInfo -> - (programInvocation (hcPkgProgram hpi) (args "-")) { - progInvokeInput = Just (showInstalledPackageInfo pkgInfo), - progInvokeInputEncoding = IOEncodingUTF8 - } +registerInvocation hpi verbosity packagedbs pkgInfo registerOptions = + (programInvocation (hcPkgProgram hpi) (args "-")) { + progInvokeInput = Just (showInstalledPackageInfo pkgInfo), + progInvokeInputEncoding = IOEncodingUTF8 + } where + cmdname + | registerAllowOverwrite registerOptions = "update" + | registerMultiInstance registerOptions = "update" + | otherwise = "register" + args file = [cmdname, file] ++ (if noPkgDbStack hpi then [packageDbOpts hpi (last packagedbs)] else packageDbStackOpts hpi packagedbs) - ++ [ "--enable-multi-instance" | multiInstance == MultiInstance ] + ++ [ "--enable-multi-instance" + | registerMultiInstance registerOptions ] + ++ [ "--force-files" + | registerSuppressFilesCheck registerOptions ] ++ verbosityOpts hpi verbosity unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId diff --git a/cabal/Cabal/Distribution/Simple/Program/Hpc.hs b/cabal/Cabal/Distribution/Simple/Program/Hpc.hs --- a/cabal/Cabal/Distribution/Simple/Program/Hpc.hs +++ b/cabal/Cabal/Distribution/Simple/Program/Hpc.hs @@ -19,6 +19,9 @@ import Prelude () import Distribution.Compat.Prelude +import Control.Monad (mapM) +import System.Directory (makeRelativeToCurrentDirectory) + import Distribution.ModuleName import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types @@ -57,8 +60,11 @@ ++ show droppedDirs return passedDirs + -- Prior to GHC 8.0, hpc assumes all .mix paths are relative. + hpcDirs'' <- mapM makeRelativeToCurrentDirectory hpcDirs' + runProgramInvocation verbosity - (markupInvocation hpc tixFile hpcDirs' destDir excluded) + (markupInvocation hpc tixFile hpcDirs'' destDir excluded) where version07 = mkVersion [0, 7] (passedDirs, droppedDirs) = splitAt 1 hpcDirs diff --git a/cabal/Cabal/Distribution/Simple/Program/Ld.hs b/cabal/Cabal/Distribution/Simple/Program/Ld.hs --- a/cabal/Cabal/Distribution/Simple/Program/Ld.hs +++ b/cabal/Cabal/Distribution/Simple/Program/Ld.hs @@ -18,24 +18,32 @@ import Prelude () import Distribution.Compat.Prelude -import Distribution.Simple.Program.Types - ( ConfiguredProgram(..) ) +import Distribution.Simple.Compiler (arResponseFilesSupported) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Program.ResponseFile + ( withResponseFile ) import Distribution.Simple.Program.Run - ( programInvocation, multiStageProgramInvocation + ( ProgramInvocation, programInvocation, multiStageProgramInvocation , runProgramInvocation ) +import Distribution.Simple.Program.Types + ( ConfiguredProgram(..) ) +import Distribution.Simple.Setup + ( fromFlagOrDefault, configUseResponseFiles ) +import Distribution.Simple.Utils + ( defaultTempFileOptions ) import Distribution.Verbosity ( Verbosity ) import System.Directory ( renameFile ) import System.FilePath - ( (<.>) ) + ( (<.>), takeDirectory ) -- | Call @ld -r@ to link a bunch of object files together. -- -combineObjectFiles :: Verbosity -> ConfiguredProgram +combineObjectFiles :: Verbosity -> LocalBuildInfo -> ConfiguredProgram -> FilePath -> [FilePath] -> IO () -combineObjectFiles verbosity ld target files = +combineObjectFiles verbosity lbi ld target files = do -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is, -- if we have more object files than fit on a single command line then we @@ -53,16 +61,33 @@ middle = programInvocation ld middleArgs final = programInvocation ld finalArgs - invocations = multiStageProgramInvocation - simple (initial, middle, final) files + targetDir = takeDirectory target - in run invocations + invokeWithResponesFile :: FilePath -> ProgramInvocation + invokeWithResponesFile atFile = + programInvocation ld $ simpleArgs ++ ['@' : atFile] + oldVersionManualOverride = + fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi + -- Whether ghc's ar supports response files is a good proxy for + -- whether ghc's ld supports them as well. + responseArgumentsNotSupported = + not (arResponseFilesSupported (compiler lbi)) + + if oldVersionManualOverride || responseArgumentsNotSupported + then + run $ multiStageProgramInvocation simple (initial, middle, final) files + else + withResponseFile verbosity defaultTempFileOptions targetDir "ld.rsp" Nothing files $ + \path -> runProgramInvocation verbosity $ invokeWithResponesFile path + where tmpfile = target <.> "tmp" -- perhaps should use a proper temp file + run :: [ProgramInvocation] -> IO () run [] = return () run [inv] = runProgramInvocation verbosity inv run (inv:invs) = do runProgramInvocation verbosity inv renameFile target tmpfile run invs + diff --git a/cabal/Cabal/Distribution/Simple/Program/ResponseFile.hs b/cabal/Cabal/Distribution/Simple/Program/ResponseFile.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Simple/Program/ResponseFile.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +---------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.ResponseFile +-- Copyright : (c) Sergey Vinokurov 2017 +-- License : BSD3-style +-- +-- Maintainer : cabal-devel@haskell.org +-- Created : 23 July 2017 +---------------------------------------------------------------------------- + +module Distribution.Simple.Program.ResponseFile (withResponseFile) where + +import Prelude () +import System.IO (TextEncoding, hSetEncoding, hPutStr, hClose) + +import Distribution.Compat.Prelude +import Distribution.Simple.Utils (TempFileOptions, withTempFileEx, debug) +import Distribution.Verbosity + +withResponseFile + :: Verbosity + -> TempFileOptions + -> FilePath -- ^ Working directory to create response file in. + -> FilePath -- ^ Template for response file name. + -> Maybe TextEncoding -- ^ Encoding to use for response file contents. + -> [String] -- ^ Arguments to put into response file. + -> (FilePath -> IO a) + -> IO a +withResponseFile verbosity tmpFileOpts workDir fileNameTemplate encoding arguments f = + withTempFileEx tmpFileOpts workDir fileNameTemplate $ \responseFileName hf -> do + traverse_ (hSetEncoding hf) encoding + let responseContents = unlines $ map escapeResponseFileArg arguments + hPutStr hf responseContents + hClose hf + debug verbosity $ responseFileName ++ " contents: <<<" + debug verbosity responseContents + debug verbosity $ ">>> " ++ responseFileName + f responseFileName + +-- Support a gcc-like response file syntax. Each separate +-- argument and its possible parameter(s), will be separated in the +-- response file by an actual newline; all other whitespace, +-- single quotes, double quotes, and the character used for escaping +-- (backslash) are escaped. The called program will need to do a similar +-- inverse operation to de-escape and re-constitute the argument list. +escapeResponseFileArg :: String -> String +escapeResponseFileArg = reverse . foldl' escape [] + where + escape :: String -> Char -> String + escape cs c = + case c of + '\\' -> c:'\\':cs + '\'' -> c:'\\':cs + '"' -> c:'\\':cs + _ | isSpace c -> c:'\\':cs + | otherwise -> c:cs + + 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 @@ -22,6 +22,7 @@ runProgramInvocation, getProgramInvocationOutput, + getProgramInvocationOutputAndErrors, getEffectiveEnvironment, ) where @@ -61,6 +62,10 @@ data IOEncoding = IOEncodingText -- locale mode text | IOEncodingUTF8 -- always utf8 +encodeToIOData :: IOEncoding -> String -> IOData +encodeToIOData IOEncodingText = IODataText +encodeToIOData IOEncodingUTF8 = IODataBinary . toUTF8LBS + emptyProgramInvocation :: ProgramInvocation emptyProgramInvocation = ProgramInvocation { @@ -137,18 +142,23 @@ (_, errors, exitCode) <- rawSystemStdInOut verbosity path args mcwd menv - (Just input) True + (Just input) IODataModeBinary when (exitCode /= ExitSuccess) $ - die $ "'" ++ path ++ "' exited with an error:\n" ++ errors + die' verbosity $ "'" ++ path ++ "' exited with an error:\n" ++ errors where - input = case encoding of - IOEncodingText -> (inputStr, False) - IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for - -- utf8 - + input = encodeToIOData encoding inputStr getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String -getProgramInvocationOutput verbosity +getProgramInvocationOutput verbosity inv = do + (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv + when (exitCode /= ExitSuccess) $ + die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors + return output + + +getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation + -> IO (String, String, ExitCode) +getProgramInvocationOutputAndErrors verbosity ProgramInvocation { progInvokePath = path, progInvokeArgs = args, @@ -158,27 +168,21 @@ progInvokeInput = minputStr, progInvokeOutputEncoding = encoding } = do - let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False - decode | utf8 = fromUTF8 . normaliseLineEndings - | otherwise = id + let mode = case encoding of IOEncodingUTF8 -> IODataModeBinary + IOEncodingText -> IODataModeText + + decode (IODataBinary b) = normaliseLineEndings (fromUTF8LBS b) + decode (IODataText s) = s + pathOverride <- getExtraPathEnv envOverrides extraPath menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) (output, errors, exitCode) <- rawSystemStdInOut verbosity path args mcwd menv - input utf8 - when (exitCode /= ExitSuccess) $ - die $ "'" ++ path ++ "' exited with an error:\n" ++ errors - return (decode output) + input mode + return (decode output, errors, exitCode) where - input = - case minputStr of - Nothing -> Nothing - Just inputStr -> Just $ - case encoding of - IOEncodingText -> (inputStr, False) - IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8 - + input = encodeToIOData encoding <$> minputStr getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> NoCallStackIO [(String, Maybe String)] getExtraPathEnv _ [] = return [] @@ -243,28 +247,28 @@ [c] -> [ simple `appendArgs` c ] - [c,c'] -> [ initial `appendArgs` c ] - ++ [ final `appendArgs` c'] - (c:cs) -> [ initial `appendArgs` c ] ++ [ middle `appendArgs` c'| c' <- init cs ] ++ [ final `appendArgs` c'| let c' = last cs ] where + appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as } + splitChunks :: Int -> [[a]] -> [[[a]]] splitChunks len = unfoldr $ \s -> if null s then Nothing else Just (chunk len s) + chunk :: Int -> [[a]] -> ([[a]], [[a]]) chunk len (s:_) | length s >= len = error toolong chunk len ss = chunk' [] len ss - chunk' acc _ [] = (reverse acc,[]) + chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]]) chunk' acc len (s:ss) | len' < len = chunk' (s:acc) (len-len'-1) ss - | otherwise = (reverse acc, s:ss) where len' = length s + chunk' acc _ ss = (reverse acc, ss) toolong = "multiStageProgramInvocation: a single program arg is larger " ++ "than the maximum command line length!" diff --git a/cabal/Cabal/Distribution/Simple/Program/Strip.hs b/cabal/Cabal/Distribution/Simple/Program/Strip.hs --- a/cabal/Cabal/Distribution/Simple/Program/Strip.hs +++ b/cabal/Cabal/Distribution/Simple/Program/Strip.hs @@ -27,7 +27,7 @@ runStrip :: Verbosity -> ProgramDb -> FilePath -> [String] -> IO () runStrip verbosity progDb path args = case lookupProgram stripProgram progDb of - Just strip -> runProgram verbosity strip (path:args) + Just strip -> runProgram verbosity strip (args ++ [path]) Nothing -> unless (buildOS == Windows) $ -- Don't bother warning on windows, we don't expect them to -- have the strip program anyway. diff --git a/cabal/Cabal/Distribution/Simple/Program/Types.hs b/cabal/Cabal/Distribution/Simple/Program/Types.hs --- a/cabal/Cabal/Distribution/Simple/Program/Types.hs +++ b/cabal/Cabal/Distribution/Simple/Program/Types.hs @@ -76,6 +76,8 @@ -- it could add args, or environment vars. programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram } +instance Show Program where + show (Program name _ _ _) = "Program: " ++ name type ProgArg = String diff --git a/cabal/Cabal/Distribution/Simple/Register.hs b/cabal/Cabal/Distribution/Simple/Register.hs --- a/cabal/Cabal/Distribution/Simple/Register.hs +++ b/cabal/Cabal/Distribution/Simple/Register.hs @@ -37,8 +37,11 @@ createPackageDB, deletePackageDB, + abiHash, invokeHcPkg, registerPackage, + HcPkg.RegisterOptions(..), + HcPkg.defaultRegisterOptions, generateRegistrationInfo, inplaceInstalledPackageInfo, absoluteInstalledPackageInfo, @@ -61,7 +64,9 @@ import qualified Distribution.Simple.LHC as LHC import qualified Distribution.Simple.UHC as UHC import qualified Distribution.Simple.HaskellSuite as HaskellSuite +import qualified Distribution.Simple.PackageIndex as Index +import Distribution.Backpack.DescribeUnitId import Distribution.Simple.Compiler import Distribution.Simple.Program import Distribution.Simple.Program.Script @@ -72,8 +77,10 @@ import qualified Distribution.InstalledPackageInfo as IPI import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.Utils +import Distribution.Utils.MapAccum import Distribution.System import Distribution.Text +import Distribution.Types.ComponentName import Distribution.Verbosity as Verbosity import Distribution.Version import Distribution.Compat.Graph (IsNode(nodeKey)) @@ -90,7 +97,7 @@ register :: PackageDescription -> LocalBuildInfo -> RegisterFlags -- ^Install in the user's database?; verbose -> IO () -register pkg_descr lbi flags = +register pkg_descr lbi0 flags = -- Duncan originally asked for us to not register/install files -- when there was no public library. But with per-component -- configure, we legitimately need to install internal libraries @@ -98,21 +105,24 @@ doRegister where doRegister = do - targets <- readTargetInfos verbosity pkg_descr lbi (regArgs flags) + targets <- readTargetInfos verbosity pkg_descr lbi0 (regArgs flags) -- It's important to register in build order, because ghc-pkg -- will complain if a dependency is not registered. - let maybeGenerateOne target - | CLib lib <- targetComponent target - = fmap Just (generateOne pkg_descr lib lbi clbi flags) - | otherwise = return Nothing - where clbi = targetCLBI target + let componentsToRegister + = neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets) - ipis <- fmap catMaybes - . traverse maybeGenerateOne - $ neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) - registerAll pkg_descr lbi flags ipis - return () + (_, ipi_mbs) <- + mapAccumM `flip` installedPkgs lbi0 `flip` componentsToRegister $ \index tgt -> + case targetComponent tgt of + CLib lib -> do + let clbi = targetCLBI tgt + lbi = lbi0 { installedPkgs = index } + ipi <- generateOne pkg_descr lib lbi clbi flags + return (Index.insert ipi index, Just ipi) + _ -> return (index, Nothing) + + registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs) where verbosity = fromFlag (regVerbosity flags) @@ -146,7 +156,8 @@ when (fromFlag (regPrintId regFlags)) $ do for_ ipis $ \installedPkgInfo -> -- Only print the public library's IPI - when (IPI.sourcePackageId installedPkgInfo == packageId pkg) $ + when (packageId installedPkgInfo == packageId pkg + && IPI.sourceLibName installedPkgInfo == Nothing) $ putStrLn (display (IPI.installedUnitId installedPkgInfo)) -- Three different modes: @@ -154,10 +165,12 @@ _ | modeGenerateRegFile -> writeRegistrationFileOrDirectory | modeGenerateRegScript -> writeRegisterScript | otherwise -> do - setupMessage verbosity "Registering" (packageId pkg) - for_ ipis $ \installedPkgInfo -> + for_ ipis $ \ipi -> do + setupMessage' verbosity "Registering" (packageId pkg) + (libraryComponentName (IPI.sourceLibName ipi)) + (Just (IPI.instantiatedWith ipi)) registerPackage verbosity (compiler lbi) (withPrograms lbi) - HcPkg.NoMultiInstance packageDbs installedPkgInfo + packageDbs ipi HcPkg.defaultRegisterOptions where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) @@ -195,7 +208,7 @@ case compilerFlavor (compiler lbi) of JHC -> notice verbosity "Registration scripts not needed for jhc" UHC -> notice verbosity "Registration scripts not needed for uhc" - _ -> withHcPkg + _ -> withHcPkg verbosity "Registration scripts are not implemented for this compiler" (compiler lbi) (withPrograms lbi) (writeHcPkgRegisterScript verbosity ipis packageDbs) @@ -215,33 +228,45 @@ --TODO: eliminate pwd! pwd <- getCurrentDirectory - --TODO: the method of setting the UnitId is compiler specific - -- this aspect should be delegated to a per-compiler helper. - let comp = compiler lbi - lbi' = lbi { - withPackageDB = withPackageDB lbi - ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)] - } - abi_hash <- + installedPkgInfo <- + if inplace + -- NB: With an inplace installation, the user may run './Setup + -- build' to update the library files, without reregistering. + -- In this case, it is critical that the ABI hash not flip. + then return (inplaceInstalledPackageInfo pwd distPref + pkg (mkAbiHash "inplace") lib lbi clbi) + else do + abi_hash <- abiHash verbosity pkg distPref lbi lib clbi + if reloc + then relocRegistrationInfo verbosity + pkg lib lbi clbi abi_hash packageDb + else return (absoluteInstalledPackageInfo + pkg abi_hash lib lbi clbi) + + + return installedPkgInfo + +-- | Compute the 'AbiHash' of a library that we built inplace. +abiHash :: Verbosity + -> PackageDescription + -> FilePath + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO AbiHash +abiHash verbosity pkg distPref lbi lib clbi = case compilerFlavor comp of GHC | compilerVersion comp >= mkVersion [6,11] -> do fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi GHCJS -> do fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi _ -> return (mkAbiHash "") - - installedPkgInfo <- - if inplace - then return (inplaceInstalledPackageInfo pwd distPref - pkg abi_hash lib lbi clbi) - else if reloc - then relocRegistrationInfo verbosity - pkg lib lbi clbi abi_hash packageDb - else return (absoluteInstalledPackageInfo - pkg abi_hash lib lbi clbi) - - - return installedPkgInfo{ IPI.abiHash = abi_hash } + where + comp = compiler lbi + lbi' = lbi { + withPackageDB = withPackageDB lbi + ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)] + } relocRegistrationInfo :: Verbosity -> PackageDescription @@ -256,7 +281,8 @@ GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb return (relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi fs) - _ -> die "Distribution.Simple.Register.relocRegistrationInfo: \ + _ -> die' verbosity + "Distribution.Simple.Register.relocRegistrationInfo: \ \not implemented for this compiler" initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO () @@ -273,7 +299,8 @@ LHC -> HcPkg.init (LHC.hcPkgInfo progdb) verbosity False dbPath UHC -> return () HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath - _ -> die $ "Distribution.Simple.Register.createPackageDB: " + _ -> die' verbosity $ + "Distribution.Simple.Register.createPackageDB: " ++ "not implemented for this compiler" doesPackageDBExist :: FilePath -> NoCallStackIO Bool @@ -298,38 +325,38 @@ invokeHcPkg :: Verbosity -> Compiler -> ProgramDb -> PackageDBStack -> [String] -> IO () invokeHcPkg verbosity comp progdb dbStack extraArgs = - withHcPkg "invokeHcPkg" comp progdb + withHcPkg verbosity "invokeHcPkg" comp progdb (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs) -withHcPkg :: String -> Compiler -> ProgramDb +withHcPkg :: Verbosity -> String -> Compiler -> ProgramDb -> (HcPkg.HcPkgInfo -> IO a) -> IO a -withHcPkg name comp progdb f = +withHcPkg verbosity name comp progdb f = case compilerFlavor comp of GHC -> f (GHC.hcPkgInfo progdb) GHCJS -> f (GHCJS.hcPkgInfo progdb) LHC -> f (LHC.hcPkgInfo progdb) - _ -> die ("Distribution.Simple.Register." ++ name ++ ":\ + _ -> die' verbosity ("Distribution.Simple.Register." ++ name ++ ":\ \not implemented for this compiler") registerPackage :: Verbosity -> Compiler -> ProgramDb - -> HcPkg.MultiInstance -> PackageDBStack -> InstalledPackageInfo + -> HcPkg.RegisterOptions -> IO () -registerPackage verbosity comp progdb multiInstance packageDbs installedPkgInfo = +registerPackage verbosity comp progdb packageDbs installedPkgInfo registerOptions = case compilerFlavor comp of - GHC -> GHC.registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo - GHCJS -> GHCJS.registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo - _ | HcPkg.MultiInstance == multiInstance - -> die "Registering multiple package instances is not yet supported for this compiler" - LHC -> LHC.registerPackage verbosity progdb packageDbs installedPkgInfo + GHC -> GHC.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions + GHCJS -> GHCJS.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions + _ | HcPkg.registerMultiInstance registerOptions + -> die' verbosity "Registering multiple package instances is not yet supported for this compiler" + LHC -> LHC.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions UHC -> UHC.registerPackage verbosity comp progdb packageDbs installedPkgInfo JHC -> notice verbosity "Registering for jhc (nothing to do)" HaskellSuite {} -> HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo - _ -> die "Registering is not implemented for this compiler" + _ -> die' verbosity "Registering is not implemented for this compiler" writeHcPkgRegisterScript :: Verbosity -> [InstalledPackageInfo] @@ -338,8 +365,9 @@ -> IO () writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do let genScript installedPkgInfo = - let invocation = HcPkg.reregisterInvocation hpi Verbosity.normal - packageDbs (Right installedPkgInfo) + let invocation = HcPkg.registerInvocation hpi Verbosity.normal + packageDbs installedPkgInfo + HcPkg.defaultRegisterOptions in invocationAsSystemScript buildOS invocation scripts = map genScript ipis -- TODO: Do something more robust here @@ -373,12 +401,11 @@ -> InstalledPackageInfo generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDirs = IPI.InstalledPackageInfo { - IPI.sourcePackageId = (packageId pkg) { - pkgName = componentCompatPackageName clbi - }, + IPI.sourcePackageId = packageId pkg, IPI.installedUnitId = componentUnitId clbi, IPI.installedComponentId_ = componentComponentId clbi, IPI.instantiatedWith = componentInstantiatedWith clbi, + IPI.sourceLibName = libName lib, IPI.compatPackageKey = componentCompatPackageKey clbi, IPI.license = license pkg, IPI.copyright = copyright pkg, @@ -393,23 +420,25 @@ IPI.abiHash = abi_hash, IPI.indefinite = componentIsIndefinite clbi, IPI.exposed = libExposed lib, - IPI.exposedModules = componentExposedModules clbi, + IPI.exposedModules = componentExposedModules clbi + -- add virtual modules into the list of exposed modules for the + -- package database as well. + ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi), IPI.hiddenModules = otherModules bi, IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo, IPI.importDirs = [ libdir installDirs | hasModules ], IPI.libraryDirs = libdirs, IPI.libraryDynDirs = dynlibdirs, IPI.dataDir = datadir installDirs, - IPI.hsLibraries = if hasLibrary - then [getHSLibraryName (componentUnitId clbi)] - else [], + IPI.hsLibraries = (if hasLibrary + then [getHSLibraryName (componentUnitId clbi)] + else []) ++ extraBundledLibs bi, IPI.extraLibraries = extraLibs bi, IPI.extraGHCiLibraries = extraGHCiLibs bi, IPI.includeDirs = absinc ++ adjustRelIncDirs relinc, IPI.includes = includes bi, - --TODO: unclear what the root cause of the - -- duplication is, but we nub it here for now: - IPI.depends = ordNub $ map fst (componentPackageDeps clbi), + IPI.depends = depends, + IPI.abiDepends = abi_depends, IPI.ccOptions = [], -- Note. NOT ccOptions bi! -- We don't want cc-options to be propagated -- to C compilations in other packages. @@ -422,12 +451,26 @@ } where bi = libBuildInfo lib + --TODO: unclear what the root cause of the + -- duplication is, but we nub it here for now: + depends = ordNub $ map fst (componentPackageDeps clbi) + abi_depends = map add_abi depends + add_abi uid = IPI.AbiDependency uid abi + where + abi = case Index.lookupUnitId (installedPkgs lbi) uid of + Nothing -> error $ + "generalInstalledPackageInfo: missing IPI for " ++ display uid + Just ipi -> IPI.abiHash ipi (absinc, relinc) = partition isAbsolute (includeDirs bi) hasModules = not $ null (allLibModules lib clbi) comp = compiler lbi - hasLibrary = hasModules || not (null (cSources bi)) - || (not (null (jsSources bi)) && - compilerFlavor comp == GHCJS) + hasLibrary = (hasModules || not (null (cSources bi)) + || not (null (asmSources bi)) + || not (null (cmmSources bi)) + || not (null (cxxSources bi)) + || (not (null (jsSources bi)) && + compilerFlavor comp == GHCJS)) + && not (componentIsIndefinite clbi) (libdirs, dynlibdirs) | not hasLibrary = (extraLibDirs bi, []) @@ -538,7 +581,7 @@ (BS.Char8.pack $ invocationAsSystemScript buildOS invocation) else runProgramInvocation verbosity invocation setupMessage verbosity "Unregistering" pkgid - withHcPkg "unregistering is only implemented for GHC and GHCJS" + withHcPkg verbosity "unregistering is only implemented for GHC and GHCJS" (compiler lbi) (withPrograms lbi) unreg unregScriptFileName :: FilePath 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 @@ -38,11 +38,10 @@ GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, configPrograms, - RelaxDeps(..), RelaxedDep(..), isRelaxDeps, - AllowNewer(..), AllowOlder(..), configAbsolutePaths, readPackageDbList, showPackageDbList, CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, + DoctestFlags(..), emptyDoctestFlags, defaultDoctestFlags, doctestCommand, HaddockTarget(..), HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, @@ -72,6 +71,7 @@ fromFlagOrDefault, flagToMaybe, flagToList, + maybeToFlag, BooleanFlag(..), boolOpt, boolOpt', trueArg, falseArg, optionVerbosity, optionNumJobs, readPToMaybe ) where @@ -82,11 +82,13 @@ import Distribution.Compiler import Distribution.ReadE import Distribution.Text +import Distribution.Parsec.Class +import Distribution.Pretty import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P +import Distribution.ParseUtils (readPToMaybe) import qualified Text.PrettyPrint as Disp import Distribution.ModuleName -import Distribution.Package -import Distribution.Package.TextClass () import Distribution.PackageDescription hiding (Flag) import Distribution.Simple.Command hiding (boolOpt, boolOpt') import qualified Distribution.Simple.Command as Command @@ -96,7 +98,12 @@ import Distribution.Simple.InstallDirs import Distribution.Verbosity import Distribution.Utils.NubList +import Distribution.Types.Dependency +import Distribution.Types.ComponentId +import Distribution.Types.Module +import Distribution.Types.PackageName +import Distribution.Compat.Stack import Distribution.Compat.Semigroup (Last' (..)) import Data.Function (on) @@ -161,7 +168,7 @@ toFlag :: a -> Flag a toFlag = Flag -fromFlag :: Flag a -> a +fromFlag :: WithCallStack (Flag a -> a) fromFlag (Flag x) = x fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" @@ -182,6 +189,10 @@ then Flag True else NoFlag +maybeToFlag :: Maybe a -> Flag a +maybeToFlag Nothing = NoFlag +maybeToFlag (Just x) = Flag x + -- | Types that represent boolean flags. class BooleanFlag a where asBool :: a -> Bool @@ -264,92 +275,6 @@ -- * Config flags -- ------------------------------------------------------------ --- | Generic data type for policy when relaxing bounds in dependencies. --- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending --- on whether or not you are relaxing an lower or upper bound --- (respectively). -data RelaxDeps = - - -- | Default: honor the upper bounds in all dependencies, never choose - -- versions newer than allowed. - RelaxDepsNone - - -- | Ignore upper bounds in dependencies on the given packages. - | RelaxDepsSome [RelaxedDep] - - -- | Ignore upper bounds in dependencies on all packages. - | RelaxDepsAll - deriving (Eq, Read, Show, Generic) - --- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag) -newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps } - deriving (Eq, Read, Show, Generic) - --- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag) -newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps } - deriving (Eq, Read, Show, Generic) - --- | Dependencies can be relaxed either for all packages in the install plan, or --- only for some packages. -data RelaxedDep = RelaxedDep PackageName - | RelaxedDepScoped PackageName PackageName - deriving (Eq, Read, Show, Generic) - -instance Text RelaxedDep where - disp (RelaxedDep p0) = disp p0 - disp (RelaxedDepScoped p0 p1) = disp p0 Disp.<> Disp.colon Disp.<> disp p1 - - parse = scopedP Parse.<++ normalP - where - scopedP = RelaxedDepScoped `fmap` parse <* Parse.char ':' <*> parse - normalP = RelaxedDep `fmap` parse - -instance Binary RelaxDeps -instance Binary RelaxedDep -instance Binary AllowNewer -instance Binary AllowOlder - -instance Semigroup RelaxDeps where - RelaxDepsNone <> r = r - l@RelaxDepsAll <> _ = l - l@(RelaxDepsSome _) <> RelaxDepsNone = l - (RelaxDepsSome _) <> r@RelaxDepsAll = r - (RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b) - -instance Monoid RelaxDeps where - mempty = RelaxDepsNone - mappend = (<>) - -instance Semigroup AllowNewer where - AllowNewer x <> AllowNewer y = AllowNewer (x <> y) - -instance Semigroup AllowOlder where - AllowOlder x <> AllowOlder y = AllowOlder (x <> y) - -instance Monoid AllowNewer where - mempty = AllowNewer mempty - mappend = (<>) - -instance Monoid AllowOlder where - mempty = AllowOlder mempty - mappend = (<>) - --- | Convert 'RelaxDeps' to a boolean. -isRelaxDeps :: RelaxDeps -> Bool -isRelaxDeps RelaxDepsNone = False -isRelaxDeps (RelaxDepsSome _) = True -isRelaxDeps RelaxDepsAll = True - -relaxDepsParser :: Parse.ReadP r (Maybe RelaxDeps) -relaxDepsParser = - (Just . RelaxDepsSome) `fmap` Parse.sepBy1 parse (Parse.char ',') - -relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String] -relaxDepsPrinter Nothing = [] -relaxDepsPrinter (Just RelaxDepsNone) = [] -relaxDepsPrinter (Just RelaxDepsAll) = [Nothing] -relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . display) $ pkgs - -- | Flags to @configure@ command. -- -- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags' @@ -378,6 +303,7 @@ configVanillaLib :: Flag Bool, -- ^Enable vanilla library configProfLib :: Flag Bool, -- ^Enable profiling in the library configSharedLib :: Flag Bool, -- ^Build shared library + configStaticLib :: Flag Bool, -- ^Build static library configDynExe :: Flag Bool, -- ^Enable dynamic linking of the -- executables. configProfExe :: Flag Bool, -- ^Enable profiling in the @@ -401,6 +327,9 @@ configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files configIPID :: Flag String, -- ^ explicit IPID to be used configCID :: Flag ComponentId, -- ^ explicit CID to be used + configDeterministic :: Flag Bool, -- ^ be as deterministic as possible + -- (e.g., invariant over GHC, database, + -- etc). Used by the test suite configDistPref :: Flag FilePath, -- ^"dist" prefix configCabalFilePath :: Flag FilePath, -- ^ Cabal file to use @@ -408,6 +337,7 @@ configUserInstall :: Flag Bool, -- ^The --user\/--global flag configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi + configSplitSections :: Flag Bool, -- ^Enable -split-sections with GHC configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC configStripExes :: Flag Bool, -- ^Enable executable stripping configStripLibs :: Flag Bool, -- ^Enable library stripping @@ -431,10 +361,9 @@ -- ^Halt and show an error message indicating an error in flag assignment configRelocatable :: Flag Bool, -- ^ Enable relocatable package built configDebugInfo :: Flag DebugInfoLevel, -- ^ Emit debug info. - configAllowOlder :: Maybe AllowOlder, -- ^ dual to 'configAllowNewer' - configAllowNewer :: Maybe AllowNewer - -- ^ Ignore upper bounds on all or some dependencies. Wrapped in 'Maybe' to - -- distinguish between "default" and "explicitly disabled". + configUseResponseFiles :: Flag Bool + -- ^ Whether to use response files at all. They're used for such tools + -- as haddock, or or ld. } deriving (Generic, Read, Show) @@ -442,7 +371,7 @@ -- | More convenient version of 'configPrograms'. Results in an -- 'error' if internal invariant is violated. -configPrograms :: ConfigFlags -> ProgramDb +configPrograms :: WithCallStack (ConfigFlags -> ProgramDb) configPrograms = maybe (error "FIXME: remove configPrograms") id . getLast' . configPrograms_ instance Eq ConfigFlags where @@ -457,6 +386,7 @@ && equal configVanillaLib && equal configProfLib && equal configSharedLib + && equal configStaticLib && equal configDynExe && equal configProfExe && equal configProf @@ -471,11 +401,13 @@ && equal configExtraLibDirs && equal configExtraIncludeDirs && equal configIPID + && equal configDeterministic && equal configDistPref && equal configVerbosity && equal configUserInstall && equal configPackageDBs && equal configGHCiLib + && equal configSplitSections && equal configSplitObjs && equal configStripExes && equal configStripLibs @@ -490,6 +422,7 @@ && equal configFlagError && equal configRelocatable && equal configDebugInfo + && equal configUseResponseFiles where equal f = on (==) f a b @@ -507,6 +440,7 @@ configVanillaLib = Flag True, configProfLib = NoFlag, configSharedLib = NoFlag, + configStaticLib = NoFlag, configDynExe = Flag False, configProfExe = NoFlag, configProf = NoFlag, @@ -525,6 +459,7 @@ #else configGHCiLib = NoFlag, #endif + configSplitSections = Flag False, configSplitObjs = Flag False, -- takes longer, so turn off by default configStripExes = Flag True, configStripLibs = Flag True, @@ -536,7 +471,7 @@ configFlagError = NoFlag, configRelocatable = Flag False, configDebugInfo = Flag NoDebugInfo, - configAllowNewer = Nothing + configUseResponseFiles = NoFlag } configureCommand :: ProgramDb -> CommandUI ConfigFlags @@ -564,12 +499,12 @@ } -- | Inverse to 'dispModSubstEntry'. -parseModSubstEntry :: Parse.ReadP r (ModuleName, Module) -parseModSubstEntry = - do k <- parse - _ <- Parse.char '=' - v <- parse - return (k, v) +parsecModSubstEntry :: ParsecParser (ModuleName, Module) +parsecModSubstEntry = do + k <- parsec + _ <- P.char '=' + v <- parsec + return (k, v) -- | Pretty-print a single entry of a module substitution. dispModSubstEntry :: (ModuleName, Module) -> Disp.Doc @@ -637,6 +572,11 @@ configSharedLib (\v flags -> flags { configSharedLib = v }) (boolOpt [] []) + ,option "" ["static"] + "Static library" + configStaticLib (\v flags -> flags { configStaticLib = v }) + (boolOpt [] []) + ,option "" ["executable-dynamic"] "Executable dynamic linking" configDynExe (\v flags -> flags { configDynExe = v }) @@ -701,6 +641,11 @@ configGHCiLib (\v flags -> flags { configGHCiLib = v }) (boolOpt [] []) + ,option "" ["split-sections"] + "compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)" + configSplitSections (\v flags -> flags { configSplitSections = v }) + (boolOpt [] []) + ,option "" ["split-objs"] "split library into smaller objects to reduce binary sizes (GHC 6.6+)" configSplitObjs (\v flags -> flags { configSplitObjs = v }) @@ -739,13 +684,20 @@ ,option "f" ["flags"] "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) - (reqArg' "FLAGS" readFlagList showFlagList) + (reqArg "FLAGS" + (parsecToReadE (\err -> "Invalid flag assignment: " ++ err) parsecFlagAssignment) + showFlagAssignment) ,option "" ["extra-include-dirs"] "A list of directories to search for header files" configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) (reqArg' "PATH" (\x -> [x]) id) + ,option "" ["deterministic"] + "Try to be as deterministic as possible (used by the test suite)" + configDeterministic (\v flags -> flags {configDeterministic = v}) + (boolOpt [] []) + ,option "" ["ipid"] "Installed package ID to compile this package as" configIPID (\v flags -> flags {configIPID = v}) @@ -776,21 +728,21 @@ "A list of additional constraints on the dependencies." configConstraints (\v flags -> flags { configConstraints = v}) (reqArg "DEPENDENCY" - (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) - (map (\x -> display x))) + (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec)) + (map display)) ,option "" ["dependency"] "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" configDependencies (\v flags -> flags { configDependencies = v}) (reqArg "NAME=CID" - (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parseDependency)) + (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecDependency)) (map (\x -> display (fst x) ++ "=" ++ display (snd x)))) ,option "" ["instantiate-with"] "A mapping of signature names to concrete module instantiations." configInstantiateWith (\v flags -> flags { configInstantiateWith = v }) (reqArg "NAME=MOD" - (readP_to_E ("Cannot parse module substitution: " ++) (fmap (:[]) parseModSubstEntry)) + (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (:[]) parsecModSubstEntry)) (map (Disp.renderStyle defaultStyle . dispModSubstEntry))) ,option "" ["tests"] @@ -808,22 +760,6 @@ configLibCoverage (\v flags -> flags { configLibCoverage = v }) (boolOpt [] []) - ,option [] ["allow-older"] - ("Ignore upper bounds in all dependencies or DEPS") - (fmap unAllowOlder . configAllowOlder) - (\v flags -> flags { configAllowOlder = fmap AllowOlder v}) - (optArg "DEPS" - (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser) - (Just RelaxDepsAll) relaxDepsPrinter) - - ,option [] ["allow-newer"] - ("Ignore upper bounds in all dependencies or DEPS") - (fmap unAllowNewer . configAllowNewer) - (\v flags -> flags { configAllowNewer = fmap AllowNewer v}) - (optArg "DEPS" - (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser) - (Just RelaxDepsAll) relaxDepsPrinter) - ,option "" ["exact-configuration"] "All direct dependencies and flags are provided on the command line." configExactConfiguration @@ -839,17 +775,14 @@ "building a package that is relocatable. (GHC only)" configRelocatable (\v flags -> flags { configRelocatable = v}) (boolOpt [] []) + + ,option "" ["response-files"] + "enable workaround for old versions of programs like \"ar\" that do not support @file arguments" + configUseResponseFiles + (\v flags -> flags { configUseResponseFiles = v }) + (boolOpt' ([], ["disable-response-files"]) ([], [])) ] where - readFlagList :: String -> FlagAssignment - readFlagList = map tagWithValue . words - where tagWithValue ('-':fname) = (mkFlagName (lowercase fname), False) - tagWithValue fname = (mkFlagName (lowercase fname), True) - - showFlagList :: FlagAssignment -> [String] - showFlagList fs = [ if not set then '-':unFlagName fname else unFlagName fname - | (fname, set) <- fs] - liftInstallDirs = liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) @@ -857,6 +790,16 @@ reqArgFlag title _sf _lf d (fmap fromPathTemplate . get) (set . fmap toPathTemplate) +showFlagAssignment :: FlagAssignment -> [String] +showFlagAssignment = map showFlagValue' . unFlagAssignment + where + -- We can't use 'showFlagValue' because legacy custom-setups don't + -- support the '+' prefix in --flags; so we omit the (redundant) + prefix; + -- NB: we assume that we never have to set/enable '-'-prefixed flags here. + showFlagValue' :: (FlagName, Bool) -> String + showFlagValue' (f, True) = unFlagName f + showFlagValue' (f, False) = '-' : unFlagName f + readPackageDbList :: String -> [Maybe PackageDB] readPackageDbList "clear" = [Nothing] readPackageDbList "global" = [Just GlobalPackageDB] @@ -875,11 +818,11 @@ showProfDetailLevelFlag NoFlag = [] showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] -parseDependency :: Parse.ReadP r (PackageName, ComponentId) -parseDependency = do - x <- parse - _ <- Parse.char '=' - y <- parse +parsecDependency :: ParsecParser (PackageName, ComponentId) +parsecDependency = do + x <- parsec + _ <- P.char '=' + y <- parsec return (x, y) installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] @@ -914,6 +857,11 @@ libexecdir (\v flags -> flags { libexecdir = v }) installDirArg + , option "" ["libexecsubdir"] + "subdirectory of libexecdir in which private executables are installed" + libexecsubdir (\v flags -> flags { libexecsubdir = v }) + installDirArg + , option "" ["datadir"] "installation directory for read-only data" datadir (\v flags -> flags { datadir = v }) @@ -1376,6 +1324,68 @@ } -- ------------------------------------------------------------ +-- * Doctest flags +-- ------------------------------------------------------------ + +data DoctestFlags = DoctestFlags { + doctestProgramPaths :: [(String, FilePath)], + doctestProgramArgs :: [(String, [String])], + doctestDistPref :: Flag FilePath, + doctestVerbosity :: Flag Verbosity + } + deriving (Show, Generic) + +defaultDoctestFlags :: DoctestFlags +defaultDoctestFlags = DoctestFlags { + doctestProgramPaths = mempty, + doctestProgramArgs = [], + doctestDistPref = NoFlag, + doctestVerbosity = Flag normal + } + +doctestCommand :: CommandUI DoctestFlags +doctestCommand = CommandUI + { commandName = "doctest" + , commandSynopsis = "Run doctest tests." + , commandDescription = Just $ \_ -> + "Requires the program doctest, version 0.12.\n" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " doctest [FLAGS]\n" + , commandDefaultFlags = defaultDoctestFlags + , commandOptions = \showOrParseArgs -> + doctestOptions showOrParseArgs + ++ programDbPaths progDb ParseArgs + doctestProgramPaths (\v flags -> flags { doctestProgramPaths = v }) + ++ programDbOption progDb showOrParseArgs + doctestProgramArgs (\v fs -> fs { doctestProgramArgs = v }) + ++ programDbOptions progDb ParseArgs + doctestProgramArgs (\v flags -> flags { doctestProgramArgs = v }) + } + where + progDb = addKnownProgram doctestProgram + emptyProgramDb + +doctestOptions :: ShowOrParseArgs -> [OptionField DoctestFlags] +doctestOptions showOrParseArgs = + [optionVerbosity doctestVerbosity + (\v flags -> flags { doctestVerbosity = v }) + ,optionDistPref + doctestDistPref (\d flags -> flags { doctestDistPref = d }) + showOrParseArgs + ] + +emptyDoctestFlags :: DoctestFlags +emptyDoctestFlags = mempty + +instance Monoid DoctestFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup DoctestFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ -- * Haddock flags -- ------------------------------------------------------------ @@ -1393,6 +1403,15 @@ -- documentation in @/doc/html/-docs@. data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic) +instance Binary HaddockTarget + +instance Text HaddockTarget where + disp ForHackage = Disp.text "for-hackage" + disp ForDevelopment = Disp.text "for-development" + + parse = Parse.choice [ Parse.string "for-hackage" >> return ForHackage + , Parse.string "for-development" >> return ForDevelopment] + data HaddockFlags = HaddockFlags { haddockProgramPaths :: [(String, FilePath)], haddockProgramArgs :: [(String, [String])], @@ -1422,7 +1441,7 @@ haddockHoogle = Flag False, haddockHtml = Flag False, haddockHtmlLocation = NoFlag, - haddockForHackage = Flag ForDevelopment, + haddockForHackage = NoFlag, haddockExecutables = Flag False, haddockTestSuites = Flag False, haddockBenchmarks = Flag False, @@ -1631,7 +1650,7 @@ -- UserHooks stop us from passing extra info in other ways buildArgs :: [String] } - deriving (Show, Generic) + deriving (Read, Show, Generic) {-# DEPRECATED buildVerbose "Use buildVerbosity instead" #-} buildVerbose :: BuildFlags -> Verbosity @@ -1819,9 +1838,19 @@ knownTestShowDetails :: [TestShowDetails] knownTestShowDetails = [minBound..maxBound] -instance Text TestShowDetails where - disp = Disp.text . lowercase . show +instance Pretty TestShowDetails where + pretty = Disp.text . lowercase . show +instance Parsec TestShowDetails where + parsec = maybe (fail "invalid TestShowDetails") return . classify =<< ident + where + ident = P.munch1 (\c -> isAlpha c || c == '_' || c == '-') + classify str = lookup (lowercase str) enumMap + enumMap :: [(String, TestShowDetails)] + enumMap = [ (display x, x) + | x <- knownTestShowDetails ] + +instance Text TestShowDetails where parse = maybe Parse.pfail return . classify =<< ident where ident = Parse.munch1 (\c -> isAlpha c || c == '_' || c == '-') @@ -1908,10 +1937,10 @@ ++ "'direct': send results of test cases in real time; no log file.") testShowDetails (\v flags -> flags { testShowDetails = v }) (reqArg "FILTER" - (readP_to_E (\_ -> "--show-details flag expects one of " + (parsecToReadE (\_ -> "--show-details flag expects one of " ++ intercalate ", " (map display knownTestShowDetails)) - (fmap toFlag parse)) + (fmap toFlag parsec)) (flagToList . fmap display)) , option [] ["keep-tix-files"] "keep .tix files for HPC between test runs" @@ -2188,10 +2217,6 @@ -- * Other Utils -- ------------------------------------------------------------ -readPToMaybe :: Parse.ReadP a a -> String -> Maybe a -readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str - , all isSpace s ] - -- | Arguments to pass to a @configure@ script, e.g. generated by -- @autoconf@. configureArgs :: Bool -> ConfigFlags -> [String] @@ -2238,9 +2263,12 @@ -- | Helper function to split a string into a list of arguments. -- It's supposed to handle quoted things sensibly, eg: -- --- > splitArgs "--foo=\"C:\Program Files\Bar\" --baz" --- > = ["--foo=C:\Program Files\Bar", "--baz"] +-- > splitArgs "--foo=\"C:/Program Files/Bar/" --baz" +-- > = ["--foo=C:/Program Files/Bar", "--baz"] -- +-- > splitArgs "\"-DMSGSTR=\\\"foo bar\\\"\" --baz" +-- > = ["-DMSGSTR=\"foo bar\"","--baz"] +-- splitArgs :: String -> [String] splitArgs = space [] where @@ -2254,6 +2282,7 @@ string :: String -> String -> [String] string w [] = word w [] string w ('"':s) = space w s + string w ('\\':'"':s) = string ('"':w) s string w ( c :s) = string (c:w) s nonstring :: String -> String -> [String] 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 @@ -163,19 +163,19 @@ signatures = sigs, libBuildInfo = libBi } -> - allSourcesBuildInfo libBi pps (modules ++ sigs) + allSourcesBuildInfo verbosity libBi pps (modules ++ sigs) -- Executables sources. , fmap concat . withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do - biSrcs <- allSourcesBuildInfo exeBi pps [] + biSrcs <- allSourcesBuildInfo verbosity exeBi pps [] mainSrc <- findMainExeFile exeBi pps mainPath return (mainSrc:biSrcs) -- Foreign library sources , fmap concat . withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do - biSrcs <- allSourcesBuildInfo flibBi pps [] + biSrcs <- allSourcesBuildInfo verbosity flibBi pps [] defFiles <- mapM (findModDefFile flibBi pps) (foreignLibModDefFile flib) return (defFiles ++ biSrcs) @@ -185,12 +185,12 @@ let bi = testBuildInfo t case testInterface t of TestSuiteExeV10 _ mainPath -> do - biSrcs <- allSourcesBuildInfo bi pps [] + biSrcs <- allSourcesBuildInfo verbosity bi pps [] srcMainFile <- findMainExeFile bi pps mainPath return (srcMainFile:biSrcs) TestSuiteLibV09 _ m -> - allSourcesBuildInfo bi pps [m] - TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " + allSourcesBuildInfo verbosity bi pps [m] + TestSuiteUnsupported tp -> die' verbosity $ "Unsupported test suite type: " ++ show tp -- Benchmarks sources. @@ -199,10 +199,10 @@ let bi = benchmarkBuildInfo bm case benchmarkInterface bm of BenchmarkExeV10 _ mainPath -> do - biSrcs <- allSourcesBuildInfo bi pps [] + biSrcs <- allSourcesBuildInfo verbosity bi pps [] srcMainFile <- findMainExeFile bi pps mainPath return (srcMainFile:biSrcs) - BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: " + BenchmarkUnsupported tp -> die' verbosity $ "Unsupported benchmark type: " ++ show tp -- Data files. @@ -223,7 +223,7 @@ . withAllLib $ \ l -> do let lbi = libBuildInfo l relincdirs = "." : filter isRelative (includeDirs lbi) - traverse (fmap snd . findIncludeFile relincdirs) (installIncludes lbi) + traverse (fmap snd . findIncludeFile verbosity relincdirs) (installIncludes lbi) -- Setup script, if it exists. , fmap (maybe [] (\f -> [f])) $ findSetupFile "" @@ -311,12 +311,12 @@ -- | Given a list of include paths, try to find the include file named -- @f@. Return the name of the file and the full path, or exit with error if -- there's no such file. -findIncludeFile :: [FilePath] -> String -> IO (String, FilePath) -findIncludeFile [] f = die ("can't find include file " ++ f) -findIncludeFile (d:ds) f = do +findIncludeFile :: Verbosity -> [FilePath] -> String -> IO (String, FilePath) +findIncludeFile verbosity [] f = die' verbosity ("can't find include file " ++ f) +findIncludeFile verbosity (d:ds) f = do let path = (d f) b <- doesFileExist path - if b then return (f,path) else findIncludeFile ds f + if b then return (f,path) else findIncludeFile verbosity ds f -- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' -- and 'other-modules'. @@ -335,7 +335,7 @@ pathsModule = autogenPathsModuleName pkg_descr0 filterFunction bi = \mn -> mn /= pathsModule - && not (elem mn (autogenModules bi)) + && not (mn `elem` autogenModules bi) -- | Prepare a directory tree of source files for a snapshot version. -- It is expected that the appropriate snapshot version has already been set @@ -426,11 +426,12 @@ return tarBallFilePath -- | Given a buildinfo, return the names of all source files. -allSourcesBuildInfo :: BuildInfo +allSourcesBuildInfo :: Verbosity + -> BuildInfo -> [PPSuffixHandler] -- ^ Extra preprocessors -> [ModuleName] -- ^ Exposed modules -> IO [FilePath] -allSourcesBuildInfo bi pps modules = do +allSourcesBuildInfo verbosity bi pps modules = do let searchDirs = hsSourceDirs bi sources <- fmap concat $ sequenceA $ [ let file = ModuleName.toFilePath module_ @@ -452,7 +453,7 @@ nonEmpty x _ [] = x nonEmpty _ f xs = f xs suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"] - notFound m = die $ "Error: Could not find module: " ++ display m + notFound m = die' verbosity $ "Error: Could not find module: " ++ display m ++ " with any suffix: " ++ show suffixes ++ ". If the module " ++ "is autogenerated it should be added to 'autogen-modules'." diff --git a/cabal/Cabal/Distribution/Simple/Test.hs b/cabal/Cabal/Distribution/Simple/Test.hs --- a/cabal/Cabal/Distribution/Simple/Test.hs +++ b/cabal/Cabal/Distribution/Simple/Test.hs @@ -21,7 +21,7 @@ import Prelude () import Distribution.Compat.Prelude -import Distribution.Package +import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD import Distribution.Simple.Compiler import Distribution.Simple.Hpc @@ -40,7 +40,7 @@ import System.Directory ( createDirectoryIfMissing, doesFileExist, getDirectoryContents , removeFile ) -import System.Exit ( ExitCode(..), exitFailure, exitWith ) +import System.Exit ( exitFailure, exitSuccess ) import System.FilePath ( () ) -- |Perform the \"@.\/setup test@\" action. @@ -80,17 +80,18 @@ , logFile = "" } - when (not $ PD.hasTests pkg_descr) $ do + unless (PD.hasTests pkg_descr) $ do notice verbosity "Package has no test suites." - exitWith ExitSuccess + exitSuccess when (PD.hasTests pkg_descr && null enabledTests) $ - die $ "No test suites enabled. Did you remember to configure with " - ++ "\'--enable-tests\'?" + die' verbosity $ + "No test suites enabled. Did you remember to configure with " + ++ "\'--enable-tests\'?" testsToRun <- case testNames of [] -> return $ zip enabledTests $ repeat Nothing - names -> flip traverse names $ \tName -> + names -> for names $ \tName -> let testMap = zip enabledNames enabledTests enabledNames = map (PD.testName . fst) enabledTests allNames = map PD.testName pkgTests @@ -98,9 +99,9 @@ in case lookup tCompName testMap of Just t -> return (t, Nothing) _ | tCompName `elem` allNames -> - die $ "Package configured with test suite " + die' verbosity $ "Package configured with test suite " ++ tName ++ " disabled." - | otherwise -> die $ "no such test: " ++ tName + | otherwise -> die' verbosity $ "no such test: " ++ tName createDirectoryIfMissing True testLogDir diff --git a/cabal/Cabal/Distribution/Simple/Test/ExeV10.hs b/cabal/Cabal/Distribution/Simple/Test/ExeV10.hs --- a/cabal/Cabal/Distribution/Simple/Test/ExeV10.hs +++ b/cabal/Cabal/Distribution/Simple/Test/ExeV10.hs @@ -6,9 +6,9 @@ ) where import Prelude () -import Distribution.Package import Distribution.Compat.Prelude +import Distribution.Types.UnqualComponentName import Distribution.Compat.CreatePipe import Distribution.Compat.Environment import qualified Distribution.PackageDescription as PD @@ -33,7 +33,7 @@ , getCurrentDirectory, removeDirectoryRecursive ) import System.Exit ( ExitCode(..) ) import System.FilePath ( (), (<.>) ) -import System.IO ( hGetContents, hPutStr, stdout, stderr ) +import System.IO ( hGetContents, stdout, stderr ) runTest :: PD.PackageDescription -> LBI.LocalBuildInfo @@ -53,7 +53,7 @@ testName' <.> exeExtension -- Check that the test executable exists. exists <- doesFileExist cmd - unless exists $ die $ "Error: Could not find test program \"" ++ cmd + unless exists $ die' verbosity $ "Error: Could not find test program \"" ++ cmd ++ "\". Did you build the package first?" -- Remove old .tix files if appropriate. @@ -78,7 +78,7 @@ void $ forkIO $ length logText `seq` return () -- '--show-details=streaming': print the log output in another thread - when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText + when (details == Streaming) $ void $ forkIO $ putStr logText return (wOut, wOut, logText) diff --git a/cabal/Cabal/Distribution/Simple/Test/LibV09.hs b/cabal/Cabal/Distribution/Simple/Test/LibV09.hs --- a/cabal/Cabal/Distribution/Simple/Test/LibV09.hs +++ b/cabal/Cabal/Distribution/Simple/Test/LibV09.hs @@ -10,8 +10,8 @@ ) where import Prelude () -import Distribution.Package import Distribution.Compat.Prelude +import Distribution.Types.UnqualComponentName import Distribution.Compat.CreatePipe import Distribution.Compat.Environment @@ -35,10 +35,11 @@ import qualified Control.Exception as CE import System.Directory - ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist + ( createDirectoryIfMissing, canonicalizePath + , doesDirectoryExist, doesFileExist , getCurrentDirectory, removeDirectoryRecursive, removeFile , setCurrentDirectory ) -import System.Exit ( ExitCode(..), exitWith ) +import System.Exit ( exitSuccess, exitWith, ExitCode(..) ) import System.FilePath ( (), (<.>) ) import System.IO ( hClose, hGetContents, hPutStr ) import System.Process (StdStream(..), waitForProcess) @@ -60,8 +61,9 @@ stubName suite <.> exeExtension -- Check that the test executable exists. exists <- doesFileExist cmd - unless exists $ die $ "Error: Could not find test program \"" ++ cmd - ++ "\". Did you build the package first?" + unless exists $ + die' verbosity $ "Error: Could not find test program \"" ++ cmd + ++ "\". Did you build the package first?" -- Remove old .tix files if appropriate. unless (fromFlag $ testKeepTix flags) $ do @@ -89,13 +91,14 @@ shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv -- Add (DY)LD_LIBRARY_PATH if needed - shellEnv' <- if LBI.withDynExe lbi - then do - let (Platform _ os) = LBI.hostPlatform lbi - paths <- LBI.depLibraryPaths - True False lbi clbi - return (addLibraryPath os paths shellEnv) - else return shellEnv + shellEnv' <- + if LBI.withDynExe lbi + then do + let (Platform _ os) = LBI.hostPlatform lbi + paths <- LBI.depLibraryPaths True False lbi clbi + cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi + return (addLibraryPath os (cpath : paths) shellEnv) + else return shellEnv createProcessWithEnv verbosity cmd opts Nothing (Just shellEnv') -- these handles are closed automatically CreatePipe (UseHandle wOut) (UseHandle wOut) @@ -269,4 +272,4 @@ writeFile (logFile testLog) $ show testLog when (suiteError logs) $ exitWith $ ExitFailure 2 when (suiteFailed logs) $ exitWith $ ExitFailure 1 - exitWith ExitSuccess + exitSuccess diff --git a/cabal/Cabal/Distribution/Simple/Test/Log.hs b/cabal/Cabal/Distribution/Simple/Test/Log.hs --- a/cabal/Cabal/Distribution/Simple/Test/Log.hs +++ b/cabal/Cabal/Distribution/Simple/Test/Log.hs @@ -18,6 +18,7 @@ import Distribution.Compat.Prelude import Distribution.Package +import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD import Distribution.Simple.Compiler import Distribution.Simple.InstallDirs 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 @@ -36,6 +36,7 @@ import Distribution.Simple.Program import Distribution.Simple.Utils import Distribution.Text +import Distribution.Types.MungedPackageId import Distribution.Verbosity import Distribution.Version import Distribution.System @@ -223,7 +224,7 @@ ++ ["--hide-all-packages"] ++ uhcPackageDbOptions user system (withPackageDB lbi) ++ ["--package=uhcbase"] - ++ ["--package=" ++ display (pkgName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] + ++ ["--package=" ++ display (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] -- search paths ++ ["-i" ++ odir] ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] diff --git a/cabal/Cabal/Distribution/Simple/UserHooks.hs b/cabal/Cabal/Distribution/Simple/UserHooks.hs --- a/cabal/Cabal/Distribution/Simple/UserHooks.hs +++ b/cabal/Cabal/Distribution/Simple/UserHooks.hs @@ -135,6 +135,13 @@ -- |Hook to run after hscolour command. Second arg indicates verbosity level. postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (), + -- |Hook to run before doctest command. Second arg indicates verbosity level. + preDoctest :: Args -> DoctestFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during doctest. + doctestHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> DoctestFlags -> IO (), + -- |Hook to run after doctest command. Second arg indicates verbosity level. + postDoctest :: Args -> DoctestFlags -> PackageDescription -> LocalBuildInfo -> IO (), + -- |Hook to run before haddock command. Second arg indicates verbosity level. preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo, -- |Over-ride this hook to get different behavior during haddock. @@ -197,6 +204,9 @@ preHscolour = rn, hscolourHook = ru, postHscolour = ru, + preDoctest = rn, + doctestHook = ru, + postDoctest = ru, preHaddock = rn, haddockHook = ru, postHaddock = ru, 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 @@ -3,6 +3,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NoMonoLocalBinds #-} ----------------------------------------------------------------------------- -- | @@ -24,12 +26,20 @@ cabalVersion, -- * logging and errors - die, - dieWithLocation, - dieMsg, dieMsgNoWrap, + -- Old style + die, dieWithLocation, + -- New style + dieNoVerbosity, + die', dieWithLocation', + dieNoWrap, topHandler, topHandlerWith, - warn, notice, noticeNoWrap, setupMessage, info, debug, - debugNoWrap, chattyTry, + warn, + notice, noticeNoWrap, noticeDoc, + setupMessage, + info, infoNoWrap, + debug, debugNoWrap, + chattyTry, + annotateIO, printRawCommandAndArgs, printRawCommandAndArgsAndEnv, -- * exceptions @@ -48,6 +58,14 @@ findProgramLocation, findProgramVersion, + -- ** 'IOData' re-export + -- + -- These types are re-exported from + -- "Distribution.Utils.IOData" for convience as they're + -- exposed in the API of 'rawSystemStdInOut' + IOData(..), + IODataMode(..), + -- * copying files smartCopySources, createDirectoryIfMissingVerbose, @@ -119,18 +137,16 @@ rewriteFile, -- * Unicode - fromUTF8, fromUTF8BS, fromUTF8LBS, - toUTF8, + toUTF8BS, + toUTF8LBS, readUTF8File, withUTF8FileContents, writeUTF8File, normaliseLineEndings, -- * BOM - startsWithBOM, - fileHasBOM, ignoreBOM, -- * generic utils @@ -144,6 +160,7 @@ listUnion, listUnionRight, ordNub, + ordNubBy, ordNubRight, safeTail, unintersperse, @@ -159,8 +176,9 @@ import Distribution.Compat.Prelude import Distribution.Text -import Distribution.Utils.String -import Distribution.Package +import Distribution.Utils.Generic +import Distribution.Utils.IOData (IOData(..), IODataMode(..)) +import qualified Distribution.Utils.IOData as IOData import Distribution.ModuleName as ModuleName import Distribution.System import Distribution.Version @@ -169,6 +187,7 @@ import Distribution.Compat.Exception import Distribution.Compat.Stack import Distribution.Verbosity +import Distribution.Types.PackageId #if __GLASGOW_HASKELL__ < 711 #ifdef VERSION_base @@ -186,24 +205,14 @@ import Control.Concurrent.MVar ( newEmptyMVar, putMVar, takeMVar ) -import Data.Bits - ( Bits((.|.), (.&.), shiftL, shiftR) ) -import Data.List - ( isInfixOf ) import Data.Typeable ( cast ) -import Data.Ord - ( comparing ) -import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import qualified Data.Set as Set -import qualified Data.ByteString as SBS - import System.Directory ( Permissions(executable), getDirectoryContents, getPermissions , doesDirectoryExist, doesFileExist, removeFile, findExecutable - , getModificationTime ) + , getModificationTime, createDirectory, removeDirectoryRecursive ) import System.Environment ( getProgName ) import System.Exit @@ -213,29 +222,26 @@ , getSearchPath, joinPath, takeDirectory, splitFileName , splitExtension, splitExtensions, splitDirectories , searchPathSeparator ) -import System.Directory - ( createDirectory, renameFile, removeDirectoryRecursive ) import System.IO - ( Handle, openFile, openBinaryFile, openBinaryTempFileWithDefaultPermissions - , IOMode(ReadMode), hSetBinaryMode - , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) -import System.IO.Error as IO.Error - ( isDoesNotExistError, isAlreadyExistsError - , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) + ( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush + , hClose, hSetBuffering, BufferMode(..) ) import System.IO.Error - ( ioeSetLocation, ioeGetLocation ) import System.IO.Unsafe ( unsafeInterleaveIO ) import qualified Control.Exception as Exception +import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) import Control.Exception (IOException, evaluate, throwIO) import Control.Concurrent (forkIO) +import Numeric (showFFloat) import qualified System.Process as Process ( CreateProcess(..), StdStream(..), proc) import System.Process ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess , showCommandForUser, waitForProcess) +import qualified Text.PrettyPrint as Disp + -- We only get our own version number when we're building with ourselves cabalVersion :: Version #if defined(BOOTSTRAPPED_CABAL) @@ -249,6 +255,57 @@ -- ---------------------------------------------------------------------------- -- Exception and logging utils +-- Cabal's logging infrastructure has a few constraints: +-- +-- * We must make all logging formatting and emissions decisions based +-- on the 'Verbosity' parameter, which is the only parameter that is +-- plumbed to enough call-sites to actually be used for this matter. +-- (One of Cabal's "big mistakes" is to have never have defined a +-- monad of its own.) +-- +-- * When we 'die', we must raise an IOError. This a backwards +-- compatibility consideration, because that's what we've raised +-- previously, and if we change to any other exception type, +-- exception handlers which match on IOError will no longer work. +-- One case where it is known we rely on IOError being catchable +-- is 'readPkgConfigDb' in cabal-install; there may be other +-- user code that also assumes this. +-- +-- * The 'topHandler' does not know what 'Verbosity' is, because +-- it gets called before we've done command line parsing (where +-- the 'Verbosity' parameter would come from). +-- +-- This leads to two big architectural choices: +-- +-- * Although naively we might imagine 'Verbosity' to be a simple +-- enumeration type, actually it is a full-on abstract data type +-- that may contain arbitrarily complex information. At the +-- moment, it is fully representable as a string, but we might +-- eventually also use verbosity to let users register their +-- own logging handler. +-- +-- * When we call 'die', we perform all the formatting and addition +-- of extra information we need, and then ship this in the IOError +-- to the top-level handler. Here are alternate designs that +-- don't work: +-- +-- a) Ship the unformatted info to the handler. This doesn't +-- work because at the point the handler gets the message, +-- we've lost call stacks, and even if we did, we don't have access +-- to 'Verbosity' to decide whether or not to render it. +-- +-- b) Print the information at the 'die' site, then raise an +-- error. This means that if the exception is subsequently +-- caught by a handler, we will still have emitted the output, +-- which is not the correct behavior. +-- +-- For the top-level handler to "know" that an error message +-- contains one of these fully formatted packets, we set a sentinel +-- in one of IOError's extra fields. This is handled by +-- 'ioeSetVerbatim' and 'ioeGetVerbatim'. +-- + +{-# DEPRECATED dieWithLocation "Messages thrown with dieWithLocation can't be controlled with Verbosity; use dieWithLocation' instead" #-} dieWithLocation :: FilePath -> Maybe Int -> String -> IO a dieWithLocation filename lineno msg = ioError . setLocation lineno @@ -259,13 +316,80 @@ setLocation (Just n) err = ioeSetLocation err (show n) _ = callStack -- TODO: Attach CallStack to exception +{-# DEPRECATED die "Messages thrown with die can't be controlled with Verbosity; use die' instead, or dieNoVerbosity if Verbosity truly is not available" #-} die :: String -> IO a -die msg = ioError (userError msg) +die = dieNoVerbosity + +dieNoVerbosity :: String -> IO a +dieNoVerbosity msg + = ioError (userError msg) where _ = callStack -- TODO: Attach CallStack to exception +-- | Tag an 'IOError' whose error string should be output to the screen +-- verbatim. +ioeSetVerbatim :: IOError -> IOError +ioeSetVerbatim e = ioeSetLocation e "dieVerbatim" + +-- | Check if an 'IOError' should be output verbatim to screen. +ioeGetVerbatim :: IOError -> Bool +ioeGetVerbatim e = ioeGetLocation e == "dieVerbatim" + +-- | Create a 'userError' whose error text will be output verbatim +verbatimUserError :: String -> IOError +verbatimUserError = ioeSetVerbatim . userError + +dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a +dieWithLocation' verbosity filename mb_lineno msg = withFrozenCallStack $ do + ts <- getPOSIXTime + pname <- getProgName + ioError . verbatimUserError + . withMetadata ts AlwaysMark VerboseTrace verbosity + . wrapTextVerbosity verbosity + $ pname ++ ": " ++ + filename ++ (case mb_lineno of + Just lineno -> ":" ++ show lineno + Nothing -> "") ++ + ": " ++ msg + +die' :: Verbosity -> String -> IO a +die' verbosity msg = withFrozenCallStack $ do + ts <- getPOSIXTime + pname <- getProgName + ioError . verbatimUserError + . withMetadata ts AlwaysMark VerboseTrace verbosity + . wrapTextVerbosity verbosity + $ pname ++ ": " ++ msg + +dieNoWrap :: Verbosity -> String -> IO a +dieNoWrap verbosity msg = withFrozenCallStack $ do + -- TODO: should this have program name or not? + ts <- getPOSIXTime + ioError . verbatimUserError + . withMetadata ts AlwaysMark VerboseTrace verbosity + $ msg + +-- | Given a block of IO code that may raise an exception, annotate +-- it with the metadata from the current scope. Use this as close +-- to external code that raises IO exceptions as possible, since +-- this function unconditionally wraps the error message with a trace +-- (so it is NOT idempotent.) +annotateIO :: Verbosity -> IO a -> IO a +annotateIO verbosity act = do + ts <- getPOSIXTime + modifyIOError (f ts) act + where + f ts ioe = ioeSetErrorString ioe + . withMetadata ts NeverMark VerboseTrace verbosity + $ ioeGetErrorString ioe + + +{-# NOINLINE topHandlerWith #-} topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a -topHandlerWith cont prog = +topHandlerWith cont prog = do + -- By default, stderr to a terminal device is NoBuffering. But this + -- is *really slow* + hSetBuffering stderr LineBuffering Exception.catches prog [ Exception.Handler rethrowAsyncExceptions , Exception.Handler rethrowExitStatus @@ -285,13 +409,17 @@ handle se = do hFlush stdout pname <- getProgName - hPutStr stderr (wrapText (message pname se)) + hPutStr stderr (message pname se) cont se message :: String -> Exception.SomeException -> String message pname (Exception.SomeException se) = case cast se :: Maybe Exception.IOException of - Just ioe -> + Just ioe + | ioeGetVerbatim ioe -> + -- Use the message verbatim + ioeGetErrorString ioe ++ "\n" + | isUserError ioe -> let file = case ioeGetFileName ioe of Nothing -> "" Just path -> path ++ location ++ ": " @@ -299,48 +427,22 @@ l@(n:_) | isDigit n -> ':' : l _ -> "" detail = ioeGetErrorString ioe - in pname ++ ": " ++ file ++ detail - Nothing -> + in wrapText (pname ++ ": " ++ file ++ detail) + _ -> + displaySomeException se ++ "\n" + +-- | BC wrapper around 'Exception.displayException'. +displaySomeException :: Exception.Exception e => e -> String +displaySomeException se = #if __GLASGOW_HASKELL__ < 710 - show se + show se #else - Exception.displayException se + Exception.displayException se #endif topHandler :: IO a -> IO a topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog --- | Print out a call site/stack according to 'Verbosity'. -hPutCallStackPrefix :: Handle -> Verbosity -> IO () -hPutCallStackPrefix h verbosity = withFrozenCallStack $ do - when (isVerboseCallSite verbosity) $ - hPutStr h parentSrcLocPrefix - when (isVerboseCallStack verbosity) $ - hPutStr h ("----\n" ++ prettyCallStack callStack ++ "\n") - --- | This can be used to help produce formatted messages as part of a fatal --- error condition, prior to using 'die' or 'exitFailure'. --- --- For fatal conditions we normally simply use 'die' which throws an --- exception. Sometimes however 'die' is not sufficiently flexible to --- produce the desired output. --- --- Like 'die', these messages are always displayed on @stderr@, irrespective --- of the 'Verbosity' level. The 'Verbosity' parameter is needed though to --- decide how to format the output (e.g. line-wrapping). --- -dieMsg :: Verbosity -> String -> NoCallStackIO () -dieMsg verbosity msg = do - hFlush stdout - hPutStr stderr (wrapTextVerbosity verbosity msg) - --- | As 'dieMsg' but with pre-formatted text. --- -dieMsgNoWrap :: String -> NoCallStackIO () -dieMsgNoWrap msg = do - hFlush stdout - hPutStr stderr msg - -- | Non fatal conditions that may be indicative of an error or problem. -- -- We display these at the 'normal' verbosity level. @@ -348,9 +450,11 @@ warn :: Verbosity -> String -> IO () warn verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do + ts <- getPOSIXTime hFlush stdout - hPutCallStackPrefix stderr verbosity - hPutStr stderr (wrapTextVerbosity verbosity ("Warning: " ++ msg)) + hPutStr stderr . withMetadata ts NormalMark FlagTrace verbosity + . wrapTextVerbosity verbosity + $ "Warning: " ++ msg -- | Useful status messages. -- @@ -362,18 +466,36 @@ notice :: Verbosity -> String -> IO () notice verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do - hPutCallStackPrefix stdout verbosity - putStr (wrapTextVerbosity verbosity msg) + ts <- getPOSIXTime + hPutStr stdout . withMetadata ts NormalMark FlagTrace verbosity + . wrapTextVerbosity verbosity + $ msg +-- | Display a message at 'normal' verbosity level, but without +-- wrapping. +-- noticeNoWrap :: Verbosity -> String -> IO () noticeNoWrap verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do - hPutCallStackPrefix stdout verbosity - putStr msg + ts <- getPOSIXTime + hPutStr stdout . withMetadata ts NormalMark FlagTrace verbosity $ msg +-- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity +-- level. Use this if you need fancy formatting. +-- +noticeDoc :: Verbosity -> Disp.Doc -> IO () +noticeDoc verbosity msg = withFrozenCallStack $ do + when (verbosity >= normal) $ do + ts <- getPOSIXTime + hPutStr stdout . withMetadata ts NormalMark FlagTrace verbosity + . Disp.renderStyle defaultStyle $ msg + +-- | Display a "setup status message". Prefer using setupMessage' +-- if possible. +-- setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () setupMessage verbosity msg pkgid = withFrozenCallStack $ do - notice verbosity (msg ++ ' ': display pkgid ++ "...") + noticeNoWrap verbosity (msg ++ ' ': display pkgid ++ "...") -- | More detail on the operation of some action. -- @@ -382,9 +504,18 @@ info :: Verbosity -> String -> IO () info verbosity msg = withFrozenCallStack $ when (verbosity >= verbose) $ do - hPutCallStackPrefix stdout verbosity - putStr (wrapTextVerbosity verbosity msg) + ts <- getPOSIXTime + hPutStr stdout . withMetadata ts NeverMark FlagTrace verbosity + . wrapTextVerbosity verbosity + $ msg +infoNoWrap :: Verbosity -> String -> IO () +infoNoWrap verbosity msg = withFrozenCallStack $ + when (verbosity >= verbose) $ do + ts <- getPOSIXTime + hPutStr stdout . withMetadata ts NeverMark FlagTrace verbosity + $ msg + -- | Detailed internal debugging information -- -- We display these messages when the verbosity level is 'deafening' @@ -392,8 +523,11 @@ debug :: Verbosity -> String -> IO () debug verbosity msg = withFrozenCallStack $ when (verbosity >= deafening) $ do - hPutCallStackPrefix stdout verbosity - putStr (wrapTextVerbosity verbosity msg) + ts <- getPOSIXTime + hPutStr stdout . withMetadata ts NeverMark FlagTrace verbosity + . wrapTextVerbosity verbosity + $ msg + -- ensure that we don't lose output if we segfault/infinite loop hFlush stdout -- | A variant of 'debug' that doesn't perform the automatic line @@ -401,8 +535,10 @@ debugNoWrap :: Verbosity -> String -> IO () debugNoWrap verbosity msg = withFrozenCallStack $ when (verbosity >= deafening) $ do - hPutCallStackPrefix stdout verbosity - putStrLn msg + ts <- getPOSIXTime + hPutStr stdout . withMetadata ts NeverMark FlagTrace verbosity + $ msg + -- ensure that we don't lose output if we segfault/infinite loop hFlush stdout -- | Perform an IO action, catching any IO exceptions and printing an error @@ -425,37 +561,132 @@ -- ----------------------------------------------------------------------------- -- Helper functions --- | Wraps text to the default line width. Existing newlines are preserved. -wrapText :: String -> String -wrapText = unlines - . map (intercalate "\n" - . map unwords - . wrapLine 79 - . words) - . lines - -- | Wraps text unless the @+nowrap@ verbosity flag is active wrapTextVerbosity :: Verbosity -> String -> String wrapTextVerbosity verb - | isVerboseNoWrap verb = unlines . lines -- makes sure there's a trailing LF - | otherwise = wrapText + | isVerboseNoWrap verb = withTrailingNewline + | otherwise = withTrailingNewline . wrapText --- | Wraps a list of words to a list of lines of words of a particular width. -wrapLine :: Int -> [String] -> [[String]] -wrapLine width = wrap 0 [] - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] +-- | Prepends a timestamp if @+timestamp@ verbosity flag is set +-- +-- This is used by 'withMetadata' +-- +withTimestamp :: Verbosity -> POSIXTime -> String -> String +withTimestamp v ts msg + | isVerboseTimestamp v = msg' + | otherwise = msg -- no-op + where + msg' = case lines msg of + [] -> tsstr "\n" + l1:rest -> unlines (tsstr (' ':l1) : map (contpfx++) rest) + + -- format timestamp to be prepended to first line with msec precision + tsstr = showFFloat (Just 3) (realToFrac ts :: Double) + + -- continuation prefix for subsequent lines of msg + contpfx = replicate (length (tsstr " ")) ' ' + +-- | Wrap output with a marker if @+markoutput@ verbosity flag is set. +-- +-- NB: Why is markoutput done with start/end markers, and not prefixes? +-- Markers are more convenient to add (if we want to add prefixes, +-- we have to 'lines' and then 'map'; here's it's just some +-- concatenates). Note that even in the prefix case, we can't +-- guarantee that the markers are unambiguous, because some of +-- Cabal's output comes straight from external programs, where +-- we don't have the ability to interpose on the output. +-- +-- This is used by 'withMetadata' +-- +withOutputMarker :: Verbosity -> String -> String +withOutputMarker v xs | not (isVerboseMarkOutput v) = xs +withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly +withOutputMarker _ xs = + "-----BEGIN CABAL OUTPUT-----\n" ++ + withTrailingNewline xs ++ + "-----END CABAL OUTPUT-----\n" + +-- | Append a trailing newline to a string if it does not +-- already have a trailing newline. +-- +withTrailingNewline :: String -> String +withTrailingNewline "" = "" +withTrailingNewline (x:xs) = x : go x xs + where + go _ (c:cs) = c : go c cs + go '\n' "" = "" + go _ "" = "\n" + +-- | Prepend a call-site and/or call-stack based on Verbosity +-- +withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String) +withCallStackPrefix tracer verbosity s = withFrozenCallStack $ + (if isVerboseCallSite verbosity + then parentSrcLocPrefix ++ + -- Hack: need a newline before starting output marker :( + if isVerboseMarkOutput verbosity + then "\n" + else "" + else "") ++ + (case traceWhen verbosity tracer of + Just pre -> pre ++ prettyCallStack callStack ++ "\n" + Nothing -> "") ++ + s + +-- | When should we emit the call stack? We always emit +-- for internal errors, emit the trace for errors when we +-- are in verbose mode, and otherwise only emit it if +-- explicitly asked for using the @+callstack@ verbosity +-- flag. (At the moment, 'AlwaysTrace' is not used. +-- +data TraceWhen + = AlwaysTrace + | VerboseTrace + | FlagTrace + deriving (Eq) + +-- | Determine if we should emit a call stack. +-- If we trace, it also emits any prefix we should append. +traceWhen :: Verbosity -> TraceWhen -> Maybe String +traceWhen _ AlwaysTrace = Just "" +traceWhen v VerboseTrace | v >= verbose = Just "" +traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n" +traceWhen _ _ = Nothing + +-- | When should we output the marker? Things like 'die' +-- always get marked, but a 'NormalMark' will only be +-- output if we're not a quiet verbosity. +-- +data MarkWhen = AlwaysMark | NormalMark | NeverMark + +-- | Add all necessary metadata to a logging message +-- +withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String) +withMetadata ts marker tracer verbosity x = withFrozenCallStack $ + -- NB: order matters. Output marker first because we + -- don't want to capture call stacks. + withTrailingNewline + . withCallStackPrefix tracer verbosity + . (case marker of + AlwaysMark -> withOutputMarker verbosity + NormalMark | not (isVerboseQuiet verbosity) + -> withOutputMarker verbosity + | otherwise + -> id + NeverMark -> id) + -- Clear out any existing markers + . clearMarkers + . withTimestamp verbosity ts + $ x + +clearMarkers :: String -> String +clearMarkers s = unlines . filter isMarker $ lines s + where + isMarker "-----BEGIN CABAL OUTPUT-----" = False + isMarker "-----END CABAL OUTPUT-----" = False + isMarker _ = True + -- ----------------------------------------------------------------------------- -- rawSystem variants maybeExit :: IO ExitCode -> IO () @@ -465,23 +696,22 @@ printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () printRawCommandAndArgs verbosity path args = withFrozenCallStack $ - printRawCommandAndArgsAndEnv verbosity path args Nothing + printRawCommandAndArgsAndEnv verbosity path args Nothing Nothing printRawCommandAndArgsAndEnv :: Verbosity -> FilePath -> [String] + -> Maybe FilePath -> Maybe [(String, String)] -> IO () -printRawCommandAndArgsAndEnv verbosity path args menv - | verbosity >= deafening = do - traverse_ (putStrLn . ("Environment: " ++) . show) menv - hPutCallStackPrefix stdout verbosity - print (path, args) - | verbosity >= verbose = do - hPutCallStackPrefix stdout verbosity - putStrLn $ showCommandForUser path args - | otherwise = return () - +printRawCommandAndArgsAndEnv verbosity path args mcwd menv = do + case menv of + Just env -> debugNoWrap verbosity ("Environment: " ++ show env) + Nothing -> return () + case mcwd of + Just cwd -> debugNoWrap verbosity ("Working directory: " ++ show cwd) + Nothing -> return () + infoNoWrap verbosity (showCommandForUser path args) -- Exit with the same exit code if the subcommand fails rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () @@ -508,7 +738,7 @@ -> [(String, String)] -> IO () rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ do - printRawCommandAndArgsAndEnv verbosity path args (Just env) + printRawCommandAndArgsAndEnv verbosity path args Nothing (Just env) hFlush stdout (_,_,_,ph) <- createProcess $ (Process.proc path args) { Process.env = (Just env) @@ -559,7 +789,7 @@ -- ^ Any handles created for stdin, stdout, or stderr -- with 'CreateProcess', and a handle to the process. createProcessWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do - printRawCommandAndArgsAndEnv verbosity path args menv + printRawCommandAndArgsAndEnv verbosity path args mcwd menv hFlush stdout (inp', out', err', ph) <- createProcess $ (Process.proc path args) { @@ -584,9 +814,9 @@ -- rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String rawSystemStdout verbosity path args = withFrozenCallStack $ do - (output, errors, exitCode) <- rawSystemStdInOut verbosity path args + (IODataText output, errors, exitCode) <- rawSystemStdInOut verbosity path args Nothing Nothing - Nothing False + Nothing IODataModeText when (exitCode /= ExitSuccess) $ die errors return output @@ -600,10 +830,10 @@ -> [String] -- ^ Arguments -> Maybe FilePath -- ^ New working dir or inherit -> Maybe [(String, String)] -- ^ New environment or inherit - -> Maybe (String, Bool) -- ^ input text and binary mode - -> Bool -- ^ output in binary mode - -> IO (String, String, ExitCode) -- ^ output, errors, exit -rawSystemStdInOut verbosity path args mcwd menv input outputBinary = withFrozenCallStack $ do + -> Maybe IOData -- ^ input text and binary mode + -> IODataMode -- ^ output in binary mode + -> IO (IOData, String, ExitCode) -- ^ output, errors, exit +rawSystemStdInOut verbosity path args mcwd menv input outputMode = withFrozenCallStack $ do printRawCommandAndArgs verbosity path args Exception.bracket @@ -612,7 +842,6 @@ $ \(inh,outh,errh,pid) -> do -- output mode depends on what the caller wants - hSetBinaryMode outh outputBinary -- but the errors are always assumed to be text (in the current locale) hSetBinaryMode errh False @@ -620,11 +849,12 @@ -- so if the process writes to stderr we do not block. err <- hGetContents errh - out <- hGetContents outh + out <- IOData.hGetContents outh outputMode + mv <- newEmptyMVar let force str = do - mberr <- Exception.try (evaluate (length str) >> return ()) + mberr <- Exception.try (evaluate (rnf str) >> return ()) putMVar mv (mberr :: Either IOError ()) _ <- forkIO $ force out _ <- forkIO $ force err @@ -632,11 +862,9 @@ -- push all the input, if any case input of Nothing -> return () - Just (inputStr, inputBinary) -> do - -- input mode depends on what the caller wants - hSetBinaryMode inh inputBinary - hPutStr inh inputStr - hClose inh + 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) @@ -652,8 +880,9 @@ " with error message:\n" ++ err ++ case input of Nothing -> "" - Just ("", _) -> "" - Just (inp, _) -> "\nstdin input:\n" ++ inp + 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) @@ -987,8 +1216,7 @@ -- that the directory did indeed exist. | isAlreadyExistsError e -> (do isDir <- doesDirectoryExist dir - if isDir then return () - else throwIO e + unless isDir $ throwIO e ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) | otherwise -> throwIO e @@ -1210,52 +1438,25 @@ ----------------------------------- -- Safely reading and writing files --- | Gets the contents of a file, but guarantee that it gets closed. --- --- The file is read lazily but if it is not fully consumed by the action then --- the remaining input is truncated and the file is closed. --- -withFileContents :: FilePath -> (String -> NoCallStackIO a) -> NoCallStackIO a -withFileContents name action = - Exception.bracket (openFile name ReadMode) hClose - (\hnd -> hGetContents hnd >>= action) - --- | Writes a file atomically. --- --- The file is either written successfully or an IO exception is raised and --- the original file is left unchanged. --- --- On windows it is not possible to delete a file that is open by a process. --- This case will give an IO exception but the atomic property is not affected. --- -writeFileAtomic :: FilePath -> BS.ByteString -> NoCallStackIO () -writeFileAtomic targetPath content = do - let (targetDir, targetFile) = splitFileName targetPath - Exception.bracketOnError - (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") - (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) - (\(tmpPath, handle) -> do - BS.hPut handle content - hClose handle - renameFile tmpPath targetPath) - -- | Write a file but only if it would have new content. If we would be writing -- the same as the existing content then leave the file as is so that we do not -- update the file's modification time. -- -- NB: the file is assumed to be ASCII-encoded. -rewriteFile :: FilePath -> String -> IO () -rewriteFile path newContent = +rewriteFile :: Verbosity -> FilePath -> String -> IO () +rewriteFile verbosity path newContent = flip catchIO mightNotExist $ do - existingContent <- readFile path + existingContent <- annotateIO verbosity $ readFile path _ <- evaluate (length existingContent) unless (existingContent == newContent) $ - writeFileAtomic path (BS.Char8.pack newContent) + annotateIO verbosity $ + writeFileAtomic path (BS.Char8.pack newContent) where - mightNotExist e | isDoesNotExistError e = writeFileAtomic path - (BS.Char8.pack newContent) - | otherwise = ioError e - _ = callStack -- TODO: attach call stack to exception + mightNotExist e | isDoesNotExistError e + = annotateIO verbosity $ writeFileAtomic path + (BS.Char8.pack newContent) + | otherwise + = ioError e -- | The path name that represents the current directory. -- In Unix, it's @\".\"@, but this is system-specific. @@ -1354,262 +1555,3 @@ buildInfoExt :: String buildInfoExt = ".buildinfo" - --- ------------------------------------------------------------ --- * Unicode stuff --- ------------------------------------------------------------ - --- This is a modification of the UTF8 code from gtk2hs and the --- utf8-string package. - -fromUTF8 :: String -> String -fromUTF8 [] = [] -fromUTF8 (c:cs) - | c <= '\x7F' = c : fromUTF8 cs - | c <= '\xBF' = replacementChar : fromUTF8 cs - | c <= '\xDF' = twoBytes c cs - | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF) - | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7) - | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3) - | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1) - | otherwise = replacementChar : fromUTF8 cs - where - twoBytes c0 (c1:cs') - | ord c1 .&. 0xC0 == 0x80 - = let d = ((ord c0 .&. 0x1F) `shiftL` 6) - .|. (ord c1 .&. 0x3F) - in if d >= 0x80 - then chr d : fromUTF8 cs' - else replacementChar : fromUTF8 cs' - twoBytes _ cs' = replacementChar : fromUTF8 cs' - - moreBytes :: Int -> Int -> [Char] -> Int -> [Char] - moreBytes 1 overlong cs' acc - | overlong <= acc && acc <= 0x10FFFF - && (acc < 0xD800 || 0xDFFF < acc) - && (acc < 0xFFFE || 0xFFFF < acc) - = chr acc : fromUTF8 cs' - - | otherwise - = replacementChar : fromUTF8 cs' - - moreBytes byteCount overlong (cn:cs') acc - | ord cn .&. 0xC0 == 0x80 - = moreBytes (byteCount-1) overlong cs' - ((acc `shiftL` 6) .|. ord cn .&. 0x3F) - - moreBytes _ _ cs' _ - = replacementChar : fromUTF8 cs' - - replacementChar = '\xfffd' - -fromUTF8BS :: SBS.ByteString -> String -fromUTF8BS = decodeStringUtf8 . SBS.unpack - -fromUTF8LBS :: BS.ByteString -> String -fromUTF8LBS = decodeStringUtf8 . BS.unpack - -toUTF8 :: String -> String -toUTF8 [] = [] -toUTF8 (c:cs) - | c <= '\x07F' = c - : toUTF8 cs - | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12)) - : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - | otherwise = chr (0xf0 .|. (w `shiftR` 18)) - : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F)) - : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - where w = ord c - --- | Whether BOM is at the beginning of the input -startsWithBOM :: String -> Bool -startsWithBOM ('\xFEFF':_) = True -startsWithBOM _ = False - --- | Check whether a file has Unicode byte order mark (BOM). -fileHasBOM :: FilePath -> NoCallStackIO Bool -fileHasBOM f = fmap (startsWithBOM . fromUTF8) - . hGetContents =<< openBinaryFile f ReadMode - --- | Ignore a Unicode byte order mark (BOM) at the beginning of the input --- -ignoreBOM :: String -> String -ignoreBOM ('\xFEFF':string) = string -ignoreBOM string = string - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Reads lazily using ordinary 'readFile'. --- -readUTF8File :: FilePath -> NoCallStackIO String -readUTF8File f = fmap (ignoreBOM . fromUTF8) - . hGetContents =<< openBinaryFile f ReadMode - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Same behaviour as 'withFileContents'. --- -withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a -withUTF8FileContents name action = - Exception.bracket - (openBinaryFile name ReadMode) - hClose - (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8) - --- | Writes a Unicode String as a UTF8 encoded text file. --- --- Uses 'writeFileAtomic', so provides the same guarantees. --- -writeUTF8File :: FilePath -> String -> NoCallStackIO () -writeUTF8File path = writeFileAtomic path . BS.pack . encodeStringUtf8 - --- | Fix different systems silly line ending conventions -normaliseLineEndings :: String -> String -normaliseLineEndings [] = [] -normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows -normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old OS X -normaliseLineEndings ( c :s) = c : normaliseLineEndings s - --- ------------------------------------------------------------ --- * Common utils --- ------------------------------------------------------------ - --- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but --- quite a bit faster. The difference between "Data.List.dropWhileEnd" and this --- version is that the one in "Data.List" is strict in elements, but spine-lazy, --- while this one is spine-strict but lazy in elements. That's what @LE@ stands --- for - "lazy in elements". --- --- Example: --- --- @ --- > tail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1] --- *** Exception: Prelude.undefined --- > tail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1] --- [5,4,3] --- > take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined] --- [5,4,3] --- > take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined] --- *** Exception: Prelude.undefined --- @ -dropWhileEndLE :: (a -> Bool) -> [a] -> [a] -dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] - --- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but --- is usually faster (as well as being easier to read). -takeWhileEndLE :: (a -> Bool) -> [a] -> [a] -takeWhileEndLE p = fst . foldr go ([], False) - where - go x (rest, done) - | not done && p x = (x:rest, False) - | otherwise = (rest, True) - --- | Like "Data.List.nub", but has @O(n log n)@ complexity instead of --- @O(n^2)@. Code for 'ordNub' and 'listUnion' taken from Niklas Hambüchen's --- package. -ordNub :: (Ord a) => [a] -> [a] -ordNub l = go Set.empty l - where - go _ [] = [] - go s (x:xs) = if x `Set.member` s then go s xs - else x : go (Set.insert x s) xs - --- | Like "Data.List.union", but has @O(n log n)@ complexity instead of --- @O(n^2)@. -listUnion :: (Ord a) => [a] -> [a] -> [a] -listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b) - where - aSet = Set.fromList a - --- | A right-biased version of 'ordNub'. --- --- Example: --- --- @ --- > ordNub [1,2,1] --- [1,2] --- > ordNubRight [1,2,1] --- [2,1] --- @ -ordNubRight :: (Ord a) => [a] -> [a] -ordNubRight = fst . foldr go ([], Set.empty) - where - go x p@(l, s) = if x `Set.member` s then p - else (x:l, Set.insert x s) - --- | A right-biased version of 'listUnion'. --- --- Example: --- --- @ --- > listUnion [1,2,3,4,3] [2,1,1] --- [1,2,3,4,3] --- > listUnionRight [1,2,3,4,3] [2,1,1] --- [4,3,2,1,1] --- @ -listUnionRight :: (Ord a) => [a] -> [a] -> [a] -listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b - where - bSet = Set.fromList b - --- | A total variant of 'tail'. -safeTail :: [a] -> [a] -safeTail [] = [] -safeTail (_:xs) = xs - -equating :: Eq a => (b -> a) -> b -> b -> Bool -equating p x y = p x == p y - -lowercase :: String -> String -lowercase = map toLower - -unintersperse :: Char -> String -> [String] -unintersperse mark = unfoldr unintersperse1 where - unintersperse1 str - | null str = Nothing - | otherwise = - let (this, rest) = break (== mark) str in - Just (this, safeTail rest) - --- ------------------------------------------------------------ --- * FilePath stuff --- ------------------------------------------------------------ - --- | 'isAbsoluteOnAnyPlatform' and 'isRelativeOnAnyPlatform' are like --- 'System.FilePath.isAbsolute' and 'System.FilePath.isRelative' but have --- platform independent heuristics. --- The System.FilePath exists in two versions, Windows and Posix. The two --- versions don't agree on what is a relative path and we don't know if we're --- given Windows or Posix paths. --- This results in false positives when running on Posix and inspecting --- Windows paths, like the hackage server does. --- System.FilePath.Posix.isAbsolute \"C:\\hello\" == False --- System.FilePath.Windows.isAbsolute \"/hello\" == False --- This means that we would treat paths that start with \"/\" to be absolute. --- On Posix they are indeed absolute, while on Windows they are not. --- --- The portable versions should be used when we might deal with paths that --- are from another OS than the host OS. For example, the Hackage Server --- deals with both Windows and Posix paths while performing the --- PackageDescription checks. In contrast, when we run 'cabal configure' we --- do expect the paths to be correct for our OS and we should not have to use --- the platform independent heuristics. -isAbsoluteOnAnyPlatform :: FilePath -> Bool --- C:\\directory -isAbsoluteOnAnyPlatform (drive:':':'\\':_) = isAlpha drive --- UNC -isAbsoluteOnAnyPlatform ('\\':'\\':_) = True --- Posix root -isAbsoluteOnAnyPlatform ('/':_) = True -isAbsoluteOnAnyPlatform _ = False - --- | @isRelativeOnAnyPlatform = not . 'isAbsoluteOnAnyPlatform'@ -isRelativeOnAnyPlatform :: FilePath -> Bool -isRelativeOnAnyPlatform = not . isAbsoluteOnAnyPlatform diff --git a/cabal/Cabal/Distribution/System.hs b/cabal/Cabal/Distribution/System.hs --- a/cabal/Cabal/Distribution/System.hs +++ b/cabal/Cabal/Distribution/System.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -42,12 +43,17 @@ import Prelude () import Distribution.Compat.Prelude +import Control.Applicative (liftA2) import qualified System.Info (os, arch) +import Distribution.Utils.Generic (lowercase) +import Distribution.Parsec.Class +import Distribution.Pretty import Distribution.Text -import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P import qualified Text.PrettyPrint as Disp -- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. @@ -118,10 +124,14 @@ osAliases Compat Solaris = ["solaris2"] osAliases _ _ = [] -instance Text OS where - disp (OtherOS name) = Disp.text name - disp other = Disp.text (lowercase (show other)) +instance Pretty OS where + pretty (OtherOS name) = Disp.text name + pretty other = Disp.text (lowercase (show other)) +instance Parsec OS where + parsec = classifyOS Compat <$> parsecIdent + +instance Text OS where parse = fmap (classifyOS Compat) ident classifyOS :: ClassificationStrictness -> String -> OS @@ -179,10 +189,14 @@ archAliases _ Arm = ["armeb", "armel"] archAliases _ _ = [] -instance Text Arch where - disp (OtherArch name) = Disp.text name - disp other = Disp.text (lowercase (show other)) +instance Pretty Arch where + pretty (OtherArch name) = Disp.text name + pretty other = Disp.text (lowercase (show other)) +instance Parsec Arch where + parsec = classifyArch Strict <$> parsecIdent + +instance Text Arch where parse = fmap (classifyArch Strict) ident classifyArch :: ClassificationStrictness -> String -> Arch @@ -205,8 +219,24 @@ instance Binary Platform +instance Pretty Platform where + pretty (Platform arch os) = pretty arch <<>> Disp.char '-' <<>> pretty os + +instance Parsec Platform where + parsec = do + arch <- parsecDashlessArch + _ <- P.char '-' + os <- parsec + return (Platform arch os) + where + parsecDashlessArch = classifyArch Strict <$> dashlessIdent + + dashlessIdent = liftA2 (:) firstChar rest + where + firstChar = P.satisfy isAlpha + rest = P.munch (\c -> isAlphaNum c || c == '_') + instance Text Platform where - disp (Platform arch os) = disp arch <<>> Disp.char '-' <<>> disp os -- TODO: there are ambigious platforms like: `arch-word-os` -- which could be parsed as -- * Platform "arch-word" "os" @@ -223,6 +253,11 @@ parseDashlessArch :: Parse.ReadP r Arch parseDashlessArch = fmap (classifyArch Strict) dashlessIdent + dashlessIdent :: Parse.ReadP r String + dashlessIdent = liftM2 (:) firstChar rest + where firstChar = Parse.satisfy isAlpha + rest = Parse.munch (\c -> isAlphaNum c || c == '_') + -- | The platform Cabal was compiled on. In most cases, -- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're -- targeting). @@ -236,13 +271,11 @@ where firstChar = Parse.satisfy isAlpha rest = Parse.munch (\c -> isAlphaNum c || c == '_' || c == '-') -dashlessIdent :: Parse.ReadP r String -dashlessIdent = liftM2 (:) firstChar rest - where firstChar = Parse.satisfy isAlpha - rest = Parse.munch (\c -> isAlphaNum c || c == '_') - -lowercase :: String -> String -lowercase = map toLower +parsecIdent :: ParsecParser String +parsecIdent = (:) <$> firstChar <*> rest + where + firstChar = P.satisfy isAlpha + rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') platformFromTriple :: String -> Maybe Platform platformFromTriple triple = diff --git a/cabal/Cabal/Distribution/Text.hs b/cabal/Cabal/Distribution/Text.hs --- a/cabal/Cabal/Distribution/Text.hs +++ b/cabal/Cabal/Distribution/Text.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DefaultSignatures #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Text @@ -15,6 +16,7 @@ Text(..), defaultStyle, display, + flatStyle, simpleParse, stdParse, ) where @@ -22,22 +24,26 @@ import Prelude () import Distribution.Compat.Prelude +import Data.Functor.Identity (Identity (..)) +import Distribution.Pretty +import Distribution.Parsec.Class import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import Data.Version (Version(Version)) +-- | /Note:/ this class will soon be deprecated. +-- It's not yet, so that we are @-Wall@ clean. class Text a where disp :: a -> Disp.Doc - parse :: Parse.ReadP r a + default disp :: Pretty a => a -> Disp.Doc + disp = pretty --- | The default rendering style used in Cabal for console output. -defaultStyle :: Disp.Style -defaultStyle = Disp.Style { Disp.mode = Disp.PageMode - , Disp.lineLength = 79 - , Disp.ribbonsPerLine = 1.0 - } + parse :: Parse.ReadP r a + default parse :: Parsec a => Parse.ReadP r a + parse = Parse.parsecToReadP parsec [] +-- | Pretty-prints with the default style. display :: Text a => a -> String display = Disp.renderStyle defaultStyle . disp @@ -68,15 +74,17 @@ -- Instances for types from the base package instance Text Bool where - disp = Disp.text . show parse = Parse.choice [ (Parse.string "True" Parse.+++ Parse.string "true") >> return True , (Parse.string "False" Parse.+++ Parse.string "false") >> return False ] instance Text Int where - disp = Disp.text . show - parse = (fmap negate $ Parse.char '-' >> parseNat) Parse.+++ parseNat + parse = fmap negate (Parse.char '-' >> parseNat) Parse.+++ parseNat + +instance Text a => Text (Identity a) where + disp = disp . runIdentity + parse = fmap Identity parse -- | Parser for non-negative integers. parseNat :: Parse.ReadP r Int diff --git a/cabal/Cabal/Distribution/Types/AbiHash.hs b/cabal/Cabal/Distribution/Types/AbiHash.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/AbiHash.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Distribution.Types.AbiHash + ( AbiHash, unAbiHash, mkAbiHash + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText + +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Distribution.Text + +-- | ABI Hashes +-- +-- Use 'mkAbiHash' and 'unAbiHash' to convert from/to a +-- 'String'. +-- +-- This type is opaque since @Cabal-2.0@ +-- +-- @since 2.0.0.2 +newtype AbiHash = AbiHash ShortText + deriving (Eq, Show, Read, Generic) + +-- | Construct a 'AbiHash' from a 'String' +-- +-- 'mkAbiHash' is the inverse to 'unAbiHash' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'AbiHash' is valid +-- +-- @since 2.0.0.2 +unAbiHash :: AbiHash -> String +unAbiHash (AbiHash h) = fromShortText h + +-- | Convert 'AbiHash' to 'String' +-- +-- @since 2.0.0.2 +mkAbiHash :: String -> AbiHash +mkAbiHash = AbiHash . toShortText + +-- | 'mkAbiHash' +-- +-- @since 2.0.0.2 +instance IsString AbiHash where + fromString = mkAbiHash + +instance Binary AbiHash + +instance Text AbiHash where + disp = Disp.text . unAbiHash + parse = fmap mkAbiHash (Parse.munch isAlphaNum) diff --git a/cabal/Cabal/Distribution/Types/AnnotatedId.hs b/cabal/Cabal/Distribution/Types/AnnotatedId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/AnnotatedId.hs @@ -0,0 +1,25 @@ +module Distribution.Types.AnnotatedId ( + AnnotatedId(..) +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Package +import Distribution.Types.ComponentName + +-- | An 'AnnotatedId' is a 'ComponentId', 'UnitId', etc. +-- which is annotated with some other useful information +-- that is useful for printing to users, etc. +data AnnotatedId id = AnnotatedId { + ann_pid :: PackageId, + ann_cname :: ComponentName, + ann_id :: id + } + deriving (Show) + +instance Package (AnnotatedId id) where + packageId = ann_pid + +instance Functor AnnotatedId where + fmap f (AnnotatedId pid cn x) = AnnotatedId pid cn (f x) diff --git a/cabal/Cabal/Distribution/Types/Benchmark.hs b/cabal/Cabal/Distribution/Types/Benchmark.hs --- a/cabal/Cabal/Distribution/Types/Benchmark.hs +++ b/cabal/Cabal/Distribution/Types/Benchmark.hs @@ -16,10 +16,12 @@ import Distribution.Types.BuildInfo import Distribution.Types.BenchmarkType import Distribution.Types.BenchmarkInterface +import Distribution.Types.UnqualComponentName import Distribution.ModuleName -import Distribution.Package +import qualified Distribution.Types.BuildInfo.Lens as L + -- | A \"benchmark\" stanza in a cabal file. -- data Benchmark = Benchmark { @@ -30,6 +32,9 @@ deriving (Generic, Show, Read, Eq, Typeable, Data) instance Binary Benchmark + +instance L.HasBuildInfo Benchmark where + buildInfo f (Benchmark x1 x2 x3) = fmap (\y1 -> Benchmark x1 x2 y1) (f x3) instance Monoid Benchmark where mempty = Benchmark { diff --git a/cabal/Cabal/Distribution/Types/Benchmark/Lens.hs b/cabal/Cabal/Distribution/Types/Benchmark/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/Benchmark/Lens.hs @@ -0,0 +1,27 @@ +module Distribution.Types.Benchmark.Lens ( + Benchmark, + module Distribution.Types.Benchmark.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.Benchmark (Benchmark) +import Distribution.Types.BenchmarkInterface (BenchmarkInterface) +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.UnqualComponentName (UnqualComponentName) + +import qualified Distribution.Types.Benchmark as T + +benchmarkName :: Lens' Benchmark UnqualComponentName +benchmarkName f s = fmap (\x -> s { T.benchmarkName = x }) (f (T.benchmarkName s)) +{-# INLINE benchmarkName #-} + +benchmarkInterface :: Lens' Benchmark BenchmarkInterface +benchmarkInterface f s = fmap (\x -> s { T.benchmarkInterface = x }) (f (T.benchmarkInterface s)) +{-# INLINE benchmarkInterface #-} + +benchmarkBuildInfo :: Lens' Benchmark BuildInfo +benchmarkBuildInfo f s = fmap (\x -> s { T.benchmarkBuildInfo = x }) (f (T.benchmarkBuildInfo s)) +{-# INLINE benchmarkBuildInfo #-} diff --git a/cabal/Cabal/Distribution/Types/BenchmarkType.hs b/cabal/Cabal/Distribution/Types/BenchmarkType.hs --- a/cabal/Cabal/Distribution/Types/BenchmarkType.hs +++ b/cabal/Cabal/Distribution/Types/BenchmarkType.hs @@ -1,18 +1,19 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.BenchmarkType ( BenchmarkType(..), knownBenchmarkTypes, ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Version +import Distribution.Parsec.Class +import Distribution.Pretty import Distribution.Text - -import Text.PrettyPrint as Disp +import Distribution.Version +import Text.PrettyPrint (char, text) -- | The \"benchmark-type\" field in the benchmark stanza. -- @@ -27,10 +28,16 @@ knownBenchmarkTypes :: [BenchmarkType] knownBenchmarkTypes = [ BenchmarkTypeExe (mkVersion [1,0]) ] -instance Text BenchmarkType where - disp (BenchmarkTypeExe ver) = text "exitcode-stdio-" <<>> disp ver - disp (BenchmarkTypeUnknown name ver) = text name <<>> char '-' <<>> disp ver +instance Pretty BenchmarkType where + pretty (BenchmarkTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver + pretty (BenchmarkTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver +instance Parsec BenchmarkType where + parsec = parsecStandard $ \ver name -> case name of + "exitcode-stdio" -> BenchmarkTypeExe ver + _ -> BenchmarkTypeUnknown name ver + +instance Text BenchmarkType where parse = stdParse $ \ver name -> case name of "exitcode-stdio" -> BenchmarkTypeExe ver _ -> BenchmarkTypeUnknown name ver 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 @@ -9,36 +9,65 @@ allLanguages, allExtensions, usedExtensions, + usesTemplateHaskellOrQQ, hcOptions, hcProfOptions, hcSharedOptions, + hcStaticOptions, ) where import Prelude () import Distribution.Compat.Prelude import Distribution.Types.Mixin +import Distribution.Types.Dependency +import Distribution.Types.ExeDependency +import Distribution.Types.LegacyExeDependency +import Distribution.Types.PkgconfigDependency -import Distribution.Package import Distribution.ModuleName import Distribution.Compiler import Language.Haskell.Extension -- Consider refactoring into executable and library versions. data BuildInfo = BuildInfo { - buildable :: Bool, -- ^ component is buildable here - buildTools :: [LegacyExeDependency], -- ^ tools needed to build this bit + -- | component is buildable here + buildable :: Bool, + -- | Tools needed to build this bit. + -- + -- This is a legacy field that 'buildToolDepends' larely supersedes. + -- + -- Unless use are very sure what you are doing, use the functions in + -- "Distribution.Simple.BuildToolDepends" rather than accessing this + -- field directly. + buildTools :: [LegacyExeDependency], + -- | Haskell tools needed to build this bit + -- + -- This field is better than 'buildTools' because it allows one to + -- precisely specify an executable in a package. + -- + -- Unless use are very sure what you are doing, use the functions in + -- "Distribution.Simple.BuildToolDepends" rather than accessing this + -- field directly. + buildToolDepends :: [ExeDependency], cppOptions :: [String], -- ^ options for pre-processing Haskell code + asmOptions :: [String], -- ^ options for assmebler + cmmOptions :: [String], -- ^ options for C-- compiler ccOptions :: [String], -- ^ options for C compiler + cxxOptions :: [String], -- ^ options for C++ compiler ldOptions :: [String], -- ^ options for linker pkgconfigDepends :: [PkgconfigDependency], -- ^ pkg-config packages that are used frameworks :: [String], -- ^support frameworks for Mac OS X extraFrameworkDirs:: [String], -- ^ extra locations to find frameworks. + asmSources :: [FilePath], -- ^ Assembly files. + cmmSources :: [FilePath], -- ^ C-- files. cSources :: [FilePath], + cxxSources :: [FilePath], jsSources :: [FilePath], hsSourceDirs :: [FilePath], -- ^ where to look for the Haskell module hierarchy otherModules :: [ModuleName], -- ^ non-exposed or non-main modules + virtualModules :: [ModuleName], -- ^ exposed modules that do not have a source file (e.g. @GHC.Prim@ from @ghc-prim@ package) autogenModules :: [ModuleName], -- ^ not present on sdist, Paths_* or user-generated with a custom Setup.hs defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified @@ -49,6 +78,17 @@ extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package extraGHCiLibs :: [String], -- ^ if present, overrides extraLibs when package is loaded with GHCi. + extraBundledLibs :: [String], -- ^ if present, adds libs to hs-lirbaries, which become part of the package. + -- Example: the Cffi library shipping with the rts, alognside the HSrts-1.0.a,.o,... + -- Example 2: a library that is being built by a foreing tool (e.g. rust) + -- 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 lirbary builders. + extraLibFlavours :: [String], -- ^ Hidden Flag. This set of strings, will be appended to all lirbaries when + -- copying. E.g. [libHS_ | flavour <- extraLibFlavours]. This + -- should only be needed in very specific cases, e.g. the `rts` package, where + -- there are multiple copies of slightly differently built libs. extraLibDirs :: [String], includeDirs :: [FilePath], -- ^directories to find .h files includes :: [FilePath], -- ^ The .h files to be found in includeDirs @@ -56,6 +96,7 @@ options :: [(CompilerFlavor,[String])], profOptions :: [(CompilerFlavor,[String])], sharedOptions :: [(CompilerFlavor,[String])], + staticOptions :: [(CompilerFlavor,[String])], customFieldsBI :: [(String,String)], -- ^Custom fields starting -- with x-, stored in a -- simple assoc-list. @@ -70,16 +111,24 @@ mempty = BuildInfo { buildable = True, buildTools = [], + buildToolDepends = [], cppOptions = [], + asmOptions = [], + cmmOptions = [], ccOptions = [], + cxxOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], extraFrameworkDirs = [], + asmSources = [], + cmmSources = [], cSources = [], + cxxSources = [], jsSources = [], hsSourceDirs = [], otherModules = [], + virtualModules = [], autogenModules = [], defaultLanguage = Nothing, otherLanguages = [], @@ -88,6 +137,8 @@ oldExtensions = [], extraLibs = [], extraGHCiLibs = [], + extraBundledLibs = [], + extraLibFlavours = [], extraLibDirs = [], includeDirs = [], includes = [], @@ -95,6 +146,7 @@ options = [], profOptions = [], sharedOptions = [], + staticOptions = [], customFieldsBI = [], targetBuildDepends = [], mixins = [] @@ -105,16 +157,24 @@ a <> b = BuildInfo { buildable = buildable a && buildable b, buildTools = combine buildTools, + buildToolDepends = combine buildToolDepends, cppOptions = combine cppOptions, + asmOptions = combine asmOptions, + cmmOptions = combine cmmOptions, ccOptions = combine ccOptions, + cxxOptions = combine cxxOptions, ldOptions = combine ldOptions, pkgconfigDepends = combine pkgconfigDepends, frameworks = combineNub frameworks, extraFrameworkDirs = combineNub extraFrameworkDirs, + asmSources = combineNub asmSources, + cmmSources = combineNub cmmSources, cSources = combineNub cSources, + cxxSources = combineNub cxxSources, jsSources = combineNub jsSources, hsSourceDirs = combineNub hsSourceDirs, otherModules = combineNub otherModules, + virtualModules = combineNub virtualModules, autogenModules = combineNub autogenModules, defaultLanguage = combineMby defaultLanguage, otherLanguages = combineNub otherLanguages, @@ -123,6 +183,8 @@ oldExtensions = combineNub oldExtensions, extraLibs = combine extraLibs, extraGHCiLibs = combine extraGHCiLibs, + extraBundledLibs = combine extraBundledLibs, + extraLibFlavours = combine extraLibFlavours, extraLibDirs = combineNub extraLibDirs, includeDirs = combineNub includeDirs, includes = combineNub includes, @@ -130,6 +192,7 @@ options = combine options, profOptions = combine profOptions, sharedOptions = combine sharedOptions, + staticOptions = combine staticOptions, customFieldsBI = combine customFieldsBI, targetBuildDepends = combineNub targetBuildDepends, mixins = combine mixins @@ -160,6 +223,14 @@ usedExtensions bi = oldExtensions bi ++ defaultExtensions bi +-- | Whether any modules in this component use Template Haskell or +-- Quasi Quotes +usesTemplateHaskellOrQQ :: BuildInfo -> Bool +usesTemplateHaskellOrQQ bi = any p (allExtensions bi) + where + p ex = ex `elem` + [EnableExtension TemplateHaskell, EnableExtension QuasiQuotes] + -- |Select options for a particular Haskell compiler. hcOptions :: CompilerFlavor -> BuildInfo -> [String] hcOptions = lookupHcOptions options @@ -170,9 +241,11 @@ hcSharedOptions :: CompilerFlavor -> BuildInfo -> [String] hcSharedOptions = lookupHcOptions sharedOptions +hcStaticOptions :: CompilerFlavor -> BuildInfo -> [String] +hcStaticOptions = lookupHcOptions staticOptions + lookupHcOptions :: (BuildInfo -> [(CompilerFlavor,[String])]) -> CompilerFlavor -> BuildInfo -> [String] lookupHcOptions f hc bi = [ opt | (hc',opts) <- f bi , hc' == hc , opt <- opts ] - diff --git a/cabal/Cabal/Distribution/Types/BuildInfo/Lens.hs b/cabal/Cabal/Distribution/Types/BuildInfo/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/BuildInfo/Lens.hs @@ -0,0 +1,316 @@ +module Distribution.Types.BuildInfo.Lens ( + BuildInfo, + HasBuildInfo (..), + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Compat.Lens + +import Distribution.Compiler (CompilerFlavor) +import Distribution.ModuleName (ModuleName) +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.ExeDependency (ExeDependency) +import Distribution.Types.LegacyExeDependency (LegacyExeDependency) +import Distribution.Types.Mixin (Mixin) +import Distribution.Types.PkgconfigDependency (PkgconfigDependency) +import Language.Haskell.Extension (Extension, Language) + +import qualified Distribution.Types.BuildInfo as T + +-- | Classy lenses for 'BuildInfo'. +class HasBuildInfo a where + buildInfo :: Lens' a BuildInfo + + buildable :: Lens' a Bool + buildable = buildInfo . buildable + {-# INLINE buildable #-} + + buildTools :: Lens' a [LegacyExeDependency] + buildTools = buildInfo . buildTools + {-# INLINE buildTools #-} + + buildToolDepends :: Lens' a [ExeDependency] + buildToolDepends = buildInfo . buildToolDepends + {-# INLINE buildToolDepends #-} + + cppOptions :: Lens' a [String] + cppOptions = buildInfo . cppOptions + {-# INLINE cppOptions #-} + + asmOptions :: Lens' a [String] + asmOptions = buildInfo . asmOptions + {-# INLINE asmOptions #-} + + cmmOptions :: Lens' a [String] + cmmOptions = buildInfo . cmmOptions + {-# INLINE cmmOptions #-} + + ccOptions :: Lens' a [String] + ccOptions = buildInfo . ccOptions + {-# INLINE ccOptions #-} + + cxxOptions :: Lens' a [String] + cxxOptions = buildInfo . cxxOptions + {-# INLINE cxxOptions #-} + + ldOptions :: Lens' a [String] + ldOptions = buildInfo . ldOptions + {-# INLINE ldOptions #-} + + pkgconfigDepends :: Lens' a [PkgconfigDependency] + pkgconfigDepends = buildInfo . pkgconfigDepends + {-# INLINE pkgconfigDepends #-} + + frameworks :: Lens' a [String] + frameworks = buildInfo . frameworks + {-# INLINE frameworks #-} + + extraFrameworkDirs :: Lens' a [String] + extraFrameworkDirs = buildInfo . extraFrameworkDirs + {-# INLINE extraFrameworkDirs #-} + + asmSources :: Lens' a [FilePath] + asmSources = buildInfo . asmSources + {-# INLINE asmSources #-} + + cmmSources :: Lens' a [FilePath] + cmmSources = buildInfo . cmmSources + {-# INLINE cmmSources #-} + + cSources :: Lens' a [FilePath] + cSources = buildInfo . cSources + {-# INLINE cSources #-} + + cxxSources :: Lens' a [FilePath] + cxxSources = buildInfo . cxxSources + {-# INLINE cxxSources #-} + + jsSources :: Lens' a [FilePath] + jsSources = buildInfo . jsSources + {-# INLINE jsSources #-} + + hsSourceDirs :: Lens' a [FilePath] + hsSourceDirs = buildInfo . hsSourceDirs + {-# INLINE hsSourceDirs #-} + + otherModules :: Lens' a [ModuleName] + otherModules = buildInfo . otherModules + {-# INLINE otherModules #-} + + virtualModules :: Lens' a [ModuleName] + virtualModules = buildInfo . virtualModules + {-# INLINE virtualModules #-} + + autogenModules :: Lens' a [ModuleName] + autogenModules = buildInfo . autogenModules + {-# INLINE autogenModules #-} + + defaultLanguage :: Lens' a (Maybe Language) + defaultLanguage = buildInfo . defaultLanguage + {-# INLINE defaultLanguage #-} + + otherLanguages :: Lens' a [Language] + otherLanguages = buildInfo . otherLanguages + {-# INLINE otherLanguages #-} + + defaultExtensions :: Lens' a [Extension] + defaultExtensions = buildInfo . defaultExtensions + {-# INLINE defaultExtensions #-} + + otherExtensions :: Lens' a [Extension] + otherExtensions = buildInfo . otherExtensions + {-# INLINE otherExtensions #-} + + oldExtensions :: Lens' a [Extension] + oldExtensions = buildInfo . oldExtensions + {-# INLINE oldExtensions #-} + + extraLibs :: Lens' a [String] + extraLibs = buildInfo . extraLibs + {-# INLINE extraLibs #-} + + extraGHCiLibs :: Lens' a [String] + extraGHCiLibs = buildInfo . extraGHCiLibs + {-# INLINE extraGHCiLibs #-} + + extraBundledLibs :: Lens' a [String] + extraBundledLibs = buildInfo . extraBundledLibs + {-# INLINE extraBundledLibs #-} + + extraLibFlavours :: Lens' a [String] + extraLibFlavours = buildInfo . extraLibFlavours + {-# INLINE extraLibFlavours #-} + + extraLibDirs :: Lens' a [String] + extraLibDirs = buildInfo . extraLibDirs + {-# INLINE extraLibDirs #-} + + includeDirs :: Lens' a [FilePath] + includeDirs = buildInfo . includeDirs + {-# INLINE includeDirs #-} + + includes :: Lens' a [FilePath] + includes = buildInfo . includes + {-# INLINE includes #-} + + installIncludes :: Lens' a [FilePath] + installIncludes = buildInfo . installIncludes + {-# INLINE installIncludes #-} + + options :: Lens' a [(CompilerFlavor,[String])] + options = buildInfo . options + {-# INLINE options #-} + + profOptions :: Lens' a [(CompilerFlavor,[String])] + profOptions = buildInfo . profOptions + {-# INLINE profOptions #-} + + sharedOptions :: Lens' a [(CompilerFlavor,[String])] + sharedOptions = buildInfo . sharedOptions + {-# INLINE sharedOptions #-} + + staticOptions :: Lens' a [(CompilerFlavor,[String])] + staticOptions = buildInfo . staticOptions + {-# INLINE staticOptions #-} + + customFieldsBI :: Lens' a [(String,String)] + customFieldsBI = buildInfo . customFieldsBI + {-# INLINE customFieldsBI #-} + + targetBuildDepends :: Lens' a [Dependency] + targetBuildDepends = buildInfo . targetBuildDepends + {-# INLINE targetBuildDepends #-} + + mixins :: Lens' a [Mixin] + mixins = buildInfo . mixins + {-# INLINE mixins #-} + + +instance HasBuildInfo BuildInfo where + buildInfo = id + {-# INLINE buildInfo #-} + + buildable f s = fmap (\x -> s { T.buildable = x }) (f (T.buildable s)) + {-# INLINE buildable #-} + + buildTools f s = fmap (\x -> s { T.buildTools = x }) (f (T.buildTools s)) + {-# INLINE buildTools #-} + + buildToolDepends f s = fmap (\x -> s { T.buildToolDepends = x }) (f (T.buildToolDepends s)) + {-# INLINE buildToolDepends #-} + + cppOptions f s = fmap (\x -> s { T.cppOptions = x }) (f (T.cppOptions s)) + {-# INLINE cppOptions #-} + + asmOptions f s = fmap (\x -> s { T.asmOptions = x }) (f (T.asmOptions s)) + {-# INLINE asmOptions #-} + + cmmOptions f s = fmap (\x -> s { T.cmmOptions = x }) (f (T.cmmOptions s)) + {-# INLINE cmmOptions #-} + + ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s)) + {-# INLINE ccOptions #-} + + cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s)) + {-# INLINE cxxOptions #-} + + ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s)) + {-# INLINE ldOptions #-} + + pkgconfigDepends f s = fmap (\x -> s { T.pkgconfigDepends = x }) (f (T.pkgconfigDepends s)) + {-# INLINE pkgconfigDepends #-} + + frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s)) + {-# INLINE frameworks #-} + + extraFrameworkDirs f s = fmap (\x -> s { T.extraFrameworkDirs = x }) (f (T.extraFrameworkDirs s)) + {-# INLINE extraFrameworkDirs #-} + + asmSources f s = fmap (\x -> s { T.asmSources = x }) (f (T.asmSources s)) + {-# INLINE asmSources #-} + + cmmSources f s = fmap (\x -> s { T.cmmSources = x }) (f (T.cmmSources s)) + {-# INLINE cmmSources #-} + + cSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cSources s)) + {-# INLINE cSources #-} + + cxxSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cxxSources s)) + {-# INLINE cxxSources #-} + + jsSources f s = fmap (\x -> s { T.jsSources = x }) (f (T.jsSources s)) + {-# INLINE jsSources #-} + + hsSourceDirs f s = fmap (\x -> s { T.hsSourceDirs = x }) (f (T.hsSourceDirs s)) + {-# INLINE hsSourceDirs #-} + + otherModules f s = fmap (\x -> s { T.otherModules = x }) (f (T.otherModules s)) + {-# INLINE otherModules #-} + + virtualModules f s = fmap (\x -> s { T.virtualModules = x }) (f (T.virtualModules s)) + {-# INLINE virtualModules #-} + + autogenModules f s = fmap (\x -> s { T.autogenModules = x }) (f (T.autogenModules s)) + {-# INLINE autogenModules #-} + + defaultLanguage f s = fmap (\x -> s { T.defaultLanguage = x }) (f (T.defaultLanguage s)) + {-# INLINE defaultLanguage #-} + + otherLanguages f s = fmap (\x -> s { T.otherLanguages = x }) (f (T.otherLanguages s)) + {-# INLINE otherLanguages #-} + + defaultExtensions f s = fmap (\x -> s { T.defaultExtensions = x }) (f (T.defaultExtensions s)) + {-# INLINE defaultExtensions #-} + + otherExtensions f s = fmap (\x -> s { T.otherExtensions = x }) (f (T.otherExtensions s)) + {-# INLINE otherExtensions #-} + + oldExtensions f s = fmap (\x -> s { T.oldExtensions = x }) (f (T.oldExtensions s)) + {-# INLINE oldExtensions #-} + + extraLibs f s = fmap (\x -> s { T.extraLibs = x }) (f (T.extraLibs s)) + {-# INLINE extraLibs #-} + + extraGHCiLibs f s = fmap (\x -> s { T.extraGHCiLibs = x }) (f (T.extraGHCiLibs s)) + {-# INLINE extraGHCiLibs #-} + + extraBundledLibs f s = fmap (\x -> s { T.extraBundledLibs = x }) (f (T.extraBundledLibs s)) + {-# INLINE extraBundledLibs #-} + + extraLibFlavours f s = fmap (\x -> s { T.extraLibFlavours = x }) (f (T.extraLibFlavours s)) + {-# INLINE extraLibFlavours #-} + + extraLibDirs f s = fmap (\x -> s { T.extraLibDirs = x }) (f (T.extraLibDirs s)) + {-# INLINE extraLibDirs #-} + + includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s)) + {-# INLINE includeDirs #-} + + includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s)) + {-# INLINE includes #-} + + installIncludes f s = fmap (\x -> s { T.installIncludes = x }) (f (T.installIncludes s)) + {-# INLINE installIncludes #-} + + options f s = fmap (\x -> s { T.options = x }) (f (T.options s)) + {-# INLINE options #-} + + profOptions f s = fmap (\x -> s { T.profOptions = x }) (f (T.profOptions s)) + {-# INLINE profOptions #-} + + sharedOptions f s = fmap (\x -> s { T.sharedOptions = x }) (f (T.sharedOptions s)) + {-# INLINE sharedOptions #-} + + staticOptions f s = fmap (\x -> s { T.staticOptions = x }) (f (T.staticOptions s)) + {-# INLINE staticOptions #-} + + customFieldsBI f s = fmap (\x -> s { T.customFieldsBI = x }) (f (T.customFieldsBI s)) + {-# INLINE customFieldsBI #-} + + targetBuildDepends f s = fmap (\x -> s { T.targetBuildDepends = x }) (f (T.targetBuildDepends s)) + {-# INLINE targetBuildDepends #-} + + mixins f s = fmap (\x -> s { T.mixins = x }) (f (T.mixins s)) + {-# INLINE mixins #-} diff --git a/cabal/Cabal/Distribution/Types/BuildType.hs b/cabal/Cabal/Distribution/Types/BuildType.hs --- a/cabal/Cabal/Distribution/Types/BuildType.hs +++ b/cabal/Cabal/Distribution/Types/BuildType.hs @@ -9,10 +9,13 @@ import Prelude () import Distribution.Compat.Prelude +import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text -import qualified Distribution.Compat.ReadP as Parse -import Text.PrettyPrint as Disp +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp -- | The type of build system used by this package. data BuildType @@ -34,10 +37,21 @@ knownBuildTypes :: [BuildType] knownBuildTypes = [Simple, Configure, Make, Custom] -instance Text BuildType where - disp (UnknownBuildType other) = Disp.text other - disp other = Disp.text (show other) +instance Pretty BuildType where + pretty (UnknownBuildType other) = Disp.text other + pretty other = Disp.text (show other) +instance Parsec BuildType where + parsec = do + name <- P.munch1 isAlphaNum + return $ case name of + "Simple" -> Simple + "Configure" -> Configure + "Custom" -> Custom + "Make" -> Make + _ -> UnknownBuildType name + +instance Text BuildType where parse = do name <- Parse.munch1 isAlphaNum return $ case name of diff --git a/cabal/Cabal/Distribution/Types/Component.hs b/cabal/Cabal/Distribution/Types/Component.hs --- a/cabal/Cabal/Distribution/Types/Component.hs +++ b/cabal/Cabal/Distribution/Types/Component.hs @@ -21,6 +21,8 @@ import Distribution.Types.ComponentName import Distribution.Types.BuildInfo +import qualified Distribution.Types.BuildInfo.Lens as L + data Component = CLib Library | CFLib ForeignLib | CExe Executable @@ -36,6 +38,13 @@ CBench b <> CBench b' = CBench (b <> b') _ <> _ = error "Cannot merge Component" +instance L.HasBuildInfo Component where + buildInfo f (CLib l) = CLib <$> L.buildInfo f l + buildInfo f (CFLib l) = CFLib <$> L.buildInfo f l + buildInfo f (CExe e) = CExe <$> L.buildInfo f e + buildInfo f (CTest t) = CTest <$> L.buildInfo f t + buildInfo f (CBench b) = CBench <$> L.buildInfo f b + foldComponent :: (Library -> a) -> (ForeignLib -> a) -> (Executable -> a) @@ -57,22 +66,18 @@ -- See also this note in -- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". -- --- @since 2.0.0.0 +-- @since 2.0.0.2 -- componentBuildable :: Component -> Bool componentBuildable = buildable . componentBuildInfo componentName :: Component -> ComponentName componentName = - foldComponent getLibName + foldComponent (libraryComponentName . libName) (CFLibName . foreignLibName) (CExeName . exeName) (CTestName . testName) (CBenchName . benchmarkName) - where - getLibName lib = case libName lib of - Nothing -> CLibName - Just n -> CSubLibName n partitionComponents :: [Component] diff --git a/cabal/Cabal/Distribution/Types/ComponentId.hs b/cabal/Cabal/Distribution/Types/ComponentId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/ComponentId.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Distribution.Types.ComponentId + ( ComponentId, unComponentId, mkComponentId + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText + +import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P +import Distribution.Text +import Distribution.Pretty +import Distribution.Parsec.Class + +import Text.PrettyPrint (text) + +-- | A 'ComponentId' uniquely identifies the transitive source +-- code closure of a component (i.e. libraries, executables). +-- +-- For non-Backpack components, this corresponds one to one with +-- the 'UnitId', which serves as the basis for install paths, +-- linker symbols, etc. +-- +-- Use 'mkComponentId' and 'unComponentId' to convert from/to a +-- 'String'. +-- +-- This type is opaque since @Cabal-2.0@ +-- +-- @since 2.0.0.2 +newtype ComponentId = ComponentId ShortText + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +-- | Construct a 'ComponentId' from a 'String' +-- +-- 'mkComponentId' is the inverse to 'unComponentId' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'ComponentId' is valid +-- +-- @since 2.0.0.2 +mkComponentId :: String -> ComponentId +mkComponentId = ComponentId . toShortText + +-- | Convert 'ComponentId' to 'String' +-- +-- @since 2.0.0.2 +unComponentId :: ComponentId -> String +unComponentId (ComponentId s) = fromShortText s + +-- | 'mkComponentId' +-- +-- @since 2.0.0.2 +instance IsString ComponentId where + fromString = mkComponentId + +instance Binary ComponentId + +instance Pretty ComponentId where + pretty = text . unComponentId + +instance Parsec ComponentId where + parsec = mkComponentId `fmap` P.munch1 abi_char + where abi_char c = isAlphaNum c || c `elem` "-_." + +instance Text ComponentId where + parse = mkComponentId `fmap` Parse.munch1 abi_char + where abi_char c = isAlphaNum c || c `elem` "-_." + +instance NFData ComponentId where + rnf = rnf . unComponentId diff --git a/cabal/Cabal/Distribution/Types/ComponentInclude.hs b/cabal/Cabal/Distribution/Types/ComponentInclude.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/ComponentInclude.hs @@ -0,0 +1,32 @@ +module Distribution.Types.ComponentInclude ( + ComponentInclude(..), + ci_id, + ci_pkgid, + ci_cname +) where + +import Distribution.Types.PackageId +import Distribution.Types.ComponentName +import Distribution.Types.AnnotatedId + +-- Once ci_id is refined to an 'OpenUnitId' or 'DefUnitId', +-- the 'includeRequiresRn' is not so useful (because it +-- includes the requirements renaming that is no longer +-- needed); use 'ci_prov_renaming' instead. +data ComponentInclude id rn = ComponentInclude { + ci_ann_id :: AnnotatedId id, + ci_renaming :: rn, + -- | Did this come from an entry in @mixins@, or + -- was implicitly generated by @build-depends@? + ci_implicit :: Bool + } + +ci_id :: ComponentInclude id rn -> id +ci_id = ann_id . ci_ann_id + +ci_pkgid :: ComponentInclude id rn -> PackageId +ci_pkgid = ann_pid . ci_ann_id + +-- | This should always return 'CLibName' or 'CSubLibName' +ci_cname :: ComponentInclude id rn -> ComponentName +ci_cname = ann_cname . ci_ann_id diff --git a/cabal/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs b/cabal/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs --- a/cabal/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs +++ b/cabal/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs @@ -4,6 +4,7 @@ module Distribution.Types.ComponentLocalBuildInfo ( ComponentLocalBuildInfo(..), componentIsIndefinite, + maybeComponentInstantiatedWith, ) where import Prelude () @@ -12,11 +13,14 @@ import Distribution.Backpack import Distribution.Compat.Graph +import Distribution.Types.ComponentId +import Distribution.Types.MungedPackageId +import Distribution.Types.UnitId import Distribution.Types.ComponentName +import Distribution.Types.MungedPackageName import Distribution.PackageDescription import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Package -- | The first five fields are common across all algebraic variants. data ComponentLocalBuildInfo @@ -41,7 +45,7 @@ -- The 'BuildInfo' specifies a set of build dependencies that must be -- satisfied in terms of version ranges. This field fixes those dependencies -- to the specific versions available on this machine for this compiler. - componentPackageDeps :: [(UnitId, PackageId)], + componentPackageDeps :: [(UnitId, MungedPackageId)], -- | The set of packages that are brought into scope during -- compilation, including a 'ModuleRenaming' which may used -- to hide or rename modules. This is what gets translated into @@ -57,8 +61,8 @@ componentInternalDeps :: [UnitId], -- | Compatibility "package key" that we pass to older versions of GHC. componentCompatPackageKey :: String, - -- | Compatability "package name" that we register this component as. - componentCompatPackageName :: PackageName, + -- | Compatibility "package name" that we register this component as. + componentCompatPackageName :: MungedPackageName, -- | A list of exposed modules (either defined in this component, -- or reexported from another component.) componentExposedModules :: [Installed.ExposedModule], @@ -71,7 +75,7 @@ componentLocalName :: ComponentName, componentComponentId :: ComponentId, componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, PackageId)], + componentPackageDeps :: [(UnitId, MungedPackageId)], componentIncludes :: [(OpenUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] @@ -80,7 +84,7 @@ componentLocalName :: ComponentName, componentComponentId :: ComponentId, componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, PackageId)], + componentPackageDeps :: [(UnitId, MungedPackageId)], componentIncludes :: [(OpenUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] @@ -89,7 +93,7 @@ componentLocalName :: ComponentName, componentComponentId :: ComponentId, componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, PackageId)], + componentPackageDeps :: [(UnitId, MungedPackageId)], componentIncludes :: [(OpenUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] @@ -99,7 +103,7 @@ componentLocalName :: ComponentName, componentComponentId :: ComponentId, componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, PackageId)], + componentPackageDeps :: [(UnitId, MungedPackageId)], componentIncludes :: [(OpenUnitId, ModuleRenaming)], componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] @@ -116,3 +120,8 @@ componentIsIndefinite :: ComponentLocalBuildInfo -> Bool componentIsIndefinite LibComponentLocalBuildInfo{ componentIsIndefinite_ = b } = b componentIsIndefinite _ = False + +maybeComponentInstantiatedWith :: ComponentLocalBuildInfo -> Maybe [(ModuleName, OpenModule)] +maybeComponentInstantiatedWith + LibComponentLocalBuildInfo { componentInstantiatedWith = insts } = Just insts +maybeComponentInstantiatedWith _ = Nothing diff --git a/cabal/Cabal/Distribution/Types/ComponentName.hs b/cabal/Cabal/Distribution/Types/ComponentName.hs --- a/cabal/Cabal/Distribution/Types/ComponentName.hs +++ b/cabal/Cabal/Distribution/Types/ComponentName.hs @@ -4,7 +4,9 @@ module Distribution.Types.ComponentName ( ComponentName(..), defaultLibName, + libraryComponentName, showComponentName, + componentNameStanza, componentNameString, ) where @@ -13,7 +15,8 @@ import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ((<++)) -import Distribution.Package +import Distribution.Types.UnqualComponentName +import Distribution.Pretty import Distribution.Text import Text.PrettyPrint as Disp @@ -30,14 +33,15 @@ instance Binary ComponentName -- Build-target-ish syntax -instance Text ComponentName where - disp CLibName = Disp.text "lib" - disp (CSubLibName str) = Disp.text "lib:" <<>> disp str - disp (CFLibName str) = Disp.text "flib:" <<>> disp str - disp (CExeName str) = Disp.text "exe:" <<>> disp str - disp (CTestName str) = Disp.text "test:" <<>> disp str - disp (CBenchName str) = Disp.text "bench:" <<>> disp str +instance Pretty ComponentName where + pretty CLibName = Disp.text "lib" + pretty (CSubLibName str) = Disp.text "lib:" <<>> pretty str + pretty (CFLibName str) = Disp.text "flib:" <<>> pretty str + pretty (CExeName str) = Disp.text "exe:" <<>> pretty str + pretty (CTestName str) = Disp.text "test:" <<>> pretty str + pretty (CBenchName str) = Disp.text "bench:" <<>> pretty str +instance Text ComponentName where parse = parseComposite <++ parseSingle where parseSingle = Parse.string "lib" >> return CLibName @@ -60,6 +64,14 @@ showComponentName (CTestName name) = "test suite '" ++ display name ++ "'" showComponentName (CBenchName name) = "benchmark '" ++ display name ++ "'" +componentNameStanza :: ComponentName -> String +componentNameStanza CLibName = "library" +componentNameStanza (CSubLibName name) = "library " ++ display name +componentNameStanza (CFLibName name) = "foreign-library " ++ display name +componentNameStanza (CExeName name) = "executable " ++ display name +componentNameStanza (CTestName name) = "test-suite " ++ display name +componentNameStanza (CBenchName name) = "benchmark " ++ display name + -- | This gets the underlying unqualified component name. In fact, it is -- guaranteed to uniquely identify a component, returning -- @Nothing@ if the 'ComponentName' was for the public @@ -71,3 +83,9 @@ componentNameString (CExeName n) = Just n componentNameString (CTestName n) = Just n componentNameString (CBenchName n) = Just n + +-- | Convert the 'UnqualComponentName' of a library into a +-- 'ComponentName'. +libraryComponentName :: Maybe UnqualComponentName -> ComponentName +libraryComponentName Nothing = CLibName +libraryComponentName (Just n) = CSubLibName n diff --git a/cabal/Cabal/Distribution/Types/ComponentRequestedSpec.hs b/cabal/Cabal/Distribution/Types/ComponentRequestedSpec.hs --- a/cabal/Cabal/Distribution/Types/ComponentRequestedSpec.hs +++ b/cabal/Cabal/Distribution/Types/ComponentRequestedSpec.hs @@ -60,7 +60,7 @@ -- See also this note in -- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". -- --- @since 2.0.0.0 +-- @since 2.0.0.2 data ComponentRequestedSpec = ComponentRequestedSpec { testsRequested :: Bool , benchmarksRequested :: Bool } @@ -71,27 +71,27 @@ -- | The default set of enabled components. Historically tests and -- benchmarks are NOT enabled by default. -- --- @since 2.0.0.0 +-- @since 2.0.0.2 defaultComponentRequestedSpec :: ComponentRequestedSpec defaultComponentRequestedSpec = ComponentRequestedSpec False False -- | Is this component enabled? See also this note in -- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". -- --- @since 2.0.0.0 +-- @since 2.0.0.2 componentEnabled :: ComponentRequestedSpec -> Component -> Bool componentEnabled enabled = isNothing . componentDisabledReason enabled -- | Is this component name enabled? See also this note in -- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". -- --- @since 2.0.0.0 +-- @since 2.0.0.2 componentNameRequested :: ComponentRequestedSpec -> ComponentName -> Bool componentNameRequested enabled = isNothing . componentNameNotRequestedReason enabled -- | Is this component disabled, and if so, why? -- --- @since 2.0.0.0 +-- @since 2.0.0.2 componentDisabledReason :: ComponentRequestedSpec -> Component -> Maybe ComponentDisabledReason componentDisabledReason enabled comp @@ -100,7 +100,7 @@ -- | Is this component name disabled, and if so, why? -- --- @since 2.0.0.0 +-- @since 2.0.0.2 componentNameNotRequestedReason :: ComponentRequestedSpec -> ComponentName -> Maybe ComponentDisabledReason componentNameNotRequestedReason @@ -116,7 +116,7 @@ -- | A reason explaining why a component is disabled. -- --- @since 2.0.0.0 +-- @since 2.0.0.2 data ComponentDisabledReason = DisabledComponent | DisabledAllTests | DisabledAllBenchmarks diff --git a/cabal/Cabal/Distribution/Types/CondTree.hs b/cabal/Cabal/Distribution/Types/CondTree.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/CondTree.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +module Distribution.Types.CondTree ( + CondTree(..), + CondBranch(..), + condIfThen, + condIfThenElse, + mapCondTree, + mapTreeConstrs, + mapTreeConds, + mapTreeData, + traverseCondTreeV, + traverseCondBranchV, + extractCondition, + simplifyCondTree, + ignoreConditions, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.Condition + +-- | A 'CondTree' is used to represent the conditional structure of +-- a Cabal file, reflecting a syntax element subject to constraints, +-- and then any number of sub-elements which may be enabled subject +-- to some condition. Both @a@ and @c@ are usually 'Monoid's. +-- +-- To be more concrete, consider the following fragment of a @Cabal@ +-- file: +-- +-- @ +-- build-depends: base >= 4.0 +-- if flag(extra) +-- build-depends: base >= 4.2 +-- @ +-- +-- One way to represent this is to have @'CondTree' 'ConfVar' +-- ['Dependency'] 'BuildInfo'@. Here, 'condTreeData' represents +-- the actual fields which are not behind any conditional, while +-- 'condTreeComponents' recursively records any further fields +-- which are behind a conditional. 'condTreeConstraints' records +-- the constraints (in this case, @base >= 4.0@) which would +-- be applied if you use this syntax; in general, this is +-- derived off of 'targetBuildInfo' (perhaps a good refactoring +-- would be to convert this into an opaque type, with a smart +-- constructor that pre-computes the dependencies.) +-- +data CondTree v c a = CondNode + { condTreeData :: a + , condTreeConstraints :: c + , condTreeComponents :: [CondBranch v c a] + } + deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable) + +instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a) + +-- | A 'CondBranch' represents a conditional branch, e.g., @if +-- flag(foo)@ on some syntax @a@. It also has an optional false +-- branch. +-- +data CondBranch v c a = CondBranch + { condBranchCondition :: Condition v + , condBranchIfTrue :: CondTree v c a + , condBranchIfFalse :: Maybe (CondTree v c a) + } + deriving (Show, Eq, Typeable, Data, Generic, Functor, Traversable) + +-- This instance is written by hand because GHC 8.0.1/8.0.2 infinite +-- loops when trying to derive it with optimizations. See +-- https://ghc.haskell.org/trac/ghc/ticket/13056 +instance Foldable (CondBranch v c) where + foldMap f (CondBranch _ c Nothing) = foldMap f c + foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a + +instance (Binary v, Binary c, Binary a) => Binary (CondBranch v c a) + +condIfThen :: Condition v -> CondTree v c a -> CondBranch v c a +condIfThen c t = CondBranch c t Nothing + +condIfThenElse :: Condition v -> CondTree v c a -> CondTree v c a -> CondBranch v c a +condIfThenElse c t e = CondBranch c t (Just e) + +mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) + -> CondTree v c a -> CondTree w d b +mapCondTree fa fc fcnd (CondNode a c ifs) = + CondNode (fa a) (fc c) (map g ifs) + where + g (CondBranch cnd t me) + = CondBranch (fcnd cnd) + (mapCondTree fa fc fcnd t) + (fmap (mapCondTree fa fc fcnd) me) + +mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a +mapTreeConstrs f = mapCondTree id f id + +mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a +mapTreeConds f = mapCondTree id id f + +mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b +mapTreeData f = mapCondTree f id id + +-- | @Traversal (CondTree v c a) (CondTree w c a) v w@ +traverseCondTreeV :: Applicative f => (v -> f w) -> CondTree v c a -> f (CondTree w c a) +traverseCondTreeV f (CondNode a c ifs) = + CondNode a c <$> traverse (traverseCondBranchV f) ifs + +-- | @Traversal (CondBranch v c a) (CondBranch w c a) v w@ +traverseCondBranchV :: Applicative f => (v -> f w) -> CondBranch v c a -> f (CondBranch w c a) +traverseCondBranchV f (CondBranch cnd t me) = CondBranch + <$> traverse f cnd + <*> traverseCondTreeV f t + <*> traverse (traverseCondTreeV f) me + +-- | Extract the condition matched by the given predicate from a cond tree. +-- +-- We use this mainly for extracting buildable conditions (see the Note above), +-- but the function is in fact more general. +extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v +extractCondition p = go + where + go (CondNode x _ cs) | not (p x) = Lit False + | otherwise = goList cs + + goList [] = Lit True + goList (CondBranch c t e : cs) = + let + ct = go t + ce = maybe (Lit True) go e + in + ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs + +-- | Flattens a CondTree using a partial flag assignment. When a condition +-- cannot be evaluated, both branches are ignored. +simplifyCondTree :: (Monoid a, Monoid d) => + (v -> Either v Bool) + -> CondTree v d a + -> (d, a) +simplifyCondTree env (CondNode a d ifs) = + mconcat $ (d, a) : mapMaybe simplifyIf ifs + where + simplifyIf (CondBranch cnd t me) = + case simplifyCondition cnd env of + (Lit True, _) -> Just $ simplifyCondTree env t + (Lit False, _) -> fmap (simplifyCondTree env) me + _ -> Nothing + +-- | Flatten a CondTree. This will resolve the CondTree by taking all +-- possible paths into account. Note that since branches represent exclusive +-- choices this may not result in a \"sane\" result. +ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c) +ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs) + where f (CondBranch _ t me) = ignoreConditions t + : maybeToList (fmap ignoreConditions me) diff --git a/cabal/Cabal/Distribution/Types/Condition.hs b/cabal/Cabal/Distribution/Types/Condition.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/Condition.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.Condition ( + Condition(..), + cNot, + cAnd, + cOr, + simplifyCondition, +) where + +import Prelude () +import Distribution.Compat.Prelude + +-- | A boolean expression parameterized over the variable type used. +data Condition c = Var c + | Lit Bool + | CNot (Condition c) + | COr (Condition c) (Condition c) + | CAnd (Condition c) (Condition c) + deriving (Show, Eq, Typeable, Data, Generic) + +-- | Boolean negation of a 'Condition' value. +cNot :: Condition a -> Condition a +cNot (Lit b) = Lit (not b) +cNot (CNot c) = c +cNot c = CNot c + +-- | Boolean AND of two 'Condtion' values. +cAnd :: Condition a -> Condition a -> Condition a +cAnd (Lit False) _ = Lit False +cAnd _ (Lit False) = Lit False +cAnd (Lit True) x = x +cAnd x (Lit True) = x +cAnd x y = CAnd x y + +-- | Boolean OR of two 'Condition' values. +cOr :: Eq v => Condition v -> Condition v -> Condition v +cOr (Lit True) _ = Lit True +cOr _ (Lit True) = Lit True +cOr (Lit False) x = x +cOr x (Lit False) = x +cOr c (CNot d) + | c == d = Lit True +cOr (CNot c) d + | c == d = Lit True +cOr x y = COr x y + +instance Functor Condition where + f `fmap` Var c = Var (f c) + _ `fmap` Lit c = Lit c + f `fmap` CNot c = CNot (fmap f c) + f `fmap` COr c d = COr (fmap f c) (fmap f d) + f `fmap` CAnd c d = CAnd (fmap f c) (fmap f d) + +instance Foldable Condition where + f `foldMap` Var c = f c + _ `foldMap` Lit _ = mempty + f `foldMap` CNot c = foldMap f c + f `foldMap` COr c d = foldMap f c `mappend` foldMap f d + f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d + +instance Traversable Condition where + f `traverse` Var c = Var `fmap` f c + _ `traverse` Lit c = pure $ Lit c + f `traverse` CNot c = CNot `fmap` traverse f c + f `traverse` COr c d = COr `fmap` traverse f c <*> traverse f d + f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d + +instance Applicative Condition where + pure = Var + (<*>) = ap + +instance Monad Condition where + return = pure + -- Terminating cases + (>>=) (Lit x) _ = Lit x + (>>=) (Var x) f = f x + -- Recursing cases + (>>=) (CNot x ) f = CNot (x >>= f) + (>>=) (COr x y) f = COr (x >>= f) (y >>= f) + (>>=) (CAnd x y) f = CAnd (x >>= f) (y >>= f) + +instance Monoid (Condition a) where + mempty = Lit False + mappend = (<>) + +instance Semigroup (Condition a) where + (<>) = COr + +instance Alternative Condition where + empty = mempty + (<|>) = mappend + +instance MonadPlus Condition where + mzero = mempty + mplus = mappend + +instance Binary c => Binary (Condition c) + +-- | Simplify the condition and return its free variables. +simplifyCondition :: Condition c + -> (c -> Either d Bool) -- ^ (partial) variable assignment + -> (Condition d, [d]) +simplifyCondition cond i = fv . walk $ cond + where + walk cnd = case cnd of + Var v -> either Var Lit (i v) + Lit b -> Lit b + CNot c -> case walk c of + Lit True -> Lit False + Lit False -> Lit True + c' -> CNot c' + COr c d -> case (walk c, walk d) of + (Lit False, d') -> d' + (Lit True, _) -> Lit True + (c', Lit False) -> c' + (_, Lit True) -> Lit True + (c',d') -> COr c' d' + CAnd c d -> case (walk c, walk d) of + (Lit False, _) -> Lit False + (Lit True, d') -> d' + (_, Lit False) -> Lit False + (c', Lit True) -> c' + (c',d') -> CAnd c' d' + -- gather free vars + fv c = (c, fv' c) + fv' c = case c of + Var v -> [v] + Lit _ -> [] + CNot c' -> fv' c' + COr c1 c2 -> fv' c1 ++ fv' c2 + CAnd c1 c2 -> fv' c1 ++ fv' c2 diff --git a/cabal/Cabal/Distribution/Types/Dependency.hs b/cabal/Cabal/Distribution/Types/Dependency.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/Dependency.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.Dependency + ( Dependency(..) + , depPkgName + , depVerRange + , thisPackageVersion + , notThisPackageVersion + , simplifyDependency + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Version ( VersionRange, thisVersion + , notThisVersion, anyVersion + , simplifyVersionRange ) + +import qualified Distribution.Compat.ReadP as Parse + +import Distribution.Text +import Distribution.Pretty +import Distribution.Parsec.Class +import Distribution.Types.PackageId +import Distribution.Types.PackageName + +import Text.PrettyPrint ((<+>)) + +-- | Describes a dependency on a source package (API) +-- +data Dependency = Dependency PackageName VersionRange + deriving (Generic, Read, Show, Eq, Typeable, Data) + +depPkgName :: Dependency -> PackageName +depPkgName (Dependency pn _) = pn + +depVerRange :: Dependency -> VersionRange +depVerRange (Dependency _ vr) = vr + +instance Binary Dependency +instance NFData Dependency where rnf = genericRnf + +instance Pretty Dependency where + pretty (Dependency name ver) = pretty name <+> pretty ver + +instance Parsec Dependency where + parsec = do + name <- lexemeParsec + ver <- parsec <|> pure anyVersion + return (Dependency name ver) + +instance Text Dependency where + parse = do name <- parse + Parse.skipSpaces + ver <- parse Parse.<++ return anyVersion + Parse.skipSpaces + return (Dependency name ver) + +thisPackageVersion :: PackageIdentifier -> Dependency +thisPackageVersion (PackageIdentifier n v) = + Dependency n (thisVersion v) + +notThisPackageVersion :: PackageIdentifier -> Dependency +notThisPackageVersion (PackageIdentifier n v) = + Dependency n (notThisVersion v) + +-- | Simplify the 'VersionRange' expression in a 'Dependency'. +-- See 'simplifyVersionRange'. +-- +simplifyDependency :: Dependency -> Dependency +simplifyDependency (Dependency name range) = + Dependency name (simplifyVersionRange range) diff --git a/cabal/Cabal/Distribution/Types/DependencyMap.hs b/cabal/Cabal/Distribution/Types/DependencyMap.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/DependencyMap.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} + +#ifdef MIN_VERSION_containers +#if MIN_VERSION_containers(0,5,0) +#define MIN_VERSION_containers_0_5_0 +#endif +#endif + +#ifndef MIN_VERSION_containers +#if __GLASGOW_HASKELL__ >= 706 +#define MIN_VERSION_containers_0_5_0 +#endif +#endif + +module Distribution.Types.DependencyMap ( + DependencyMap, + toDepMap, + fromDepMap, + constrainBy, +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Types.Dependency +import Distribution.Types.PackageName +import Distribution.Version + +#ifdef MIN_VERSION_containers_0_5_0 +import qualified Data.Map.Lazy as Map +#else +import qualified Data.Map as Map +#endif + +-- | A map of dependencies. Newtyped since the default monoid instance is not +-- appropriate. The monoid instance uses 'intersectVersionRanges'. +newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange } + deriving (Show, Read) + +instance Monoid DependencyMap where + mempty = DependencyMap Map.empty + mappend = (<>) + +instance Semigroup DependencyMap where + (DependencyMap a) <> (DependencyMap b) = + DependencyMap (Map.unionWith intersectVersionRanges a b) + +toDepMap :: [Dependency] -> DependencyMap +toDepMap ds = + DependencyMap $ Map.fromListWith intersectVersionRanges [ (p,vr) | Dependency p vr <- ds ] + +fromDepMap :: DependencyMap -> [Dependency] +fromDepMap m = [ Dependency p vr | (p,vr) <- Map.toList (unDependencyMap m) ] + +-- Apply extra constraints to a dependency map. +-- Combines dependencies where the result will only contain keys from the left +-- (first) map. If a key also exists in the right map, both constraints will +-- be intersected. +constrainBy :: DependencyMap -- ^ Input map + -> DependencyMap -- ^ Extra constraints + -> DependencyMap +constrainBy left extra = + DependencyMap $ +#ifdef MIN_VERSION_containers_0_5_0 + Map.foldrWithKey tightenConstraint (unDependencyMap left) + (unDependencyMap extra) +#else + Map.foldWithKey tightenConstraint (unDependencyMap left) + (unDependencyMap extra) +#endif + where tightenConstraint n c l = + case Map.lookup n l of + Nothing -> l + Just vr -> Map.insert n (intersectVersionRanges vr c) l diff --git a/cabal/Cabal/Distribution/Types/ExeDependency.hs b/cabal/Cabal/Distribution/Types/ExeDependency.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/ExeDependency.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.ExeDependency + ( ExeDependency(..) + , qualifiedExeName + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec.Class +import Distribution.Pretty +import Distribution.Text +import Distribution.Types.ComponentName +import Distribution.Types.PackageName +import Distribution.Types.UnqualComponentName +import Distribution.Version (VersionRange, anyVersion) + +import qualified Distribution.Compat.Parsec as P +import Distribution.Compat.ReadP ((<++)) +import qualified Distribution.Compat.ReadP as Parse +import Text.PrettyPrint (text, (<+>)) + +-- | Describes a dependency on an executable from a package +-- +data ExeDependency = ExeDependency + PackageName + UnqualComponentName -- name of executable component of package + VersionRange + deriving (Generic, Read, Show, Eq, Typeable, Data) + +instance Binary ExeDependency +instance NFData ExeDependency where rnf = genericRnf + +instance Pretty ExeDependency where + pretty (ExeDependency name exe ver) = + (pretty name <<>> text ":" <<>> pretty exe) <+> pretty ver + +instance Parsec ExeDependency where + parsec = do + name <- lexemeParsec + _ <- P.char ':' + exe <- lexemeParsec + ver <- parsec <|> pure anyVersion + return (ExeDependency name exe ver) + +instance Text ExeDependency where + parse = do name <- parse + _ <- Parse.char ':' + exe <- parse + Parse.skipSpaces + ver <- parse <++ return anyVersion + Parse.skipSpaces + return (ExeDependency name exe ver) + +qualifiedExeName :: ExeDependency -> ComponentName +qualifiedExeName (ExeDependency _ ucn _) = CExeName ucn diff --git a/cabal/Cabal/Distribution/Types/Executable.hs b/cabal/Cabal/Distribution/Types/Executable.hs --- a/cabal/Cabal/Distribution/Types/Executable.hs +++ b/cabal/Cabal/Distribution/Types/Executable.hs @@ -13,16 +13,23 @@ import Distribution.Compat.Prelude import Distribution.Types.BuildInfo +import Distribution.Types.UnqualComponentName +import Distribution.Types.ExecutableScope import Distribution.ModuleName -import Distribution.Package +import qualified Distribution.Types.BuildInfo.Lens as L + data Executable = Executable { exeName :: UnqualComponentName, modulePath :: FilePath, + exeScope :: ExecutableScope, buildInfo :: BuildInfo } deriving (Generic, Show, Read, Eq, Typeable, Data) +instance L.HasBuildInfo Executable where + buildInfo f l = (\x -> l { buildInfo = x }) <$> f (buildInfo l) + instance Binary Executable instance Monoid Executable where @@ -33,6 +40,7 @@ a <> b = Executable{ exeName = combine' exeName, modulePath = combine modulePath, + exeScope = combine exeScope, buildInfo = combine buildInfo } where combine field = field a `mappend` field b diff --git a/cabal/Cabal/Distribution/Types/Executable/Lens.hs b/cabal/Cabal/Distribution/Types/Executable/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/Executable/Lens.hs @@ -0,0 +1,32 @@ +module Distribution.Types.Executable.Lens ( + Executable, + module Distribution.Types.Executable.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.Executable (Executable) +import Distribution.Types.ExecutableScope (ExecutableScope) +import Distribution.Types.UnqualComponentName (UnqualComponentName) + +import qualified Distribution.Types.Executable as T + +exeName :: Lens' Executable UnqualComponentName +exeName f s = fmap (\x -> s { T.exeName = x }) (f (T.exeName s)) +{-# INLINE exeName #-} + +modulePath :: Lens' Executable String +modulePath f s = fmap (\x -> s { T.modulePath = x }) (f (T.modulePath s)) +{-# INLINE modulePath #-} + +exeScope :: Lens' Executable ExecutableScope +exeScope f s = fmap (\x -> s { T.exeScope = x }) (f (T.exeScope s)) +{-# INLINE exeScope #-} + +{- +buildInfo :: Lens' Executable BuildInfo +buildInfo f s = fmap (\x -> s { T.buildInfo = x }) (f (T.buildInfo s)) +{-# INLINE buildInfo #-} +-} diff --git a/cabal/Cabal/Distribution/Types/ExecutableScope.hs b/cabal/Cabal/Distribution/Types/ExecutableScope.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/ExecutableScope.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.ExecutableScope ( + ExecutableScope(..), +) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Pretty +import Distribution.Parsec.Class +import Distribution.Text + +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp + +data ExecutableScope = ExecutableScopeUnknown + | ExecutablePublic + | ExecutablePrivate + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Pretty ExecutableScope where + pretty ExecutablePublic = Disp.text "public" + pretty ExecutablePrivate = Disp.text "private" + pretty ExecutableScopeUnknown = Disp.text "unknown" + +instance Parsec ExecutableScope where + parsec = do + name <- P.munch1 (\c -> isAlphaNum c || c == '-') + return $ case name of + "public" -> ExecutablePublic + "private" -> ExecutablePrivate + _ -> ExecutableScopeUnknown + +instance Text ExecutableScope where + parse = Parse.choice + [ Parse.string "public" >> return ExecutablePublic + , Parse.string "private" >> return ExecutablePrivate + ] + +instance Binary ExecutableScope + +instance Monoid ExecutableScope where + mempty = ExecutableScopeUnknown + mappend = (<>) + +instance Semigroup ExecutableScope where + ExecutableScopeUnknown <> x = x + x <> ExecutableScopeUnknown = x + x <> y | x == y = x + | otherwise = error "Ambiguous executable scope" diff --git a/cabal/Cabal/Distribution/Types/ForeignLib.hs b/cabal/Cabal/Distribution/Types/ForeignLib.hs --- a/cabal/Cabal/Distribution/Types/ForeignLib.hs +++ b/cabal/Cabal/Distribution/Types/ForeignLib.hs @@ -1,24 +1,43 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoMonoLocalBinds #-} module Distribution.Types.ForeignLib( ForeignLib(..), emptyForeignLib, foreignLibModules, foreignLibIsShared, + foreignLibVersion, + + LibVersionInfo, + mkLibVersionInfo, + libVersionInfoCRA, + libVersionNumber, + libVersionNumberShow, + libVersionMajor ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Package import Distribution.ModuleName - +import Distribution.Parsec.Class +import Distribution.Pretty +import Distribution.System +import Distribution.Text import Distribution.Types.BuildInfo -import Distribution.Types.ForeignLibType import Distribution.Types.ForeignLibOption +import Distribution.Types.ForeignLibType +import Distribution.Types.UnqualComponentName +import Distribution.Version +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import qualified Text.Read as Read + +import qualified Distribution.Types.BuildInfo.Lens as L + -- | A foreign library stanza is like a library stanza, except that -- the built code is intended for consumption by a non-Haskell client. data ForeignLib = ForeignLib { @@ -31,6 +50,12 @@ , foreignLibOptions :: [ForeignLibOption] -- | Build information for this foreign library. , foreignLibBuildInfo :: BuildInfo + -- | Libtool-style version-info data to compute library version. + -- Refer to the libtool documentation on the + -- current:revision:age versioning scheme. + , foreignLibVersionInfo :: Maybe LibVersionInfo + -- | Linux library version + , foreignLibVersionLinux :: Maybe Version -- | (Windows-specific) module definition files -- @@ -40,15 +65,99 @@ } deriving (Generic, Show, Read, Eq, Typeable, Data) +data LibVersionInfo = LibVersionInfo Int Int Int deriving (Data, Eq, Generic, Typeable) + +instance Ord LibVersionInfo where + LibVersionInfo c r _ `compare` LibVersionInfo c' r' _ = + case c `compare` c' of + EQ -> r `compare` r' + e -> e + +instance Show LibVersionInfo where + showsPrec d (LibVersionInfo c r a) = showParen (d > 10) + $ showString "mkLibVersionInfo " + . showsPrec 11 (c,r,a) + +instance Read LibVersionInfo where + readPrec = Read.parens $ do + Read.Ident "mkLibVersionInfo" <- Read.lexP + t <- Read.step Read.readPrec + return (mkLibVersionInfo t) + +instance Binary LibVersionInfo + +instance Pretty LibVersionInfo where + pretty (LibVersionInfo c r a) + = Disp.hcat $ Disp.punctuate (Disp.char ':') $ map Disp.int [c,r,a] + +instance Parsec LibVersionInfo where + parsec = do + c <- P.integral + (r, a) <- P.option (0,0) $ do + _ <- P.char ':' + r <- P.integral + a <- P.option 0 $ do + _ <- P.char ':' + P.integral + return (r,a) + return $ mkLibVersionInfo (c,r,a) + +instance Text LibVersionInfo where + parse = do + c <- parseNat + (r, a) <- Parse.option (0,0) $ do + _ <- Parse.char ':' + r <- parseNat + a <- Parse.option 0 (Parse.char ':' >> parseNat) + return (r, a) + return $ mkLibVersionInfo (c,r,a) + where + parseNat = read `fmap` Parse.munch1 isDigit + +-- | Construct 'LibVersionInfo' from @(current, revision, age)@ +-- numbers. +-- +-- For instance, @mkLibVersionInfo (3,0,0)@ constructs a +-- 'LibVersionInfo' representing the version-info @3:0:0@. +-- +-- All version components must be non-negative. +mkLibVersionInfo :: (Int, Int, Int) -> LibVersionInfo +mkLibVersionInfo (c,r,a) = LibVersionInfo c r a + +-- | From a given 'LibVersionInfo', extract the @(current, revision, +-- age)@ numbers. +libVersionInfoCRA :: LibVersionInfo -> (Int, Int, Int) +libVersionInfoCRA (LibVersionInfo c r a) = (c,r,a) + +-- | Given a version-info field, produce a @major.minor.build@ version +libVersionNumber :: LibVersionInfo -> (Int, Int, Int) +libVersionNumber (LibVersionInfo c r a) = (c-a , a , r) + +-- | Given a version-info field, return @"major.minor.build"@ as a +-- 'String' +libVersionNumberShow :: LibVersionInfo -> String +libVersionNumberShow v = + let (major, minor, build) = libVersionNumber v + in show major ++ "." ++ show minor ++ "." ++ show build + +-- | Return the @major@ version of a version-info field. +libVersionMajor :: LibVersionInfo -> Int +libVersionMajor (LibVersionInfo c _ a) = c-a + +instance L.HasBuildInfo ForeignLib where + buildInfo f l = (\x -> l { foreignLibBuildInfo = x }) <$> f (foreignLibBuildInfo l) + instance Binary ForeignLib instance Semigroup ForeignLib where a <> b = ForeignLib { - foreignLibName = combine' foreignLibName - , foreignLibType = combine foreignLibType - , foreignLibOptions = combine foreignLibOptions - , foreignLibBuildInfo = combine foreignLibBuildInfo - , foreignLibModDefFile = combine foreignLibModDefFile + foreignLibName = combine' foreignLibName + , foreignLibType = combine foreignLibType + , foreignLibOptions = combine foreignLibOptions + , foreignLibBuildInfo = combine foreignLibBuildInfo + , foreignLibVersionInfo = combine'' foreignLibVersionInfo + , foreignLibVersionLinux = combine'' foreignLibVersionLinux + , foreignLibModDefFile = combine foreignLibModDefFile } where combine field = field a `mappend` field b combine' field = case ( unUnqualComponentName $ field a @@ -57,14 +166,17 @@ (_, "") -> field a (x, y) -> error $ "Ambiguous values for executable field: '" ++ x ++ "' and '" ++ y ++ "'" + combine'' field = field b instance Monoid ForeignLib where mempty = ForeignLib { - foreignLibName = mempty - , foreignLibType = ForeignLibTypeUnknown - , foreignLibOptions = [] - , foreignLibBuildInfo = mempty - , foreignLibModDefFile = [] + foreignLibName = mempty + , foreignLibType = ForeignLibTypeUnknown + , foreignLibOptions = [] + , foreignLibBuildInfo = mempty + , foreignLibVersionInfo = Nothing + , foreignLibVersionLinux = Nothing + , foreignLibModDefFile = [] } mappend = (<>) @@ -79,3 +191,20 @@ -- | Is the foreign library shared? foreignLibIsShared :: ForeignLib -> Bool foreignLibIsShared = foreignLibTypeIsShared . foreignLibType + +-- | Get a version number for a foreign library. +-- If we're on Linux, and a Linux version is specified, use that. +-- If we're on Linux, and libtool-style version-info is specified, translate +-- that field into appropriate version numbers. +-- Otherwise, this feature is unsupported so we don't return any version data. +foreignLibVersion :: ForeignLib -> OS -> [Int] +foreignLibVersion flib Linux = + case foreignLibVersionLinux flib of + Just v -> versionNumbers v + Nothing -> + case foreignLibVersionInfo flib of + Just v' -> + let (major, minor, build) = libVersionNumber v' + in [major, minor, build] + Nothing -> [] +foreignLibVersion _ _ = [] diff --git a/cabal/Cabal/Distribution/Types/ForeignLib/Lens.hs b/cabal/Cabal/Distribution/Types/ForeignLib/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/ForeignLib/Lens.hs @@ -0,0 +1,45 @@ +module Distribution.Types.ForeignLib.Lens ( + ForeignLib, + module Distribution.Types.ForeignLib.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.ForeignLib (ForeignLib, LibVersionInfo) +import Distribution.Types.ForeignLibOption (ForeignLibOption) +import Distribution.Types.ForeignLibType (ForeignLibType) +import Distribution.Types.UnqualComponentName (UnqualComponentName) +import Distribution.Version (Version) + +import qualified Distribution.Types.ForeignLib as T + +foreignLibName :: Lens' ForeignLib UnqualComponentName +foreignLibName f s = fmap (\x -> s { T.foreignLibName = x }) (f (T.foreignLibName s)) +{-# INLINE foreignLibName #-} + +foreignLibType :: Lens' ForeignLib ForeignLibType +foreignLibType f s = fmap (\x -> s { T.foreignLibType = x }) (f (T.foreignLibType s)) +{-# INLINE foreignLibType #-} + +foreignLibOptions :: Lens' ForeignLib [ForeignLibOption] +foreignLibOptions f s = fmap (\x -> s { T.foreignLibOptions = x }) (f (T.foreignLibOptions s)) +{-# INLINE foreignLibOptions #-} + +foreignLibBuildInfo :: Lens' ForeignLib BuildInfo +foreignLibBuildInfo f s = fmap (\x -> s { T.foreignLibBuildInfo = x }) (f (T.foreignLibBuildInfo s)) +{-# INLINE foreignLibBuildInfo #-} + +foreignLibVersionInfo :: Lens' ForeignLib (Maybe LibVersionInfo) +foreignLibVersionInfo f s = fmap (\x -> s { T.foreignLibVersionInfo = x }) (f (T.foreignLibVersionInfo s)) +{-# INLINE foreignLibVersionInfo #-} + +foreignLibVersionLinux :: Lens' ForeignLib (Maybe Version) +foreignLibVersionLinux f s = fmap (\x -> s { T.foreignLibVersionLinux = x }) (f (T.foreignLibVersionLinux s)) +{-# INLINE foreignLibVersionLinux #-} + +foreignLibModDefFile :: Lens' ForeignLib [FilePath] +foreignLibModDefFile f s = fmap (\x -> s { T.foreignLibModDefFile = x }) (f (T.foreignLibModDefFile s)) +{-# INLINE foreignLibModDefFile #-} diff --git a/cabal/Cabal/Distribution/Types/ForeignLibOption.hs b/cabal/Cabal/Distribution/Types/ForeignLibOption.hs --- a/cabal/Cabal/Distribution/Types/ForeignLibOption.hs +++ b/cabal/Cabal/Distribution/Types/ForeignLibOption.hs @@ -8,10 +8,14 @@ import Prelude () import Distribution.Compat.Prelude -import Text.PrettyPrint -import qualified Distribution.Compat.ReadP as Parse +import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp + data ForeignLibOption = -- | Merge in all dependent libraries (i.e., use -- @ghc -shared -static@ rather than just record @@ -21,12 +25,19 @@ ForeignLibStandalone deriving (Generic, Show, Read, Eq, Typeable, Data) -instance Text ForeignLibOption where - disp ForeignLibStandalone = text "standalone" +instance Pretty ForeignLibOption where + pretty ForeignLibStandalone = Disp.text "standalone" +instance Parsec ForeignLibOption where + parsec = do + name <- P.munch1 (\c -> isAlphaNum c || c == '-') + case name of + "standalone" -> return ForeignLibStandalone + _ -> fail "unrecognized foreign-library option" + +instance Text ForeignLibOption where parse = Parse.choice [ do _ <- Parse.string "standalone" ; return ForeignLibStandalone ] instance Binary ForeignLibOption - diff --git a/cabal/Cabal/Distribution/Types/ForeignLibType.hs b/cabal/Cabal/Distribution/Types/ForeignLibType.hs --- a/cabal/Cabal/Distribution/Types/ForeignLibType.hs +++ b/cabal/Cabal/Distribution/Types/ForeignLibType.hs @@ -9,11 +9,15 @@ import Prelude () import Distribution.Compat.Prelude +import Distribution.PackageDescription.Utils -import Text.PrettyPrint hiding ((<>)) +import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text + +import qualified Distribution.Compat.Parsec as P import qualified Distribution.Compat.ReadP as Parse -import Distribution.PackageDescription.Utils +import qualified Text.PrettyPrint as Disp -- | What kind of foreign library is to be built? data ForeignLibType = @@ -26,11 +30,20 @@ | ForeignLibTypeUnknown deriving (Generic, Show, Read, Eq, Typeable, Data) -instance Text ForeignLibType where - disp ForeignLibNativeShared = text "native-shared" - disp ForeignLibNativeStatic = text "native-static" - disp ForeignLibTypeUnknown = text "unknown" +instance Pretty ForeignLibType where + pretty ForeignLibNativeShared = Disp.text "native-shared" + pretty ForeignLibNativeStatic = Disp.text "native-static" + pretty ForeignLibTypeUnknown = Disp.text "unknown" +instance Parsec ForeignLibType where + parsec = do + name <- P.munch1 (\c -> isAlphaNum c || c == '-') + return $ case name of + "native-shared" -> ForeignLibNativeShared + "native-static" -> ForeignLibNativeStatic + _ -> ForeignLibTypeUnknown + +instance Text ForeignLibType where parse = Parse.choice [ do _ <- Parse.string "native-shared" ; return ForeignLibNativeShared , do _ <- Parse.string "native-static" ; return ForeignLibNativeStatic 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 @@ -1,8 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Distribution.Types.GenericPackageDescription ( GenericPackageDescription(..), @@ -12,30 +11,47 @@ mkFlagName, unFlagName, FlagAssignment, + mkFlagAssignment, + unFlagAssignment, + lookupFlagAssignment, + insertFlagAssignment, + diffFlagAssignment, + nullFlagAssignment, + showFlagValue, + dispFlagAssignment, + parseFlagAssignment, + parsecFlagAssignment, ConfVar(..), - Condition(..), - CondTree(..), - cOr, - cAnd, - cNot, ) where import Prelude () +import Data.List ((\\)) import Distribution.Compat.Prelude import Distribution.Utils.ShortText +import Distribution.Utils.Generic (lowercase) +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P +import Distribution.Compat.ReadP ((+++)) import Distribution.Types.PackageDescription +import Distribution.Types.Dependency import Distribution.Types.Library import Distribution.Types.ForeignLib import Distribution.Types.Executable 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.Class +import Distribution.Pretty +import Distribution.Text -- --------------------------------------------------------------------------- -- The GenericPackageDescription type @@ -85,7 +101,7 @@ -- -- This type is opaque since @Cabal-2.0@ -- --- @since 2.0 +-- @since 2.0.0.2 newtype FlagName = FlagName ShortText deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) @@ -96,127 +112,158 @@ -- Note: No validations are performed to ensure that the resulting -- 'FlagName' is valid -- --- @since 2.0 +-- @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 +-- @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 + parsec = mkFlagName . lowercase <$> parsec' + where + parsec' = (:) <$> lead <*> rest + lead = P.satisfy (\c -> isAlphaNum c || c == '_') + rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') + +instance Text FlagName where + -- Note: we don't check that FlagName doesn't have leading dash, + -- cabal check will do that. + parse = mkFlagName . lowercase <$> parse' + where + parse' = (:) <$> lead <*> rest + lead = Parse.satisfy (\c -> isAlphaNum c || c == '_') + rest = Parse.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)]@ -- -type FlagAssignment = [(FlagName, Bool)] - --- | 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 - --- | A boolean expression parameterized over the variable type used. -data Condition c = Var c - | Lit Bool - | CNot (Condition c) - | COr (Condition c) (Condition c) - | CAnd (Condition c) (Condition c) - deriving (Show, Eq, Typeable, Data, Generic) +newtype FlagAssignment = FlagAssignment [(FlagName, Bool)] + deriving (Binary,Eq,Ord,Semigroup,Monoid) --- | Boolean negation of a 'Condition' value. -cNot :: Condition a -> Condition a -cNot (Lit b) = Lit (not b) -cNot (CNot c) = c -cNot c = CNot c +-- TODO: the Semigroup/Monoid/Ord/Eq instances would benefit from +-- [(FlagName,Bool)] being in a normal form, i.e. sorted. We could +-- e.g. switch to a `Data.Map.Map` representation, but see duplicates +-- check in `configuredPackageProblems`. +-- +-- Also, the 'Semigroup' instance currently is left-biased as entries +-- in the left-hand 'FlagAssignment' shadow those occuring in the +-- right-hand side 'FlagAssignment' for the same flagnames. --- | Boolean AND of two 'Condtion' values. -cAnd :: Condition a -> Condition a -> Condition a -cAnd (Lit False) _ = Lit False -cAnd _ (Lit False) = Lit False -cAnd (Lit True) x = x -cAnd x (Lit True) = x -cAnd x y = CAnd x y +-- | Construct a 'FlagAssignment' from a list of flag/value pairs. +-- +-- @since 2.2.0 +mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment +mkFlagAssignment = FlagAssignment --- | Boolean OR of two 'Condition' values. -cOr :: Eq v => Condition v -> Condition v -> Condition v -cOr (Lit True) _ = Lit True -cOr _ (Lit True) = Lit True -cOr (Lit False) x = x -cOr x (Lit False) = x -cOr c (CNot d) - | c == d = Lit True -cOr (CNot c) d - | c == d = Lit True -cOr x y = COr x y +-- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs. +-- +-- @ ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @ +-- +-- @since 2.2.0 +unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)] +unFlagAssignment (FlagAssignment xs) = xs -instance Functor Condition where - f `fmap` Var c = Var (f c) - _ `fmap` Lit c = Lit c - f `fmap` CNot c = CNot (fmap f c) - f `fmap` COr c d = COr (fmap f c) (fmap f d) - f `fmap` CAnd c d = CAnd (fmap f c) (fmap f d) +-- | Test whether 'FlagAssignment' is empty. +-- +-- @since 2.2.0 +nullFlagAssignment :: FlagAssignment -> Bool +nullFlagAssignment (FlagAssignment []) = True +nullFlagAssignment _ = False -instance Foldable Condition where - f `foldMap` Var c = f c - _ `foldMap` Lit _ = mempty - f `foldMap` CNot c = foldMap f c - f `foldMap` COr c d = foldMap f c `mappend` foldMap f d - f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d +-- | 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 = lookup fn . unFlagAssignment -instance Traversable Condition where - f `traverse` Var c = Var `fmap` f c - _ `traverse` Lit c = pure $ Lit c - f `traverse` CNot c = CNot `fmap` traverse f c - f `traverse` COr c d = COr `fmap` traverse f c <*> traverse f d - f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d +-- | Insert or update the boolean value of a flag. +-- +-- @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 lateron via +-- `D.C.Dependency.configuredPackageProblems` +insertFlagAssignment flag val = mkFlagAssignment . ((flag,val):) . unFlagAssignment -instance Applicative Condition where - pure = Var - (<*>) = ap +-- | 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 = mkFlagAssignment (unFlagAssignment fa1 \\ unFlagAssignment fa2) -instance Monad Condition where - return = pure - -- Terminating cases - (>>=) (Lit x) _ = Lit x - (>>=) (Var x) f = f x - -- Recursing cases - (>>=) (CNot x ) f = CNot (x >>= f) - (>>=) (COr x y) f = COr (x >>= f) (y >>= f) - (>>=) (CAnd x y) f = CAnd (x >>= f) (y >>= f) +-- | @since 2.2.0 +instance Read FlagAssignment where + readsPrec p s = [ (FlagAssignment x, rest) | (x,rest) <- readsPrec p s ] -instance Monoid (Condition a) where - mempty = Lit False - mappend = (<>) +-- | @since 2.2.0 +instance Show FlagAssignment where + showsPrec p (FlagAssignment xs) = showsPrec p xs -instance Semigroup (Condition a) where - (<>) = COr +-- | String representation of a flag-value pair. +showFlagValue :: (FlagName, Bool) -> String +showFlagValue (f, True) = '+' : unFlagName f +showFlagValue (f, False) = '-' : unFlagName f -instance Alternative Condition where - empty = mempty - (<|>) = mappend +-- | Pretty-prints a flag assignment. +dispFlagAssignment :: FlagAssignment -> Disp.Doc +dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment -instance MonadPlus Condition where - mzero = mempty - mplus = mappend +-- | Parses a flag assignment. +parsecFlagAssignment :: ParsecParser FlagAssignment +parsecFlagAssignment = FlagAssignment <$> 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) -instance Binary c => Binary (Condition c) +-- | Parses a flag assignment. +parseFlagAssignment :: Parse.ReadP r FlagAssignment +parseFlagAssignment = FlagAssignment <$> Parse.sepBy parseFlagValue Parse.skipSpaces1 + where + parseFlagValue = + (do Parse.optional (Parse.char '+') + f <- parse + return (f, True)) + +++ (do _ <- Parse.char '-' + f <- parse + return (f, False)) +-- {-# DEPRECATED parseFlagAssignment "Use parsecFlagAssignment" #-} -data CondTree v c a = CondNode - { condTreeData :: a - , condTreeConstraints :: c - , condTreeComponents :: [( Condition v - , CondTree v c a - , Maybe (CondTree v c a))] - } - deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable) +-- | 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 v, Binary c, Binary a) => Binary (CondTree v c a) +instance Binary ConfVar diff --git a/cabal/Cabal/Distribution/Types/GenericPackageDescription/Lens.hs b/cabal/Cabal/Distribution/Types/GenericPackageDescription/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/GenericPackageDescription/Lens.hs @@ -0,0 +1,121 @@ +module Distribution.Types.GenericPackageDescription.Lens ( + GenericPackageDescription, + Flag, + FlagName, + ConfVar (..), + module Distribution.Types.GenericPackageDescription.Lens, + ) where + +import Prelude() +import Distribution.Compat.Prelude +import Distribution.Compat.Lens + +import Distribution.Types.GenericPackageDescription (GenericPackageDescription(GenericPackageDescription), Flag(MkFlag), FlagName, ConfVar (..)) + +-- lens +import Distribution.Types.BuildInfo.Lens + +-- We import types from their packages, so we can remove unused imports +-- and have wider inter-module dependency graph +import Distribution.Types.CondTree (CondTree) +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.Executable (Executable) +import Distribution.Types.PackageDescription (PackageDescription) +import Distribution.Types.Benchmark (Benchmark) +import Distribution.Types.ForeignLib (ForeignLib) +import Distribution.Types.Library (Library) +import Distribution.Types.TestSuite (TestSuite) +import Distribution.Types.UnqualComponentName (UnqualComponentName) +import Distribution.System (Arch, OS) +import Distribution.Compiler (CompilerFlavor) +import Distribution.Version (VersionRange) + +------------------------------------------------------------------------------- +-- GenericPackageDescription +------------------------------------------------------------------------------- + +condBenchmarks :: Lens' GenericPackageDescription [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] +condBenchmarks f (GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 x8) = fmap (\y1 -> GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 y1) (f x8) +{-# INLINE condBenchmarks #-} + +condExecutables :: Lens' GenericPackageDescription [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] +condExecutables f (GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 x8) = fmap (\y1 -> GenericPackageDescription x1 x2 x3 x4 x5 y1 x7 x8) (f x6) +{-# INLINE condExecutables #-} + +condForeignLibs :: Lens' GenericPackageDescription [(UnqualComponentName, CondTree ConfVar [Dependency] Distribution.Types.ForeignLib.ForeignLib)] +condForeignLibs f (GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 x8) = fmap (\y1 -> GenericPackageDescription x1 x2 x3 x4 y1 x6 x7 x8) (f x5) +{-# INLINE condForeignLibs #-} + +condLibrary :: Lens' GenericPackageDescription (Maybe (CondTree ConfVar [Dependency] Library)) +condLibrary f (GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 x8) = fmap (\y1 -> GenericPackageDescription x1 x2 y1 x4 x5 x6 x7 x8) (f x3) +{-# INLINE condLibrary #-} + +condSubLibraries :: Lens' GenericPackageDescription [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] +condSubLibraries f (GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 x8) = fmap (\y1 -> GenericPackageDescription x1 x2 x3 y1 x5 x6 x7 x8) (f x4) +{-# INLINE condSubLibraries #-} + +condTestSuites :: Lens' GenericPackageDescription [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] +condTestSuites f (GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 x8) = fmap (\y1 -> GenericPackageDescription x1 x2 x3 x4 x5 x6 y1 x8) (f x7) +{-# INLINE condTestSuites #-} + +genPackageFlags :: Lens' GenericPackageDescription [Flag] +genPackageFlags f (GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 x8) = fmap (\y1 -> GenericPackageDescription x1 y1 x3 x4 x5 x6 x7 x8) (f x2) +{-# INLINE genPackageFlags #-} + +packageDescription :: Lens' GenericPackageDescription PackageDescription +packageDescription f (GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 x8) = fmap (\y1 -> GenericPackageDescription y1 x2 x3 x4 x5 x6 x7 x8) (f x1) +{-# INLINE packageDescription #-} + +------------------------------------------------------------------------------- +-- BuildInfos +------------------------------------------------------------------------------- + +buildInfos :: Traversal' GenericPackageDescription BuildInfo +buildInfos f (GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 x8) = + GenericPackageDescription x1 x2 + <$> (traverse . traverse . buildInfo) f x3 + <*> (traverse . _2 . traverse . buildInfo) f x4 + <*> (traverse . _2 . traverse . buildInfo) f x5 + <*> (traverse . _2 . traverse . buildInfo) f x6 + <*> (traverse . _2 . traverse . buildInfo) f x7 + <*> (traverse . _2 . traverse . buildInfo) f x8 + +------------------------------------------------------------------------------- +-- Flag +------------------------------------------------------------------------------- + +flagName :: Lens' Flag FlagName +flagName f (MkFlag x1 x2 x3 x4) = fmap (\y1 -> MkFlag y1 x2 x3 x4) (f x1) +{-# INLINE flagName #-} + +flagDescription :: Lens' Flag String +flagDescription f (MkFlag x1 x2 x3 x4) = fmap (\y1 -> MkFlag x1 y1 x3 x4) (f x2) +{-# INLINE flagDescription #-} + +flagDefault :: Lens' Flag Bool +flagDefault f (MkFlag x1 x2 x3 x4) = fmap (\y1 -> MkFlag x1 x2 y1 x4) (f x3) +{-# INLINE flagDefault #-} + +flagManual :: Lens' Flag Bool +flagManual f (MkFlag x1 x2 x3 x4) = fmap (\y1 -> MkFlag x1 x2 x3 y1) (f x4) +{-# INLINE flagManual #-} + +------------------------------------------------------------------------------- +-- ConfVar +------------------------------------------------------------------------------- + +_OS :: Traversal' ConfVar OS +_OS f (OS os) = OS <$> f os +_OS _ x = pure x + +_Arch :: Traversal' ConfVar Arch +_Arch f (Arch arch) = Arch <$> f arch +_Arch _ x = pure x + +_Flag :: Traversal' ConfVar FlagName +_Flag f (Flag flag) = Flag <$> f flag +_Flag _ x = pure x + +_Impl :: Traversal' ConfVar (CompilerFlavor, VersionRange) +_Impl f (Impl cf vr) = uncurry Impl <$> f (cf, vr) +_Impl _ x = pure x diff --git a/cabal/Cabal/Distribution/Types/HookedBuildInfo.hs b/cabal/Cabal/Distribution/Types/HookedBuildInfo.hs --- a/cabal/Cabal/Distribution/Types/HookedBuildInfo.hs +++ b/cabal/Cabal/Distribution/Types/HookedBuildInfo.hs @@ -8,7 +8,7 @@ -- import Distribution.Compat.Prelude import Distribution.Types.BuildInfo -import Distribution.Package +import Distribution.Types.UnqualComponentName -- | 'HookedBuildInfo' is mechanism that hooks can use to -- override the 'BuildInfo's inside packages. One example diff --git a/cabal/Cabal/Distribution/Types/IncludeRenaming.hs b/cabal/Cabal/Distribution/Types/IncludeRenaming.hs --- a/cabal/Cabal/Distribution/Types/IncludeRenaming.hs +++ b/cabal/Cabal/Distribution/Types/IncludeRenaming.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.IncludeRenaming ( IncludeRenaming(..), @@ -7,16 +7,19 @@ isDefaultIncludeRenaming, ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Types.ModuleRenaming -import Distribution.Text - -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<+>), text) -import Distribution.Compat.ReadP +import qualified Distribution.Compat.Parsec as P +import Distribution.Compat.ReadP ((<++)) +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Parsec.Class +import Distribution.Pretty +import Distribution.Text +import Text.PrettyPrint (text, (<+>)) +import qualified Text.PrettyPrint as Disp -- --------------------------------------------------------------------------- -- Module renaming @@ -40,15 +43,27 @@ isDefaultIncludeRenaming :: IncludeRenaming -> Bool isDefaultIncludeRenaming (IncludeRenaming p r) = isDefaultRenaming p && isDefaultRenaming r -instance Text IncludeRenaming where - disp (IncludeRenaming prov_rn req_rn) = - disp prov_rn +instance Pretty IncludeRenaming where + pretty (IncludeRenaming prov_rn req_rn) = + pretty prov_rn <+> (if isDefaultRenaming req_rn then Disp.empty - else text "requires" <+> disp req_rn) + else text "requires" <+> pretty req_rn) + +instance Parsec IncludeRenaming where + parsec = do + prov_rn <- parsec + req_rn <- P.option defaultRenaming $ P.try $ do + P.spaces + _ <- P.string "requires" + P.spaces + parsec + return (IncludeRenaming prov_rn req_rn) + +instance Text IncludeRenaming where parse = do prov_rn <- parse - req_rn <- (string "requires" >> skipSpaces >> parse) <++ return defaultRenaming + req_rn <- (Parse.string "requires" >> Parse.skipSpaces >> parse) <++ return defaultRenaming -- Requirements don't really care if they're mentioned -- or not (since you can't thin a requirement.) But -- we have a little hack in Configure to combine diff --git a/cabal/Cabal/Distribution/Types/LegacyExeDependency.hs b/cabal/Cabal/Distribution/Types/LegacyExeDependency.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/LegacyExeDependency.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.LegacyExeDependency + ( LegacyExeDependency(..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec.Class +import Distribution.ParseUtils (parseMaybeQuoted) +import Distribution.Pretty +import Distribution.Text +import Distribution.Version (VersionRange, anyVersion) + +import qualified Distribution.Compat.Parsec as P +import Distribution.Compat.ReadP ((<++)) +import qualified Distribution.Compat.ReadP as Parse +import Text.PrettyPrint (text, (<+>)) + +-- | Describes a legacy `build-tools`-style dependency on an executable +-- +-- It is "legacy" because we do not know what the build-tool referred to. It +-- could refer to a pkg-config executable (PkgconfigName), or an internal +-- executable (UnqualComponentName). Thus the name is stringly typed. +-- +-- @since 2.0.0.2 +data LegacyExeDependency = LegacyExeDependency + String + VersionRange + deriving (Generic, Read, Show, Eq, Typeable, Data) + +instance Binary LegacyExeDependency +instance NFData LegacyExeDependency where rnf = genericRnf + +instance Pretty LegacyExeDependency where + pretty (LegacyExeDependency name ver) = + text name <+> pretty ver + +instance Parsec LegacyExeDependency where + parsec = do + name <- parsecMaybeQuoted nameP + P.spaces + verRange <- parsecMaybeQuoted parsec <|> pure anyVersion + pure $ LegacyExeDependency name verRange + where + nameP = intercalate "-" <$> P.sepBy1 component (P.char '-') + component = do + cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_') + if all isDigit cs then fail "invalid component" else return cs + +instance Text LegacyExeDependency where + parse = do name <- parseMaybeQuoted parseBuildToolName + Parse.skipSpaces + ver <- parse <++ return anyVersion + Parse.skipSpaces + return $ LegacyExeDependency name ver + where + -- like parsePackageName but accepts symbols in components + parseBuildToolName :: Parse.ReadP r String + parseBuildToolName = do ns <- Parse.sepBy1 component (Parse.char '-') + return (intercalate "-" ns) + where component = do + cs <- Parse.munch1 (\c -> isAlphaNum c || c == '+' || c == '_') + if all isDigit cs then Parse.pfail else return cs diff --git a/cabal/Cabal/Distribution/Types/Lens.hs b/cabal/Cabal/Distribution/Types/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/Lens.hs @@ -0,0 +1,25 @@ +module Distribution.Types.Lens ( + module Distribution.Types.Benchmark.Lens, + module Distribution.Types.BuildInfo.Lens, + module Distribution.Types.Executable.Lens, + module Distribution.Types.ForeignLib.Lens, + module Distribution.Types.GenericPackageDescription.Lens, + module Distribution.Types.Library.Lens, + module Distribution.Types.PackageDescription.Lens, + module Distribution.Types.PackageId.Lens, + module Distribution.Types.SetupBuildInfo.Lens, + module Distribution.Types.SourceRepo.Lens, + module Distribution.Types.TestSuite.Lens, + ) where + +import Distribution.Types.Benchmark.Lens +import Distribution.Types.BuildInfo.Lens +import Distribution.Types.Executable.Lens +import Distribution.Types.ForeignLib.Lens +import Distribution.Types.GenericPackageDescription.Lens +import Distribution.Types.Library.Lens +import Distribution.Types.PackageDescription.Lens +import Distribution.Types.PackageId.Lens +import Distribution.Types.SetupBuildInfo.Lens +import Distribution.Types.SourceRepo.Lens +import Distribution.Types.TestSuite.Lens diff --git a/cabal/Cabal/Distribution/Types/Library.hs b/cabal/Cabal/Distribution/Types/Library.hs --- a/cabal/Cabal/Distribution/Types/Library.hs +++ b/cabal/Cabal/Distribution/Types/Library.hs @@ -15,18 +15,23 @@ import Distribution.Types.BuildInfo import Distribution.Types.ModuleReexport +import Distribution.Types.UnqualComponentName import Distribution.ModuleName -import Distribution.Package -data Library = Library { - libName :: Maybe UnqualComponentName, - exposedModules :: [ModuleName], - reexportedModules :: [ModuleReexport], - signatures:: [ModuleName], -- ^ What sigs need implementations? - libExposed :: Bool, -- ^ Is the lib to be exposed by default? - libBuildInfo :: BuildInfo +import qualified Distribution.Types.BuildInfo.Lens as L + +data Library = Library + { libName :: Maybe UnqualComponentName + , exposedModules :: [ModuleName] + , reexportedModules :: [ModuleReexport] + , signatures :: [ModuleName] -- ^ What sigs need implementations? + , libExposed :: Bool -- ^ Is the lib to be exposed by default? + , libBuildInfo :: BuildInfo } deriving (Generic, Show, Eq, Read, Typeable, Data) + +instance L.HasBuildInfo Library where + buildInfo f l = (\x -> l { libBuildInfo = x }) <$> f (libBuildInfo l) instance Binary Library diff --git a/cabal/Cabal/Distribution/Types/Library/Lens.hs b/cabal/Cabal/Distribution/Types/Library/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/Library/Lens.hs @@ -0,0 +1,40 @@ +module Distribution.Types.Library.Lens ( + Library, + module Distribution.Types.Library.Lens, + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Compat.Lens + +import Distribution.ModuleName (ModuleName) +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.Library (Library) +import Distribution.Types.ModuleReexport (ModuleReexport) +import Distribution.Types.UnqualComponentName (UnqualComponentName) + +import qualified Distribution.Types.Library as T + +libName :: Lens' Library (Maybe UnqualComponentName) +libName f s = fmap (\x -> s { T.libName = x }) (f (T.libName s)) +{-# INLINE libName #-} + +exposedModules :: Lens' Library [ModuleName] +exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s)) +{-# INLINE exposedModules #-} + +reexportedModules :: Lens' Library [ModuleReexport] +reexportedModules f s = fmap (\x -> s { T.reexportedModules = x }) (f (T.reexportedModules s)) +{-# INLINE reexportedModules #-} + +signatures :: Lens' Library [ModuleName] +signatures f s = fmap (\x -> s { T.signatures = x }) (f (T.signatures s)) +{-# INLINE signatures #-} + +libExposed :: Lens' Library Bool +libExposed f s = fmap (\x -> s { T.libExposed = x }) (f (T.libExposed s)) +{-# INLINE libExposed #-} + +libBuildInfo :: Lens' Library BuildInfo +libBuildInfo f s = fmap (\x -> s { T.libBuildInfo = x }) (f (T.libBuildInfo s)) +{-# INLINE libBuildInfo #-} 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 @@ -59,6 +59,10 @@ import Distribution.Types.PackageDescription import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.ComponentId +import Distribution.Types.MungedPackageId +import Distribution.Types.PackageId +import Distribution.Types.UnitId import Distribution.Types.TargetInfo import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, @@ -66,7 +70,6 @@ substPathTemplate, ) import Distribution.Simple.Program import Distribution.PackageDescription -import Distribution.Package import Distribution.Simple.Compiler import Distribution.Simple.PackageIndex import Distribution.Simple.Setup @@ -139,6 +142,7 @@ withVanillaLib:: Bool, -- ^Whether to build normal libs. withProfLib :: Bool, -- ^Whether to build profiling versions of libs. withSharedLib :: Bool, -- ^Whether to build shared versions of libs. + withStaticLib :: Bool, -- ^Whether to build static versions of libs (with all other libs rolled in) withDynExe :: Bool, -- ^Whether to link executables dynamically withProfExe :: Bool, -- ^Whether to build executables for profiling. withProfLibDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. @@ -146,6 +150,7 @@ withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (if available). withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. + splitSections :: Bool, -- ^Use -split-sections with GHC, if available splitObjs :: Bool, -- ^Use -split-objs with GHC, if available stripExes :: Bool, -- ^Whether to strip executables during install stripLibs :: Bool, -- ^Whether to strip libraries during install @@ -187,7 +192,7 @@ case componentNameCLBIs lbi CLibName of [LibComponentLocalBuildInfo { componentUnitId = uid }] -> uid - _ -> mkLegacyUnitId (localPackage lbi) + _ -> mkLegacyUnitId $ localPackage lbi -- | Extract the compatibility package key from the public library component of a -- 'LocalBuildInfo' if it exists, or make a fake package key based @@ -261,7 +266,7 @@ neededTargetsInBuildOrder' pkg_descr lbi uids = case Graph.closure (componentGraph lbi) uids of Nothing -> error $ "localBuildPlan: missing uids " ++ intercalate ", " (map display uids) - Just clos -> map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (Graph.fromList clos)) + Just clos -> map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (Graph.fromDistinctList clos)) -- | Execute @f@ for every 'TargetInfo' needed to build @uid@s, respecting -- the build dependency order. @@ -316,7 +321,7 @@ -- | External package dependencies for the package as a whole. This is the -- union of the individual 'componentPackageDeps', less any internal deps. {-# DEPRECATED externalPackageDeps "You almost certainly don't want this function, which agglomerates the dependencies of ALL enabled components. If you're using this to write out information on your dependencies, read off the dependencies directly from the actual component in question. To be removed in Cabal 2.2" #-} -externalPackageDeps :: LocalBuildInfo -> [(UnitId, PackageId)] +externalPackageDeps :: LocalBuildInfo -> [(UnitId, MungedPackageId)] externalPackageDeps lbi = -- TODO: what about non-buildable components? nub [ (ipkgid, pkgid) diff --git a/cabal/Cabal/Distribution/Types/Mixin.hs b/cabal/Cabal/Distribution/Types/Mixin.hs --- a/cabal/Cabal/Distribution/Types/Mixin.hs +++ b/cabal/Cabal/Distribution/Types/Mixin.hs @@ -1,32 +1,43 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.Mixin ( Mixin(..), ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Text.PrettyPrint ((<+>)) -import Distribution.Compat.ReadP -import Distribution.Text -import Distribution.Package +import Distribution.Parsec.Class +import Distribution.Pretty +import Distribution.Text import Distribution.Types.IncludeRenaming +import Distribution.Types.PackageName +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse + data Mixin = Mixin { mixinPackageName :: PackageName , mixinIncludeRenaming :: IncludeRenaming } deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) instance Binary Mixin -instance Text Mixin where - disp (Mixin pkg_name incl) = - disp pkg_name <+> disp incl +instance Pretty Mixin where + pretty (Mixin pkg_name incl) = pretty pkg_name <+> pretty incl +instance Parsec Mixin where + parsec = do + mod_name <- parsec + P.spaces + incl <- parsec + return (Mixin mod_name incl) + +instance Text Mixin where parse = do pkg_name <- parse - skipSpaces + Parse.skipSpaces incl <- parse return (Mixin pkg_name incl) diff --git a/cabal/Cabal/Distribution/Types/Module.hs b/cabal/Cabal/Distribution/Types/Module.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/Module.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Distribution.Types.Module + ( Module(..) + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P +import qualified Text.PrettyPrint as Disp +import Distribution.Pretty +import Distribution.Parsec.Class +import Distribution.Text +import Distribution.Types.UnitId +import Distribution.ModuleName + +-- | A module identity uniquely identifies a Haskell module by +-- qualifying a 'ModuleName' with the 'UnitId' which defined +-- it. This type distinguishes between two packages +-- which provide a module with the same name, or a module +-- from the same package compiled with different dependencies. +-- There are a few cases where Cabal needs to know about +-- module identities, e.g., when writing out reexported modules in +-- the 'InstalledPackageInfo'. +data Module = + Module DefUnitId ModuleName + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +instance Binary Module + +instance Pretty Module where + pretty (Module uid mod_name) = + pretty uid <<>> Disp.text ":" <<>> pretty mod_name + +instance Parsec Module where + parsec = do + uid <- parsec + _ <- P.char ':' + mod_name <- parsec + return (Module uid mod_name) + +instance Text Module where + parse = do + uid <- parse + _ <- Parse.char ':' + mod_name <- parse + return (Module uid mod_name) + +instance NFData Module where + rnf (Module uid mod_name) = rnf uid `seq` rnf mod_name diff --git a/cabal/Cabal/Distribution/Types/ModuleReexport.hs b/cabal/Cabal/Distribution/Types/ModuleReexport.hs --- a/cabal/Cabal/Distribution/Types/ModuleReexport.hs +++ b/cabal/Cabal/Distribution/Types/ModuleReexport.hs @@ -1,19 +1,23 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.ModuleReexport ( ModuleReexport(..) ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Package import Distribution.ModuleName +import Distribution.Parsec.Class +import Distribution.Pretty import Distribution.Text +import Distribution.Types.PackageName -import Text.PrettyPrint as Disp +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import Text.PrettyPrint ((<+>)) +import qualified Text.PrettyPrint as Disp -- ----------------------------------------------------------------------------- -- Module re-exports @@ -27,14 +31,26 @@ instance Binary ModuleReexport -instance Text ModuleReexport where - disp (ModuleReexport mpkgname origname newname) = - maybe Disp.empty (\pkgname -> disp pkgname <<>> Disp.char ':') mpkgname - <<>> disp origname +instance Pretty ModuleReexport where + pretty (ModuleReexport mpkgname origname newname) = + maybe Disp.empty (\pkgname -> pretty pkgname <<>> Disp.char ':') mpkgname + <<>> pretty origname <+> if newname == origname then Disp.empty - else Disp.text "as" <+> disp newname + else Disp.text "as" <+> pretty newname +instance Parsec ModuleReexport where + parsec = do + mpkgname <- P.optionMaybe (P.try $ parsec <* P.char ':') + origname <- parsec + newname <- P.option origname $ P.try $ do + P.spaces + _ <- P.string "as" + P.spaces + parsec + return (ModuleReexport mpkgname origname newname) + +instance Text ModuleReexport where parse = do mpkgname <- Parse.option Nothing $ do pkgname <- parse diff --git a/cabal/Cabal/Distribution/Types/ModuleRenaming.hs b/cabal/Cabal/Distribution/Types/ModuleRenaming.hs --- a/cabal/Cabal/Distribution/Types/ModuleRenaming.hs +++ b/cabal/Cabal/Distribution/Types/ModuleRenaming.hs @@ -1,21 +1,27 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.ModuleRenaming ( ModuleRenaming(..), + interpModuleRenaming, defaultRenaming, isDefaultRenaming, ) where -import Prelude () import Distribution.Compat.Prelude hiding (empty) +import Prelude () -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP ((<++)) import Distribution.ModuleName +import Distribution.Parsec.Class +import Distribution.Pretty import Distribution.Text -import Text.PrettyPrint +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Distribution.Compat.Parsec as P +import Distribution.Compat.ReadP ((<++)) +import qualified Distribution.Compat.ReadP as Parse +import Text.PrettyPrint (hsep, parens, punctuate, text, (<+>), comma) -- | Renaming applied to the modules provided by a package. -- The boolean indicates whether or not to also include all of the @@ -38,6 +44,18 @@ | HidingRenaming [ModuleName] deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) +-- | Interpret a 'ModuleRenaming' as a partial map from 'ModuleName' +-- to 'ModuleName'. For efficiency, you should partially apply it +-- with 'ModuleRenaming' and then reuse it. +interpModuleRenaming :: ModuleRenaming -> ModuleName -> Maybe ModuleName +interpModuleRenaming DefaultRenaming = Just +interpModuleRenaming (ModuleRenaming rns) = + let m = Map.fromList rns + in \k -> Map.lookup k m +interpModuleRenaming (HidingRenaming hs) = + let s = Set.fromList hs + in \k -> if k `Set.member` s then Nothing else Just k + -- | The default renaming, if something is specified in @build-depends@ -- only. defaultRenaming :: ModuleRenaming @@ -53,16 +71,45 @@ -- NB: parentheses are mandatory, because later we may extend this syntax -- to allow "hiding (A, B)" or other modifier words. -instance Text ModuleRenaming where - disp DefaultRenaming = empty - disp (HidingRenaming hides) - = text "hiding" <+> parens (hsep (punctuate comma (map disp hides))) - disp (ModuleRenaming rns) +instance Pretty ModuleRenaming where + pretty DefaultRenaming = mempty + pretty (HidingRenaming hides) + = text "hiding" <+> parens (hsep (punctuate comma (map pretty hides))) + pretty (ModuleRenaming rns) = parens . hsep $ punctuate comma (map dispEntry rns) where dispEntry (orig, new) - | orig == new = disp orig - | otherwise = disp orig <+> text "as" <+> disp new + | orig == new = pretty orig + | otherwise = pretty orig <+> text "as" <+> pretty new +instance Parsec ModuleRenaming where + -- NB: try not necessary as the first token is obvious + parsec = P.choice [ parseRename, parseHiding, return DefaultRenaming ] + where + parseRename = do + rns <- P.between (P.char '(') (P.char ')') parseList + P.spaces + return (ModuleRenaming rns) + parseHiding = do + _ <- P.string "hiding" + P.spaces + hides <- P.between (P.char '(') (P.char ')') + (P.sepBy parsec (P.char ',' >> P.spaces)) + return (HidingRenaming hides) + parseList = + P.sepBy parseEntry (P.char ',' >> P.spaces) + parseEntry = do + orig <- parsec + P.spaces + P.option (orig, orig) $ do + _ <- P.string "as" + P.spaces + new <- parsec + P.spaces + return (orig, new) + + + +instance Text ModuleRenaming where parse = do fmap ModuleRenaming parseRns <++ parseHidingRenaming <++ return DefaultRenaming diff --git a/cabal/Cabal/Distribution/Types/MungedPackageId.hs b/cabal/Cabal/Distribution/Types/MungedPackageId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/MungedPackageId.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.MungedPackageId + ( MungedPackageId(..) + , computeCompatPackageId + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Version + ( Version, nullVersion ) + +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Distribution.Compat.ReadP +import Distribution.Text +import Distribution.Types.PackageId +import Distribution.Types.UnqualComponentName +import Distribution.Types.MungedPackageName + +-- | A simple pair of a 'MungedPackageName' and 'Version'. 'MungedPackageName' is to +-- 'MungedPackageId' as 'PackageName' is to 'PackageId'. See 'MungedPackageName' for more +-- info. +data MungedPackageId + = MungedPackageId { + -- | The combined package and component name. see documentation for + -- 'MungedPackageName'. + mungedName :: MungedPackageName, + -- | The version of this package / component, eg 1.2 + mungedVersion :: Version + } + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +instance Binary MungedPackageId + +instance Text MungedPackageId where + disp (MungedPackageId n v) + | v == nullVersion = disp n -- if no version, don't show version. + | otherwise = disp n <<>> Disp.char '-' <<>> disp v + + parse = do + n <- parse + v <- (Parse.char '-' >> parse) <++ return nullVersion + return (MungedPackageId n v) + +instance NFData MungedPackageId where + rnf (MungedPackageId name version) = rnf name `seq` rnf version + +-- | See docs for 'Distribution.Types.MungedPackageName.computeCompatPackageId'. this +-- is a thin wrapper around that. +computeCompatPackageId :: PackageId -> Maybe UnqualComponentName -> MungedPackageId +computeCompatPackageId (PackageIdentifier pn vr) mb_uqn = MungedPackageId pn' vr + where pn' = computeCompatPackageName pn mb_uqn diff --git a/cabal/Cabal/Distribution/Types/MungedPackageName.hs b/cabal/Cabal/Distribution/Types/MungedPackageName.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/MungedPackageName.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.MungedPackageName + ( MungedPackageName, unMungedPackageName, mkMungedPackageName + , computeCompatPackageName + , decodeCompatPackageName + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText + +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.ReadP as Parse +import Distribution.ParseUtils +import Distribution.Text +import Distribution.Types.PackageName +import Distribution.Types.UnqualComponentName + +-- | A combination of a package and component name used in various legacy +-- interfaces, chiefly bundled with a version as 'MungedPackageId'. It's generally +-- better to use a 'UnitId' to opaquely refer to some compilation/packing unit, +-- but that doesn't always work, e.g. where a "name" is needed, in which case +-- this can be used as a fallback. +-- +-- Use 'mkMungedPackageName' and 'unMungedPackageName' to convert from/to a 'String'. +-- +-- @since 2.0.0.2 +newtype MungedPackageName = MungedPackageName ShortText + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +-- | Convert 'MungedPackageName' to 'String' +unMungedPackageName :: MungedPackageName -> String +unMungedPackageName (MungedPackageName s) = fromShortText s + +-- | Construct a 'MungedPackageName' from a 'String' +-- +-- 'mkMungedPackageName' is the inverse to 'unMungedPackageName' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'MungedPackageName' is valid +-- +-- @since 2.0.0.2 +mkMungedPackageName :: String -> MungedPackageName +mkMungedPackageName = MungedPackageName . toShortText + +-- | 'mkMungedPackageName' +-- +-- @since 2.0.0.2 +instance IsString MungedPackageName where + fromString = mkMungedPackageName + +instance Binary MungedPackageName + +instance Text MungedPackageName where + disp = Disp.text . unMungedPackageName + parse = mkMungedPackageName <$> parsePackageName + +instance NFData MungedPackageName where + rnf (MungedPackageName pkg) = rnf pkg + +-- | Computes the package name for a library. If this is the public +-- library, it will just be the original package name; otherwise, +-- it will be a munged package name recording the original package +-- name as well as the name of the internal library. +-- +-- A lot of tooling in the Haskell ecosystem assumes that if something +-- is installed to the package database with the package name 'foo', +-- then it actually is an entry for the (only public) library in package +-- 'foo'. With internal packages, this is not necessarily true: +-- a public library as well as arbitrarily many internal libraries may +-- come from the same package. To prevent tools from getting confused +-- in this case, the package name of these internal libraries is munged +-- so that they do not conflict the public library proper. A particular +-- case where this matters is ghc-pkg: if we don't munge the package +-- name, the inplace registration will OVERRIDE a different internal +-- library. +-- +-- We munge into a reserved namespace, "z-", and encode both the +-- component name and the package name of an internal library using the +-- following format: +-- +-- compat-pkg-name ::= "z-" package-name "-z-" library-name +-- +-- where package-name and library-name have "-" ( "z" + ) "-" +-- segments encoded by adding an extra "z". +-- +-- When we have the public library, the compat-pkg-name is just the +-- package-name, no surprises there! +-- +computeCompatPackageName :: PackageName -> Maybe UnqualComponentName -> MungedPackageName +-- First handle the cases where we can just use the original 'PackageName'. +-- This is for the PRIMARY library, and it is non-Backpack, or the +-- indefinite package for us. +computeCompatPackageName pkg_name Nothing + = mkMungedPackageName $ unPackageName pkg_name +computeCompatPackageName pkg_name (Just uqn) + = mkMungedPackageName $ + "z-" ++ zdashcode (unPackageName pkg_name) ++ + "-z-" ++ zdashcode (unUnqualComponentName uqn) + +decodeCompatPackageName :: MungedPackageName -> (PackageName, Maybe UnqualComponentName) +decodeCompatPackageName m = + case unMungedPackageName m of + 'z':'-':rest | [([pn, cn], "")] <- Parse.readP_to_S parseZDashCode rest + -> (mkPackageName pn, Just (mkUnqualComponentName cn)) + s -> (mkPackageName s, Nothing) + +zdashcode :: String -> String +zdashcode s = go s (Nothing :: Maybe Int) [] + where go [] _ r = reverse r + go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r) + go ('-':z) _ r = go z (Just 0) ('-':r) + go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r) + go (c:z) _ r = go z Nothing (c:r) + +parseZDashCode :: Parse.ReadP r [String] +parseZDashCode = do + ns <- Parse.sepBy1 (Parse.many1 (Parse.satisfy (/= '-'))) (Parse.char '-') + Parse.eof + return (go ns) + where + go ns = case break (=="z") ns of + (_, []) -> [paste ns] + (as, "z":bs) -> paste as : go bs + _ -> error "parseZDashCode: go" + unZ :: String -> String + unZ "" = error "parseZDashCode: unZ" + unZ r@('z':zs) | all (=='z') zs = zs + | otherwise = r + unZ r = r + paste :: [String] -> String + paste = intercalate "-" . map unZ diff --git a/cabal/Cabal/Distribution/Types/PackageDescription.hs b/cabal/Cabal/Distribution/Types/PackageDescription.hs --- a/cabal/Cabal/Distribution/Types/PackageDescription.hs +++ b/cabal/Cabal/Distribution/Types/PackageDescription.hs @@ -63,8 +63,12 @@ import Distribution.Types.ForeignLib import Distribution.Types.Component -import Distribution.Types.ComponentName import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.Dependency +import Distribution.Types.PackageId +import Distribution.Types.ComponentName +import Distribution.Types.PackageName +import Distribution.Types.UnqualComponentName import Distribution.Types.SetupBuildInfo import Distribution.Types.BuildInfo import Distribution.Types.BuildType @@ -133,6 +137,7 @@ foreignLibs :: [ForeignLib], testSuites :: [TestSuite], benchmarks :: [Benchmark], + -- files dataFiles :: [FilePath], dataDir :: FilePath, extraSrcFiles :: [FilePath], @@ -310,6 +315,9 @@ allBuildInfo pkg_descr = [ bi | lib <- allLibraries pkg_descr , let bi = libBuildInfo lib , buildable bi ] + ++ [ bi | flib <- foreignLibs pkg_descr + , let bi = foreignLibBuildInfo flib + , buildable bi ] ++ [ bi | exe <- executables pkg_descr , let bi = buildInfo exe , buildable bi ] @@ -375,14 +383,14 @@ -- indicate if we are actually going to build the component, -- see 'enabledComponents' instead. -- --- @since 2.0.0.0 +-- @since 2.0.0.2 -- pkgBuildableComponents :: PackageDescription -> [Component] pkgBuildableComponents = filter componentBuildable . pkgComponents -- | A list of all components in the package that are enabled. -- --- @since 2.0.0.0 +-- @since 2.0.0.2 -- enabledComponents :: PackageDescription -> ComponentRequestedSpec -> [Component] enabledComponents pkg enabled = filter (componentEnabled enabled) $ pkgBuildableComponents pkg diff --git a/cabal/Cabal/Distribution/Types/PackageDescription/Lens.hs b/cabal/Cabal/Distribution/Types/PackageDescription/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/PackageDescription/Lens.hs @@ -0,0 +1,149 @@ +module Distribution.Types.PackageDescription.Lens ( + PackageDescription, + module Distribution.Types.PackageDescription.Lens, + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Compat.Lens + +import Distribution.Compiler (CompilerFlavor) +import Distribution.License (License) +import Distribution.Types.Benchmark (Benchmark) +import Distribution.Types.BuildType (BuildType) +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.Executable (Executable) +import Distribution.Types.ForeignLib (ForeignLib) +import Distribution.Types.Library (Library) +import Distribution.Types.PackageDescription (PackageDescription) +import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.SetupBuildInfo (SetupBuildInfo) +import Distribution.Types.SourceRepo (SourceRepo) +import Distribution.Types.TestSuite (TestSuite) +import Distribution.Version (Version, VersionRange) + +import qualified Distribution.Types.PackageDescription as T + +package :: Lens' PackageDescription PackageIdentifier +package f s = fmap (\x -> s { T.package = x }) (f (T.package s)) +{-# INLINE package #-} + +license :: Lens' PackageDescription License +license f s = fmap (\x -> s { T.license = x }) (f (T.license s)) +{-# INLINE license #-} + +licenseFiles :: Lens' PackageDescription [String] +licenseFiles f s = fmap (\x -> s { T.licenseFiles = x }) (f (T.licenseFiles s)) +{-# INLINE licenseFiles #-} + +copyright :: Lens' PackageDescription String +copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) +{-# INLINE copyright #-} + +maintainer :: Lens' PackageDescription String +maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) +{-# INLINE maintainer #-} + +author :: Lens' PackageDescription String +author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) +{-# INLINE author #-} + +stability :: Lens' PackageDescription String +stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) +{-# INLINE stability #-} + +testedWith :: Lens' PackageDescription [(CompilerFlavor,VersionRange)] +testedWith f s = fmap (\x -> s { T.testedWith = x }) (f (T.testedWith s)) +{-# INLINE testedWith #-} + +homepage :: Lens' PackageDescription String +homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) +{-# INLINE homepage #-} + +pkgUrl :: Lens' PackageDescription String +pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) +{-# INLINE pkgUrl #-} + +bugReports :: Lens' PackageDescription String +bugReports f s = fmap (\x -> s { T.bugReports = x }) (f (T.bugReports s)) +{-# INLINE bugReports #-} + +sourceRepos :: Lens' PackageDescription [SourceRepo] +sourceRepos f s = fmap (\x -> s { T.sourceRepos = x }) (f (T.sourceRepos s)) +{-# INLINE sourceRepos #-} + +synopsis :: Lens' PackageDescription String +synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) +{-# INLINE synopsis #-} + +description :: Lens' PackageDescription String +description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) +{-# INLINE description #-} + +category :: Lens' PackageDescription String +category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) +{-# INLINE category #-} + +customFieldsPD :: Lens' PackageDescription [(String,String)] +customFieldsPD f s = fmap (\x -> s { T.customFieldsPD = x }) (f (T.customFieldsPD s)) +{-# INLINE customFieldsPD #-} + +buildDepends :: Lens' PackageDescription [Dependency] +buildDepends f s = fmap (\x -> s { T.buildDepends = x }) (f (T.buildDepends s)) +{-# INLINE buildDepends #-} + +specVersionRaw :: Lens' PackageDescription (Either Version VersionRange) +specVersionRaw f s = fmap (\x -> s { T.specVersionRaw = x }) (f (T.specVersionRaw s)) +{-# INLINE specVersionRaw #-} + +buildType :: Lens' PackageDescription (Maybe BuildType) +buildType f s = fmap (\x -> s { T.buildType = x }) (f (T.buildType s)) +{-# INLINE buildType #-} + +setupBuildInfo :: Lens' PackageDescription (Maybe SetupBuildInfo) +setupBuildInfo f s = fmap (\x -> s { T.setupBuildInfo = x }) (f (T.setupBuildInfo s)) +{-# INLINE setupBuildInfo #-} + +library :: Lens' PackageDescription (Maybe Library) +library f s = fmap (\x -> s { T.library = x }) (f (T.library s)) +{-# INLINE library #-} + +subLibraries :: Lens' PackageDescription [Library] +subLibraries f s = fmap (\x -> s { T.subLibraries = x }) (f (T.subLibraries s)) +{-# INLINE subLibraries #-} + +executables :: Lens' PackageDescription [Executable] +executables f s = fmap (\x -> s { T.executables = x }) (f (T.executables s)) +{-# INLINE executables #-} + +foreignLibs :: Lens' PackageDescription [ForeignLib] +foreignLibs f s = fmap (\x -> s { T.foreignLibs = x }) (f (T.foreignLibs s)) +{-# INLINE foreignLibs #-} + +testSuites :: Lens' PackageDescription [TestSuite] +testSuites f s = fmap (\x -> s { T.testSuites = x }) (f (T.testSuites s)) +{-# INLINE testSuites #-} + +benchmarks :: Lens' PackageDescription [Benchmark] +benchmarks f s = fmap (\x -> s { T.benchmarks = x }) (f (T.benchmarks s)) +{-# INLINE benchmarks #-} + +dataFiles :: Lens' PackageDescription [FilePath] +dataFiles f s = fmap (\x -> s { T.dataFiles = x }) (f (T.dataFiles s)) +{-# INLINE dataFiles #-} + +dataDir :: Lens' PackageDescription FilePath +dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s)) +{-# INLINE dataDir #-} + +extraSrcFiles :: Lens' PackageDescription [String] +extraSrcFiles f s = fmap (\x -> s { T.extraSrcFiles = x }) (f (T.extraSrcFiles s)) +{-# INLINE extraSrcFiles #-} + +extraTmpFiles :: Lens' PackageDescription [String] +extraTmpFiles f s = fmap (\x -> s { T.extraTmpFiles = x }) (f (T.extraTmpFiles s)) +{-# INLINE extraTmpFiles #-} + +extraDocFiles :: Lens' PackageDescription [String] +extraDocFiles f s = fmap (\x -> s { T.extraDocFiles = x }) (f (T.extraDocFiles s)) +{-# INLINE extraDocFiles #-} diff --git a/cabal/Cabal/Distribution/Types/PackageId.hs b/cabal/Cabal/Distribution/Types/PackageId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/PackageId.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.PackageId + ( PackageIdentifier(..) + , PackageId + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Version + ( Version, nullVersion ) + +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Distribution.Compat.ReadP +import Distribution.Text +import Distribution.Pretty +import Distribution.Types.PackageName + +-- | Type alias so we can use the shorter name PackageId. +type PackageId = PackageIdentifier + +-- | The name and version of a package. +data PackageIdentifier + = PackageIdentifier { + pkgName :: PackageName, -- ^The name of this package, eg. foo + pkgVersion :: Version -- ^the version of this package, eg 1.2 + } + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +instance Binary PackageIdentifier + +instance Pretty PackageIdentifier where + pretty (PackageIdentifier n v) + | v == nullVersion = pretty n -- if no version, don't show version. + | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v + +instance Text PackageIdentifier where + parse = do + n <- parse + v <- (Parse.char '-' >> parse) <++ return nullVersion + return (PackageIdentifier n v) + +instance NFData PackageIdentifier where + rnf (PackageIdentifier name version) = rnf name `seq` rnf version diff --git a/cabal/Cabal/Distribution/Types/PackageId/Lens.hs b/cabal/Cabal/Distribution/Types/PackageId/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/PackageId/Lens.hs @@ -0,0 +1,22 @@ +module Distribution.Types.PackageId.Lens ( + PackageIdentifier, + module Distribution.Types.PackageId.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.PackageName (PackageName) +import Distribution.Version (Version) + +import qualified Distribution.Types.PackageId as T + +pkgName :: Lens' PackageIdentifier PackageName +pkgName f s = fmap (\x -> s { T.pkgName = x }) (f (T.pkgName s)) +{-# INLINE pkgName #-} + +pkgVersion :: Lens' PackageIdentifier Version +pkgVersion f s = fmap (\x -> s { T.pkgVersion = x }) (f (T.pkgVersion s)) +{-# INLINE pkgVersion #-} diff --git a/cabal/Cabal/Distribution/Types/PackageName.hs b/cabal/Cabal/Distribution/Types/PackageName.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/PackageName.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.PackageName + ( PackageName, unPackageName, mkPackageName + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText + +import qualified Text.PrettyPrint as Disp +import Distribution.ParseUtils +import Distribution.Text +import Distribution.Pretty +import Distribution.Parsec.Class + +-- | A package name. +-- +-- Use 'mkPackageName' and 'unPackageName' to convert from/to a +-- 'String'. +-- +-- This type is opaque since @Cabal-2.0@ +-- +-- @since 2.0.0.2 +newtype PackageName = PackageName ShortText + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +-- | Convert 'PackageName' to 'String' +unPackageName :: PackageName -> String +unPackageName (PackageName s) = fromShortText s + +-- | Construct a 'PackageName' from a 'String' +-- +-- 'mkPackageName' is the inverse to 'unPackageName' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'PackageName' is valid +-- +-- @since 2.0.0.2 +mkPackageName :: String -> PackageName +mkPackageName = PackageName . toShortText + +-- | 'mkPackageName' +-- +-- @since 2.0.0.2 +instance IsString PackageName where + fromString = mkPackageName + +instance Binary PackageName + +instance Pretty PackageName where + pretty = Disp.text . unPackageName + +instance Parsec PackageName where + parsec = mkPackageName <$> parsecUnqualComponentName + +instance Text PackageName where + parse = mkPackageName <$> parsePackageName + +instance NFData PackageName where + rnf (PackageName pkg) = rnf pkg diff --git a/cabal/Cabal/Distribution/Types/PkgconfigDependency.hs b/cabal/Cabal/Distribution/Types/PkgconfigDependency.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/PkgconfigDependency.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.PkgconfigDependency + ( PkgconfigDependency(..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Version (VersionRange, anyVersion) + +import Distribution.Types.PkgconfigName + +import Distribution.Parsec.Class +import Distribution.Pretty +import Distribution.Text + +import qualified Distribution.Compat.Parsec as P +import Distribution.Compat.ReadP ((<++)) +import qualified Distribution.Compat.ReadP as Parse +import Text.PrettyPrint ((<+>)) + +-- | Describes a dependency on a pkg-config library +-- +-- @since 2.0.0.2 +data PkgconfigDependency = PkgconfigDependency + PkgconfigName + VersionRange + deriving (Generic, Read, Show, Eq, Typeable, Data) + +instance Binary PkgconfigDependency +instance NFData PkgconfigDependency where rnf = genericRnf + +instance Pretty PkgconfigDependency where + pretty (PkgconfigDependency name ver) = + pretty name <+> pretty ver + +instance Parsec PkgconfigDependency where + parsec = do + name <- parsec + P.spaces + verRange <- parsec <|> pure anyVersion + pure $ PkgconfigDependency name verRange + +instance Text PkgconfigDependency where + parse = do name <- parse + Parse.skipSpaces + ver <- parse <++ return anyVersion + Parse.skipSpaces + return $ PkgconfigDependency name ver diff --git a/cabal/Cabal/Distribution/Types/PkgconfigName.hs b/cabal/Cabal/Distribution/Types/PkgconfigName.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/PkgconfigName.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.PkgconfigName + ( PkgconfigName, unPkgconfigName, mkPkgconfigName + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText + +import Distribution.Pretty +import Distribution.Parsec.Class +import Distribution.Text + +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp + +-- | A pkg-config library name +-- +-- This is parsed as any valid argument to the pkg-config utility. +-- +-- @since 2.0.0.2 +newtype PkgconfigName = PkgconfigName ShortText + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) + +-- | Convert 'PkgconfigName' to 'String' +-- +-- @since 2.0.0.2 +unPkgconfigName :: PkgconfigName -> String +unPkgconfigName (PkgconfigName s) = fromShortText s + +-- | Construct a 'PkgconfigName' from a 'String' +-- +-- 'mkPkgconfigName' is the inverse to 'unPkgconfigName' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'PkgconfigName' is valid +-- +-- @since 2.0.0.2 +mkPkgconfigName :: String -> PkgconfigName +mkPkgconfigName = PkgconfigName . toShortText + +-- | 'mkPkgconfigName' +-- +-- @since 2.0.0.2 +instance IsString PkgconfigName where + fromString = mkPkgconfigName + +instance Binary PkgconfigName + +-- pkg-config allows versions and other letters in package names, eg +-- "gtk+-2.0" is a valid pkg-config package _name_. It then has a package +-- version number like 2.10.13 +instance Pretty PkgconfigName where + pretty = Disp.text . unPkgconfigName + +instance Parsec PkgconfigName where + parsec = mkPkgconfigName <$> P.munch1 (\c -> isAlphaNum c || c `elem` "+-._") + +instance Text PkgconfigName where + parse = mkPkgconfigName + <$> Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-._") + +instance NFData PkgconfigName where + rnf (PkgconfigName pkg) = rnf pkg diff --git a/cabal/Cabal/Distribution/Types/SetupBuildInfo.hs b/cabal/Cabal/Distribution/Types/SetupBuildInfo.hs --- a/cabal/Cabal/Distribution/Types/SetupBuildInfo.hs +++ b/cabal/Cabal/Distribution/Types/SetupBuildInfo.hs @@ -8,7 +8,7 @@ import Prelude () import Distribution.Compat.Prelude -import Distribution.Package +import Distribution.Types.Dependency -- --------------------------------------------------------------------------- -- The SetupBuildInfo type @@ -17,9 +17,9 @@ -- To keep things simple for tools that compile Setup.hs we limit the -- options authors can specify to just Haskell package dependencies. -data SetupBuildInfo = SetupBuildInfo { - setupDepends :: [Dependency], - defaultSetupDepends :: Bool +data SetupBuildInfo = SetupBuildInfo + { setupDepends :: [Dependency] + , defaultSetupDepends :: Bool -- ^ Is this a default 'custom-setup' section added by the cabal-install -- code (as opposed to user-provided)? This field is only used -- internally, and doesn't correspond to anything in the .cabal @@ -30,9 +30,10 @@ instance Binary SetupBuildInfo instance Monoid SetupBuildInfo where - mempty = SetupBuildInfo [] False - mappend = (<>) + mempty = SetupBuildInfo [] False + mappend = (<>) instance Semigroup SetupBuildInfo where - a <> b = SetupBuildInfo (setupDepends a <> setupDepends b) - (defaultSetupDepends a || defaultSetupDepends b) + a <> b = SetupBuildInfo + (setupDepends a <> setupDepends b) + (defaultSetupDepends a || defaultSetupDepends b) diff --git a/cabal/Cabal/Distribution/Types/SetupBuildInfo/Lens.hs b/cabal/Cabal/Distribution/Types/SetupBuildInfo/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/SetupBuildInfo/Lens.hs @@ -0,0 +1,21 @@ +module Distribution.Types.SetupBuildInfo.Lens ( + SetupBuildInfo, + module Distribution.Types.SetupBuildInfo.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.SetupBuildInfo (SetupBuildInfo) + +import qualified Distribution.Types.SetupBuildInfo as T + +setupDepends :: Lens' SetupBuildInfo [Dependency] +setupDepends f s = fmap (\x -> s { T.setupDepends = x }) (f (T.setupDepends s)) +{-# INLINE setupDepends #-} + +defaultSetupDepends :: Lens' SetupBuildInfo Bool +defaultSetupDepends f s = fmap (\x -> s { T.defaultSetupDepends = x }) (f (T.defaultSetupDepends s)) +{-# INLINE defaultSetupDepends #-} diff --git a/cabal/Cabal/Distribution/Types/SourceRepo.hs b/cabal/Cabal/Distribution/Types/SourceRepo.hs --- a/cabal/Cabal/Distribution/Types/SourceRepo.hs +++ b/cabal/Cabal/Distribution/Types/SourceRepo.hs @@ -14,10 +14,15 @@ import Prelude () import Distribution.Compat.Prelude -import qualified Distribution.Compat.ReadP as Parse +import Distribution.Utils.Generic (lowercase) + +import Distribution.Pretty +import Distribution.Parsec.Class import Distribution.Text -import Text.PrettyPrint as Disp +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp -- ------------------------------------------------------------ -- * Source repos @@ -132,11 +137,15 @@ repoTypeAliases GnuArch = ["arch"] repoTypeAliases _ = [] -instance Text RepoKind where - disp RepoHead = Disp.text "head" - disp RepoThis = Disp.text "this" - disp (RepoKindUnknown other) = Disp.text other +instance Pretty RepoKind where + pretty RepoHead = Disp.text "head" + pretty RepoThis = Disp.text "this" + pretty (RepoKindUnknown other) = Disp.text other +instance Parsec RepoKind where + parsec = classifyRepoKind <$> P.munch1 isIdent + +instance Text RepoKind where parse = fmap classifyRepoKind ident classifyRepoKind :: String -> RepoKind @@ -145,22 +154,26 @@ "this" -> RepoThis _ -> RepoKindUnknown name +instance Pretty RepoType where + pretty (OtherRepoType other) = Disp.text other + pretty other = Disp.text (lowercase (show other)) + +instance Parsec RepoType where + parsec = classifyRepoType <$> P.munch1 isIdent + instance Text RepoType where - disp (OtherRepoType other) = Disp.text other - disp other = Disp.text (lowercase (show other)) parse = fmap classifyRepoType ident classifyRepoType :: String -> RepoType classifyRepoType s = - fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap + fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap where repoTypeMap = [ (name, repoType') | repoType' <- knownRepoTypes , name <- display repoType' : repoTypeAliases repoType' ] ident :: Parse.ReadP r String -ident = Parse.munch1 (\c -> isAlphaNum c || c == '_' || c == '-') - -lowercase :: String -> String -lowercase = map toLower +ident = Parse.munch1 isIdent +isIdent :: Char -> Bool +isIdent c = isAlphaNum c || c == '_' || c == '-' diff --git a/cabal/Cabal/Distribution/Types/SourceRepo/Lens.hs b/cabal/Cabal/Distribution/Types/SourceRepo/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/SourceRepo/Lens.hs @@ -0,0 +1,39 @@ +module Distribution.Types.SourceRepo.Lens ( + T.SourceRepo, + module Distribution.Types.SourceRepo.Lens, + ) where + +import Prelude() +import Distribution.Compat.Prelude +import Distribution.Compat.Lens + +import Distribution.Types.SourceRepo (SourceRepo, RepoKind, RepoType) +import qualified Distribution.Types.SourceRepo as T + +repoKind :: Lens' SourceRepo RepoKind +repoKind f s = fmap (\x -> s { T.repoKind = x }) (f (T.repoKind s)) +{-# INLINE repoKind #-} + +repoType :: Lens' SourceRepo (Maybe RepoType) +repoType f s = fmap (\x -> s { T.repoType = x }) (f (T.repoType s)) +{-# INLINE repoType #-} + +repoLocation :: Lens' SourceRepo (Maybe String) +repoLocation f s = fmap (\x -> s { T.repoLocation = x }) (f (T.repoLocation s)) +{-# INLINE repoLocation #-} + +repoModule :: Lens' SourceRepo (Maybe String) +repoModule f s = fmap (\x -> s { T.repoModule = x }) (f (T.repoModule s)) +{-# INLINE repoModule #-} + +repoBranch :: Lens' SourceRepo (Maybe String) +repoBranch f s = fmap (\x -> s { T.repoBranch = x }) (f (T.repoBranch s)) +{-# INLINE repoBranch #-} + +repoTag :: Lens' SourceRepo (Maybe String) +repoTag f s = fmap (\x -> s { T.repoTag = x }) (f (T.repoTag s)) +{-# INLINE repoTag #-} + +repoSubdir :: Lens' SourceRepo (Maybe FilePath) +repoSubdir f s = fmap (\x -> s { T.repoSubdir = x }) (f (T.repoSubdir s)) +{-# INLINE repoSubdir #-} diff --git a/cabal/Cabal/Distribution/Types/TargetInfo.hs b/cabal/Cabal/Distribution/Types/TargetInfo.hs --- a/cabal/Cabal/Distribution/Types/TargetInfo.hs +++ b/cabal/Cabal/Distribution/Types/TargetInfo.hs @@ -8,8 +8,8 @@ import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.Component +import Distribution.Types.UnitId -import Distribution.Package import Distribution.Compat.Graph (IsNode(..)) -- | The 'TargetInfo' contains all the information necessary to build a diff --git a/cabal/Cabal/Distribution/Types/TestSuite.hs b/cabal/Cabal/Distribution/Types/TestSuite.hs --- a/cabal/Cabal/Distribution/Types/TestSuite.hs +++ b/cabal/Cabal/Distribution/Types/TestSuite.hs @@ -16,10 +16,12 @@ import Distribution.Types.BuildInfo import Distribution.Types.TestType import Distribution.Types.TestSuiteInterface +import Distribution.Types.UnqualComponentName import Distribution.ModuleName -import Distribution.Package +import qualified Distribution.Types.BuildInfo.Lens as L + -- | A \"test-suite\" stanza in a cabal file. -- data TestSuite = TestSuite { @@ -28,6 +30,9 @@ testBuildInfo :: BuildInfo } deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance L.HasBuildInfo TestSuite where + buildInfo f l = (\x -> l { testBuildInfo = x }) <$> f (testBuildInfo l) instance Binary TestSuite diff --git a/cabal/Cabal/Distribution/Types/TestSuite/Lens.hs b/cabal/Cabal/Distribution/Types/TestSuite/Lens.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/TestSuite/Lens.hs @@ -0,0 +1,27 @@ +module Distribution.Types.TestSuite.Lens ( + TestSuite, + module Distribution.Types.TestSuite.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.TestSuite (TestSuite) +import Distribution.Types.TestSuiteInterface (TestSuiteInterface) +import Distribution.Types.UnqualComponentName (UnqualComponentName) + +import qualified Distribution.Types.TestSuite as T + +testName :: Lens' TestSuite UnqualComponentName +testName f s = fmap (\x -> s { T.testName = x }) (f (T.testName s)) +{-# INLINE testName #-} + +testInterface :: Lens' TestSuite TestSuiteInterface +testInterface f s = fmap (\x -> s { T.testInterface = x }) (f (T.testInterface s)) +{-# INLINE testInterface #-} + +testBuildInfo :: Lens' TestSuite BuildInfo +testBuildInfo f s = fmap (\x -> s { T.testBuildInfo = x }) (f (T.testBuildInfo s)) +{-# INLINE testBuildInfo #-} diff --git a/cabal/Cabal/Distribution/Types/TestType.hs b/cabal/Cabal/Distribution/Types/TestType.hs --- a/cabal/Cabal/Distribution/Types/TestType.hs +++ b/cabal/Cabal/Distribution/Types/TestType.hs @@ -1,18 +1,19 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Types.TestType ( TestType(..), knownTestTypes, ) where -import Prelude () import Distribution.Compat.Prelude - import Distribution.Version -import Distribution.Text +import Prelude () -import Text.PrettyPrint as Disp +import Distribution.Parsec.Class +import Distribution.Pretty +import Distribution.Text +import Text.PrettyPrint (char, text) -- | The \"test-type\" field in the test suite stanza. -- @@ -27,11 +28,18 @@ knownTestTypes = [ TestTypeExe (mkVersion [1,0]) , TestTypeLib (mkVersion [0,9]) ] -instance Text TestType where - disp (TestTypeExe ver) = text "exitcode-stdio-" <<>> disp ver - disp (TestTypeLib ver) = text "detailed-" <<>> disp ver - disp (TestTypeUnknown name ver) = text name <<>> char '-' <<>> disp ver +instance Pretty TestType where + pretty (TestTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver + pretty (TestTypeLib ver) = text "detailed-" <<>> pretty ver + pretty (TestTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver +instance Parsec TestType where + parsec = parsecStandard $ \ver name -> case name of + "exitcode-stdio" -> TestTypeExe ver + "detailed" -> TestTypeLib ver + _ -> TestTypeUnknown name ver + +instance Text TestType where parse = stdParse $ \ver name -> case name of "exitcode-stdio" -> TestTypeExe ver "detailed" -> TestTypeLib ver diff --git a/cabal/Cabal/Distribution/Types/UnitId.hs b/cabal/Cabal/Distribution/Types/UnitId.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/UnitId.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} + +module Distribution.Types.UnitId + ( UnitId, unUnitId, mkUnitId + , DefUnitId + , unsafeMkDefUnitId + , unDefUnitId + , newSimpleUnitId + , mkLegacyUnitId + , getHSLibraryName + , InstalledPackageId -- backwards compat + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText + +import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P +import Distribution.Pretty +import Distribution.Parsec.Class +import Distribution.Text +import Distribution.Types.ComponentId +import Distribution.Types.PackageId + +import Text.PrettyPrint (text) + +-- | A unit identifier identifies a (possibly instantiated) +-- package/component that can be installed the installed package +-- database. There are several types of components that can be +-- installed: +-- +-- * A traditional library with no holes, so that 'unitIdHash' +-- is @Nothing@. In the absence of Backpack, 'UnitId' +-- is the same as a 'ComponentId'. +-- +-- * An indefinite, Backpack library with holes. In this case, +-- 'unitIdHash' is still @Nothing@, but in the install, +-- there are only interfaces, no compiled objects. +-- +-- * An instantiated Backpack library with all the holes +-- filled in. 'unitIdHash' is a @Just@ a hash of the +-- instantiating mapping. +-- +-- A unit is a component plus the additional information on how the +-- holes are filled in. Thus there is a one to many relationship: for a +-- particular component there are many different ways of filling in the +-- holes, and each different combination is a unit (and has a separate +-- 'UnitId'). +-- +-- 'UnitId' is distinct from 'OpenUnitId', in that it is always +-- installed, whereas 'OpenUnitId' are intermediate unit identities +-- that arise during mixin linking, and don't necessarily correspond +-- to any actually installed unit. Since the mapping is not actually +-- recorded in a 'UnitId', you can't actually substitute over them +-- (but you can substitute over 'OpenUnitId'). See also +-- "Distribution.Backpack.FullUnitId" for a mechanism for expanding an +-- instantiated 'UnitId' to retrieve its mapping. +-- +-- Backwards compatibility note: if you need to get the string +-- representation of a UnitId to pass, e.g., as a @-package-id@ +-- flag, use the 'display' function, which will work on all +-- versions of Cabal. +-- +newtype UnitId = UnitId ShortText + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, NFData) + +{-# DEPRECATED InstalledPackageId "Use UnitId instead" #-} +type InstalledPackageId = UnitId + +instance Binary UnitId + +-- | The textual format for 'UnitId' coincides with the format +-- GHC accepts for @-package-id@. +-- +instance Pretty UnitId where + pretty = text . unUnitId + +-- | The textual format for 'UnitId' coincides with the format +-- GHC accepts for @-package-id@. +-- +instance Parsec UnitId where + parsec = mkUnitId <$> P.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") + +instance Text UnitId where + parse = mkUnitId <$> Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") + +-- | If you need backwards compatibility, consider using 'display' +-- instead, which is supported by all versions of Cabal. +-- +unUnitId :: UnitId -> String +unUnitId (UnitId s) = fromShortText s + +mkUnitId :: String -> UnitId +mkUnitId = UnitId . toShortText + +-- | 'mkUnitId' +-- +-- @since 2.0.0.2 +instance IsString UnitId where + fromString = mkUnitId + +-- | Create a unit identity with no associated hash directly +-- from a 'ComponentId'. +newSimpleUnitId :: ComponentId -> UnitId +newSimpleUnitId = mkUnitId . unComponentId + +-- | Make an old-style UnitId from a package identifier. +-- Assumed to be for the public library +mkLegacyUnitId :: PackageId -> UnitId +mkLegacyUnitId = newSimpleUnitId . mkComponentId . display + +-- | Returns library name prefixed with HS, suitable for filenames +getHSLibraryName :: UnitId -> String +getHSLibraryName uid = "HS" ++ display uid + +-- | A 'UnitId' for a definite package. The 'DefUnitId' invariant says +-- that a 'UnitId' identified this way is definite; i.e., it has no +-- unfilled holes. +newtype DefUnitId = DefUnitId { unDefUnitId :: UnitId } + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Pretty, Text) + +-- Workaround for a GHC 8.0.1 bug, see +-- https://github.com/haskell/cabal/issues/4793#issuecomment-334258288 +instance Parsec DefUnitId where + parsec = DefUnitId <$> parsec + +-- | Unsafely create a 'DefUnitId' from a 'UnitId'. Your responsibility +-- is to ensure that the 'DefUnitId' invariant holds. +unsafeMkDefUnitId :: UnitId -> DefUnitId +unsafeMkDefUnitId = DefUnitId diff --git a/cabal/Cabal/Distribution/Types/UnqualComponentName.hs b/cabal/Cabal/Distribution/Types/UnqualComponentName.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/UnqualComponentName.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Distribution.Types.UnqualComponentName + ( UnqualComponentName, unUnqualComponentName, mkUnqualComponentName + , packageNameToUnqualComponentName, unqualComponentNameToPackageName + ) where + +import Distribution.Compat.Prelude +import Distribution.Utils.ShortText +import Prelude () + +import Distribution.Parsec.Class +import Distribution.ParseUtils (parsePackageName) +import Distribution.Pretty +import Distribution.Text +import Distribution.Types.PackageName + +-- | An unqualified component name, for any kind of component. +-- +-- This is distinguished from a 'ComponentName' and 'ComponentId'. The former +-- also states which of a library, executable, etc the name refers too. The +-- later uniquely identifiers a component and its closure. +-- +-- @since 2.0.0.2 +newtype UnqualComponentName = UnqualComponentName ShortText + deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, + Semigroup, Monoid) -- TODO: bad enabler of bad monoids + +-- | Convert 'UnqualComponentName' to 'String' +-- +-- @since 2.0.0.2 +unUnqualComponentName :: UnqualComponentName -> String +unUnqualComponentName (UnqualComponentName s) = fromShortText s + +-- | Construct a 'UnqualComponentName' from a 'String' +-- +-- 'mkUnqualComponentName' is the inverse to 'unUnqualComponentName' +-- +-- Note: No validations are performed to ensure that the resulting +-- 'UnqualComponentName' is valid +-- +-- @since 2.0.0.2 +mkUnqualComponentName :: String -> UnqualComponentName +mkUnqualComponentName = UnqualComponentName . toShortText + +-- | 'mkUnqualComponentName' +-- +-- @since 2.0.0.2 +instance IsString UnqualComponentName where + fromString = mkUnqualComponentName + +instance Binary UnqualComponentName + +instance Pretty UnqualComponentName where + pretty = showToken . unUnqualComponentName + +instance Parsec UnqualComponentName where + parsec = mkUnqualComponentName <$> parsecUnqualComponentName + +instance Text UnqualComponentName where + parse = mkUnqualComponentName <$> parsePackageName + +instance NFData UnqualComponentName where + rnf (UnqualComponentName pkg) = rnf pkg + +-- TODO avoid String round trip with these PackageName <-> +-- UnqualComponentName converters. + +-- | Converts a package name to an unqualified component name +-- +-- Useful in legacy situations where a package name may refer to an internal +-- component, if one is defined with that name. +-- +-- @since 2.0.0.2 +packageNameToUnqualComponentName :: PackageName -> UnqualComponentName +packageNameToUnqualComponentName = mkUnqualComponentName . unPackageName + +-- | Converts an unqualified component name to a package name +-- +-- `packageNameToUnqualComponentName` is the inverse of +-- `unqualComponentNameToPackageName`. +-- +-- Useful in legacy situations where a package name may refer to an internal +-- component, if one is defined with that name. +-- +-- @since 2.0.0.2 +unqualComponentNameToPackageName :: UnqualComponentName -> PackageName +unqualComponentNameToPackageName = mkPackageName . unUnqualComponentName diff --git a/cabal/Cabal/Distribution/Types/Version.hs b/cabal/Cabal/Distribution/Types/Version.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/Version.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Types.Version ( + -- * Package versions + Version, + mkVersion, + mkVersion', + versionNumbers, + nullVersion, + alterVersion, + version0, + -- * Internal + validVersion, + ) where + +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec.Class +import Distribution.Pretty +import Distribution.Text + +import qualified Data.Version as Base +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import qualified Text.Read as Read + +-- | A 'Version' represents the version of a software entity. +-- +-- Instances of 'Eq' and 'Ord' are provided, which gives exact +-- equality and lexicographic ordering of the version number +-- components (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2, etc.). +-- +-- This type is opaque and distinct from the 'Base.Version' type in +-- "Data.Version" since @Cabal-2.0@. The difference extends to the +-- 'Binary' instance using a different (and more compact) encoding. +-- +-- @since 2.0.0.2 +data Version = PV0 {-# UNPACK #-} !Word64 + | PV1 !Int [Int] + -- NOTE: If a version fits into the packed Word64 + -- representation (i.e. at most four version components + -- which all fall into the [0..0xfffe] range), then PV0 + -- MUST be used. This is essential for the 'Eq' instance + -- to work. + deriving (Data,Eq,Generic,Typeable) + +instance Ord Version where + compare (PV0 x) (PV0 y) = compare x y + compare (PV1 x xs) (PV1 y ys) = case compare x y of + EQ -> compare xs ys + c -> c + compare (PV0 w) (PV1 y ys) = case compare x y of + EQ -> compare [x2,x3,x4] ys + c -> c + where + x = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 + x2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 + x3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 + x4 = fromIntegral (w .&. 0xffff) - 1 + compare (PV1 x xs) (PV0 w) = case compare x y of + EQ -> compare xs [y2,y3,y4] + c -> c + where + y = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 + y2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 + y3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 + y4 = fromIntegral (w .&. 0xffff) - 1 + +instance Show Version where + showsPrec d v = showParen (d > 10) + $ showString "mkVersion " + . showsPrec 11 (versionNumbers v) + +instance Read Version where + readPrec = Read.parens $ do + Read.Ident "mkVersion" <- Read.lexP + v <- Read.step Read.readPrec + return (mkVersion v) + +instance Binary Version + +instance NFData Version where + rnf (PV0 _) = () + rnf (PV1 _ ns) = rnf ns + +instance Pretty Version where + pretty ver + = Disp.hcat (Disp.punctuate (Disp.char '.') + (map Disp.int $ versionNumbers ver)) + +instance Parsec Version where + parsec = mkVersion <$> P.sepBy1 P.integral (P.char '.') <* tags + where + tags = do + ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) + case ts of + [] -> pure () + (_ : _) -> parsecWarning PWTVersionTag "version with tags" + +instance Text Version where + parse = do + branch <- Parse.sepBy1 parseNat (Parse.char '.') + -- allow but ignore tags: + _tags <- Parse.many (Parse.char '-' >> Parse.munch1 isAlphaNum) + return (mkVersion branch) + where + parseNat = read `fmap` Parse.munch1 isDigit + +-- | Construct 'Version' from list of version number components. +-- +-- For instance, @mkVersion [3,2,1]@ constructs a 'Version' +-- representing the version @3.2.1@. +-- +-- All version components must be non-negative. @mkVersion []@ +-- currently represents the special /null/ version; see also 'nullVersion'. +-- +-- @since 2.0.0.2 +mkVersion :: [Int] -> Version +-- TODO: add validity check; disallow 'mkVersion []' (we have +-- 'nullVersion' for that) +mkVersion [] = nullVersion +mkVersion (v1:[]) + | inWord16VerRep1 v1 = PV0 (mkWord64VerRep1 v1) + | otherwise = PV1 v1 [] + where + inWord16VerRep1 x1 = inWord16 (x1 .|. (x1+1)) + mkWord64VerRep1 y1 = mkWord64VerRep (y1+1) 0 0 0 + +mkVersion (v1:vs@(v2:[])) + | inWord16VerRep2 v1 v2 = PV0 (mkWord64VerRep2 v1 v2) + | otherwise = PV1 v1 vs + where + inWord16VerRep2 x1 x2 = inWord16 (x1 .|. (x1+1) + .|. x2 .|. (x2+1)) + mkWord64VerRep2 y1 y2 = mkWord64VerRep (y1+1) (y2+1) 0 0 + +mkVersion (v1:vs@(v2:v3:[])) + | inWord16VerRep3 v1 v2 v3 = PV0 (mkWord64VerRep3 v1 v2 v3) + | otherwise = PV1 v1 vs + where + inWord16VerRep3 x1 x2 x3 = inWord16 (x1 .|. (x1+1) + .|. x2 .|. (x2+1) + .|. x3 .|. (x3+1)) + mkWord64VerRep3 y1 y2 y3 = mkWord64VerRep (y1+1) (y2+1) (y3+1) 0 + +mkVersion (v1:vs@(v2:v3:v4:[])) + | inWord16VerRep4 v1 v2 v3 v4 = PV0 (mkWord64VerRep4 v1 v2 v3 v4) + | otherwise = PV1 v1 vs + where + inWord16VerRep4 x1 x2 x3 x4 = inWord16 (x1 .|. (x1+1) + .|. x2 .|. (x2+1) + .|. x3 .|. (x3+1) + .|. x4 .|. (x4+1)) + mkWord64VerRep4 y1 y2 y3 y4 = mkWord64VerRep (y1+1) (y2+1) (y3+1) (y4+1) + +mkVersion (v1:vs) = PV1 v1 vs + +-- | Version 0. A lower bound of 'Version'. +-- +-- @since 2.2 +version0 :: Version +version0 = mkVersion [0] + +{-# INLINE mkWord64VerRep #-} +mkWord64VerRep :: Int -> Int -> Int -> Int -> Word64 +mkWord64VerRep v1 v2 v3 v4 = + (fromIntegral v1 `shiftL` 48) + .|. (fromIntegral v2 `shiftL` 32) + .|. (fromIntegral v3 `shiftL` 16) + .|. fromIntegral v4 + +{-# INLINE inWord16 #-} +inWord16 :: Int -> Bool +inWord16 x = (fromIntegral x :: Word) <= 0xffff + +-- | Variant of 'Version' which converts a "Data.Version" 'Version' +-- into Cabal's 'Version' type. +-- +-- @since 2.0.0.2 +mkVersion' :: Base.Version -> Version +mkVersion' = mkVersion . Base.versionBranch + +-- | Unpack 'Version' into list of version number components. +-- +-- This is the inverse to 'mkVersion', so the following holds: +-- +-- > (versionNumbers . mkVersion) vs == vs +-- +-- @since 2.0.0.2 +versionNumbers :: Version -> [Int] +versionNumbers (PV1 n ns) = n:ns +versionNumbers (PV0 w) + | v1 < 0 = [] + | v2 < 0 = [v1] + | v3 < 0 = [v1,v2] + | v4 < 0 = [v1,v2,v3] + | otherwise = [v1,v2,v3,v4] + where + v1 = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 + v2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 + v3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 + v4 = fromIntegral (w .&. 0xffff) - 1 + + +-- | Constant representing the special /null/ 'Version' +-- +-- The 'nullVersion' compares (via 'Ord') as less than every proper +-- 'Version' value. +-- +-- @since 2.0.0.2 +nullVersion :: Version +-- TODO: at some point, 'mkVersion' may disallow creating /null/ +-- 'Version's +nullVersion = PV0 0 + +-- | Apply function to list of version number components +-- +-- > alterVersion f == mkVersion . f . versionNumbers +-- +-- @since 2.0.0.2 +alterVersion :: ([Int] -> [Int]) -> Version -> Version +alterVersion f = mkVersion . f . versionNumbers + +-- internal helper +validVersion :: Version -> Bool +validVersion v = v /= nullVersion && all (>=0) (versionNumbers v) + + diff --git a/cabal/Cabal/Distribution/Types/VersionInterval.hs b/cabal/Cabal/Distribution/Types/VersionInterval.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/VersionInterval.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Distribution.Types.VersionInterval ( + -- * Version intervals + VersionIntervals, + toVersionIntervals, + fromVersionIntervals, + withinIntervals, + versionIntervals, + mkVersionIntervals, + unionVersionIntervals, + intersectVersionIntervals, + invertVersionIntervals, + relaxLastInterval, + relaxHeadInterval, + + -- * Version intervals view + asVersionIntervals, + VersionInterval, + LowerBound(..), + UpperBound(..), + Bound(..), + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Control.Exception (assert) + +import Distribution.Types.Version +import Distribution.Types.VersionRange + +------------------------------------------------------------------------------- +-- VersionRange +------------------------------------------------------------------------------- + +-- | View a 'VersionRange' as a union of intervals. +-- +-- This provides a canonical view of the semantics of a 'VersionRange' as +-- opposed to the syntax of the expression used to define it. For the syntactic +-- view use 'foldVersionRange'. +-- +-- Each interval is non-empty. The sequence is in increasing order and no +-- intervals overlap or touch. Therefore only the first and last can be +-- unbounded. The sequence can be empty if the range is empty +-- (e.g. a range expression like @< 1 && > 2@). +-- +-- Other checks are trivial to implement using this view. For example: +-- +-- > isNoVersion vr | [] <- asVersionIntervals vr = True +-- > | otherwise = False +-- +-- > isSpecificVersion vr +-- > | [(LowerBound v InclusiveBound +-- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr +-- > , v == v' = Just v +-- > | otherwise = Nothing +-- +asVersionIntervals :: VersionRange -> [VersionInterval] +asVersionIntervals = versionIntervals . toVersionIntervals + + +------------------------------------------------------------------------------- +-- VersionInterval +------------------------------------------------------------------------------- + +-- | A complementary representation of a 'VersionRange'. Instead of a boolean +-- version predicate it uses an increasing sequence of non-overlapping, +-- non-empty intervals. +-- +-- The key point is that this representation gives a canonical representation +-- for the semantics of 'VersionRange's. This makes it easier to check things +-- like whether a version range is empty, covers all versions, or requires a +-- certain minimum or maximum version. It also makes it easy to check equality +-- or containment. It also makes it easier to identify \'simple\' version +-- predicates for translation into foreign packaging systems that do not +-- support complex version range expressions. +-- +newtype VersionIntervals = VersionIntervals [VersionInterval] + deriving (Eq, Show, Typeable) + +-- | Inspect the list of version intervals. +-- +versionIntervals :: VersionIntervals -> [VersionInterval] +versionIntervals (VersionIntervals is) = is + +type VersionInterval = (LowerBound, UpperBound) +data LowerBound = LowerBound Version !Bound deriving (Eq, Show) +data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show) +data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) + +minLowerBound :: LowerBound +minLowerBound = LowerBound (mkVersion [0]) InclusiveBound + +isVersion0 :: Version -> Bool +isVersion0 = (==) version0 + +instance Ord LowerBound where + LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of + LT -> True + EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) + GT -> False + +instance Ord UpperBound where + _ <= NoUpperBound = True + NoUpperBound <= UpperBound _ _ = False + UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of + LT -> True + EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) + GT -> False + +invariant :: VersionIntervals -> Bool +invariant (VersionIntervals intervals) = all validInterval intervals + && all doesNotTouch' adjacentIntervals + where + doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool + doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' + + adjacentIntervals :: [(VersionInterval, VersionInterval)] + adjacentIntervals + | null intervals = [] + | otherwise = zip intervals (tail intervals) + +checkInvariant :: VersionIntervals -> VersionIntervals +checkInvariant is = assert (invariant is) is + +-- | Directly construct a 'VersionIntervals' from a list of intervals. +-- +-- In @Cabal-2.2@ the 'Maybe' is dropped from the result type. +-- +mkVersionIntervals :: [VersionInterval] -> VersionIntervals +mkVersionIntervals intervals + | invariant (VersionIntervals intervals) = VersionIntervals intervals + | otherwise + = checkInvariant + . foldl' (flip insertInterval) (VersionIntervals []) + . filter validInterval + $ intervals + +insertInterval :: VersionInterval -> VersionIntervals -> VersionIntervals +insertInterval i is = unionVersionIntervals (VersionIntervals [i]) is + +validInterval :: (LowerBound, UpperBound) -> Bool +validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i + where + validLower (LowerBound v _) = validVersion v + validUpper NoUpperBound = True + validUpper (UpperBound v _) = validVersion v + +-- Check an interval is non-empty +-- +nonEmpty :: VersionInterval -> Bool +nonEmpty (_, NoUpperBound ) = True +nonEmpty (LowerBound l lb, UpperBound u ub) = + (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) + +-- Check an upper bound does not intersect, or even touch a lower bound: +-- +-- ---| or ---) but not ---] or ---) or ---] +-- |--- (--- (--- [--- [--- +-- +doesNotTouch :: UpperBound -> LowerBound -> Bool +doesNotTouch NoUpperBound _ = False +doesNotTouch (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) + +-- | Check an upper bound does not intersect a lower bound: +-- +-- ---| or ---) or ---] or ---) but not ---] +-- |--- (--- (--- [--- [--- +-- +doesNotIntersect :: UpperBound -> LowerBound -> Bool +doesNotIntersect NoUpperBound _ = False +doesNotIntersect (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) + +-- | Test if a version falls within the version intervals. +-- +-- It exists mostly for completeness and testing. It satisfies the following +-- properties: +-- +-- > withinIntervals v (toVersionIntervals vr) = withinRange v vr +-- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs) +-- +withinIntervals :: Version -> VersionIntervals -> Bool +withinIntervals v (VersionIntervals intervals) = any withinInterval intervals + where + withinInterval (lowerBound, upperBound) = withinLower lowerBound + && withinUpper upperBound + withinLower (LowerBound v' ExclusiveBound) = v' < v + withinLower (LowerBound v' InclusiveBound) = v' <= v + + withinUpper NoUpperBound = True + withinUpper (UpperBound v' ExclusiveBound) = v' > v + withinUpper (UpperBound v' InclusiveBound) = v' >= v + +-- | Convert a 'VersionRange' to a sequence of version intervals. +-- +toVersionIntervals :: VersionRange -> VersionIntervals +toVersionIntervals = foldVersionRange + ( chkIvl (minLowerBound, NoUpperBound)) + (\v -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)) + (\v -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound)) + (\v -> if isVersion0 v then VersionIntervals [] else + chkIvl (minLowerBound, UpperBound v ExclusiveBound)) + unionVersionIntervals + intersectVersionIntervals + where + chkIvl interval = checkInvariant (VersionIntervals [interval]) + +-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression +-- representing the version intervals. +-- +fromVersionIntervals :: VersionIntervals -> VersionRange +fromVersionIntervals (VersionIntervals []) = noVersion +fromVersionIntervals (VersionIntervals intervals) = + foldr1 unionVersionRanges [ interval l u | (l, u) <- intervals ] + + where + interval (LowerBound v InclusiveBound) + (UpperBound v' InclusiveBound) | v == v' + = thisVersion v + interval (LowerBound v InclusiveBound) + (UpperBound v' ExclusiveBound) | isWildcardRange v v' + = withinVersion v + interval l u = lowerBound l `intersectVersionRanges'` upperBound u + + lowerBound (LowerBound v InclusiveBound) + | isVersion0 v = Nothing + | otherwise = Just (orLaterVersion v) + lowerBound (LowerBound v ExclusiveBound) = Just (laterVersion v) + + upperBound NoUpperBound = Nothing + upperBound (UpperBound v InclusiveBound) = Just (orEarlierVersion v) + upperBound (UpperBound v ExclusiveBound) = Just (earlierVersion v) + + intersectVersionRanges' Nothing Nothing = anyVersion + intersectVersionRanges' (Just vr) Nothing = vr + intersectVersionRanges' Nothing (Just vr) = vr + intersectVersionRanges' (Just vr) (Just vr') = intersectVersionRanges vr vr' + +unionVersionIntervals :: VersionIntervals -> VersionIntervals + -> VersionIntervals +unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = + checkInvariant (VersionIntervals (union is0 is'0)) + where + union is [] = is + union [] is' = is' + union (i:is) (i':is') = case unionInterval i i' of + Left Nothing -> i : union is (i' :is') + Left (Just i'') -> union is (i'':is') + Right Nothing -> i' : union (i :is) is' + Right (Just i'') -> union (i'':is) is' + +unionInterval :: VersionInterval -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +unionInterval (lower , upper ) (lower', upper') + + -- Non-intersecting intervals with the left interval ending first + | upper `doesNotTouch` lower' = Left Nothing + + -- Non-intersecting intervals with the right interval first + | upper' `doesNotTouch` lower = Right Nothing + + -- Complete or partial overlap, with the left interval ending first + | upper <= upper' = lowerBound `seq` + Left (Just (lowerBound, upper')) + + -- Complete or partial overlap, with the left interval ending first + | otherwise = lowerBound `seq` + Right (Just (lowerBound, upper)) + where + lowerBound = min lower lower' + +intersectVersionIntervals :: VersionIntervals -> VersionIntervals + -> VersionIntervals +intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = + checkInvariant (VersionIntervals (intersect is0 is'0)) + where + intersect _ [] = [] + intersect [] _ = [] + intersect (i:is) (i':is') = case intersectInterval i i' of + Left Nothing -> intersect is (i':is') + Left (Just i'') -> i'' : intersect is (i':is') + Right Nothing -> intersect (i:is) is' + Right (Just i'') -> i'' : intersect (i:is) is' + +intersectInterval :: VersionInterval -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +intersectInterval (lower , upper ) (lower', upper') + + -- Non-intersecting intervals with the left interval ending first + | upper `doesNotIntersect` lower' = Left Nothing + + -- Non-intersecting intervals with the right interval first + | upper' `doesNotIntersect` lower = Right Nothing + + -- Complete or partial overlap, with the left interval ending first + | upper <= upper' = lowerBound `seq` + Left (Just (lowerBound, upper)) + + -- Complete or partial overlap, with the right interval ending first + | otherwise = lowerBound `seq` + Right (Just (lowerBound, upper')) + where + lowerBound = max lower lower' + +invertVersionIntervals :: VersionIntervals + -> VersionIntervals +invertVersionIntervals (VersionIntervals xs) = + case xs of + -- Empty interval set + [] -> VersionIntervals [(noLowerBound, NoUpperBound)] + -- Interval with no lower bound + ((lb, ub) : more) | lb == noLowerBound -> + VersionIntervals $ invertVersionIntervals' ub more + -- Interval with a lower bound + ((lb, ub) : more) -> + VersionIntervals $ (noLowerBound, invertLowerBound lb) + : invertVersionIntervals' ub more + where + -- Invert subsequent version intervals given the upper bound of + -- the intervals already inverted. + invertVersionIntervals' :: UpperBound + -> [(LowerBound, UpperBound)] + -> [(LowerBound, UpperBound)] + invertVersionIntervals' NoUpperBound [] = [] + invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)] + invertVersionIntervals' ub0 [(lb, NoUpperBound)] = + [(invertUpperBound ub0, invertLowerBound lb)] + invertVersionIntervals' ub0 ((lb, ub1) : more) = + (invertUpperBound ub0, invertLowerBound lb) + : invertVersionIntervals' ub1 more + + invertLowerBound :: LowerBound -> UpperBound + invertLowerBound (LowerBound v b) = UpperBound v (invertBound b) + + invertUpperBound :: UpperBound -> LowerBound + invertUpperBound (UpperBound v b) = LowerBound v (invertBound b) + invertUpperBound NoUpperBound = error "NoUpperBound: unexpected" + + invertBound :: Bound -> Bound + invertBound ExclusiveBound = InclusiveBound + invertBound InclusiveBound = ExclusiveBound + + noLowerBound :: LowerBound + noLowerBound = LowerBound (mkVersion [0]) InclusiveBound + + +relaxLastInterval :: VersionIntervals -> VersionIntervals +relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs) + where + relaxLastInterval' [] = [] + relaxLastInterval' [(l,_)] = [(l, NoUpperBound)] + relaxLastInterval' (i:is) = i : relaxLastInterval' is + +relaxHeadInterval :: VersionIntervals -> VersionIntervals +relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs) + where + relaxHeadInterval' [] = [] + relaxHeadInterval' ((_,u):is) = (minLowerBound,u) : is diff --git a/cabal/Cabal/Distribution/Types/VersionRange.hs b/cabal/Cabal/Distribution/Types/VersionRange.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Types/VersionRange.hs @@ -0,0 +1,526 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +module Distribution.Types.VersionRange ( + -- * Version ranges + VersionRange(..), + + -- ** Constructing + anyVersion, noVersion, + thisVersion, notThisVersion, + laterVersion, earlierVersion, + orLaterVersion, orEarlierVersion, + unionVersionRanges, intersectVersionRanges, + withinVersion, + majorBoundVersion, + + -- ** Inspection + -- + -- See "Distribution.Version" for more utilities. + withinRange, + foldVersionRange, + normaliseVersionRange, + stripParensVersionRange, + hasUpperBound, + hasLowerBound, + + -- ** Cata & ana + VersionRangeF (..), + cataVersionRange, + anaVersionRange, + hyloVersionRange, + projectVersionRange, + embedVersionRange, + + -- ** Utilities + wildcardUpperBound, + majorUpperBound, + isWildcardRange, + ) where + +import Distribution.Compat.Prelude +import Prelude () +import Distribution.Types.Version + +import Distribution.Pretty +import Distribution.Parsec.Class +import Distribution.Text +import Text.PrettyPrint ((<+>)) + +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P + +data VersionRange + = AnyVersion + | ThisVersion Version -- = version + | LaterVersion Version -- > version (NB. not >=) + | OrLaterVersion Version -- >= version + | EarlierVersion Version -- < version + | OrEarlierVersion Version -- <= version + | WildcardVersion Version -- == ver.* (same as >= ver && < ver+1) + | MajorBoundVersion Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1) + | UnionVersionRanges VersionRange VersionRange + | IntersectVersionRanges VersionRange VersionRange + | VersionRangeParens VersionRange -- just '(exp)' parentheses syntax + deriving (Data, Eq, Generic, Read, Show, Typeable) + +instance Binary VersionRange + +instance NFData VersionRange where rnf = genericRnf + +{-# DeprecateD AnyVersion + "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED ThisVersion + "Use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED LaterVersion + "Use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED EarlierVersion + "Use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED WildcardVersion + "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED UnionVersionRanges + "Use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED IntersectVersionRanges + "Use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'"#-} + +-- | The version range @-any@. That is, a version range containing all +-- versions. +-- +-- > withinRange v anyVersion = True +-- +anyVersion :: VersionRange +anyVersion = AnyVersion + +-- | The empty version range, that is a version range containing no versions. +-- +-- This can be constructed using any unsatisfiable version range expression, +-- for example @> 1 && < 1@. +-- +-- > withinRange v noVersion = False +-- +noVersion :: VersionRange +noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v) + where v = mkVersion [1] + +-- | The version range @== v@ +-- +-- > withinRange v' (thisVersion v) = v' == v +-- +thisVersion :: Version -> VersionRange +thisVersion = ThisVersion + +-- | The version range @< v || > v@ +-- +-- > withinRange v' (notThisVersion v) = v' /= v +-- +notThisVersion :: Version -> VersionRange +notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) + +-- | The version range @> v@ +-- +-- > withinRange v' (laterVersion v) = v' > v +-- +laterVersion :: Version -> VersionRange +laterVersion = LaterVersion + +-- | The version range @>= v@ +-- +-- > withinRange v' (orLaterVersion v) = v' >= v +-- +orLaterVersion :: Version -> VersionRange +orLaterVersion = OrLaterVersion + +-- | The version range @< v@ +-- +-- > withinRange v' (earlierVersion v) = v' < v +-- +earlierVersion :: Version -> VersionRange +earlierVersion = EarlierVersion + +-- | The version range @<= v@ +-- +-- > withinRange v' (orEarlierVersion v) = v' <= v +-- +orEarlierVersion :: Version -> VersionRange +orEarlierVersion = OrEarlierVersion + +-- | The version range @vr1 || vr2@ +-- +-- > withinRange v' (unionVersionRanges vr1 vr2) +-- > = withinRange v' vr1 || withinRange v' vr2 +-- +unionVersionRanges :: VersionRange -> VersionRange -> VersionRange +unionVersionRanges = UnionVersionRanges + +-- | The version range @vr1 && vr2@ +-- +-- > withinRange v' (intersectVersionRanges vr1 vr2) +-- > = withinRange v' vr1 && withinRange v' vr2 +-- +intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange +intersectVersionRanges = IntersectVersionRanges + +-- | The version range @== v.*@. +-- +-- For example, for version @1.2@, the version range @== 1.2.*@ is the same as +-- @>= 1.2 && < 1.3@ +-- +-- > withinRange v' (laterVersion v) = v' >= v && v' < upper v +-- > where +-- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t +-- +withinVersion :: Version -> VersionRange +withinVersion = WildcardVersion + +-- | The version range @^>= v@. +-- +-- For example, for version @1.2.3.4@, the version range @^>= 1.2.3.4@ is the same as +-- @>= 1.2.3.4 && < 1.3@. +-- +-- Note that @^>= 1@ is equivalent to @>= 1 && < 1.1@. +-- +-- @since 2.0.0.2 +majorBoundVersion :: Version -> VersionRange +majorBoundVersion = MajorBoundVersion + +-- | F-Algebra of 'VersionRange'. See 'cataVersionRange'. +-- +-- @since 2.2 +data VersionRangeF a + = AnyVersionF + | ThisVersionF Version -- = version + | LaterVersionF Version -- > version (NB. not >=) + | OrLaterVersionF Version -- >= version + | EarlierVersionF Version -- < version + | OrEarlierVersionF Version -- <= version + | WildcardVersionF Version -- == ver.* (same as >= ver && < ver+1) + | MajorBoundVersionF Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1) + | UnionVersionRangesF a a + | IntersectVersionRangesF a a + | VersionRangeParensF a + deriving (Data, Eq, Generic, Read, Show, Typeable, Functor, Foldable, Traversable) + +-- | @since 2.2 +projectVersionRange :: VersionRange -> VersionRangeF VersionRange +projectVersionRange AnyVersion = AnyVersionF +projectVersionRange (ThisVersion v) = ThisVersionF v +projectVersionRange (LaterVersion v) = LaterVersionF v +projectVersionRange (OrLaterVersion v) = OrLaterVersionF v +projectVersionRange (EarlierVersion v) = EarlierVersionF v +projectVersionRange (OrEarlierVersion v) = OrEarlierVersionF v +projectVersionRange (WildcardVersion v) = WildcardVersionF v +projectVersionRange (MajorBoundVersion v) = MajorBoundVersionF v +projectVersionRange (UnionVersionRanges a b) = UnionVersionRangesF a b +projectVersionRange (IntersectVersionRanges a b) = IntersectVersionRangesF a b +projectVersionRange (VersionRangeParens a) = VersionRangeParensF a + +-- | Fold 'VersionRange'. +-- +-- @since 2.2 +cataVersionRange :: (VersionRangeF a -> a) -> VersionRange -> a +cataVersionRange f = c where c = f . fmap c . projectVersionRange + +-- | @since 2.2 +embedVersionRange :: VersionRangeF VersionRange -> VersionRange +embedVersionRange AnyVersionF = AnyVersion +embedVersionRange (ThisVersionF v) = ThisVersion v +embedVersionRange (LaterVersionF v) = LaterVersion v +embedVersionRange (OrLaterVersionF v) = OrLaterVersion v +embedVersionRange (EarlierVersionF v) = EarlierVersion v +embedVersionRange (OrEarlierVersionF v) = OrEarlierVersion v +embedVersionRange (WildcardVersionF v) = WildcardVersion v +embedVersionRange (MajorBoundVersionF v) = MajorBoundVersion v +embedVersionRange (UnionVersionRangesF a b) = UnionVersionRanges a b +embedVersionRange (IntersectVersionRangesF a b) = IntersectVersionRanges a b +embedVersionRange (VersionRangeParensF a) = VersionRangeParens a + +-- | Unfold 'VersionRange'. +-- +-- @since 2.2 +anaVersionRange :: (a -> VersionRangeF a) -> a -> VersionRange +anaVersionRange g = a where a = embedVersionRange . fmap a . g + + +-- | Fold over the basic syntactic structure of a 'VersionRange'. +-- +-- This provides a syntactic view of the expression defining the version range. +-- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented +-- in terms of the other basic syntax. +-- +-- For a semantic view use 'asVersionIntervals'. +-- +foldVersionRange :: a -- ^ @\"-any\"@ version + -> (Version -> a) -- ^ @\"== v\"@ + -> (Version -> a) -- ^ @\"> v\"@ + -> (Version -> a) -- ^ @\"< v\"@ + -> (a -> a -> a) -- ^ @\"_ || _\"@ union + -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection + -> VersionRange -> a +foldVersionRange anyv this later earlier union intersect = fold + where + fold = cataVersionRange alg + + alg AnyVersionF = anyv + alg (ThisVersionF v) = this v + alg (LaterVersionF v) = later v + alg (OrLaterVersionF v) = union (this v) (later v) + alg (EarlierVersionF v) = earlier v + alg (OrEarlierVersionF v) = union (this v) (earlier v) + alg (WildcardVersionF v) = fold (wildcard v) + alg (MajorBoundVersionF v) = fold (majorBound v) + alg (UnionVersionRangesF v1 v2) = union v1 v2 + alg (IntersectVersionRangesF v1 v2) = intersect v1 v2 + alg (VersionRangeParensF v) = v + + wildcard v = intersectVersionRanges + (orLaterVersion v) + (earlierVersion (wildcardUpperBound v)) + + majorBound v = intersectVersionRanges + (orLaterVersion v) + (earlierVersion (majorUpperBound v)) + +-- | Refold 'VersionRange' +-- +-- @since 2.2 +hyloVersionRange :: (VersionRangeF VersionRange -> VersionRange) + -> (VersionRange -> VersionRangeF VersionRange) + -> VersionRange -> VersionRange +hyloVersionRange f g = h where h = f . fmap h . g + +-- | Normalise 'VersionRange'. +-- +-- In particular collapse @(== v || > v)@ into @>= v@, and so on. +normaliseVersionRange :: VersionRange -> VersionRange +normaliseVersionRange = hyloVersionRange embed projectVersionRange + where + -- == v || > v, > v || == v ==> >= v + embed (UnionVersionRangesF (ThisVersion v) (LaterVersion v')) | v == v' = + orLaterVersion v + embed (UnionVersionRangesF (LaterVersion v) (ThisVersion v')) | v == v' = + orLaterVersion v + + -- == v || < v, < v || == v ==> <= v + embed (UnionVersionRangesF (ThisVersion v) (EarlierVersion v')) | v == v' = + orEarlierVersion v + embed (UnionVersionRangesF (EarlierVersion v) (ThisVersion v')) | v == v' = + orEarlierVersion v + + -- otherwise embed normally + embed vr = embedVersionRange vr + +-- | Remove 'VersionRangeParens' constructors. +-- +-- @since 2.2 +stripParensVersionRange :: VersionRange -> VersionRange +stripParensVersionRange = hyloVersionRange embed projectVersionRange + where + embed (VersionRangeParensF vr) = vr + embed vr = embedVersionRange vr + +-- | Does this version fall within the given range? +-- +-- This is the evaluation function for the 'VersionRange' type. +-- +withinRange :: Version -> VersionRange -> Bool +withinRange v = foldVersionRange + True + (\v' -> v == v') + (\v' -> v > v') + (\v' -> v < v') + (||) + (&&) + +---------------------------- +-- Wildcard range utilities +-- + +-- | @since 2.2 +wildcardUpperBound :: Version -> Version +wildcardUpperBound = alterVersion $ + \lowerBound -> init lowerBound ++ [last lowerBound + 1] + +isWildcardRange :: Version -> Version -> Bool +isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2) + where check (n:[]) (m:[]) | n+1 == m = True + check (n:ns) (m:ms) | n == m = check ns ms + check _ _ = False + +-- | Compute next greater major version to be used as upper bound +-- +-- Example: @0.4.1@ produces the version @0.5@ which then can be used +-- to construct a range @>= 0.4.1 && < 0.5@ +-- +-- @since 2.2 +majorUpperBound :: Version -> Version +majorUpperBound = alterVersion $ \numbers -> case numbers of + [] -> [0,1] -- should not happen + [m1] -> [m1,1] -- e.g. version '1' + (m1:m2:_) -> [m1,m2+1] + +------------------------------------------------------------------------------- +-- Parsec & Pretty +------------------------------------------------------------------------------- + +instance Pretty VersionRange where + pretty = fst . cataVersionRange alg + where + alg AnyVersionF = (Disp.text "-any", 0 :: Int) + alg (ThisVersionF v) = (Disp.text "==" <<>> pretty v, 0) + alg (LaterVersionF v) = (Disp.char '>' <<>> pretty v, 0) + alg (OrLaterVersionF v) = (Disp.text ">=" <<>> pretty v, 0) + alg (EarlierVersionF v) = (Disp.char '<' <<>> pretty v, 0) + alg (OrEarlierVersionF v) = (Disp.text "<=" <<>> pretty v, 0) + alg (WildcardVersionF v) = (Disp.text "==" <<>> dispWild v, 0) + alg (MajorBoundVersionF v) = (Disp.text "^>=" <<>> pretty v, 0) + alg (UnionVersionRangesF (r1, p1) (r2, p2)) = + (punct 1 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2) + alg (IntersectVersionRangesF (r1, p1) (r2, p2)) = + (punct 0 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1) + alg (VersionRangeParensF (r, _)) = + (Disp.parens r, 0) + + dispWild ver = + Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int $ versionNumbers ver)) + <<>> Disp.text ".*" + + punct p p' | p < p' = Disp.parens + | otherwise = id + +instance Parsec VersionRange where + parsec = expr + where + expr = do P.spaces + t <- term + P.spaces + (do _ <- P.string "||" + P.spaces + e <- expr + return (unionVersionRanges t e) + <|> + return t) + term = do f <- factor + P.spaces + (do _ <- P.string "&&" + P.spaces + t <- term + return (intersectVersionRanges f t) + <|> + return f) + factor = P.choice + $ parens expr + : parseAnyVersion + : parseNoVersion + : parseWildcardRange + : map parseRangeOp rangeOps + parseAnyVersion = P.string "-any" >> return anyVersion + parseNoVersion = P.string "-none" >> return noVersion + + parseWildcardRange = P.try $ do + _ <- P.string "==" + P.spaces + branch <- some (P.integral <* P.char '.') + _ <- P.char '*' + return (withinVersion (mkVersion branch)) + + parens p = P.between + (P.char '(' >> P.spaces) + (P.char ')' >> P.spaces) + (do a <- p + P.spaces + return (VersionRangeParens a)) + + -- TODO: make those non back-tracking + parseRangeOp (s,f) = P.try (P.string s *> P.spaces *> fmap f parsec) + rangeOps = [ ("<", earlierVersion), + ("<=", orEarlierVersion), + (">", laterVersion), + (">=", orLaterVersion), + ("^>=", majorBoundVersion), + ("==", thisVersion) ] + +instance Text VersionRange where + parse = expr + where + expr = do Parse.skipSpaces + t <- term + Parse.skipSpaces + (do _ <- Parse.string "||" + Parse.skipSpaces + e <- expr + return (UnionVersionRanges t e) + Parse.+++ + return t) + term = do f <- factor + Parse.skipSpaces + (do _ <- Parse.string "&&" + Parse.skipSpaces + t <- term + return (IntersectVersionRanges f t) + Parse.+++ + return f) + factor = Parse.choice $ parens expr + : parseAnyVersion + : parseNoVersion + : parseWildcardRange + : map parseRangeOp rangeOps + parseAnyVersion = Parse.string "-any" >> return AnyVersion + parseNoVersion = Parse.string "-none" >> return noVersion + + parseWildcardRange = do + _ <- Parse.string "==" + Parse.skipSpaces + branch <- Parse.sepBy1 digits (Parse.char '.') + _ <- Parse.char '.' + _ <- Parse.char '*' + return (WildcardVersion (mkVersion branch)) + + parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces) + (Parse.char ')' >> Parse.skipSpaces) + (do a <- p + Parse.skipSpaces + return (VersionRangeParens a)) + + digits = do + firstDigit <- Parse.satisfy isDigit + if firstDigit == '0' + then return 0 + else do rest <- Parse.munch isDigit + return (read (firstDigit : rest)) -- TODO: eradicateNoParse + + parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse + rangeOps = [ ("<", EarlierVersion), + ("<=", orEarlierVersion), + (">", LaterVersion), + (">=", orLaterVersion), + ("^>=", MajorBoundVersion), + ("==", ThisVersion) ] + +-- | Does the version range have an upper bound? +-- +-- @since 1.24.0.0 +hasUpperBound :: VersionRange -> Bool +hasUpperBound = foldVersionRange + False + (const True) + (const False) + (const True) + (&&) (||) + +-- | Does the version range have an explicit lower bound? +-- +-- Note: this function only considers the user-specified lower bounds, but not +-- the implicit >=0 lower bound. +-- +-- @since 1.24.0.0 +hasLowerBound :: VersionRange -> Bool +hasLowerBound = foldVersionRange + False + (const True) + (const True) + (const False) + (&&) (||) diff --git a/cabal/Cabal/Distribution/Utils/BinaryWithFingerprint.hs b/cabal/Cabal/Distribution/Utils/BinaryWithFingerprint.hs deleted file mode 100644 --- a/cabal/Cabal/Distribution/Utils/BinaryWithFingerprint.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} --- | Support for binary serialization with a fingerprint. -module Distribution.Utils.BinaryWithFingerprint ( - encodeWithFingerprint, - decodeWithFingerprint, - decodeWithFingerprintOrFailIO, -) where - -#if MIN_VERSION_base(4,8,0) - -import Distribution.Compat.Binary -import Data.ByteString.Lazy (ByteString) -import Control.Exception - -import Data.Binary.Get -import Data.Binary.Put - -import GHC.Generics -import GHC.Fingerprint -import Data.Typeable -import Control.Monad - --- | Private wrapper type so we can give 'Binary' instance for --- 'Fingerprint' -newtype FP = FP Fingerprint - -instance Binary FP where - put (FP (Fingerprint a b)) = put a >> put b - get = do - a <- get - b <- get - return (FP (Fingerprint a b)) - -fingerprintRep :: forall a. Typeable (Rep a) => Proxy a -> Fingerprint -fingerprintRep _ = typeRepFingerprint (typeRep (Proxy :: Proxy (Rep a))) - --- | Encode a value, recording a fingerprint in the header. --- --- The fingerprint is GHC's Typeable fingerprint associated with --- the Generic Rep of a type: this fingerprint is better than --- the fingerprint of the type itself, as it changes when the --- representation changes (and thus the binary serialization format --- changes.) --- -encodeWithFingerprint :: forall a. (Binary a, Typeable (Rep a)) => a -> ByteString -encodeWithFingerprint x = runPut $ do - put (FP (fingerprintRep (Proxy :: Proxy a))) - put x - --- | Decode a value, verifying the fingerprint in the header. --- -decodeWithFingerprint :: forall a. (Binary a, Typeable (Rep a)) => ByteString -> a -decodeWithFingerprint = runGet $ do - FP fp <- get - let expect_fp = fingerprintRep (Proxy :: Proxy a) - when (expect_fp /= fp) $ - fail $ "Expected fingerprint " ++ show expect_fp ++ - " but got " ++ show fp - get - --- | Decode a value, forcing the decoded value to discover decoding errors --- and report them. --- -decodeWithFingerprintOrFailIO :: (Binary a, Typeable (Rep a)) => ByteString -> IO (Either String a) -decodeWithFingerprintOrFailIO bs = - catch (evaluate (decodeWithFingerprint bs) >>= return . Right) - $ \(ErrorCall str) -> return $ Left str - -#else - -import Distribution.Compat.Binary -import Data.ByteString.Lazy (ByteString) - --- Dummy implementations that don't actually save fingerprints - -encodeWithFingerprint :: Binary a => a -> ByteString -encodeWithFingerprint = encode - -decodeWithFingerprint :: Binary a => ByteString -> a -decodeWithFingerprint = decode - -decodeWithFingerprintOrFailIO :: Binary a => ByteString -> IO (Either String a) -decodeWithFingerprintOrFailIO = decodeOrFailIO - -#endif diff --git a/cabal/Cabal/Distribution/Utils/Generic.hs b/cabal/Cabal/Distribution/Utils/Generic.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Utils/Generic.hs @@ -0,0 +1,452 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE BangPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Utils +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- License : BSD3 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A large and somewhat miscellaneous collection of utility functions used +-- throughout the rest of the Cabal lib and in other tools that use the Cabal +-- lib like @cabal-install@. It has a very simple set of logging actions. It +-- has low level functions for running programs, a bunch of wrappers for +-- various directory and file functions that do extra logging. + +module Distribution.Utils.Generic ( + -- * reading and writing files safely + withFileContents, + writeFileAtomic, + + -- * Unicode + + -- ** Conversions + fromUTF8BS, + fromUTF8LBS, + + toUTF8BS, + toUTF8LBS, + + -- ** File I/O + readUTF8File, + withUTF8FileContents, + writeUTF8File, + + -- ** BOM + ignoreBOM, + + -- ** Misc + normaliseLineEndings, + + -- * generic utils + dropWhileEndLE, + takeWhileEndLE, + equating, + comparing, + isInfixOf, + intercalate, + lowercase, + isAscii, + isAsciiAlpha, + isAsciiAlphaNum, + listUnion, + listUnionRight, + ordNub, + ordNubBy, + ordNubRight, + safeTail, + unintersperse, + wrapText, + wrapLine, + unfoldrM, + spanMaybe, + breakMaybe, + + -- * FilePath stuff + isAbsoluteOnAnyPlatform, + isRelativeOnAnyPlatform, + ) where + +import Prelude () +import Distribution.Compat.Prelude + +import Distribution.Utils.String + +import Data.List + ( isInfixOf ) +import Data.Ord + ( comparing ) +import qualified Data.ByteString.Lazy as BS +import qualified Data.Set as Set + +import qualified Data.ByteString as SBS + +import System.Directory + ( removeFile, renameFile ) +import System.FilePath + ( (<.>), splitFileName ) +import System.IO + ( withFile, withBinaryFile + , openBinaryTempFileWithDefaultPermissions + , IOMode(ReadMode), hGetContents, hClose ) +import qualified Control.Exception as Exception + +-- ----------------------------------------------------------------------------- +-- Helper functions + +-- | Wraps text to the default line width. Existing newlines are preserved. +wrapText :: String -> String +wrapText = unlines + . map (intercalate "\n" + . map unwords + . wrapLine 79 + . words) + . lines + +-- | Wraps a list of words to a list of lines of words of a particular width. +wrapLine :: Int -> [String] -> [[String]] +wrapLine width = wrap 0 [] + where wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w:ws) + | length w + 1 > width + = wrap (length w) [w] ws + wrap col line (w:ws) + | col + length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +----------------------------------- +-- Safely reading and writing files + +-- | Gets the contents of a file, but guarantee that it gets closed. +-- +-- The file is read lazily but if it is not fully consumed by the action then +-- the remaining input is truncated and the file is closed. +-- +withFileContents :: FilePath -> (String -> NoCallStackIO a) -> NoCallStackIO a +withFileContents name action = + withFile name ReadMode + (\hnd -> hGetContents hnd >>= action) + +-- | Writes a file atomically. +-- +-- The file is either written successfully or an IO exception is raised and +-- the original file is left unchanged. +-- +-- On windows it is not possible to delete a file that is open by a process. +-- This case will give an IO exception but the atomic property is not affected. +-- +writeFileAtomic :: FilePath -> BS.ByteString -> NoCallStackIO () +writeFileAtomic targetPath content = do + let (targetDir, targetFile) = splitFileName targetPath + Exception.bracketOnError + (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") + (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) + (\(tmpPath, handle) -> do + BS.hPut handle content + hClose handle + renameFile tmpPath targetPath) + +-- ------------------------------------------------------------ +-- * Unicode stuff +-- ------------------------------------------------------------ + +-- | Decode 'String' from UTF8-encoded 'BS.ByteString' +-- +-- Invalid data in the UTF8 stream (this includes code-points @U+D800@ +-- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@). +-- +fromUTF8BS :: SBS.ByteString -> String +fromUTF8BS = decodeStringUtf8 . SBS.unpack + +-- | Variant of 'fromUTF8BS' for lazy 'BS.ByteString's +-- +fromUTF8LBS :: BS.ByteString -> String +fromUTF8LBS = decodeStringUtf8 . BS.unpack + +-- | Encode 'String' to to UTF8-encoded 'SBS.ByteString' +-- +-- Code-points in the @U+D800@-@U+DFFF@ range will be encoded +-- as the replacement character (i.e. @U+FFFD@). +-- +toUTF8BS :: String -> SBS.ByteString +toUTF8BS = SBS.pack . encodeStringUtf8 + +-- | Variant of 'toUTF8BS' for lazy 'BS.ByteString's +-- +toUTF8LBS :: String -> BS.ByteString +toUTF8LBS = BS.pack . encodeStringUtf8 + +-- | Ignore a Unicode byte order mark (BOM) at the beginning of the input +-- +ignoreBOM :: String -> String +ignoreBOM ('\xFEFF':string) = string +ignoreBOM string = string + +-- | Reads a UTF8 encoded text file as a Unicode String +-- +-- Reads lazily using ordinary 'readFile'. +-- +readUTF8File :: FilePath -> NoCallStackIO String +readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> BS.readFile f + +-- | Reads a UTF8 encoded text file as a Unicode String +-- +-- Same behaviour as 'withFileContents'. +-- +withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a +withUTF8FileContents name action = + withBinaryFile name ReadMode + (\hnd -> BS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS) + +-- | Writes a Unicode String as a UTF8 encoded text file. +-- +-- Uses 'writeFileAtomic', so provides the same guarantees. +-- +writeUTF8File :: FilePath -> String -> NoCallStackIO () +writeUTF8File path = writeFileAtomic path . BS.pack . encodeStringUtf8 + +-- | Fix different systems silly line ending conventions +normaliseLineEndings :: String -> String +normaliseLineEndings [] = [] +normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows +normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old OS X +normaliseLineEndings ( c :s) = c : normaliseLineEndings s + +-- ------------------------------------------------------------ +-- * Common utils +-- ------------------------------------------------------------ + +-- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but +-- quite a bit faster. The difference between "Data.List.dropWhileEnd" and this +-- version is that the one in "Data.List" is strict in elements, but spine-lazy, +-- while this one is spine-strict but lazy in elements. That's what @LE@ stands +-- for - "lazy in elements". +-- +-- Example: +-- +-- >>> tail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1] +-- *** Exception: Prelude.undefined +-- ... +-- +-- >>> tail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1] +-- [5,4,3] +-- +-- >>> take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined] +-- [5,4,3] +-- +-- >>> take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined] +-- *** Exception: Prelude.undefined +-- ... +-- +dropWhileEndLE :: (a -> Bool) -> [a] -> [a] +dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] + +-- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but +-- is usually faster (as well as being easier to read). +takeWhileEndLE :: (a -> Bool) -> [a] -> [a] +takeWhileEndLE p = fst . foldr go ([], False) + where + go x (rest, done) + | not done && p x = (x:rest, False) + | otherwise = (rest, True) + +-- | Like 'Data.List.nub', but has @O(n log n)@ complexity instead of +-- @O(n^2)@. Code for 'ordNub' and 'listUnion' taken from Niklas Hambüchen's +-- package. +ordNub :: Ord a => [a] -> [a] +ordNub = ordNubBy id + +-- | Like 'ordNub' and 'Data.List.nubBy'. Selects a key for each element and +-- takes the nub based on that key. +ordNubBy :: Ord b => (a -> b) -> [a] -> [a] +ordNubBy f l = go Set.empty l + where + go !_ [] = [] + go !s (x:xs) + | y `Set.member` s = go s xs + | otherwise = let !s' = Set.insert y s + in x : go s' xs + where + y = f x + +-- | Like "Data.List.union", but has @O(n log n)@ complexity instead of +-- @O(n^2)@. +listUnion :: (Ord a) => [a] -> [a] -> [a] +listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b) + where + aSet = Set.fromList a + +-- | A right-biased version of 'ordNub'. +-- +-- Example: +-- +-- >>> ordNub [1,2,1] :: [Int] +-- [1,2] +-- +-- >>> ordNubRight [1,2,1] :: [Int] +-- [2,1] +-- +ordNubRight :: (Ord a) => [a] -> [a] +ordNubRight = fst . foldr go ([], Set.empty) + where + go x p@(l, s) = if x `Set.member` s then p + else (x:l, Set.insert x s) + +-- | A right-biased version of 'listUnion'. +-- +-- Example: +-- +-- >>> listUnion [1,2,3,4,3] [2,1,1] +-- [1,2,3,4,3] +-- +-- >>> listUnionRight [1,2,3,4,3] [2,1,1] +-- [4,3,2,1,1] +-- +listUnionRight :: (Ord a) => [a] -> [a] -> [a] +listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b + where + bSet = Set.fromList b + +-- | A total variant of 'tail'. +safeTail :: [a] -> [a] +safeTail [] = [] +safeTail (_:xs) = xs + +equating :: Eq a => (b -> a) -> b -> b -> Bool +equating p x y = p x == p y + +-- | Lower case string +-- +-- >>> lowercase "Foobar" +-- "foobar" +lowercase :: String -> String +lowercase = map toLower + +-- | Ascii characters +isAscii :: Char -> Bool +isAscii c = fromEnum c < 0x80 + +-- | Ascii letters. +isAsciiAlpha :: Char -> Bool +isAsciiAlpha c = ('a' <= c && c <= 'z') + || ('A' <= c && c <= 'Z') + +-- | Ascii letters and digits. +-- +-- >>> isAsciiAlphaNum 'a' +-- True +-- +-- >>> isAsciiAlphaNum 'ä' +-- False +-- +isAsciiAlphaNum :: Char -> Bool +isAsciiAlphaNum c = isAscii c || isDigit c + +unintersperse :: Char -> String -> [String] +unintersperse mark = unfoldr unintersperse1 where + unintersperse1 str + | null str = Nothing + | otherwise = + let (this, rest) = break (== mark) str in + Just (this, safeTail rest) + +-- | Like 'break', but with 'Maybe' predicate +-- +-- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar", "1", "2", "quu"] +-- (["foo","bar"],Just (1,["2","quu"])) +-- +-- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar"] +-- (["foo","bar"],Nothing) +-- +-- @since 2.2 +-- +breakMaybe :: (a -> Maybe b) -> [a] -> ([a], Maybe (b, [a])) +breakMaybe f = go id where + go !acc [] = (acc [], Nothing) + go !acc (x:xs) = case f x of + Nothing -> go (acc . (x:)) xs + Just b -> (acc [], Just (b, xs)) + +-- | Like 'span' but with 'Maybe' predicate +-- +-- >>> spanMaybe listToMaybe [[1,2],[3],[],[4,5],[6,7]] +-- ([1,3],[[],[4,5],[6,7]]) +-- +-- >>> spanMaybe (readMaybe :: String -> Maybe Int) ["1", "2", "foo"] +-- ([1,2],["foo"]) +-- +-- @since 2.2 +-- +spanMaybe :: (a -> Maybe b) -> [a] -> ([b],[a]) +spanMaybe _ xs@[] = ([], xs) +spanMaybe p xs@(x:xs') = case p x of + Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs) + Nothing -> ([], xs) + +-- | 'unfoldr' with monadic action. +-- +-- >>> take 5 $ unfoldrM (\b r -> Just (r + b, b + 1)) (1 :: Int) 2 +-- [3,4,5,6,7] +-- +-- @since 2.2 +-- +unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a] +unfoldrM f = go where + go b = do + m <- f b + case m of + Nothing -> return [] + Just (a, b') -> liftM (a :) (go b') + +-- ------------------------------------------------------------ +-- * FilePath stuff +-- ------------------------------------------------------------ + +-- | 'isAbsoluteOnAnyPlatform' and 'isRelativeOnAnyPlatform' are like +-- 'System.FilePath.isAbsolute' and 'System.FilePath.isRelative' but have +-- platform independent heuristics. +-- The System.FilePath exists in two versions, Windows and Posix. The two +-- versions don't agree on what is a relative path and we don't know if we're +-- given Windows or Posix paths. +-- This results in false positives when running on Posix and inspecting +-- Windows paths, like the hackage server does. +-- System.FilePath.Posix.isAbsolute \"C:\\hello\" == False +-- System.FilePath.Windows.isAbsolute \"/hello\" == False +-- This means that we would treat paths that start with \"/\" to be absolute. +-- On Posix they are indeed absolute, while on Windows they are not. +-- +-- The portable versions should be used when we might deal with paths that +-- are from another OS than the host OS. For example, the Hackage Server +-- deals with both Windows and Posix paths while performing the +-- PackageDescription checks. In contrast, when we run 'cabal configure' we +-- do expect the paths to be correct for our OS and we should not have to use +-- the platform independent heuristics. +isAbsoluteOnAnyPlatform :: FilePath -> Bool +-- C:\\directory +isAbsoluteOnAnyPlatform (drive:':':'\\':_) = isAlpha drive +-- UNC +isAbsoluteOnAnyPlatform ('\\':'\\':_) = True +-- Posix root +isAbsoluteOnAnyPlatform ('/':_) = True +isAbsoluteOnAnyPlatform _ = False + +-- | @isRelativeOnAnyPlatform = not . 'isAbsoluteOnAnyPlatform'@ +isRelativeOnAnyPlatform :: FilePath -> Bool +isRelativeOnAnyPlatform = not . isAbsoluteOnAnyPlatform + +-- $setup +-- >>> import Data.Maybe +-- >>> import Text.Read diff --git a/cabal/Cabal/Distribution/Utils/IOData.hs b/cabal/Cabal/Distribution/Utils/IOData.hs new file mode 100644 --- /dev/null +++ b/cabal/Cabal/Distribution/Utils/IOData.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE CPP #-} + +-- | @since 2.2.0 +module Distribution.Utils.IOData + ( -- * 'IOData' & 'IODataMode' type + IOData(..) + , IODataMode(..) + , null + , hGetContents + , hPutContents + ) where + +import qualified Data.ByteString.Lazy as BS +import Distribution.Compat.Prelude hiding (null) +import qualified Prelude +import qualified System.IO + +-- | Represents either textual or binary data passed via I/O functions +-- which support binary/text mode +-- +-- @since 2.2.0 +data IOData = IODataText String + -- ^ How Text gets encoded is usually locale-dependent. + | IODataBinary BS.ByteString + -- ^ Raw binary which gets read/written in binary mode. + +-- | Test whether 'IOData' is empty +-- +-- @since 2.2.0 +null :: IOData -> Bool +null (IODataText s) = Prelude.null s +null (IODataBinary b) = BS.null b + +instance NFData IOData where + rnf (IODataText s) = rnf s +#if MIN_VERSION_bytestring(0,10,0) + rnf (IODataBinary bs) = rnf bs +#else + rnf (IODataBinary bs) = rnf (BS.length bs) +#endif + +data IODataMode = IODataModeText | IODataModeBinary + +-- | 'IOData' Wrapper for 'System.IO.hGetContents' +-- +-- __Note__: This operation uses lazy I/O. Use 'NFData' to force all +-- data to be read and consequently the internal file handle to be +-- closed. +-- +-- @since 2.2.0 +hGetContents :: System.IO.Handle -> IODataMode -> Prelude.IO IOData +hGetContents h IODataModeText = do + System.IO.hSetBinaryMode h False + IODataText <$> System.IO.hGetContents h +hGetContents h IODataModeBinary = do + System.IO.hSetBinaryMode h True + IODataBinary <$> BS.hGetContents h + +-- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose' +-- +-- This is the dual operation ot 'ioDataHGetContents', +-- and consequently the handle is closed with `hClose`. +-- +-- @since 2.2.0 +hPutContents :: System.IO.Handle -> IOData -> Prelude.IO () +hPutContents h (IODataText c) = do + System.IO.hSetBinaryMode h False + System.IO.hPutStr h c + System.IO.hClose h +hPutContents h (IODataBinary c) = do + System.IO.hSetBinaryMode h True + BS.hPutStr h c + System.IO.hClose h diff --git a/cabal/Cabal/Distribution/Utils/LogProgress.hs b/cabal/Cabal/Distribution/Utils/LogProgress.hs --- a/cabal/Cabal/Distribution/Utils/LogProgress.hs +++ b/cabal/Cabal/Distribution/Utils/LogProgress.hs @@ -1,41 +1,89 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} module Distribution.Utils.LogProgress ( LogProgress, - LogMsg(..), runLogProgress, warnProgress, infoProgress, + dieProgress, + addProgressCtx, ) where +import Prelude () +import Distribution.Compat.Prelude + import Distribution.Utils.Progress import Distribution.Verbosity import Distribution.Simple.Utils -import Text.PrettyPrint (Doc, (<+>), text, render) -import Control.Monad (when) +import Text.PrettyPrint +type CtxMsg = Doc +type LogMsg = Doc +type ErrMsg = Doc + +data LogEnv = LogEnv { + le_verbosity :: Verbosity, + le_context :: [CtxMsg] + } + -- | The 'Progress' monad with specialized logging and -- error messages. -type LogProgress a = Progress LogMsg Doc a +newtype LogProgress a = LogProgress { unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a } --- | A tracing message which will be output at some verbosity. -data LogMsg = LogMsg Verbosity Doc +instance Functor LogProgress where + fmap f (LogProgress m) = LogProgress (fmap (fmap f) m) +instance Applicative LogProgress where + pure x = LogProgress (pure (pure x)) + LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r + +instance Monad LogProgress where + return = pure + LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r + -- | Run 'LogProgress', outputting traces according to 'Verbosity', -- 'die' if there is an error. -runLogProgress :: Verbosity -> LogProgress a -> IO a -runLogProgress verbosity = foldProgress step_fn fail_fn return +runLogProgress :: Verbosity -> LogProgress a -> NoCallStackIO a +runLogProgress verbosity (LogProgress m) = + foldProgress step_fn fail_fn return (m env) where - step_fn :: LogMsg -> IO a -> IO a - step_fn (LogMsg v doc) go = do - when (verbosity >= v) $ - putStrLn (render doc) + env = LogEnv { + le_verbosity = verbosity, + le_context = [] + } + step_fn :: LogMsg -> NoCallStackIO a -> NoCallStackIO a + step_fn doc go = do + putStrLn (render doc) go - fail_fn :: Doc -> IO a - fail_fn doc = die (render doc) + fail_fn :: Doc -> NoCallStackIO a + fail_fn doc = do + dieNoWrap verbosity (render doc) -- | Output a warning trace message in 'LogProgress'. warnProgress :: Doc -> LogProgress () -warnProgress s = stepProgress (LogMsg normal (text "Warning:" <+> s)) +warnProgress s = LogProgress $ \env -> + when (le_verbosity env >= normal) $ + stepProgress $ + hang (text "Warning:") 4 (formatMsg (le_context env) s) -- | Output an informational trace message in 'LogProgress'. infoProgress :: Doc -> LogProgress () -infoProgress s = stepProgress (LogMsg verbose s) +infoProgress s = LogProgress $ \env -> + when (le_verbosity env >= verbose) $ + stepProgress s + +-- | Fail the computation with an error message. +dieProgress :: Doc -> LogProgress a +dieProgress s = LogProgress $ \env -> + failProgress $ + hang (text "Error:") 4 (formatMsg (le_context env) s) + +-- | Format a message with context. (Something simple for now.) +formatMsg :: [CtxMsg] -> Doc -> Doc +formatMsg ctx doc = doc $$ vcat ctx + +-- | Add a message to the error/warning context. +addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a +addProgressCtx s (LogProgress m) = LogProgress $ \env -> + m env { le_context = s : le_context env } diff --git a/cabal/Cabal/Distribution/Utils/ShortText.hs b/cabal/Cabal/Distribution/Utils/ShortText.hs --- a/cabal/Cabal/Distribution/Utils/ShortText.hs +++ b/cabal/Cabal/Distribution/Utils/ShortText.hs @@ -17,8 +17,6 @@ import Distribution.Compat.Prelude import Distribution.Utils.String -import Data.String (IsString(..)) - #if defined(MIN_VERSION_bytestring) # if MIN_VERSION_bytestring(0,10,4) # define HAVE_SHORTBYTESTRING 1 @@ -62,7 +60,7 @@ -- Note: This type is for internal uses (such as e.g. 'PackageName') -- and shall not be exposed in Cabal's API -- --- @since 2.0.0 +-- @since 2.0.0.2 #if HAVE_SHORTBYTESTRING newtype ShortText = ST { unST :: BS.Short.ShortByteString } deriving (Eq,Ord,Generic,Data,Typeable) diff --git a/cabal/Cabal/Distribution/Utils/String.hs b/cabal/Cabal/Distribution/Utils/String.hs --- a/cabal/Cabal/Distribution/Utils/String.hs +++ b/cabal/Cabal/Distribution/Utils/String.hs @@ -10,7 +10,8 @@ -- | Decode 'String' from UTF8-encoded octets. -- --- Invalid data will be decoded as the replacement character (@U+FFFD@) +-- Invalid data in the UTF8 stream (this includes code-points @U+D800@ +-- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@). -- -- See also 'encodeStringUtf8' decodeStringUtf8 :: [Word8] -> String @@ -40,9 +41,7 @@ moreBytes :: Int -> Int -> [Word8] -> Int -> [Char] moreBytes 1 overlong cs' acc - | overlong <= acc && acc <= 0x10FFFF - && (acc < 0xD800 || 0xDFFF < acc) - && (acc < 0xFFFE || 0xFFFF < acc) + | overlong <= acc, acc <= 0x10FFFF, (acc < 0xD800 || 0xDFFF < acc) = chr acc : go cs' | otherwise @@ -61,6 +60,9 @@ -- | Encode 'String' to a list of UTF8-encoded octets -- +-- Code-points in the @U+D800@-@U+DFFF@ range will be encoded +-- as the replacement character (i.e. @U+FFFD@). +-- -- See also 'decodeUtf8' encodeStringUtf8 :: String -> [Word8] encodeStringUtf8 [] = [] @@ -69,6 +71,12 @@ : encodeStringUtf8 cs | c <= '\x7FF' = (0xC0 .|. w8ShiftR 6 ) : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | c <= '\xD7FF'= (0xE0 .|. w8ShiftR 12 ) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | c <= '\xDFFF'= 0xEF : 0xBF : 0xBD -- U+FFFD : encodeStringUtf8 cs | c <= '\xFFFF'= (0xE0 .|. w8ShiftR 12 ) : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) 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 @@ -27,18 +27,28 @@ -- * Verbosity Verbosity, silent, normal, verbose, deafening, - moreVerbose, lessVerbose, + moreVerbose, lessVerbose, isVerboseQuiet, intToVerbosity, flagToVerbosity, showForCabal, showForGHC, + verboseNoFlags, verboseHasFlags, + modifyVerbosity, -- * Call stacks verboseCallSite, verboseCallStack, isVerboseCallSite, isVerboseCallStack, + -- * Output markets + verboseMarkOutput, isVerboseMarkOutput, + verboseUnmarkOutput, + -- * line-wrapping verboseNoWrap, isVerboseNoWrap, - ) where + -- * timestamps + verboseTimestamp, isVerboseTimestamp, + verboseNoTimestamp, + ) where + import Prelude () import Distribution.Compat.Prelude @@ -51,11 +61,12 @@ data Verbosity = Verbosity { vLevel :: VerbosityLevel, - vFlags :: Set VerbosityFlag + vFlags :: Set VerbosityFlag, + vQuiet :: Bool } deriving (Generic) mkVerbosity :: VerbosityLevel -> Verbosity -mkVerbosity l = Verbosity { vLevel = l, vFlags = Set.empty } +mkVerbosity l = Verbosity { vLevel = l, vFlags = Set.empty, vQuiet = False } instance Show Verbosity where showsPrec n = showsPrec n . vLevel @@ -111,12 +122,27 @@ lessVerbose :: Verbosity -> Verbosity lessVerbose v = + verboseQuiet $ case vLevel v of Deafening -> v -- deafening stays deafening Verbose -> v { vLevel = Normal } Normal -> v { vLevel = Silent } Silent -> v +-- | Combinator for transforming verbosity level while retaining the +-- original hidden state. +-- +-- For instance, the following property holds +-- +-- prop> isVerboseNoWrap (modifyVerbosity (max verbose) v) == isVerboseNoWrap v +-- +-- __Note__: you can use @modifyVerbosity (const v1) v0@ to overwrite +-- @v1@'s flags with @v0@'s flags. +-- +-- @since 2.0.1.0 +modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity +modifyVerbosity f v = v { vLevel = vLevel (f v) } + intToVerbosity :: Int -> Maybe Verbosity intToVerbosity 0 = Just (mkVerbosity Silent) intToVerbosity 1 = Just (mkVerbosity Normal) @@ -144,6 +170,8 @@ [ string "callsite" >> return verboseCallSite , string "callstack" >> return verboseCallStack , string "nowrap" >> return verboseNoWrap + , string "markoutput" >> return verboseMarkOutput + , string "timestamp" >> return verboseTimestamp ] flagToVerbosity :: ReadE Verbosity @@ -159,8 +187,23 @@ showForCabal, showForGHC :: Verbosity -> String -showForCabal v = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,verbose,deafening] +showForCabal v + | Set.null (vFlags v) + = maybe (error "unknown verbosity") show $ + elemIndex v [silent,normal,verbose,deafening] + | otherwise + = unwords $ (case vLevel v of + Silent -> "silent" + Normal -> "normal" + Verbose -> "verbose" + Deafening -> "debug") + : concatMap showFlag (Set.toList (vFlags v)) + where + showFlag VCallSite = ["+callsite"] + showFlag VCallStack = ["+callstack"] + showFlag VNoWrap = ["+nowrap"] + showFlag VMarkOutput = ["+markoutput"] + showFlag VTimestamp = ["+timestamp"] showForGHC v = maybe (error "unknown verbosity") show $ elemIndex v [silent,normal,__,verbose,deafening] where __ = silent -- this will be always ignored by elemIndex @@ -169,30 +212,89 @@ = VCallStack | VCallSite | VNoWrap + | VMarkOutput + | VTimestamp deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) instance Binary VerbosityFlag -- | Turn on verbose call-site printing when we log. verboseCallSite :: Verbosity -> Verbosity -verboseCallSite v = v { vFlags = Set.insert VCallSite (vFlags v) } +verboseCallSite = verboseFlag VCallSite -- | Turn on verbose call-stack printing when we log. verboseCallStack :: Verbosity -> Verbosity -verboseCallStack v = v { vFlags = Set.insert VCallStack (vFlags v) } +verboseCallStack = verboseFlag VCallStack +-- | Turn on @-----BEGIN CABAL OUTPUT-----@ markers for output +-- from Cabal (as opposed to GHC, or system dependent). +verboseMarkOutput :: Verbosity -> Verbosity +verboseMarkOutput = verboseFlag VMarkOutput + +-- | Turn off marking; useful for suppressing nondeterministic output. +verboseUnmarkOutput :: Verbosity -> Verbosity +verboseUnmarkOutput = verboseNoFlag VMarkOutput + +-- | Disable line-wrapping for log messages. +verboseNoWrap :: Verbosity -> Verbosity +verboseNoWrap = verboseFlag VNoWrap + +-- | Mark the verbosity as quiet +verboseQuiet :: Verbosity -> Verbosity +verboseQuiet v = v { vQuiet = True } + +-- | Turn on timestamps for log messages. +verboseTimestamp :: Verbosity -> Verbosity +verboseTimestamp = verboseFlag VTimestamp + +-- | Turn off timestamps for log messages. +verboseNoTimestamp :: Verbosity -> Verbosity +verboseNoTimestamp = verboseNoFlag VTimestamp + +-- | Helper function for flag enabling functions +verboseFlag :: VerbosityFlag -> (Verbosity -> Verbosity) +verboseFlag flag v = v { vFlags = Set.insert flag (vFlags v) } + +-- | Helper function for flag disabling functions +verboseNoFlag :: VerbosityFlag -> (Verbosity -> Verbosity) +verboseNoFlag flag v = v { vFlags = Set.delete flag (vFlags v) } + +-- | Turn off all flags +verboseNoFlags :: Verbosity -> Verbosity +verboseNoFlags v = v { vFlags = Set.empty } + +verboseHasFlags :: Verbosity -> Bool +verboseHasFlags = not . Set.null . vFlags + -- | Test if we should output call sites when we log. isVerboseCallSite :: Verbosity -> Bool -isVerboseCallSite = (Set.member VCallSite) . vFlags +isVerboseCallSite = isVerboseFlag VCallSite -- | Test if we should output call stacks when we log. isVerboseCallStack :: Verbosity -> Bool -isVerboseCallStack = (Set.member VCallStack) . vFlags +isVerboseCallStack = isVerboseFlag VCallStack --- | Disable line-wrapping for log messages. -verboseNoWrap :: Verbosity -> Verbosity -verboseNoWrap v = v { vFlags = Set.insert VNoWrap (vFlags v) } +-- | Test if we should output markets. +isVerboseMarkOutput :: Verbosity -> Bool +isVerboseMarkOutput = isVerboseFlag VMarkOutput -- | Test if line-wrapping is disabled for log messages. isVerboseNoWrap :: Verbosity -> Bool -isVerboseNoWrap = (Set.member VNoWrap) . vFlags +isVerboseNoWrap = isVerboseFlag VNoWrap + +-- | Test if we had called 'lessVerbose' on the verbosity +isVerboseQuiet :: Verbosity -> Bool +isVerboseQuiet = vQuiet + +-- | Test if if we should output timestamps when we log. +isVerboseTimestamp :: Verbosity -> Bool +isVerboseTimestamp = isVerboseFlag VTimestamp + +-- | Helper function for flag testing functions. +isVerboseFlag :: VerbosityFlag -> Verbosity -> Bool +isVerboseFlag flag = (Set.member flag) . vFlags + +-- $setup +-- >>> import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum) +-- >>> instance Arbitrary VerbosityLevel where arbitrary = arbitraryBoundedEnum +-- >>> instance Arbitrary Verbosity where arbitrary = fmap mkVerbosity arbitrary diff --git a/cabal/Cabal/Distribution/Version.hs b/cabal/Cabal/Distribution/Version.hs --- a/cabal/Cabal/Distribution/Version.hs +++ b/cabal/Cabal/Distribution/Version.hs @@ -1,1078 +1,259 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Version --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- Duncan Coutts 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Exports the 'Version' type along with a parser and pretty printer. A version --- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data --- types. Version ranges are like @\">= 1.2 && < 2\"@. - -module Distribution.Version ( - -- * Package versions - Version, - mkVersion, - mkVersion', - versionNumbers, - nullVersion, - alterVersion, - - -- * Version ranges - VersionRange(..), - - -- ** Constructing - anyVersion, noVersion, - thisVersion, notThisVersion, - laterVersion, earlierVersion, - orLaterVersion, orEarlierVersion, - unionVersionRanges, intersectVersionRanges, - differenceVersionRanges, - invertVersionRange, - withinVersion, - majorBoundVersion, - betweenVersionsInclusive, - - -- ** Inspection - withinRange, - isAnyVersion, - isNoVersion, - isSpecificVersion, - simplifyVersionRange, - foldVersionRange, - foldVersionRange', - hasUpperBound, - hasLowerBound, - - -- ** Modification - removeUpperBound, - removeLowerBound, - - -- * Version intervals view - asVersionIntervals, - VersionInterval, - LowerBound(..), - UpperBound(..), - Bound(..), - - -- ** 'VersionIntervals' abstract type - -- | The 'VersionIntervals' type and the accompanying functions are exposed - -- primarily for completeness and testing purposes. In practice - -- 'asVersionIntervals' is the main function to use to - -- view a 'VersionRange' as a bunch of 'VersionInterval's. - -- - VersionIntervals, - toVersionIntervals, - fromVersionIntervals, - withinIntervals, - versionIntervals, - mkVersionIntervals, - unionVersionIntervals, - intersectVersionIntervals, - invertVersionIntervals - - ) where - -import Prelude () -import Distribution.Compat.Prelude -import qualified Data.Version as Base -import Data.Bits (shiftL, shiftR, (.|.), (.&.)) - -import Distribution.Text -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP hiding (get) - -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<+>)) -import Control.Exception (assert) - -import qualified Text.Read as Read - --- ----------------------------------------------------------------------------- --- Versions - --- | A 'Version' represents the version of a software entity. --- --- Instances of 'Eq' and 'Ord' are provided, which gives exact --- equality and lexicographic ordering of the version number --- components (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2, etc.). --- --- This type is opaque and distinct from the 'Base.Version' type in --- "Data.Version" since @Cabal-2.0@. The difference extends to the --- 'Binary' instance using a different (and more compact) encoding. --- --- @since 2.0 -data Version = PV0 {-# UNPACK #-} !Word64 - | PV1 !Int [Int] - -- NOTE: If a version fits into the packed Word64 - -- representation (i.e. at most four version components - -- which all fall into the [0..0xfffe] range), then PV0 - -- MUST be used. This is essential for the 'Eq' instance - -- to work. - deriving (Data,Eq,Generic,Typeable) - -instance Ord Version where - compare (PV0 x) (PV0 y) = compare x y - compare (PV1 x xs) (PV1 y ys) = case compare x y of - EQ -> compare xs ys - c -> c - compare (PV0 w) (PV1 y ys) = case compare x y of - EQ -> compare [x2,x3,x4] ys - c -> c - where - x = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 - x2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 - x3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 - x4 = fromIntegral (w .&. 0xffff) - 1 - compare (PV1 x xs) (PV0 w) = case compare x y of - EQ -> compare xs [y2,y3,y4] - c -> c - where - y = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 - y2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 - y3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 - y4 = fromIntegral (w .&. 0xffff) - 1 - -instance Show Version where - showsPrec d v = showParen (d > 10) - $ showString "mkVersion " - . showsPrec 11 (versionNumbers v) - -instance Read Version where - readPrec = Read.parens $ do - Read.Ident "mkVersion" <- Read.lexP - v <- Read.step Read.readPrec - return (mkVersion v) - -instance Binary Version - -instance NFData Version where - rnf (PV0 _) = () - rnf (PV1 _ ns) = rnf ns - -instance Text Version where - disp ver - = Disp.hcat (Disp.punctuate (Disp.char '.') - (map Disp.int $ versionNumbers ver)) - - parse = do - branch <- Parse.sepBy1 parseNat (Parse.char '.') - -- allow but ignore tags: - _tags <- Parse.many (Parse.char '-' >> Parse.munch1 isAlphaNum) - return (mkVersion branch) - where - parseNat = read `fmap` Parse.munch1 isDigit - --- | Construct 'Version' from list of version number components. --- --- For instance, @mkVersion [3,2,1]@ constructs a 'Version' --- representing the version @3.2.1@. --- --- All version components must be non-negative. @mkVersion []@ --- currently represents the special /null/ version; see also 'nullVersion'. --- --- @since 2.0 -mkVersion :: [Int] -> Version --- TODO: add validity check; disallow 'mkVersion []' (we have --- 'nullVersion' for that) -mkVersion [] = nullVersion -mkVersion (v1:[]) - | inWord16VerRep1 v1 = PV0 (mkWord64VerRep1 v1) - | otherwise = PV1 v1 [] - where - inWord16VerRep1 x1 = inWord16 (x1 .|. (x1+1)) - mkWord64VerRep1 y1 = mkWord64VerRep (y1+1) 0 0 0 - -mkVersion (v1:vs@(v2:[])) - | inWord16VerRep2 v1 v2 = PV0 (mkWord64VerRep2 v1 v2) - | otherwise = PV1 v1 vs - where - inWord16VerRep2 x1 x2 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1)) - mkWord64VerRep2 y1 y2 = mkWord64VerRep (y1+1) (y2+1) 0 0 - -mkVersion (v1:vs@(v2:v3:[])) - | inWord16VerRep3 v1 v2 v3 = PV0 (mkWord64VerRep3 v1 v2 v3) - | otherwise = PV1 v1 vs - where - inWord16VerRep3 x1 x2 x3 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1) - .|. x3 .|. (x3+1)) - mkWord64VerRep3 y1 y2 y3 = mkWord64VerRep (y1+1) (y2+1) (y3+1) 0 - -mkVersion (v1:vs@(v2:v3:v4:[])) - | inWord16VerRep4 v1 v2 v3 v4 = PV0 (mkWord64VerRep4 v1 v2 v3 v4) - | otherwise = PV1 v1 vs - where - inWord16VerRep4 x1 x2 x3 x4 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1) - .|. x3 .|. (x3+1) - .|. x4 .|. (x4+1)) - mkWord64VerRep4 y1 y2 y3 y4 = mkWord64VerRep (y1+1) (y2+1) (y3+1) (y4+1) - -mkVersion (v1:vs) = PV1 v1 vs - - -{-# INLINE mkWord64VerRep #-} -mkWord64VerRep :: Int -> Int -> Int -> Int -> Word64 -mkWord64VerRep v1 v2 v3 v4 = - (fromIntegral v1 `shiftL` 48) - .|. (fromIntegral v2 `shiftL` 32) - .|. (fromIntegral v3 `shiftL` 16) - .|. fromIntegral v4 - -{-# INLINE inWord16 #-} -inWord16 :: Int -> Bool -inWord16 x = (fromIntegral x :: Word) <= 0xffff - --- | Variant of 'Version' which converts a "Data.Version" 'Version' --- into Cabal's 'Version' type. --- --- @since 2.0 -mkVersion' :: Base.Version -> Version -mkVersion' = mkVersion . Base.versionBranch - --- | Unpack 'Version' into list of version number components. --- --- This is the inverse to 'mkVersion', so the following holds: --- --- > (versionNumbers . mkVersion) vs == vs --- --- @since 2.0 -versionNumbers :: Version -> [Int] -versionNumbers (PV1 n ns) = n:ns -versionNumbers (PV0 w) - | v1 < 0 = [] - | v2 < 0 = [v1] - | v3 < 0 = [v1,v2] - | v4 < 0 = [v1,v2,v3] - | otherwise = [v1,v2,v3,v4] - where - v1 = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 - v2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 - v3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 - v4 = fromIntegral (w .&. 0xffff) - 1 - - --- | Constant representing the special /null/ 'Version' --- --- The 'nullVersion' compares (via 'Ord') as less than every proper --- 'Version' value. --- --- @since 2.0 -nullVersion :: Version --- TODO: at some point, 'mkVersion' may disallow creating /null/ --- 'Version's -nullVersion = PV0 0 - --- | Apply function to list of version number components --- --- > alterVersion f == mkVersion . f . versionNumbers --- --- @since 2.0 -alterVersion :: ([Int] -> [Int]) -> Version -> Version -alterVersion f = mkVersion . f . versionNumbers - --- internal helper -validVersion :: Version -> Bool -validVersion v = v /= nullVersion && all (>=0) (versionNumbers v) - --- ----------------------------------------------------------------------------- --- Version ranges - --- Todo: maybe move this to Distribution.Package.Version? --- (package-specific versioning scheme). - -data VersionRange - = AnyVersion - | ThisVersion Version -- = version - | LaterVersion Version -- > version (NB. not >=) - | EarlierVersion Version -- < version - | WildcardVersion Version -- == ver.* (same as >= ver && < ver+1) - | MajorBoundVersion Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1) - | UnionVersionRanges VersionRange VersionRange - | IntersectVersionRanges VersionRange VersionRange - | VersionRangeParens VersionRange -- just '(exp)' parentheses syntax - deriving (Data, Eq, Generic, Read, Show, Typeable) - -instance Binary VersionRange - -instance NFData VersionRange where rnf = genericRnf - -{-# DeprecateD AnyVersion - "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED ThisVersion - "Use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED LaterVersion - "Use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED EarlierVersion - "Use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED WildcardVersion - "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED UnionVersionRanges - "Use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED IntersectVersionRanges - "Use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'"#-} - --- | The version range @-any@. That is, a version range containing all --- versions. --- --- > withinRange v anyVersion = True --- -anyVersion :: VersionRange -anyVersion = AnyVersion - --- | The empty version range, that is a version range containing no versions. --- --- This can be constructed using any unsatisfiable version range expression, --- for example @> 1 && < 1@. --- --- > withinRange v noVersion = False --- -noVersion :: VersionRange -noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v) - where v = mkVersion [1] - --- | The version range @== v@ --- --- > withinRange v' (thisVersion v) = v' == v --- -thisVersion :: Version -> VersionRange -thisVersion = ThisVersion - --- | The version range @< v || > v@ --- --- > withinRange v' (notThisVersion v) = v' /= v --- -notThisVersion :: Version -> VersionRange -notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) - --- | The version range @> v@ --- --- > withinRange v' (laterVersion v) = v' > v --- -laterVersion :: Version -> VersionRange -laterVersion = LaterVersion - --- | The version range @>= v@ --- --- > withinRange v' (orLaterVersion v) = v' >= v --- -orLaterVersion :: Version -> VersionRange -orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v) - --- | The version range @< v@ --- --- > withinRange v' (earlierVersion v) = v' < v --- -earlierVersion :: Version -> VersionRange -earlierVersion = EarlierVersion - --- | The version range @<= v@ --- --- > withinRange v' (orEarlierVersion v) = v' <= v --- -orEarlierVersion :: Version -> VersionRange -orEarlierVersion v = UnionVersionRanges (ThisVersion v) (EarlierVersion v) - --- | The version range @vr1 || vr2@ --- --- > withinRange v' (unionVersionRanges vr1 vr2) --- > = withinRange v' vr1 || withinRange v' vr2 --- -unionVersionRanges :: VersionRange -> VersionRange -> VersionRange -unionVersionRanges = UnionVersionRanges - --- | The version range @vr1 && vr2@ --- --- > withinRange v' (intersectVersionRanges vr1 vr2) --- > = withinRange v' vr1 && withinRange v' vr2 --- -intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange -intersectVersionRanges = IntersectVersionRanges - --- | The difference of two version ranges --- --- > withinRange v' (differenceVersionRanges vr1 vr2) --- > = withinRange v' vr1 && not (withinRange v' vr2) --- --- @since 1.24.1.0 -differenceVersionRanges :: VersionRange -> VersionRange -> VersionRange -differenceVersionRanges vr1 vr2 = - intersectVersionRanges vr1 (invertVersionRange vr2) - --- | The inverse of a version range --- --- > withinRange v' (invertVersionRange vr) --- > = not (withinRange v' vr) --- -invertVersionRange :: VersionRange -> VersionRange -invertVersionRange = - fromVersionIntervals . invertVersionIntervals - . VersionIntervals . asVersionIntervals - --- | The version range @== v.*@. --- --- For example, for version @1.2@, the version range @== 1.2.*@ is the same as --- @>= 1.2 && < 1.3@ --- --- > withinRange v' (laterVersion v) = v' >= v && v' < upper v --- > where --- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t --- -withinVersion :: Version -> VersionRange -withinVersion = WildcardVersion - --- | The version range @^>= v@. --- --- For example, for version @1.2.3.4@, the version range @^>= 1.2.3.4@ is the same as --- @>= 1.2.3.4 && < 1.3@. --- --- Note that @^>= 1@ is equivalent to @>= 1 && < 1.1@. --- --- @since 2.0@ -majorBoundVersion :: Version -> VersionRange -majorBoundVersion = MajorBoundVersion - --- In practice this is not very useful because we normally use inclusive lower --- bounds and exclusive upper bounds. --- --- > withinRange v' (laterVersion v) = v' > v --- -betweenVersionsInclusive :: Version -> Version -> VersionRange -betweenVersionsInclusive v1 v2 = - IntersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2) - -{-# DEPRECATED betweenVersionsInclusive - "In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds" #-} - --- | Given a version range, remove the highest upper bound. Example: @(>= 1 && < --- 3) || (>= 4 && < 5)@ is converted to @(>= 1 && < 3) || (>= 4)@. -removeUpperBound :: VersionRange -> VersionRange -removeUpperBound = fromVersionIntervals . relaxLastInterval . toVersionIntervals - where - relaxLastInterval (VersionIntervals intervals) = - VersionIntervals (relaxLastInterval' intervals) - - relaxLastInterval' [] = [] - relaxLastInterval' [(l,_)] = [(l, NoUpperBound)] - relaxLastInterval' (i:is) = i : relaxLastInterval' is - --- | Given a version range, remove the lowest lower bound. --- Example: @(>= 1 && < 3) || (>= 4 && < 5)@ is converted to --- @(>= 0 && < 3) || (>= 4 && < 5)@. -removeLowerBound :: VersionRange -> VersionRange -removeLowerBound = fromVersionIntervals . relaxHeadInterval . toVersionIntervals - where - relaxHeadInterval (VersionIntervals intervals) = - VersionIntervals (relaxHeadInterval' intervals) - - relaxHeadInterval' [] = [] - relaxHeadInterval' ((_,u):is) = (minLowerBound,u) : is - --- | Fold over the basic syntactic structure of a 'VersionRange'. --- --- This provides a syntactic view of the expression defining the version range. --- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented --- in terms of the other basic syntax. --- --- For a semantic view use 'asVersionIntervals'. --- -foldVersionRange :: a -- ^ @\"-any\"@ version - -> (Version -> a) -- ^ @\"== v\"@ - -> (Version -> a) -- ^ @\"> v\"@ - -> (Version -> a) -- ^ @\"< v\"@ - -> (a -> a -> a) -- ^ @\"_ || _\"@ union - -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection - -> VersionRange -> a -foldVersionRange anyv this later earlier union intersect = fold - where - fold AnyVersion = anyv - fold (ThisVersion v) = this v - fold (LaterVersion v) = later v - fold (EarlierVersion v) = earlier v - fold (WildcardVersion v) = fold (wildcard v) - fold (MajorBoundVersion v) = fold (majorBound v) - fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) - fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) - fold (VersionRangeParens v) = fold v - - wildcard v = intersectVersionRanges - (orLaterVersion v) - (earlierVersion (wildcardUpperBound v)) - - majorBound v = intersectVersionRanges - (orLaterVersion v) - (earlierVersion (majorUpperBound v)) - --- | An extended variant of 'foldVersionRange' that also provides a view of the --- expression in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== --- v.*\"@ is presented explicitly rather than in terms of the other basic --- syntax. --- -foldVersionRange' :: a -- ^ @\"-any\"@ version - -> (Version -> a) -- ^ @\"== v\"@ - -> (Version -> a) -- ^ @\"> v\"@ - -> (Version -> a) -- ^ @\"< v\"@ - -> (Version -> a) -- ^ @\">= v\"@ - -> (Version -> a) -- ^ @\"<= v\"@ - -> (Version -> Version -> a) -- ^ @\"== v.*\"@ wildcard. The - -- function is passed the - -- inclusive lower bound and the - -- exclusive upper bounds of the - -- range defined by the wildcard. - -> (Version -> Version -> a) -- ^ @\"^>= v\"@ major upper bound - -- The function is passed the - -- inclusive lower bound and the - -- exclusive major upper bounds - -- of the range defined by this - -- operator. - -> (a -> a -> a) -- ^ @\"_ || _\"@ union - -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection - -> (a -> a) -- ^ @\"(_)\"@ parentheses - -> VersionRange -> a -foldVersionRange' anyv this later earlier orLater orEarlier - wildcard major union intersect parens = fold - where - fold AnyVersion = anyv - fold (ThisVersion v) = this v - fold (LaterVersion v) = later v - fold (EarlierVersion v) = earlier v - - fold (UnionVersionRanges (ThisVersion v) - (LaterVersion v')) | v==v' = orLater v - fold (UnionVersionRanges (LaterVersion v) - (ThisVersion v')) | v==v' = orLater v - fold (UnionVersionRanges (ThisVersion v) - (EarlierVersion v')) | v==v' = orEarlier v - fold (UnionVersionRanges (EarlierVersion v) - (ThisVersion v')) | v==v' = orEarlier v - - fold (WildcardVersion v) = wildcard v (wildcardUpperBound v) - fold (MajorBoundVersion v) = major v (majorUpperBound v) - fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) - fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) - fold (VersionRangeParens v) = parens (fold v) - - --- | Does this version fall within the given range? --- --- This is the evaluation function for the 'VersionRange' type. --- -withinRange :: Version -> VersionRange -> Bool -withinRange v = foldVersionRange - True - (\v' -> v == v') - (\v' -> v > v') - (\v' -> v < v') - (||) - (&&) - --- | View a 'VersionRange' as a union of intervals. --- --- This provides a canonical view of the semantics of a 'VersionRange' as --- opposed to the syntax of the expression used to define it. For the syntactic --- view use 'foldVersionRange'. --- --- Each interval is non-empty. The sequence is in increasing order and no --- intervals overlap or touch. Therefore only the first and last can be --- unbounded. The sequence can be empty if the range is empty --- (e.g. a range expression like @< 1 && > 2@). --- --- Other checks are trivial to implement using this view. For example: --- --- > isNoVersion vr | [] <- asVersionIntervals vr = True --- > | otherwise = False --- --- > isSpecificVersion vr --- > | [(LowerBound v InclusiveBound --- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr --- > , v == v' = Just v --- > | otherwise = Nothing --- -asVersionIntervals :: VersionRange -> [VersionInterval] -asVersionIntervals = versionIntervals . toVersionIntervals - --- | Does this 'VersionRange' place any restriction on the 'Version' or is it --- in fact equivalent to 'AnyVersion'. --- --- Note this is a semantic check, not simply a syntactic check. So for example --- the following is @True@ (for all @v@). --- --- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v) --- -isAnyVersion :: VersionRange -> Bool -isAnyVersion vr = case asVersionIntervals vr of - [(LowerBound v InclusiveBound, NoUpperBound)] | isVersion0 v -> True - _ -> False - --- | This is the converse of 'isAnyVersion'. It check if the version range is --- empty, if there is no possible version that satisfies the version range. --- --- For example this is @True@ (for all @v@): --- --- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v) --- -isNoVersion :: VersionRange -> Bool -isNoVersion vr = case asVersionIntervals vr of - [] -> True - _ -> False - --- | Is this version range in fact just a specific version? --- --- For example the version range @\">= 3 && <= 3\"@ contains only the version --- @3@. --- -isSpecificVersion :: VersionRange -> Maybe Version -isSpecificVersion vr = case asVersionIntervals vr of - [(LowerBound v InclusiveBound - ,UpperBound v' InclusiveBound)] - | v == v' -> Just v - _ -> Nothing - --- | Simplify a 'VersionRange' expression. For non-empty version ranges --- this produces a canonical form. Empty or inconsistent version ranges --- are left as-is because that provides more information. --- --- If you need a canonical form use --- @fromVersionIntervals . toVersionIntervals@ --- --- It satisfies the following properties: --- --- > withinRange v (simplifyVersionRange r) = withinRange v r --- --- > withinRange v r = withinRange v r' --- > ==> simplifyVersionRange r = simplifyVersionRange r' --- > || isNoVersion r --- > || isNoVersion r' --- -simplifyVersionRange :: VersionRange -> VersionRange -simplifyVersionRange vr - -- If the version range is inconsistent then we just return the - -- original since that has more information than ">1 && < 1", which - -- is the canonical inconsistent version range. - | null (versionIntervals vi) = vr - | otherwise = fromVersionIntervals vi - where - vi = toVersionIntervals vr - ----------------------------- --- Wildcard range utilities --- - -wildcardUpperBound :: Version -> Version -wildcardUpperBound = alterVersion $ - \lowerBound -> init lowerBound ++ [last lowerBound + 1] - -isWildcardRange :: Version -> Version -> Bool -isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2) - where check (n:[]) (m:[]) | n+1 == m = True - check (n:ns) (m:ms) | n == m = check ns ms - check _ _ = False - --- | Compute next greater major version to be used as upper bound --- --- Example: @0.4.1@ produces the version @0.5@ which then can be used --- to construct a range @>= 0.4.1 && < 0.5@ -majorUpperBound :: Version -> Version -majorUpperBound = alterVersion $ \numbers -> case numbers of - [] -> [0,1] -- should not happen - [m1] -> [m1,1] -- e.g. version '1' - (m1:m2:_) -> [m1,m2+1] - ------------------- --- Intervals view --- - --- | A complementary representation of a 'VersionRange'. Instead of a boolean --- version predicate it uses an increasing sequence of non-overlapping, --- non-empty intervals. --- --- The key point is that this representation gives a canonical representation --- for the semantics of 'VersionRange's. This makes it easier to check things --- like whether a version range is empty, covers all versions, or requires a --- certain minimum or maximum version. It also makes it easy to check equality --- or containment. It also makes it easier to identify \'simple\' version --- predicates for translation into foreign packaging systems that do not --- support complex version range expressions. --- -newtype VersionIntervals = VersionIntervals [VersionInterval] - deriving (Eq, Show) - --- | Inspect the list of version intervals. --- -versionIntervals :: VersionIntervals -> [VersionInterval] -versionIntervals (VersionIntervals is) = is - -type VersionInterval = (LowerBound, UpperBound) -data LowerBound = LowerBound Version !Bound deriving (Eq, Show) -data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show) -data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) - -minLowerBound :: LowerBound -minLowerBound = LowerBound (mkVersion [0]) InclusiveBound - -isVersion0 :: Version -> Bool -isVersion0 = (== mkVersion [0]) - -instance Ord LowerBound where - LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of - LT -> True - EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) - GT -> False - -instance Ord UpperBound where - _ <= NoUpperBound = True - NoUpperBound <= UpperBound _ _ = False - UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of - LT -> True - EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) - GT -> False - -invariant :: VersionIntervals -> Bool -invariant (VersionIntervals intervals) = all validInterval intervals - && all doesNotTouch' adjacentIntervals - where - doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool - doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' - - adjacentIntervals :: [(VersionInterval, VersionInterval)] - adjacentIntervals - | null intervals = [] - | otherwise = zip intervals (tail intervals) - -checkInvariant :: VersionIntervals -> VersionIntervals -checkInvariant is = assert (invariant is) is - --- | Directly construct a 'VersionIntervals' from a list of intervals. --- --- Each interval must be non-empty. The sequence must be in increasing order --- and no intervals may overlap or touch. If any of these conditions are not --- satisfied the function returns @Nothing@. --- -mkVersionIntervals :: [VersionInterval] -> Maybe VersionIntervals -mkVersionIntervals intervals - | invariant (VersionIntervals intervals) = Just (VersionIntervals intervals) - | otherwise = Nothing - -validInterval :: (LowerBound, UpperBound) -> Bool -validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i - where - validLower (LowerBound v _) = validVersion v - validUpper NoUpperBound = True - validUpper (UpperBound v _) = validVersion v - --- Check an interval is non-empty --- -nonEmpty :: VersionInterval -> Bool -nonEmpty (_, NoUpperBound ) = True -nonEmpty (LowerBound l lb, UpperBound u ub) = - (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) - --- Check an upper bound does not intersect, or even touch a lower bound: --- --- ---| or ---) but not ---] or ---) or ---] --- |--- (--- (--- [--- [--- --- -doesNotTouch :: UpperBound -> LowerBound -> Bool -doesNotTouch NoUpperBound _ = False -doesNotTouch (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) - --- | Check an upper bound does not intersect a lower bound: --- --- ---| or ---) or ---] or ---) but not ---] --- |--- (--- (--- [--- [--- --- -doesNotIntersect :: UpperBound -> LowerBound -> Bool -doesNotIntersect NoUpperBound _ = False -doesNotIntersect (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) - --- | Test if a version falls within the version intervals. --- --- It exists mostly for completeness and testing. It satisfies the following --- properties: --- --- > withinIntervals v (toVersionIntervals vr) = withinRange v vr --- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs) --- -withinIntervals :: Version -> VersionIntervals -> Bool -withinIntervals v (VersionIntervals intervals) = any withinInterval intervals - where - withinInterval (lowerBound, upperBound) = withinLower lowerBound - && withinUpper upperBound - withinLower (LowerBound v' ExclusiveBound) = v' < v - withinLower (LowerBound v' InclusiveBound) = v' <= v - - withinUpper NoUpperBound = True - withinUpper (UpperBound v' ExclusiveBound) = v' > v - withinUpper (UpperBound v' InclusiveBound) = v' >= v - --- | Convert a 'VersionRange' to a sequence of version intervals. --- -toVersionIntervals :: VersionRange -> VersionIntervals -toVersionIntervals = foldVersionRange - ( chkIvl (minLowerBound, NoUpperBound)) - (\v -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)) - (\v -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound)) - (\v -> if isVersion0 v then VersionIntervals [] else - chkIvl (minLowerBound, UpperBound v ExclusiveBound)) - unionVersionIntervals - intersectVersionIntervals - where - chkIvl interval = checkInvariant (VersionIntervals [interval]) - --- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression --- representing the version intervals. --- -fromVersionIntervals :: VersionIntervals -> VersionRange -fromVersionIntervals (VersionIntervals []) = noVersion -fromVersionIntervals (VersionIntervals intervals) = - foldr1 UnionVersionRanges [ interval l u | (l, u) <- intervals ] - - where - interval (LowerBound v InclusiveBound) - (UpperBound v' InclusiveBound) | v == v' - = ThisVersion v - interval (LowerBound v InclusiveBound) - (UpperBound v' ExclusiveBound) | isWildcardRange v v' - = WildcardVersion v - interval l u = lowerBound l `intersectVersionRanges'` upperBound u - - lowerBound (LowerBound v InclusiveBound) - | isVersion0 v = AnyVersion - | otherwise = orLaterVersion v - lowerBound (LowerBound v ExclusiveBound) = LaterVersion v - - upperBound NoUpperBound = AnyVersion - upperBound (UpperBound v InclusiveBound) = orEarlierVersion v - upperBound (UpperBound v ExclusiveBound) = EarlierVersion v - - intersectVersionRanges' vr AnyVersion = vr - intersectVersionRanges' AnyVersion vr = vr - intersectVersionRanges' vr vr' = IntersectVersionRanges vr vr' - -unionVersionIntervals :: VersionIntervals -> VersionIntervals - -> VersionIntervals -unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = - checkInvariant (VersionIntervals (union is0 is'0)) - where - union is [] = is - union [] is' = is' - union (i:is) (i':is') = case unionInterval i i' of - Left Nothing -> i : union is (i' :is') - Left (Just i'') -> union is (i'':is') - Right Nothing -> i' : union (i :is) is' - Right (Just i'') -> union (i'':is) is' - -unionInterval :: VersionInterval -> VersionInterval - -> Either (Maybe VersionInterval) (Maybe VersionInterval) -unionInterval (lower , upper ) (lower', upper') - - -- Non-intersecting intervals with the left interval ending first - | upper `doesNotTouch` lower' = Left Nothing - - -- Non-intersecting intervals with the right interval first - | upper' `doesNotTouch` lower = Right Nothing - - -- Complete or partial overlap, with the left interval ending first - | upper <= upper' = lowerBound `seq` - Left (Just (lowerBound, upper')) - - -- Complete or partial overlap, with the left interval ending first - | otherwise = lowerBound `seq` - Right (Just (lowerBound, upper)) - where - lowerBound = min lower lower' - -intersectVersionIntervals :: VersionIntervals -> VersionIntervals - -> VersionIntervals -intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = - checkInvariant (VersionIntervals (intersect is0 is'0)) - where - intersect _ [] = [] - intersect [] _ = [] - intersect (i:is) (i':is') = case intersectInterval i i' of - Left Nothing -> intersect is (i':is') - Left (Just i'') -> i'' : intersect is (i':is') - Right Nothing -> intersect (i:is) is' - Right (Just i'') -> i'' : intersect (i:is) is' - -intersectInterval :: VersionInterval -> VersionInterval - -> Either (Maybe VersionInterval) (Maybe VersionInterval) -intersectInterval (lower , upper ) (lower', upper') - - -- Non-intersecting intervals with the left interval ending first - | upper `doesNotIntersect` lower' = Left Nothing - - -- Non-intersecting intervals with the right interval first - | upper' `doesNotIntersect` lower = Right Nothing - - -- Complete or partial overlap, with the left interval ending first - | upper <= upper' = lowerBound `seq` - Left (Just (lowerBound, upper)) - - -- Complete or partial overlap, with the right interval ending first - | otherwise = lowerBound `seq` - Right (Just (lowerBound, upper')) - where - lowerBound = max lower lower' - -invertVersionIntervals :: VersionIntervals - -> VersionIntervals -invertVersionIntervals (VersionIntervals xs) = - case xs of - -- Empty interval set - [] -> VersionIntervals [(noLowerBound, NoUpperBound)] - -- Interval with no lower bound - ((lb, ub) : more) | lb == noLowerBound -> - VersionIntervals $ invertVersionIntervals' ub more - -- Interval with a lower bound - ((lb, ub) : more) -> - VersionIntervals $ (noLowerBound, invertLowerBound lb) - : invertVersionIntervals' ub more - where - -- Invert subsequent version intervals given the upper bound of - -- the intervals already inverted. - invertVersionIntervals' :: UpperBound - -> [(LowerBound, UpperBound)] - -> [(LowerBound, UpperBound)] - invertVersionIntervals' NoUpperBound [] = [] - invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)] - invertVersionIntervals' ub0 [(lb, NoUpperBound)] = - [(invertUpperBound ub0, invertLowerBound lb)] - invertVersionIntervals' ub0 ((lb, ub1) : more) = - (invertUpperBound ub0, invertLowerBound lb) - : invertVersionIntervals' ub1 more - - invertLowerBound :: LowerBound -> UpperBound - invertLowerBound (LowerBound v b) = UpperBound v (invertBound b) - - invertUpperBound :: UpperBound -> LowerBound - invertUpperBound (UpperBound v b) = LowerBound v (invertBound b) - invertUpperBound NoUpperBound = error "NoUpperBound: unexpected" - - invertBound :: Bound -> Bound - invertBound ExclusiveBound = InclusiveBound - invertBound InclusiveBound = ExclusiveBound - - noLowerBound :: LowerBound - noLowerBound = LowerBound (mkVersion [0]) InclusiveBound - -------------------------------- --- Parsing and pretty printing --- - -instance Text VersionRange where - disp = fst - . foldVersionRange' -- precedence: - ( Disp.text "-any" , 0 :: Int) - (\v -> (Disp.text "==" <<>> disp v , 0)) - (\v -> (Disp.char '>' <<>> disp v , 0)) - (\v -> (Disp.char '<' <<>> disp v , 0)) - (\v -> (Disp.text ">=" <<>> disp v , 0)) - (\v -> (Disp.text "<=" <<>> disp v , 0)) - (\v _ -> (Disp.text "==" <<>> dispWild v , 0)) - (\v _ -> (Disp.text "^>=" <<>> disp v , 0)) - (\(r1, p1) (r2, p2) -> - (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) - (\(r1, p1) (r2, p2) -> - (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) - (\(r, _) -> (Disp.parens r, 0)) - - where dispWild ver = - Disp.hcat (Disp.punctuate (Disp.char '.') - (map Disp.int $ versionNumbers ver)) - <<>> Disp.text ".*" - punct p p' | p < p' = Disp.parens - | otherwise = id - - parse = expr - where - expr = do Parse.skipSpaces - t <- term - Parse.skipSpaces - (do _ <- Parse.string "||" - Parse.skipSpaces - e <- expr - return (UnionVersionRanges t e) - +++ - return t) - term = do f <- factor - Parse.skipSpaces - (do _ <- Parse.string "&&" - Parse.skipSpaces - t <- term - return (IntersectVersionRanges f t) - +++ - return f) - factor = Parse.choice $ parens expr - : parseAnyVersion - : parseNoVersion - : parseWildcardRange - : map parseRangeOp rangeOps - parseAnyVersion = Parse.string "-any" >> return AnyVersion - parseNoVersion = Parse.string "-none" >> return noVersion - - parseWildcardRange = do - _ <- Parse.string "==" - Parse.skipSpaces - branch <- Parse.sepBy1 digits (Parse.char '.') - _ <- Parse.char '.' - _ <- Parse.char '*' - return (WildcardVersion (mkVersion branch)) - - parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces) - (Parse.char ')' >> Parse.skipSpaces) - (do a <- p - Parse.skipSpaces - return (VersionRangeParens a)) - - digits = do - firstDigit <- Parse.satisfy isDigit - if firstDigit == '0' - then return 0 - else do rest <- Parse.munch isDigit - return (read (firstDigit : rest)) -- TODO: eradicateNoParse - - parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse - rangeOps = [ ("<", EarlierVersion), - ("<=", orEarlierVersion), - (">", LaterVersion), - (">=", orLaterVersion), - ("^>=", MajorBoundVersion), - ("==", ThisVersion) ] - --- | Does the version range have an upper bound? --- --- @since 1.24.0.0 -hasUpperBound :: VersionRange -> Bool -hasUpperBound = foldVersionRange - False - (const True) - (const False) - (const True) - (&&) (||) - --- | Does the version range have an explicit lower bound? --- --- Note: this function only considers the user-specified lower bounds, but not --- the implicit >=0 lower bound. --- --- @since 1.24.0.0 -hasLowerBound :: VersionRange -> Bool -hasLowerBound = foldVersionRange - False - (const True) - (const True) - (const False) - (&&) (||) +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Version +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- Duncan Coutts 2008 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Exports the 'Version' type along with a parser and pretty printer. A version +-- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data +-- types. Version ranges are like @\">= 1.2 && < 2\"@. + +module Distribution.Version ( + -- * Package versions + Version, + version0, + mkVersion, + mkVersion', + versionNumbers, + nullVersion, + alterVersion, + + -- * Version ranges + VersionRange(..), + + -- ** Constructing + anyVersion, noVersion, + thisVersion, notThisVersion, + laterVersion, earlierVersion, + orLaterVersion, orEarlierVersion, + unionVersionRanges, intersectVersionRanges, + differenceVersionRanges, + invertVersionRange, + withinVersion, + majorBoundVersion, + betweenVersionsInclusive, + + -- ** Inspection + withinRange, + isAnyVersion, + isNoVersion, + isSpecificVersion, + simplifyVersionRange, + foldVersionRange, + foldVersionRange', + normaliseVersionRange, + stripParensVersionRange, + hasUpperBound, + hasLowerBound, + + -- ** Cata & ana + VersionRangeF (..), + cataVersionRange, + anaVersionRange, + hyloVersionRange, + projectVersionRange, + embedVersionRange, + + -- ** Utilities + wildcardUpperBound, + majorUpperBound, + + -- ** Modification + removeUpperBound, + removeLowerBound, + + -- * Version intervals view + asVersionIntervals, + VersionInterval, + LowerBound(..), + UpperBound(..), + Bound(..), + + -- ** 'VersionIntervals' abstract type + -- | The 'VersionIntervals' type and the accompanying functions are exposed + -- primarily for completeness and testing purposes. In practice + -- 'asVersionIntervals' is the main function to use to + -- view a 'VersionRange' as a bunch of 'VersionInterval's. + -- + VersionIntervals, + toVersionIntervals, + fromVersionIntervals, + withinIntervals, + versionIntervals, + mkVersionIntervals, + unionVersionIntervals, + intersectVersionIntervals, + invertVersionIntervals + + ) where + +import Distribution.Types.Version +import Distribution.Types.VersionRange +import Distribution.Types.VersionInterval + +------------------------------------------------------------------------------- +-- Utilities on VersionRange requiring VersionInterval +------------------------------------------------------------------------------- + +-- | Does this 'VersionRange' place any restriction on the 'Version' or is it +-- in fact equivalent to 'AnyVersion'. +-- +-- Note this is a semantic check, not simply a syntactic check. So for example +-- the following is @True@ (for all @v@). +-- +-- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v) +-- +isAnyVersion :: VersionRange -> Bool +isAnyVersion vr = case asVersionIntervals vr of + [(LowerBound v InclusiveBound, NoUpperBound)] | isVersion0 v -> True + _ -> False + where + isVersion0 :: Version -> Bool + isVersion0 = (== mkVersion [0]) + + +-- | This is the converse of 'isAnyVersion'. It check if the version range is +-- empty, if there is no possible version that satisfies the version range. +-- +-- For example this is @True@ (for all @v@): +-- +-- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v) +-- +isNoVersion :: VersionRange -> Bool +isNoVersion vr = case asVersionIntervals vr of + [] -> True + _ -> False + +-- | Is this version range in fact just a specific version? +-- +-- For example the version range @\">= 3 && <= 3\"@ contains only the version +-- @3@. +-- +isSpecificVersion :: VersionRange -> Maybe Version +isSpecificVersion vr = case asVersionIntervals vr of + [(LowerBound v InclusiveBound + ,UpperBound v' InclusiveBound)] + | v == v' -> Just v + _ -> Nothing + +-- | Simplify a 'VersionRange' expression. For non-empty version ranges +-- this produces a canonical form. Empty or inconsistent version ranges +-- are left as-is because that provides more information. +-- +-- If you need a canonical form use +-- @fromVersionIntervals . toVersionIntervals@ +-- +-- It satisfies the following properties: +-- +-- > withinRange v (simplifyVersionRange r) = withinRange v r +-- +-- > withinRange v r = withinRange v r' +-- > ==> simplifyVersionRange r = simplifyVersionRange r' +-- > || isNoVersion r +-- > || isNoVersion r' +-- +simplifyVersionRange :: VersionRange -> VersionRange +simplifyVersionRange vr + -- If the version range is inconsistent then we just return the + -- original since that has more information than ">1 && < 1", which + -- is the canonical inconsistent version range. + | null (versionIntervals vi) = vr + | otherwise = fromVersionIntervals vi + where + vi = toVersionIntervals vr + +-- | The difference of two version ranges +-- +-- > withinRange v' (differenceVersionRanges vr1 vr2) +-- > = withinRange v' vr1 && not (withinRange v' vr2) +-- +-- @since 1.24.1.0 +differenceVersionRanges :: VersionRange -> VersionRange -> VersionRange +differenceVersionRanges vr1 vr2 = + intersectVersionRanges vr1 (invertVersionRange vr2) + +-- | The inverse of a version range +-- +-- > withinRange v' (invertVersionRange vr) +-- > = not (withinRange v' vr) +-- +invertVersionRange :: VersionRange -> VersionRange +invertVersionRange = + fromVersionIntervals . invertVersionIntervals . toVersionIntervals + +-- | Given a version range, remove the highest upper bound. Example: @(>= 1 && < +-- 3) || (>= 4 && < 5)@ is converted to @(>= 1 && < 3) || (>= 4)@. +removeUpperBound :: VersionRange -> VersionRange +removeUpperBound = fromVersionIntervals . relaxLastInterval . toVersionIntervals + +-- | Given a version range, remove the lowest lower bound. +-- Example: @(>= 1 && < 3) || (>= 4 && < 5)@ is converted to +-- @(>= 0 && < 3) || (>= 4 && < 5)@. +removeLowerBound :: VersionRange -> VersionRange +removeLowerBound = fromVersionIntervals . relaxHeadInterval . toVersionIntervals + +------------------------------------------------------------------------------- +-- Deprecated +------------------------------------------------------------------------------- + +-- In practice this is not very useful because we normally use inclusive lower +-- bounds and exclusive upper bounds. +-- +-- > withinRange v' (laterVersion v) = v' > v +-- +betweenVersionsInclusive :: Version -> Version -> VersionRange +betweenVersionsInclusive v1 v2 = + intersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2) + +{-# DEPRECATED betweenVersionsInclusive + "In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds" #-} + + + + +-- | An extended variant of 'foldVersionRange' that also provides a view of the +-- expression in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== +-- v.*\"@ is presented explicitly rather than in terms of the other basic +-- syntax. +-- +foldVersionRange' :: a -- ^ @\"-any\"@ version + -> (Version -> a) -- ^ @\"== v\"@ + -> (Version -> a) -- ^ @\"> v\"@ + -> (Version -> a) -- ^ @\"< v\"@ + -> (Version -> a) -- ^ @\">= v\"@ + -> (Version -> a) -- ^ @\"<= v\"@ + -> (Version -> Version -> a) -- ^ @\"== v.*\"@ wildcard. The + -- function is passed the + -- inclusive lower bound and the + -- exclusive upper bounds of the + -- range defined by the wildcard. + -> (Version -> Version -> a) -- ^ @\"^>= v\"@ major upper bound + -- The function is passed the + -- inclusive lower bound and the + -- exclusive major upper bounds + -- of the range defined by this + -- operator. + -> (a -> a -> a) -- ^ @\"_ || _\"@ union + -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection + -> (a -> a) -- ^ @\"(_)\"@ parentheses + -> VersionRange -> a +foldVersionRange' anyv this later earlier orLater orEarlier + wildcard major union intersect parens = + cataVersionRange alg . normaliseVersionRange + where + alg AnyVersionF = anyv + alg (ThisVersionF v) = this v + alg (LaterVersionF v) = later v + alg (EarlierVersionF v) = earlier v + alg (OrLaterVersionF v) = orLater v + alg (OrEarlierVersionF v) = orEarlier v + alg (WildcardVersionF v) = wildcard v (wildcardUpperBound v) + alg (MajorBoundVersionF v) = major v (majorUpperBound v) + alg (UnionVersionRangesF v1 v2) = union v1 v2 + alg (IntersectVersionRangesF v1 v2) = intersect v1 v2 + alg (VersionRangeParensF v) = parens v +{-# DEPRECATED foldVersionRange' "Use cataVersionRange & normaliseVersionRange for more principled folding" #-} diff --git a/cabal/Cabal/LICENSE b/cabal/Cabal/LICENSE --- a/cabal/Cabal/LICENSE +++ b/cabal/Cabal/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2016, Cabal Development Team. +Copyright (c) 2003-2017, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. All rights reserved. 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 @@ -27,11 +27,15 @@ import Prelude () import Distribution.Compat.Prelude +import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) + +import Distribution.Parsec.Class +import Distribution.Pretty import Distribution.Text -import qualified Distribution.Compat.ReadP as Parse +import qualified Distribution.Compat.Parsec as P +import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp -import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) -- ------------------------------------------------------------ -- * Language @@ -61,10 +65,14 @@ knownLanguages :: [Language] knownLanguages = [Haskell98, Haskell2010] -instance Text Language where - disp (UnknownLanguage other) = Disp.text other - disp other = Disp.text (show other) +instance Pretty Language where + pretty (UnknownLanguage other) = Disp.text other + pretty other = Disp.text (show other) +instance Parsec Language where + parsec = classifyLanguage <$> P.munch1 isAlphaNum + +instance Text Language where parse = do lang <- Parse.munch1 isAlphaNum return (classifyLanguage lang) @@ -113,7 +121,7 @@ -- | Allow overlapping class instances, provided there is a unique -- most specific instance for each use. -- - -- * + -- * OverlappingInstances -- | Ignore structural rules guaranteeing the termination of class @@ -121,7 +129,7 @@ -- recursion stack, and compilation may fail if this depth is -- exceeded. -- - -- * + -- * | UndecidableInstances -- | Implies 'OverlappingInstances'. Allow the implementation to @@ -129,34 +137,36 @@ -- instantiation of types will lead to a more specific instance -- being applicable. -- - -- * + -- * | IncoherentInstances - -- | /(deprecated)/ Allow recursive bindings in @do@ blocks, using the @rec@ - -- keyword. See also 'RecursiveDo'. + -- | /(deprecated)/ Deprecated in favour of 'RecursiveDo'. + -- + -- Old description: Allow recursive bindings in @do@ blocks, using + -- the @rec@ keyword. See also 'RecursiveDo'. | DoRec - -- | Allow recursive bindings using @mdo@, a variant of @do@. - -- @DoRec@ provides a different, preferred syntax. + -- | Allow recursive bindings in @do@ blocks, using the @rec@ + -- keyword, or @mdo@, a variant of @do@. -- - -- * + -- * | RecursiveDo -- | Provide syntax for writing list comprehensions which iterate -- over several lists together, like the 'zipWith' family of -- functions. -- - -- * + -- * | ParallelListComp -- | Allow multiple parameters in a type class. -- - -- * + -- * | MultiParamTypeClasses -- | Enable the dreaded monomorphism restriction. -- - -- * + -- * | MonomorphismRestriction -- | Allow a specification attached to a multi-parameter type class @@ -165,37 +175,43 @@ -- for the declared instances, and will use this property to reduce -- ambiguity in instance resolution. -- - -- * + -- * | FunctionalDependencies - -- | Like 'RankNTypes' but does not allow a higher-rank type to - -- itself appear on the left of a function arrow. + -- | /(deprecated)/ A synonym for 'RankNTypes'. -- - -- * + -- Old description: Like 'RankNTypes' but does not allow a + -- higher-rank type to itself appear on the left of a function + -- arrow. + -- + -- * | Rank2Types -- | Allow a universally-quantified type to occur on the left of a -- function arrow. -- - -- * + -- * | RankNTypes - -- | Allow data constructors to have polymorphic arguments. Unlike - -- 'RankNTypes', does not allow this for ordinary functions. + -- | /(deprecated)/ A synonym for 'RankNTypes'. -- - -- * + -- Old description: Allow data constructors to have polymorphic + -- arguments. Unlike 'RankNTypes', does not allow this for ordinary + -- functions. + -- + -- * | PolymorphicComponents -- | Allow existentially-quantified data constructors. -- - -- * + -- * | ExistentialQuantification -- | Cause a type variable in a signature, which has an explicit -- @forall@ quantifier, to scope over the definition of the -- accompanying value declaration. -- - -- * + -- * | ScopedTypeVariables -- | Deprecated, use 'ScopedTypeVariables' instead. @@ -203,70 +219,70 @@ -- | Enable implicit function parameters with dynamic scope. -- - -- * + -- * | ImplicitParams -- | Relax some restrictions on the form of the context of a type -- signature. -- - -- * + -- * | FlexibleContexts -- | Relax some restrictions on the form of the context of an -- instance declaration. -- - -- * + -- * | FlexibleInstances -- | Allow data type declarations with no constructors. -- - -- * + -- * | EmptyDataDecls -- | Run the C preprocessor on Haskell source code. -- - -- * + -- * | CPP -- | Allow an explicit kind signature giving the kind of types over -- which a type variable ranges. -- - -- * + -- * | KindSignatures -- | Enable a form of pattern which forces evaluation before an -- attempted match, and a form of strict @let@/@where@ binding. -- - -- * + -- * | BangPatterns -- | Allow type synonyms in instance heads. -- - -- * + -- * | TypeSynonymInstances -- | Enable Template Haskell, a system for compile-time -- metaprogramming. -- - -- * + -- * | TemplateHaskell -- | Enable the Foreign Function Interface. In GHC, implements the -- standard Haskell 98 Foreign Function Interface Addendum, plus -- some GHC-specific extensions. -- - -- * + -- * | ForeignFunctionInterface -- | Enable arrow notation. -- - -- * + -- * | Arrows -- | /(deprecated)/ Enable generic type classes, with default instances defined in -- terms of the algebraic structure of a type. -- - -- * + -- * | Generics -- | Enable the implicit importing of the module "Prelude". When @@ -274,101 +290,102 @@ -- identifiers, use whatever is in scope rather than the "Prelude" -- -- version. -- - -- * + -- * | ImplicitPrelude -- | Enable syntax for implicitly binding local names corresponding -- to the field names of a record. Puns bind specific names, unlike -- 'RecordWildCards'. -- - -- * + -- * | NamedFieldPuns -- | Enable a form of guard which matches a pattern and binds -- variables. -- - -- * + -- * | PatternGuards -- | Allow a type declared with @newtype@ to use @deriving@ for any -- class with an instance for the underlying type. -- - -- * + -- * | GeneralizedNewtypeDeriving -- | Enable the \"Trex\" extensible records system. -- - -- * + -- * | ExtensibleRecords -- | Enable type synonyms which are transparent in some definitions -- and opaque elsewhere, as a way of implementing abstract -- datatypes. -- - -- * + -- * | RestrictedTypeSynonyms -- | Enable an alternate syntax for string literals, -- with string templating. -- - -- * + -- * | HereDocuments -- | Allow the character @#@ as a postfix modifier on identifiers. -- Also enables literal syntax for unboxed values. -- - -- * + -- * | MagicHash -- | Allow data types and type synonyms which are indexed by types, -- i.e. ad-hoc polymorphism for types. -- - -- * + -- * | TypeFamilies -- | Allow a standalone declaration which invokes the type class -- @deriving@ mechanism. -- - -- * + -- * | StandaloneDeriving -- | Allow certain Unicode characters to stand for certain ASCII -- character sequences, e.g. keywords and punctuation. -- - -- * + -- * | UnicodeSyntax -- | Allow the use of unboxed types as foreign types, e.g. in -- @foreign import@ and @foreign export@. -- - -- * + -- * | UnliftedFFITypes -- | Enable interruptible FFI. -- - -- * + -- * | InterruptibleFFI -- | Allow use of CAPI FFI calling convention (@foreign import capi@). -- - -- * + -- * | CApiFFI -- | Defer validity checking of types until after expanding type -- synonyms, relaxing the constraints on how synonyms may be used. -- - -- * + -- * | LiberalTypeSynonyms -- | Allow the name of a type constructor, type class, or type -- variable to be an infix operator. + -- * | TypeOperators -- | Enable syntax for implicitly binding local names corresponding -- to the field names of a record. A wildcard binds all unmentioned -- names, unlike 'NamedFieldPuns'. -- - -- * + -- * | RecordWildCards -- | Deprecated, use 'NamedFieldPuns' instead. @@ -377,41 +394,43 @@ -- | Allow a record field name to be disambiguated by the type of -- the record it's in. -- - -- * + -- * | DisambiguateRecordFields -- | Enable traditional record syntax (as supported by Haskell 98) -- - -- * + -- * | TraditionalRecordSyntax -- | Enable overloading of string literals using a type class, much -- like integer literals. -- - -- * + -- * | OverloadedStrings -- | Enable generalized algebraic data types, in which type -- variables may be instantiated on a per-constructor basis. Implies -- 'GADTSyntax'. -- - -- * + -- * | GADTs -- | Enable GADT syntax for declaring ordinary algebraic datatypes. -- - -- * + -- * | GADTSyntax - -- | Make pattern bindings monomorphic. + -- | /(deprecated)/ Has no effect. -- - -- * + -- Old description: Make pattern bindings monomorphic. + -- + -- * | MonoPatBinds -- | Relax the requirements on mutually-recursive polymorphic -- functions. -- - -- * + -- * | RelaxedPolyRec -- | Allow default instantiation of polymorphic types in more @@ -422,34 +441,34 @@ -- | Enable unboxed tuples. -- - -- * + -- * | UnboxedTuples -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and -- 'Data.Generics.Data'. -- - -- * + -- * | DeriveDataTypeable -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'. -- - -- * + -- * | DeriveGeneric -- | Enable support for default signatures. -- - -- * + -- * | DefaultSignatures -- | Allow type signatures to be specified in instance declarations. -- - -- * + -- * | InstanceSigs -- | Allow a class method's type to place additional constraints on -- a class type variable. -- - -- * + -- * | ConstrainedClassMethods -- | Allow imports to be qualified by the package name the module is @@ -457,13 +476,13 @@ -- -- > import "network" Network.Socket -- - -- * + -- * | PackageImports -- | /(deprecated)/ Allow a type variable to be instantiated at a -- polymorphic type. -- - -- * + -- * | ImpredicativeTypes -- | /(deprecated)/ Change the syntax for qualified infix operators. @@ -474,31 +493,31 @@ -- | Relax the interpretation of left operator sections to allow -- unary postfix operators. -- - -- * + -- * | PostfixOperators -- | Enable quasi-quotation, a mechanism for defining new concrete -- syntax for expressions and patterns. -- - -- * + -- * | QuasiQuotes -- | Enable generalized list comprehensions, supporting operations -- such as sorting and grouping. -- - -- * + -- * | TransformListComp -- | Enable monad comprehensions, which generalise the list -- comprehension syntax to work for any monad. -- - -- * + -- * | MonadComprehensions -- | Enable view patterns, which match a value by applying a -- function and matching on the result. -- - -- * + -- * | ViewPatterns -- | Allow concrete XML syntax to be used in expressions and patterns, @@ -516,7 +535,7 @@ -- | Enable the use of tuple sections, e.g. @(, True)@ desugars into -- @\x -> (x, True)@. -- - -- * + -- * | TupleSections -- | Allow GHC primops, written in C--, to be imported into a Haskell @@ -526,7 +545,7 @@ -- | Support for patterns of the form @n + k@, where @k@ is an -- integer literal. -- - -- * + -- * | NPlusKPatterns -- | Improve the layout rule when @if@ expressions are used in a @do@ @@ -535,55 +554,55 @@ -- | Enable support for multi-way @if@-expressions. -- - -- * + -- * | MultiWayIf -- | Enable support lambda-@case@ expressions. -- - -- * + -- * | LambdaCase -- | Makes much of the Haskell sugar be desugared into calls to the -- function with a particular name that is in scope. -- - -- * + -- * | RebindableSyntax -- | Make @forall@ a keyword in types, which can be used to give the -- generalisation explicitly. -- - -- * + -- * | ExplicitForAll -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. -- - -- * + -- * | DatatypeContexts -- | Local (@let@ and @where@) bindings are monomorphic. -- - -- * + -- * | MonoLocalBinds -- | Enable @deriving@ for the 'Data.Functor.Functor' class. -- - -- * + -- * | DeriveFunctor -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class. -- - -- * + -- * | DeriveTraversable -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class. -- - -- * + -- * | DeriveFoldable -- | Enable non-decreasing indentation for @do@ blocks. -- - -- * + -- * | NondecreasingIndentation -- | Allow imports to be qualified with a safe keyword that requires @@ -592,26 +611,26 @@ -- -- > import safe Network.Socket -- - -- * + -- * | SafeImports -- | Compile a module in the Safe, Safe Haskell mode -- a restricted -- form of the Haskell language to ensure type safety. -- - -- * + -- * | Safe -- | Compile a module in the Trustworthy, Safe Haskell mode -- no -- restrictions apply but the module is marked as trusted as long as -- the package the module resides in is trusted. -- - -- * + -- * | Trustworthy -- | Compile a module in the Unsafe, Safe Haskell mode so that -- modules compiled using Safe, Safe Haskell mode can't import it. -- - -- * + -- * | Unsafe -- | Allow type class/implicit parameter/equality constraints to be @@ -619,17 +638,17 @@ -- the @(ctxt => ty)@ syntax so that any type of kind constraint can -- occur before the arrow. -- - -- * + -- * | ConstraintKinds -- | Enable kind polymorphism. -- - -- * + -- * | PolyKinds -- | Enable datatype promotion. -- - -- * + -- * | DataKinds -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/. @@ -639,54 +658,56 @@ -- | Enable explicit role annotations, like in (@type role Foo representational representational@). -- - -- * + -- * | RoleAnnotations -- | Enable overloading of list literals, arithmetic sequences and -- list patterns using the 'IsList' type class. -- - -- * + -- * | OverloadedLists -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled. -- - -- * + -- * | EmptyCase - -- | Triggers the generation of derived 'Typeable' instances for every - -- datatype and type class declaration. + -- | /(deprecated)/ Deprecated in favour of 'DeriveDataTypeable'. -- - -- * + -- Old description: Triggers the generation of derived 'Typeable' + -- instances for every datatype and type class declaration. + -- + -- * | AutoDeriveTypeable -- | Desugars negative literals directly (without using negate). -- - -- * + -- * | NegativeLiterals -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@). -- - -- * + -- * | BinaryLiterals -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'. -- - -- * + -- * | NumDecimals -- | Enable support for type classes with no type parameter. -- - -- * + -- * | NullaryTypeClasses -- | Enable explicit namespaces in module import/export lists. -- - -- * + -- * | ExplicitNamespaces -- | Allow the user to write ambiguous types, and the type inference engine to infer them. -- - -- * + -- * | AllowAmbiguousTypes -- | Enable @foreign import javascript@. @@ -694,47 +715,51 @@ -- | Allow giving names to and abstracting over patterns. -- - -- * + -- * | PatternSynonyms -- | Allow anonymous placeholders (underscore) inside type signatures. The -- type inference engine will generate a message describing the type inferred -- at the hole's location. -- - -- * + -- * | PartialTypeSignatures -- | Allow named placeholders written with a leading underscore inside type -- signatures. Wildcards with the same name unify to the same type. -- - -- * + -- * | NamedWildCards -- | Enable @deriving@ for any class. -- - -- * + -- * | DeriveAnyClass -- | Enable @deriving@ for the 'Language.Haskell.TH.Syntax.Lift' class. -- - -- * + -- * | DeriveLift -- | Enable support for 'static pointers' (and the @static@ -- keyword) to refer to globally stable names, even across -- different programs. -- - -- * + -- * | StaticPointers -- | Switches data type declarations to be strict by default (as if -- they had a bang using @BangPatterns@), and allow opt-in field -- laziness using @~@. + -- + -- * | StrictData -- | Switches all pattern bindings to be strict by default (as if -- they had a bang using @BangPatterns@), ordinary patterns are -- recovered using @~@. Implies @StrictData@. + -- + -- * | Strict -- | Allows @do@-notation for types that are @'Applicative'@ as well @@ -760,7 +785,7 @@ -- code will compile with the new planned desugaring of fail. | MonadFailDesugaring - -- | A subset of @TemplateHaskell@ including only quasi-quoting. + -- | A subset of @TemplateHaskell@ including only quoting. | TemplateHaskellQuotes -- | Allows use of the @#label@ syntax. @@ -770,6 +795,16 @@ -- as injective. | TypeFamilyDependencies + -- | Allow multiple @deriving@ clauses, each optionally qualified with a + -- /strategy/. + | DerivingStrategies + + -- | Enable the use of unboxed sum syntax. + | UnboxedSums + + -- | Allow use of hexadecimal literal notation for floating-point values. + | HexFloatLiterals + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data) instance Binary KnownExtension @@ -794,18 +829,23 @@ -- name to the old one for older compilers. Otherwise we are in danger -- of the scenario in ticket #689. -instance Text Extension where - disp (UnknownExtension other) = Disp.text other - disp (EnableExtension ke) = Disp.text (show ke) - disp (DisableExtension ke) = Disp.text ("No" ++ show ke) +instance Pretty Extension where + pretty (UnknownExtension other) = Disp.text other + pretty (EnableExtension ke) = Disp.text (show ke) + pretty (DisableExtension ke) = Disp.text ("No" ++ show ke) +instance Parsec Extension where + parsec = classifyExtension <$> P.munch1 isAlphaNum + +instance Text Extension where parse = do extension <- Parse.munch1 isAlphaNum return (classifyExtension extension) -instance Text KnownExtension where - disp ke = Disp.text (show ke) +instance Pretty KnownExtension where + pretty ke = Disp.text (show ke) +instance Text KnownExtension where parse = do extension <- Parse.munch1 isAlphaNum case classifyKnownExtension extension of diff --git a/cabal/Cabal/Makefile b/cabal/Cabal/Makefile --- a/cabal/Cabal/Makefile +++ b/cabal/Cabal/Makefile @@ -1,5 +1,5 @@ -VERSION=1.25.0.0 +VERSION=2.1.0.0 #KIND=devel KIND=rc @@ -25,7 +25,15 @@ SDIST_STAMP=dist/Cabal-$(VERSION).tar.gz DISTLOC=dist/release DIST_STAMP=$(DISTLOC)/Cabal-$(VERSION).tar.gz +SPHINXCMD:=$(shell command -v sphinx-build2 2> /dev/null) +ifndef SPHINXCMD + SPHINXCMD:=$(shell command -v sphinx-build 2> /dev/null) +endif +ifndef SPHINXCMD + $(error "needs sphinx-build") +endif + COMMA=, setup: $(SOURCES) Setup.hs @@ -49,24 +57,12 @@ $(HADDOCK_STAMP) : $(CONFIG_STAMP) $(BUILD_STAMP) ./setup haddock -PANDOC=pandoc -PANDOC_OPTIONS= \ - --standalone \ - --smart \ - --css=$(PANDOC_HTML_CSS) -PANDOC_HTML_OUTDIR=dist/doc/users-guide -PANDOC_HTML_CSS=Cabal.css +SPHINX_HTML_OUTDIR=dist/doc/users-guide -users-guide: $(USERGUIDE_STAMP) doc/*.markdown -$(USERGUIDE_STAMP): doc/*.markdown - mkdir -p $(PANDOC_HTML_OUTDIR) - for file in $^; do \ - [ $${file} != doc/index.markdown ] && TOC=--table-of-contents || TOC=; \ - $(PANDOC) $(PANDOC_OPTIONS) $${TOC} --from=markdown --to=html \ - --output $(PANDOC_HTML_OUTDIR)/$$(basename $${file} .markdown).html \ - $${file}; \ - done - cp doc/$(PANDOC_HTML_CSS) $(PANDOC_HTML_OUTDIR) +users-guide: $(USERGUIDE_STAMP) +$(USERGUIDE_STAMP) : doc/*.rst + mkdir -p $(SPHINX_HTML_OUTDIR) + $(SPHINXCMD) doc $(SPHINX_HTML_OUTDIR) docs: haddock users-guide @@ -106,16 +102,19 @@ cp -r dist/doc/html $(DISTLOC)/Cabal-$(VERSION)/doc/API cp -r dist/doc/users-guide $(DISTLOC)/Cabal-$(VERSION)/doc/ cp changelog $(DISTLOC)/Cabal-$(VERSION)/ - tar -C $(DISTLOC) -czf $(DISTLOC)/Cabal-$(VERSION).tar.gz Cabal-$(VERSION) - mv $(DISTLOC)/Cabal-$(VERSION)/doc $(DISTLOC)/ + tar --format=ustar -C $(DISTLOC) -czf $(DISTLOC)/Cabal-$(VERSION).tar.gz Cabal-$(VERSION) + mkdir $(DISTLOC)/doc + mv $(DISTLOC)/Cabal-$(VERSION)/doc/users-guide $(DISTLOC)/doc + mv $(DISTLOC)/Cabal-$(VERSION)/doc/API $(DISTLOC)/doc mv $(DISTLOC)/Cabal-$(VERSION)/changelog $(DISTLOC)/ rm -r $(DISTLOC)/Cabal-$(VERSION)/ @echo "Cabal tarball built: $(DIST_STAMP)" @echo "Release fileset prepared: $(DISTLOC)/" -release: $(DIST_STAMP) - scp -r $(DISTLOC) $(SSH_USER)@haskell.org:/home/web/haskell.org/cabal/release/cabal-$(VERSION) - ssh $(SSH_USER)@haskell.org 'cd /home/web/haskell.org/cabal/release && rm -f $(KIND) && ln -s cabal-$(VERSION) $(KIND)' +# Out of date, use SFTP +#release: $(DIST_STAMP) +# scp -r $(DISTLOC) $(SSH_USER)@haskell.org:/home/web/haskell.org/cabal/release/cabal-$(VERSION) +# ssh $(SSH_USER)@haskell.org 'cd /home/web/haskell.org/cabal/release && rm -f $(KIND) && ln -s cabal-$(VERSION) $(KIND)' # tags... diff --git a/cabal/Cabal/changelog b/cabal/Cabal/changelog --- a/cabal/Cabal/changelog +++ b/cabal/Cabal/changelog @@ -1,6 +1,58 @@ -*-change-log-*- -1.25.x.x (current development version) +2.2.0.0 (current development version) + * Cabal does not try to build an empty set of `inputModules` (#4890). + * Add `HexFloatLiterals` to `KnownExtension` + * Added `virtual-module` field, to allow modules that are not built + but registered (#4875). + * `copyComponent` and `installIncludeFiles` will look for include + headers in the build directory ('dist/build/...' by default) + as well (#4866). + * Added cxx-options and cxx-sources build info fields for seperate + compilation of C++ source files (#3700) + * Remove unused '--allow-newer'/'--allow-older' support (#4527) + * Change `FlagAssignment` to be an opaque `newtype`. + * Change `rawSystemStdInOut` to use proper type to represent + binary and textual data; new 'Distribution.Utils.IOData' module; + removed obsolete 'startsWithBOM', 'fileHasBOM', 'fromUTF8', + and 'toUTF8' functions; add new `toUTF8BS`/`toUTF8LBS` + encoding functions. (#4666) + * Warn about `.cabal` file-name not matching package name + in 'cabal check' (#4592) + * By default 'ar' program receives arguments via '@file' format. + Old behavior can be restored with '--ar-does-not-support-at-arguments' + argument to 'configure' or 'install'. (#4596) + * Added '.Lens' modules, with optics for package description data + types. (#4701) + * Support for GHC's numeric -g debug levels (#4673). + * Added elif-conditionals to .cabal syntax (#4750). + * Support for building with Win32 version 2.6 (#4835). + * Compilation with section splitting is now supported via the + '--enable-split-sections' flag (#4819) + * TODO + +2.0.1.1 Mikhail Glushenkov December 2017 + * Don't pass `other-modules` to stub executable for detailed-0.9 + (#4918). + * Hpc: Use relative .mix search paths (#4917). + +2.0.1.0 Mikhail Glushenkov November 2017 + * Support for GHC's numeric -g debug levels (#4673). + * Added a new 'Distribution.Verbosity.modifyVerbosity' combinator + (#4724). + * Added a new 'cabal check' warning about unused, undeclared or + non-Unicode flags. Also, it warns about leading dash, which is + unusable but accepted if it's unused in conditionals. (#4687) + * Modify `allBuildInfo` to include foreign library info (#4763). + * Documentation fixes. + +2.0.0.2 Mikhail Glushenkov July 2017 + * See http://coldwa.st/e/blog/2017-09-09-Cabal-2-0.html + for more detailed release notes. + * The 2.0 migration guide gives advice on adapting Custom setup + scripts to backwards-incompatible changes in this release: + https://github.com/haskell/cabal/wiki/2.0-migration-guide + * Add CURRENT_PACKAGE_VERSION to cabal_macros.h (#4319) * Dropped support for versions of GHC earlier than 6.12 (#3111). * GHC compatibility window for the Cabal library has been extended to five years (#3838). @@ -108,7 +160,29 @@ * Support for "foreign libraries" (#2540), which are Haskell libraries intended to be used by foreign languages like C. Foreign libraries only work with GHC 7.8 and later. + * Added a technical preview version of integrated doctest support (#4480). + * Added a new 'scope' field to the executable stanza. Executables + with 'scope: private' get installed into + $libexecdir/$libexecsubdir. Additionally $libexecdir now has a + subdir structure similar to $lib(sub)dir to allow installing + private executables of different packages and package versions + alongside one another. Private executables are those that are + expected to be run by other programs rather than users. (#3461) +1.24.2.0 Mikhail Glushenkov December 2016 + * Fixed a bug in the handling of non-buildable components (#4094). + * Reverted a PVP-noncompliant API change in 1.24.1.0 (#4123). + * Bumped the directory upper bound to < 1.4 (#4158). + +1.24.1.0 Ryan Thomas October 2016 + * API addition: 'differenceVersionRanges' (#3519). + * Fixed reexported-modules display mangling (#3928). + * Check that the correct cabal-version is specified when the + extra-doc-files field is present (#3825). + * Fixed an incorrect invocation of GetShortPathName that was + causing build failures on Windows (#3649). + * Linker flags are now set correctly on GHC >= 7.8 (#3443). + 1.24.0.0 Ryan Thomas March 2016 * Support GHC 8. * Deal with extra C sources from preprocessors (#238). @@ -142,6 +216,46 @@ https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst for more details. +1.22.8.0 Ryan Thomas March 2016 + * Distribution.Simple.Setup: remove job cap. Fixes #3191. + * Check all object file suffixes for recompilation. Fixes #3128. + * Move source files under 'src/'. Fixes #3003. + +1.22.7.0 Ryan Thomas January 2016 + * Backport #3012 to the 1.22 branch + * Cabal.cabal: change build-type to Simple + * Add foldl' import + * The Cabal part for fully gcc-like response files + +1.22.6.0 Ryan Thomas December 2015 + * Relax upper bound to allow upcoming binary-0.8 + +1.22.5.0 Ryan Thomas November 2015 + * Don't recompile C sources unless needed (#2601). (Luke Iannini) + * Support Haddock response files. + * Add frameworks when linking a dynamic library. + +1.22.4.0 Ryan Thomas June 2015 + * Add libname install-dirs variable, use it by default. Fixes #2437. (Edward Z. Yang) + * Reduce temporary directory name length, fixes #2502. (Edward Z. Yang) + * Workaround for #2527. (Mikhail Glushenkov) + +1.22.3.0 Ryan Thomas April 2015 + * Fix for the ghcjs-pkg version number handling (Luite Stegeman) + * filterConfigureFlags: filter more flags (Mikhail Glushenkov) + * Cabal check will fail on -fprof-auto passed as a ghc-option - Fixes #2479 (John Chee) + +1.22.2.0 Ryan Thomas March 2015 + * Don't pass '--{en,dis}able-profiling' to old setup. + * Add -Wall police + * Fix dependencies on 'old-time' + * Fix test interface detailed-0.9 with GHC 7.10 + * Fix HPC tests with GHC 7.10 + * Make sure to pass the package key to ghc + * Use --package-{name|version} when available for Haddock when available + * Put full package name and version in library names + * Fully specify package key format, so external tools can generate it. + 1.22.0.0 Johan Tibell January 2015 * Support GHC 7.10. * Experimental support for emitting DWARF debug info. @@ -175,6 +289,9 @@ * Build shared libraries by default when linking executables dynamically. * Build profiled libraries by default when profiling executables. +1.20.0.4 Ryan Thomas January 2016 + * Cabal.cabal: change build-type to Simple. + 1.20.0.1 Johan Tibell May 2014 * Fix streaming test output. @@ -484,7 +601,7 @@ 1.1.1 Isaac Jones July 2005 * WARNING: Interfaces not documented in the user's guide may change in future releases. - * Handles recursive modules for GHC 6.2 and GHC 6.4. + * Handles recursive modules for GHC 6.2 and GHC 6.4. * Added "setup test" command (Used with UserHook) * implemented handling of _stub.{c,h,o} files * Added support for profiling diff --git a/cabal/Cabal/doc/README.md b/cabal/Cabal/doc/README.md --- a/cabal/Cabal/doc/README.md +++ b/cabal/Cabal/doc/README.md @@ -11,12 +11,16 @@ ### How to build it +* Currently requires python-2 * `> pip install sphinx` -* `> sphinx-build doc html` -* if you are missing dependencies, install them with pip as needed +* `> pip install sphinx_rtd_theme` +* `> cd Cabal` +* `> make clean users-guide` +* if you are missing any other dependencies, install them with `pip` as needed ¯\\\_(ツ)_/¯ * Python on Mac OS X dislikes `LC_CTYPE=UTF-8`, unset the env var in terminal preferences and instead set `LC_ALL=en_US.UTF-8` or something +* On archlinux, package `python2-sphinx` is sufficient. ### Caveats, for newcomers to RST from MD RST does not allow you to skip section levels when nesting, like MD diff --git a/cabal/Cabal/doc/conf.py b/cabal/Cabal/doc/conf.py --- a/cabal/Cabal/doc/conf.py +++ b/cabal/Cabal/doc/conf.py @@ -13,7 +13,7 @@ sys.path.insert(0, os.path.abspath('.')) import cabaldomain -version = "1.25" +version = "2.1" extensions = ['sphinx.ext.extlinks'] @@ -34,7 +34,7 @@ # General information about the project. project = u'Cabal' -copyright = u'2016, Cabal Team' +copyright = u'2003-2017, Cabal Team' # N.B. version comes from ghc_config release = version # The full version, including alpha/beta/rc tags. @@ -67,6 +67,17 @@ # Convert quotes and dashes to typographically correct entities html_use_smartypants = True html_show_copyright = True +html_context = { + 'source_url_prefix': "https://github.com/haskell/cabal/tree/master/Cabal/doc/", + "display_github": True, + "github_host": "github.com", + "github_user": "haskell", + "github_repo": 'cabal', + "github_version": "master/", + "conf_py_path": "Cabal/doc/", + "source_suffix": '.rst', +} + # If true, an OpenSearch description file will be output, and all pages will # contain a tag referring to it. The value of this option must be the 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 @@ -177,11 +177,13 @@ with. The most common kinds of constraints are: - ``pkgname >= n`` +- ``pkgname ^>= n`` (since Cabal 2.0) - ``pkgname >= n && < m`` -- ``pkgname == n.*`` +- ``pkgname == n.*`` (since Cabal 1.6) The last is just shorthand, for example ``base == 4.*`` means exactly -the same thing as ``base >= 4 && < 5``. +the same thing as ``base >= 4 && < 5``. Please refer to the documentation +on the :pkg-field:`build-depends` field for more information. Building the package -------------------- @@ -270,8 +272,10 @@ versions follow the conventional numeric style, consisting of a sequence of digits such as "1.0.1" or "2.0". There are a range of common conventions for "versioning" packages, that is giving some meaning to -the version number in terms of changes in the package. Section [TODO] -has some tips on package versioning. +the version number in terms of changes in the package, such as +e.g. `SemVer `__; however, for packages intended to be +distributed via Hackage Haskell's `Package Versioning Policy`_ applies +(see also the `PVP/SemVer FAQ section `__). The combination of package name and version is called the *package ID* and is written with a hyphen to separate the name and version, e.g. @@ -495,7 +499,7 @@ make up your package. You will need to add two more files to the root directory of the package: -:file:`{package}.cabal` +:file:`{package-name}.cabal` a Unicode UTF-8 text file containing a package description. For details of the syntax of this file, see the section on `package descriptions`_. @@ -537,12 +541,12 @@ version: 1.0 library - build-depends: base + build-depends: base >= 4 && < 5 exposed-modules: Foo extensions: ForeignFunctionInterface ghc-options: -Wall if os(windows) - build-depends: Win32 + build-depends: Win32 >= 2.1 && < 2.6 Example: A package containing a simple library ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -586,16 +590,16 @@ author: Angela Author license: BSD3 build-type: Simple - cabal-version: >= 1.2 + cabal-version: >= 1.8 executable program1 - build-depends: HUnit + build-depends: HUnit >= 1.1.1 && < 1.2 main-is: Main.hs hs-source-dirs: prog1 executable program2 main-is: Main.hs - build-depends: HUnit + build-depends: HUnit >= 1.1.1 && < 1.2 hs-source-dirs: prog2 other-modules: Utils @@ -612,10 +616,10 @@ license: BSD3 author: Angela Author build-type: Simple - cabal-version: >= 1.2 + cabal-version: >= 1.8 library - build-depends: HUnit + build-depends: HUnit >= 1.1.1 && < 1.2 exposed-modules: A, B, C executable program1 @@ -650,7 +654,8 @@ must be a Unicode text file encoded using valid UTF-8. There must be exactly one such file in the directory. The first part of the name is usually the package name, and some of the tools that operate on Cabal -packages require this. +packages require this; specifically, Hackage rejects packages which +don't follow this rule. In the package description file, lines whose first non-whitespace characters are "``--``" are treated as comments and ignored. @@ -727,7 +732,8 @@ ``hsc2hs`` preprocessors, Cabal will also automatically add, compile and link any C sources generated by the preprocessor (produced by ``hsc2hs``'s ``#def`` feature or ``c2hs``'s auto-generated wrapper -functions). +functions). Dependencies on pre-processors are specified via the +:pkg-field:`build-tools` or :pkg-field:`build-tool-depends` fields. Some fields take lists of values, which are optionally separated by commas, except for the :pkg-field:`build-depends` field, where the commas are @@ -746,6 +752,10 @@ The unique name of the package, without the version number. + As pointed out in the section on `package descriptions`_, some + tools require the package-name specified for this field to match + the package description's file-name :file:`{package-name}.cabal`. + .. pkg-field:: version: numbers (required) The package version number, usually consisting of a sequence of @@ -894,7 +904,7 @@ :: - bug-reports: http://hackage.haskell.org/trac/hackage/ + bug-reports: https://github.com/haskell/cabal/issues .. pkg-field:: package-url: URL @@ -1000,6 +1010,15 @@ A list of modules added by this package. +.. pkg-field:: virtual-modules: identifier list + + A list of virtual modules provided by this package. Virtual modules + are modules without a source file. See for example the ``GHC.Prim`` + module from the ``ghc-prim`` package. Modules listed here will not be + built, but still end up in the list of ``exposed-modules`` in the + installed package info when the package is registered in the package + database. + .. pkg-field:: exposed: boolean :default: ``True`` @@ -1038,7 +1057,7 @@ The library section may also contain build information fields (see the section on `build information`_). -Cabal 1.25 and later support "internal libraries", which are extra named +Cabal 2.0 and later support "internal libraries", which are extra named libraries (as opposed to the usual unnamed library section). For example, suppose that your test suite needs access to some internal modules in your library, which you do not otherwise want to export. You @@ -1056,15 +1075,19 @@ library foo-internal exposed-modules: Foo.Internal + -- NOTE: no explicit constraints on base needed + -- as they're inherited from the 'library' stanza build-depends: base library exposed-modules: Foo.Public - build-depends: foo-internal, base + build-depends: foo-internal, base >= 4.3 && < 5 test-suite test-foo type: exitcode-stdio-1.0 main-is: test-foo.hs + -- NOTE: no constraints on 'foo-internal' as same-package + -- dependencies implicitly refer to the same package instance build-depends: foo-internal, base Internal libraries are also useful for packages that define multiple @@ -1147,6 +1170,83 @@ foo >= 0.5.2 && < 0.6 bar >= 1.1 && < 1.2 +Listing outdated dependency version bounds +"""""""""""""""""""""""""""""""""""""""""" + +Manually updating dependency version bounds in a ``.cabal`` file or a +freeze file can be tedious, especially when there's a lot of +dependencies. The ``cabal outdated`` command is designed to help with +that. It will print a list of packages for which there is a new +version on Hackage that is outside the version bound specified in the +``build-depends`` field. The ``outdated`` command can also be +configured to act on the freeze file (both old- and new-style) and +ignore major (or all) version bumps on Hackage for a subset of +dependencies. + +The following flags are supported by the ``outdated`` command: + +``--freeze-file`` + Read dependency version bounds from the freeze file (``cabal.config``) + instead of the package description file (``$PACKAGENAME.cabal``). +``--new-freeze-file`` + Read dependency version bounds from the new-style freeze file + (``cabal.project.freeze``) instead of the package description file. +``--simple-output`` + Print only the names of outdated dependencies, one per line. +``--exit-code`` + Exit with a non-zero exit code when there are outdated dependencies. +``-q, --quiet`` + Don't print any output. Implies ``-v0`` and ``--exit-code``. +``--ignore`` *PACKAGENAMES* + Don't warn about outdated dependency version bounds for the packages in this + list. +``--minor`` *[PACKAGENAMES]* + Ignore major version bumps for these packages. E.g. if there's a version 2.0 + of a package ``pkg`` on Hackage and the freeze file specifies the constraint + ``pkg == 1.9``, ``cabal outdated --freeze --minor=pkg`` will only consider + the ``pkg`` outdated when there's a version of ``pkg`` on Hackage satisfying + ``pkg > 1.9 && < 2.0``. ``--minor`` can also be used without arguments, in + that case major version bumps are ignored for all packages. + +Examples: + +.. code-block:: console + + $ cd /some/package + $ cabal outdated + Outdated dependencies: + haskell-src-exts <1.17 (latest: 1.19.1) + language-javascript <0.6 (latest: 0.6.0.9) + unix ==2.7.2.0 (latest: 2.7.2.1) + + $ cabal outdated --simple-output + haskell-src-exts + language-javascript + unix + + $ cabal outdated --ignore=haskell-src-exts + Outdated dependencies: + language-javascript <0.6 (latest: 0.6.0.9) + unix ==2.7.2.0 (latest: 2.7.2.1) + + $ cabal outdated --ignore=haskell-src-exts,language-javascript,unix + All dependencies are up to date. + + $ cabal outdated --ignore=haskell-src-exts,language-javascript,unix -q + $ echo $? + 0 + + $ cd /some/other/package + $ cabal outdated --freeze-file + Outdated dependencies: + HTTP ==4000.3.3 (latest: 4000.3.4) + HUnit ==1.3.1.1 (latest: 1.5.0.0) + + $ cabal outdated --freeze-file --ignore=HTTP --minor=HUnit + Outdated dependencies: + HUnit ==1.3.1.1 (latest: 1.3.1.2) + + Executables ^^^^^^^^^^^ @@ -1169,6 +1269,13 @@ must be relative to one of the directories listed in :pkg-field:`hs-source-dirs`. +.. pkg-field:: scope: token + :since: 2.0 + + Whether the executable is ``public`` (default) or ``private``, i.e. meant to + be run by other programs rather than the user. Private executables are + installed into `$libexecdir/$libexecsubdir`. + Running executables """"""""""""""""""" @@ -1189,8 +1296,8 @@ Test suites ^^^^^^^^^^^ -.. pkg-section:: test name - :synopsis: Test suit build information. +.. pkg-section:: test-suite name + :synopsis: Test suite build information. Test suite sections (if present) describe package test suites and must have an argument after the section label, which defines the name of the @@ -1263,7 +1370,7 @@ Test-Suite test-foo type: exitcode-stdio-1.0 main-is: test-foo.hs - build-depends: base + build-depends: base >= 4 && < 5 .. code-block:: haskell :caption: test-foo.hs @@ -1297,7 +1404,7 @@ Test-Suite test-bar type: detailed-0.9 test-module: Bar - build-depends: base, Cabal >= 1.9.2 + build-depends: base >= 4 && < 5, Cabal >= 1.9.2 && < 2 .. code-block:: haskell @@ -1397,7 +1504,7 @@ Benchmark bench-foo type: exitcode-stdio-1.0 main-is: bench-foo.hs - build-depends: base, time + build-depends: base >= 4 && < 5, time >= 1.1 && < 1.7 .. code-block:: haskell :caption: bench-foo.hs @@ -1433,7 +1540,7 @@ pass to ``cabal bench``. Foreign libraries -""""""""""""""""" +^^^^^^^^^^^^^^^^^ Foreign libraries are system libraries intended to be linked against programs written in C or other "foreign" languages. They @@ -1451,6 +1558,7 @@ foreign-library myforeignlib type: native-shared + lib-version-info: 6:3:2 if os(Windows) options: standalone @@ -1463,6 +1571,13 @@ c-sources: csrc/MyForeignLibWrapper.c default-language: Haskell2010 + +.. pkg-section:: foreign-library name + :since: 2.0 + :synopsis: Foriegn library build information. + + Build information for `foreign libraries`_. + .. pkg-field:: type: foreign library type Cabal recognizes ``native-static`` and ``native-shared`` here, although @@ -1483,11 +1598,53 @@ This option can only be used when creating dynamic Windows libraries (that is, when using ``native-shared`` and the ``os`` is ``Windows``). If - used, it must be a path to a _module definition file_. The details of + used, it must be a path to a *module definition file*. The details of module definition files are beyond the scope of this document; see the `GHC `_ manual for some details and some further pointers. +.. pkg-field:: lib-version-info: current:revision:age + + This field is currently only used on Linux. + + This field specifies a Libtool-style version-info field that sets + an appropriate ABI version for the foreign library. Note that the + three numbers specified in this field do not directly specify the + actual ABI version: ``6:3:2`` results in library version ``4.2.3``. + + With this field set, the SONAME of the library is set, and symlinks + are installed. + + How you should bump this field on an ABI change depends on the + breakage you introduce: + + - Programs using the previous version may use the new version as + drop-in replacement, and programs using the new version can also + work with the previous one. In other words, no recompiling nor + relinking is needed. In this case, bump ``revision`` only, don't + touch current nor age. + - Programs using the previous version may use the new version as + drop-in replacement, but programs using the new version may use + APIs not present in the previous one. In other words, a program + linking against the new version may fail with "unresolved + symbols" if linking against the old version at runtime: set + revision to 0, bump current and age. + - Programs may need to be changed, recompiled, and relinked in + order to use the new version. Bump current, set revision and age + to 0. + + Also refer to the Libtool documentation on the version-info field. + +.. pkg-field:: lib-version-linux: version + + This field is only used on Linux. + + Specifies the library ABI version directly for foreign libraries + built on Linux: so specifying ``4.2.3`` causes a library + ``libfoo.so.4.2.3`` to be built with SONAME ``libfoo.so.4``, and + appropriate symlinks ``libfoo.so.4`` and ``libfoo.so`` to be + installed. + Note that typically foreign libraries should export a way to initialize and shutdown the Haskell runtime. In the example above, this is done by the ``csrc/MyForeignLibWrapper.c`` file, which might look something like @@ -1564,23 +1721,49 @@ It is only syntactic sugar. It is exactly equivalent to ``foo >= 1.2 && < 1.3``. - Starting with Cabal 2.0, there's a new syntactic sugar to support + .. Warning:: + + A potential pitfall of the wildcard syntax is that the + constraint ``nats == 1.0.*`` doesn't match the release + ``nats-1`` because the version ``1`` is lexicographically less + than ``1.0``. This is not an issue with the caret-operator + ``^>=`` described below. + + Starting with Cabal 2.0, there's a new syntactic sugar to express PVP_-style - major upper bounds conveniently, and is inspired by similiar + major upper bounds conveniently, and is inspired by similar syntactic sugar found in other language ecosystems where it's often called the "Caret" operator: :: - build-depends: foo ^>= 1.2.3.4, - bar ^>= 1 + build-depends: + foo ^>= 1.2.3.4, + bar ^>= 1 - The declaration above is exactly equivalent to + This allows to express the intent that this packages requires + versions of ``foo`` and ``bar`` which are semantically compatible + to ``foo-1.2.3.4`` and ``bar-1`` respectively. This subtle but important + difference in signaling allows tooling to treat *"hard"* ``<``-style + and *"weak"* ``^>=``-style upper bounds differently. For instance, + :option:`--allow-newer`'s ``^``-modifier allows to relax only *"weak"* + ``^>=``-style bounds while leaving ``<``-bounds unaffected. + Ignoring the signaling intent, the equivalences are + + - ``^>= x`` == ``>= x && < x.1`` + - ``^>= x.y`` == ``>= x.y && < x.(y+1)`` + - ``^>= x.y.z`` == ``>= x.y.z && < x.(y+1)`` + - ``^>= x.y.z.u`` == ``>= x.y.z.u && < x.(y+1)`` + - etc. + + Consequently, the example declaration above is equivalent to + :: - build-depends: foo >= 1.2.3.4 && < 1.3, - bar >= 1 && < 1.1 + build-depends: + foo >= 1.2.3.4 && < 1.3, + bar >= 1 && < 1.1 .. Note:: @@ -1660,15 +1843,97 @@ Deprecated in favor of :pkg-field:`default-extensions`. +.. pkg-field:: build-tool-depends: package:executable list + :since: 2.0 + + A list of Haskell programs needed to build this component. + Each is specified by the package containing the executable and the name of the executable itself, separated by a colon, and optionally followed by a version bound. + It is fine for the package to be the current one, in which case this is termed an *internal*, rather than *external* executable dependency. + + External dependencies can (and should) contain a version bound like conventional :pkg-field:`build-depends` dependencies. + Internal deps should not contain a version bound, as they will be always resolved within the same configuration of the package in the build plan. + Specifically, version bounds that include the package's version will be warned for being extraneous, and version bounds that exclude the package's version will raise an error for being impossible to follow. + + Cabal can make sure that specified programs are built and on the ``PATH`` before building the component in question. + It will always do so for internal dependencies, and also do so for external dependencies when using Nix-style local builds. + + :pkg-field:`build-tool-depends` was added in Cabal 2.0, and it will + be ignored (with a warning) with old versions of Cabal. See + :pkg-field:`build-tools` for more information about backwards + compatibility. + .. pkg-field:: build-tools: program list + :deprecated: - A list of programs, possibly annotated with versions, needed to - build this package, e.g. ``c2hs >= 0.15, cpphs``. If no version - constraint is specified, any version is assumed to be acceptable. - :pkg-field:`build-tools` can refer to locally defined executables, in which - case Cabal will make sure that executable is built first and add it - to the PATH upon invocations to the compiler. + Deprecated in favor of :pkg-field:`build-tool-depends`, but :ref:`see below for backwards compatibility information `. + A list of Haskell programs needed to build this component. + Each may be followed by an optional version bound. + Confusingly, each program in the list either refer to one of three things: + + 1. Another executables in the same package (supported since Cabal 1.12) + + 2. Tool name contained in Cabal's :ref:`hard-coded set of common tools ` + + 3. A pre-built executable that should already be on the ``PATH`` + (supported since Cabal 2.0) + + These cases are listed in order of priority: + an executable in the package will override any of the hard-coded packages with the same name, + and a hard-coded package will override any executable on the ``PATH``. + + In the first two cases, the list entry is desugared into a :pkg-field:`build-tool-depends` entry. + In the first case, the entry is desugared into a :pkg-field:`build-tool-depends` entry by prefixing with ``$pkg:``. + In the second case, it is desugared by looking up the package and executable name in a hard-coded table. + In either case, the optional version bound is passed through unchanged. + Refer to the documentation for :pkg-field:`build-tool-depends` to understand the desugared field's meaning, along with restrictions on version bounds. + + .. _buildtoolsbc: + + **Backward Compatiblity** + + Although this field is deprecated in favor of :pkg-field:`build-tool-depends`, there are some situations where you may prefer to use :pkg-field:`build-tools` in cases (1) and (2), as it is supported by more versions of Cabal. + In case (3), :pkg-field:`build-tool-depends` is better for backwards-compatibility, as it will be ignored by old versions of Cabal; if you add the executable to :pkg-field:`build-tools`, a setup script built against old Cabal will choke. + If an old version of Cabal is used, an end-user will have to manually arrange for the requested executable to be in your ``PATH``. + + .. _buildtoolsmap: + + **Set of Known Tool Names** + + Identifiers specified in :pkg-field:`build-tools` are desugared into their respective equivalent :pkg-field:`build-tool-depends` form according to the table below. Consequently, a legacy specification such as:: + + build-tools: alex >= 3.2.1 && < 3.3, happy >= 1.19.5 && < 1.20 + + is simply desugared into the equivalent specification:: + + build-tool-depends: alex:alex >= 3.2.1 && < 3.3, happy:happy >= 1.19.5 && < 1.20 + + +--------------------------+-----------------------------------+-----------------+ + | :pkg-field:`build-tools` | desugared | Note | + | identifier | :pkg-field:`build-tool-depends` | | + | | identifier | | + +==========================+===================================+=================+ + | ``alex`` | ``alex:alex`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``c2hs`` | ``c2hs:c2hs`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``cpphs`` | ``cpphs:cpphs`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``greencard`` | ``greencard:greencard`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``haddock`` | ``haddock:haddock`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``happy`` | ``happy:happy`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``hsc2hs`` | ``hsc2hs:hsc2hs`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``hscolour`` | ``hscolour:hscolour`` | | + +--------------------------+-----------------------------------+-----------------+ + | ``hspec-discover`` | ``hspec-discover:hspec-discover`` | since Cabal 2.0 | + +--------------------------+-----------------------------------+-----------------+ + + This built-in set can be programmatically extended via ``Custom`` setup scripts; this, however, is of limited use since the Cabal solver cannot access information injected by ``Custom`` setup scripts. + .. pkg-field:: buildable: boolean :default: ``True`` @@ -1768,12 +2033,32 @@ source tree. Cabal looks in these directories when attempting to locate files listed in :pkg-field:`includes` and :pkg-field:`install-includes`. - + .. pkg-field:: c-sources: filename list A list of C source files to be compiled and linked with the Haskell files. +.. pkg-field:: cxx-sources: filename list + + A list of C++ source files to be compiled and linked with the Haskell + files. Useful for segregating C and C++ sources when supplying different + command-line arguments to the compiler via the :pkg-field:`cc-options` + and the :pkg-field:`cxx-options` fields. The files listed in the + :pkg-field:`cxx-sources` can reference files listed in the + :pkg-field:`c-sources` field and vice-versa. The object files will be linked + appropriately. + +.. pkg-field:: asm-sources: filename list + + A list of assembly source files to be compiled and linked with the + Haskell files. + +.. pkg-field:: cmm-sources: filename list + + A list of C-- source files to be compiled and linked with the Haskell + files. + .. pkg-field:: js-sources: filename list A list of JavaScript source files to be linked with the Haskell @@ -1788,6 +2073,15 @@ A list of extra libraries to be used instead of 'extra-libraries' when the package is loaded with GHCi. +.. pkg-field:: extra-bundled-libraries: token list + + A list of libraries that are supposed to be copied from the build + directory alongside the produced haskell libraries. Note that you + are under the obligation to produce those lirbaries in the build + directory (e.g. via a custom setup). Libraries listed here will + be included when ``copy``-ing packages and be listed in the + ``hs-libraries`` of the package configuration. + .. pkg-field:: extra-lib-dirs: directory list A list of directories to search for libraries. @@ -1804,6 +2098,18 @@ haskell source and other pre-processed Haskell source like .hsc .chs. Does not apply to C code, that's what cc-options is for. +.. pkg-field:: cxx-options: token list + + Command-line arguments to be passed to the compiler when compiling + C++ code. The C++ sources to which these command-line arguments + should be applied can be specified with the :pkg-field:`cxx-sources` + field. Command-line options for C and C++ can be passed separately to + the compiler when compiling both C and C++ sources by segregating the C + and C++ sources with the :pkg-field:`c-sources` and + :pkg-field:`cxx-sources` fields respectively, and providing different + command-line arguments with the :pkg-field:`cc-options` and the + :pkg-field:`cxx-options` fields. + .. pkg-field:: ld-options: token list Command-line arguments to be passed to the linker. Since the @@ -1853,45 +2159,61 @@ Name: Test1 Version: 0.0.1 - Cabal-Version: >= 1.2 + Cabal-Version: >= 1.8 License: BSD3 Author: Jane Doe Synopsis: Test package to test configurations Category: Example + Build-Type: Simple Flag Debug Description: Enable debug support Default: False + Manual: True Flag WebFrontend Description: Include API for web frontend. - -- Cabal checks if the configuration is possible, first - -- with this flag set to True and if not it tries with False + Default: False + Manual: True + Flag NewDirectory + description: Whether to build against @directory >= 1.2@ + -- This is an automatic flag which the solver will be + -- assign automatically while searching for a solution + Library - Build-Depends: base + Build-Depends: base >= 4.2 && < 4.9 Exposed-Modules: Testing.Test1 Extensions: CPP - if flag(debug) - GHC-Options: -DDEBUG + GHC-Options: -Wall + if flag(Debug) + CPP-Options: -DDEBUG if !os(windows) CC-Options: "-DDEBUG" else CC-Options: "-DNDEBUG" - if flag(webfrontend) - Build-Depends: cgi > 0.42 + if flag(WebFrontend) + Build-Depends: cgi >= 0.42 && < 0.44 Other-Modules: Testing.WebStuff + CPP-Options: -DWEBFRONTEND + if flag(NewDirectory) + build-depends: directory >= 1.2 && < 1.4 + Build-Depends: time >= 1.0 && < 1.9 + else + build-depends: directory == 1.1.* + Build-Depends: old-time >= 1.0 && < 1.2 + Executable test1 Main-is: T1.hs Other-Modules: Testing.Test1 - Build-Depends: base + Build-Depends: base >= 4.2 && < 4.9 if flag(debug) CC-Options: "-DDEBUG" - GHC-Options: -DDEBUG + CPP-Options: -DDEBUG Layout """""" @@ -1914,23 +2236,25 @@ Name: Test1 Version: 0.0.1 - Cabal-Version: >= 1.2 + Cabal-Version: >= 1.8 License: BSD3 Author: Jane Doe Synopsis: Test package to test configurations Category: Example + Build-Type: Simple Flag Debug { Description: Enable debug support Default: False + Manual: True } Library { - Build-Depends: base + Build-Depends: base >= 4.2 && < 4.9 Exposed-Modules: Testing.Test1 Extensions: CPP if flag(debug) { - GHC-Options: -DDEBUG + CPP-Options: -DDEBUG if !os(windows) { CC-Options: "-DDEBUG" } else { @@ -1947,8 +2271,13 @@ Flag section declares a flag which can be used in `conditional blocks`_. -A flag section may contain the following fields: +Flag names are case-insensitive and must match ``[[:alnum:]_][[:alnum:]_-]*`` +regular expression. +.. note:: + + Hackage accepts ASCII-only flags, ``[a-zA-Z0-9_][a-zA-Z0-9_-]*`` regexp. + .. pkg-field:: description: freeform The description of this flag. @@ -2001,6 +2330,17 @@ Note that the ``if`` and the condition have to be all on the same line. +Since Cabal 2.2 conditional blocks support ``elif`` construct. + +:: + + if condition1 + property-descriptions-or-conditionals + elif condition2 + property-descriptions-or-conditionals + else + property-descriptions-or-conditionals + Conditions """""""""" @@ -2274,10 +2614,28 @@ Fork the package's source repository using the appropriate version control system. The optional argument allows to choose a specific repository kind. +``--index-state`` *[HEAD\|@\|]* + Use source package index state as it existed at a previous time. Accepts + unix-timestamps (e.g. ``@1474732068``), ISO8601 UTC timestamps (e.g. + ``2016-09-24T17:47:48Z``), or ``HEAD`` (default). + This determines which package versions are available as well as which + ``.cabal`` file revision is selected (unless ``--pristine`` is used). +``--pristine`` + Unpack the original pristine tarball, rather than updating the + ``.cabal`` file with the latest revision from the package archive. Custom setup scripts -------------------- +Since Cabal 1.24, custom ``Setup.hs`` are required to accurately track +their dependencies by declaring them in the ``.cabal`` file rather than +rely on dependencies being implicitly in scope. Please refer +`this article `__ +for more details. + +Declaring a ``custom-setup`` stanza also enables the generation of +``MIN_VERSION_package_(A,B,C)`` CPP macros for the Setup component. + .. pkg-section:: custom-setup :synopsis: Custom Setup.hs build information. :since: 1.24 @@ -2289,8 +2647,8 @@ custom-setup setup-depends: - base >= 4.5 && < 4.11, - Cabal < 1.25 + base >= 4.5 && < 4.11, + Cabal >= 1.14 && < 1.25 .. pkg-field:: setup-depends: package list :since: 1.24 @@ -2299,6 +2657,74 @@ :pkg-field:`build-depends` field for a description of the syntax expected by this field. +Backward compatibility and ``custom-setup`` +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +Versions prior to Cabal 1.24 don't recognise ``custom-setup`` stanzas, +and will behave agnostic to them (except for warning about an unknown +section). Consequently, versions prior to Cabal 1.24 can't ensure the +declared dependencies ``setup-depends`` are in scope, and instead +whatever is registered in the current package database environment +will become eligible (and resolved by the compiler) for the +``Setup.hs`` module. + +The availability of the +``MIN_VERSION_package_(A,B,C)`` CPP macros +inside ``Setup.hs`` scripts depends on the condition that either + +- a ``custom-setup`` section has been declared (or ``cabal new-build`` is being + used which injects an implicit hard-coded ``custom-setup`` stanza if it's missing), or +- GHC 8.0 or later is used (which natively injects package version CPP macros) + +Consequently, if you need to write backward compatible ``Setup.hs`` +scripts using CPP, you should declare a ``custom-setup`` stanza and +use the pattern below: + +.. code-block:: haskell + + {-# LANGUAGE CPP #-} + import Distribution.Simple + + #if defined(MIN_VERSION_Cabal) + -- version macros are available and can be used as usual + # if MIN_VERSION_Cabal(a,b,c) + -- code specific to lib:Cabal >= a.b.c + # else + -- code specific to lib:Cabal < a.b.c + # endif + #else + # warning Enabling heuristic fall-back. Please upgrade cabal-install to 1.24 or later if Setup.hs fails to compile. + + -- package version macros not available; except for exotic environments, + -- you can heuristically assume that lib:Cabal's version is correlated + -- with __GLASGOW_HASKELL__, and specifically since we can assume that + -- GHC < 8.0, we can assume that lib:Cabal is version 1.22 or older. + #endif + + main = ... + +The simplified (heuristic) CPP pattern shown below is useful if all you need +is to distinguish ``Cabal < 2.0`` from ``Cabal >= 2.0``. + +.. code-block:: haskell + + {-# LANGUAGE CPP #-} + import Distribution.Simple + + #if !defined(MIN_VERSION_Cabal) + # define MIN_VERSION_Cabal(a,b,c) 0 + #endif + + #if MIN_VERSION_Cabal(2,0,0) + -- code for lib:Cabal >= 2.0 + #else + -- code for lib:Cabal < 2.0 + #endif + + main = ... + + + Autogenerated modules --------------------- @@ -2309,12 +2735,13 @@ really on the package when distributed. This makes commands like sdist fail because the file is not found. -This special modules must appear again on the :pkg-field:`autogen-modules` +These special modules must appear again on the :pkg-field:`autogen-modules` field of the stanza that is using it, besides :pkg-field:`other-modules` or :pkg-field:`library:exposed-modules`. With this there is no need to create complex build hooks for this poweruser case. .. pkg-field:: autogen-modules: module list + :since: 2.0 .. TODO: document autogen-modules field @@ -2576,9 +3003,18 @@ sequence, but numeric on each component, so for example 1.2.0 is greater than 1.0.3). -Since version 1.20, there is also the ``MIN_TOOL_VERSION_``\ *``tool``* -family of macros for conditioning on the version of build tools used to +Since version 1.20, the ``MIN_TOOL_VERSION_``\ *``tool``* +family of macros lets you condition on the version of build tools used to build the program (e.g. ``hsc2hs``). + +Since version 1.24, the macro ``CURRENT_COMPONENT_ID``, which +expands to the string of the component identifier that uniquely +identifies this component. Furthermore, if the package is a library, +the macro ``CURRENT_PACKAGE_KEY`` records the identifier that was passed +to GHC for use in symbols and for type equality. + +Since version 2.0, the macro ``CURRENT_PACKAGE_VERSION`` expands +to the string version number of the current package. Cabal places the definitions of these macros into an automatically-generated header file, which is included when diff --git a/cabal/Cabal/doc/index.rst b/cabal/Cabal/doc/index.rst --- a/cabal/Cabal/doc/index.rst +++ b/cabal/Cabal/doc/index.rst @@ -11,3 +11,4 @@ concepts-and-development bugs-and-stability nix-local-build-overview + nix-integration 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 @@ -495,8 +495,8 @@ (As mentioned previously, you *must* specify internal dependencies as well.) -- Internal ``build-tools`` dependencies are expected to be in the - ``PATH`` upon subsequent invocations of ``setup``. +- Internal ``build-tool-depends`` and ``build-tools`` dependencies are expected + to be in the ``PATH`` upon subsequent invocations of ``setup``. Full details can be found in the `Componentized Cabal proposal `__. @@ -645,17 +645,30 @@ .. option:: --libsubdir=dir - A subdirectory of *libdir* in which libraries are actually - installed. For example, in the simple build system on Unix, the - default *libdir* is ``/usr/local/lib``, and *libsubdir* contains the - package identifier and compiler, e.g. ``mypkg-0.2/ghc-6.4``, so + A subdirectory of *libdir* in which libraries are actually installed. For + example, in the simple build system on Unix, the default *libdir* is + ``/usr/local/lib``, and *libsubdir* contains the compiler ABI and package + identifier, + e.g. ``x86_64-linux-ghc-8.0.2/mypkg-0.1.0-IxQNmCA7qrSEQNkoHSF7A``, so libraries would be installed in - ``/usr/local/lib/mypkg-0.2/ghc-6.4``. + ``/usr/local/lib/x86_64-linux-ghc-8.0.2/mypkg-0.1.0-IxQNmCA7qrSEQNkoHSF7A/``. *dir* may contain the following path variables: ``$pkgid``, ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, ``$abitag`` +.. option:: --libexecsubdir=dir + + A subdirectory of *libexecdir* in which private executables are + installed. For example, in the simple build system on Unix, the default + *libexecdir* is ``/usr/local/libexec``, and *libsubdir* is + ``x86_64-linux-ghc-8.0.2/mypkg-0.1.0``, so private executables would be + installed in ``/usr/local/libexec/x86_64-linux-ghc-8.0.2/mypkg-0.1.0/`` + + *dir* may contain the following path variables: ``$pkgid``, + ``$pkg``, ``$version``, ``$compiler``, ``$os``, ``$arch``, ``$abi``, + ``$abitag`` + .. option:: --datasubdir=dir A subdirectory of *datadir* in which data files are actually @@ -967,6 +980,8 @@ if the compiler supports it. Level 2 is likely to lead to longer compile times and bigger generated code. + When optimizations are enabled, Cabal passes ``-O2`` to the C compiler. + .. option:: --disable-optimization Build without optimization. This is suited for development: building @@ -1122,6 +1137,16 @@ (default) Do not build shared library. +.. option:: --enable-static + + Build a static library. This passes ``-staticlib`` to GHC (available + for iOS, and with 8.4 more platforms). The result is an archive ``.a`` + containing all dependent haskell libararies combined. + +.. option:: --disable-static + + (default) Do not build a static library. + .. option:: --enable-executable-dynamic Link executables dynamically. The executable's library dependencies @@ -1255,24 +1280,103 @@ .. option:: --constraint=constraint - Restrict solutions involving a package to a given version range. For - example, ``cabal install --constraint="bar==2.1"`` will only - consider install plans that do not use ``bar`` at all, or ``bar`` of - version 2.1. + Restrict solutions involving a package to given version + bounds, flag settings, and other properties. For example, to + consider only install plans that use version 2.1 of ``bar`` + or do not use ``bar`` at all, write: - As a special case, ``cabal install --constraint="bar -none"`` - prevents ``bar`` from being used at all (``-none`` abbreviates - ``> 1 && < 1``); ``cabal install --constraint="bar installed"`` - prevents reinstallation of the ``bar`` package; - ``cabal install --constraint="bar +foo -baz"`` specifies that the - flag ``foo`` should be turned on and the ``baz`` flag should be - turned off. + :: + $ 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 + used at all: + + :: + + # Note: this is just syntax sugar for '> 1 && < 1', and is + # supported by build-depends. + $ cabal install --constraint="bar -none" + + You can also specify flag assignments: + + :: + + # Require bar to be installed with the foo flag turned on and + # the baz flag turned off. + $ cabal install --constraint="bar +foo -baz" + + To specify multiple constraints, you may pass the + ``constraint`` option multiple times. + + There are also some more specialized constraints, which most people + don't generally need: + + :: + + # Require that a version of bar be used that is already installed in + # the global package database. + $ cabal install --constraint="bar installed" + + # Require the local source copy of bar to be used. + # (Note: By default, if we have a local package we will + # automatically use it, so it will generally not be necessary to + # specify this.) + $ cabal install --constraint="bar source" + + # Require that bar have test suites and benchmarks enabled. + $ cabal install --constraint="bar test" --constraint="bar bench" + + By default, constraints only apply to build dependencies + (``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 + tools. To explicitly apply a constraint to a setup or build + tool dependency, you can add a qualifier to the constraint as + follows: + + :: + + # Example use of the 'any' qualifier. This constraint + # applies to package bar anywhere in the dependency graph. + $ cabal install --constraint="any.bar == 1.0" + + :: + + # Example uses of 'setup' qualifiers. + + # This constraint applies to package bar when it is a + # dependency of any Setup.hs script. + $ cabal install --constraint="setup.bar == 1.0" + + # This constraint applies to package bar when it is a + # dependency of the Setup.hs script of package foo. + $ cabal install --constraint="foo:setup.bar == 1.0" + + .. TODO: Uncomment this example once we decide on a syntax for 'exe'. + .. # Example use of the 'exe' (executable build tool) + # qualifier. This constraint applies to package baz when it + # is a dependency of the build tool bar being used to + # build package foo. + $ cabal install --constraint="foo:bar:exe.baz == 1.0" + .. option:: --preference=preference Specify a soft constraint on versions of a package. The solver will attempt to satisfy these preferences on a "best-effort" basis. +.. option:: --disable-response-files + + Enable workaround for older versions of programs such as ``ar`` or + ``ld`` that do not support response file arguments (i.e. ``@file`` + arguments). You may want this flag only if you specify custom ar + executable. For system ``ar`` or the one bundled with ``ghc`` on + Windows the ``cabal`` should do the right thing and hence should + normally not require this flag. + .. _setup-build: setup build @@ -1603,8 +1707,8 @@ The files placed in this distribution are the package description file, the setup script, the sources of the modules named in the package description file, and files named in the ``license-file``, ``main-is``, -``c-sources``, ``js-sources``, ``data-files``, ``extra-source-files`` -and ``extra-doc-files`` fields. +``c-sources``, ``asm-sources``, ``cmm-sources``, ``js-sources``, +``data-files``, ``extra-source-files`` and ``extra-doc-files`` fields. This command takes the following option: diff --git a/cabal/Cabal/doc/nix-integration.rst b/cabal/Cabal/doc/nix-integration.rst new file mode 100644 --- /dev/null +++ b/cabal/Cabal/doc/nix-integration.rst @@ -0,0 +1,49 @@ +Nix Integration +=============== + +`Nix `_ is a package manager popular with some Haskell developers due to its focus on reliability and reproducibility. ``cabal`` now has the ability to integrate with Nix for dependency management during local package development. + +Enabling Nix Integration +------------------------ + +To enable Nix integration, simply pass the ``--enable-nix`` global option when you call ``cabal``. To use this option everywhere, edit your ``$HOME/.cabal/config`` file to include: + +.. code-block:: cabal + + nix: True + +If the package (which must be locally unpacked) provides a ``shell.nix`` or ``default.nix`` file, this flag will cause ``cabal`` to run most commands through ``nix-shell``. If both expressions are present, ``shell.nix`` is preferred. The following commands are affected: + +- ``cabal configure`` +- ``cabal build`` +- ``cabal repl`` +- ``cabal install`` (only if installing into a sandbox) +- ``cabal haddock`` +- ``cabal freeze`` +- ``cabal gen-bounds`` +- ``cabal run`` + +If the package does not provide an expression, ``cabal`` runs normally. + +Creating Nix Expressions +------------------------ + +The Nix package manager is based on a lazy, pure, functional programming language; packages are defined by expressions in this language. The fastest way to create a Nix expression for a Cabal package is with the `cabal2nix `_ tool. To create a ``shell.nix`` expression for the package in the current directory, run this command: + +.. code-block:: console + + $ cabal2nix --shell ./. >shell.nix + +Nix Expression Evaluation +------------------------- + +(This section describes for advanced users how Nix expressions are evaluated.) + +First, the Nix expression (``shell.nix`` or ``default.nix``) is instantiated with ``nix-instantiate``. The ``--add-root`` and ``--indirect`` options are used to create an indirect root in the Cabal build directory, preventing Nix from garbage collecting the derivation while in use. The ``IN_NIX_SHELL`` environment variable is set so that ``builtins.getEnv`` works as it would in ``nix-shell``. + +Next, the commands above are run through ``nix-shell`` using the instantiated derivation. Again, ``--add-root`` and ``--indirect`` are used to prevent Nix from garbage collecting the packages in the environment. The child ``cabal`` process reads the ``CABAL_IN_NIX_SHELL`` environment variable to prevent it from spawning additional child shells. + +Further Reading +---------------- + +The `Nix manual `_ provides further instructions for writing Nix expressions. The `Nixpkgs manual `_ describes the infrastructure provided for Haskell packages. diff --git a/cabal/Cabal/doc/nix-local-build-overview.rst b/cabal/Cabal/doc/nix-local-build-overview.rst --- a/cabal/Cabal/doc/nix-local-build-overview.rst +++ b/cabal/Cabal/doc/nix-local-build-overview.rst @@ -1,10 +1,12 @@ Nix-style Local Builds ====================== -``cabal new-build``, also known as Nix-style local builds, is a new -command inspired by Nix that comes with cabal-install 1.24. Nix-style -local builds combine the best of non-sandboxed and sandboxed Cabal: +Nix-style local builds are a new build system implementation inspired by Nix. +The Nix-style local build system is commonly called "new-build" for short after the ``cabal new-*`` family of commands that control it. +However those names are only temporary until Nix-style local builds becomes the default. +Nix-style local builds combine the best of non-sandboxed and sandboxed Cabal: + 1. Like sandboxed Cabal today, we build sets of independent local packages deterministically and independent of any global state. new-build will never tell you that it can't build your package @@ -20,8 +22,8 @@ rebuild dependencies whenever you make a new sandbox: dependencies which can be shared, are shared. -Nix-style local builds work with all versions of GHC supported by -cabal-install 1.24, which currently is GHC 7.0 and later. +Nix-style local builds were first released as beta in cabal-install 1.24. +They currently work with all versions of GHC supported by that release: GHC 7.0 and later. Some features described in this manual are not implemented. If you need them, please give us a shout and we'll prioritize accordingly. 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 @@ -17,6 +17,12 @@ $ cabal new-repl +To run an executable defined in this package, use this command: + +:: + + $ cabal new-run [executable args] + Developing multiple packages ---------------------------- @@ -139,11 +145,11 @@ find that we already have this ID built, we can just use the already built version. -The global package store is ``~/.cabal/store``; if you need to clear -your store for whatever reason (e.g., to reclaim disk space or because -the global store is corrupted), deleting this directory is safe -(``new-build`` will just rebuild everything it needs on its next -invocation). +The global package store is ``~/.cabal/store`` (configurable via +global `store-dir` option); if you need to clear your store for +whatever reason (e.g., to reclaim disk space or because the global +store is corrupted), deleting this directory is safe (``new-build`` +will just rebuild everything it needs on its next invocation). This split motivates some of the UI choices for Nix-style local build commands. For example, flags passed to ``cabal new-build`` are only @@ -167,7 +173,7 @@ there is no programmatic way to access the location of build products. The location of the build products is intended to be an internal implementation detail of new-build, but we also understand that many -unimplemented features (e.g., ``new-test``) can only be reasonably +unimplemented features (e.g., ``new-install``) can only be reasonably worked around by accessing build products directly. The location where build products can be found varies depending on the @@ -285,6 +291,20 @@ apply options to an external package, use a ``package`` stanza in a ``cabal.project`` file. +cabal new-update +---------------- + +``cabal new-update`` updates the state of the package index. If the +project contains multiple remote package repositories it will update +the index of all of them (e.g. when using overlays). + +Seom examples: + +:: + + $ cabal new-update # update all remote repos + $ cabal new-update head.hackage # update only head.hackage + cabal new-build --------------- @@ -303,8 +323,19 @@ a specific component (e.g., a library, executable, test suite or benchmark) to be built. +- All packages: ``all``, which specifies all packages within the project. + +- Components of a particular type: ``package:ctypes``, ``all:ctypes``: + which specifies all components of the given type. Where valid + ``ctypes`` are: + - ``libs``, ``libraries``, + - ``flibs``, ``foreign-libraries``, + - ``exes``, ``executables``, + - ``tests``, + - ``benches``, ``benchmarks``. + In component targets, ``package:`` and ``ctype:`` (valid component types -are ``lib``, ``exe``, ``test`` and ``bench``) can be used to +are ``lib``, ``flib``, ``exe``, ``test`` and ``bench``) can be used to disambiguate when multiple packages define the same component, or the same component name is used in a package (e.g., a package ``foo`` defines both an executable and library named ``foo``). We always prefer @@ -338,14 +369,38 @@ (``new-repl`` will just successively open a separate GHCi session for each target.) +cabal new-run +------------- + +``cabal new-run [TARGET [ARGS]]`` runs the executable specified by the +target, which can be a component, a package or can be left blank, as +long as it can uniquely identify an executable within the project. + +See `the new-build section <#cabal-new-build>`__ for the target syntax. + +Except in the case of the empty target, the strings after it will be +passed to the executable as arguments. + +If one of the arguments starts with ``-`` it will be interpreted as +a cabal flag, so if you need to pass flags to the executable you +have to separate them with ``--``. + +:: + + $ cabal new-run target -- -a -bcd --argument + cabal new-freeze ---------------- -``cabal new-freeze`` writes out a ``cabal.project.freeze`` file which -records all of the versions and flags which that are picked by the -solver under the current index and flags. A ``cabal.project.freeze`` -file has the same syntax as ``cabal.project`` and looks something like -this: +``cabal new-freeze`` writes out a **freeze file** which records all of +the versions and flags which that are picked by the solver under the +current index and flags. Default name of this file is +``cabal.project.freeze`` but in combination with a +``--project-file=my.project`` flag (see :ref:`project-file +`) +the name will be ``my.project.freeze``. +A freeze file has the same syntax as ``cabal.project`` and looks +something like this: .. highlight:: cabal @@ -364,34 +419,39 @@ recommended: users often need to build against different versions of libraries than what you developed against. -Unsupported commands --------------------- +cabal new-bench +--------------- -The following commands are not currently supported: +``cabal new-bench [TARGETS] [OPTIONS]`` runs the specified benchmarks +(all the benchmarks in the current package by default), first ensuring +they are up to date. -``cabal new-test`` (:issue:`3638`) - Workaround: run the test executable directly (see `Where are my - build products <#where-are-my-build-products>`__?) +cabal new-test +-------------- -``cabal new-bench`` (:issue:`3638`) - Workaround: run the benchmark executable directly (see `Where are my - build products <#where-are-my-build-products>`__?) +``cabal new-test [TARGETS] [OPTIONS]`` runs the specified test suites +(all the test suites in the current package by default), first ensuring +they are up to date. -``cabal new-run`` (:issue:`3638`) - Workaround: run the executable directly (see `Where are my build - products <#where-are-my-build-products>`__?) +cabal new-haddock +----------------- -``cabal new-exec`` - Workaround: if you wanted to execute GHCi, consider using - ``cabal new-repl`` instead. Otherwise, use ``-v`` to find the list - of flags GHC is being invoked with and pass it manually. +``cabal new-haddock [FLAGS] TARGET`` builds Haddock documentation for +the specified packages within the project. -``cabal new-haddock`` (:issue:`3535`) - Workaround: run - ``cabal act-as-setup -- haddock --builddir=dist-newstyle/build/pkg-0.1`` - (or execute the Custom setup script directly). +cabal new-exec +--------------- -``cabal new-install`` (:issue:`3737`) +``cabal new-exec [FLAGS] [--] COMMAND [--] [ARGS]`` runs the specified command +using the project's environment. That is, passing the right flags to compiler +invocations and bringing the project's executables into scope. + +Unsupported commands +-------------------- + +The following commands are not currently supported: + +``cabal new-install`` (:issue:`3737` and :issue:`3332`) Workaround: no good workaround at the moment. (But note that you no longer need to install libraries before building!) @@ -580,39 +640,55 @@ The command line variant of this field is ``--keep-going``. +.. option:: --builddir=DIR + Specifies the name of the directory where build products for + build will be stored; defaults to ``dist-newstyle``. If a + relative name is specified, this directory is resolved relative + to the root of the project (i.e., where the ``cabal.project`` + file lives.) + + This option cannot be specified via a ``cabal.project`` file. + +.. _cmdoption-project-file: +.. option:: --project-file=FILE + + Specifies the name of the project file used to specify the + rest of the top-level configuration; defaults to ``cabal.project``. + This name not only specifies the name of the main project file, + but also the auxiliary project files ``cabal.project.freeze`` + and ``cabal.project.local``; for example, if you specify + ``--project-file=my.project``, then the other files that will + be probed are ``my.project.freeze`` and ``my.project.local``. + + If the specified project file is a relative path, we will + look for the file relative to the current working directory, + and then for the parent directory, until the project file is + found or we have hit the top of the user's home directory. + + This option cannot be specified via a ``cabal.project`` file. + +.. option:: --store-dir=DIR + + Specifies the name of the directory of the global package store. + Solver configuration options ---------------------------- The following settings control the behavior of the dependency solver: .. cfg-field:: constraints: constraints list (comma separated) - --constrant="pkg >= 2.0" + --constraint="pkg >= 2.0" :synopsis: Extra dependencies constraints. - Add extra constraints to the version bounds, flag settings, and - other properties a solver can pick for a package. For example, to - only consider install plans that do not use ``bar`` at all, or use - ``bar-2.1``, write: - + Add extra constraints to the version bounds, flag settings, + and other properties a solver can pick for a + package. For example: + :: constraints: bar == 2.1 - Version bounds have the same syntax as ``build-depends``. You can - also specify flag assignments: - - :: - - -- Require bar to be installed with the foo flag turned on and - -- the baz flag turned off - constraints: bar +foo -baz - - -- Require that bar NOT be present in the install plan. Note: - -- this is just syntax sugar for '> 1 && < 1', and is supported - -- by build-depends. - constraints: bar -none - A package can be specified multiple times in ``constraints``, in which case the specified constraints are intersected. This is useful, since the syntax does not allow you to specify multiple @@ -622,33 +698,11 @@ :: constraints: bar == 2.1, - bar +foo -baz, - - There are also some more specialized constraints, which most people - don't generally need: - - :: - - -- Require bar to be preinstalled in the global package database - -- (this does NOT include the Nix-local build global store.) - constraints: bar installed - - -- Require the local source copy of bar to be used - -- (Note: By default, if we have a local package we will - -- automatically use it, so it generally not be necessary to - -- specify this) - constraints: bar source - - -- Require that bar be solved with test suites and benchmarks enabled - -- (Note: By default, new-build configures the solver to make - -- a best-effort attempt to enable these stanzas, so this generally - -- should not be necessary.) - constraints: bar test, - bar bench + bar +foo -baz - The command line variant of this field is - ``--constraint="pkg >= 2.0"``; to specify multiple constraints, pass - the flag multiple times. + Valid constraints take the same form as for the `constraint + command line option + `__. .. cfg-field:: preferences: preference (comma separated) --preference="pkg >= 2.0" @@ -676,7 +730,7 @@ the flag multiple times. .. cfg-field:: allow-newer: none, all or list of scoped package names (space or comma separated) - --allow-newer, --allow-newer=[none,all,pkg] + --allow-newer, --allow-newer=[none,all,[scope:][^]pkg] :synopsis: Lift dependencies upper bound constaints. :default: ``none`` @@ -693,11 +747,28 @@ allow-newer: pkg:dep-pkg - This syntax is recommended, as it is often only a single package + If the scope shall be limited to specific releases of ``pkg``, the + extended form as in + + :: + + allow-newer: pkg-1.2.3:dep-pkg, pkg-1.1.2:dep-pkg + + can be used to limit the relaxation of dependencies on + ``dep-pkg`` by the ``pkg-1.2.3`` and ``pkg-1.1.2`` releases only. + + The scoped syntax is recommended, as it is often only a single package whose upper bound is misbehaving. In this case, the upper bounds of other packages should still be respected; indeed, relaxing the bound can break some packages which test the selected version of packages. + The syntax also allows to prefix the dependee package with a + modifier symbol to modify the scope/semantic of the relaxation + transformation in a additional ways. Currently only one modifier + symbol is defined, i.e. ``^`` (i.e. caret) which causes the + relaxation to be applied only to ``^>=`` operators and leave all other + version operators untouched. + However, in some situations (e.g., when attempting to build packages on a new version of GHC), it is useful to disregard *all* upper-bounds, with respect to a package or all packages. This can be @@ -707,22 +778,54 @@ :: -- Disregard upper bounds involving the dependencies on - -- packages bar, baz and quux - allow-newer: bar, baz, quux + -- packages bar, baz. For quux only, relax + -- 'quux ^>= ...'-style constraints only. + allow-newer: bar, baz, ^quux -- Disregard all upper bounds when dependency solving allow-newer: all + -- Disregard all `^>=`-style upper bounds when dependency solving + allow-newer: ^all + + + For consistency, there is also the explicit wildcard scope syntax + ``*`` (or its alphabetic synonym ``all``). Consequently, the + examples above are equivalent to the explicitly scoped variants: + + :: + + allow-newer: all:bar, *:baz, *:^quux + + allow-newer: *:* + allow-newer: all:all + + allow-newer: *:^* + allow-newer: all:^all + + In order to ignore all bounds specified by a package ``pkg-1.2.3`` + you can combine scoping with a right-hand-side wildcard like so + + :: + + -- Disregard any upper bounds specified by pkg-1.2.3 + allow-newer: pkg-1.2.3:* + + -- Disregard only `^>=`-style upper bounds in pkg-1.2.3 + allow-newer: pkg-1.2.3:^* + + :cfg-field:`allow-newer` is often used in conjunction with a constraint (in the cfg-field:`constraints` field) forcing the usage of a specific, newer version of a package. - The command line variant of this field is ``--allow-newer=bar``. A + The command line variant of this field is e.g. ``--allow-newer=bar``. A bare ``--allow-newer`` is equivalent to ``--allow-newer=all``. .. cfg-field:: allow-older: none, all, list of scoped package names (space or comma separated) - --allow-older, --allow-older=[none,all,pkg] + --allow-older, --allow-older=[none,all,[scope:][^]pkg] :synopsis: Lift dependency lower bound constaints. + :since: 2.0 :default: ``none`` @@ -735,7 +838,7 @@ .. cfg-field:: index-state: HEAD, unix-timestamp, ISO8601 UTC timestamp. :synopsis: Use source package index state as it existed at a previous time. - :since: 1.25 + :since: 2.0 :default: ``HEAD`` @@ -891,6 +994,8 @@ planning to run code, turning off optimization will lead to better build times and less code to be rebuilt when a module changes. + When optimizations are enabled, Cabal passes ``-O2`` to the C compiler. + We also accept ``True`` (equivalent to 1) and ``False`` (equivalent to 0). @@ -996,8 +1101,8 @@ Object code options ^^^^^^^^^^^^^^^^^^^ -.. cfg-field:: debug-info: boolean - --enable-debug-info +.. cfg-field:: debug-info: integer + --enable-debug-info= --disable-debug-info :synopsis: Build with debug info enabled. :since: 1.22 @@ -1009,16 +1114,35 @@ instruct it to do so. See the GHC wiki page on :ghc-wiki:`DWARF` for more information about this feature. - (This field also accepts numeric syntax, but as of GHC 8.0 this - doesn't do anything.) + (This field also accepts numeric syntax, but until GHC 8.2 this didn't + do anything.) The command line variant of this flag is ``--enable-debug-info`` and ``--disable-debug-info``. +.. cfg-field:: split-sections: boolean + --enable-split-sections + --disable-split-sections + :synopsis: Use GHC's split sections feature. + :since: 2.1 + + :default: False + + Use the GHC ``-split-sections`` feature when building the library. This + reduces the final size of the executables that use the library by + allowing them to link with only the bits that they use rather than + the entire library. The downside is that building the library takes + longer and uses a bit more memory. + + This feature is supported by GHC 8.0 and later. + + The command line variant of this flag is ``--enable-split-sections`` and + ``--disable-split-sections``. + .. cfg-field:: split-objs: boolean --enable-split-objs --disable-split-objs - :synopsis: Use GHC split objects feature. + :synopsis: Use GHC's split objects feature. :default: False @@ -1028,6 +1152,9 @@ the entire library. The downside is that building the library takes longer and uses considerably more memory. + It is generally recommend that you use ``split-sections`` instead + of ``split-objs`` where possible. + The command line variant of this flag is ``--enable-split-objs`` and ``--disable-split-objs``. @@ -1161,6 +1288,21 @@ The command line variant of this flag is ``--relocatable``. +Static linking options +^^^^^^^^^^^^^^^^^^^^^^ + +.. cfg-field:: static: boolean + --enable-static + --disable-static + :synopsis: Build static library. + + + :default: False + + Roll this and all dependent libraries into a combined ``.a`` archive. + This uses GHCs ``-staticlib`` flag, which is avaiable for iOS and with + GHC 8.4 and later for other platforms as well. + Foreign function interface options ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -1684,6 +1826,21 @@ The command line variant of this field is ``--(no-)strong-flags``. +.. cfg-field:: allow-boot-library-installs: boolean + --allow-boot-library-installs + --no-allow-boot-library-installs + :synopsis: Allow cabal to install or upgrade any package. + + :default: False + + By default, the dependency solver doesn't allow ``base``, + ``ghc-prim``, ``integer-simple``, ``integer-gmp``, and + ``template-haskell`` to be installed or upgraded. This flag + removes the restriction. + + The command line variant of this field is + ``--(no-)allow-boot-library-installs``. + .. cfg-field:: cabal-lib-version: version --cabal-lib-version=version :synopsis: Version of Cabal library used to build package. @@ -1696,6 +1853,5 @@ The command line variant of this field is ``--cabal-lib-version=1.24.0.1``. - .. include:: references.inc diff --git a/cabal/Cabal/misc/gen-extra-source-files.hs b/cabal/Cabal/misc/gen-extra-source-files.hs deleted file mode 100644 --- a/cabal/Cabal/misc/gen-extra-source-files.hs +++ /dev/null @@ -1,119 +0,0 @@ -#!/usr/bin/env runhaskell -{-# LANGUAGE PackageImports #-} - --- NB: Force an installed Cabal package to be used, NOT --- some local files which have these names (as would be --- the case if we were in the Cabal source directory.) -import "Cabal" Distribution.PackageDescription -import "Cabal" Distribution.PackageDescription.Parse (ParseResult (..), parsePackageDescription) -import "Cabal" Distribution.Verbosity (silent) -import qualified "Cabal" Distribution.ModuleName as ModuleName - -import Data.List (isPrefixOf, isSuffixOf, sort) -import System.Environment (getArgs, getProgName) -import System.FilePath (takeExtension, takeFileName) -import System.Process (readProcess) - -import qualified System.IO as IO - -main' :: FilePath -> IO () -main' fp = do - -- Read cabal file, so we can determine test modules - contents <- strictReadFile fp - cabal <- case parsePackageDescription contents of - ParseOk _ x -> pure x - ParseFailed errs -> fail (show errs) - - -- We skip some files - let testModuleFiles = getOtherModulesFiles cabal - let skipPredicates' = skipPredicates ++ map (==) testModuleFiles - - -- Read all files git knows about under "tests" and "PackageTests" (cabal-testsuite) - files0 <- lines <$> readProcess "git" ["ls-files", "tests", "PackageTests"] "" - - -- Filter - let files1 = filter (\f -> takeExtension f `elem` whitelistedExtensionss || - takeFileName f `elem` whitelistedFiles) - files0 - let files2 = filter (\f -> not $ any ($ dropTestsDir f) skipPredicates') files1 - let files3 = sort files2 - let files = files3 - - -- Read current file - let inputLines = lines contents - linesBefore = takeWhile (/= topLine) inputLines - linesAfter = dropWhile (/= bottomLine) inputLines - - -- Output - let outputLines = linesBefore ++ [topLine] ++ map (" " ++) files ++ linesAfter - writeFile fp (unlines outputLines) - - -topLine, bottomLine :: String -topLine = " -- BEGIN gen-extra-source-files" -bottomLine = " -- END gen-extra-source-files" - -dropTestsDir :: FilePath -> FilePath -dropTestsDir fp - | pfx `isPrefixOf` fp = drop (length pfx) fp - | otherwise = fp - where - pfx = "tests/" - -whitelistedFiles :: [FilePath] -whitelistedFiles = [ "ghc", "ghc-pkg", "ghc-7.10", "ghc-pkg-7.10", "ghc-pkg-ghc-7.10" ] - -whitelistedExtensionss :: [String] -whitelistedExtensionss = map ('.' : ) - [ "hs", "lhs", "c", "h", "sh", "cabal", "hsc", "err", "out", "in", "project" ] - -getOtherModulesFiles :: GenericPackageDescription -> [FilePath] -getOtherModulesFiles gpd = mainModules ++ map fromModuleName otherModules' - where - testSuites :: [TestSuite] - testSuites = map (foldMapCondTree id . snd) (condTestSuites gpd) - - mainModules = concatMap (mainModule . testInterface) testSuites - otherModules' = concatMap (otherModules . testBuildInfo) testSuites - - fromModuleName mn = ModuleName.toFilePath mn ++ ".hs" - - mainModule (TestSuiteLibV09 _ mn) = [fromModuleName mn] - mainModule (TestSuiteExeV10 _ fp) = [fp] - mainModule _ = [] - -skipPredicates :: [FilePath -> Bool] -skipPredicates = - [ isSuffixOf "register.sh" - ] - where - -- eq = (==) - -main :: IO () -main = do - args <- getArgs - case args of - [fp] -> main' fp - _ -> do - progName <- getProgName - putStrLn "Error too few arguments!" - putStrLn $ "Usage: " ++ progName ++ " FILE" - putStrLn " where FILE is Cabal.cabal, cabal-testsuite.cabal or cabal-install.cabal" - -strictReadFile :: FilePath -> IO String -strictReadFile fp = do - handle <- IO.openFile fp IO.ReadMode - contents <- get handle - IO.hClose handle - return contents - where - get h = IO.hGetContents h >>= \s -> length s `seq` return s - -foldMapCondTree :: Monoid m => (a -> m) -> CondTree v c a -> m -foldMapCondTree f (CondNode x _ cs) - = mappend (f x) - -- list, 3-tuple+maybe - $ (foldMap . foldMapTriple . foldMapCondTree) f cs - where - foldMapTriple :: Monoid x => (b -> x) -> (a, b, Maybe b) -> x - foldMapTriple f (_, x, y) = mappend (f x) (foldMap f y) diff --git a/cabal/LICENSE b/cabal/LICENSE --- a/cabal/LICENSE +++ b/cabal/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2016, Cabal Development Team. +Copyright (c) 2003-2017, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents. diff --git a/cabal/Makefile b/cabal/Makefile new file mode 100644 --- /dev/null +++ b/cabal/Makefile @@ -0,0 +1,23 @@ +.PHONY : all lexer lib exe doctest gen-extra-source-files + +LEXER_HS:=Cabal/Distribution/Parsec/Lexer.hs + +all : exe lib + +lexer : $(LEXER_HS) + +$(LEXER_HS) : boot/Lexer.x + alex --latin1 --ghc -o $@ $^ + +lib : $(LEXER_HS) + cabal new-build --enable-tests Cabal + +exe : $(LEXER_HS) + cabal new-build --enable-tests cabal + +doctest : + doctest --fast Cabal/Distribution Cabal/Language + +gen-extra-source-files: + cabal new-run --builddir=dist-newstyle-meta --project-file=cabal.project.meta gen-extra-source-files -- Cabal/Cabal.cabal + cabal new-run --builddir=dist-newstyle=meta --project-file=cabal.project.meta gen-extra-source-files -- cabal-install/cabal-install.cabal diff --git a/cabal/Paths_Cabal.hs b/cabal/Paths_Cabal.hs --- a/cabal/Paths_Cabal.hs +++ b/cabal/Paths_Cabal.hs @@ -5,4 +5,4 @@ import Data.Version (Version(..)) version :: Version -version = Version [1,25,0,0] [] +version = Version [2,1,0,0] [] diff --git a/cabal/Paths_cabal_install.hs b/cabal/Paths_cabal_install.hs --- a/cabal/Paths_cabal_install.hs +++ b/cabal/Paths_cabal_install.hs @@ -5,4 +5,4 @@ import Data.Version (Version(..)) version :: Version -version = Version [1,25,0,0] [] +version = Version [2,1,0,0] [] diff --git a/cabal/README.md b/cabal/README.md --- a/cabal/README.md +++ b/cabal/README.md @@ -8,9 +8,15 @@ The canonical upstream repository is located at https://github.com/haskell/cabal. -Installing Cabal ----------------- +Installing Cabal (by downloading the binary) +-------------------------------------------- +Prebuilt binary releases can be obtained from https://www.haskell.org/cabal/download.html. +The `cabal-install` binary download for your platform should contain the `cabal` executable. + +Installing Cabal (with cabal) +----------------------------- + Assuming that you have a pre-existing, older version of `cabal-install`, run: @@ -29,6 +35,17 @@ (cd cabal-install; cabal install) ~~~~ +Installing Cabal (without cabal) +-------------------------------- + +Assuming you don't have a pre-existing copy of `cabal-install`, run: + +~~~~ +cabal-install $ ./bootstrap.sh # running ./bootstrap.sh from within in cabal-install folder. +~~~~ + +For more details, and non-unix like systems, see the [README.md in cabal-install](cabal-install/README.md) + Building Cabal for hacking -------------------------- @@ -38,36 +55,70 @@ it is sufficient to run: ~~~~ -cabal new-build cabal-install +cabal new-build cabal ~~~~ -To build a local, development copy of cabal-install. The binary -will be located at -`dist-newstyle/build/cabal-install-$VERSION/build/cabal/cabal`; -you can determine the `$VERSION` of cabal-install by looking at -[cabal-install/cabal-install.cabal](cabal-install/cabal-install.cabal). +To build a local, development copy of cabal-install. The location +of your build products will vary depending on which version of +cabal-install you use to build; see the documentation section +[Where are my build products?](http://cabal.readthedocs.io/en/latest/nix-local-build.html#where-are-my-build-products) +to find the binary (or just run `find -type f -executable -name cabal`). Here are some other useful variations on the commands: ~~~~ cabal new-build Cabal # build library only -cabal new-build Cabal:package-tests # build Cabal's package test suite -cabal new-build cabal-install:integration-tests # etc... +cabal new-build Cabal:unit-tests # build Cabal's unit test suite +cabal new-build cabal-tests # etc... ~~~~ +**Dogfooding HEAD.** +Many of the core developers of Cabal dogfood `cabal-install` HEAD +when doing development on Cabal. This helps us identify bugs +which were missed by the test suite and easily experiment with new +features. + +The recommended workflow in this case is slightly different: you will +maintain two Cabal source trees: your production tree (built with a +released version of Cabal) which always tracks `master` and which you +update only when you want to move to a new version of Cabal to dogfood, +and your development tree (built with your production Cabal) that you +actually do development on. + +In more detail, suppose you have checkouts of Cabal at `~/cabal-prod` +and `~/cabal-dev`, and you have a release copy of cabal installed at +`/opt/cabal/1.24/bin/cabal`. First, build your production tree: + +~~~~ +cd ~/cabal-prod +/opt/cabal/1.24/bin/cabal new-build cabal +~~~~ + +This will produce a cabal binary (see also: [Where are my build products?](http://cabal.readthedocs.io/en/latest/nix-local-build.html#where-are-my-build-products) +). Add this binary to your PATH, +and then use it to build your development copy: + +~~~~ +cd ~/cabal-dev +cabal new-build cabal +~~~~ + Running tests ------------- **Using Travis and AppVeyor.** -The easiest way to run tests on Cabal is to make a branch on GitHub -and then open a pull request; our continuous integration service on -Travis and AppVeyor will build and test your code. Title your PR -with WIP so we know that it does not need code review. Alternately, -you can enable Travis on your fork in your own username and Travis -should build your local branches. +If you are not in a hurry, the most convenient way to run tests on Cabal +is to make a branch on GitHub and then open a pull request; our +continuous integration service on Travis and AppVeyor will build and +test your code. Title your PR with WIP so we know that it does not need +code review. Some tips for using Travis effectively: +* Travis builds take a long time. Use them when you are pretty + sure everything is OK; otherwise, try to run relevant tests locally + first. + * Watch over your jobs on the [Travis website](http://travis-ci.org). If you know a build of yours is going to fail (because one job has already failed), be nice to others and cancel the rest of the jobs, @@ -75,37 +126,55 @@ * 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). -* If you enable Travis for the fork of Cabal in your local GitHub, you - can have builds done automatically for your local branch seperate - from Cabal. This is an alternative to opening a PR. +**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 +build. Here are some guidelines for debugging continuous integration +failures: -**Running tests locally.** -To run tests locally with `new-build`, you will need to know the -name of the test suite you want. Cabal and cabal-install have -several. In general, the test executable for -`{Cabal,cabal-install}:$TESTNAME` will be stored at -`dist-newstyle/build/{Cabal,cabal-install}-$VERSION/build/$TESTNAME/$TESTNAME`. +1. Can you tell what the problem is by looking at the logs? The + `cabal-testsuite` tests run with `-v` logging by default, which + is dumped to the log upon failure; you may be able to figure out + what the problem is directly this way. -To run a single test, use `-p` which applies a regex filter to the test names. +2. Can you reproduce the problem by running the test locally? + See the next section for how to run the various test suites + on your local machine. -* `Cabal:package-tests` are out-of-process integration tests on the top-level `Setup` - command line interface. If you are hacking on the Cabal library you - want to run this test suite. It must be run from the `Cabal` subdirectory - (ugh!) This test suite can be a bit touchy; see - [Cabal/tests/README.md](Cabal/tests/README.md) for more information. - Build products and test logs are generated and stored in - `Cabal/tests/PackageTests` under folders named `dist-test` and - `dist-test.$subname`. +3. Is the test failing only for a specific version of GHC, or + a specific operating system? If so, try reproducing the + problem on the specific configuration. - Handy command line spell to find test logs is: - ```sh - find . -name test.log|grep test-name - ``` +4. Is the test failing on a Travis per-GHC build + ([for example](https://travis-ci.org/haskell-pushbot/cabal-binaries/builds/208128401))? + In this case, if you click on "Branch", you can get access to + the precise binaries that were built by Travis that are being + tested. If you have an Ubuntu system, you can download + the binaries and run them directly. - `test.sh` in the same directory as `test.log` is intended to let you rerun - the test without running the actual test driver. +5. Is the test failing on AppVeyor? Consider logging in via + Remote Desktop to the build VM: + https://www.appveyor.com/docs/how-to/rdp-to-build-worker/ +If none of these let you reproduce, there might be some race condition +or continuous integration breakage; please file a bug. +**Running tests locally.** +To run tests locally with `new-build`, you will need to know the +name of the test suite you want. Cabal and cabal-install have +several. Also, you'll want to read [Where are my build products?](http://cabal.readthedocs.io/en/latest/nix-local-build.html#where-are-my-build-products) + +The most important test suite is `cabal-testsuite`: most user-visible +changes to Cabal should come with a test in this framework. See +[cabal-testsuite/README.md](cabal-testsuite/README.md) for more +information about how to run tests and write new ones. Quick +start: use `cabal-tests` to run `Cabal` tests, and `cabal-tests +--with-cabal=/path/to/cabal` to run `cabal-install` tests +(don't forget `--with-cabal`! Your cabal-install tests won't +run without it). + +There are also other test suites: + * `Cabal:unit-tests` are small, quick-running unit tests on small pieces of functionality in Cabal. If you are working on some utility functions in the Cabal library you should run this @@ -120,14 +189,12 @@ cabal-install's dependency solver. If you are working on the solver you should run this test suite. -* `cabal-install:integration-tests` are out-of-process integration tests on the - top-level `cabal` command line interface. The coverage is not - very good but it attempts to exercise most of cabal-install. - * `cabal-install:integration-tests2` are integration tests on some top-level API functions inside the `cabal-install` source code. - You should also run this test suite. +For these test executables, `-p` which applies a regex filter to the test +names. + Conventions ----------- @@ -136,6 +203,8 @@ * Try to follow style conventions of a file you are modifying, and avoid gratuitous reformatting (it makes merges harder!) +* Format your commit messages [in the standard way](https://chris.beams.io/posts/git-commit/#seven-rules). + * A lot of Cabal does not have top-level comments. We are trying to fix this. If you add new top-level definitions, please Haddock them; and if you spend some time understanding what a function does, help @@ -143,10 +212,14 @@ * If you do something tricky or non-obvious, add a comment. +* If your commit only touches comments, you can use `[ci skip]` + anywhere in the body of the commit message to avoid needlessly + triggering the build bots. + * For local imports (Cabal module importing Cabal module), import lists are NOT required (although you may use them at your discretion.) For - third-party and standard library imports, please use explicit import - lists. + third-party and standard library imports, please use either qualified imports + or explicit import lists. * You can use basically any GHC extension supported by a GHC in our support window, except Template Haskell, which would cause @@ -157,11 +230,13 @@ buildable out-of-the-box with the dependencies that shipped with GHC for at least five years. The Travis CI checks this, so most developers submit a PR to see if their code works on all these - versions of GHC. cabal-install must also be buildable on all + versions of GHC. `cabal-install` must also be buildable on all supported GHCs, although it does not have to be buildable out-of-the-box. Instead, the `cabal-install/bootstrap.sh` script - must be able to download and install all of the dependencies. (This - is also checked by CI!) + must be able to download and install all of the dependencies (this + is also checked by CI). Also, self-upgrade to the latest version + (i.e. `cabal install cabal-install`) must work with all versions of + `cabal-install` released during the last three years. * `Cabal` has its own Prelude, in `Distribution.Compat.Prelude`, that provides a compatibility layer and exports some commonly @@ -204,8 +279,7 @@ * For more organizational concerns, the [mailing list](http://www.haskell.org/mailman/listinfo/cabal-devel) is used. -* Many developers idle on `#hackage` on `irc.freenode.net`. `#ghc` is - also a decently good bet. +* Many developers idle on `#hackage` on `irc.freenode.net` ([archives](http://ircbrowse.net/browse/hackage)). `#ghc` ([archives](http://ircbrowse.net/browse/ghc)) is also a decently good bet. Releases -------- diff --git a/cabal/appveyor-retry.cmd b/cabal/appveyor-retry.cmd new file mode 100644 --- /dev/null +++ b/cabal/appveyor-retry.cmd @@ -0,0 +1,21 @@ +@echo off +rem Source: https://github.com/appveyor/ci/blob/master/scripts/appveyor-retry.cmd +rem initiate the retry number +set retryNumber=0 +set maxRetries=3 + +:RUN +%* +set LastErrorLevel=%ERRORLEVEL% +IF %LastErrorLevel% == 0 GOTO :EOF +set /a retryNumber=%retryNumber%+1 +IF %reTryNumber% == %maxRetries% (GOTO :FAILED) + +:RETRY +set /a retryNumberDisp=%retryNumber%+1 +@echo Command "%*" failed with exit code %LastErrorLevel%. Retrying %retryNumberDisp% of %maxRetries% +GOTO :RUN + +: FAILED +@echo Sorry, we tried running command for %maxRetries% times and all attempts were unsuccessful! +EXIT /B %LastErrorLevel% diff --git a/cabal/appveyor.yml b/cabal/appveyor.yml --- a/cabal/appveyor.yml +++ b/cabal/appveyor.yml @@ -1,12 +1,19 @@ install: # Using '-y' and 'refreshenv' as a workaround to: # https://github.com/haskell/cabal/issues/3687 - - choco install -y ghc --version 8.0.1 > NUL + - choco install -y ghc --version 8.0.2 - refreshenv - - curl -o cabal.zip --silent https://www.haskell.org/cabal/release/cabal-install-1.24.0.0/cabal-install-1.24.0.0-x86_64-unknown-mingw32.zip + # See http://help.appveyor.com/discussions/problems/6312-curl-command-not-found#comment_42195491 + # NB: Do this after refreshenv, otherwise it will be clobbered! + - set PATH=%APPDATA%\cabal\bin;C:\Program Files\Git\mingw64\bin;%PATH% + # TODO: remove --insecure, this is to workaround haskell.org + # failing to send intermediate cert; see https://github.com/haskell/cabal/pull/4172 + - curl -o cabal.zip --insecure --progress-bar https://www.haskell.org/cabal/release/cabal-install-2.0.0.0/cabal-install-2.0.0.0-x86_64-unknown-mingw32.zip - 7z x -bd cabal.zip - cabal --version - cabal update + # Install parsec, text and mtl, also alex and happy + - echo "" | appveyor-retry cabal install parsec-3.1.11 text-1.2.2.2 mtl-2.2.1 alex-3.1.7 happy-1.19.5 build_script: - cd Cabal @@ -14,27 +21,39 @@ # 'echo "" |' works around an AppVeyor issue: # https://github.com/commercialhaskell/stack/issues/1097#issuecomment-145747849 - - echo "" | ..\cabal install --only-dependencies --enable-tests + - echo "" | ..\appveyor-retry ..\cabal install --only-dependencies --enable-tests - Setup configure --user --ghc-option=-Werror --enable-tests - Setup build - Setup test --show-details=streaming --test-option=--hide-successes - Setup install + # hackage-repo-tool doesn't build on Windows: + # https://github.com/well-typed/hackage-security/issues/175 + # - echo "" | ..\cabal install hackage-repo-tool --allow-newer=Cabal,time --constraint="Cabal == 2.1.0.0" - cd ..\cabal-testsuite - - echo "" | ..\cabal install --only-dependencies --enable-tests - - ghc --make -threaded -i -i. Setup.hs -Wall -Werror + - ghc --make -threaded -i Setup.hs -package Cabal-2.1.0.0 + - echo "" | ..\appveyor-retry ..\cabal install --only-dependencies --enable-tests - Setup configure --user --ghc-option=-Werror --enable-tests - Setup build - - Setup test --show-details=streaming --test-option=--hide-successes + # Must install the test suite, so that our GHCi invocation picks it up + - Setup install + # Copy the setup script into the spot cabal-tests expects it + - mkdir dist\setup + - cp Setup.exe dist\setup + - dist\build\cabal-tests\cabal-tests.exe -j3 + # - Setup test --show-details=streaming --test-option=--hide-successes - cd ..\cabal-install - ghc --make -threaded -i -i. Setup.hs -Wall -Werror - - echo "" | ..\cabal install happy - - echo "" | ..\cabal install --only-dependencies --enable-tests - - ..\cabal configure --user --ghc-option=-Werror --enable-tests + - echo "" | ..\appveyor-retry ..\cabal install --only-dependencies --enable-tests -flib + - ..\cabal configure --user --ghc-option=-Werror --enable-tests -flib - ..\cabal build # update package index again, this time for the cabal under test - dist\build\cabal\cabal.exe update + # run cabal-testsuite first as it has better logging + - cd ..\cabal-testsuite + - dist\build\cabal-tests\cabal-tests.exe -j3 --skip-setup-tests --with-cabal=..\cabal-install\dist\build\cabal\cabal.exe + - cd ..\cabal-install - ..\cabal test unit-tests --show-details=streaming --test-option=--pattern=!FileMonitor --test-option=--hide-successes - - ..\cabal test integration-tests --show-details=streaming --test-option=--pattern=!exec --test-option=--hide-successes - ..\cabal test integration-tests2 --show-details=streaming --test-option=--hide-successes - ..\cabal test solver-quickcheck --show-details=streaming --test-option=--hide-successes --test-option=--quickcheck-tests=1000 + - ..\cabal test memory-usage-tests --show-details=streaming diff --git a/cabal/boot/Lexer.x b/cabal/boot/Lexer.x new file mode 100644 --- /dev/null +++ b/cabal/boot/Lexer.x @@ -0,0 +1,281 @@ +{ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Parsec.Lexer +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Lexer for the cabal files. +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +#ifdef CABAL_PARSEC_DEBUG +{-# LANGUAGE PatternGuards #-} +#endif +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Distribution.Parsec.Lexer + (ltest, lexToken, Token(..), LToken(..) + ,bol_section, in_section, in_field_layout, in_field_braces + ,mkLexState) where + +-- [Note: boostrapping parsec parser] +-- +-- We manually produce the `Lexer.hs` file from `boot/Lexer.x` (make lexer) +-- because boostrapping cabal-install would be otherwise tricky. +-- Alex is (atm) tricky package to build, cabal-install has some magic +-- to move bundled generated files in place, so rather we don't depend +-- on it before we can build it ourselves. +-- Therefore there is one thing less to worry in bootstrap.sh, which is a win. +-- +-- See also https://github.com/haskell/cabal/issues/4633 +-- + +import Prelude () +import qualified Prelude as Prelude +import Distribution.Compat.Prelude + +import Distribution.Parsec.LexerMonad +import Distribution.Parsec.Common (Position (..), incPos, retPos) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B.Char8 +import qualified Data.Word as Word + +#ifdef CABAL_PARSEC_DEBUG +import Debug.Trace +import qualified Data.Vector as V +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +#endif + +} +-- Various character classes + +$space = \ -- single space char +$ctlchar = [\x0-\x1f \x7f] +$printable = \x0-\xff # $ctlchar -- so no \n \r +$symbol' = [ \, \= \< \> \+ \* \& \| \! \$ \% \^ \@ \# \? \/ \\ \~ ] +$symbol = [$symbol' \- \.] +$spacetab = [$space \t] + +$paren = [ \( \) \[ \] ] +$field_layout = [$printable \t] +$field_layout' = [$printable] # [$space] +$field_braces = [$printable \t] # [\{ \}] +$field_braces' = [$printable] # [\{ \} $space] +$comment = [$printable \t] +$namecore = [$printable] # [$space \: \" \{ \} $paren $symbol'] +$instr = [$printable $space] # [\"] +$instresc = $printable + +@bom = \xef \xbb \xbf +@nbsp = \xc2 \xa0 +@nbspspacetab = ($spacetab | @nbsp) +@nl = \n | \r\n | \r +@name = $namecore+ +@string = \" ( $instr | \\ $instresc )* \" +@oplike = $symbol+ + + +tokens :- + +<0> { + @bom? { \_ len _ -> do + when (len /= 0) $ addWarning LexWarningBOM "Byte-order mark found at the beginning of the file" + setStartCode bol_section + lexToken + } +} + + { + @nbspspacetab* @nl { \_pos len inp -> checkWhitespace len inp >> adjustPos retPos >> lexToken } + -- no @nl here to allow for comments on last line of the file with no trailing \n + $spacetab* "--" $comment* ; -- TODO: check the lack of @nl works here + -- including counting line numbers +} + + { + @nbspspacetab* --TODO prevent or record leading tabs + { \pos len inp -> checkWhitespace len inp >> + if B.length inp == len + then return (L pos EOF) + else setStartCode in_section + >> return (L pos (Indent len)) } + $spacetab* \{ { tok OpenBrace } + $spacetab* \} { tok CloseBrace } +} + + { + $spacetab+ ; --TODO: don't allow tab as leading space + + "--" $comment* ; + + @name { toki TokSym } + @string { \pos len inp -> return $! L pos (TokStr (B.take (len - 2) (B.tail inp))) } + @oplike { toki TokOther } + $paren { toki TokOther } + \: { tok Colon } + \{ { tok OpenBrace } + \} { tok CloseBrace } + @nl { \_ _ _ -> adjustPos retPos >> setStartCode bol_section >> lexToken } +} + + { + @nbspspacetab* --TODO prevent or record leading tabs + { \pos len inp -> checkWhitespace len inp >>= \len' -> + if B.length inp == len + then return (L pos EOF) + else setStartCode in_field_layout + >> return (L pos (Indent len')) } +} + + { + $spacetab+; --TODO prevent or record leading tabs + $field_layout' $field_layout* { toki TokFieldLine } + @nl { \_ _ _ -> adjustPos retPos >> setStartCode bol_field_layout >> lexToken } +} + + { + () { \_ _ _ -> setStartCode in_field_braces >> lexToken } +} + + { + $spacetab+; --TODO prevent or record leading tabs + $field_braces' $field_braces* { toki TokFieldLine } + \{ { tok OpenBrace } + \} { tok CloseBrace } + @nl { \_ _ _ -> adjustPos retPos >> setStartCode bol_field_braces >> lexToken } +} + +{ + +-- | Tokens of outer cabal file structure. Field values are treated opaquely. +data Token = TokSym !ByteString -- ^ Haskell-like identifier, number or operator + | TokStr !ByteString -- ^ String in quotes + | TokOther !ByteString -- ^ Operators and parens + | Indent !Int -- ^ Indentation token + | TokFieldLine !ByteString -- ^ Lines after @:@ + | Colon + | OpenBrace + | CloseBrace + | EOF + | LexicalError InputStream --TODO: add separate string lexical error + deriving Show + +data LToken = L !Position !Token + deriving Show + +toki :: (ByteString -> Token) -> Position -> Int -> ByteString -> Lex LToken +toki t pos len input = return $! L pos (t (B.take len input)) + +tok :: Token -> Position -> Int -> ByteString -> Lex LToken +tok t pos _len _input = return $! L pos t + +checkWhitespace :: Int -> ByteString -> Lex Int +checkWhitespace len bs + | B.any (== 194) (B.take len bs) = do + addWarning LexWarningNBSP "Non-breaking space found" + return $ len - B.count 194 (B.take len bs) + | otherwise = return len + +-- ----------------------------------------------------------------------------- +-- The input type + +type AlexInput = InputStream + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar _ = error "alexInputPrevChar not used" + +alexGetByte :: AlexInput -> Maybe (Word.Word8,AlexInput) +alexGetByte = B.uncons + +lexicalError :: Position -> InputStream -> Lex LToken +lexicalError pos inp = do + setInput B.empty + return $! L pos (LexicalError inp) + +lexToken :: Lex LToken +lexToken = do + pos <- getPos + inp <- getInput + st <- getStartCode + case alexScan inp st of + AlexEOF -> return (L pos EOF) + AlexError inp' -> + let !len_bytes = B.length inp - B.length inp' in + --FIXME: we want len_chars here really + -- need to decode utf8 up to this point + lexicalError (incPos len_bytes pos) inp' + AlexSkip inp' len_chars -> do + checkPosition pos inp inp' len_chars + adjustPos (incPos len_chars) + setInput inp' + lexToken + AlexToken inp' len_chars action -> do + checkPosition pos inp inp' len_chars + adjustPos (incPos len_chars) + setInput inp' + let !len_bytes = B.length inp - B.length inp' + t <- action pos len_bytes inp + --traceShow t $ return tok + return t + + +checkPosition :: Position -> ByteString -> ByteString -> Int -> Lex () +#ifdef CABAL_PARSEC_DEBUG +checkPosition pos@(Position lineno colno) inp inp' len_chars = do + text_lines <- getDbgText + let len_bytes = B.length inp - B.length inp' + pos_txt | lineno-1 < V.length text_lines = T.take len_chars (T.drop (colno-1) (text_lines V.! (lineno-1))) + | otherwise = T.empty + real_txt = B.take len_bytes inp + when (pos_txt /= T.decodeUtf8 real_txt) $ + traceShow (pos, pos_txt, T.decodeUtf8 real_txt) $ + traceShow (take 3 (V.toList text_lines)) $ return () + where + getDbgText = Lex $ \s@LexState{ dbgText = txt } -> LexResult s txt +#else +checkPosition _ _ _ _ = return () +#endif + +lexAll :: Lex [LToken] +lexAll = do + t <- lexToken + case t of + L _ EOF -> return [t] + _ -> do ts <- lexAll + return (t : ts) + +ltest :: Int -> String -> Prelude.IO () +ltest code s = + let (ws, xs) = execLexer (setStartCode code >> lexAll) (B.Char8.pack s) + in traverse_ print ws >> traverse_ print xs + + +mkLexState :: ByteString -> LexState +mkLexState input = LexState + { curPos = Position 1 1 + , curInput = input + , curCode = 0 + , warnings = [] +#ifdef CABAL_PARSEC_DEBUG + , dbgText = V.fromList . lines' . T.decodeUtf8With T.lenientDecode $ input +#endif + } + +#ifdef CABAL_PARSEC_DEBUG +lines' :: T.Text -> [T.Text] +lines' s1 + | T.null s1 = [] + | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of + (l, s2) | Just (c,s3) <- T.uncons s2 + -> case T.uncons s3 of + Just ('\n', s4) | c == '\r' -> l `T.snoc` '\r' `T.snoc` '\n' : lines' s4 + _ -> l `T.snoc` c : lines' s3 + + | otherwise + -> [l] +#endif +} diff --git a/cabal/cabal-dev-scripts/LICENSE b/cabal/cabal-dev-scripts/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/cabal-dev-scripts/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Cabal Development Team + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Cabal Development Team nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cabal/cabal-dev-scripts/Setup.hs b/cabal/cabal-dev-scripts/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-dev-scripts/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-dev-scripts/cabal-dev-scripts.cabal b/cabal/cabal-dev-scripts/cabal-dev-scripts.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-dev-scripts/cabal-dev-scripts.cabal @@ -0,0 +1,23 @@ +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 + +executable gen-extra-source-files + default-language: Haskell2010 + main-is: GenExtraSourceFiles.hs + hs-source-dirs: src + build-depends: + base >=4.10 && <4.11, + Cabal >=2.0 && <2.2, + directory, + filepath, + process diff --git a/cabal/cabal-dev-scripts/src/GenExtraSourceFiles.hs b/cabal/cabal-dev-scripts/src/GenExtraSourceFiles.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-dev-scripts/src/GenExtraSourceFiles.hs @@ -0,0 +1,107 @@ +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription +import Distribution.PackageDescription.Parse + (ParseResult (..), parseGenericPackageDescription) +import Distribution.Verbosity (silent) + +import Data.List (isPrefixOf, isSuffixOf, sort) +import System.Directory (canonicalizePath, setCurrentDirectory) +import System.Environment (getArgs, getProgName) +import System.FilePath (takeDirectory, takeExtension, takeFileName) +import System.Process (readProcess) + +import qualified System.IO as IO + +main' :: FilePath -> IO () +main' fp' = do + fp <- canonicalizePath fp' + setCurrentDirectory (takeDirectory fp) + + -- Read cabal file, so we can determine test modules + contents <- strictReadFile fp + cabal <- case parseGenericPackageDescription contents of + ParseOk _ x -> pure x + ParseFailed errs -> fail (show errs) + + -- We skip some files + let testModuleFiles = getOtherModulesFiles cabal + let skipPredicates' = skipPredicates ++ map (==) testModuleFiles + + -- Read all files git knows about under "tests" + files0 <- lines <$> readProcess "git" ["ls-files", "tests"] "" + + -- Filter + let files1 = filter (\f -> takeExtension f `elem` whitelistedExtensionss || + takeFileName f `elem` whitelistedFiles) + files0 + let files2 = filter (\f -> not $ any ($ dropTestsDir f) skipPredicates') files1 + let files3 = sort files2 + let files = files3 + + -- Read current file + let inputLines = lines contents + linesBefore = takeWhile (/= topLine) inputLines + linesAfter = dropWhile (/= bottomLine) inputLines + + -- Output + let outputLines = linesBefore ++ [topLine] ++ map (" " ++) files ++ linesAfter + writeFile fp (unlines outputLines) + + +topLine, bottomLine :: String +topLine = " -- BEGIN gen-extra-source-files" +bottomLine = " -- END gen-extra-source-files" + +dropTestsDir :: FilePath -> FilePath +dropTestsDir fp + | pfx `isPrefixOf` fp = drop (length pfx) fp + | otherwise = fp + where + pfx = "tests/" + +whitelistedFiles :: [FilePath] +whitelistedFiles = [ "ghc", "ghc-pkg", "ghc-7.10", "ghc-pkg-7.10", "ghc-pkg-ghc-7.10" ] + +whitelistedExtensionss :: [String] +whitelistedExtensionss = map ('.' : ) + [ "hs", "lhs", "c", "h", "sh", "cabal", "hsc", "err", "out", "in", "project" ] + +getOtherModulesFiles :: GenericPackageDescription -> [FilePath] +getOtherModulesFiles gpd = mainModules ++ map fromModuleName otherModules' + where + testSuites :: [TestSuite] + testSuites = map (foldMap id . snd) (condTestSuites gpd) + + mainModules = concatMap (mainModule . testInterface) testSuites + otherModules' = concatMap (otherModules . testBuildInfo) testSuites + + fromModuleName mn = ModuleName.toFilePath mn ++ ".hs" + + mainModule (TestSuiteLibV09 _ mn) = [fromModuleName mn] + mainModule (TestSuiteExeV10 _ fp) = [fp] + mainModule _ = [] + +skipPredicates :: [FilePath -> Bool] +skipPredicates = + [ isSuffixOf "register.sh" + ] + +main :: IO () +main = do + args <- getArgs + case args of + [fp] -> main' fp + _ -> do + progName <- getProgName + putStrLn "Error too few arguments!" + putStrLn $ "Usage: " ++ progName ++ " FILE" + putStrLn " where FILE is Cabal.cabal, cabal-testsuite.cabal or cabal-install.cabal" + +strictReadFile :: FilePath -> IO String +strictReadFile fp = do + handle <- IO.openFile fp IO.ReadMode + contents <- get handle + IO.hClose handle + return contents + where + get h = IO.hGetContents h >>= \s -> length s `seq` return s diff --git a/cabal/cabal-install/.ghci b/cabal/cabal-install/.ghci deleted file mode 100644 --- a/cabal/cabal-install/.ghci +++ /dev/null @@ -1,1 +0,0 @@ -:set -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs --- a/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs +++ b/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs @@ -26,6 +26,9 @@ -- showList, ) where +import Prelude () +import Distribution.Client.Compat.Prelude hiding (show) + import qualified Distribution.Client.Types as BR ( BuildOutcome, BuildFailure(..), BuildResult(..) , DocsResult(..), TestsResult(..) ) @@ -36,7 +39,8 @@ import Distribution.Package ( PackageIdentifier(..), mkPackageName ) import Distribution.PackageDescription - ( FlagName, mkFlagName, unFlagName, FlagAssignment ) + ( FlagName, mkFlagName, unFlagName + , FlagAssignment, mkFlagAssignment, unFlagAssignment ) import Distribution.Version ( mkVersion' ) import Distribution.System @@ -57,15 +61,11 @@ import qualified Text.PrettyPrint as Disp ( Doc, render, char, text ) import Text.PrettyPrint - ( (<+>), (<>) ) + ( (<+>) ) -import Data.List - ( unfoldr, sortBy ) import Data.Char as Char ( isAlpha, isAlphaNum ) -import Prelude hiding (show) - data BuildReport = BuildReport { -- | The package this build report is about @@ -173,7 +173,7 @@ arch = requiredField "arch", compiler = requiredField "compiler", client = requiredField "client", - flagAssignment = [], + flagAssignment = mempty, dependencies = [], installOutcome = requiredField "install-outcome", -- cabalVersion = Nothing, @@ -194,7 +194,7 @@ parseFields :: String -> ParseResult BuildReport parseFields input = do - fields <- mapM extractField =<< readFields input + fields <- traverse extractField =<< readFields input let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name) sortedFieldDescrs (sortBy (comparing (\(_,name,_) -> name)) fields) @@ -249,7 +249,8 @@ , simpleField "client" Text.disp Text.parse client (\v r -> r { client = v }) , listField "flags" dispFlag parseFlag - flagAssignment (\v r -> r { flagAssignment = v }) + (unFlagAssignment . flagAssignment) + (\v r -> r { flagAssignment = mkFlagAssignment v }) , listField "dependencies" Text.disp Text.parse dependencies (\v r -> r { dependencies = v }) , simpleField "install-outcome" Text.disp Text.parse @@ -265,7 +266,7 @@ dispFlag :: (FlagName, Bool) -> Disp.Doc dispFlag (fname, True) = Disp.text (unFlagName fname) -dispFlag (fname, False) = Disp.char '-' <> Disp.text (unFlagName fname) +dispFlag (fname, False) = Disp.char '-' <<>> Disp.text (unFlagName fname) parseFlag :: Parse.ReadP r (FlagName, Bool) parseFlag = do diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs --- a/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs +++ b/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs @@ -51,7 +51,7 @@ import Data.List ( groupBy, sortBy ) import Data.Maybe - ( catMaybes ) + ( mapMaybe ) import System.FilePath ( (), takeDirectory ) import System.Directory @@ -126,10 +126,9 @@ -> BuildOutcomes -> [(BuildReport, Maybe Repo)] fromInstallPlan platform comp plan buildOutcomes = - catMaybes - . map (\pkg -> fromPlanPackage - platform comp pkg - (InstallPlan.lookupBuildOutcome pkg buildOutcomes)) + mapMaybe (\pkg -> fromPlanPackage + platform comp pkg + (InstallPlan.lookupBuildOutcome pkg buildOutcomes)) . InstallPlan.toList $ plan diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs --- a/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs +++ b/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs @@ -25,7 +25,7 @@ import Distribution.Client.BuildReports.Anonymous (BuildReport) import Distribution.Text (display) import Distribution.Verbosity (Verbosity) -import Distribution.Simple.Utils (die) +import Distribution.Simple.Utils (die') import Distribution.Client.HttpUtils import Distribution.Client.Setup ( RepoContext(..) ) @@ -48,7 +48,7 @@ res <- postHttp transport verbosity fullURI (BuildReport.show buildReport) (Just auth) case res of (303, redir) -> return $ undefined redir --TODO parse redir - _ -> die "unrecognized response" -- give response + _ -> die' verbosity "unrecognized response" -- give response {- setAllowRedirects False @@ -89,4 +89,4 @@ res <- postHttp transport verbosity fullURI buildLog (Just auth) case res of (200, _) -> return () - _ -> die "unrecognized response" -- give response + _ -> die' verbosity "unrecognized response" -- give response diff --git a/cabal/cabal-install/Distribution/Client/BuildTarget.hs b/cabal/cabal-install/Distribution/Client/BuildTarget.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/BuildTarget.hs +++ /dev/null @@ -1,1670 +0,0 @@ -{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.BuildTargets --- Copyright : (c) Duncan Coutts 2012, 2015 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- --- Handling for user-specified build targets --- Unlike "Distribution.Simple.BuildTarget" these build --- targets also handle package qualification (so, up to --- four levels of qualification, as opposed to the former's --- three.) ------------------------------------------------------------------------------ -module Distribution.Client.BuildTarget ( - - -- * Build targets - BuildTarget(..), - -- Don't export me: it's partial (if you try to qualify too - -- much you will error.) - --showBuildTarget, - QualLevel(..), - buildTargetPackage, - buildTargetComponentName, - - -- * Top level convenience - readUserBuildTargets, - resolveUserBuildTargets, - - -- * Parsing user build targets - UserBuildTarget, - parseUserBuildTargets, - showUserBuildTarget, - UserBuildTargetProblem(..), - reportUserBuildTargetProblems, - - -- * Resolving build targets - resolveBuildTargets, - BuildTargetProblem(..), - reportBuildTargetProblems, - ) where - -import Distribution.Package - ( Package(..), PackageId, PackageName, packageName - , unUnqualComponentName ) -import Distribution.Client.Types - ( PackageLocation(..) ) - -import Distribution.PackageDescription - ( PackageDescription - , Executable(..) - , TestSuite(..), TestSuiteInterface(..), testModules - , Benchmark(..), BenchmarkInterface(..), benchmarkModules - , BuildInfo(..), explicitLibModules, exeModules ) -import Distribution.ModuleName - ( ModuleName, toFilePath ) -import Distribution.Simple.LocalBuildInfo - ( Component(..), ComponentName(..) - , pkgComponents, componentName, componentBuildInfo ) -import Distribution.Types.ForeignLib - -import Distribution.Text - ( display, simpleParse ) -import Distribution.Simple.Utils - ( die, lowercase ) -import Distribution.Client.Utils - ( makeRelativeToCwd ) - -import Data.Either - ( partitionEithers ) -import Data.Function - ( on ) -import Data.List - ( nubBy, stripPrefix, partition, intercalate, sortBy, groupBy ) -import Data.Maybe - ( listToMaybe, maybeToList ) -import Data.Ord - ( comparing ) -import GHC.Generics (Generic) -#if MIN_VERSION_containers(0,5,0) -import qualified Data.Map.Lazy as Map.Lazy -import qualified Data.Map.Strict as Map -import Data.Map.Strict (Map) -#else -import qualified Data.Map as Map.Lazy -import qualified Data.Map as Map -import Data.Map (Map) -#endif -import qualified Data.Set as Set -import Control.Arrow ((&&&)) -import Control.Monad -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative(..), (<$>)) -#endif -import Control.Applicative (Alternative(..)) -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP - ( (+++), (<++) ) -import Data.Char - ( isSpace, isAlphaNum ) -import System.FilePath as FilePath - ( takeExtension, dropExtension, addTrailingPathSeparator - , splitDirectories, joinPath, splitPath ) -import System.Directory - ( doesFileExist, doesDirectoryExist, canonicalizePath - , getCurrentDirectory ) -import System.FilePath - ( (), (<.>), normalise ) -import Text.EditDistance - ( defaultEditCosts, restrictedDamerauLevenshteinDistance ) - --- ------------------------------------------------------------ --- * User build targets --- ------------------------------------------------------------ - --- | Various ways that a user may specify a build target. --- --- The main general form has lots of optional parts: --- --- > [ package name | package dir | package .cabal file ] --- > [ [lib:|exe:] component name ] --- > [ module name | source file ] --- --- There's also a special case of a package tarball. It doesn't take part in --- the main general form since we always build a tarball package as a whole. --- --- > [package tar.gz file] --- -data UserBuildTarget = - - -- | A simple target specified by a single part. This is any of the - -- general forms that can be expressed using one part, which are: - -- - -- > cabal build foo -- package name - -- > cabal build ../bar ../bar/bar.cabal -- package dir or package file - -- > cabal build foo -- component name - -- > cabal build Data.Foo -- module name - -- > cabal build Data/Foo.hs bar/Main.hsc -- file name - -- - -- It can also be a package tarball. - -- - -- > cabal build bar.tar.gz - -- - UserBuildTarget1 String - - -- | A qualified target with two parts. This is any of the general - -- forms that can be expressed using two parts, which are: - -- - -- > cabal build foo:foo -- package : component - -- > cabal build foo:Data.Foo -- package : module - -- > cabal build foo:Data/Foo.hs -- package : filename - -- - -- > cabal build ./foo:foo -- package dir : component - -- > cabal build ./foo:Data.Foo -- package dir : module - -- - -- > cabal build ./foo.cabal:foo -- package file : component - -- > cabal build ./foo.cabal:Data.Foo -- package file : module - -- > cabal build ./foo.cabal:Main.hs -- package file : filename - -- - -- > cabal build lib:foo exe:foo -- namespace : component - -- > cabal build foo:Data.Foo -- component : module - -- > cabal build foo:Data/Foo.hs -- component : filename - -- - | UserBuildTarget2 String String - - -- A (very) qualified target with three parts. This is any of the general - -- forms that can be expressed using three parts, which are: - -- - -- > cabal build foo:lib:foo -- package : namespace : component - -- > cabal build foo:foo:Data.Foo -- package : component : module - -- > cabal build foo:foo:Data/Foo.hs -- package : component : filename - -- - -- > cabal build foo/:lib:foo -- pkg dir : namespace : component - -- > cabal build foo/:foo:Data.Foo -- pkg dir : component : module - -- > cabal build foo/:foo:Data/Foo.hs -- pkg dir : component : filename - -- - -- > cabal build foo.cabal:lib:foo -- pkg file : namespace : component - -- > cabal build foo.cabal:foo:Data.Foo -- pkg file : component : module - -- > cabal build foo.cabal:foo:Data/Foo.hs -- pkg file : component : filename - -- - -- > cabal build lib:foo:Data.Foo -- namespace : component : module - -- > cabal build lib:foo:Data/Foo.hs -- namespace : component : filename - -- - | UserBuildTarget3 String String String - - -- A (rediculously) qualified target with four parts. This is any of the - -- general forms that can be expressed using all four parts, which are: - -- - -- > cabal build foo:lib:foo:Data.Foo -- package : namespace : component : module - -- > cabal build foo:lib:foo:Data/Foo.hs -- package : namespace : component : filename - -- - -- > cabal build foo/:lib:foo:Data.Foo -- pkg dir : namespace : component : module - -- > cabal build foo/:lib:foo:Data/Foo.hs -- pkg dir : namespace : component : filename - -- - -- > cabal build foo.cabal:lib:foo:Data.Foo -- pkg file : namespace : component : module - -- > cabal build foo.cabal:lib:foo:Data/Foo.hs -- pkg file : namespace : component : filename - -- - | UserBuildTarget4 String String String String - deriving (Show, Eq, Ord) - - --- ------------------------------------------------------------ --- * Resolved build targets --- ------------------------------------------------------------ - --- | A fully resolved build target. --- -data BuildTarget pkg = - - -- | A package as a whole - -- - BuildTargetPackage pkg - - -- | A specific component - -- - | BuildTargetComponent pkg ComponentName - - -- | A specific module within a specific component. - -- - | BuildTargetModule pkg ComponentName ModuleName - - -- | A specific file within a specific component. - -- - | BuildTargetFile pkg ComponentName FilePath - deriving (Eq, Ord, Functor, Show, Generic) - - --- | Get the package that the 'BuildTarget' is referring to. --- -buildTargetPackage :: BuildTarget pkg -> pkg -buildTargetPackage (BuildTargetPackage p) = p -buildTargetPackage (BuildTargetComponent p _cn) = p -buildTargetPackage (BuildTargetModule p _cn _mn) = p -buildTargetPackage (BuildTargetFile p _cn _fn) = p - - --- | Get the 'ComponentName' that the 'BuildTarget' is referring to, if any. --- The 'BuildTargetPackage' target kind doesn't refer to any individual --- component, while the component, module and file kinds do. --- -buildTargetComponentName :: BuildTarget pkg -> Maybe ComponentName -buildTargetComponentName (BuildTargetPackage _p) = Nothing -buildTargetComponentName (BuildTargetComponent _p cn) = Just cn -buildTargetComponentName (BuildTargetModule _p cn _mn) = Just cn -buildTargetComponentName (BuildTargetFile _p cn _fn) = Just cn - - --- ------------------------------------------------------------ --- * Top level, do everything --- ------------------------------------------------------------ - - --- | Parse a bunch of command line args as user build targets, failing with an --- error if any targets are unrecognised. --- -readUserBuildTargets :: [String] -> IO [UserBuildTarget] -readUserBuildTargets targetStrs = do - let (uproblems, utargets) = parseUserBuildTargets targetStrs - reportUserBuildTargetProblems uproblems - return utargets - - --- | A 'UserBuildTarget's is just a semi-structured string. We sill have quite --- a bit of work to do to figure out which targets they refer to (ie packages, --- components, file locations etc). --- --- The possible targets are based on the available packages (and their --- locations). It fails with an error if any user string cannot be matched to --- a valid target. --- -resolveUserBuildTargets :: [(PackageDescription, PackageLocation a)] - -> [UserBuildTarget] -> IO [BuildTarget PackageName] -resolveUserBuildTargets pkgs utargets = do - utargets' <- mapM getUserTargetFileStatus utargets - pkgs' <- mapM (uncurry selectPackageInfo) pkgs - pwd <- getCurrentDirectory - let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' - (bproblems, btargets) = resolveBuildTargets - primaryPkg otherPkgs utargets'' - utargets'' - -- default local dir target if there's no given target - | not (null primaryPkg) - , null utargets = [UserBuildTargetFileStatus1 "./" - (FileStatusExistsDir pwd)] - | otherwise = utargets' - -- if there's nothing to build, build everything - btargets' | null utargets - , null primaryPkg - = [ BuildTargetPackage pkg - | pkg <- otherPkgs ] - | otherwise - = btargets - - reportBuildTargetProblems bproblems - return (map (fmap packageName) btargets') - where - selectPrimaryLocalPackage :: FilePath - -> [PackageInfo] - -> ([PackageInfo], [PackageInfo]) - selectPrimaryLocalPackage pwd pkgs' = - let (primary, others) = partition isPrimary pkgs' - in (primary, others) - where - isPrimary PackageInfo { pinfoDirectory = Just (dir,_) } - | dir == pwd = True - isPrimary _ = False - - --- ------------------------------------------------------------ --- * Checking if targets exist as files --- ------------------------------------------------------------ - -data UserBuildTargetFileStatus = - UserBuildTargetFileStatus1 String FileStatus - | UserBuildTargetFileStatus2 String FileStatus String - | UserBuildTargetFileStatus3 String FileStatus String String - | UserBuildTargetFileStatus4 String FileStatus String String String - deriving (Eq, Ord, Show) - -data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath - | FileStatusExistsDir FilePath -- the canonicalised filepath - | FileStatusNotExists Bool -- does the parent dir exist even? - deriving (Eq, Ord, Show) - -getUserTargetFileStatus :: UserBuildTarget -> IO UserBuildTargetFileStatus -getUserTargetFileStatus t = - case t of - UserBuildTarget1 s1 -> - (\f1 -> UserBuildTargetFileStatus1 s1 f1) <$> fileStatus s1 - UserBuildTarget2 s1 s2 -> - (\f1 -> UserBuildTargetFileStatus2 s1 f1 s2) <$> fileStatus s1 - UserBuildTarget3 s1 s2 s3 -> - (\f1 -> UserBuildTargetFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 - UserBuildTarget4 s1 s2 s3 s4 -> - (\f1 -> UserBuildTargetFileStatus4 s1 f1 s2 s3 s4) <$> fileStatus s1 - where - fileStatus f = do - fexists <- doesFileExist f - dexists <- doesDirectoryExist f - case splitPath f of - _ | fexists -> FileStatusExistsFile <$> canonicalizePath f - | dexists -> FileStatusExistsDir <$> canonicalizePath f - (d:_) -> FileStatusNotExists <$> doesDirectoryExist d - _ -> error "getUserTargetFileStatus: empty path" - -forgetFileStatus :: UserBuildTargetFileStatus -> UserBuildTarget -forgetFileStatus t = case t of - UserBuildTargetFileStatus1 s1 _ -> UserBuildTarget1 s1 - UserBuildTargetFileStatus2 s1 _ s2 -> UserBuildTarget2 s1 s2 - UserBuildTargetFileStatus3 s1 _ s2 s3 -> UserBuildTarget3 s1 s2 s3 - UserBuildTargetFileStatus4 s1 _ s2 s3 s4 -> UserBuildTarget4 s1 s2 s3 s4 - - --- ------------------------------------------------------------ --- * Parsing user targets --- ------------------------------------------------------------ - - --- | Parse a bunch of 'UserBuildTarget's (purely without throwing exceptions). --- -parseUserBuildTargets :: [String] -> ([UserBuildTargetProblem] - ,[UserBuildTarget]) -parseUserBuildTargets = partitionEithers . map parseUserBuildTarget - -parseUserBuildTarget :: String -> Either UserBuildTargetProblem - UserBuildTarget -parseUserBuildTarget targetstr = - case readPToMaybe parseTargetApprox targetstr of - Nothing -> Left (UserBuildTargetUnrecognised targetstr) - Just tgt -> Right tgt - - where - parseTargetApprox :: Parse.ReadP r UserBuildTarget - parseTargetApprox = - (do a <- tokenQ - return (UserBuildTarget1 a)) - +++ (do a <- tokenQ - _ <- Parse.char ':' - b <- tokenQ - return (UserBuildTarget2 a b)) - +++ (do a <- tokenQ - _ <- Parse.char ':' - b <- tokenQ - _ <- Parse.char ':' - c <- tokenQ - return (UserBuildTarget3 a b c)) - +++ (do a <- tokenQ - _ <- Parse.char ':' - b <- token - _ <- Parse.char ':' - c <- tokenQ - _ <- Parse.char ':' - d <- tokenQ - return (UserBuildTarget4 a b c d)) - - token = Parse.munch1 (\x -> not (isSpace x) && x /= ':') - tokenQ = parseHaskellString <++ token - parseHaskellString :: Parse.ReadP r String - parseHaskellString = Parse.readS_to_P reads - - readPToMaybe :: Parse.ReadP a a -> String -> Maybe a - readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str - , all isSpace s ] - --- | Syntax error when trying to parse a 'UserBuildTarget'. -data UserBuildTargetProblem - = UserBuildTargetUnrecognised String - deriving Show - --- | Throw an exception with a formatted message if there are any problems. --- -reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO () -reportUserBuildTargetProblems problems = do - case [ target | UserBuildTargetUnrecognised target <- problems ] of - [] -> return () - target -> - die $ unlines - [ "Unrecognised build target syntax for '" ++ name ++ "'." - | name <- target ] - ++ "Syntax:\n" - ++ " - build [package]\n" - ++ " - build [package:]component\n" - ++ " - build [package:][component:]module\n" - ++ " - build [package:][component:]file\n" - ++ " where\n" - ++ " package is a package name, package dir or .cabal file\n\n" - ++ "Examples:\n" - ++ " - build foo -- package name\n" - ++ " - build tests -- component name\n" - ++ " (name of library, executable, test-suite or benchmark)\n" - ++ " - build Data.Foo -- module name\n" - ++ " - build Data/Foo.hsc -- file name\n\n" - ++ "An ambigious target can be qualified by package, component\n" - ++ "and/or component kind (lib|exe|test|bench)\n" - ++ " - build foo:tests -- component qualified by package\n" - ++ " - build tests:Data.Foo -- module qualified by component\n" - ++ " - build lib:foo -- component qualified by kind" - - --- | Render a 'UserBuildTarget' back as the external syntax. This is mainly for --- error messages. --- -showUserBuildTarget :: UserBuildTarget -> String -showUserBuildTarget = intercalate ":" . components - where - components (UserBuildTarget1 s1) = [s1] - components (UserBuildTarget2 s1 s2) = [s1,s2] - components (UserBuildTarget3 s1 s2 s3) = [s1,s2,s3] - components (UserBuildTarget4 s1 s2 s3 s4) = [s1,s2,s3,s4] - -showBuildTarget :: QualLevel -> BuildTarget PackageInfo -> String -showBuildTarget ql = showUserBuildTarget . forgetFileStatus - . hd . renderBuildTarget ql - where hd [] = error "showBuildTarget: head" - hd (x:_) = x - - --- ------------------------------------------------------------ --- * Resolving user targets to build targets --- ------------------------------------------------------------ - - --- | Given a bunch of user-specified targets, try to resolve what it is they --- refer to. --- -resolveBuildTargets :: [PackageInfo] -- any primary pkg, e.g. cur dir - -> [PackageInfo] -- all the other local packages - -> [UserBuildTargetFileStatus] - -> ([BuildTargetProblem], [BuildTarget PackageInfo]) -resolveBuildTargets ppinfo opinfo = - partitionEithers - . map (resolveBuildTarget ppinfo opinfo) - -resolveBuildTarget :: [PackageInfo] -> [PackageInfo] - -> UserBuildTargetFileStatus - -> Either BuildTargetProblem (BuildTarget PackageInfo) -resolveBuildTarget ppinfo opinfo userTarget = - case findMatch (matcher userTarget) of - Unambiguous target -> Right target - None errs -> Left (classifyMatchErrors errs) - Ambiguous exactMatch targets -> - case disambiguateBuildTargets - matcher userTarget exactMatch - targets of - Right targets' -> Left (BuildTargetAmbiguous userTarget' targets') - Left ((m, ms):_) -> Left (MatchingInternalError userTarget' m ms) - Left [] -> internalError "resolveBuildTarget" - where - matcher = matchBuildTarget ppinfo opinfo - - userTarget' = forgetFileStatus userTarget - - classifyMatchErrors errs - | not (null expected) - = let (things, got:_) = unzip expected in - BuildTargetExpected userTarget' things got - - | not (null nosuch) - = BuildTargetNoSuch userTarget' nosuch - - | otherwise - = internalError $ "classifyMatchErrors: " ++ show errs - where - expected = [ (thing, got) - | (_, MatchErrorExpected thing got) - <- map (innerErr Nothing) errs ] - -- Trim the list of alternatives by dropping duplicates and - -- retaining only at most three most similar (by edit distance) ones. - nosuch = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $ - [ ((inside, thing, got), Set.fromList alts) - | (inside, MatchErrorNoSuch thing got alts) - <- map (innerErr Nothing) errs - ] - - genResults (inside, thing, got) alts acc = ( - inside - , thing - , got - , take maxResults - $ map fst - $ takeWhile distanceLow - $ sortBy (comparing snd) - $ map addLevDist - $ Set.toList alts - ) : acc - where - addLevDist = id &&& restrictedDamerauLevenshteinDistance - defaultEditCosts got - - distanceLow (_, dist) = dist < length got `div` 2 - - maxResults = 3 - - innerErr _ (MatchErrorIn kind thing m) - = innerErr (Just (kind,thing)) m - innerErr c m = (c,m) - --- | The various ways that trying to resolve a 'UserBuildTarget' to a --- 'BuildTarget' can fail. --- -data BuildTargetProblem - = BuildTargetExpected UserBuildTarget [String] String - -- ^ [expected thing] (actually got) - | BuildTargetNoSuch UserBuildTarget - [(Maybe (String, String), String, String, [String])] - -- ^ [([in thing], no such thing, actually got, alternatives)] - | BuildTargetAmbiguous UserBuildTarget - [(UserBuildTarget, BuildTarget PackageInfo)] - - | MatchingInternalError UserBuildTarget (BuildTarget PackageInfo) - [(UserBuildTarget, [BuildTarget PackageInfo])] - - -disambiguateBuildTargets - :: (UserBuildTargetFileStatus -> Match (BuildTarget PackageInfo)) - -> UserBuildTargetFileStatus -> Bool - -> [BuildTarget PackageInfo] - -> Either [(BuildTarget PackageInfo, - [(UserBuildTarget, [BuildTarget PackageInfo])])] - [(UserBuildTarget, BuildTarget PackageInfo)] -disambiguateBuildTargets matcher matchInput exactMatch matchResults = - case partitionEithers results of - (errs@(_:_), _) -> Left errs - ([], ok) -> Right ok - where - -- So, here's the strategy. We take the original match results, and make a - -- table of all their renderings at all qualification levels. - -- Note there can be multiple renderings at each qualification level. - matchResultsRenderings :: [(BuildTarget PackageInfo, - [UserBuildTargetFileStatus])] - matchResultsRenderings = - [ (matchResult, matchRenderings) - | matchResult <- matchResults - , let matchRenderings = - [ rendering - | ql <- [QL1 .. QL4] - , rendering <- renderBuildTarget ql matchResult ] - ] - - -- Of course the point is that we're looking for renderings that are - -- unambiguous matches. So we build another memo table of all the matches - -- for all of those renderings. So by looking up in this table we can see - -- if we've got an unambiguous match. - - memoisedMatches :: Map UserBuildTargetFileStatus - (Match (BuildTarget PackageInfo)) - memoisedMatches = - -- avoid recomputing the main one if it was an exact match - (if exactMatch then Map.insert matchInput (ExactMatch 0 matchResults) - else id) - $ Map.Lazy.fromList - [ (rendering, matcher rendering) - | rendering <- concatMap snd matchResultsRenderings ] - - -- Finally, for each of the match results, we go through all their - -- possible renderings (in order of qualification level, though remember - -- there can be multiple renderings per level), and find the first one - -- that has an unambiguous match. - results :: [Either (BuildTarget PackageInfo, - [(UserBuildTarget, [BuildTarget PackageInfo])]) - (UserBuildTarget, BuildTarget PackageInfo)] - results = - [ case findUnambiguous originalMatch matchRenderings of - Just unambiguousRendering -> - Right ( forgetFileStatus unambiguousRendering - , originalMatch) - - -- This case is an internal error, but we bubble it up and report it - Nothing -> - Left ( originalMatch - , [ (forgetFileStatus rendering, matches) - | rendering <- matchRenderings - , let (ExactMatch _ matches) = - memoisedMatches Map.! rendering - ] ) - - | (originalMatch, matchRenderings) <- matchResultsRenderings ] - - findUnambiguous :: BuildTarget PackageInfo -> [UserBuildTargetFileStatus] - -> Maybe UserBuildTargetFileStatus - findUnambiguous _ [] = Nothing - findUnambiguous t (r:rs) = - case memoisedMatches Map.! r of - ExactMatch _ [t'] | fmap packageName t == fmap packageName t' - -> Just r - ExactMatch _ _ -> findUnambiguous t rs - InexactMatch _ _ -> internalError "InexactMatch" - NoMatch _ _ -> internalError "NoMatch" - -internalError :: String -> a -internalError msg = - error $ "BuildTargets: internal error: " ++ msg - - -data QualLevel = QL1 | QL2 | QL3 | QL4 - deriving (Enum, Show) - -renderBuildTarget :: QualLevel -> BuildTarget PackageInfo - -> [UserBuildTargetFileStatus] -renderBuildTarget ql t = - case t of - BuildTargetPackage p -> - case ql of - QL1 -> [t1 (dispP p)] - QL2 -> [t1' pf fs | (pf, fs) <- dispPF p] - QL3 -> [] - QL4 -> [] - - BuildTargetComponent p c -> - case ql of - QL1 -> [t1 (dispC p c)] - QL2 -> [t2 (dispP p) (dispC p c), - t2 (dispK c) (dispC p c)] - QL3 -> [t3 (dispP p) (dispK c) (dispC p c)] - QL4 -> [] - - BuildTargetModule p c m -> - case ql of - QL1 -> [t1 (dispM m)] - QL2 -> [t2 (dispP p) (dispM m), - t2 (dispC p c) (dispM m)] - QL3 -> [t3 (dispP p) (dispC p c) (dispM m), - t3 (dispK c) (dispC p c) (dispM m)] - QL4 -> [t4 (dispP p) (dispK c) (dispC p c) (dispM m)] - - BuildTargetFile p c f -> - case ql of - QL1 -> [t1 f] - QL2 -> [t2 (dispP p) f, - t2 (dispC p c) f] - QL3 -> [t3 (dispP p) (dispC p c) f, - t3 (dispK c) (dispC p c) f] - QL4 -> [t4 (dispP p) (dispK c) (dispC p c) f] - where - t1 s1 = UserBuildTargetFileStatus1 s1 none - t1' s1 = UserBuildTargetFileStatus1 s1 - t2 s1 = UserBuildTargetFileStatus2 s1 none - t3 s1 = UserBuildTargetFileStatus3 s1 none - t4 s1 = UserBuildTargetFileStatus4 s1 none - none = FileStatusNotExists False - - dispP = display . packageName - dispC = componentStringName - dispK = showComponentKindShort . componentKind - dispM = display - - dispPF p = [ (addTrailingPathSeparator drel, FileStatusExistsDir dabs) - | PackageInfo { pinfoDirectory = Just (dabs,drel) } <- [p] ] - ++ [ (frel, FileStatusExistsFile fabs) - | PackageInfo { pinfoPackageFile = Just (fabs,frel) } <- [p] ] - - --- | Throw an exception with a formatted message if there are any problems. --- -reportBuildTargetProblems :: [BuildTargetProblem] -> IO () -reportBuildTargetProblems problems = do - - case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of - [] -> return () - ((target, originalMatch, renderingsAndMatches):_) -> - die $ "Internal error in build target matching. It should always be " - ++ "possible to find a syntax that's sufficiently qualified to " - ++ "give an unambigious match. However when matching '" - ++ showUserBuildTarget target ++ "' we found " - ++ showBuildTarget QL1 originalMatch - ++ " (" ++ showBuildTargetKind originalMatch ++ ") which does not " - ++ "have an unambigious syntax. The possible syntax and the " - ++ "targets they match are as follows:\n" - ++ unlines - [ "'" ++ showUserBuildTarget rendering ++ "' which matches " - ++ intercalate ", " - [ showBuildTarget QL1 match ++ - " (" ++ showBuildTargetKind match ++ ")" - | match <- matches ] - | (rendering, matches) <- renderingsAndMatches ] - - case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of - [] -> return () - targets -> - die $ unlines - [ "Unrecognised build target '" ++ showUserBuildTarget target - ++ "'.\n" - ++ "Expected a " ++ intercalate " or " expected - ++ ", rather than '" ++ got ++ "'." - | (target, expected, got) <- targets ] - - case [ (t, e) | BuildTargetNoSuch t e <- problems ] of - [] -> return () - targets -> - die $ unlines - [ "Unknown build target '" ++ showUserBuildTarget target ++ - "'.\n" ++ unlines - [ (case inside of - Just (kind, thing) - -> "The " ++ kind ++ " " ++ thing ++ " has no " - Nothing -> "There is no ") - ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" - | (thing, got, _alts) <- nosuch' ] ++ "." - ++ if null alternatives then "" else - "\nPerhaps you meant " ++ intercalate ";\nor " - [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?" - | (thing, alts) <- alternatives ] - | (inside, nosuch') <- groupByContainer nosuch - , let alternatives = - [ (thing, alts) - | (thing,_got,alts@(_:_)) <- nosuch' ] - ] - | (target, nosuch) <- targets - , let groupByContainer = - map (\g@((inside,_,_,_):_) -> - (inside, [ (thing,got,alts) - | (_,thing,got,alts) <- g ])) - . groupBy ((==) `on` (\(x,_,_,_) -> x)) - . sortBy (compare `on` (\(x,_,_,_) -> x)) - ] - where - mungeThing "file" = "file target" - mungeThing thing = thing - - case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of - [] -> return () - targets -> - die $ unlines - [ "Ambiguous build target '" ++ showUserBuildTarget target - ++ "'. It could be:\n " - ++ unlines [ " "++ showUserBuildTarget ut ++ - " (" ++ showBuildTargetKind bt ++ ")" - | (ut, bt) <- amb ] - | (target, amb) <- targets ] - - where - showBuildTargetKind (BuildTargetPackage _ ) = "package" - showBuildTargetKind (BuildTargetComponent _ _ ) = "component" - showBuildTargetKind (BuildTargetModule _ _ _) = "module" - showBuildTargetKind (BuildTargetFile _ _ _) = "file" - - ----------------------------------- --- Top level BuildTarget matcher --- - -matchBuildTarget :: [PackageInfo] -> [PackageInfo] - -> UserBuildTargetFileStatus - -> Match (BuildTarget PackageInfo) -matchBuildTarget ppinfo opinfo = \utarget -> - nubMatchesBy ((==) `on` (fmap packageName)) $ - case utarget of - UserBuildTargetFileStatus1 str1 fstatus1 -> - matchBuildTarget1 ppinfo opinfo str1 fstatus1 - - UserBuildTargetFileStatus2 str1 fstatus1 str2 -> - matchBuildTarget2 pinfo str1 fstatus1 str2 - - UserBuildTargetFileStatus3 str1 fstatus1 str2 str3 -> - matchBuildTarget3 pinfo str1 fstatus1 str2 str3 - - UserBuildTargetFileStatus4 str1 fstatus1 str2 str3 str4 -> - matchBuildTarget4 pinfo str1 fstatus1 str2 str3 str4 - where - pinfo = ppinfo ++ opinfo - --TODO: sort this out - - -matchBuildTarget1 :: [PackageInfo] -> [PackageInfo] - -> String -> FileStatus -> Match (BuildTarget PackageInfo) -matchBuildTarget1 ppinfo opinfo = \str1 fstatus1 -> - match1Cmp pcinfo str1 - match1Pkg pinfo str1 fstatus1 - match1Cmp ocinfo str1 - match1Mod cinfo str1 - match1Fil pinfo str1 fstatus1 - where - pinfo = ppinfo ++ opinfo - cinfo = concatMap pinfoComponents pinfo - pcinfo = concatMap pinfoComponents ppinfo - ocinfo = concatMap pinfoComponents opinfo - - -matchBuildTarget2 :: [PackageInfo] -> String -> FileStatus -> String - -> Match (BuildTarget PackageInfo) -matchBuildTarget2 pinfo str1 fstatus1 str2 = - match2PkgCmp pinfo str1 fstatus1 str2 - <|> match2KndCmp cinfo str1 str2 - match2PkgMod pinfo str1 fstatus1 str2 - match2CmpMod cinfo str1 str2 - match2PkgFil pinfo str1 fstatus1 str2 - match2CmpFil cinfo str1 str2 - where - cinfo = concatMap pinfoComponents pinfo - --TODO: perhaps we actually do want to prioritise local/primary components - - -matchBuildTarget3 :: [PackageInfo] -> String -> FileStatus -> String -> String - -> Match (BuildTarget PackageInfo) -matchBuildTarget3 pinfo str1 fstatus1 str2 str3 = - match3PkgKndCmp pinfo str1 fstatus1 str2 str3 - match3PkgCmpMod pinfo str1 fstatus1 str2 str3 - match3PkgCmpFil pinfo str1 fstatus1 str2 str3 - match3KndCmpMod cinfo str1 str2 str3 - match3KndCmpFil cinfo str1 str2 str3 - where - cinfo = concatMap pinfoComponents pinfo - - -matchBuildTarget4 :: [PackageInfo] - -> String -> FileStatus -> String -> String -> String - -> Match (BuildTarget PackageInfo) -matchBuildTarget4 pinfo str1 fstatus1 str2 str3 str4 = - match4PkgKndCmpMod pinfo str1 fstatus1 str2 str3 str4 - match4PkgKndCmpFil pinfo str1 fstatus1 str2 str3 str4 - - ------------------------------------- --- Individual BuildTarget matchers --- - -match1Pkg :: [PackageInfo] -> String -> FileStatus - -> Match (BuildTarget PackageInfo) -match1Pkg pinfo = \str1 fstatus1 -> do - guardPackage str1 fstatus1 - p <- matchPackage pinfo str1 fstatus1 - return (BuildTargetPackage p) - -match1Cmp :: [ComponentInfo] -> String -> Match (BuildTarget PackageInfo) -match1Cmp cs = \str1 -> do - guardComponentName str1 - c <- matchComponentName cs str1 - return (BuildTargetComponent (cinfoPackage c) (cinfoName c)) - -match1Mod :: [ComponentInfo] -> String -> Match (BuildTarget PackageInfo) -match1Mod cs = \str1 -> do - guardModuleName str1 - let ms = [ (m,c) | c <- cs, m <- cinfoModules c ] - (m,c) <- matchModuleNameAnd ms str1 - return (BuildTargetModule (cinfoPackage c) (cinfoName c) m) - -match1Fil :: [PackageInfo] -> String -> FileStatus - -> Match (BuildTarget PackageInfo) -match1Fil ps str1 fstatus1 = - expecting "file" str1 $ do - (pkgfile, p) <- matchPackageDirectoryPrefix ps fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - (filepath, c) <- matchComponentFile (pinfoComponents p) pkgfile - return (BuildTargetFile p (cinfoName c) filepath) - ---- - -match2PkgCmp :: [PackageInfo] - -> String -> FileStatus -> String - -> Match (BuildTarget PackageInfo) -match2PkgCmp ps = \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 - guardComponentName str2 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentName (pinfoComponents p) str2 - return (BuildTargetComponent p (cinfoName c)) - --TODO: the error here ought to say there's no component by that name in - -- this package, and name the package - -match2KndCmp :: [ComponentInfo] -> String -> String - -> Match (BuildTarget PackageInfo) -match2KndCmp cs = \str1 str2 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - return (BuildTargetComponent (cinfoPackage c) (cinfoName c)) - -match2PkgMod :: [PackageInfo] -> String -> FileStatus -> String - -> Match (BuildTarget PackageInfo) -match2PkgMod ps = \str1 fstatus1 str2 -> do - guardPackage str1 fstatus1 - guardModuleName str2 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - let ms = [ (m,c) | c <- pinfoComponents p, m <- cinfoModules c ] - (m,c) <- matchModuleNameAnd ms str2 - return (BuildTargetModule p (cinfoName c) m) - -match2CmpMod :: [ComponentInfo] -> String -> String - -> Match (BuildTarget PackageInfo) -match2CmpMod cs = \str1 str2 -> do - guardComponentName str1 - guardModuleName str2 - c <- matchComponentName cs str1 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str2 - return (BuildTargetModule (cinfoPackage c) (cinfoName c) m) - -match2PkgFil :: [PackageInfo] -> String -> FileStatus -> String - -> Match (BuildTarget PackageInfo) -match2PkgFil ps str1 fstatus1 str2 = do - guardPackage str1 fstatus1 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - (filepath, c) <- matchComponentFile (pinfoComponents p) str2 - return (BuildTargetFile p (cinfoName c) filepath) - -match2CmpFil :: [ComponentInfo] -> String -> String - -> Match (BuildTarget PackageInfo) -match2CmpFil cs str1 str2 = do - guardComponentName str1 - c <- matchComponentName cs str1 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath, _) <- matchComponentFile [c] str2 - return (BuildTargetFile (cinfoPackage c) (cinfoName c) filepath) - ---- - -match3PkgKndCmp :: [PackageInfo] - -> String -> FileStatus -> String -> String - -> Match (BuildTarget PackageInfo) -match3PkgKndCmp ps = \str1 fstatus1 str2 str3 -> do - guardPackage str1 fstatus1 - ckind <- matchComponentKind str2 - guardComponentName str3 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentKindAndName (pinfoComponents p) ckind str3 - return (BuildTargetComponent p (cinfoName c)) - -match3PkgCmpMod :: [PackageInfo] - -> String -> FileStatus -> String -> String - -> Match (BuildTarget PackageInfo) -match3PkgCmpMod ps = \str1 fstatus1 str2 str3 -> do - guardPackage str1 fstatus1 - guardComponentName str2 - guardModuleName str3 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentName (pinfoComponents p) str2 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str3 - return (BuildTargetModule p (cinfoName c) m) - -match3KndCmpMod :: [ComponentInfo] - -> String -> String -> String - -> Match (BuildTarget PackageInfo) -match3KndCmpMod cs = \str1 str2 str3 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - guardModuleName str3 - c <- matchComponentKindAndName cs ckind str2 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str3 - return (BuildTargetModule (cinfoPackage c) (cinfoName c) m) - -match3PkgCmpFil :: [PackageInfo] - -> String -> FileStatus -> String -> String - -> Match (BuildTarget PackageInfo) -match3PkgCmpFil ps = \str1 fstatus1 str2 str3 -> do - guardPackage str1 fstatus1 - guardComponentName str2 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentName (pinfoComponents p) str2 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath, _) <- matchComponentFile [c] str3 - return (BuildTargetFile p (cinfoName c) filepath) - -match3KndCmpFil :: [ComponentInfo] -> String -> String -> String - -> Match (BuildTarget PackageInfo) -match3KndCmpFil cs = \str1 str2 str3 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath, _) <- matchComponentFile [c] str3 - return (BuildTargetFile (cinfoPackage c) (cinfoName c) filepath) - --- - -match4PkgKndCmpMod :: [PackageInfo] - -> String-> FileStatus -> String -> String -> String - -> Match (BuildTarget PackageInfo) -match4PkgKndCmpMod ps = \str1 fstatus1 str2 str3 str4 -> do - guardPackage str1 fstatus1 - ckind <- matchComponentKind str2 - guardComponentName str3 - guardModuleName str4 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentKindAndName (pinfoComponents p) ckind str3 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str4 - return (BuildTargetModule p (cinfoName c) m) - -match4PkgKndCmpFil :: [PackageInfo] - -> String -> FileStatus -> String -> String -> String - -> Match (BuildTarget PackageInfo) -match4PkgKndCmpFil ps = \str1 fstatus1 str2 str3 str4 -> do - guardPackage str1 fstatus1 - ckind <- matchComponentKind str2 - guardComponentName str3 - p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentKindAndName (pinfoComponents p) ckind str3 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath,_) <- matchComponentFile [c] str4 - return (BuildTargetFile p (cinfoName c) filepath) - - -------------------------------- --- Package and component info --- - -data PackageInfo = PackageInfo { - pinfoId :: PackageId, - pinfoLocation :: PackageLocation (), - pinfoDirectory :: Maybe (FilePath, FilePath), - pinfoPackageFile :: Maybe (FilePath, FilePath), - pinfoComponents :: [ComponentInfo] - } - -data ComponentInfo = ComponentInfo { - cinfoName :: ComponentName, - cinfoStrName :: ComponentStringName, - cinfoPackage :: PackageInfo, - cinfoSrcDirs :: [FilePath], - cinfoModules :: [ModuleName], - cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) - cinfoCFiles :: [FilePath], - cinfoJsFiles :: [FilePath] - } - -type ComponentStringName = String - -instance Package PackageInfo where - packageId = pinfoId - ---TODO: [required eventually] need the original GenericPackageDescription or --- the flattening thereof because we need to be able to target modules etc --- that are not enabled in the current configuration. -selectPackageInfo :: PackageDescription -> PackageLocation a -> IO PackageInfo -selectPackageInfo pkg loc = do - (pkgdir, pkgfile) <- - case loc of - --TODO: local tarballs, remote tarballs etc - LocalUnpackedPackage dir -> do - dirabs <- canonicalizePath dir - dirrel <- makeRelativeToCwd dirabs - --TODO: ought to get this earlier in project reading - let fileabs = dirabs display (packageName pkg) <.> "cabal" - filerel = dirrel display (packageName pkg) <.> "cabal" - exists <- doesFileExist fileabs - return ( Just (dirabs, dirrel) - , if exists then Just (fileabs, filerel) else Nothing - ) - _ -> return (Nothing, Nothing) - let pinfo = - PackageInfo { - pinfoId = packageId pkg, - pinfoLocation = fmap (const ()) loc, - pinfoDirectory = pkgdir, - pinfoPackageFile = pkgfile, - pinfoComponents = selectComponentInfo pinfo pkg - } - return pinfo - - -selectComponentInfo :: PackageInfo -> PackageDescription -> [ComponentInfo] -selectComponentInfo pinfo pkg = - [ ComponentInfo { - cinfoName = componentName c, - cinfoStrName = componentStringName pkg (componentName c), - cinfoPackage = pinfo, - cinfoSrcDirs = hsSourceDirs bi, --- [ pkgroot srcdir --- | (pkgroot,_) <- maybeToList (pinfoDirectory pinfo) --- , srcdir <- hsSourceDirs bi ], - cinfoModules = componentModules c, - cinfoHsFiles = componentHsFiles c, - cinfoCFiles = cSources bi, - cinfoJsFiles = jsSources bi - } - | c <- pkgComponents pkg - , let bi = componentBuildInfo c ] - - -componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName -componentStringName pkg CLibName = display (packageName pkg) -componentStringName _ (CSubLibName name) = unUnqualComponentName name -componentStringName _ (CFLibName name) = unUnqualComponentName name -componentStringName _ (CExeName name) = unUnqualComponentName name -componentStringName _ (CTestName name) = unUnqualComponentName name -componentStringName _ (CBenchName name) = unUnqualComponentName name - -componentModules :: Component -> [ModuleName] --- I think it's unlikely users will ask to build a requirement --- which is not mentioned locally. -componentModules (CLib lib) = explicitLibModules lib -componentModules (CFLib flib) = foreignLibModules flib -componentModules (CExe exe) = exeModules exe -componentModules (CTest test) = testModules test -componentModules (CBench bench) = benchmarkModules bench - -componentHsFiles :: Component -> [FilePath] -componentHsFiles (CExe exe) = [modulePath exe] -componentHsFiles (CTest TestSuite { - testInterface = TestSuiteExeV10 _ mainfile - }) = [mainfile] -componentHsFiles (CBench Benchmark { - benchmarkInterface = BenchmarkExeV10 _ mainfile - }) = [mainfile] -componentHsFiles _ = [] - - ------------------------------- --- Matching component kinds --- - -data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind - deriving (Eq, Ord, Show) - -componentKind :: ComponentName -> ComponentKind -componentKind CLibName = LibKind -componentKind (CSubLibName _) = LibKind -componentKind (CFLibName _) = FLibKind -componentKind (CExeName _) = ExeKind -componentKind (CTestName _) = TestKind -componentKind (CBenchName _) = BenchKind - -cinfoKind :: ComponentInfo -> ComponentKind -cinfoKind = componentKind . cinfoName - -matchComponentKind :: String -> Match ComponentKind -matchComponentKind s - | s `elem` ["lib", "library"] = increaseConfidence >> return LibKind - | s `elem` ["exe", "executable"] = increaseConfidence >> return ExeKind - | s `elem` ["tst", "test", "test-suite"] = increaseConfidence - >> return TestKind - | s `elem` ["bench", "benchmark"] = increaseConfidence - >> return BenchKind - | otherwise = matchErrorExpected - "component kind" s - -showComponentKind :: ComponentKind -> String -showComponentKind LibKind = "library" -showComponentKind FLibKind = "foreign library" -showComponentKind ExeKind = "executable" -showComponentKind TestKind = "test-suite" -showComponentKind BenchKind = "benchmark" - -showComponentKindShort :: ComponentKind -> String -showComponentKindShort LibKind = "lib" -showComponentKindShort FLibKind = "flib" -showComponentKindShort ExeKind = "exe" -showComponentKindShort TestKind = "test" -showComponentKindShort BenchKind = "bench" - ------------------------------- --- Matching package targets --- - -guardPackage :: String -> FileStatus -> Match () -guardPackage str fstatus = - guardPackageName str - <|> guardPackageDir str fstatus - <|> guardPackageFile str fstatus - - -guardPackageName :: String -> Match () -guardPackageName s - | validPackageName s = increaseConfidence - | otherwise = matchErrorExpected "package name" s - where - -validPackageName :: String -> Bool -validPackageName s = - all validPackageNameChar s - && not (null s) - where - validPackageNameChar c = isAlphaNum c || c == '-' - - -guardPackageDir :: String -> FileStatus -> Match () -guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence -guardPackageDir str _ = matchErrorExpected "package directory" str - - -guardPackageFile :: String -> FileStatus -> Match () -guardPackageFile _ (FileStatusExistsFile file) - | takeExtension file == ".cabal" - = increaseConfidence -guardPackageFile str _ = matchErrorExpected "package .cabal file" str - - -matchPackage :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo -matchPackage pinfo = \str fstatus -> - orNoThingIn "project" "" $ - matchPackageName pinfo str - (matchPackageDir pinfo str fstatus - <|> matchPackageFile pinfo str fstatus) - - -matchPackageName :: [PackageInfo] -> String -> Match PackageInfo -matchPackageName ps = \str -> do - guard (validPackageName str) - orNoSuchThing "package" str - (map (display . packageName) ps) $ - increaseConfidenceFor $ - matchInexactly caseFold (display . packageName) ps str - - -matchPackageDir :: [PackageInfo] - -> String -> FileStatus -> Match PackageInfo -matchPackageDir ps = \str fstatus -> - case fstatus of - FileStatusExistsDir canondir -> - orNoSuchThing "package directory" str (map (snd . fst) dirs) $ - increaseConfidenceFor $ - fmap snd $ matchExactly (fst . fst) dirs canondir - _ -> mzero - where - dirs = [ ((dabs,drel),p) - | p@PackageInfo{ pinfoDirectory = Just (dabs,drel) } <- ps ] - - -matchPackageFile :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo -matchPackageFile ps = \str fstatus -> do - case fstatus of - FileStatusExistsFile canonfile -> - orNoSuchThing "package .cabal file" str (map (snd . fst) files) $ - increaseConfidenceFor $ - fmap snd $ matchExactly (fst . fst) files canonfile - _ -> mzero - where - files = [ ((fabs,frel),p) - | p@PackageInfo{ pinfoPackageFile = Just (fabs,frel) } <- ps ] - ---TODO: test outcome when dir exists but doesn't match any known one - ---TODO: perhaps need another distinction, vs no such thing, point is the --- thing is not known, within the project, but could be outside project - - ------------------------------- --- Matching component targets --- - - -guardComponentName :: String -> Match () -guardComponentName s - | all validComponentChar s - && not (null s) = increaseConfidence - | otherwise = matchErrorExpected "component name" s - where - validComponentChar c = isAlphaNum c || c == '.' - || c == '_' || c == '-' || c == '\'' - - -matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo -matchComponentName cs str = - orNoSuchThing "component" str (map cinfoStrName cs) - $ increaseConfidenceFor - $ matchInexactly caseFold cinfoStrName cs str - - -matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String - -> Match ComponentInfo -matchComponentKindAndName cs ckind str = - orNoSuchThing (showComponentKind ckind ++ " component") str - (map render cs) - $ increaseConfidenceFor - $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) - (\c -> (cinfoKind c, cinfoStrName c)) - cs - (ckind, str) - where - render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c - - ------------------------------- --- Matching module targets --- - -guardModuleName :: String -> Match () -guardModuleName s = - case simpleParse s :: Maybe ModuleName of - Just _ -> increaseConfidence - _ | all validModuleChar s - && not (null s) -> return () - | otherwise -> matchErrorExpected "module name" s - where - validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' - - -matchModuleName :: [ModuleName] -> String -> Match ModuleName -matchModuleName ms str = - orNoSuchThing "module" str (map display ms) - $ increaseConfidenceFor - $ matchInexactly caseFold display ms str - - -matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a) -matchModuleNameAnd ms str = - orNoSuchThing "module" str (map (display . fst) ms) - $ increaseConfidenceFor - $ matchInexactly caseFold (display . fst) ms str - - ------------------------------- --- Matching file targets --- - -matchPackageDirectoryPrefix :: [PackageInfo] -> FileStatus - -> Match (FilePath, PackageInfo) -matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) = - increaseConfidenceFor $ - matchDirectoryPrefix pkgdirs filepath - where - pkgdirs = [ (dir, p) - | p@PackageInfo { pinfoDirectory = Just (dir,_) } <- ps ] -matchPackageDirectoryPrefix _ _ = mzero - - -matchComponentFile :: [ComponentInfo] -> String - -> Match (FilePath, ComponentInfo) -matchComponentFile cs str = - orNoSuchThing "file" str [] $ - matchComponentModuleFile cs str - <|> matchComponentOtherFile cs str - - -matchComponentOtherFile :: [ComponentInfo] -> String - -> Match (FilePath, ComponentInfo) -matchComponentOtherFile cs = - matchFile - [ (file, c) - | c <- cs - , file <- cinfoHsFiles c - ++ cinfoCFiles c - ++ cinfoJsFiles c - ] - - -matchComponentModuleFile :: [ComponentInfo] -> String - -> Match (FilePath, ComponentInfo) -matchComponentModuleFile cs str = do - matchFile - [ (normalise (d toFilePath m), c) - | c <- cs - , d <- cinfoSrcDirs c - , m <- cinfoModules c - ] - (dropExtension (normalise str)) - --- utils - -matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) -matchFile fs = - increaseConfidenceFor - . matchInexactly caseFold fst fs - -matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) -matchDirectoryPrefix dirs filepath = - tryEach $ - [ (file, x) - | (dir,x) <- dirs - , file <- maybeToList (stripDirectory dir) ] - where - stripDirectory :: FilePath -> Maybe FilePath - stripDirectory dir = - joinPath `fmap` stripPrefix (splitDirectories dir) filepathsplit - - filepathsplit = splitDirectories filepath - - ------------------------------- --- Matching monad --- - --- | A matcher embodies a way to match some input as being some recognised --- value. In particular it deals with multiple and ambiguous matches. --- --- There are various matcher primitives ('matchExactly', 'matchInexactly'), --- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we --- can run a matcher against an input using 'findMatch'. --- -data Match a = NoMatch Confidence [MatchError] - | ExactMatch Confidence [a] - | InexactMatch Confidence [a] - deriving Show - -type Confidence = Int - -data MatchError = MatchErrorExpected String String -- thing got - | MatchErrorNoSuch String String [String] -- thing got alts - | MatchErrorIn String String MatchError -- kind thing - deriving (Show, Eq) - - -instance Functor Match where - fmap _ (NoMatch d ms) = NoMatch d ms - fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) - fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) - -instance Applicative Match where - pure a = ExactMatch 0 [a] - (<*>) = ap - -instance Alternative Match where - empty = NoMatch 0 [] - (<|>) = matchPlus - -instance Monad Match where - return = pure - NoMatch d ms >>= _ = NoMatch d ms - ExactMatch d xs >>= f = addDepth d - $ msum (map f xs) - InexactMatch d xs >>= f = addDepth d . forceInexact - $ msum (map f xs) - -instance MonadPlus Match where - mzero = empty - mplus = matchPlus - -() :: Match a -> Match a -> Match a -() = matchPlusShadowing - -infixl 3 - -addDepth :: Confidence -> Match a -> Match a -addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs -addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs -addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs - -forceInexact :: Match a -> Match a -forceInexact (ExactMatch d ys) = InexactMatch d ys -forceInexact m = m - --- | Combine two matchers. Exact matches are used over inexact matches --- but if we have multiple exact, or inexact then the we collect all the --- ambiguous matches. --- -matchPlus :: Match a -> Match a -> Match a -matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = - ExactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a -matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = - InexactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b -matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') - | d1 > d2 = a - | d1 < d2 = b - | otherwise = NoMatch d1 (ms ++ ms') - --- | Combine two matchers. This is similar to 'matchPlus' with the --- difference that an exact match from the left matcher shadows any exact --- match on the right. Inexact matches are still collected however. --- -matchPlusShadowing :: Match a -> Match a -> Match a -matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a -matchPlusShadowing a b = matchPlus a b - - ------------------------------- --- Various match primitives --- - -matchErrorExpected :: String -> String -> Match a -matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] - -matchErrorNoSuch :: String -> String -> [String] -> Match a -matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts] - -expecting :: String -> String -> Match a -> Match a -expecting thing got (NoMatch 0 _) = matchErrorExpected thing got -expecting _ _ m = m - -orNoSuchThing :: String -> String -> [String] -> Match a -> Match a -orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts -orNoSuchThing _ _ _ m = m - -orNoThingIn :: String -> String -> Match a -> Match a -orNoThingIn kind name (NoMatch n ms) = - NoMatch n [ MatchErrorIn kind name m | m <- ms ] -orNoThingIn _ _ m = m - -increaseConfidence :: Match () -increaseConfidence = ExactMatch 1 [()] - -increaseConfidenceFor :: Match a -> Match a -increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r - -nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a -nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs -nubMatchesBy eq (ExactMatch d xs) = ExactMatch d (nubBy eq xs) -nubMatchesBy eq (InexactMatch d xs) = InexactMatch d (nubBy eq xs) - --- | Lift a list of matches to an exact match. --- -exactMatches, inexactMatches :: [a] -> Match a - -exactMatches [] = mzero -exactMatches xs = ExactMatch 0 xs - -inexactMatches [] = mzero -inexactMatches xs = InexactMatch 0 xs - -tryEach :: [a] -> Match a -tryEach = exactMatches - - ------------------------------- --- Top level match runner --- - --- | Given a matcher and a key to look up, use the matcher to find all the --- possible matches. There may be 'None', a single 'Unambiguous' match or --- you may have an 'Ambiguous' match with several possibilities. --- -findMatch :: Match a -> MaybeAmbiguous a -findMatch match = case match of - NoMatch _ msgs -> None msgs - ExactMatch _ [x] -> Unambiguous x - InexactMatch _ [x] -> Unambiguous x - ExactMatch _ [] -> error "findMatch: impossible: ExactMatch []" - InexactMatch _ [] -> error "findMatch: impossible: InexactMatch []" - ExactMatch _ xs -> Ambiguous True xs - InexactMatch _ xs -> Ambiguous False xs - -data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous Bool [a] - deriving Show - - ------------------------------- --- Basic matchers --- - --- | A primitive matcher that looks up a value in a finite 'Map'. The --- value must match exactly. --- -matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a) -matchExactly key xs = - \k -> case Map.lookup k m of - Nothing -> mzero - Just ys -> exactMatches ys - where - m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] - --- | A primitive matcher that looks up a value in a finite 'Map'. It checks --- for an exact or inexact match. We get an inexact match if the match --- is not exact, but the canonical forms match. It takes a canonicalisation --- function for this purpose. --- --- So for example if we used string case fold as the canonicalisation --- function, then we would get case insensitive matching (but it will still --- report an exact match when the case matches too). --- -matchInexactly :: (Ord k, Ord k') => (k -> k') -> (a -> k) - -> [a] -> (k -> Match a) -matchInexactly cannonicalise key xs = - \k -> case Map.lookup k m of - Just ys -> exactMatches ys - Nothing -> case Map.lookup (cannonicalise k) m' of - Just ys -> inexactMatches ys - Nothing -> mzero - where - m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] - - -- the map of canonicalised keys to groups of inexact matches - m' = Map.mapKeysWith (++) cannonicalise m - - ------------------------------- --- Utils --- - -caseFold :: String -> String -caseFold = lowercase - - ------------------------------- --- Example inputs --- - -{- -ex1pinfo :: [PackageInfo] -ex1pinfo = - [ PackageInfo { - pinfoName = PackageName "foo", - pinfoDirectory = Just "/the/foo", - pinfoPackageFile = Just "/the/foo/foo.cabal", - pinfoComponents = [] - } - , PackageInfo { - pinfoName = PackageName "bar", - pinfoDirectory = Just "/the/bar", - pinfoPackageFile = Just "/the/bar/bar.cabal", - pinfoComponents = [] - } - ] --} -{- -stargets = - [ BuildTargetComponent (CExeName "foo") - , BuildTargetModule (CExeName "foo") (mkMn "Foo") - , BuildTargetModule (CExeName "tst") (mkMn "Foo") - ] - where - mkMn :: String -> ModuleName - mkMn = fromJust . simpleParse - -ex_pkgid :: PackageIdentifier -Just ex_pkgid = simpleParse "thelib" --} - -{- -ex_cs :: [ComponentInfo] -ex_cs = - [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) - , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) - ] - where - mkC n ds ms = ComponentInfo n (componentStringName n) ds (map mkMn ms) - mkMn :: String -> ModuleName - mkMn = fromJust . simpleParse - pkgid :: PackageIdentifier - Just pkgid = simpleParse "thelib" --} diff --git a/cabal/cabal-install/Distribution/Client/Check.hs b/cabal/cabal-install/Distribution/Client/Check.hs --- a/cabal/cabal-install/Distribution/Client/Check.hs +++ b/cabal/cabal-install/Distribution/Client/Check.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Check @@ -17,20 +18,19 @@ import Control.Monad ( when, unless ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) +import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) import Distribution.PackageDescription.Check import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.Verbosity ( Verbosity ) import Distribution.Simple.Utils - ( defaultPackageDesc, toUTF8, wrapText ) + ( defaultPackageDesc, wrapText ) check :: Verbosity -> IO Bool check verbosity = do pdfile <- defaultPackageDesc verbosity - ppd <- readPackageDescription verbosity pdfile + ppd <- readGenericPackageDescription verbosity pdfile -- flatten the generic package description into a regular package -- description -- TODO: this may give more warnings than it should give; @@ -82,8 +82,8 @@ when (null packageChecks) $ putStrLn "No errors or warnings could be found in the package." - return (null . filter isCheckError $ packageChecks) + return (not . any isCheckError $ packageChecks) where printCheckMessages = mapM_ (putStrLn . format . explanation) - format = toUTF8 . wrapText . ("* "++) + format = wrapText . ("* "++) diff --git a/cabal/cabal-install/Distribution/Client/CmdBench.hs b/cabal/cabal-install/Distribution/Client/CmdBench.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/CmdBench.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} + +-- | cabal-install CLI command: bench +-- +module Distribution.Client.CmdBench ( + -- * The @bench@ CLI and action + benchCommand, + benchAction, + + -- * Internals exposed for testing + TargetProblem(..), + selectPackageTargets, + selectComponentTarget + ) where + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) +import qualified Distribution.Client.Setup as Client +import Distribution.Simple.Setup + ( HaddockFlags, fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText, die' ) + +import Control.Monad (when) + + +benchCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +benchCommand = Client.installCommand { + commandName = "new-bench", + commandSynopsis = "Run benchmarks", + commandUsage = usageAlternatives "new-bench" [ "[TARGETS] [FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Runs the specified benchmarks, first ensuring they are up to " + ++ "date.\n\n" + + ++ "Any benchmark in any package in the project can be specified. " + ++ "A package can be specified in which case all the benchmarks in the " + ++ "package are run. The default is to run all the benchmarks in the " + ++ "package in the current directory.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " new-bench\n" + ++ " Run all the benchmarks in the package in the current directory\n" + ++ " " ++ pname ++ " new-bench pkgname\n" + ++ " Run all the benchmarks in the package named pkgname\n" + ++ " " ++ pname ++ " new-bench cname\n" + ++ " Run the benchmark named cname\n" + ++ " " ++ pname ++ " new-bench cname -O2\n" + ++ " Run the benchmark built with '-O2' (including local libs used)\n\n" + + ++ cmdCommonHelpTextNewBuildBeta + } + + +-- | The @build@ command does a lot. It brings the install plan up to date, +-- selects that part of the plan needed by the given or implicit targets and +-- then executes the plan. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +benchAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +benchAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) + targetStrings globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ + "The bench command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'bench'." + + -- Interpret the targets on the command line as bench targets + -- (as opposed to say build or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBench + targets + elaboratedPlan + return (elaboratedPlan', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + +-- | This defines what a 'TargetSelector' means for the @bench@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @bench@ command we select all buildable benchmarks, +-- or fail if there are no benchmarks or no buildable benchmarks. +-- +selectPackageTargets :: TargetSelector PackageId + -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable benchmark targets then we select those + | not (null targetsBenchBuildable) + = Right targetsBenchBuildable + + -- If there are benchmarks but none are buildable then we report those + | not (null targetsBench) + = Left (TargetProblemNoneEnabled targetSelector targetsBench) + + -- If there are no benchmarks but some other targets then we report that + | not (null targets) + = Left (TargetProblemNoBenchmarks targetSelector) + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targetsBenchBuildable = selectBuildableTargets + . filterTargetsKind BenchKind + $ targets + + targetsBench = forgetTargetsDetail + . filterTargetsKind BenchKind + $ targets + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @bench@ command we just need to check it is a benchmark, in addition +-- to the basic checks on being buildable etc. +-- +selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget pkgid cname subtarget@WholeComponent t + | CBenchName _ <- availableTargetComponentName t + = either (Left . TargetProblemCommon) return $ + selectComponentTargetBasic pkgid cname subtarget t + | otherwise + = Left (TargetProblemComponentNotBenchmark pkgid cname) + +selectComponentTarget pkgid cname subtarget _ + = Left (TargetProblemIsSubComponent pkgid cname subtarget) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @bench@ command. +-- +data TargetProblem = + TargetProblemCommon TargetProblemCommon + + -- | The 'TargetSelector' matches benchmarks but none are buildable + | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + + -- | There are no targets at all + | TargetProblemNoTargets (TargetSelector PackageId) + + -- | The 'TargetSelector' matches targets but no benchmarks + | TargetProblemNoBenchmarks (TargetSelector PackageId) + + -- | The 'TargetSelector' refers to a component that is not a benchmark + | TargetProblemComponentNotBenchmark PackageId ComponentName + + -- | Asking to benchmark an individual file or module is not supported + | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget + deriving (Eq, Show) + +reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderTargetProblem + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (TargetProblemCommon problem) = + renderTargetProblemCommon "run" problem + +renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled "benchmark" targetSelector targets + +renderTargetProblem (TargetProblemNoBenchmarks targetSelector) = + "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector + ++ "' which refers to " ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any benchmarks." + +renderTargetProblem (TargetProblemNoTargets targetSelector) = + case targetSelectorFilter targetSelector of + Just kind | kind /= BenchKind + -> "The bench command is for running benchmarks, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + + _ -> renderTargetProblemNoTargets "benchmark" targetSelector + +renderTargetProblem (TargetProblemComponentNotBenchmark pkgid cname) = + "The bench command is for running benchmarks, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " from the package " + ++ display pkgid ++ "." + where + targetSelector = TargetComponent pkgid cname WholeComponent + +renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) = + "The bench command can only run benchmarks as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + where + targetSelector = TargetComponent pkgid cname subtarget 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 @@ -1,50 +1,68 @@ +{-# LANGUAGE ViewPatterns #-} + -- | cabal-install CLI command: build -- module Distribution.Client.CmdBuild ( + -- * The @build@ CLI and action buildCommand, buildAction, + + -- * Internals exposed for testing + TargetProblem(..), + selectPackageTargets, + selectComponentTarget ) where import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectConfig - ( BuildTimeSettings(..) ) -import Distribution.Client.ProjectPlanning - ( PackageTarget(..) ) -import Distribution.Client.BuildTarget - ( readUserBuildTargets ) +import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) +import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) -import Distribution.Verbosity - ( normal ) - import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) +import Distribution.Verbosity + ( Verbosity, normal ) import Distribution.Simple.Utils - ( wrapText ) -import qualified Distribution.Client.Setup as Client + ( wrapText, die' ) +import qualified Data.Map as Map + + buildCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) buildCommand = Client.installCommand { commandName = "new-build", - commandSynopsis = "Builds a Nix-local build project", - commandUsage = usageAlternatives "new-build" [ "[FLAGS]" - , "[FLAGS] TARGETS" ], + commandSynopsis = "Compile targets within the project.", + commandUsage = usageAlternatives "new-build" [ "[TARGETS] [FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ - "Builds a Nix-local build project, automatically building and installing" - ++ "necessary dependencies.", + "Build one or more targets from within the project. The available " + ++ "targets are the packages in the project as well as individual " + ++ "components within those packages, including libraries, executables, " + ++ "test-suites or benchmarks. Targets can be specified by name or " + ++ "location. If no target is specified then the default is to build " + ++ "the package in the current directory.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " new-build " + ++ " " ++ pname ++ " new-build\n" ++ " Build the package in the current directory or all packages in the project\n" - ++ " " ++ pname ++ " new-build pkgname " + ++ " " ++ pname ++ " new-build pkgname\n" ++ " Build the package named pkgname in the project\n" - ++ " " ++ pname ++ " new-build cname " + ++ " " ++ pname ++ " new-build ./pkgfoo\n" + ++ " Build the package in the ./pkgfoo directory\n" + ++ " " ++ pname ++ " new-build cname\n" ++ " Build the component named cname in the project\n" - ++ " " ++ pname ++ " new-build pkgname:cname" - ++ " Build the component named cname in the package pkgname\n" + ++ " " ++ pname ++ " new-build cname --enable-profiling\n" + ++ " Build the component in profiling mode (including dependencies as needed)\n\n" + + ++ cmdCommonHelpTextNewBuildBeta } @@ -57,34 +75,123 @@ -- buildAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -buildAction (configFlags, configExFlags, installFlags, haddockFlags) +buildAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) targetStrings globalFlags = do - userTargets <- readUserBuildTargets targetStrings + baseCtx <- establishProjectBaseContext verbosity cliConfig + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) targetStrings + buildCtx <- - runProjectPreBuildPhase - verbosity - ( globalFlags, configFlags, configExFlags - , installFlags, haddockFlags ) - PreBuildHooks { - hookPrePlanning = \_ _ _ -> return (), + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - hookSelectPlanSubset = \buildSettings' elaboratedPlan -> do -- Interpret the targets on the command line as build targets -- (as opposed to say repl or haddock targets). - selectTargets - verbosity - BuildDefaultComponents - BuildSpecificComponent - userTargets - (buildSettingOnlyDeps buildSettings') - elaboratedPlan - } + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + targetSelectors - printPlan verbosity buildCtx + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + elaboratedPlan'' <- + if buildSettingOnlyDeps (buildSettings baseCtx) + then either (reportCannotPruneDependencies verbosity) return $ + pruneInstallPlanToDependencies (Map.keysSet targets) + elaboratedPlan' + else return elaboratedPlan' - buildOutcomes <- runProjectBuildPhase verbosity buildCtx - runProjectPostBuildPhase verbosity buildCtx buildOutcomes + return (elaboratedPlan'', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + +-- | This defines what a 'TargetSelector' means for the @bench@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @build@ command select all components except non-buildable and disabled +-- tests\/benchmarks, fail if there are no such components +-- +selectPackageTargets :: TargetSelector PackageId + -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable targets then we select those + | not (null targetsBuildable) + = Right targetsBuildable + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail targets + targetsBuildable = selectBuildableTargetsWith + (buildable targetSelector) + targets + + -- When there's a target filter like "pkg:tests" then we do select tests, + -- but if it's just a target like "pkg" then we don't build tests unless + -- they are requested by default (i.e. by using --enable-tests) + buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + buildable _ _ = True + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @build@ command we just need the basic checks on being buildable etc. +-- +selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget pkgid cname subtarget = + either (Left . TargetProblemCommon) Right + . selectComponentTargetBasic pkgid cname subtarget + + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @build@ command. +-- +data TargetProblem = + TargetProblemCommon TargetProblemCommon + + -- | The 'TargetSelector' matches targets but none are buildable + | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + + -- | There are no targets at all + | TargetProblemNoTargets (TargetSelector PackageId) + deriving (Eq, Show) + +reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderTargetProblem + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (TargetProblemCommon problem) = + renderTargetProblemCommon "build" problem +renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled "build" targetSelector targets +renderTargetProblem(TargetProblemNoTargets targetSelector) = + renderTargetProblemNoTargets "build" targetSelector + +reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a +reportCannotPruneDependencies verbosity = + die' verbosity . renderCannotPruneDependencies + 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: configure -- module Distribution.Client.CmdConfigure ( @@ -5,13 +6,17 @@ configureAction, ) where +import System.Directory +import Control.Monad +import qualified Data.Map as Map + import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectPlanning - ( PackageTarget(..) ) + ( writeProjectLocalExtraConfig ) import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Verbosity @@ -20,24 +25,49 @@ import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Simple.Utils - ( wrapText ) + ( wrapText, notice ) import qualified Distribution.Client.Setup as Client configureCommand :: CommandUI (ConfigFlags, ConfigExFlags ,InstallFlags, HaddockFlags) configureCommand = Client.installCommand { commandName = "new-configure", - commandSynopsis = "Write out a cabal.project.local file.", + commandSynopsis = "Add extra project configuration", commandUsage = usageAlternatives "new-configure" [ "[FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ - "Configures a Nix-local build project, downloading source from" - ++ " the network and writing out a cabal.project.local file which" - ++ " saves any FLAGS, to be reapplied on subsequent invocations to " - ++ "new-build.", + "Adjust how the project is built by setting additional package flags " + ++ "and other flags.\n\n" + + ++ "The configuration options are written to the 'cabal.project.local' " + ++ "file (or '$project_file.local', if '--project-file' is specified) " + ++ "which extends the configuration from the 'cabal.project' file " + ++ "(if any). This combination is used as the project configuration for " + ++ "all other commands (such as 'new-build', 'new-repl' etc) though it " + ++ "can be extended/overridden on a per-command basis.\n\n" + + ++ "The new-configure command also checks that the project configuration " + ++ "will work. In particular it checks that there is a consistent set of " + ++ "dependencies for the project as a whole.\n\n" + + ++ "The 'cabal.project.local' file persists across 'new-clean' but is " + ++ "overwritten on the next use of the 'new-configure' command. The " + ++ "intention is that the 'cabal.project' file should be kept in source " + ++ "control but the 'cabal.project.local' should not.\n\n" + + ++ "It is never necessary to use the 'new-configure' command. It is " + ++ "merely a convenience in cases where you do not want to specify flags " + ++ "to 'new-build' (and other commands) every time and yet do not want " + ++ "to alter the 'cabal.project' persistently.", commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " new-configure " - ++ " Configure project of the current directory\n" + ++ " " ++ pname ++ " new-configure --with-compiler ghc-7.10.3\n" + ++ " Adjust the project configuration to use the given compiler\n" + ++ " program and check the resulting configuration works.\n" + ++ " " ++ pname ++ " new-configure\n" + ++ " Reset the local configuration to empty and check the overall\n" + ++ " project configuration works.\n\n" + + ++ cmdCommonHelpTextNewBuildBeta } -- | To a first approximation, the @configure@ just runs the first phase of @@ -52,37 +82,33 @@ -- configureAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -configureAction (configFlags, configExFlags, installFlags, haddockFlags) +configureAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) _extraArgs globalFlags = do --TODO: deal with _extraArgs, since flags with wrong syntax end up there + baseCtx <- establishProjectBaseContext verbosity cliConfig + + -- Write out the @cabal.project.local@ so it gets picked up by the + -- planning phase. If old config exists, then print the contents + -- before overwriting + exists <- doesFileExist "cabal.project.local" + when exists $ do + notice verbosity "'cabal.project.local' file already exists. Now overwriting it." + copyFile "cabal.project.local" "cabal.project.local~" + writeProjectLocalExtraConfig (distDirLayout baseCtx) + cliConfig + buildCtx <- - runProjectPreBuildPhase - verbosity - ( globalFlags, configFlags, configExFlags - , installFlags, haddockFlags ) - PreBuildHooks { - hookPrePlanning = \rootDir _ cliConfig -> - -- Write out the @cabal.project.local@ so it gets picked up by the - -- planning phase. - writeProjectLocalExtraConfig rootDir cliConfig, + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> - hookSelectPlanSubset = \buildSettings' elaboratedPlan -> do - -- Select the same subset of targets as 'CmdBuild' would + -- TODO: Select the same subset of targets as 'CmdBuild' would -- pick (ignoring, for example, executables in libraries - -- we depend on). - selectTargets - verbosity - BuildDefaultComponents - BuildSpecificComponent - [] - (buildSettingOnlyDeps buildSettings') - elaboratedPlan - - } + -- we depend on). But we don't want it to fail, so actually we + -- have to do it slightly differently from build. + return (elaboratedPlan, Map.empty) - let buildCtx' = buildCtx { - buildSettings = (buildSettings buildCtx) { + let baseCtx' = baseCtx { + buildSettings = (buildSettings baseCtx) { buildSettingDryRun = True } } @@ -92,6 +118,10 @@ -- implicit target like "." -- -- TODO: should we say what's in the project (+deps) as a whole? - printPlan verbosity buildCtx' + printPlan verbosity baseCtx' buildCtx where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + diff --git a/cabal/cabal-install/Distribution/Client/CmdErrorMessages.hs b/cabal/cabal-install/Distribution/Client/CmdErrorMessages.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/CmdErrorMessages.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} + +-- | Utilities to help format error messages for the various CLI commands. +-- +module Distribution.Client.CmdErrorMessages ( + module Distribution.Client.CmdErrorMessages, + module Distribution.Client.TargetSelector, + ) where + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.TargetSelector + ( ComponentKindFilter, componentKind, showTargetSelector ) + +import Distribution.Package + ( packageId, packageName ) +import Distribution.Types.ComponentName + ( showComponentName ) +import Distribution.Solver.Types.OptionalStanza + ( OptionalStanza(..) ) +import Distribution.Text + ( display ) + +import Data.Maybe (isNothing) +import Data.List (sortBy, groupBy, nub) +import Data.Function (on) + + +----------------------- +-- Singular or plural +-- + +-- | A tag used in rendering messages to distinguish singular or plural. +-- +data Plural = Singular | Plural + +-- | Used to render a singular or plural version of something +-- +-- > plural (listPlural theThings) "it is" "they are" +-- +plural :: Plural -> a -> a -> a +plural Singular si _pl = si +plural Plural _si pl = pl + +-- | Singular for singleton lists and plural otherwise. +-- +listPlural :: [a] -> Plural +listPlural [_] = Singular +listPlural _ = Plural + + +-------------------- +-- Rendering lists +-- + +-- | Render a list of things in the style @foo, bar and baz@ +renderListCommaAnd :: [String] -> String +renderListCommaAnd [] = "" +renderListCommaAnd [x] = x +renderListCommaAnd [x,x'] = x ++ " and " ++ x' +renderListCommaAnd (x:xs) = x ++ ", " ++ renderListCommaAnd xs + +-- | Render a list of things in the style @blah blah; this that; and the other@ +renderListSemiAnd :: [String] -> String +renderListSemiAnd [] = "" +renderListSemiAnd [x] = x +renderListSemiAnd [x,x'] = x ++ "; and " ++ x' +renderListSemiAnd (x:xs) = x ++ "; " ++ renderListSemiAnd xs + +-- | When rendering lists of things it often reads better to group related +-- things, e.g. grouping components by package name +-- +-- > renderListSemiAnd +-- > [ "the package " ++ display pkgname ++ " components " +-- > ++ renderListCommaAnd showComponentName components +-- > | (pkgname, components) <- sortGroupOn packageName allcomponents ] +-- +sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])] +sortGroupOn key = map (\xs@(x:_) -> (key x, xs)) + . groupBy ((==) `on` key) + . sortBy (compare `on` key) + + +---------------------------------------------------- +-- Renderering for a few project and package types +-- + +renderTargetSelector :: TargetSelector PackageId -> String +renderTargetSelector (TargetPackage _ pkgid Nothing) = + "the package " ++ display pkgid + +renderTargetSelector (TargetPackage _ pkgid (Just kfilter)) = + "the " ++ renderComponentKind Plural kfilter + ++ " in the package " ++ display pkgid + +renderTargetSelector (TargetAllPackages Nothing) = + "all the packages in the project" + +renderTargetSelector (TargetAllPackages (Just kfilter)) = + "all the " ++ renderComponentKind Plural kfilter + ++ " in the project" + +renderTargetSelector (TargetComponent pkgid CLibName WholeComponent) = + "the library in the package " ++ display pkgid + +renderTargetSelector (TargetComponent _pkgid cname WholeComponent) = + "the " ++ showComponentName cname + +renderTargetSelector (TargetComponent _pkgid cname (FileTarget filename)) = + "the file " ++ filename ++ " in the " ++ showComponentName cname + +renderTargetSelector (TargetComponent _pkgid cname (ModuleTarget modname)) = + "the module " ++ display modname ++ " in the " ++ showComponentName cname + +renderTargetSelector (TargetPackageName pkgname) = + "the package " ++ display pkgname + + +renderOptionalStanza :: Plural -> OptionalStanza -> String +renderOptionalStanza Singular TestStanzas = "test suite" +renderOptionalStanza Plural TestStanzas = "test suites" +renderOptionalStanza Singular BenchStanzas = "benchmark" +renderOptionalStanza Plural BenchStanzas = "benchmarks" + +-- | The optional stanza type (test suite or benchmark), if it is one. +optionalStanza :: ComponentName -> Maybe OptionalStanza +optionalStanza (CTestName _) = Just TestStanzas +optionalStanza (CBenchName _) = Just BenchStanzas +optionalStanza _ = Nothing + +-- | Does the 'TargetSelector' potentially refer to one package or many? +-- +targetSelectorPluralPkgs :: TargetSelector a -> Plural +targetSelectorPluralPkgs (TargetAllPackages _) = Plural +targetSelectorPluralPkgs (TargetPackage _ _ _) = Singular +targetSelectorPluralPkgs (TargetComponent _ _ _) = Singular +targetSelectorPluralPkgs (TargetPackageName _) = Singular + +-- | Does the 'TargetSelector' refer to +targetSelectorRefersToPkgs :: TargetSelector a -> Bool +targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetComponent _ _ _) = False +targetSelectorRefersToPkgs (TargetPackageName _) = True + +targetSelectorFilter :: TargetSelector a -> Maybe ComponentKindFilter +targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter +targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter +targetSelectorFilter (TargetComponent _ _ _) = Nothing +targetSelectorFilter (TargetPackageName _) = Nothing + +renderComponentKind :: Plural -> ComponentKind -> String +renderComponentKind Singular ckind = case ckind of + LibKind -> "library" -- internal/sub libs? + FLibKind -> "foreign library" + ExeKind -> "executable" + TestKind -> "test suite" + BenchKind -> "benchmark" +renderComponentKind Plural ckind = case ckind of + LibKind -> "libraries" -- internal/sub libs? + FLibKind -> "foreign libraries" + ExeKind -> "executables" + TestKind -> "test suites" + BenchKind -> "benchmarks" + + +------------------------------------------------------- +-- Renderering error messages for TargetProblemCommon +-- + +renderTargetProblemCommon :: String -> TargetProblemCommon -> String +renderTargetProblemCommon verb (TargetNotInProject pkgname) = + "Cannot " ++ verb ++ " the package " ++ display pkgname ++ ", it is not " + ++ "in this project (either directly or indirectly). If you want to add it " + ++ "to the project then edit the cabal.project file." + +renderTargetProblemCommon verb (TargetComponentNotProjectLocal pkgid cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " + ++ "package " ++ display pkgid ++ " is not local to the project, and cabal " + ++ "does not currently support building test suites or benchmarks of " + ++ "non-local dependencies. To run test suites or benchmarks from " + ++ "dependencies you can unpack the package locally and adjust the " + ++ "cabal.project file to include that package directory." + +renderTargetProblemCommon verb (TargetComponentNotBuildable pkgid cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because it is " + ++ "marked as 'buildable: False' within the '" ++ display (packageName pkgid) + ++ ".cabal' file (at least for the current configuration). If you believe it " + ++ "should be buildable then check the .cabal file to see if the buildable " + ++ "property is conditional on flags. Alternatively you may simply have to " + ++ "edit the .cabal file to declare it as buildable and fix any resulting " + ++ "build problems." + +renderTargetProblemCommon verb (TargetOptionalStanzaDisabledByUser _ cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because " + ++ "building " ++ compkinds ++ " has been explicitly disabled in the " + ++ "configuration. You can adjust this configuration in the " + ++ "cabal.project{.local} file either for all packages in the project or on " + ++ "a per-package basis. Note that if you do not explicitly disable " + ++ compkinds ++ " then the solver will merely try to make a plan with " + ++ "them available, so you may wish to explicitly enable them which will " + ++ "require the solver to find a plan with them available or to fail with an " + ++ "explanation." + where + compkinds = renderComponentKind Plural (componentKind cname) + +renderTargetProblemCommon verb (TargetOptionalStanzaDisabledBySolver pkgid cname _) = + "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " + ++ "solver did not find a plan that included the " ++ compkinds + ++ " for " ++ display pkgid ++ ". It is probably worth trying again with " + ++ compkinds ++ "explicitly enabled in the configuration in the " + ++ "cabal.project{.local} file. This will ask the solver to find a plan with " + ++ "the " ++ compkinds ++ " available. It will either fail with an " + ++ "explanation or find a different plan that uses different versions of some " + ++ "other packages. Use the '--dry-run' flag to see package versions and " + ++ "check that you are happy with the choices." + where + compkinds = renderComponentKind Plural (componentKind cname) + +renderTargetProblemCommon verb (TargetProblemNoSuchPackage pkgid) = + "Internal error when trying to " ++ verb ++ " the package " + ++ display pkgid ++ ". The package is not in the set of available targets " + ++ "for the project plan, which would suggest an inconsistency " + ++ "between readTargetSelectors and resolveTargets." + +renderTargetProblemCommon verb (TargetProblemNoSuchComponent pkgid cname) = + "Internal error when trying to " ++ verb ++ " the " + ++ showComponentName cname ++ " from the package " ++ display pkgid + ++ ". The package,component pair is not in the set of available targets " + ++ "for the project plan, which would suggest an inconsistency " + ++ "between readTargetSelectors and resolveTargets." + + +------------------------------------------------------------ +-- Renderering error messages for TargetProblemNoneEnabled +-- + +-- | Several commands have a @TargetProblemNoneEnabled@ problem constructor. +-- This renders an error message for those cases. +-- +renderTargetProblemNoneEnabled :: String + -> TargetSelector PackageId + -> [AvailableTarget ()] + -> String +renderTargetProblemNoneEnabled verb targetSelector targets = + "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector + ++ " because none of the components are available to build: " + ++ renderListSemiAnd + [ case (status, mstanza) of + (TargetDisabledByUser, Just stanza) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ plural (listPlural targets') " is " " are " + ++ " not available because building " + ++ renderOptionalStanza Plural stanza + ++ " has been disabled in the configuration" + (TargetDisabledBySolver, Just stanza) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ plural (listPlural targets') " is " " are " + ++ "not available because the solver did not find a plan that " + ++ "included the " ++ renderOptionalStanza Plural stanza + (TargetNotBuildable, _) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ plural (listPlural targets') " is " " are all " + ++ "marked as 'buildable: False'" + (TargetNotLocal, _) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ " cannot be built because cabal does not currently support " + ++ "building test suites or benchmarks of non-local dependencies" + (TargetBuildable () TargetNotRequestedByDefault, Just stanza) -> + renderListCommaAnd + [ "the " ++ showComponentName availableTargetComponentName + | AvailableTarget {availableTargetComponentName} <- targets' ] + ++ " will not be built because " ++ renderOptionalStanza Plural stanza + ++ " are not built by default in the current configuration (but you " + ++ "can still build them specifically)" --TODO: say how + _ -> error $ "renderBuildTargetProblem: unexpected status " + ++ show (status, mstanza) + | ((status, mstanza), targets') <- sortGroupOn groupingKey targets + ] + where + groupingKey t = + ( availableTargetStatus t + , case availableTargetStatus t of + TargetNotBuildable -> Nothing + TargetNotLocal -> Nothing + _ -> optionalStanza (availableTargetComponentName t) + ) + +------------------------------------------------------------ +-- Renderering error messages for TargetProblemNoneEnabled +-- + +-- | Several commands have a @TargetProblemNoTargets@ problem constructor. +-- This renders an error message for those cases. +-- +renderTargetProblemNoTargets :: String -> TargetSelector PackageId -> String +renderTargetProblemNoTargets verb targetSelector = + "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector + ++ " because " ++ reason targetSelector ++ ". " + ++ "Check the .cabal " + ++ plural (targetSelectorPluralPkgs targetSelector) + "file for the package and make sure that it properly declares " + "files for the packages and make sure that they properly declare " + ++ "the components that you expect." + where + reason (TargetPackage _ _ Nothing) = + "it does not contain any components at all" + reason (TargetPackage _ _ (Just kfilter)) = + "it does not contain any " ++ renderComponentKind Plural kfilter + reason (TargetAllPackages Nothing) = + "none of them contain any components at all" + reason (TargetAllPackages (Just kfilter)) = + "none of the packages contain any " + ++ renderComponentKind Plural kfilter + reason ts@TargetComponent{} = + error $ "renderTargetProblemNoTargets: " ++ show ts + reason (TargetPackageName _) = + "it does not contain any components at all" + +----------------------------------------------------------- +-- Renderering error messages for CannotPruneDependencies +-- + +renderCannotPruneDependencies :: CannotPruneDependencies -> String +renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) = + "Cannot select only the dependencies (as requested by the " + ++ "'--only-dependencies' flag), " + ++ (case pkgids of + [pkgid] -> "the package " ++ display pkgid ++ " is " + _ -> "the packages " + ++ renderListCommaAnd (map display pkgids) ++ " are ") + ++ "required by a dependency of one of the other targets." + where + -- throw away the details and just list the deps that are needed + pkgids :: [PackageId] + pkgids = nub . map packageId . concatMap snd $ brokenPackages + +{- + ++ "Syntax:\n" + ++ " - build [package]\n" + ++ " - build [package:]component\n" + ++ " - build [package:][component:]module\n" + ++ " - build [package:][component:]file\n" + ++ " where\n" + ++ " package is a package name, package dir or .cabal file\n\n" + ++ "Examples:\n" + ++ " - build foo -- package name\n" + ++ " - build tests -- component name\n" + ++ " (name of library, executable, test-suite or benchmark)\n" + ++ " - build Data.Foo -- module name\n" + ++ " - build Data/Foo.hsc -- file name\n\n" + ++ "An ambigious target can be qualified by package, component\n" + ++ "and/or component kind (lib|exe|test|bench|flib)\n" + ++ " - build foo:tests -- component qualified by package\n" + ++ " - build tests:Data.Foo -- module qualified by component\n" + ++ " - build lib:foo -- component qualified by kind" +-} diff --git a/cabal/cabal-install/Distribution/Client/CmdExec.hs b/cabal/cabal-install/Distribution/Client/CmdExec.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/CmdExec.hs @@ -0,0 +1,259 @@ +------------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Exec +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Implementation of the 'new-exec' command for running an arbitrary executable +-- in an environment suited to the part of the store built for a project. +------------------------------------------------------------------------------- + +{-# LANGUAGE RecordWildCards #-} +module Distribution.Client.CmdExec + ( execAction + , execCommand + ) where + +import Distribution.Client.DistDirLayout + ( DistDirLayout(..) + ) +import Distribution.Client.InstallPlan + ( GenericPlanPackage(..) + , toGraph + ) +import Distribution.Client.Setup + ( ConfigExFlags + , ConfigFlags(configVerbosity) + , GlobalFlags + , InstallFlags + ) +import Distribution.Client.ProjectOrchestration + ( ProjectBuildContext(..) + , runProjectPreBuildPhase + , establishProjectBaseContext + , distDirLayout + , commandLineFlagsToProjectConfig + , ProjectBaseContext(..) + ) +import Distribution.Client.ProjectPlanOutput + ( updatePostBuildProjectStatus + , createPackageEnvironment + , argsEquivalentOfGhcEnvironmentFile + , PostBuildProjectStatus + ) +import qualified Distribution.Client.ProjectPlanning as Planning +import Distribution.Client.ProjectPlanning + ( ElaboratedInstallPlan + , ElaboratedSharedConfig(..) + ) +import Distribution.Simple.Command + ( CommandUI(..) + ) +import Distribution.Simple.Program.Db + ( modifyProgramSearchPath + , requireProgram + , configuredPrograms + ) +import Distribution.Simple.Program.Find + ( ProgramSearchPathEntry(..) + ) +import Distribution.Simple.Program.Run + ( programInvocation + , runProgramInvocation + ) +import Distribution.Simple.Program.Types + ( programOverrideEnv + , programDefaultArgs + , programPath + , simpleProgram + , ConfiguredProgram + ) +import Distribution.Simple.GHC + ( getImplInfo + , GhcImplInfo(supportsPkgEnvFiles) ) +import Distribution.Simple.Setup + ( HaddockFlags + , fromFlagOrDefault + ) +import Distribution.Simple.Utils + ( die' + , info + , withTempDirectory + , wrapText + ) +import Distribution.Verbosity + ( Verbosity + , normal + ) + +import qualified Distribution.Client.CmdBuild as CmdBuild + +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) +execCommand = CommandUI + { commandName = "new-exec" + , commandSynopsis = "Give a command access to the store." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " new-exec [FLAGS] [--] COMMAND [--] [ARGS]\n" + , commandDescription = Just $ \pname -> wrapText $ + "During development it is often useful to run build tasks and perform" + ++ " one-off program executions to experiment with the behavior of build" + ++ " tools. It is convenient to run these tools in the same way " ++ pname + ++ " itself would. The `" ++ pname ++ " new-exec` command provides a way to" + ++ " do so.\n" + ++ "\n" + ++ "Compiler tools will be configured to see the same subset of the store" + ++ " that builds would see. The PATH is modified to make all executables in" + ++ " the dependency tree available (provided they have been built already)." + ++ " Commands are also rewritten in the way cabal itself would. For" + ++ " example, `" ++ pname ++ " new-exec ghc` will consult the configuration" + ++ " to choose an appropriate version of ghc and to include any" + ++ " ghc-specific flags requested." + , commandNotes = Nothing + , commandOptions = commandOptions CmdBuild.buildCommand + , commandDefaultFlags = commandDefaultFlags CmdBuild.buildCommand + } + +execAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +execAction (configFlags, configExFlags, installFlags, haddockFlags) + extraArgs globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig + + -- To set up the environment, we'd like to select the libraries in our + -- dependency tree that we've already built. So first we set up an install + -- plan, but we walk the dependency tree without first executing the plan. + buildCtx <- runProjectPreBuildPhase + verbosity + baseCtx + (\plan -> return (plan, M.empty)) + + -- We use the build status below to decide what libraries to include in the + -- compiler environment, but we don't want to actually build anything. So we + -- pass mempty to indicate that nothing happened and we just want the current + -- status. + buildStatus <- updatePostBuildProjectStatus + verbosity + (distDirLayout baseCtx) + (elaboratedPlanOriginal buildCtx) + (pkgsBuildStatus buildCtx) + mempty + + -- Some dependencies may have executables. Let's put those on the PATH. + extraPaths <- pathAdditions verbosity baseCtx buildCtx + let programDb = modifyProgramSearchPath + (map ProgramSearchPathDir extraPaths ++) + . pkgConfigCompilerProgs + . elaboratedShared + $ buildCtx + + -- Now that we have the packages, set up the environment. We accomplish this + -- by creating an environment file that selects the databases and packages we + -- computed in the previous step, and setting an environment variable to + -- point at the file. + -- In case ghc is too old to support environment files, + -- we pass the same info as arguments + let compiler = pkgConfigCompiler $ elaboratedShared buildCtx + envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler) + case extraArgs of + [] -> die' verbosity "Please specify an executable to run" + exe:args -> do + (program, _) <- requireProgram verbosity (simpleProgram exe) programDb + let argOverrides = + argsEquivalentOfGhcEnvironmentFile + compiler + (distDirLayout baseCtx) + (elaboratedPlanOriginal buildCtx) + buildStatus + programIsConfiguredCompiler = matchCompilerPath + (elaboratedShared buildCtx) + program + argOverrides' = + if envFilesSupported + || not programIsConfiguredCompiler + then [] + else argOverrides + + (if envFilesSupported + then withTempEnvFile verbosity baseCtx buildCtx buildStatus + else \f -> f []) $ \envOverrides -> do + let program' = withOverrides + envOverrides + argOverrides' + program + invocation = programInvocation program' args + runProgramInvocation verbosity invocation + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + withOverrides env args program = program + { programOverrideEnv = programOverrideEnv program ++ env + , programDefaultArgs = programDefaultArgs program ++ args} + +matchCompilerPath :: ElaboratedSharedConfig -> ConfiguredProgram -> Bool +matchCompilerPath elaboratedShared program = + programPath program + `elem` + (programPath <$> configuredCompilers) + where + configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared + +-- | Execute an action with a temporary .ghc.environment file reflecting the +-- current environment. The action takes an environment containing the env +-- variable which points ghc to the file. +withTempEnvFile :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> PostBuildProjectStatus + -> ([(String, Maybe String)] -> IO a) + -> IO a +withTempEnvFile verbosity + baseCtx + buildCtx + buildStatus + action = + withTempDirectory + verbosity + (distTempDirectory (distDirLayout baseCtx)) + "environment." + (\tmpDir -> do + envOverrides <- createPackageEnvironment + verbosity + tmpDir + (elaboratedPlanToExecute buildCtx) + (elaboratedShared buildCtx) + buildStatus + action envOverrides) + +pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath] +pathAdditions verbosity ProjectBaseContext{..}ProjectBuildContext{..} = do + info verbosity . unlines $ "Including the following directories in PATH:" + : paths + return paths + where + paths = S.toList + $ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute + +binDirectories + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> Set FilePath +binDirectories layout config = fromElaboratedInstallPlan where + fromElaboratedInstallPlan = fromGraph . toGraph + fromGraph = foldMap fromPlan + fromSrcPkg = S.fromList . Planning.binDirectories layout config + + fromPlan (PreExisting _) = mempty + fromPlan (Configured pkg) = fromSrcPkg pkg + fromPlan (Installed pkg) = fromSrcPkg pkg + 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards #-} +{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ViewPatterns #-} -- | cabal-install CLI command: freeze -- @@ -7,19 +7,19 @@ freezeAction, ) where +import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning import Distribution.Client.ProjectConfig ( ProjectConfig(..), ProjectConfigShared(..) - , commandLineFlagsToProjectConfig, writeProjectLocalFreezeConfig - , findProjectRoot ) + , writeProjectLocalFreezeConfig ) import Distribution.Client.Targets - ( UserConstraint(..) ) + ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) ) +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty(..) ) import Distribution.Solver.Types.ConstraintSource ( ConstraintSource(..) ) import Distribution.Client.DistDirLayout - ( defaultDistDirLayout, defaultCabalDirLayout ) -import Distribution.Client.Config - ( defaultCabalDir ) + ( DistDirLayout(distProjectFile) ) import qualified Distribution.Client.InstallPlan as InstallPlan @@ -29,13 +29,14 @@ ( VersionRange, thisVersion , unionVersionRanges, simplifyVersionRange ) import Distribution.PackageDescription - ( FlagAssignment ) + ( FlagAssignment, nullFlagAssignment ) import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Simple.Utils - ( die, notice ) + ( die', notice, wrapText ) import Distribution.Verbosity ( normal ) @@ -43,28 +44,53 @@ import qualified Data.Map as Map import Data.Map (Map) import Control.Monad (unless) -import System.FilePath import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) -import Distribution.Simple.Utils - ( wrapText ) import qualified Distribution.Client.Setup as Client freezeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) freezeCommand = Client.installCommand { commandName = "new-freeze", - commandSynopsis = "Freezes a Nix-local build project", + commandSynopsis = "Freeze dependencies.", commandUsage = usageAlternatives "new-freeze" [ "[FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ - "Performs dependency solving on a Nix-local build project, and" - ++ " then writes out the precise dependency configuration to cabal.project.freeze" - ++ " so that the plan is always used in subsequent builds.", + "The project configuration is frozen so that it will be reproducible " + ++ "in future.\n\n" + + ++ "The precise dependency configuration for the project is written to " + ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if " + ++ "'--project-file' is specified). This file extends the configuration " + ++ "from the 'cabal.project' file and thus is used as the project " + ++ "configuration for all other commands (such as 'new-build', " + ++ "'new-repl' etc).\n\n" + + ++ "The freeze file can be kept in source control. To make small " + ++ "adjustments it may be edited manually, or to make bigger changes " + ++ "you may wish to delete the file and re-freeze. For more control, " + ++ "one approach is to try variations using 'new-build --dry-run' with " + ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have " + ++ "a satisfactory solution to freeze it using the 'new-freeze' command " + ++ "with the same set of flags.", commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " new-freeze " - ++ " Freeze the configuration of the current project\n" + ++ " " ++ pname ++ " new-freeze\n" + ++ " Freeze the configuration of the current project\n\n" + ++ " " ++ pname ++ " new-build --dry-run --constraint=\"aeson < 1\"\n" + ++ " Check what a solution with the given constraints would look like\n" + ++ " " ++ pname ++ " new-freeze --constraint=\"aeson < 1\"\n" + ++ " Freeze a solution using the given constraints\n\n" + + ++ "Note: this command is part of the new project-based system (aka " + ++ "nix-style\nlocal builds). These features are currently in beta. " + ++ "Please see\n" + ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html " + ++ "for\ndetails and advice on what you can expect to work. If you " + ++ "encounter problems\nplease file issues at " + ++ "https://github.com/haskell/cabal/issues and if you\nhave any time " + ++ "to get involved and help with testing, fixing bugs etc then\nthat " + ++ "is very much appreciated.\n" } -- | To a first approximation, the @freeze@ command runs the first phase of @@ -76,36 +102,36 @@ -- freezeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -freezeAction (configFlags, configExFlags, installFlags, haddockFlags) +freezeAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) extraArgs globalFlags = do unless (null extraArgs) $ - die $ "'freeze' doesn't take any extra arguments: " + die' verbosity $ "'freeze' doesn't take any extra arguments: " ++ unwords extraArgs - cabalDir <- defaultCabalDir - let cabalDirLayout = defaultCabalDirLayout cabalDir - - projectRootDir <- findProjectRoot - let distDirLayout = defaultDistDirLayout projectRootDir - - let cliConfig = commandLineFlagsToProjectConfig - globalFlags configFlags configExFlags - installFlags haddockFlags - + ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages + } <- establishProjectBaseContext verbosity cliConfig - (_, elaboratedPlan, _, _) <- + (_, elaboratedPlan, _) <- rebuildInstallPlan verbosity - projectRootDir distDirLayout cabalDirLayout - cliConfig + distDirLayout cabalDirLayout + projectConfig + localPackages let freezeConfig = projectFreezeConfig elaboratedPlan - writeProjectLocalFreezeConfig projectRootDir freezeConfig + writeProjectLocalFreezeConfig distDirLayout freezeConfig notice verbosity $ - "Wrote freeze file: " ++ projectRootDir "cabal.project.freeze" + "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze" where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags @@ -147,7 +173,8 @@ versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] versionConstraints = Map.mapWithKey - (\p v -> [(UserConstraintVersion p v, ConstraintSourceFreeze)]) + (\p v -> [(UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v), + ConstraintSourceFreeze)]) versionRanges versionRanges :: Map PackageName VersionRange @@ -164,7 +191,8 @@ flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] flagConstraints = Map.mapWithKey - (\p f -> [(UserConstraintFlags p f, ConstraintSourceFreeze)]) + (\p f -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f), + ConstraintSourceFreeze)]) flagAssignments flagAssignments :: Map PackageName FlagAssignment @@ -174,7 +202,7 @@ | InstallPlan.Configured elab <- InstallPlan.toList plan , let flags = elabFlagAssignment elab pkgname = packageName elab - , not (null flags) ] + , not (nullFlagAssignment flags) ] -- As described above, remove the version constraints on local packages, -- but leave any flag constraints. @@ -200,8 +228,8 @@ else Just constraints) #endif - isVersionConstraint UserConstraintVersion{} = True - isVersionConstraint _ = False + isVersionConstraint (UserConstraint _ (PackagePropertyVersion _)) = True + isVersionConstraint _ = False localPackages :: Map PackageName () localPackages = 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 @@ -1,47 +1,70 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: haddock -- module Distribution.Client.CmdHaddock ( + -- * The @haddock@ CLI and action haddockCommand, haddockAction, + + -- * Internals exposed for testing + TargetProblem(..), + selectPackageTargets, + selectComponentTarget ) where import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectPlanning - ( PackageTarget(..) ) -import Distribution.Client.BuildTarget - ( readUserBuildTargets ) +import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) import qualified Distribution.Client.Setup as Client +import Distribution.Simple.Setup + ( HaddockFlags(..), fromFlagOrDefault, fromFlag ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) -import Distribution.Simple.Setup - ( HaddockFlags, fromFlagOrDefault ) -import Distribution.Simple.Utils - ( wrapText ) import Distribution.Verbosity - ( normal ) + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText, die' ) -import Control.Monad (unless, void) +import Control.Monad (when) -haddockCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + +haddockCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags + ,HaddockFlags) haddockCommand = Client.installCommand { commandName = "new-haddock", - commandSynopsis = "Build Haddock documentation for the current project", + commandSynopsis = "Build Haddock documentation", commandUsage = usageAlternatives "new-haddock" [ "[FLAGS] TARGET" ], commandDescription = Just $ \_ -> wrapText $ - "Build Haddock documentation for a Nix-local build project.", + "Build Haddock documentation for the specified packages within the " + ++ "project.\n\n" + + ++ "Any package in the project can be specified. If no package is " + ++ "specified, the default is to build the documentation for the package " + ++ "in the current directory. The default behaviour is to build " + ++ "documentation for the exposed modules of the library component (if " + ++ "any). This can be changed with the '--internal', '--executables', " + ++ "'--tests', '--benchmarks' or '--all' flags.\n\n" + + ++ "Currently, documentation for dependencies is NOT built. This " + ++ "behavior may change in future.\n\n" + + ++ "Additional configuration flags can be specified on the command line " + ++ "and these extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " new-haddock cname" - ++ " Build documentation for the component named cname\n" - ++ " " ++ pname ++ " new-haddock pkgname:cname" - ++ " Build documentation for the component named cname in pkgname\n" + ++ " " ++ pname ++ " new-haddock pkgname" + ++ " Build documentation for the package named pkgname\n\n" + + ++ cmdCommonHelpTextNewBuildBeta } + --TODO: [nice to have] support haddock on specific components, not just + -- whole packages and the silly --executables etc modifiers. -- | The @haddock@ command is TODO. -- @@ -50,44 +73,128 @@ -- haddockAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -haddockAction (configFlags, configExFlags, installFlags, haddockFlags) +haddockAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) targetStrings globalFlags = do - userTargets <- readUserBuildTargets targetStrings + baseCtx <- establishProjectBaseContext verbosity cliConfig + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) targetStrings + buildCtx <- - runProjectPreBuildPhase - verbosity - ( globalFlags, configFlags, configExFlags - , installFlags, haddockFlags ) - PreBuildHooks { - hookPrePlanning = \_ _ _ -> return (), - hookSelectPlanSubset = \_ -> + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity + "The haddock command does not support '--only-dependencies'." + -- When we interpret the targets on the command line, interpret them as -- haddock targets - selectTargets - verbosity - HaddockDefaultComponents - (const HaddockDefaultComponents) - userTargets - False -- onlyDependencies, always False for haddock - } + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + (selectPackageTargets haddockFlags) + selectComponentTarget + TargetProblemCommon + elaboratedPlan + targetSelectors - --TODO: Hmm, but we don't have any targets. Currently this prints what we - -- would build if we were to build everything. Could pick implicit target like "." - --TODO: should we say what's in the project (+deps) as a whole? - printPlan - verbosity - buildCtx { - buildSettings = (buildSettings buildCtx) { - buildSettingDryRun = True - } - } + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionHaddock + targets + elaboratedPlan + return (elaboratedPlan', targets) - unless (buildSettingDryRun (buildSettings buildCtx)) $ void $ - runProjectBuildPhase - verbosity - buildCtx + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags +-- | This defines what a 'TargetSelector' means for the @haddock@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @haddock@ command we select all buildable libraries. Additionally, +-- depending on the @--executables@ flag we also select all the buildable exes. +-- We do similarly for test-suites, benchmarks and foreign libs. +-- +selectPackageTargets :: HaddockFlags -> TargetSelector PackageId + -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets haddockFlags targetSelector targets + + -- If there are any buildable targets then we select those + | not (null targetsBuildable) + = Right targetsBuildable + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail (map disableNotRequested targets) + targetsBuildable = selectBuildableTargets (map disableNotRequested targets) + + -- When there's a target filter like "pkg:exes" then we do select exes, + -- but if it's just a target like "pkg" then we don't build docs for exes + -- unless they are requested by default (i.e. by using --executables) + disableNotRequested t@(AvailableTarget _ cname (TargetBuildable _ _) _) + | not (isRequested targetSelector (componentKind cname)) + = t { availableTargetStatus = TargetDisabledByUser } + disableNotRequested t = t + + isRequested (TargetPackage _ _ (Just _)) _ = True + isRequested (TargetAllPackages (Just _)) _ = True + isRequested _ LibKind = True +-- isRequested _ SubLibKind = True --TODO: what about sublibs? + isRequested _ FLibKind = fromFlag (haddockForeignLibs haddockFlags) + isRequested _ ExeKind = fromFlag (haddockExecutables haddockFlags) + isRequested _ TestKind = fromFlag (haddockTestSuites haddockFlags) + isRequested _ BenchKind = fromFlag (haddockBenchmarks haddockFlags) + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @haddock@ command we just need the basic checks on being buildable +-- etc. +-- +selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget pkgid cname subtarget = + either (Left . TargetProblemCommon) Right + . selectComponentTargetBasic pkgid cname subtarget + + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @haddock@ command. +-- +data TargetProblem = + TargetProblemCommon TargetProblemCommon + + -- | The 'TargetSelector' matches targets but none are buildable + | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + + -- | There are no targets at all + | TargetProblemNoTargets (TargetSelector PackageId) + deriving (Eq, Show) + +reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderTargetProblem + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (TargetProblemCommon problem) = + renderTargetProblemCommon "build documentation for" problem + +renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled "build documentation for" targetSelector targets + +renderTargetProblem(TargetProblemNoTargets targetSelector) = + renderTargetProblemNoTargets "build documentation for" targetSelector diff --git a/cabal/cabal-install/Distribution/Client/CmdInstall.hs b/cabal/cabal-install/Distribution/Client/CmdInstall.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/CmdInstall.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} + +-- | cabal-install CLI command: build +-- +module Distribution.Client.CmdInstall ( + -- * The @build@ CLI and action + installCommand, + installAction, + + -- * Internals exposed for testing + TargetProblem(..), + selectPackageTargets, + selectComponentTarget + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) +import qualified Distribution.Client.Setup as Client +import Distribution.Client.Types + ( PackageSpecifier(NamedPackage), UnresolvedSourcePackage ) +import Distribution.Client.ProjectPlanning.Types + ( pkgConfigCompiler ) +import Distribution.Client.ProjectConfig.Types + ( ProjectConfig, ProjectConfigBuildOnly(..) + , projectConfigLogsDir, projectConfigStoreDir, projectConfigShared + , projectConfigBuildOnly, projectConfigDistDir + , projectConfigConfigFile ) +import Distribution.Client.Config + ( defaultCabalDir ) +import Distribution.Client.ProjectConfig + ( readGlobalConfig, resolveBuildTimeSettings ) +import Distribution.Client.DistDirLayout + ( defaultDistDirLayout, distDirectory, mkCabalDirLayout + , ProjectRoot(ProjectRootImplicit), distProjectCacheDirectory + , storePackageDirectory, cabalStoreDirLayout ) +import Distribution.Client.RebuildMonad + ( runRebuild ) +import Distribution.Client.InstallSymlink + ( symlinkBinary ) +import Distribution.Simple.Setup + ( Flag(Flag), HaddockFlags, fromFlagOrDefault, flagToMaybe ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Simple.Compiler + ( compilerId ) +import Distribution.Types.PackageName + ( mkPackageName ) +import Distribution.Types.UnitId + ( UnitId ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, unUnqualComponentName ) +import Distribution.Verbosity + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText, die', withTempDirectory, createDirectoryIfMissingVerbose ) + +import qualified Data.Map as Map +import System.Directory ( getTemporaryDirectory, makeAbsolute ) +import System.FilePath ( () ) + +import qualified Distribution.Client.CmdBuild as CmdBuild + +installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +installCommand = CommandUI + { commandName = "new-install" + , commandSynopsis = "Install packages." + , commandUsage = usageAlternatives "new-install" [ "[TARGETS] [FLAGS]" ] + , commandDescription = Just $ \_ -> wrapText $ + "Installs one or more packages. This is done by installing them " + ++ "in the store and symlinking the executables in the directory " + ++ "specified by the --symlink-bindir flag (`~/.cabal/bin/` by default). " + ++ "If you want the installed executables to be available globally, " + ++ "make sure that the PATH environment variable contains that directory. " + ++ "\n\n" + ++ "If TARGET is a library, it will be added to the global environment. " + ++ "When doing this, cabal will try to build a plan that includes all " + ++ "the previously installed libraries. This is currently not implemented." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " new-install\n" + ++ " Install the package in the current directory\n" + ++ " " ++ pname ++ " new-install pkgname\n" + ++ " Install the package named pkgname (fetching it from hackage if necessary)\n" + ++ " " ++ pname ++ " new-install ./pkgfoo\n" + ++ " Install the package in the ./pkgfoo directory\n" + + ++ cmdCommonHelpTextNewBuildBeta + , commandOptions = commandOptions CmdBuild.buildCommand + , commandDefaultFlags = commandDefaultFlags CmdBuild.buildCommand + } + + +-- | The @install@ command actually serves four different needs. It installs: +-- * Nonlocal exes: +-- For example a program from hackage. The behavior is similar to the old +-- install command, except that now conflicts between separate runs of the +-- command are impossible thanks to the store. +-- Exes are installed in the store like a normal dependency, then they are +-- symlinked uin the directory specified by --symlink-bindir. +-- To do this we need a dummy projectBaseContext containing the targets as +-- estra packages and using a temporary dist directory. +-- * Nonlocal libraries (TODO see #4558) +-- * Local exes (TODO see #4558) +-- * Local libraries (TODO see #4558) +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +installAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) + targetStrings globalFlags = do + -- We never try to build tests/benchmarks for remote packages. + -- So we set them as disabled by default and error if they are explicitly + -- enabled. + when (configTests configFlags' == Flag True) $ + die' verbosity $ "--enable-tests was specified, but tests can't " + ++ "be enabled in a remote package" + when (configBenchmarks configFlags' == Flag True) $ + die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't " + ++ "be enabled in a remote package" + + -- We need a place to put a temporary dist directory + globalTmp <- getTemporaryDirectory + withTempDirectory + verbosity + globalTmp + "cabal-install." + $ \tmpDir -> do + + let packageNames = mkPackageName <$> targetStrings + packageSpecifiers = + (\pname -> NamedPackage pname []) <$> packageNames + + baseCtx <- establishDummyProjectBaseContext + verbosity + cliConfig + tmpDir + packageSpecifiers + + let targetSelectors = TargetPackageName <$> packageNames + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + -- Interpret the targets on the command line as build targets + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + elaboratedPlan'' <- + if buildSettingOnlyDeps (buildSettings baseCtx) + then either (reportCannotPruneDependencies verbosity) return $ + pruneInstallPlanToDependencies (Map.keysSet targets) + elaboratedPlan' + else return elaboratedPlan' + + return (elaboratedPlan'', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + + let compiler = pkgConfigCompiler $ elaboratedShared buildCtx + let mkPkgBinDir = ( "bin") . + storePackageDirectory + (cabalStoreDirLayout $ cabalDirLayout baseCtx) + (compilerId compiler) + + -- If there are exes, symlink them + let defaultSymlinkBindir = error "TODO: how do I get the default ~/.cabal (or ~/.local) directory? (use --symlink-bindir explicitly for now)" "bin" + symlinkBindir <- makeAbsolute $ fromFlagOrDefault defaultSymlinkBindir (Client.installSymlinkBinDir installFlags) + traverse_ (symlinkBuiltPackage mkPkgBinDir symlinkBindir) + $ Map.toList $ targetsMap buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + configFlags' = disableTestsBenchsByDefault configFlags + verbosity = fromFlagOrDefault normal (configVerbosity configFlags') + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags' configExFlags + installFlags haddockFlags + + +-- | Disables tests and benchmarks if they weren't explicitly enabled. +disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags +disableTestsBenchsByDefault configFlags = + configFlags { configTests = Flag False <> configTests configFlags + , configBenchmarks = Flag False <> configBenchmarks configFlags } + +-- | Symlink every exe from a package from the store to a given location +symlinkBuiltPackage :: (UnitId -> FilePath) -- ^ A function to get an UnitId's + -- store directory + -> FilePath -- ^ Where to put the symlink + -> ( UnitId + , [(ComponentTarget, [TargetSelector PackageId])] ) + -> IO () +symlinkBuiltPackage mkSourceBinDir destDir (pkg, components) = + traverse_ (symlinkBuiltExe (mkSourceBinDir pkg) destDir) exes + where + exes = catMaybes $ (exeMaybe . fst) <$> components + exeMaybe (ComponentTarget (CExeName exe) _) = Just exe + exeMaybe _ = Nothing + +-- | Symlink a specific exe. +symlinkBuiltExe :: FilePath -> FilePath -> UnqualComponentName -> IO Bool +symlinkBuiltExe sourceDir destDir exe = + symlinkBinary + destDir + sourceDir + exe + $ unUnqualComponentName exe + +-- | Create a dummy project context, without a .cabal or a .cabal.project file +-- (a place where to put a temporary dist directory is still needed) +establishDummyProjectBaseContext :: Verbosity + -> ProjectConfig + -> FilePath -- ^ Where to put the dist directory + -> [PackageSpecifier UnresolvedSourcePackage] -- ^ The packages to be included in the project + -> IO ProjectBaseContext +establishDummyProjectBaseContext verbosity cliConfig tmpDir localPackages = do + + cabalDir <- defaultCabalDir + + -- Create the dist directories + createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout + createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout + + globalConfig <- runRebuild "" + $ readGlobalConfig verbosity + $ projectConfigConfigFile + $ projectConfigShared cliConfig + let projectConfig = globalConfig <> cliConfig + + let ProjectConfigBuildOnly { + projectConfigLogsDir, + projectConfigStoreDir + } = projectConfigBuildOnly projectConfig + + mlogsDir = flagToMaybe projectConfigLogsDir + mstoreDir = flagToMaybe projectConfigStoreDir + cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + + buildSettings = resolveBuildTimeSettings + verbosity cabalDirLayout + projectConfig + + return ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + buildSettings + } + where + mdistDirectory = flagToMaybe + $ projectConfigDistDir + $ projectConfigShared cliConfig + projectRoot = ProjectRootImplicit tmpDir + distDirLayout = defaultDistDirLayout projectRoot + mdistDirectory + +-- | This defines what a 'TargetSelector' means for the @bench@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @build@ command select all components except non-buildable and disabled +-- tests\/benchmarks, fail if there are no such components +-- +selectPackageTargets :: TargetSelector PackageId + -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable targets then we select those + | not (null targetsBuildable) + = Right targetsBuildable + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail targets + targetsBuildable = selectBuildableTargetsWith + (buildable targetSelector) + targets + + -- When there's a target filter like "pkg:tests" then we do select tests, + -- but if it's just a target like "pkg" then we don't build tests unless + -- they are requested by default (i.e. by using --enable-tests) + buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + buildable _ _ = True + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @build@ command we just need the basic checks on being buildable etc. +-- +selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget pkgid cname subtarget = + either (Left . TargetProblemCommon) Right + . selectComponentTargetBasic pkgid cname subtarget + + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @build@ command. +-- +data TargetProblem = + TargetProblemCommon TargetProblemCommon + + -- | The 'TargetSelector' matches targets but none are buildable + | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + + -- | There are no targets at all + | TargetProblemNoTargets (TargetSelector PackageId) + deriving (Eq, Show) + +reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderTargetProblem + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (TargetProblemCommon problem) = + renderTargetProblemCommon "build" problem +renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled "build" targetSelector targets +renderTargetProblem(TargetProblemNoTargets targetSelector) = + renderTargetProblemNoTargets "build" targetSelector + +reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a +reportCannotPruneDependencies verbosity = + die' verbosity . renderCannotPruneDependencies + 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 @@ -1,50 +1,81 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: repl -- module Distribution.Client.CmdRepl ( + -- * The @repl@ CLI and action replCommand, replAction, + + -- * Internals exposed for testing + TargetProblem(..), + selectPackageTargets, + selectComponentTarget ) where import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectConfig - ( BuildTimeSettings(..) ) -import Distribution.Client.ProjectPlanning - ( PackageTarget(..) ) -import Distribution.Client.BuildTarget - ( readUserBuildTargets ) +import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) +import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Package + ( packageName ) +import Distribution.Types.ComponentName + ( componentNameString ) +import Distribution.Text + ( display ) import Distribution.Verbosity - ( normal ) + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText, die', ordNub ) +import qualified Data.Map as Map +import qualified Data.Set as Set import Control.Monad (when) -import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) -import Distribution.Simple.Utils - ( wrapText, die ) -import qualified Distribution.Client.Setup as Client replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) replCommand = Client.installCommand { commandName = "new-repl", - commandSynopsis = "Open a REPL for the current project", - commandUsage = usageAlternatives "new-repl" [ "[FLAGS] TARGET" ], + commandSynopsis = "Open an interactive session for the given component.", + commandUsage = usageAlternatives "new-repl" [ "[TARGET] [FLAGS]" ], commandDescription = Just $ \_ -> wrapText $ - "Opens a REPL for a Nix-local build project.", + "Open an interactive session for a component within the project. The " + ++ "available targets are the same as for the 'new-build' command: " + ++ "individual components within packages in the project, including " + ++ "libraries, executables, test-suites or benchmarks. Packages can " + ++ "also be specified in which case the library component in the " + ++ "package will be used, or the (first listed) executable in the " + ++ "package if there is no library.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " new-repl cname" - ++ " Open a REPL for the component named cname\n" - ++ " " ++ pname ++ " new-repl pkgname:cname" - ++ " Open a REPL for the component named cname in pkgname\n" + "Examples, open an interactive session:\n" + ++ " " ++ pname ++ " new-repl\n" + ++ " for the default component in the package in the current directory\n" + ++ " " ++ pname ++ " new-repl pkgname\n" + ++ " for the default component in the package named 'pkgname'\n" + ++ " " ++ pname ++ " new-repl ./pkgfoo\n" + ++ " for the default component in the package in the ./pkgfoo directory\n" + ++ " " ++ pname ++ " new-repl cname\n" + ++ " for the component named 'cname'\n" + ++ " " ++ pname ++ " new-repl pkgname:cname\n" + ++ " for the component 'cname' in the package 'pkgname'\n\n" + + ++ cmdCommonHelpTextNewBuildBeta } + -- | 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 -- repl target and then executes the plan. @@ -57,44 +88,205 @@ -- "Distribution.Client.ProjectOrchestration" -- replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) - -> [String] -> GlobalFlags -> IO () -replAction (configFlags, configExFlags, installFlags, haddockFlags) + -> [String] -> GlobalFlags -> IO () +replAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) targetStrings globalFlags = do - userTargets <- readUserBuildTargets targetStrings + baseCtx <- establishProjectBaseContext verbosity cliConfig + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) targetStrings + buildCtx <- - runProjectPreBuildPhase - verbosity - ( globalFlags, configFlags, configExFlags - , installFlags, haddockFlags ) - PreBuildHooks { - hookPrePlanning = \_ _ _ -> return (), + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - hookSelectPlanSubset = \buildSettings elaboratedPlan -> do - when (buildSettingOnlyDeps buildSettings) $ - die $ "The repl command does not support '--only-dependencies'. " + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ "The repl command does not support '--only-dependencies'. " ++ "You may wish to use 'build --only-dependencies' and then " ++ "use 'repl'." + -- Interpret the targets on the command line as repl targets -- (as opposed to say build or haddock targets). - selectTargets - verbosity - ReplDefaultComponent - ReplSpecificComponent - userTargets - False -- onlyDependencies, always False for repl - elaboratedPlan - --TODO: [required eventually] reject multiple targets, or at least - -- targets spanning multiple components. ie it's ok to have two - -- module/file targets in the same component, but not two that live - -- in different components. - } + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + targetSelectors - printPlan verbosity buildCtx + -- Reject multiple targets, or at least targets in different + -- components. It is ok to have two module/file targets in the + -- same component, but not two that live in different components. + when (Set.size (distinctTargetComponents targets) > 1) $ + reportTargetProblems verbosity + [TargetProblemMultipleTargets targets] - buildOutcomes <- runProjectBuildPhase verbosity buildCtx - runProjectPostBuildPhase verbosity buildCtx buildOutcomes + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionRepl + targets + elaboratedPlan + return (elaboratedPlan', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + +-- | This defines what a 'TargetSelector' means for the @repl@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For repl we select: +-- +-- * the library if there is only one and it's buildable; or +-- +-- * the exe if there is only one and it's buildable; or +-- +-- * any other buildable component. +-- +-- Fail if there are no buildable lib\/exe components, or if there are +-- multiple libs or exes. +-- +selectPackageTargets :: TargetSelector PackageId + -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there is exactly one buildable library then we select that + | [target] <- targetsLibsBuildable + = Right [target] + + -- but fail if there are multiple buildable libraries. + | not (null targetsLibsBuildable) + = Left (TargetProblemMatchesMultiple targetSelector targetsLibsBuildable') + + -- If there is exactly one buildable executable then we select that + | [target] <- targetsExesBuildable + = Right [target] + + -- but fail if there are multiple buildable executables. + | not (null targetsExesBuildable) + = Left (TargetProblemMatchesMultiple targetSelector targetsExesBuildable') + + -- If there is exactly one other target then we select that + | [target] <- targetsBuildable + = Right [target] + + -- but fail if there are multiple such targets + | not (null targetsBuildable) + = Left (TargetProblemMatchesMultiple targetSelector targetsBuildable') + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail targets + (targetsLibsBuildable, + targetsLibsBuildable') = selectBuildableTargets' + . filterTargetsKind LibKind + $ targets + (targetsExesBuildable, + targetsExesBuildable') = selectBuildableTargets' + . filterTargetsKind ExeKind + $ targets + (targetsBuildable, + targetsBuildable') = selectBuildableTargetsWith' + (isRequested targetSelector) targets + + -- When there's a target filter like "pkg:tests" then we do select tests, + -- but if it's just a target like "pkg" then we don't build tests unless + -- they are requested by default (i.e. by using --enable-tests) + isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + isRequested _ _ = True + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @repl@ command we just need the basic checks on being buildable etc. +-- +selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget pkgid cname subtarget = + either (Left . TargetProblemCommon) Right + . selectComponentTargetBasic pkgid cname subtarget + + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @repl@ command. +-- +data TargetProblem = + TargetProblemCommon TargetProblemCommon + + -- | The 'TargetSelector' matches targets but none are buildable + | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + + -- | There are no targets at all + | TargetProblemNoTargets (TargetSelector PackageId) + + -- | A single 'TargetSelector' matches multiple targets + | TargetProblemMatchesMultiple (TargetSelector PackageId) [AvailableTarget ()] + + -- | Multiple 'TargetSelector's match multiple targets + | TargetProblemMultipleTargets TargetsMap + deriving (Eq, Show) + +reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderTargetProblem + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (TargetProblemCommon problem) = + renderTargetProblemCommon "open a repl for" problem + +renderTargetProblem (TargetProblemMatchesMultiple targetSelector targets) = + "Cannot open a repl for multiple components at once. The target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " which " + ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ") + ++ renderListSemiAnd + [ "the " ++ renderComponentKind Plural ckind ++ " " ++ + renderListCommaAnd + [ maybe (display pkgname) display (componentNameString cname) + | t <- ts + , let cname = availableTargetComponentName t + pkgname = packageName (availableTargetPackageId t) + ] + | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets + ] + ++ ".\n\n" ++ explanationSingleComponentLimitation + where + availableTargetComponentKind = componentKind + . availableTargetComponentName + +renderTargetProblem (TargetProblemMultipleTargets selectorMap) = + "Cannot open a repl for multiple components at once. The targets " + ++ renderListCommaAnd + [ "'" ++ showTargetSelector ts ++ "'" + | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] + ++ " refer to different components." + ++ ".\n\n" ++ explanationSingleComponentLimitation + +renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled "open a repl for" targetSelector targets + +renderTargetProblem (TargetProblemNoTargets targetSelector) = + renderTargetProblemNoTargets "open a repl for" targetSelector + + +explanationSingleComponentLimitation :: String +explanationSingleComponentLimitation = + "The reason for this limitation is that current versions of ghci do not " + ++ "support loading multiple components as source. Load just one component " + ++ "and when you make changes to a dependent component then quit and reload." diff --git a/cabal/cabal-install/Distribution/Client/CmdRun.hs b/cabal/cabal-install/Distribution/Client/CmdRun.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/CmdRun.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} + +-- | cabal-install CLI command: run +-- +module Distribution.Client.CmdRun ( + -- * The @run@ CLI and action + runCommand, + runAction, + + -- * Internals exposed for testing + TargetProblem(..), + selectPackageTargets, + selectComponentTarget + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) +import qualified Distribution.Client.Setup as Client +import Distribution.Simple.Setup + ( HaddockFlags, fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Types.ComponentName + ( componentNameString ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText, die', ordNub, info ) +import Distribution.Client.ProjectPlanning + ( ElaboratedConfiguredPackage(..), BuildStyle(..) + , ElaboratedInstallPlan, binDirectoryFor ) +import Distribution.Client.InstallPlan + ( toList, foldPlanPackage ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, unUnqualComponentName ) +import Distribution.Types.PackageDescription + ( PackageDescription(dataDir) ) +import Distribution.Simple.Program.Run + ( runProgramInvocation, ProgramInvocation(..), + emptyProgramInvocation ) +import Distribution.Simple.Build.PathsModule + ( pkgPathEnvVar ) +import Distribution.Types.UnitId + ( UnitId ) +import Distribution.Client.Types + ( PackageLocation(..) ) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import System.FilePath + ( () ) + + +runCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +runCommand = Client.installCommand { + commandName = "new-run", + commandSynopsis = "Run an executable.", + commandUsage = usageAlternatives "new-run" + [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ], + commandDescription = Just $ \pname -> wrapText $ + "Runs the specified executable, first ensuring it is up to date.\n\n" + + ++ "Any executable in any package in the project can be specified. " + ++ "A package can be specified if contains just one executable. " + ++ "The default is to use the package in the current directory if it " + ++ "contains just one executable.\n\n" + + ++ "Extra arguments can be passed to the program, but use '--' to " + ++ "separate arguments for the program from arguments for " ++ pname + ++ ". The executable is run in an environment where it can find its " + ++ "data files inplace in the build tree.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " new-run\n" + ++ " Run the executable in the package in the current directory\n" + ++ " " ++ pname ++ " new-run foo-tool\n" + ++ " Run the named executable (in any package in the project)\n" + ++ " " ++ pname ++ " new-run pkgfoo:foo-tool\n" + ++ " Run the executable 'foo-tool' in the package 'pkgfoo'\n" + ++ " " ++ pname ++ " new-run foo -O2 -- dothing --fooflag\n" + ++ " Build with '-O2' and run the program, passing it extra arguments.\n\n" + + ++ cmdCommonHelpTextNewBuildBeta + } + + +-- | The @build@ command does a lot. It brings the install plan up to date, +-- selects that part of the plan needed by the given or implicit targets and +-- then executes the plan. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +runAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +runAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) + targetStrings globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) + (take 1 targetStrings) -- Drop the exe's args. + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ + "The run command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'run'." + + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + targetSelectors + + -- Reject multiple targets, or at least targets in different + -- components. It is ok to have two module/file targets in the + -- same component, but not two that live in different components. + -- + -- Note that we discard the target and return the whole 'TargetsMap', + -- so this check will be repeated (and must succeed) after + -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. + _ <- singleExeOrElse + (reportTargetProblems + verbosity + [TargetProblemMultipleTargets targets]) + targets + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) + + (selectedUnitId, selectedComponent) <- + -- Slight duplication with 'runProjectPreBuildPhase'. + singleExeOrElse + (die' verbosity $ "No or multiple targets given, but the run " + ++ "phase has been reached. This is a bug.") + $ targetsMap buildCtx + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + + + let elaboratedPlan = elaboratedPlanToExecute buildCtx + matchingElaboratedConfiguredPackages = + matchingPackagesByUnitId + selectedUnitId + elaboratedPlan + + let exeName = unUnqualComponentName selectedComponent + + -- In the common case, we expect @matchingElaboratedConfiguredPackages@ + -- to consist of a single element that provides a single way of building + -- an appropriately-named executable. In that case we take that + -- package and continue. + -- + -- However, multiple packages/components could provide that + -- executable, or it's possible we don't find the executable anywhere + -- in the build plan. I suppose in principle it's also possible that + -- a single package provides an executable in two different ways, + -- though that's probably a bug if. Anyway it's a good lint to report + -- an error in all of these cases, even if some seem like they + -- shouldn't happen. + pkg <- case matchingElaboratedConfiguredPackages of + [] -> die' verbosity $ "Unknown executable " + ++ exeName + ++ " in package " + ++ display selectedUnitId + [elabPkg] -> do + info verbosity $ "Selecting " + ++ display selectedUnitId + ++ " to supply " ++ exeName + return elabPkg + elabPkgs -> die' verbosity + $ "Multiple matching executables found matching " + ++ exeName + ++ ":\n" + ++ unlines (fmap (\p -> " - in package " ++ display (elabUnitId p)) elabPkgs) + let exePath = binDirectoryFor (distDirLayout baseCtx) + (elaboratedShared buildCtx) + pkg + exeName + exeName + let args = drop 1 targetStrings + runProgramInvocation + verbosity + emptyProgramInvocation { + progInvokePath = exePath, + progInvokeArgs = args, + progInvokeEnv = dataDirsEnvironmentForPlan elaboratedPlan + } + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + + +-- | Construct the environment needed for the data files to work. +-- This consists of a separate @*_datadir@ variable for each +-- inplace package in the plan. +dataDirsEnvironmentForPlan :: ElaboratedInstallPlan + -> [(String, Maybe FilePath)] +dataDirsEnvironmentForPlan = catMaybes + . fmap (foldPlanPackage + (const Nothing) + dataDirEnvVarForPackage) + . toList + +-- | Construct an environment variable that points +-- the package's datadir to its correct location. +-- This might be: +-- * 'Just' the package's source directory plus the data subdirectory +-- for inplace packages. +-- * 'Nothing' for packages installed in the store (the path was +-- already included in the package at install/build time). +-- * The other cases are not handled yet. See below. +dataDirEnvVarForPackage :: ElaboratedConfiguredPackage + -> Maybe (String, Maybe FilePath) +dataDirEnvVarForPackage pkg = + case (elabBuildStyle pkg, elabPkgSourceLocation pkg) + of (BuildAndInstall, _) -> Nothing + (BuildInplaceOnly, LocalUnpackedPackage path) -> Just + (pkgPathEnvVar (elabPkgDescription pkg) "datadir", + Just $ path dataDir (elabPkgDescription pkg)) + -- TODO: handle the other cases for PackageLocation. + -- We will only need this when we add support for + -- remote/local tarballs. + (BuildInplaceOnly, _) -> Nothing + +singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) +singleExeOrElse action targetsMap = + case Set.toList . distinctTargetComponents $ targetsMap + of [(unitId, CExeName component)] -> return (unitId, component) + _ -> action + +-- | Filter the 'ElaboratedInstallPlan' keeping only the +-- 'ElaboratedConfiguredPackage's that match the specified +-- 'UnitId'. +matchingPackagesByUnitId :: UnitId + -> ElaboratedInstallPlan + -> [ElaboratedConfiguredPackage] +matchingPackagesByUnitId uid = + catMaybes + . fmap (foldPlanPackage + (const Nothing) + (\x -> if elabUnitId x == uid + then Just x + else Nothing)) + . toList + +-- | This defines what a 'TargetSelector' means for the @run@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @run@ command we select the exe if there is only one and it's +-- buildable. Fail if there are no or multiple buildable exe components. +-- +selectPackageTargets :: TargetSelector PackageId + -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there is exactly one buildable executable then we select that + | [target] <- targetsExesBuildable + = Right [target] + + -- but fail if there are multiple buildable executables. + | not (null targetsExesBuildable) + = Left (TargetProblemMatchesMultiple targetSelector targetsExesBuildable') + + -- If there are executables but none are buildable then we report those + | not (null targetsExes) + = Left (TargetProblemNoneEnabled targetSelector targetsExes) + + -- If there are no executables but some other targets then we report that + | not (null targets) + = Left (TargetProblemNoExes targetSelector) + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + (targetsExesBuildable, + targetsExesBuildable') = selectBuildableTargets' + . filterTargetsKind ExeKind + $ targets + + targetsExes = forgetTargetsDetail + . filterTargetsKind ExeKind + $ targets + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @run@ command we just need to check it is a executable, in addition +-- to the basic checks on being buildable etc. +-- +selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget pkgid cname subtarget@WholeComponent t + | CExeName _ <- availableTargetComponentName t + = either (Left . TargetProblemCommon) return $ + selectComponentTargetBasic pkgid cname subtarget t + | otherwise + = Left (TargetProblemComponentNotExe pkgid cname) + +selectComponentTarget pkgid cname subtarget _ + = Left (TargetProblemIsSubComponent pkgid cname subtarget) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @run@ command. +-- +data TargetProblem = + TargetProblemCommon TargetProblemCommon + -- | The 'TargetSelector' matches targets but none are buildable + | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + + -- | There are no targets at all + | TargetProblemNoTargets (TargetSelector PackageId) + + -- | The 'TargetSelector' matches targets but no executables + | TargetProblemNoExes (TargetSelector PackageId) + + -- | A single 'TargetSelector' matches multiple targets + | TargetProblemMatchesMultiple (TargetSelector PackageId) [AvailableTarget ()] + + -- | Multiple 'TargetSelector's match multiple targets + | TargetProblemMultipleTargets TargetsMap + + -- | The 'TargetSelector' refers to a component that is not an executable + | TargetProblemComponentNotExe PackageId ComponentName + + -- | Asking to run an individual file or module is not supported + | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget + deriving (Eq, Show) + +reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderTargetProblem + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (TargetProblemCommon problem) = + renderTargetProblemCommon "run" problem + +renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled "run" targetSelector targets + +renderTargetProblem (TargetProblemNoExes targetSelector) = + "Cannot run the target '" ++ showTargetSelector targetSelector + ++ "' which refers to " ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any executables." + +renderTargetProblem (TargetProblemNoTargets targetSelector) = + case targetSelectorFilter targetSelector of + Just kind | kind /= ExeKind + -> "The run command is for running executables, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + + _ -> renderTargetProblemNoTargets "run" targetSelector + +renderTargetProblem (TargetProblemMatchesMultiple targetSelector targets) = + "The run command is for running a single executable at once. The target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " which includes the executables " + ++ renderListCommaAnd + [ display name + | cname@CExeName{} <- map availableTargetComponentName targets + , let Just name = componentNameString cname + ] + ++ "." + +renderTargetProblem (TargetProblemMultipleTargets selectorMap) = + "The run command is for running a single executable at once. The targets " + ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" + | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ] + ++ " refer to different executables." + +renderTargetProblem (TargetProblemComponentNotExe pkgid cname) = + "The run command is for running executables, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " from the package " + ++ display pkgid ++ "." + where + targetSelector = TargetComponent pkgid cname WholeComponent + +renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) = + "The run command can only run an executable as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + where + targetSelector = TargetComponent pkgid cname subtarget diff --git a/cabal/cabal-install/Distribution/Client/CmdTest.hs b/cabal/cabal-install/Distribution/Client/CmdTest.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/CmdTest.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} + +-- | cabal-install CLI command: test +-- +module Distribution.Client.CmdTest ( + -- * The @test@ CLI and action + testCommand, + testAction, + + -- * Internals exposed for testing + TargetProblem(..), + selectPackageTargets, + selectComponentTarget + ) where + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , applyFlagDefaults ) +import qualified Distribution.Client.Setup as Client +import Distribution.Simple.Setup + ( HaddockFlags, fromFlagOrDefault ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText, die' ) + +import Control.Monad (when) + + +testCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +testCommand = Client.installCommand { + commandName = "new-test", + commandSynopsis = "Run test-suites", + commandUsage = usageAlternatives "new-test" [ "[TARGETS] [FLAGS]" ], + commandDescription = Just $ \_ -> wrapText $ + "Runs the specified test-suites, first ensuring they are up to " + ++ "date.\n\n" + + ++ "Any test-suite in any package in the project can be specified. " + ++ "A package can be specified in which case all the test-suites in the " + ++ "package are run. The default is to run all the test-suites in the " + ++ "package in the current directory.\n\n" + + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " new-test\n" + ++ " Run all the test-suites in the package in the current directory\n" + ++ " " ++ pname ++ " new-test pkgname\n" + ++ " Run all the test-suites in the package named pkgname\n" + ++ " " ++ pname ++ " new-test cname\n" + ++ " Run the test-suite named cname\n" + ++ " " ++ pname ++ " new-test cname --enable-coverage\n" + ++ " Run the test-suite built with code coverage (including local libs used)\n\n" + + ++ cmdCommonHelpTextNewBuildBeta + } + + +-- | The @test@ 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 +-- test target(s) and then executes the plan. +-- +-- Compared to @build@ the difference is that there's also test targets +-- which are ephemeral. +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +testAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +testAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) + targetStrings globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) targetStrings + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ + "The test command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'test'." + + -- Interpret the targets on the command line as test targets + -- (as opposed to say build or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionTest + targets + elaboratedPlan + return (elaboratedPlan', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + +-- | This defines what a 'TargetSelector' means for the @test@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @test@ command we select all buildable test-suites, +-- or fail if there are no test-suites or no buildable test-suites. +-- +selectPackageTargets :: TargetSelector PackageId + -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable test-suite targets then we select those + | not (null targetsTestsBuildable) + = Right targetsTestsBuildable + + -- If there are test-suites but none are buildable then we report those + | not (null targetsTests) + = Left (TargetProblemNoneEnabled targetSelector targetsTests) + + -- If there are no test-suite but some other targets then we report that + | not (null targets) + = Left (TargetProblemNoTests targetSelector) + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targetsTestsBuildable = selectBuildableTargets + . filterTargetsKind TestKind + $ targets + + targetsTests = forgetTargetsDetail + . filterTargetsKind TestKind + $ targets + + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @test@ command we just need to check it is a test-suite, in addition +-- to the basic checks on being buildable etc. +-- +selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget pkgid cname subtarget@WholeComponent t + | CTestName _ <- availableTargetComponentName t + = either (Left . TargetProblemCommon) return $ + selectComponentTargetBasic pkgid cname subtarget t + | otherwise + = Left (TargetProblemComponentNotTest pkgid cname) + +selectComponentTarget pkgid cname subtarget _ + = Left (TargetProblemIsSubComponent pkgid cname subtarget) + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @test@ command. +-- +data TargetProblem = + TargetProblemCommon TargetProblemCommon + + -- | The 'TargetSelector' matches targets but none are buildable + | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + + -- | There are no targets at all + | TargetProblemNoTargets (TargetSelector PackageId) + + -- | The 'TargetSelector' matches targets but no test-suites + | TargetProblemNoTests (TargetSelector PackageId) + + -- | The 'TargetSelector' refers to a component that is not a test-suite + | TargetProblemComponentNotTest PackageId ComponentName + + -- | Asking to test an individual file or module is not supported + | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget + deriving (Eq, Show) + +reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderTargetProblem + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (TargetProblemCommon problem) = + renderTargetProblemCommon "run" problem + +renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled "test" targetSelector targets + +renderTargetProblem (TargetProblemNoTests targetSelector) = + "Cannot run tests for the target '" ++ showTargetSelector targetSelector + ++ "' which refers to " ++ renderTargetSelector targetSelector + ++ " because " + ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" + ++ " not contain any test suites." + +renderTargetProblem (TargetProblemNoTargets targetSelector) = + case targetSelectorFilter targetSelector of + Just kind | kind /= TestKind + -> "The test command is for running test suites, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + + _ -> renderTargetProblemNoTargets "test" targetSelector + +renderTargetProblem (TargetProblemComponentNotTest pkgid cname) = + "The test command is for running test suites, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ " from the package " + ++ display pkgid ++ "." + where + targetSelector = TargetComponent pkgid cname WholeComponent + +renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) = + "The test command can only run test suites as a whole, " + ++ "not files or modules within them, but the target '" + ++ showTargetSelector targetSelector ++ "' refers to " + ++ renderTargetSelector targetSelector ++ "." + where + targetSelector = TargetComponent pkgid cname subtarget diff --git a/cabal/cabal-install/Distribution/Client/CmdUpdate.hs b/cabal/cabal-install/Distribution/Client/CmdUpdate.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/CmdUpdate.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ViewPatterns, TupleSections #-} + +-- | cabal-install CLI command: update +-- +module Distribution.Client.CmdUpdate ( + updateCommand, + updateAction, + ) where + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectConfig + ( ProjectConfig(..) + , projectConfigWithSolverRepoContext ) +import Distribution.Client.Types + ( Repo(..), RemoteRepo(..), isRepoRemote ) +import Distribution.Client.HttpUtils + ( DownloadResult(..) ) +import Distribution.Client.FetchUtils + ( downloadIndex ) +import Distribution.Client.JobControl + ( newParallelJobControl, spawnJob, collectJob ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags, UpdateFlags + , applyFlagDefaults, defaultUpdateFlags, RepoContext(..) ) +import Distribution.Simple.Setup + ( HaddockFlags, fromFlagOrDefault ) +import Distribution.Simple.Utils + ( die', notice, wrapText, writeFileAtomic, noticeNoWrap, intercalate ) +import Distribution.Verbosity + ( Verbosity, normal, lessVerbose ) +import Distribution.Client.IndexUtils.Timestamp +import Distribution.Client.IndexUtils + ( updateRepoIndexCache, Index(..), writeIndexTimestamp + , currentIndexTimestamp ) +import Distribution.Text + ( Text(..), display, simpleParse ) + +import Data.Maybe (fromJust) +import qualified Distribution.Compat.ReadP as ReadP +import qualified Text.PrettyPrint as Disp + +import Control.Monad (unless, when) +import qualified Data.ByteString.Lazy as BS +import Distribution.Client.GZipUtils (maybeDecompress) +import System.FilePath (dropExtension) +import Data.Time (getCurrentTime) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import qualified Distribution.Client.Setup as Client + +import qualified Hackage.Security.Client as Sec + +updateCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +updateCommand = Client.installCommand { + commandName = "new-update", + commandSynopsis = "Updates list of known packages.", + commandUsage = usageAlternatives "new-update" [ "[FLAGS] [REPOS]" ], + commandDescription = Just $ \_ -> wrapText $ + "For all known remote repositories, download the package list.", + commandNotes = Just $ \pname -> + "REPO has the format [,] where index-state follows\n" + ++ "the same format and syntax that is supported by the --index-state flag.\n\n" + ++ "Examples:\n" + ++ " " ++ pname ++ " new-update\n" + ++ " Download the package list for all known remote repositories.\n\n" + ++ " " ++ pname ++ " new-update hackage.haskell.org,@1474732068\n" + ++ " " ++ pname ++ " new-update hackage.haskell.org,2016-09-24T17:47:48Z\n" + ++ " " ++ pname ++ " new-update hackage.haskell.org,HEAD\n" + ++ " " ++ pname ++ " new-update hackage.haskell.org\n" + ++ " Download hackage.haskell.org at a specific index state.\n\n" + ++ " " ++ pname ++ " new update hackage.haskell.org head.hackage\n" + ++ " Download hackage.haskell.org and head.hackage\n" + ++ " head.hackage must be a known repo-id. E.g. from\n" + ++ " your cabal.project(.local) file.\n\n" + ++ "Note: this command is part of the new project-based system (aka " + ++ "nix-style\nlocal builds). These features are currently in beta. " + ++ "Please see\n" + ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html " + ++ "for\ndetails and advice on what you can expect to work. If you " + ++ "encounter problems\nplease file issues at " + ++ "https://github.com/haskell/cabal/issues and if you\nhave any time " + ++ "to get involved and help with testing, fixing bugs etc then\nthat " + ++ "is very much appreciated.\n" + } + +data UpdateRequest = UpdateRequest + { _updateRequestRepoName :: String + , _updateRequestRepoState :: IndexState + } deriving (Show) + +instance Text UpdateRequest where + disp (UpdateRequest n s) = Disp.text n Disp.<> Disp.char ',' Disp.<> disp s + parse = parseWithState ReadP.+++ parseHEAD + where parseWithState = do + name <- ReadP.many1 (ReadP.satisfy (\c -> c /= ',')) + _ <- ReadP.char ',' + state <- parse + return (UpdateRequest name state) + parseHEAD = do + name <- ReadP.manyTill (ReadP.satisfy (\c -> c /= ',')) ReadP.eof + return (UpdateRequest name IndexStateHead) + +updateAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +updateAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) + extraArgs globalFlags = do + + ProjectBaseContext { + projectConfig + } <- establishProjectBaseContext verbosity cliConfig + + projectConfigWithSolverRepoContext verbosity (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig) + $ \repoCtxt -> do + let repos = filter isRepoRemote $ repoContextRepos repoCtxt + repoName = remoteRepoName . repoRemote + parseArg :: String -> IO UpdateRequest + parseArg s = case simpleParse s of + Just r -> return r + Nothing -> die' verbosity $ "'new-update' unable to parse repo: \"" ++ s ++ "\"" + updateRepoRequests <- mapM parseArg extraArgs + + unless (null updateRepoRequests) $ do + let remoteRepoNames = map repoName repos + unknownRepos = [r | (UpdateRequest r _) <- updateRepoRequests + , not (r `elem` remoteRepoNames)] + unless (null unknownRepos) $ + die' verbosity $ "'new-update' repo(s): \"" ++ intercalate "\", \"" unknownRepos + ++ "\" can not be found in known remote repo(s): " ++ intercalate ", " remoteRepoNames + + let reposToUpdate :: [(Repo, IndexState)] + reposToUpdate = case updateRepoRequests of + -- if we are not given any speicifc repository. Update all repositories to + -- HEAD. + [] -> map (,IndexStateHead) repos + updateRequests -> let repoMap = [(repoName r, r) | r <- repos] + lookup' k = fromJust (lookup k repoMap) + in [(lookup' name, state) | (UpdateRequest name state) <- updateRequests] + + case reposToUpdate of + [] -> return () + [(remoteRepo, _)] -> + notice verbosity $ "Downloading the latest package list from " + ++ repoName remoteRepo + _ -> notice verbosity . unlines + $ "Downloading the latest package lists from: " + : map (("- " ++) . repoName . fst) reposToUpdate + + jobCtrl <- newParallelJobControl (length reposToUpdate) + mapM_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt) reposToUpdate + mapM_ (\_ -> collectJob jobCtrl) reposToUpdate + + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + +updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState) -> IO () +updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do + transport <- repoContextGetTransport repoCtxt + case repo of + RepoLocal{..} -> return () + RepoRemote{..} -> do + downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir + case downloadResult of + FileAlreadyInCache -> return () + FileDownloaded indexPath -> do + writeFileAtomic (dropExtension indexPath) . maybeDecompress + =<< BS.readFile indexPath + updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) + RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do + let index = RepoIndex repoCtxt repo + -- NB: This may be a nullTimestamp if we've never updated before + current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo + -- NB: always update the timestamp, even if we didn't actually + -- download anything + writeIndexTimestamp index indexState + ce <- if repoContextIgnoreExpiry repoCtxt + then Just `fmap` getCurrentTime + else return Nothing + updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce + -- Update cabal's internal index as well so that it's not out of sync + -- (If all access to the cache goes through hackage-security this can go) + case updated of + Sec.NoUpdates -> + return () + Sec.HasUpdates -> + updateRepoIndexCache verbosity index + -- TODO: This will print multiple times if there are multiple + -- repositories: main problem is we don't have a way of updating + -- a specific repo. Once we implement that, update this. + when (current_ts /= nullTimestamp) $ + noticeNoWrap verbosity $ + "To revert to previous state run:\n" ++ + " cabal new-update '" ++ remoteRepoName (repoRemote repo) ++ "," ++ display current_ts ++ "'\n" + diff --git a/cabal/cabal-install/Distribution/Client/Compat/FileLock.hsc b/cabal/cabal-install/Distribution/Client/Compat/FileLock.hsc new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Compat/FileLock.hsc @@ -0,0 +1,201 @@ +{-# 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/Compat/FilePerms.hs b/cabal/cabal-install/Distribution/Client/Compat/FilePerms.hs --- a/cabal/cabal-install/Distribution/Client/Compat/FilePerms.hs +++ b/cabal/cabal-install/Distribution/Client/Compat/FilePerms.hs @@ -12,9 +12,8 @@ import System.Posix.Internals ( c_chmod ) import Foreign.C - ( withCString ) -import Foreign.C - ( throwErrnoPathIfMinus1_ ) + ( withCString + , throwErrnoPathIfMinus1_ ) #else import System.Win32.File (setFileAttributes, fILE_ATTRIBUTE_HIDDEN) #endif /* mingw32_HOST_OS */ diff --git a/cabal/cabal-install/Distribution/Client/Compat/Prelude.hs b/cabal/cabal-install/Distribution/Client/Compat/Prelude.hs --- a/cabal/cabal-install/Distribution/Client/Compat/Prelude.hs +++ b/cabal/cabal-install/Distribution/Client/Compat/Prelude.hs @@ -27,7 +27,7 @@ #endif #if !MIN_VERSION_base(4,6,0) --- | An implementation of readMaybe, for compatability with older base versions. +-- | An implementation of readMaybe, for compatibility with older base versions. readMaybe :: Read a => String -> Maybe a readMaybe s = case reads s of [(x,"")] -> Just x diff --git a/cabal/cabal-install/Distribution/Client/Compat/Semaphore.hs b/cabal/cabal-install/Distribution/Client/Compat/Semaphore.hs --- a/cabal/cabal-install/Distribution/Client/Compat/Semaphore.hs +++ b/cabal/cabal-install/Distribution/Client/Compat/Semaphore.hs @@ -10,7 +10,7 @@ import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry, writeTVar) import Control.Exception (mask_, onException) -import Control.Monad (join, when) +import Control.Monad (join, unless) import Data.Typeable (Typeable) -- | 'QSem' is a quantity semaphore in which the resource is aqcuired @@ -57,7 +57,7 @@ flip onException (wake s t) $ atomically $ do b <- readTVar t - when (not b) retry + unless b retry wake :: QSem -> TVar Bool -> IO () 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 @@ -15,6 +15,7 @@ -- downloaded packages. ----------------------------------------------------------------------------- module Distribution.Client.Config ( + addInfoForKnownRepos, SavedConfig(..), loadConfig, getConfigFilePath, @@ -46,7 +47,9 @@ ) where import Distribution.Client.Types - ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo ) + ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo + , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps + ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.Setup @@ -63,7 +66,6 @@ ( DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Setup ( ConfigFlags(..), configureOptions, defaultConfigFlags - , AllowNewer(..), AllowOlder(..), RelaxDeps(..) , HaddockFlags(..), haddockOptions, defaultHaddockFlags , installDirsOptions, optionDistPref , programDbPaths', programDbOptions @@ -92,7 +94,7 @@ import Distribution.Simple.Program ( defaultProgramDb ) import Distribution.Simple.Utils - ( die, notice, warn, lowercase, cabalVersion ) + ( die', notice, warn, lowercase, cabalVersion ) import Distribution.Compiler ( CompilerFlavor(..), defaultCompilerFlavor ) import Distribution.Verbosity @@ -101,7 +103,7 @@ import Distribution.Solver.Types.ConstraintSource import Data.List - ( partition, find, foldl' ) + ( partition, find, foldl', nubBy ) import Data.Maybe ( fromMaybe ) import Control.Monad @@ -136,8 +138,6 @@ import qualified Data.Map as M import Data.Function ( on ) -import Data.List - ( nubBy ) import GHC.Generics ( Generic ) -- @@ -206,6 +206,12 @@ in case b' of [] -> a' _ -> b' + lastNonMempty' :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a + lastNonMempty' field subfield = + let a' = subfield . field $ a + b' = subfield . field $ b + in if b' == mempty then a' else b' + lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a) -> NubList a lastNonEmptyNL' field subfield = @@ -228,7 +234,9 @@ globalRequireSandbox = combine globalRequireSandbox, globalIgnoreSandbox = combine globalIgnoreSandbox, globalIgnoreExpiry = combine globalIgnoreExpiry, - globalHttpTransport = combine globalHttpTransport + globalHttpTransport = combine globalHttpTransport, + globalNix = combine globalNix, + globalStoreDir = combine globalStoreDir } where combine = combine' savedGlobalFlags @@ -244,6 +252,7 @@ installIndependentGoals = combine installIndependentGoals, installShadowPkgs = combine installShadowPkgs, installStrongFlags = combine installStrongFlags, + installAllowBootLibInstalls = combine installAllowBootLibInstalls, installReinstall = combine installReinstall, installAvoidReinstalls = combine installAvoidReinstalls, installOverrideReinstall = combine installOverrideReinstall, @@ -257,11 +266,13 @@ installBuildReports = combine installBuildReports, installReportPlanningFailure = combine installReportPlanningFailure, installSymlinkBinDir = combine installSymlinkBinDir, + installPerComponent = combine installPerComponent, installOneShot = combine installOneShot, installNumJobs = combine installNumJobs, installKeepGoing = combine installKeepGoing, installRunTests = combine installRunTests, - installOfflineMode = combine installOfflineMode + installOfflineMode = combine installOfflineMode, + installProjectFileName = combine installProjectFileName } where combine = combine' savedInstallFlags @@ -283,6 +294,7 @@ configProfLib = combine configProfLib, configProf = combine configProf, configSharedLib = combine configSharedLib, + configStaticLib = combine configStaticLib, configDynExe = combine configDynExe, configProfExe = combine configProfExe, configProfDetail = combine configProfDetail, @@ -304,6 +316,7 @@ configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs, -- TODO: NubListify configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs, + configDeterministic = combine configDeterministic, configIPID = combine configIPID, configCID = combine configCID, configDistPref = combine configDistPref, @@ -313,6 +326,7 @@ -- TODO: NubListify configPackageDBs = lastNonEmpty configPackageDBs, configGHCiLib = combine configGHCiLib, + configSplitSections = combine configSplitSections, configSplitObjs = combine configSplitObjs, configStripExes = combine configStripExes, configStripLibs = combine configStripLibs, @@ -321,7 +335,7 @@ -- TODO: NubListify configDependencies = lastNonEmpty configDependencies, -- TODO: NubListify - configConfigurationsFlags = lastNonEmpty configConfigurationsFlags, + configConfigurationsFlags = lastNonMempty configConfigurationsFlags, configTests = combine configTests, configBenchmarks = combine configBenchmarks, configCoverage = combine configCoverage, @@ -329,15 +343,13 @@ configExactConfiguration = combine configExactConfiguration, configFlagError = combine configFlagError, configRelocatable = combine configRelocatable, - configAllowOlder = combineMonoid savedConfigureFlags - configAllowOlder, - configAllowNewer = combineMonoid savedConfigureFlags - configAllowNewer + configUseResponseFiles = combine configUseResponseFiles } where combine = combine' savedConfigureFlags lastNonEmpty = lastNonEmpty' savedConfigureFlags lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags + lastNonMempty = lastNonMempty' savedConfigureFlags combinedSavedConfigureExFlags = ConfigExFlags { configCabalVersion = combine configCabalVersion, @@ -345,7 +357,9 @@ configExConstraints = lastNonEmpty configExConstraints, -- TODO: NubListify configPreferences = lastNonEmpty configPreferences, - configSolver = combine configSolver + configSolver = combine configSolver, + configAllowNewer = combineMonoid savedConfigureExFlags configAllowNewer, + configAllowOlder = combineMonoid savedConfigureExFlags configAllowOlder } where combine = combine' savedConfigureExFlags @@ -417,6 +431,7 @@ baseSavedConfig :: IO SavedConfig baseSavedConfig = do userPrefix <- defaultCabalDir + cacheDir <- defaultCacheDir logsDir <- defaultLogsDir worldFile <- defaultWorldFile return mempty { @@ -429,6 +444,7 @@ prefix = toFlag (toPathTemplate userPrefix) }, savedGlobalFlags = mempty { + globalCacheDir = toFlag cacheDir, globalLogsDir = toFlag logsDir, globalWorldFile = toFlag worldFile } @@ -612,7 +628,7 @@ return conf Just (ParseFailed err) -> do let (line, msg) = locatedErrorMsg err - die $ + die' verbosity $ "Error parsing config file " ++ configFile ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg @@ -700,11 +716,12 @@ globalRemoteRepos = toNubList [defaultRemoteRepo] }, savedInstallFlags = defaultInstallFlags, - savedConfigureExFlags = defaultConfigExFlags, + savedConfigureExFlags = defaultConfigExFlags { + configAllowNewer = Just (AllowNewer mempty), + configAllowOlder = Just (AllowOlder mempty) + }, savedConfigureFlags = (defaultConfigFlags defaultProgramDb) { - configUserInstall = toFlag defaultUserInstall, - configAllowNewer = Just (AllowNewer RelaxDepsNone), - configAllowOlder = Just (AllowOlder RelaxDepsNone) + configUserInstall = toFlag defaultUserInstall }, savedUserInstallDirs = fmap toFlag userInstallDirs, savedGlobalInstallDirs = fmap toFlag globalInstallDirs, @@ -747,16 +764,7 @@ [simpleField "compiler" (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse) configHcFlavor (\v flags -> flags { configHcFlavor = 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 }) + -- TODO: The following is a temporary fix. The "optimization" -- and "debug-info" fields are OptArg, and viewAsFieldDescr -- fails on that. Instead of a hand-written hackaged parser @@ -813,7 +821,18 @@ ++ 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 }) + ] ++ toSavedConfig liftInstallFlag (installOptions ParseArgs) @@ -856,12 +875,12 @@ optional = Parse.option mempty . fmap toFlag - showRelaxDeps Nothing = mempty - showRelaxDeps (Just RelaxDepsNone) = Disp.text "False" - showRelaxDeps (Just _) = Disp.text "True" + showRelaxDeps Nothing = mempty + showRelaxDeps (Just rd) | isRelaxDeps rd = Disp.text "True" + | otherwise = Disp.text "False" toRelaxDeps True = RelaxDepsAll - toRelaxDeps False = RelaxDepsNone + toRelaxDeps False = mempty -- TODO: next step, make the deprecated fields elicit a warning. @@ -1165,7 +1184,7 @@ filterShow :: SavedConfig -> [(String, String)] filterShow cfg = map keyValueSplit - . filter (\s -> not (null s) && any (== ':') s) + . filter (\s -> not (null s) && ':' `elem` s) . map nonComment . lines $ showConfig cfg 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Configure @@ -37,7 +38,6 @@ ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Targets ( userToPackageConstraint, userConstraintPackageName ) -import Distribution.Package (PackageId) import Distribution.Client.JobControl (Lock) import qualified Distribution.Solver.Types.ComponentDeps as CD @@ -56,28 +56,25 @@ import Distribution.Simple.Program (ProgramDb) import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags ) import Distribution.Simple.Setup - ( ConfigFlags(..), AllowNewer(..), AllowOlder(..), RelaxDeps(..) + ( ConfigFlags(..) , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex, lookupPackageName ) -import Distribution.Simple.Utils - ( defaultPackageDesc ) import Distribution.Package - ( Package(..), packageName - , Dependency(..), thisPackageVersion - ) + ( Package(..), packageName, PackageId ) +import Distribution.Types.Dependency + ( Dependency(..), thisPackageVersion ) import qualified Distribution.PackageDescription as PkgDesc -import Distribution.PackageDescription.Parse - ( readPackageDescription ) +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription ) import Distribution.PackageDescription.Configuration ( finalizePD ) import Distribution.Version ( Version, mkVersion, anyVersion, thisVersion , VersionRange, orLaterVersion ) import Distribution.Simple.Utils as Utils - ( warn, notice, debug, die ) -import Distribution.Simple.Setup - ( isRelaxDeps ) + ( warn, notice, debug, die' + , defaultPackageDesc ) import Distribution.System ( Platform ) import Distribution.Text ( display ) @@ -88,16 +85,16 @@ -- | Choose the Cabal version such that the setup scripts compiled against this -- version will support the given command-line flags. -chooseCabalVersion :: ConfigFlags -> Maybe Version -> VersionRange -chooseCabalVersion configFlags maybeVersion = +chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange +chooseCabalVersion configExFlags maybeVersion = maybe defaultVersionRange thisVersion maybeVersion where -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed -- for '--allow-newer' to work. allowNewer = isRelaxDeps - (maybe RelaxDepsNone unAllowNewer $ configAllowNewer configFlags) + (maybe mempty unAllowNewer $ configAllowNewer configExFlags) allowOlder = isRelaxDeps - (maybe RelaxDepsNone unAllowOlder $ configAllowOlder configFlags) + (maybe mempty unAllowOlder $ configAllowOlder configExFlags) defaultVersionRange = if allowOlder || allowNewer then orLaterVersion (mkVersion [1,19,2]) @@ -135,12 +132,12 @@ warn verbosity $ "solver failed to find a solution:\n" ++ message - ++ "Trying configure anyway." + ++ "\nTrying configure anyway." setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing) Nothing configureCommand (const configFlags) extraArgs Right installPlan0 -> - let installPlan = InstallPlan.configureInstallPlan installPlan0 + let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 in case fst (InstallPlan.ready installPlan) of [pkg@(ReadyPackage (ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _) @@ -150,7 +147,7 @@ (setupScriptOptions installedPkgIndex (Just pkg)) configFlags pkg extraArgs - _ -> die $ "internal error: configure install plan should have exactly " + _ -> die' verbosity $ "internal error: configure install plan should have exactly " ++ "one local ready package." where @@ -167,7 +164,7 @@ (useDistPref defaultSetupScriptOptions) (configDistPref configFlags)) (chooseCabalVersion - configFlags + configExFlags (flagToMaybe (configCabalVersion configExFlags))) Nothing False @@ -256,7 +253,7 @@ -- Return the setup dependencies computed by the solver ReadyPackage cpkg <- mpkg return [ ( cid, srcid ) - | ConfiguredId srcid cid <- CD.setupDeps (confPkgDeps cpkg) + | ConfiguredId srcid (Just PkgDesc.CLibName) cid <- CD.setupDeps (confPkgDeps cpkg) ] -- | Warn if any constraints or preferences name packages that are not in the @@ -296,7 +293,10 @@ -> IO (Progress String String SolverInstallPlan) planLocalPackage verbosity comp platform configFlags configExFlags installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do - pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity + pkg <- readGenericPackageDescription verbosity =<< + case flagToMaybe (configCabalFilePath configFlags) of + Nothing -> defaultPackageDesc verbosity + Just fp -> return fp solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerInfo comp) @@ -314,9 +314,9 @@ resolverParams = removeLowerBounds - (fromMaybe (AllowOlder RelaxDepsNone) $ configAllowOlder configFlags) + (fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags) . removeUpperBounds - (fromMaybe (AllowNewer RelaxDepsNone) $ configAllowNewer configFlags) + (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags) . addPreferences -- preferences from the config file or command line @@ -332,15 +332,17 @@ . addConstraints -- package flags from the config file or command line - [ let pc = PackageConstraintFlags (packageName pkg) - (configConfigurationsFlags configFlags) + [ let pc = PackageConstraint + (scopeToplevel $ packageName pkg) + (PackagePropertyFlags $ configConfigurationsFlags configFlags) in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget ] . addConstraints -- '--enable-tests' and '--enable-benchmarks' constraints from -- the config file or command line - [ let pc = PackageConstraintStanzas (packageName pkg) $ + [ let pc = PackageConstraint (scopeToplevel $ packageName pkg) . + PackagePropertyStanzas $ [ TestStanzas | testsEnabled ] ++ [ BenchStanzas | benchmarksEnabled ] in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget @@ -351,6 +353,8 @@ -- installed package index . setSolveExecutables (SolveExecutables False) + . setSolverVerbosity verbosity + $ standardInstallPolicy installedPkgIndex -- NB: We pass in an *empty* source package database, @@ -387,15 +391,18 @@ where gpkg = packageDescription spkg configureFlags = filterConfigureFlags configFlags { - configIPID = toFlag (display ipid), + configIPID = if isJust (flagToMaybe (configIPID configFlags)) + -- Make sure cabal configure --ipid works. + then configIPID configFlags + else toFlag (display ipid), configConfigurationsFlags = flags, -- We generate the legacy constraints as well as the new style precise -- deps. In the end only one set gets passed to Setup.hs configure, -- depending on the Cabal version we are talking to. configConstraints = [ thisPackageVersion srcid - | ConfiguredId srcid _uid <- CD.nonSetupDeps deps ], + | ConfiguredId srcid (Just PkgDesc.CLibName) _uid <- CD.nonSetupDeps deps ], configDependencies = [ (packageName srcid, uid) - | ConfiguredId srcid uid <- CD.nonSetupDeps deps ], + | ConfiguredId srcid (Just PkgDesc.CLibName) uid <- CD.nonSetupDeps deps ], -- Use '--exact-configuration' if supported. configExactConfiguration = toFlag True, configVerbosity = toFlag verbosity, diff --git a/cabal/cabal-install/Distribution/Client/Dependency.hs b/cabal/cabal-install/Distribution/Client/Dependency.hs --- a/cabal/cabal-install/Distribution/Client/Dependency.hs +++ b/cabal/cabal-install/Distribution/Client/Dependency.hs @@ -23,7 +23,9 @@ resolveWithoutDependencies, -- * Constructing resolver policies + PackageProperty(..), PackageConstraint(..), + scopeToplevel, PackagesPreferenceDefault(..), PackagePreference(..), @@ -49,13 +51,16 @@ setAvoidReinstalls, setShadowPkgs, setStrongFlags, + setAllowBootLibInstalls, setMaxBackjumps, setEnableBackjumping, setSolveExecutables, setGoalOrder, + setSolverVerbosity, removeLowerBounds, removeUpperBounds, addDefaultSetupDependencies, + addSetupCabalMinVersionConstraint, ) where import Distribution.Solver.Modular @@ -66,27 +71,26 @@ import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Types ( SourcePackageDb(SourcePackageDb) - , UnresolvedPkgLoc, UnresolvedSourcePackage ) + , PackageSpecifier(..), pkgSpecifierTarget, pkgSpecifierConstraints + , UnresolvedPkgLoc, UnresolvedSourcePackage + , AllowNewer(..), AllowOlder(..), RelaxDeps(..), RelaxedDep(..) + , RelaxDepScope(..), RelaxDepMod(..), RelaxDepSubject(..), isRelaxDeps + ) import Distribution.Client.Dependency.Types ( PreSolver(..), Solver(..) , PackagesPreferenceDefault(..) ) import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..) ) -import Distribution.Client.Targets import Distribution.Package ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId - , Package(..), packageName, packageVersion - , Dependency(Dependency)) + , Package(..), packageName, packageVersion ) +import Distribution.Types.Dependency import qualified Distribution.PackageDescription as PD import qualified Distribution.PackageDescription.Configuration as PD import Distribution.PackageDescription.Configuration ( finalizePD ) import Distribution.Client.PackageUtils ( externalBuildDepends ) -import Distribution.Version - ( mkVersion, VersionRange, anyVersion, thisVersion, orLaterVersion - , withinRange, simplifyVersionRange - , removeLowerBound, removeUpperBound ) import Distribution.Compiler ( CompilerInfo(..) ) import Distribution.System @@ -95,14 +99,13 @@ ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) import Distribution.Simple.Utils ( comparing ) -import Distribution.Simple.Configure - ( relaxPackageDeps ) import Distribution.Simple.Setup - ( asBool, AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) + ( asBool ) import Distribution.Text ( display ) import Distribution.Verbosity - ( Verbosity ) + ( normal, Verbosity ) +import Distribution.Version import qualified Distribution.Compat.Graph as Graph import Distribution.Solver.Types.ComponentDeps (ComponentDeps) @@ -128,7 +131,7 @@ import Data.List ( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub ) import Data.Function (on) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set) @@ -157,6 +160,10 @@ depResolverAvoidReinstalls :: AvoidReinstalls, depResolverShadowPkgs :: ShadowPkgs, depResolverStrongFlags :: StrongFlags, + + -- | Whether to allow base and its dependencies to be installed. + depResolverAllowBootLibInstalls :: AllowBootLibInstalls, + depResolverMaxBackjumps :: Maybe Int, depResolverEnableBackjumping :: EnableBackjumping, -- | Whether or not to solve for dependencies on executables. @@ -166,7 +173,8 @@ depResolverSolveExecutables :: SolveExecutables, -- | Function to override the solver's goal-ordering heuristics. - depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering) + depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), + depResolverVerbosity :: Verbosity } showDepResolverParams :: DepResolverParams -> String @@ -185,6 +193,7 @@ ++ "\navoid reinstalls: " ++ show (asBool (depResolverAvoidReinstalls p)) ++ "\nshadow packages: " ++ show (asBool (depResolverShadowPkgs p)) ++ "\nstrong flags: " ++ show (asBool (depResolverStrongFlags p)) + ++ "\nallow boot library installs: " ++ show (asBool (depResolverAllowBootLibInstalls p)) ++ "\nmax backjumps: " ++ maybe "infinite" show (depResolverMaxBackjumps p) where @@ -239,10 +248,12 @@ depResolverAvoidReinstalls = AvoidReinstalls False, depResolverShadowPkgs = ShadowPkgs False, depResolverStrongFlags = StrongFlags False, + depResolverAllowBootLibInstalls = AllowBootLibInstalls False, depResolverMaxBackjumps = Nothing, depResolverEnableBackjumping = EnableBackjumping True, depResolverSolveExecutables = SolveExecutables True, - depResolverGoalOrder = Nothing + depResolverGoalOrder = Nothing, + depResolverVerbosity = normal } addTargets :: [PackageName] @@ -311,6 +322,12 @@ depResolverStrongFlags = sf } +setAllowBootLibInstalls :: AllowBootLibInstalls -> DepResolverParams -> DepResolverParams +setAllowBootLibInstalls i params = + params { + depResolverAllowBootLibInstalls = i + } + setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams setMaxBackjumps n params = params { @@ -337,6 +354,12 @@ depResolverGoalOrder = order } +setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams +setSolverVerbosity verbosity params = + params { + depResolverVerbosity = verbosity + } + -- | Some packages are specific to a given compiler version and should never be -- upgraded. dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams @@ -345,11 +368,17 @@ where extraConstraints = [ LabeledPackageConstraint - (PackageConstraintInstalled pkgname) + (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled) ConstraintSourceNonUpgradeablePackage | Set.notMember (mkPackageName "base") (depResolverTargets params) - , pkgname <- map mkPackageName [ "base", "ghc-prim", "integer-gmp" - , "integer-simple" ] + -- If you change this enumeration, make sure to update the list in + -- "Distribution.Solver.Modular.Solver" as well + , pkgname <- [ mkPackageName "base" + , mkPackageName "ghc-prim" + , mkPackageName "integer-gmp" + , mkPackageName "integer-simple" + , mkPackageName "template-haskell" + ] , isInstalled pkgname ] isInstalled = not . null @@ -395,24 +424,18 @@ -- 'addSourcePackages' won't have upper bounds in dependencies relaxed. -- removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams -removeUpperBounds (AllowNewer RelaxDepsNone) params = params -removeUpperBounds (AllowNewer allowNewer) params = - params { - depResolverSourcePkgIndex = sourcePkgIndex' - } - where - sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params - - relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage - relaxDeps srcPkg = srcPkg { - packageDescription = relaxPackageDeps removeUpperBound allowNewer - (packageDescription srcPkg) - } +removeUpperBounds (AllowNewer relDeps) = removeBounds RelaxUpper relDeps -- | Dual of 'removeUpperBounds' removeLowerBounds :: AllowOlder -> DepResolverParams -> DepResolverParams -removeLowerBounds (AllowOlder RelaxDepsNone) params = params -removeLowerBounds (AllowOlder allowNewer) params = +removeLowerBounds (AllowOlder relDeps) = removeBounds RelaxLower relDeps + +data RelaxKind = RelaxLower | RelaxUpper + +-- | Common internal implementation of 'removeLowerBounds'/'removeUpperBounds' +removeBounds :: RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams +removeBounds _ rd params | not (isRelaxDeps rd) = params -- no-op optimisation +removeBounds relKind relDeps params = params { depResolverSourcePkgIndex = sourcePkgIndex' } @@ -421,10 +444,65 @@ relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage relaxDeps srcPkg = srcPkg { - packageDescription = relaxPackageDeps removeLowerBound allowNewer + packageDescription = relaxPackageDeps relKind relDeps (packageDescription srcPkg) } +-- | Relax the dependencies of this package if needed. +-- +-- Helper function used by 'removeBounds' +relaxPackageDeps :: RelaxKind + -> RelaxDeps + -> PD.GenericPackageDescription -> PD.GenericPackageDescription +relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds' +relaxPackageDeps relKind RelaxDepsAll gpd = PD.transformAllBuildDepends relaxAll gpd + where + relaxAll :: Dependency -> Dependency + relaxAll (Dependency pkgName verRange) = + Dependency pkgName (removeBound relKind RelaxDepModNone verRange) + +relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd = + PD.transformAllBuildDepends relaxSome gpd + where + thisPkgName = packageName gpd + thisPkgId = packageId gpd + depsToRelax = Map.fromList $ mapMaybe f depsToRelax0 + + f :: RelaxedDep -> Maybe (RelaxDepSubject,RelaxDepMod) + f (RelaxedDep scope rdm p) = case scope of + RelaxDepScopeAll -> Just (p,rdm) + RelaxDepScopePackage p0 + | p0 == thisPkgName -> Just (p,rdm) + | otherwise -> Nothing + RelaxDepScopePackageId p0 + | p0 == thisPkgId -> Just (p,rdm) + | otherwise -> Nothing + + relaxSome :: Dependency -> Dependency + relaxSome d@(Dependency depName verRange) + | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax = + -- a '*'-subject acts absorbing, for consistency with + -- the 'Semigroup RelaxDeps' instance + Dependency depName (removeBound relKind relMod verRange) + | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax = + Dependency depName (removeBound relKind relMod verRange) + | otherwise = d -- no-op + +-- | Internal helper for 'relaxPackageDeps' +removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange +removeBound RelaxLower RelaxDepModNone = removeLowerBound +removeBound RelaxUpper RelaxDepModNone = removeUpperBound +removeBound relKind RelaxDepModCaret = hyloVersionRange embed projectVersionRange + where + embed (MajorBoundVersionF v) = caretTransformation v (majorUpperBound v) + embed vr = embedVersionRange vr + + -- This function is the interesting part as it defines the meaning + -- of 'RelaxDepModCaret', i.e. to transform only @^>=@ constraints; + caretTransformation l u = case relKind of + RelaxUpper -> orLaterVersion l -- rewrite @^>= x.y.z@ into @>= x.y.z@ + RelaxLower -> earlierVersion u -- rewrite @^>= x.y.z@ into @< x.(y+1)@ + -- | Supply defaults for packages without explicit Setup dependencies -- -- Note: It's important to apply 'addDefaultSetupDepends' after @@ -460,7 +538,22 @@ gpkgdesc = packageDescription srcpkg pkgdesc = PD.packageDescription gpkgdesc +-- | If a package has a custom setup then we need to add a setup-depends +-- on Cabal. +-- +addSetupCabalMinVersionConstraint :: Version + -> DepResolverParams -> DepResolverParams +addSetupCabalMinVersionConstraint minVersion = + addConstraints + [ LabeledPackageConstraint + (PackageConstraint (ScopeAnySetupQualifier cabalPkgname) + (PackagePropertyVersion $ orLaterVersion minVersion)) + ConstraintSetupCabalMinVersion + ] + where + cabalPkgname = mkPackageName "Cabal" + upgradeDependencies :: DepResolverParams -> DepResolverParams upgradeDependencies = setPreferenceDefault PreferAllLatest @@ -560,8 +653,9 @@ (thisVersion (packageVersion pkg)) | pkg <- otherDeps ] . addConstraints - [ let pc = PackageConstraintVersion (packageName pkg) - (thisVersion (packageVersion pkg)) + [ let pc = PackageConstraint + (scopeToplevel $ packageName pkg) + (PackagePropertyVersion $ thisVersion (packageVersion pkg)) in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep | pkg <- modifiedDeps ] @@ -622,7 +716,8 @@ $ fmap (validateSolverResult platform comp indGoals) $ runSolver solver (SolverConfig reordGoals cntConflicts indGoals noReinstalls - shadowing strFlags maxBkjumps enableBj solveExes order) + shadowing strFlags allowBootLibs maxBkjumps enableBj + solveExes order verbosity) platform comp installedPkgIndex sourcePkgIndex pkgConfigDB preferences constraints targets where @@ -638,10 +733,15 @@ noReinstalls shadowing strFlags + allowBootLibs maxBkjumps enableBj solveExes - order) = dontUpgradeNonUpgradeablePackages params + order + verbosity) = + if asBool (depResolverAllowBootLibInstalls params) + then params + else dontUpgradeNonUpgradeablePackages params preferences = interpretPackagesPreference targets defpref prefs @@ -699,13 +799,13 @@ -> SolverInstallPlan validateSolverResult platform comp indepGoals pkgs = case planPackagesProblems platform comp pkgs of - [] -> case SolverInstallPlan.new indepGoals index of + [] -> case SolverInstallPlan.new indepGoals graph of Right plan -> plan Left problems -> error (formatPlanProblems problems) problems -> error (formatPkgProblems problems) where - index = Graph.fromList pkgs + graph = Graph.fromDistinctList pkgs formatPkgProblems = formatProblemMessage . map showPlanPackageProblem formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem @@ -716,11 +816,13 @@ : "The proposed (invalid) plan contained the following problems:" : problems ++ "Proposed plan:" - : [SolverInstallPlan.showPlanIndex index] + : [SolverInstallPlan.showPlanIndex pkgs] data PlanPackageProblem = - InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc) [PackageProblem] + InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc) + [PackageProblem] + | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc] showPlanPackageProblem :: PlanPackageProblem -> String showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) = @@ -728,6 +830,9 @@ ++ " has an invalid configuration, in particular:\n" ++ unlines [ " " ++ showPackageProblem problem | problem <- packageProblems ] +showPlanPackageProblem (DuplicatePackageSolverId pid dups) = + "Package " ++ display (packageId pid) ++ " has " + ++ show (length dups) ++ " duplicate instances." planPackagesProblems :: Platform -> CompilerInfo -> [ResolverPackage UnresolvedPkgLoc] @@ -737,6 +842,8 @@ | Configured pkg <- pkgs , let packageProblems = configuredPackageProblems platform cinfo pkg , not (null packageProblems) ] + ++ [ DuplicatePackageSolverId (Graph.nodeKey (head dups)) dups + | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ] data PackageProblem = DuplicateFlag PD.FlagName | MissingFlag PD.FlagName @@ -782,7 +889,8 @@ -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] configuredPackageProblems platform cinfo (SolverPackage pkg specifiedFlags stanzas specifiedDeps' _specifiedExeDeps') = - [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ] + -- FIXME/TODO: FlagAssignment ought to be duplicate-free as internal invariant + [ DuplicateFlag flag | ((flag,_):_) <- duplicates (PD.unFlagAssignment specifiedFlags) ] ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] ++ [ DuplicateDeps pkgs @@ -799,7 +907,7 @@ mergedFlags = mergeBy compare (sort $ map PD.flagName (PD.genPackageFlags (packageDescription pkg))) - (sort $ map fst specifiedFlags) + (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO packageSatisfiesDependency (PackageIdentifier name version) @@ -866,7 +974,8 @@ resolveWithoutDependencies (DepResolverParams targets constraints prefs defpref installedPkgIndex sourcePkgIndex _reorderGoals _countConflicts _indGoals _avoidReinstalls - _shadowing _strFlags _maxBjumps _enableBj _solveExes _order) = + _shadowing _strFlags _maxBjumps _enableBj + _solveExes _allowBootLibInstalls _order _verbosity) = collectEithers $ map selectPackage (Set.toList targets) where selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage @@ -901,8 +1010,9 @@ Map.findWithDefault anyVersion pkgname packageVersionConstraintMap packageVersionConstraintMap = let pcs = map unlabelPackageConstraint constraints - in Map.fromList [ (name, range) - | PackageConstraintVersion name range <- pcs ] + in Map.fromList [ (scopeToPackageName scope, range) + | PackageConstraint + scope (PackagePropertyVersion range) <- pcs ] packagePreferences :: PackageName -> PackagePreferences packagePreferences = interpretPackagesPreference targets defpref prefs diff --git a/cabal/cabal-install/Distribution/Client/DistDirLayout.hs b/cabal/cabal-install/Distribution/Client/DistDirLayout.hs --- a/cabal/cabal-install/Distribution/Client/DistDirLayout.hs +++ b/cabal/cabal-install/Distribution/Client/DistDirLayout.hs @@ -1,32 +1,40 @@ {-# LANGUAGE RecordWildCards #-} --- | +-- | -- -- The layout of the .\/dist\/ directory where cabal keeps all of it's state -- and build artifacts. -- module Distribution.Client.DistDirLayout ( - -- 'DistDirLayout' + -- * 'DistDirLayout' DistDirLayout(..), DistDirParams(..), defaultDistDirLayout, + ProjectRoot(..), + -- * 'StoreDirLayout' + StoreDirLayout(..), + defaultStoreDirLayout, + -- * 'CabalDirLayout' CabalDirLayout(..), - defaultCabalDirLayout, + mkCabalDirLayout, + defaultCabalDirLayout ) where +import Data.Maybe (fromMaybe) import System.FilePath + import Distribution.Package ( PackageId, ComponentId, UnitId ) import Distribution.Compiler -import Distribution.Simple.Compiler (PackageDB(..), OptimisationLevel(..)) +import Distribution.Simple.Compiler + ( PackageDB(..), PackageDBStack, OptimisationLevel(..) ) import Distribution.Text import Distribution.Types.ComponentName import Distribution.System -import Distribution.Client.Types - ( InstalledPackageId ) + -- | Information which can be used to construct the path to -- the build directory of a build. This is LESS fine-grained -- than what goes into the hashed 'InstalledPackageId', @@ -51,9 +59,20 @@ -- data DistDirLayout = DistDirLayout { - -- | The dist directory, which is the root of where cabal keeps all its - -- state including the build artifacts from each package we build. + -- | The root directory of the project. Many other files are relative to + -- this location. In particular, the @cabal.project@ lives here. -- + distProjectRootDirectory :: FilePath, + + -- | The @cabal.project@ file and related like @cabal.project.freeze@. + -- The parameter is for the extension, like \"freeze\", or \"\" for the + -- main file. + -- + distProjectFile :: String -> FilePath, + + -- | The \"dist\" directory, which is the root of where cabal keeps all + -- its state including the build artifacts from each package we build. + -- distDirectory :: FilePath, -- | The directory under dist where we keep the build artifacts for a @@ -93,25 +112,71 @@ } +-- | The layout of a cabal nix-style store. +-- +data StoreDirLayout = StoreDirLayout { + storeDirectory :: CompilerId -> FilePath, + storePackageDirectory :: CompilerId -> UnitId -> FilePath, + storePackageDBPath :: CompilerId -> FilePath, + storePackageDB :: CompilerId -> PackageDB, + storePackageDBStack :: CompilerId -> PackageDBStack, + storeIncomingDirectory :: CompilerId -> FilePath, + storeIncomingLock :: CompilerId -> UnitId -> FilePath + } + --TODO: move to another module, e.g. CabalDirLayout? +-- or perhaps rename this module to DirLayouts. + +-- | The layout of the user-wide cabal directory, that is the @~/.cabal@ dir +-- on unix, and equivalents on other systems. +-- +-- At the moment this is just a partial specification, but the idea is +-- eventually to cover it all. +-- data CabalDirLayout = CabalDirLayout { - cabalStoreDirectory :: CompilerId -> FilePath, - cabalStorePackageDirectory :: CompilerId -> InstalledPackageId - -> FilePath, - cabalStorePackageDBPath :: CompilerId -> FilePath, - cabalStorePackageDB :: CompilerId -> PackageDB, + cabalStoreDirLayout :: StoreDirLayout, cabalLogsDirectory :: FilePath, cabalWorldFile :: FilePath } -defaultDistDirLayout :: FilePath -> DistDirLayout -defaultDistDirLayout projectRootDirectory = +-- | Information about the root directory of the project. +-- +-- It can either be an implict project root in the current dir if no +-- @cabal.project@ file is found, or an explicit root if the file is found. +-- +data ProjectRoot = + -- | -- ^ An implict project root. It contains the absolute project + -- root dir. + ProjectRootImplicit FilePath + + -- | -- ^ An explicit project root. It contains the absolute project + -- root dir and the relative @cabal.project@ file (or explicit override) + | ProjectRootExplicit FilePath FilePath + deriving (Eq, Show) + +-- | Make the default 'DistDirLayout' based on the project root dir and +-- optional overrides for the location of the @dist@ directory and the +-- @cabal.project@ file. +-- +defaultDistDirLayout :: ProjectRoot -- ^ the project root + -> Maybe FilePath -- ^ the @dist@ directory or default + -- (absolute or relative to the root) + -> DistDirLayout +defaultDistDirLayout projectRoot mdistDirectory = DistDirLayout {..} where - distDirectory = projectRootDirectory "dist-newstyle" + (projectRootDir, projectFile) = case projectRoot of + ProjectRootImplicit dir -> (dir, dir "cabal.project") + ProjectRootExplicit dir file -> (dir, dir file) + + distProjectRootDirectory = projectRootDir + distProjectFile ext = projectFile <.> ext + + distDirectory = distProjectRootDirectory + fromMaybe "dist-newstyle" mdistDirectory --TODO: switch to just dist at some point, or some other new name distBuildRootDirectory = distDirectory "build" @@ -120,10 +185,14 @@ display (distParamPlatform params) display (distParamCompilerId params) display (distParamPackageId params) - (case fmap componentNameString (distParamComponentName params) of - Nothing -> "" - Just Nothing -> "" - Just (Just name) -> "c" display name) + (case distParamComponentName params of + Nothing -> "" + Just CLibName -> "" + Just (CSubLibName name) -> "l" display name + Just (CFLibName name) -> "f" display name + Just (CExeName name) -> "x" display name + Just (CTestName name) -> "t" display name + Just (CBenchName name) -> "b" display name) (case distParamOptimization params of NoOptimisation -> "noopt" NormalOptimisation -> "" @@ -151,25 +220,44 @@ distPackageDB = SpecificPackageDB . distPackageDBPath - -defaultCabalDirLayout :: FilePath -> CabalDirLayout -defaultCabalDirLayout cabalDir = - CabalDirLayout {..} +defaultStoreDirLayout :: FilePath -> StoreDirLayout +defaultStoreDirLayout storeRoot = + StoreDirLayout {..} where + storeDirectory compid = + storeRoot display compid - cabalStoreDirectory compid = - cabalDir "store" display compid + storePackageDirectory compid ipkgid = + storeDirectory compid display ipkgid - cabalStorePackageDirectory compid ipkgid = - cabalStoreDirectory compid display ipkgid + storePackageDBPath compid = + storeDirectory compid "package.db" - cabalStorePackageDBPath compid = - cabalStoreDirectory compid "package.db" + storePackageDB compid = + SpecificPackageDB (storePackageDBPath compid) - cabalStorePackageDB = - SpecificPackageDB . cabalStorePackageDBPath + storePackageDBStack compid = + [GlobalPackageDB, storePackageDB compid] - cabalLogsDirectory = cabalDir "logs" + storeIncomingDirectory compid = + storeDirectory compid "incoming" - cabalWorldFile = cabalDir "world" + storeIncomingLock compid unitid = + storeIncomingDirectory compid display unitid <.> "lock" + +defaultCabalDirLayout :: FilePath -> CabalDirLayout +defaultCabalDirLayout cabalDir = + mkCabalDirLayout cabalDir Nothing Nothing + +mkCabalDirLayout :: FilePath -- ^ Cabal directory + -> Maybe FilePath -- ^ Store directory + -> Maybe FilePath -- ^ Log directory + -> CabalDirLayout +mkCabalDirLayout cabalDir mstoreDir mlogDir = + CabalDirLayout {..} + where + cabalStoreDirLayout = + defaultStoreDirLayout (fromMaybe (cabalDir "store") mstoreDir) + cabalLogsDirectory = fromMaybe (cabalDir "logs") mlogDir + cabalWorldFile = cabalDir "world" diff --git a/cabal/cabal-install/Distribution/Client/Exec.hs b/cabal/cabal-install/Distribution/Client/Exec.hs --- a/cabal/cabal-install/Distribution/Client/Exec.hs +++ b/cabal/cabal-install/Distribution/Client/Exec.hs @@ -27,12 +27,13 @@ import Distribution.Simple.Program.Find (ProgramSearchPathEntry(..)) import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation) import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) ) -import Distribution.Simple.Utils (die, warn) +import Distribution.Simple.Utils (die', warn) -import Distribution.System (Platform) +import Distribution.System (Platform(..), OS(..), buildOS) import Distribution.Verbosity (Verbosity) import System.Directory ( doesDirectoryExist ) +import System.Environment (lookupEnv) import System.FilePath (searchPathSeparator, ()) @@ -51,19 +52,19 @@ case extraArgs of (exe:args) -> do program <- requireProgram' verbosity useSandbox programDb exe - env <- ((++) (programOverrideEnv program)) <$> environmentOverrides + env <- environmentOverrides (programOverrideEnv program) let invocation = programInvocation program { programOverrideEnv = env } args runProgramInvocation verbosity invocation - [] -> die "Please specify an executable to run" + [] -> die' verbosity "Please specify an executable to run" where - environmentOverrides = + environmentOverrides env = case useSandbox of - NoSandbox -> return [] + NoSandbox -> return env (UseSandbox sandboxDir) -> - sandboxEnvironment verbosity sandboxDir comp platform programDb + sandboxEnvironment verbosity sandboxDir comp platform programDb env -- | Return the package's sandbox environment. @@ -74,13 +75,19 @@ -> Compiler -> Platform -> ProgramDb + -> [(String, Maybe String)] -- environment overrides so far -> IO [(String, Maybe String)] -sandboxEnvironment verbosity sandboxDir comp platform programDb = +sandboxEnvironment verbosity sandboxDir comp platform programDb iEnv = case compilerFlavor comp of GHC -> env GHC.getGlobalPackageDB ghcProgram "GHC_PACKAGE_PATH" GHCJS -> env GHCJS.getGlobalPackageDB ghcjsProgram "GHCJS_PACKAGE_PATH" - _ -> die "exec only works with GHC and GHCJS" + _ -> die' verbosity "exec only works with GHC and GHCJS" where + (Platform _ os) = platform + ldPath = case os of + OSX -> "DYLD_LIBRARY_PATH" + Windows -> "PATH" + _ -> "LD_LIBRARY_PATH" env getGlobalPackageDB hcProgram packagePathEnvVar = do let Just program = lookupProgram hcProgram programDb gDb <- getGlobalPackageDB verbosity program @@ -92,14 +99,64 @@ exists <- doesDirectoryExist sandboxPackagePath unless exists $ warn verbosity $ "Package database is not a directory: " ++ sandboxPackagePath + -- MASSIVE HACK. We need this to be synchronized with installLibDir + -- in defaultInstallDirs' in Distribution.Simple.InstallDirs, + -- which has a special case for Windows (WHY? Who knows; it's been + -- around as long as Windows exists.) The sane thing to do here + -- would be to read out the actual install dirs that were associated + -- with the package in question, but that's not a well-formed question + -- here because there is not actually install directory for the + -- "entire" sandbox. Since we want to kill this code in favor of + -- new-build, I decided it wasn't worth fixing this "properly." + -- Also, this doesn't handle LHC correctly but I don't care -- ezyang + let extraLibPath = + case buildOS of + Windows -> sandboxDir + _ -> sandboxDir "lib" + -- 2016-11-26 Apologies for the spaghetti code here. + -- Essentially we just want to add the sandbox's lib/ dir to + -- whatever the library search path environment variable is: + -- this allows running existing executables against foreign + -- libraries (meaning Haskell code with a bunch of foreign + -- exports). However, on Windows this variable is equal to the + -- executable search path env var. And we try to keep not only + -- what was already set in the environment, but also the + -- additional directories we add below in requireProgram'. So + -- the strategy is that we first take the environment + -- overrides from requireProgram' below. If the library search + -- path env is overridden (e.g. because we're on windows), we + -- prepend the lib/ dir to the relevant override. If not, we + -- want to avoid wiping the user's own settings, so we first + -- read the env var's current value, and then prefix ours if + -- the user had any set. + iEnv' <- + if any ((==ldPath) . fst) iEnv + then return $ updateLdPath extraLibPath iEnv + else do + currentLibraryPath <- lookupEnv ldPath + let updatedLdPath = + case currentLibraryPath of + Nothing -> Just extraLibPath + Just paths -> + Just $ extraLibPath ++ [searchPathSeparator] ++ paths + return $ (ldPath, updatedLdPath) : iEnv + -- Build the environment - return [ (packagePathEnvVar, Just compilerPackagePaths) - , ("CABAL_SANDBOX_PACKAGE_PATH", Just compilerPackagePaths) - , ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath) - ] + return $ [ (packagePathEnvVar, Just compilerPackagePaths) + , ("CABAL_SANDBOX_PACKAGE_PATH", Just compilerPackagePaths) + , ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath) + ] ++ iEnv' prependToSearchPath path newValue = newValue ++ [searchPathSeparator] ++ path + + updateLdPath path = map update + where + update (name, Just current) + | name == ldPath = (ldPath, Just $ path ++ [searchPathSeparator] ++ current) + update (name, Nothing) + | name == ldPath = (ldPath, Just path) + update x = x -- | Check that a program is configured and available to be run. If diff --git a/cabal/cabal-install/Distribution/Client/Fetch.hs b/cabal/cabal-install/Distribution/Client/Fetch.hs --- a/cabal/cabal-install/Distribution/Client/Fetch.hs +++ b/cabal/cabal-install/Distribution/Client/Fetch.hs @@ -39,7 +39,7 @@ import Distribution.Simple.Setup ( fromFlag ) import Distribution.Simple.Utils - ( die, notice, debug ) + ( die', notice, debug ) import Distribution.System ( Platform ) import Distribution.Text @@ -82,7 +82,7 @@ fetch verbosity packageDBs repoCtxt comp platform progdb globalFlags fetchFlags userTargets = do - mapM_ checkTarget userTargets + mapM_ (checkTarget verbosity) userTargets installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb sourcePkgDb <- getSourcePackages verbosity repoCtxt @@ -131,7 +131,7 @@ solver <- chooseSolver verbosity (fromFlag (fetchSolver fetchFlags)) (compilerInfo comp) notice verbosity "Resolving dependencies..." - installPlan <- foldProgress logMsg die return $ + installPlan <- foldProgress logMsg (die' verbosity) return $ resolveDependencies platform (compilerInfo comp) pkgConfigDb solver @@ -145,7 +145,7 @@ <- SolverInstallPlan.toList installPlan ] | otherwise = - either (die . unlines . map show) return $ + either (die' verbosity . unlines . map show) return $ resolveWithoutDependencies resolverParams where @@ -164,6 +164,10 @@ . setStrongFlags strongFlags + . setAllowBootLibInstalls allowBootLibInstalls + + . setSolverVerbosity verbosity + -- Reinstall the targets given on the command line so that the dep -- resolver will decide that they need fetching, even if they're -- already installed. Since we want to get the source packages of @@ -181,12 +185,13 @@ shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) strongFlags = fromFlag (fetchStrongFlags fetchFlags) maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags) + allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags) -checkTarget :: UserTarget -> IO () -checkTarget target = case target of +checkTarget :: Verbosity -> UserTarget -> IO () +checkTarget verbosity target = case target of UserTargetRemoteTarball _uri - -> die $ "The 'fetch' command does not yet support remote tarballs. " + -> die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " ++ "In the meantime you can use the 'unpack' commands." _ -> return () @@ -196,7 +201,7 @@ LocalTarballPackage _file -> return () RemoteTarballPackage _uri _ -> - die $ "The 'fetch' command does not yet support remote tarballs. " + die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " ++ "In the meantime you can use the 'unpack' commands." RepoTarballPackage repo pkgid _ -> do 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 @@ -44,7 +44,7 @@ import Distribution.Text ( display ) import Distribution.Verbosity - ( Verbosity ) + ( Verbosity, verboseUnmarkOutput ) import Distribution.Client.GlobalFlags ( RepoContext(..) ) @@ -140,7 +140,7 @@ where downloadTarballPackage uri = do transport <- repoContextGetTransport repoCtxt - transportCheckHttps transport uri + transportCheckHttps verbosity transport uri notice verbosity ("Downloading " ++ show uri) tmpdir <- getTemporaryDirectory (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz" @@ -165,7 +165,7 @@ RepoRemote{..} -> do transport <- repoContextGetTransport repoCtxt - remoteRepoCheckHttps transport repoRemote + remoteRepoCheckHttps verbosity transport repoRemote let uri = packageURI repoRemote pkgid dir = packageDir repo pkgid path = packageFile repo pkgid @@ -178,7 +178,7 @@ path = packageFile repo pkgid createDirectoryIfMissing True dir Sec.uncheckClientErrors $ do - info verbosity ("writing " ++ path) + info verbosity ("Writing " ++ path) Sec.downloadPackage' rep pkgid path return path @@ -188,7 +188,7 @@ -- downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult downloadIndex transport verbosity remoteRepo cacheDir = do - remoteRepoCheckHttps transport remoteRepo + remoteRepoCheckHttps verbosity transport remoteRepo let uri = (remoteRepoURI remoteRepo) { uriPath = uriPath (remoteRepoURI remoteRepo) `FilePath.Posix.combine` "00-index.tar.gz" @@ -229,7 +229,10 @@ let fetchPackages :: IO () fetchPackages = forM_ asyncDownloadVars $ \(pkgloc, var) -> do - result <- try $ fetchPackage verbosity repoCtxt pkgloc + -- Suppress marking here, because 'withAsync' means + -- that we get nondeterministic interleaving + result <- try $ fetchPackage (verboseUnmarkOutput verbosity) + repoCtxt pkgloc putMVar var result withAsync fetchPackages $ \_ -> @@ -241,6 +244,11 @@ -- -- If the download failed with an exception then this will be thrown. -- +-- Note: This function is supposed to be idempotent, as our install plans +-- can now use the same tarball for many builds, e.g. different +-- components and/or qualified goals, and these all go through the +-- download phase so we end up using 'waitAsyncFetchPackage' twice on +-- the same package. C.f. #4461. waitAsyncFetchPackage :: Verbosity -> AsyncFetchMap -> UnresolvedPkgLoc @@ -249,7 +257,7 @@ case Map.lookup srcloc downloadMap of Just hnd -> do debug verbosity $ "Waiting for download of " ++ show srcloc - either throwIO return =<< takeMVar hnd + either throwIO return =<< readMVar hnd Nothing -> fail "waitAsyncFetchPackage: package not being downloaded" diff --git a/cabal/cabal-install/Distribution/Client/FileMonitor.hs b/cabal/cabal-install/Distribution/Client/FileMonitor.hs --- a/cabal/cabal-install/Distribution/Client/FileMonitor.hs +++ b/cabal/cabal-install/Distribution/Client/FileMonitor.hs @@ -45,7 +45,7 @@ import qualified Data.Map as Map #endif import qualified Data.ByteString.Lazy as BS -import qualified Distribution.Utils.BinaryWithFingerprint as Binary +import qualified Distribution.Compat.Binary as Binary import qualified Data.Hashable as Hashable import Control.Monad @@ -403,7 +403,7 @@ -- See 'FileMonitor' for a full explanation. -- checkFileMonitorChanged - :: (Binary a, Binary b, Typeable a, Typeable b) + :: (Binary a, Binary b) => FileMonitor a b -- ^ cache file path -> FilePath -- ^ root directory -> a -- ^ guard or key value @@ -481,23 +481,23 @@ -- -- This determines the type and format of the binary cache file. -- -readCacheFile :: (Binary a, Binary b, Typeable a, Typeable b) +readCacheFile :: (Binary a, Binary b) => FileMonitor a b -> IO (Either String (MonitorStateFileSet, a, b)) readCacheFile FileMonitor {fileMonitorCacheFile} = withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> - Binary.decodeWithFingerprintOrFailIO =<< BS.hGetContents hnd + Binary.decodeOrFailIO =<< BS.hGetContents hnd -- | Helper for writing the cache file. -- -- This determines the type and format of the binary cache file. -- -rewriteCacheFile :: (Binary a, Binary b, Typeable a, Typeable b) +rewriteCacheFile :: (Binary a, Binary b) => FileMonitor a b -> MonitorStateFileSet -> a -> b -> IO () rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result = writeFileAtomic fileMonitorCacheFile $ - Binary.encodeWithFingerprint (fileset, key, result) + Binary.encode (fileset, key, result) -- | Probe the file system to see if any of the monitored files have changed. -- @@ -758,7 +758,7 @@ -- any files then you can use @Nothing@ for the timestamp parameter. -- updateFileMonitor - :: (Binary a, Binary b, Typeable a, Typeable b) + :: (Binary a, Binary b) => FileMonitor a b -- ^ cache file path -> FilePath -- ^ root directory -> Maybe MonitorTimestamp -- ^ timestamp when the update action started @@ -965,7 +965,7 @@ -- that the set of files to monitor can change then it's simpler just to throw -- away the structure and use a finite map. -- -readCacheFileHashes :: (Binary a, Binary b, Typeable a, Typeable b) +readCacheFileHashes :: (Binary a, Binary b) => FileMonitor a b -> IO FileHashCache readCacheFileHashes monitor = handleDoesNotExist Map.empty $ diff --git a/cabal/cabal-install/Distribution/Client/Freeze.hs b/cabal/cabal-install/Distribution/Client/Freeze.hs --- a/cabal/cabal-install/Distribution/Client/Freeze.hs +++ b/cabal/cabal-install/Distribution/Client/Freeze.hs @@ -52,7 +52,7 @@ import Distribution.Simple.Setup ( fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils - ( die, notice, debug, writeFileAtomic ) + ( die', notice, debug, writeFileAtomic ) import Distribution.System ( Platform ) import Distribution.Text @@ -72,15 +72,15 @@ -- constraining each dependency to an exact version. -- freeze :: Verbosity - -> PackageDBStack - -> RepoContext - -> Compiler - -> Platform - -> ProgramDb - -> Maybe SandboxPackageInfo - -> GlobalFlags - -> FreezeFlags - -> IO () + -> PackageDBStack + -> RepoContext + -> Compiler + -> Platform + -> ProgramDb + -> Maybe SandboxPackageInfo + -> GlobalFlags + -> FreezeFlags + -> IO () freeze verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo globalFlags freezeFlags = do @@ -132,10 +132,10 @@ where sanityCheck pkgSpecifiers = do when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $ - die $ "internal error: 'resolveUserTargets' returned " + die' verbosity $ "internal error: 'resolveUserTargets' returned " ++ "unexpected named package specifiers!" when (length pkgSpecifiers /= 1) $ - die $ "internal error: 'resolveUserTargets' returned " + die' verbosity $ "internal error: 'resolveUserTargets' returned " ++ "unexpected source package specifiers!" planPackages :: Verbosity @@ -155,7 +155,7 @@ (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp) notice verbosity "Resolving dependencies..." - installPlan <- foldProgress logMsg die return $ + installPlan <- foldProgress logMsg (die' verbosity) return $ resolveDependencies platform (compilerInfo comp) pkgConfigDb solver @@ -179,9 +179,14 @@ . setStrongFlags strongFlags + . setAllowBootLibInstalls allowBootLibInstalls + + . setSolverVerbosity verbosity + . addConstraints [ let pkg = pkgSpecifierTarget pkgSpecifier - pc = PackageConstraintStanzas pkg stanzas + pc = PackageConstraint (scopeToplevel pkg) + (PackagePropertyStanzas stanzas) in LabeledPackageConstraint pc ConstraintSourceFreeze | pkgSpecifier <- pkgSpecifiers ] @@ -202,6 +207,7 @@ shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) strongFlags = fromFlag (freezeStrongFlags freezeFlags) maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags) + allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags) -- | Remove all unneeded packages from an install plan. @@ -234,7 +240,8 @@ freezePackages verbosity globalFlags pkgs = do pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $ - loadUserConfig verbosity "" (flagToMaybe . globalConstraintsFile $ globalFlags) + loadUserConfig verbosity "" + (flagToMaybe . globalConstraintsFile $ globalFlags) writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv where addFrozenConstraints config = @@ -244,11 +251,12 @@ } } constraint pkg = - (pkgIdToConstraint $ packageId pkg, ConstraintSourceUserConfig userPackageEnvironmentFile) + (pkgIdToConstraint $ packageId pkg + ,ConstraintSourceUserConfig userPackageEnvironmentFile) where pkgIdToConstraint pkgId = - UserConstraintVersion (packageName pkgId) - (thisVersion $ packageVersion pkgId) + UserConstraint (UserQualified UserQualToplevel (packageName pkgId)) + (PackagePropertyVersion $ thisVersion (packageVersion pkgId)) createPkgEnv config = mempty { pkgEnvSavedConfig = config } showPkgEnv = BS.Char8.pack . showPackageEnvironment 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.GenBounds @@ -14,6 +15,9 @@ genBounds ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.Init ( incVersion ) import Distribution.Client.Freeze @@ -23,16 +27,16 @@ import Distribution.Client.Setup ( GlobalFlags(..), FreezeFlags(..), RepoContext ) import Distribution.Package - ( Package(..), Dependency(..), unPackageName - , packageName, packageVersion ) + ( Package(..), unPackageName, packageName, packageVersion ) import Distribution.PackageDescription ( buildDepends ) import Distribution.PackageDescription.Configuration ( finalizePD ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription ) import Distribution.Types.ComponentRequestedSpec ( defaultComponentRequestedSpec ) +import Distribution.Types.Dependency import Distribution.Simple.Compiler ( Compiler, PackageDBStack, compilerInfo ) import Distribution.Simple.Program @@ -109,10 +113,10 @@ cwd <- getCurrentDirectory path <- tryFindPackageDesc cwd - gpd <- readPackageDescription verbosity path + gpd <- readGenericPackageDescription verbosity path -- NB: We don't enable tests or benchmarks, since often they -- don't really have useful bounds. - let epd = finalizePD [] defaultComponentRequestedSpec + let epd = finalizePD mempty defaultComponentRequestedSpec (const True) platform cinfo [] gpd case epd of Left _ -> putStrLn "finalizePD failed" @@ -137,7 +141,7 @@ let thePkgs = filter isNeeded pkgs let padTo = maximum $ map (length . unPackageName . packageName) pkgs - mapM_ (putStrLn . (++",") . showBounds padTo) thePkgs + traverse_ (putStrLn . (++",") . showBounds padTo) thePkgs depName :: Dependency -> String depName (Dependency pn _) = unPackageName pn 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 @@ -23,9 +23,9 @@ import Distribution.Package ( PackageId, packageId, packageName ) import Distribution.Simple.Setup - ( Flag(..), fromFlag, fromFlagOrDefault ) + ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils - ( notice, die, info, rawSystemExitCode, writeFileAtomic ) + ( notice, die', info, rawSystemExitCode, writeFileAtomic ) import Distribution.Verbosity ( Verbosity ) import Distribution.Text(display) @@ -39,7 +39,7 @@ import Distribution.Client.FetchUtils import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackages ) + ( getSourcePackagesAtIndexState ) import Distribution.Client.Compat.Process ( readProcessWithExitCode ) import Distribution.Compat.Exception @@ -80,16 +80,18 @@ _ -> True unless useFork $ - mapM_ checkTarget userTargets + mapM_ (checkTarget verbosity) userTargets - sourcePkgDb <- getSourcePackages verbosity repoCtxt + let idxState = flagToMaybe $ getIndexState getFlags + sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState + pkgSpecifiers <- resolveUserTargets verbosity repoCtxt (fromFlag $ globalWorldFile globalFlags) (packageIndex sourcePkgDb) userTargets - pkgs <- either (die . unlines . map show) return $ + pkgs <- either (die' verbosity . unlines . map show) return $ resolveWithoutDependencies (resolverParams sourcePkgDb pkgSpecifiers) @@ -135,10 +137,10 @@ where usePristine = fromFlagOrDefault False (getPristine getFlags) -checkTarget :: UserTarget -> IO () -checkTarget target = case target of - UserTargetLocalDir dir -> die (notTarball dir) - UserTargetLocalCabalFile file -> die (notTarball file) +checkTarget :: Verbosity -> UserTarget -> IO () +checkTarget verbosity target = case target of + UserTargetLocalDir dir -> die' verbosity (notTarball dir) + UserTargetLocalCabalFile file -> die' verbosity (notTarball file) _ -> return () where notTarball t = @@ -157,10 +159,10 @@ pkgdir = prefix pkgdirname pkgdir' = addTrailingPathSeparator pkgdir existsDir <- doesDirectoryExist pkgdir - when existsDir $ die $ + when existsDir $ die' verbosity $ "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking." existsFile <- doesFileExist pkgdir - when existsFile $ die $ + when existsFile $ die' verbosity $ "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." notice verbosity $ "Unpacking to " ++ pkgdir' Tar.extractTarGzFile prefix pkgdirname pkgPath @@ -231,11 +233,11 @@ destDirExists <- doesDirectoryExist destdir when destDirExists $ do - die ("The directory " ++ show destdir ++ " already exists, not forking.") + die' verbosity ("The directory " ++ show destdir ++ " already exists, not forking.") destFileExists <- doesFileExist destdir when destFileExists $ do - die ("A file " ++ show destdir ++ " is in the way, not forking.") + die' verbosity ("A file " ++ show destdir ++ " is in the way, not forking.") let repos = PD.sourceRepos desc case findBranchCmd branchers repos kind of @@ -243,11 +245,11 @@ exitCode <- io verbosity destdir case exitCode of ExitSuccess -> return () - ExitFailure _ -> die ("Couldn't fork package " ++ pkgid) + ExitFailure _ -> die' verbosity ("Couldn't fork package " ++ pkgid) Nothing -> case repos of - [] -> die ("Package " ++ pkgid + [] -> die' verbosity ("Package " ++ pkgid ++ " does not have any source repositories.") - _ -> die ("Package " ++ pkgid + _ -> die' verbosity ("Package " ++ pkgid ++ " does not have any usable source repositories.") -- | Given a set of possible branchers, and a set of possible source diff --git a/cabal/cabal-install/Distribution/Client/GlobalFlags.hs b/cabal/cabal-install/Distribution/Client/GlobalFlags.hs --- a/cabal/cabal-install/Distribution/Client/GlobalFlags.hs +++ b/cabal/cabal-install/Distribution/Client/GlobalFlags.hs @@ -67,7 +67,9 @@ globalRequireSandbox :: Flag Bool, globalIgnoreSandbox :: Flag Bool, globalIgnoreExpiry :: Flag Bool, -- ^ Ignore security expiry dates - globalHttpTransport :: Flag String + globalHttpTransport :: Flag String, + globalNix :: Flag Bool, -- ^ Integrate with Nix + globalStoreDir :: Flag FilePath } deriving Generic defaultGlobalFlags :: GlobalFlags @@ -85,7 +87,9 @@ globalRequireSandbox = Flag False, globalIgnoreSandbox = Flag False, globalIgnoreExpiry = Flag False, - globalHttpTransport = mempty + globalHttpTransport = mempty, + globalNix = Flag False, + globalStoreDir = mempty } instance Monoid GlobalFlags where 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 @@ -37,9 +37,8 @@ import qualified Paths_cabal_install (version) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils - ( die, info, warn, debug, notice, writeFileAtomic - , copyFileVerbose, withTempFile - , rawSystemStdInOut, toUTF8, fromUTF8, normaliseLineEndings ) + ( die', info, warn, debug, notice, writeFileAtomic + , copyFileVerbose, withTempFile ) import Distribution.Client.Utils ( withTempFileName ) import Distribution.Client.Types @@ -51,9 +50,9 @@ import qualified System.FilePath.Posix as FilePath.Posix ( splitDirectories ) import System.FilePath - ( (<.>) ) + ( (<.>), takeFileName, takeDirectory ) import System.Directory - ( doesFileExist, renameFile ) + ( doesFileExist, renameFile, canonicalizePath ) import System.IO ( withFile, IOMode(ReadMode), hGetContents, hClose ) import System.IO.Error @@ -67,10 +66,8 @@ , configureAllKnownPrograms , requireProgram, lookupProgram ) import Distribution.Simple.Program.Run - ( IOEncoding(..), getEffectiveEnvironment ) + ( getProgramInvocationOutputAndErrors ) import Numeric (showHex) -import System.Directory (canonicalizePath) -import System.FilePath (takeFileName, takeDirectory) import System.Random (randomRIO) import System.Exit (ExitCode(..)) @@ -131,26 +128,26 @@ 304 -> do notice verbosity "Skipping download: local and remote files match." return FileAlreadyInCache - errCode -> die $ "Failed to download " ++ show uri + errCode -> die' verbosity $ "Failed to download " ++ show uri ++ " : HTTP code " ++ show errCode ------------------------------------------------------------------------------ -- Utilities for repo url management -- -remoteRepoCheckHttps :: HttpTransport -> RemoteRepo -> IO () -remoteRepoCheckHttps transport repo +remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO () +remoteRepoCheckHttps verbosity transport repo | uriScheme (remoteRepoURI repo) == "https:" , not (transportSupportsHttps transport) - = die $ "The remote repository '" ++ remoteRepoName repo + = die' verbosity $ "The remote repository '" ++ remoteRepoName repo ++ "' specifies a URL that " ++ requiresHttpsErrorMessage | otherwise = return () -transportCheckHttps :: HttpTransport -> URI -> IO () -transportCheckHttps transport uri +transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO () +transportCheckHttps verbosity transport uri | uriScheme uri == "https:" , not (transportSupportsHttps transport) - = die $ "The URL " ++ show uri + = die' verbosity $ "The URL " ++ show uri ++ " " ++ requiresHttpsErrorMessage | otherwise = return () @@ -164,13 +161,13 @@ ++ "external program is available, or one can be selected specifically " ++ "with the global flag --http-transport=" -remoteRepoTryUpgradeToHttps :: HttpTransport -> RemoteRepo -> IO RemoteRepo -remoteRepoTryUpgradeToHttps transport repo +remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo +remoteRepoTryUpgradeToHttps verbosity transport repo | remoteRepoShouldTryHttps repo , uriScheme (remoteRepoURI repo) == "http:" , not (transportSupportsHttps transport) , not (transportManuallySelected transport) - = die $ "The builtin HTTP implementation does not support HTTPS, but using " + = die' verbosity $ "The builtin HTTP implementation does not support HTTPS, but using " ++ "HTTPS for authenticated uploads is recommended. " ++ "The transport implementations with HTTPS support are " ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ] @@ -246,7 +243,7 @@ noPostYet :: Verbosity -> URI -> String -> Maybe (String, String) -> IO (Int, String) -noPostYet _ _ _ _ = die "Posting (for report upload) is not implemented yet" +noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet" supportedTransports :: [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)] @@ -284,7 +281,7 @@ let Just transport = mkTrans progdb return transport { transportManuallySelected = True } - Nothing -> die $ "Unknown HTTP transport specified: " ++ name + Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name ++ ". The supported transports are " ++ intercalate ", " [ name' | (name', _, _, _ ) <- supportedTransports ] @@ -341,7 +338,7 @@ (programInvocation prog args) withFile tmpFile ReadMode $ \hnd -> do headers <- hGetContents hnd - (code, _err, etag') <- parseResponse uri resp headers + (code, _err, etag') <- parseResponse verbosity uri resp headers evaluate $ force (code, etag') posthttp = noPostYet @@ -367,7 +364,7 @@ ] resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth (programInvocation prog args) - (code, err, _etag) <- parseResponse uri resp "" + (code, err, _etag) <- parseResponse verbosity uri resp "" return (code, err) puthttpfile verbosity uri path auth headers = do @@ -384,13 +381,13 @@ | Header name value <- headers ] resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth (programInvocation prog args) - (code, err, _etag) <- parseResponse uri resp "" + (code, err, _etag) <- parseResponse verbosity uri resp "" return (code, err) -- on success these curl invocations produces an output like "200" -- and on failure it has the server error response first - parseResponse :: URI -> String -> String -> IO (Int, String, Maybe ETag) - parseResponse uri resp headers = + parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag) + parseResponse verbosity uri resp headers = let codeerr = case reverse (lines resp) of (codeLine:rerrLines) -> @@ -409,7 +406,7 @@ in case codeerr of Just (i, err) -> return (i, err, mb_etag) - _ -> statusParseFail uri resp + _ -> statusParseFail verbosity uri resp wgetTransport :: ConfiguredProgram -> HttpTransport @@ -422,7 +419,7 @@ -- wget doesn't support range requests. -- so, we not only ignore range request headers, -- but we also dispay a warning message when we see them. - let hasRangeHeader = any (\hdr -> isRangeHeader hdr) reqHeaders + let hasRangeHeader = any isRangeHeader reqHeaders warningMsg = "the 'wget' transport currently doesn't support" ++ " range requests, which wastes network bandwidth." ++ " To fix this, set 'http-transport' to 'curl' or" @@ -431,7 +428,7 @@ ++ " support HTTPS.\n" when (hasRangeHeader) $ warn verbosity warningMsg - (code, etag') <- parseOutput uri resp + (code, etag') <- parseOutput verbosity uri resp return (code, etag') where args = [ "--output-document=" ++ destPath @@ -471,7 +468,7 @@ , "--header=Content-type: multipart/form-data; " ++ "boundary=" ++ boundary ] out <- runWGet verbosity (addUriAuth auth uri) args - (code, _etag) <- parseOutput uri out + (code, _etag) <- parseOutput verbosity uri out withFile responseFile ReadMode $ \hnd -> do resp <- hGetContents hnd evaluate $ force (code, resp) @@ -489,7 +486,7 @@ | Header name value <- headers ] out <- runWGet verbosity (addUriAuth auth uri) args - (code, _etag) <- parseOutput uri out + (code, _etag) <- parseOutput verbosity uri out withFile responseFile ReadMode $ \hnd -> do resp <- hGetContents hnd evaluate $ force (code, resp) @@ -515,14 +512,14 @@ -- wget returns exit code 8 for server "errors" like "304 not modified" if exitCode == ExitSuccess || exitCode == ExitFailure 8 then return resp - else die $ "'" ++ programPath prog + else die' verbosity $ "'" ++ programPath prog ++ "' exited with an error:\n" ++ resp -- With the --server-response flag, wget produces output with the full -- http server response with all headers, we want to find a line like -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple -- requests due to redirects. - parseOutput uri resp = + parseOutput verbosity uri resp = let parsedCode = listToMaybe [ code | (protocol:codestr:_err) <- map words (reverse (lines resp)) @@ -534,7 +531,7 @@ | ["ETag:", etag] <- map words (reverse (lines resp)) ] in case parsedCode of Just i -> return (i, mb_etag) - _ -> statusParseFail uri resp + _ -> statusParseFail verbosity uri resp powershellTransport :: ConfiguredProgram -> HttpTransport @@ -554,7 +551,7 @@ where parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of Just i -> return (i, Nothing) -- TODO extract real etag - Nothing -> statusParseFail uri x + Nothing -> statusParseFail verbosity uri x etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ] posthttp = noPostYet @@ -572,14 +569,14 @@ resp <- runPowershellScript verbosity $ webclientScript (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth) (uploadFileAction "POST" uri fullPath) - parseUploadResponse uri resp + parseUploadResponse verbosity uri resp puthttpfile verbosity uri path auth headers = do fullPath <- canonicalizePath path resp <- runPowershellScript verbosity $ webclientScript (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth) (uploadFileAction "PUT" uri fullPath) - parseUploadResponse uri resp + parseUploadResponse verbosity uri resp runPowershellScript verbosity script = do let args = @@ -618,10 +615,10 @@ , "Write-Host (-join [System.Text.Encoding]::UTF8.GetChars($bodyBytes));" ] - parseUploadResponse uri resp = case lines (trim resp) of + parseUploadResponse verbosity uri resp = case lines (trim resp) of (codeStr : message) | Just code <- readMaybe codeStr -> return (code, unlines message) - _ -> statusParseFail uri resp + _ -> statusParseFail verbosity uri resp webclientScript setup action = unlines [ "$wc = new-object system.net.webclient;" @@ -715,7 +712,7 @@ p <- fixupEmptyProxy <$> fetchProxy True Exception.handleJust (guard . isDoesNotExistError) - (const . die $ "Couldn't establish HTTP connection. " + (const . die' verbosity $ "Couldn't establish HTTP connection. " ++ "Possible cause: HTTP proxy server is down.") $ browse $ do setProxy p @@ -739,9 +736,9 @@ , " (", display buildOS, "; ", display buildArch, ")" ] -statusParseFail :: URI -> String -> IO a -statusParseFail uri r = - die $ "Failed to download " ++ show uri ++ " : " +statusParseFail :: Verbosity -> URI -> String -> IO a +statusParseFail verbosity uri r = + die' verbosity $ "Failed to download " ++ show uri ++ " : " ++ "No Status Code could be parsed from response: " ++ r -- Trim @@ -783,38 +780,3 @@ genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer return $ showHex i "" - ------------------------------------------------------------------------------- --- Compat utils - --- TODO: This is only here temporarily so we can release without also requiring --- the latest Cabal lib. The function is also included in Cabal now. - -getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation - -> IO (String, String, ExitCode) -getProgramInvocationOutputAndErrors verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envOverrides, - progInvokeCwd = mcwd, - progInvokeInput = minputStr, - progInvokeOutputEncoding = encoding - } = do - let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False - decode | utf8 = fromUTF8 . normaliseLineEndings - | otherwise = id - menv <- getEffectiveEnvironment envOverrides - (output, errors, exitCode) <- rawSystemStdInOut verbosity - path args - mcwd menv - input utf8 - return (decode output, decode errors, exitCode) - where - input = - case minputStr of - Nothing -> Nothing - Just inputStr -> Just $ - case encoding of - IOEncodingText -> (inputStr, False) - IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8 diff --git a/cabal/cabal-install/Distribution/Client/IndexUtils.hs b/cabal/cabal-install/Distribution/Client/IndexUtils.hs --- a/cabal/cabal-install/Distribution/Client/IndexUtils.hs +++ b/cabal/cabal-install/Distribution/Client/IndexUtils.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- @@ -31,6 +31,8 @@ parsePackageIndex, updateRepoIndexCache, updatePackageIndexCacheFile, + writeIndexTimestamp, + currentIndexTimestamp, readCacheStrict, -- only used by soon-to-be-obsolete sandbox code BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType @@ -45,36 +47,34 @@ import qualified Distribution.Client.Tar as Tar import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.Types +import Distribution.Verbosity import Distribution.Package ( PackageId, PackageIdentifier(..), mkPackageName - , Package(..), packageVersion, packageName - , Dependency(Dependency) ) + , Package(..), packageVersion, packageName ) +import Distribution.Types.Dependency import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse import Distribution.PackageDescription ( GenericPackageDescription ) -import Distribution.PackageDescription.Parse - ( parsePackageDescription ) import Distribution.Simple.Compiler ( Compiler, PackageDBStack ) import Distribution.Simple.Program ( ProgramDb ) import qualified Distribution.Simple.Configure as Configure ( getInstalledPackages, getInstalledPackagesMonitorFiles ) -import Distribution.ParseUtils - ( ParseResult(..) ) import Distribution.Version ( mkVersion, intersectVersionRanges ) import Distribution.Text ( display, simpleParse ) -import Distribution.Verbosity - ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils - ( die, warn, info, fromUTF8, ignoreBOM ) + ( die', warn, info ) import Distribution.Client.Setup ( RepoContext(..) ) +import Distribution.PackageDescription.Parsec + ( parseGenericPackageDescriptionMaybe ) +import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse + import Distribution.Solver.Types.PackageIndex (PackageIndex) import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import Distribution.Solver.Types.SourcePackage @@ -186,7 +186,7 @@ -- This is a higher level wrapper used internally in cabal-install. getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb getSourcePackages verbosity repoCtxt = - getSourcePackagesAtIndexState verbosity repoCtxt IndexStateHead + getSourcePackagesAtIndexState verbosity repoCtxt Nothing -- | Variant of 'getSourcePackages' which allows getting the source -- packages at a particular 'IndexState'. @@ -197,32 +197,49 @@ -- TODO: Enhance to allow specifying per-repo 'IndexState's and also -- report back per-repo 'IndexStateInfo's (in order for @new-freeze@ -- to access it) -getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> IndexState +getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> Maybe IndexState -> IO SourcePackageDb getSourcePackagesAtIndexState verbosity repoCtxt _ | null (repoContextRepos repoCtxt) = do - warn verbosity $ "No remote package servers have been specified. Usually " - ++ "you would have one specified in the config file." + -- In the test suite, we routinely don't have any remote package + -- servers, so don't bleat about it + warn (verboseUnmarkOutput verbosity) $ + "No remote package servers have been specified. Usually " ++ + "you would have one specified in the config file." return SourcePackageDb { packageIndex = mempty, packagePreferences = mempty } -getSourcePackagesAtIndexState verbosity repoCtxt idxState = do - case idxState of - IndexStateHead -> info verbosity "Reading available packages..." - IndexStateTime time -> - info verbosity ("Reading available packages (for index-state as of " - ++ display time ++ ")...") +getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do + let describeState IndexStateHead = "most recent state" + describeState (IndexStateTime time) = "historical state as of " ++ display time pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do let rname = maybe "" remoteRepoName $ maybeRepoRemote r + info verbosity ("Reading available packages of " ++ rname ++ "...") + + idxState <- case mb_idxState of + Just idxState -> do + info verbosity $ "Using " ++ describeState idxState ++ + " as explicitly requested (via command line / project configuration)" + return idxState + Nothing -> do + mb_idxState' <- readIndexTimestamp (RepoIndex repoCtxt r) + case mb_idxState' of + Nothing -> do + info verbosity "Using most recent state (could not read timestamp file)" + return IndexStateHead + Just idxState -> do + info verbosity $ "Using " ++ describeState idxState ++ + " specified from most recent cabal update" + return idxState + unless (idxState == IndexStateHead) $ case r of RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')") RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ rname ++ "')") RepoSecure {} -> pure () - let idxState' = case r of RepoSecure {} -> idxState _ -> IndexStateHead @@ -236,10 +253,17 @@ return () IndexStateTime ts0 -> do when (isiMaxTime isi /= ts0) $ - warn verbosity ("Requested index-state " ++ display ts0 + if ts0 > isiMaxTime isi + then warn verbosity $ + "Requested index-state" ++ display ts0 + ++ " is newer than '" ++ rname ++ "'!" + ++ " Falling back to older state (" + ++ display (isiMaxTime isi) ++ ")." + else info verbosity $ + "Requested index-state " ++ display ts0 ++ " does not exist in '"++rname++"'!" ++ " Falling back to older state (" - ++ display (isiMaxTime isi) ++ ").") + ++ display (isiMaxTime isi) ++ ")." info verbosity ("index-state("++rname++") = " ++ display (isiMaxTime isi) ++ " (HEAD = " ++ display (isiHeadTime isi) ++ ")") @@ -261,7 +285,7 @@ updateRepoIndexCache verbosity index cache <- readIndexCache verbosity index withFile (indexFile index) ReadMode $ \indexHnd -> - packageListFromCache mkPkg indexHnd cache ReadPackageIndexStrict + packageListFromCache verbosity mkPkg indexHnd cache ReadPackageIndexStrict -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. @@ -330,7 +354,9 @@ -- getSourcePackagesMonitorFiles :: [Repo] -> [FilePath] getSourcePackagesMonitorFiles repos = - [ indexBaseName repo <.> "cache" | repo <- repos ] + concat [ [ indexBaseName repo <.> "cache" + , indexBaseName repo <.> "timestamp" ] + | repo <- repos ] -- | It is not necessary to call this, as the cache will be updated when the -- index is read normally. However you can do the work earlier if you like. @@ -399,14 +425,14 @@ -- function over this to translate it to a list of IO actions returning -- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of -- 'PackageOrDep's, still maintaining the lazy nature of the original tar read. -parsePackageIndex :: ByteString -> [IO (Maybe PackageOrDep)] -parsePackageIndex = concatMap (uncurry extract) . tarEntriesList . Tar.read +parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)] +parsePackageIndex verbosity = concatMap (uncurry extract) . tarEntriesList . Tar.read where extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)] extract blockNo entry = tryExtractPkg ++ tryExtractPrefs where tryExtractPkg = do - mkPkgEntry <- maybeToList $ extractPkg entry blockNo + mkPkgEntry <- maybeToList $ extractPkg verbosity entry blockNo return $ fmap (fmap Pkg) mkPkgEntry tryExtractPrefs = do @@ -425,8 +451,8 @@ go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ show e) go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es' -extractPkg :: Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry)) -extractPkg entry blockNo = case Tar.entryContent entry of +extractPkg :: Verbosity -> Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry)) +extractPkg verbosity entry blockNo = case Tar.entryContent entry of Tar.NormalFile content _ | takeExtension fileName == ".cabal" -> case splitDirectories (normalise fileName) of @@ -434,11 +460,10 @@ Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo) where pkgid = PackageIdentifier (mkPackageName pkgname) ver - parsed = parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack - $ content - descr = case parsed of - ParseOk _ d -> d - _ -> error $ "Couldn't read cabal file " + parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content) + descr = case parsed of + Just d -> d + Nothing -> error $ "Couldn't read cabal file " ++ show fileName _ -> Nothing _ -> Nothing @@ -450,8 +475,8 @@ dirExists <- doesDirectoryExist path result <- if not dirExists then return Nothing else do - cabalFile <- tryFindAddSourcePackageDesc path "Error reading package index." - descr <- PackageDesc.Parse.readPackageDescription normal cabalFile + cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index." + descr <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr) descr path blockNo return result @@ -529,6 +554,10 @@ cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache" cacheFile (SandboxIndex index) = index `replaceExtension` "cache" +timestampFile :: Index -> FilePath +timestampFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "timestamp" +timestampFile (SandboxIndex index) = index `replaceExtension` "timestamp" + -- | Return 'True' if 'Index' uses 01-index format (aka secure repo) is01Index :: Index -> Bool is01Index (RepoIndex _ repo) = case repo of @@ -541,7 +570,7 @@ updatePackageIndexCacheFile :: Verbosity -> Index -> IO () updatePackageIndexCacheFile verbosity index = do info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...") - withIndexEntries index $ \entries -> do + withIndexEntries verbosity index $ \entries -> do let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries) cache = Cache { cacheHeadTs = maxTs , cacheEntries = entries @@ -570,8 +599,8 @@ -- TODO: It would be nicer if we actually incrementally updated @cabal@'s -- cache, rather than reconstruct it from zero on each update. However, this -- would require a change in the cache format. -withIndexEntries :: Index -> ([IndexCacheEntry] -> IO a) -> IO a -withIndexEntries (RepoIndex repoCtxt repo@RepoSecure{..}) callback = +withIndexEntries :: Verbosity -> Index -> ([IndexCacheEntry] -> IO a) -> IO a +withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{..}) callback = repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do -- Incrementally (lazily) read all the entries in the tar file in order, @@ -598,10 +627,10 @@ timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $ epochTimeToTimestamp $ Sec.indexEntryTime sie -withIndexEntries index callback = do -- non-secure repositories +withIndexEntries verbosity index callback = do -- non-secure repositories withFile (indexFile index) ReadMode $ \h -> do bs <- maybeDecompress `fmap` BS.hGetContents h - pkgsOrPrefs <- lazySequence $ parsePackageIndex bs + pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs callback $ map toCache (catMaybes pkgsOrPrefs) where toCache :: PackageOrDep -> IndexCacheEntry @@ -622,18 +651,19 @@ cache0 <- readIndexCache verbosity index indexHnd <- openFile (indexFile index) ReadMode let (cache,isi) = filterCache idxState cache0 - (pkgs,deps) <- packageIndexFromCache mkPkg indexHnd cache ReadPackageIndexLazyIO + (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache ReadPackageIndexLazyIO pure (pkgs,deps,isi) packageIndexFromCache :: Package pkg - => (PackageEntry -> pkg) + => Verbosity + -> (PackageEntry -> pkg) -> Handle -> Cache -> ReadPackageIndexMode -> IO (PackageIndex pkg, [Dependency]) -packageIndexFromCache mkPkg hnd cache mode = do - (pkgs, prefs) <- packageListFromCache mkPkg hnd cache mode +packageIndexFromCache verbosity mkPkg hnd cache mode = do + (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache mode pkgIndex <- evaluate $ PackageIndex.fromList pkgs return (pkgIndex, prefs) @@ -646,12 +676,13 @@ -- all .cabal edits and preference-updates. The masking happens -- here, i.e. the semantics that later entries in a tar file mask -- earlier ones is resolved in this function. -packageListFromCache :: (PackageEntry -> pkg) +packageListFromCache :: Verbosity + -> (PackageEntry -> pkg) -> Handle -> Cache -> ReadPackageIndexMode -> IO ([pkg], [Dependency]) -packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntries +packageListFromCache verbosity mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntries where accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs) @@ -664,12 +695,10 @@ pkgtxt <- getEntryContent blockno pkg <- readPackageDescription pkgtxt return (pkg, pkgtxt) - let srcpkg = case mode of - ReadPackageIndexLazyIO -> - mkPkg (NormalPackage pkgid pkg pkgtxt blockno) - ReadPackageIndexStrict -> - pkg `seq` pkgtxt `seq` mkPkg (NormalPackage pkgid pkg - pkgtxt blockno) + case mode of + ReadPackageIndexLazyIO -> pure () + ReadPackageIndexStrict -> evaluate pkg *> evaluate pkgtxt *> pure () + let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno) accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do @@ -678,8 +707,8 @@ -- file after the reference was added to the index. path <- liftM byteStringToFilePath . getEntryContent $ blockno pkg <- do let err = "Error reading package index from cache." - file <- tryFindAddSourcePackageDesc path err - PackageDesc.Parse.readPackageDescription normal file + file <- tryFindAddSourcePackageDesc verbosity path err + PackageDesc.Parse.readGenericPackageDescription normal file let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno) accum srcpkgs (srcpkg:btrs) prefs entries @@ -698,11 +727,12 @@ readPackageDescription :: ByteString -> IO GenericPackageDescription readPackageDescription content = - case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of - ParseOk _ d -> return d - _ -> interror "failed to parse .cabal file" + case parseGenericPackageDescriptionMaybe (BS.toStrict content) of + Just gpd -> return gpd + Nothing -> interror "failed to parse .cabal file" - interror msg = die $ "internal error when reading package index: " ++ msg + interror :: String -> IO a + interror msg = die' verbosity $ "internal error when reading package index: " ++ msg ++ "The package index or index cache is probably " ++ "corrupt. Running 'hackport update' might fix it." @@ -727,7 +757,7 @@ updatePackageIndexCacheFile verbosity index - either die (return . hashConsCache) =<< readIndexCache' index + either (die' verbosity) (return . hashConsCache) =<< readIndexCache' index Right res -> return (hashConsCache res) @@ -744,6 +774,31 @@ writeIndexCache index cache | is01Index index = encodeFile (cacheFile index) cache | otherwise = writeFile (cacheFile index) (show00IndexCache cache) + +-- | Write the 'IndexState' to the filesystem +writeIndexTimestamp :: Index -> IndexState -> IO () +writeIndexTimestamp index st + = writeFile (timestampFile index) (display st) + +-- | Read out the "current" index timestamp, i.e., what +-- timestamp you would use to revert to this version +currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp +currentIndexTimestamp verbosity repoCtxt r = do + mb_is <- readIndexTimestamp (RepoIndex repoCtxt r) + case mb_is of + Just (IndexStateTime ts) -> return ts + _ -> do + (_,_,isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead + return (isiHeadTime isi) + +-- | Read the 'IndexState' from the filesystem +readIndexTimestamp :: Index -> IO (Maybe IndexState) +readIndexTimestamp index + = fmap simpleParse (readFile (timestampFile index)) + `catchIO` \e -> + if isDoesNotExistError e + then return Nothing + else ioError e -- | Optimise sharing of equal values inside 'Cache' -- 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 @@ -53,14 +53,15 @@ import Distribution.Verbosity ( Verbosity ) import Distribution.ModuleName - ( ModuleName, fromString ) -- And for the Text instance + ( ModuleName ) -- And for the Text instance import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, sourcePackageId, exposed ) + ( InstalledPackageInfo, exposed ) import qualified Distribution.Package as P import Language.Haskell.Extension ( Language(..) ) import Distribution.Client.Init.Types - ( InitFlags(..), PackageType(..), Category(..) ) + ( InitFlags(..), BuildType(..), PackageType(..), Category(..) + , displayPackageType ) import Distribution.Client.Init.Licenses ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) import Distribution.Client.Init.Heuristics @@ -207,8 +208,20 @@ ?>> fmap (fmap (either UnknownLicense id)) (maybePrompt flags (promptList "Please choose a license" listedLicenses (Just BSD3) display True)) - return $ flags { license = maybeToFlag lic } + + if isLicenseInvalid lic + then putStrLn promptInvalidOtherLicenseMsg >> getLicense flags + else return $ flags { license = maybeToFlag lic } + where + isLicenseInvalid (Just (UnknownLicense t)) = any (not . isAlphaNum) t + isLicenseInvalid _ = False + + promptInvalidOtherLicenseMsg = "\nThe license must be alphanumeric. " ++ + "If your license name has many words, " ++ + "the convention is to use camel case (e.g. PublicDomain). " ++ + "Please choose a different license." + listedLicenses = knownLicenses \\ [GPL Nothing, LGPL Nothing, AGPL Nothing , Apache Nothing, OtherLicense] @@ -298,16 +311,16 @@ -- | Ask whether the project builds a library or executable. getLibOrExec :: InitFlags -> IO InitFlags getLibOrExec flags = do - isLib <- return (flagToMaybe $ packageType flags) + pkgType <- return (flagToMaybe $ packageType flags) ?>> maybePrompt flags (either (const Library) id `fmap` promptList "What does the package build" - [Library, Executable] - Nothing display False) + [Library, Executable, LibraryAndExecutable] + Nothing displayPackageType False) ?>> return (Just Library) - mainFile <- if isLib /= Just Executable then return Nothing else + mainFile <- if pkgType == Just Library then return Nothing else getMainFile flags - return $ flags { packageType = maybeToFlag isLib + return $ flags { packageType = maybeToFlag pkgType , mainIs = maybeToFlag mainFile } @@ -338,8 +351,17 @@ (Just Haskell2010) display True) ?>> return (Just Haskell2010) - return $ flags { language = maybeToFlag lang } + if invalidLanguage lang + then putStrLn invalidOtherLanguageMsg >> getLanguage flags + else return $ flags { language = maybeToFlag lang } + where + invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t + invalidLanguage _ = False + + invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " ++ + "Please enter a different language." + -- | Ask whether to generate explanatory comments. getGenComments :: InitFlags -> IO InitFlags getGenComments flags = do @@ -454,7 +476,7 @@ 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 sourcePackageId ps) + pkgGroups = groupBy ((==) `on` P.pkgName) (map P.packageId ps) -- Given a list of available versions of the same package, pick a dependency. toDep :: [P.PackageIdentifier] -> IO P.Dependency @@ -622,7 +644,7 @@ Flag (GPL (Just v)) | v == mkVersion [2] -> Just gplv2 - Flag (GPL (Just v)) | v == mkVersion [2] + Flag (GPL (Just v)) | v == mkVersion [3] -> Just gplv3 Flag (LGPL (Just v)) | v == mkVersion [2,1] @@ -671,14 +693,14 @@ ] writeChangeLog :: InitFlags -> IO () -writeChangeLog flags = when (any (== defaultChangeLog) $ maybe [] id (extraSrc flags)) $ do +writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do message flags ("Generating "++ defaultChangeLog ++"...") writeFileSafe flags defaultChangeLog changeLog where changeLog = unlines [ "# Revision history for " ++ pname , "" - , "## " ++ pver ++ " -- YYYY-mm-dd" + , "## " ++ pver ++ " -- YYYY-mm-dd" , "" , "* First version. Released on an unsuspecting world." ] @@ -713,17 +735,16 @@ -- | Create Main.hs, but only if we are init'ing an executable and -- the mainIs flag has been provided. createMainHs :: InitFlags -> IO () -createMainHs flags@InitFlags{ sourceDirs = Just (srcPath:_) - , packageType = Flag Executable - , mainIs = Flag mainFile } = - writeMainHs flags (srcPath mainFile) -createMainHs flags@InitFlags{ sourceDirs = _ - , packageType = Flag Executable - , mainIs = Flag mainFile } = - writeMainHs flags mainFile -createMainHs _ = return () +createMainHs flags = + if hasMainHs flags then + case sourceDirs flags of + Just (srcPath:_) -> writeMainHs flags (srcPath mainFile) + _ -> writeMainHs flags mainFile + else return () + where + Flag mainFile = mainIs flags --- | Write a main file if it doesn't already exist. +--- | Write a main file if it doesn't already exist. writeMainHs :: InitFlags -> FilePath -> IO () writeMainHs flags mainPath = do dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) @@ -733,6 +754,13 @@ message flags $ "Generating " ++ mainPath ++ "..." writeFileSafe flags mainFullPath mainHs +-- | Check that a main file exists. +hasMainHs :: InitFlags -> Bool +hasMainHs flags = case mainIs flags of + Flag _ -> (packageType flags == Flag Executable + || packageType flags == Flag LibraryAndExecutable) + _ -> False + -- | Default Main.hs file. Used when no Main.hs exists. mainHs :: String mainHs = unlines @@ -849,30 +877,18 @@ False , case packageType c of - Flag Executable -> - text "\nexecutable" <+> - text (maybe "" display . flagToMaybe $ packageName c) $$ - nest 2 (vcat - [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True - - , generateBuildInfo Executable c - ]) - Flag Library -> text "\nlibrary" $$ nest 2 (vcat - [ fieldS "exposed-modules" (listField (exposedModules c)) - (Just "Modules exported by the library.") - True - - , generateBuildInfo Library c - ]) + Flag Executable -> executableStanza + Flag Library -> libraryStanza + Flag LibraryAndExecutable -> libraryStanza $+$ executableStanza _ -> empty ] where - generateBuildInfo :: PackageType -> InitFlags -> Doc - generateBuildInfo pkgtype c' = vcat + generateBuildInfo :: BuildType -> InitFlags -> Doc + generateBuildInfo buildType c' = vcat [ fieldS "other-modules" (listField (otherModules c')) - (Just $ case pkgtype of - Library -> "Modules included in this library but not exported." - Executable -> "Modules included in this executable, other than Main.") + (Just $ case buildType of + LibBuild -> "Modules included in this library but not exported." + ExecBuild -> "Modules included in this executable, other than Main.") True , fieldS "other-extensions" (listField (otherExts c')) @@ -942,6 +958,25 @@ breakLine cs = case break (==' ') cs of (w,cs') -> w : breakLine' cs' breakLine' [] = [] breakLine' cs = case span (==' ') cs of (w,cs') -> w : breakLine cs' + + executableStanza :: Doc + executableStanza = text "\nexecutable" <+> + text (maybe "" display . flagToMaybe $ packageName c) $$ + nest 2 (vcat + [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True + + , generateBuildInfo ExecBuild c + ]) + + libraryStanza :: Doc + libraryStanza = text "\nlibrary" $$ nest 2 (vcat + [ fieldS "exposed-modules" (listField (exposedModules c)) + (Just "Modules exported by the library.") + True + + , generateBuildInfo LibBuild c + ]) + -- | Generate warnings for missing fields etc. generateWarnings :: InitFlags -> IO () diff --git a/cabal/cabal-install/Distribution/Client/Init/Types.hs b/cabal/cabal-install/Distribution/Client/Init/Types.hs --- a/cabal/cabal-install/Distribution/Client/Init/Types.hs +++ b/cabal/cabal-install/Distribution/Client/Init/Types.hs @@ -18,6 +18,7 @@ import Distribution.Simple.Setup ( Flag(..) ) +import Distribution.Types.Dependency as P import Distribution.Compat.Semigroup import Distribution.Version import Distribution.Verbosity @@ -77,12 +78,14 @@ -- ones, which is why we want Maybe [foo] for collecting foo values, -- not Flag [foo]. -data PackageType = Library | Executable +data BuildType = LibBuild | ExecBuild + +data PackageType = Library | Executable | LibraryAndExecutable deriving (Show, Read, Eq) -instance Text PackageType where - disp = Disp.text . show - parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable] -- TODO: eradicateNoParse +displayPackageType :: PackageType -> String +displayPackageType LibraryAndExecutable = "Library and Executable" +displayPackageType pkgtype = show pkgtype instance Monoid InitFlags where mempty = gmempty 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 @@ -32,8 +32,6 @@ import Prelude () import Distribution.Client.Compat.Prelude -import Data.List - ( (\\) ) import qualified Data.Map as Map import qualified Data.Set as S import Control.Exception as Exception @@ -47,7 +45,6 @@ ( ExitCode(..) ) import Distribution.Compat.Exception ( catchIO, catchExit ) -import Control.Exception ( assert ) import Control.Monad ( forM_, mapM ) import System.Directory @@ -73,7 +70,7 @@ import Distribution.Solver.Types.PackageFixedDeps import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackagesAtIndexState, IndexState(..), getInstalledPackages ) + ( getSourcePackagesAtIndexState, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.InstallPlan (InstallPlan) @@ -126,7 +123,6 @@ import Distribution.Simple.Setup ( haddockCommand, HaddockFlags(..) , buildCommand, BuildFlags(..), emptyBuildFlags - , AllowNewer(..), AllowOlder(..), RelaxDeps(..) , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal ( Flag(..) @@ -140,17 +136,19 @@ ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate , initialPathTemplateEnv, installDirsTemplateEnv ) import Distribution.Simple.Configure (interpretPackageDbFlags) -import Distribution.Simple.Register (registerPackage) -import Distribution.Simple.Program.HcPkg (MultiInstance(..)) +import Distribution.Simple.Register (registerPackage, defaultRegisterOptions) import Distribution.Package ( PackageIdentifier(..), PackageId, packageName, packageVersion - , Package(..), HasUnitId(..) - , Dependency(..), thisPackageVersion + , Package(..), HasMungedPackageId(..), HasUnitId(..) , UnitId ) +import Distribution.Types.Dependency + ( Dependency(..), thisPackageVersion ) +import Distribution.Types.MungedPackageId import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription ( PackageDescription, GenericPackageDescription(..), Flag(..) - , unFlagName, FlagAssignment ) + , FlagAssignment, mkFlagAssignment, unFlagAssignment + , showFlagValue, diffFlagAssignment, nullFlagAssignment ) import Distribution.PackageDescription.Configuration ( finalizePD ) import Distribution.ParseUtils @@ -158,7 +156,7 @@ import Distribution.Version ( Version, VersionRange, foldVersionRange ) import Distribution.Simple.Utils as Utils - ( notice, info, warn, debug, debugNoWrap, die + ( notice, info, warn, debug, debugNoWrap, die' , withTempDirectory ) import Distribution.Client.Utils ( determineNumJobs, logDirChange, mergeBy, MergeResult(..) @@ -168,7 +166,7 @@ import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity - ( Verbosity, normal, verbose ) + ( Verbosity, modifyVerbosity, normal, verbose ) import Distribution.Simple.BuildPaths ( exeExtension ) --TODO: @@ -210,9 +208,13 @@ userTargets0 = do unless (installRootCmd installFlags == Cabal.NoFlag) $ - die $ "--root-cmd is no longer supported, " + warn verbosity $ "--root-cmd is no longer supported, " ++ "see https://github.com/haskell/cabal/issues/3353" - unless (fromFlag (configUserInstall configFlags)) $ + ++ " (if you didn't type --root-cmd, comment out root-cmd" + ++ " in your ~/.cabal/config file)" + let userOrSandbox = fromFlag (configUserInstall configFlags) + || isUseSandbox useSandbox + unless userOrSandbox $ warn verbosity $ "the --global flag is deprecated -- " ++ "it is generally considered a bad idea to install packages " ++ "into the global store" @@ -224,7 +226,7 @@ case planResult of Left message -> do reportPlanningFailure verbosity args installContext message - die' message + die'' message Right installPlan -> processInstallPlan verbosity args installContext installPlan where @@ -233,7 +235,7 @@ mSandboxPkgInfo, globalFlags, configFlags, configExFlags, installFlags, haddockFlags) - die' message = die (message ++ if isUseSandbox useSandbox + die'' message = die' verbosity (message ++ if isUseSandbox useSandbox then installFailedInSandbox else []) -- TODO: use a better error message, remove duplication. installFailedInSandbox = @@ -273,8 +275,7 @@ (packageDBs, repoCtxt, comp, _, progdb,_,_, globalFlags, _, configExFlags, installFlags, _) mUserTargets = do - let idxState = fromFlagOrDefault IndexStateHead $ - installIndexState installFlags + let idxState = flagToMaybe (installIndexState installFlags) installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState @@ -318,7 +319,7 @@ solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) (compilerInfo comp) notice verbosity "Resolving dependencies..." - return $ planPackages comp platform mSandboxPkgInfo solver + return $ planPackages verbosity comp platform mSandboxPkgInfo solver configFlags configExFlags installFlags installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers @@ -327,7 +328,7 @@ -> SolverInstallPlan -> IO () processInstallPlan verbosity - args@(_,_, _, _, _, _, _, _, _, _, installFlags, _) + args@(_,_, _, _, _, _, _, _, configFlags, _, installFlags, _) (installedPkgIndex, sourcePkgDb, _, userTargets, pkgSpecifiers, _) installPlan0 = do @@ -339,7 +340,7 @@ args installedPkgIndex installPlan postInstallActions verbosity args userTargets installPlan buildOutcomes where - installPlan = InstallPlan.configureInstallPlan installPlan0 + installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 dryRun = fromFlag (installDryRun installFlags) nothingToInstall = null (fst (InstallPlan.ready installPlan)) @@ -347,7 +348,8 @@ -- * Installation planning -- ------------------------------------------------------------ -planPackages :: Compiler +planPackages :: Verbosity + -> Compiler -> Platform -> Maybe SandboxPackageInfo -> Solver @@ -359,7 +361,7 @@ -> PkgConfigDb -> [PackageSpecifier UnresolvedSourcePackage] -> Progress String String SolverInstallPlan -planPackages comp platform mSandboxPkgInfo solver +planPackages verbosity comp platform mSandboxPkgInfo solver configFlags configExFlags installFlags installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = @@ -388,6 +390,10 @@ . setStrongFlags strongFlags + . setAllowBootLibInstalls allowBootLibInstalls + + . setSolverVerbosity verbosity + . setPreferenceDefault (if upgradeDeps then PreferAllLatest else PreferLatestForSelected) @@ -407,16 +413,18 @@ . addConstraints --FIXME: this just applies all flags to all targets which -- is silly. We should check if the flags are appropriate - [ let pc = PackageConstraintFlags - (pkgSpecifierTarget pkgSpecifier) flags + [ let pc = PackageConstraint + (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyFlags flags) in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget | let flags = configConfigurationsFlags configFlags - , not (null flags) + , not (nullFlagAssignment flags) , pkgSpecifier <- pkgSpecifiers ] . addConstraints - [ let pc = PackageConstraintStanzas - (pkgSpecifierTarget pkgSpecifier) stanzas + [ let pc = PackageConstraint + (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyStanzas stanzas) in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget | pkgSpecifier <- pkgSpecifiers ] @@ -445,13 +453,15 @@ shadowPkgs = fromFlag (installShadowPkgs installFlags) strongFlags = fromFlag (installStrongFlags installFlags) maxBackjumps = fromFlag (installMaxBackjumps installFlags) + allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags) upgradeDeps = fromFlag (installUpgradeDeps installFlags) onlyDeps = fromFlag (installOnlyDeps installFlags) - allowOlder = fromMaybe (AllowOlder RelaxDepsNone) - (configAllowOlder configFlags) - allowNewer = fromMaybe (AllowNewer RelaxDepsNone) - (configAllowNewer configFlags) + allowOlder = fromMaybe (AllowOlder mempty) + (configAllowOlder configExFlags) + allowNewer = fromMaybe (AllowNewer mempty) + (configAllowNewer configExFlags) + -- | Remove the provided targets from the install plan. pruneInstallPlan :: Package targetpkg => [PackageSpecifier targetpkg] @@ -538,8 +548,9 @@ let breaksPkgs = not (null newBrokenPkgs) let adaptedVerbosity - | containsReinstalls && not overrideReinstall = verbosity `max` verbose - | otherwise = verbosity + | containsReinstalls + , not overrideReinstall = modifyVerbosity (max verbose) verbosity + | otherwise = verbosity -- We print the install plan if we are in a dry-run or if we are confronted -- with a dangerous install plan. @@ -553,9 +564,9 @@ when containsReinstalls $ do if breaksPkgs then do - (if dryRun || overrideReinstall then warn verbosity else die) $ unlines $ + (if dryRun || overrideReinstall then warn else die') verbosity $ unlines $ "The following packages are likely to be broken by the reinstalls:" - : map (display . Installed.sourcePackageId) newBrokenPkgs + : map (display . mungedId) newBrokenPkgs ++ if overrideReinstall then if dryRun then [] else ["Continuing even though " ++ @@ -575,7 +586,7 @@ . filterM (fmap isNothing . checkFetched . packageSource) $ pkgs unless (null notFetched) $ - die $ "Can't download packages in offline mode. " + die' verbosity $ "Can't download packages in offline mode. " ++ "Must download the following packages to proceed:\n" ++ intercalate ", " (map display notFetched) ++ "\nTry using 'cabal fetch'." @@ -590,7 +601,7 @@ | NewVersion [Version] | Reinstall [UnitId] [PackageChange] -type PackageChange = MergeResult PackageIdentifier PackageIdentifier +type PackageChange = MergeResult MungedPackageId MungedPackageId extractReinstalls :: PackageStatus -> [UnitId] extractReinstalls (Reinstall ipids _) = ipids @@ -603,8 +614,8 @@ case PackageIndex.lookupPackageName installedPkgIndex (packageName cpkg) of [] -> NewPackage - ps -> case filter ((== packageId cpkg) - . Installed.sourcePackageId) (concatMap snd ps) of + ps -> case filter ((== mungedId cpkg) + . mungedId) (concatMap snd ps) of [] -> NewVersion (map fst ps) pkgs@(pkg:_) -> Reinstall (map Installed.installedUnitId pkgs) (changes pkg cpkg) @@ -613,22 +624,21 @@ changes :: Installed.InstalledPackageInfo -> ReadyPackage - -> [MergeResult PackageIdentifier PackageIdentifier] + -> [PackageChange] changes pkg (ReadyPackage pkg') = filter changed $ - mergeBy (comparing packageName) + mergeBy (comparing mungedName) -- deps of installed pkg (resolveInstalledIds $ Installed.depends pkg) -- deps of configured pkg (resolveInstalledIds $ CD.nonSetupDeps (depends pkg')) -- convert to source pkg ids via index - resolveInstalledIds :: [UnitId] -> [PackageIdentifier] + resolveInstalledIds :: [UnitId] -> [MungedPackageId] resolveInstalledIds = nub . sort - . map Installed.sourcePackageId - . catMaybes - . map (PackageIndex.lookupUnitId installedPkgIndex) + . map mungedId + . mapMaybe (PackageIndex.lookupUnitId installedPkgIndex) changed (InBoth pkgid pkgid') = pkgid /= pkgid' changed _ = True @@ -641,7 +651,7 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of [] -> return () pkgs - | verbosity >= Verbosity.verbose -> putStr $ unlines $ + | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ ("In order, the following " ++ wouldWill ++ " be installed:") : map showPkgAndReason pkgs | otherwise -> notice verbosity $ unlines $ @@ -684,7 +694,7 @@ x -> Just $ packageVersion $ last x toFlagAssignment :: [Flag] -> FlagAssignment - toFlagAssignment = map (\ f -> (flagName f, flagDefault f)) + toFlagAssignment = mkFlagAssignment . map (\ f -> (flagName f, flagDefault f)) nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment nonDefaultFlags cpkg = @@ -692,22 +702,17 @@ toFlagAssignment (genPackageFlags (SourcePackage.packageDescription $ confPkgSource cpkg)) - in confPkgFlags cpkg \\ defaultAssignment + in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment showStanzas :: [OptionalStanza] -> String - showStanzas = concatMap ((' ' :) . showStanza) - showStanza TestStanzas = "*test" - showStanza BenchStanzas = "*bench" + showStanzas = concatMap ((" *" ++) . showStanza) showFlagAssignment :: FlagAssignment -> String - showFlagAssignment = concatMap ((' ' :) . showFlagValue) - showFlagValue (f, True) = '+' : showFlagName f - showFlagValue (f, False) = '-' : showFlagName f - showFlagName = unFlagName + showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment change (OnlyInLeft pkgid) = display pkgid ++ " removed" change (InBoth pkgid pkgid') = display pkgid ++ " -> " - ++ display (packageVersion pkgid') + ++ display (mungedVersion pkgid') change (OnlyInRight pkgid') = display pkgid' ++ " added" showDep pkg | Just rdeps <- Map.lookup (packageId pkg) revDeps @@ -717,7 +722,8 @@ revDepGraphEdges :: [(PackageId, PackageId)] revDepGraphEdges = [ (rpid, packageId cpkg) | (ReadyPackage cpkg, _) <- plan - , ConfiguredId rpid _ <- CD.flatDeps (confPkgDeps cpkg) ] + , ConfiguredId rpid (Just PackageDescription.CLibName) _ + <- CD.flatDeps (confPkgDeps cpkg) ] revDeps :: Map.Map PackageId [PackageId] revDeps = Map.fromListWith (++) (map (fmap (:[])) revDepGraphEdges) @@ -747,7 +753,7 @@ (compilerId comp) pkgids (configConfigurationsFlags configFlags) - when (not (null buildReports)) $ + unless (null buildReports) $ info verbosity $ "Solver failure will be reported for " ++ intercalate "," (map display pkgids) @@ -780,8 +786,8 @@ theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId theSpecifiedPackage pkgSpec = case pkgSpec of - NamedPackage name [PackageConstraintVersion name' version] - | name == name' -> PackageIdentifier name <$> trivialRange version + NamedPackage name [PackagePropertyVersion version] + -> PackageIdentifier name <$> trivialRange version NamedPackage _ _ -> Nothing SpecificSourcePackage pkg -> Just $ packageId pkg where @@ -818,7 +824,7 @@ unless oneShot $ World.insert verbosity worldFile --FIXME: does not handle flags - [ World.WorldPkgInfo dep [] + [ World.WorldPkgInfo dep mempty | UserTargetNamed dep <- targets ] let buildReports = BuildReports.fromInstallPlan platform (compilerId comp) @@ -838,9 +844,9 @@ symlinkBinaries verbosity platform comp configFlags installFlags installPlan buildOutcomes - printBuildFailures buildOutcomes + printBuildFailures verbosity buildOutcomes - updateSandboxTimestampsFile useSandbox mSandboxPkgInfo + updateSandboxTimestampsFile verbosity useSandbox mSandboxPkgInfo comp platform installPlan buildOutcomes where @@ -979,12 +985,12 @@ bindir = fromFlag (installSymlinkBinDir installFlags) -printBuildFailures :: BuildOutcomes -> IO () -printBuildFailures buildOutcomes = +printBuildFailures :: Verbosity -> BuildOutcomes -> IO () +printBuildFailures verbosity buildOutcomes = case [ (pkgid, failure) | (pkgid, Left failure) <- Map.toList buildOutcomes ] of [] -> return () - failed -> die . unlines + failed -> die' verbosity . unlines $ "Error: some packages failed to install:" : [ display pkgid ++ printFailureReason reason | (pkgid, reason) <- failed ] @@ -1022,15 +1028,15 @@ -- | If we're working inside a sandbox and some add-source deps were installed, -- update the timestamps of those deps. -updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo +updateSandboxTimestampsFile :: Verbosity -> UseSandbox -> Maybe SandboxPackageInfo -> Compiler -> Platform -> InstallPlan -> BuildOutcomes -> IO () -updateSandboxTimestampsFile (UseSandbox sandboxDir) +updateSandboxTimestampsFile verbosity (UseSandbox sandboxDir) (Just (SandboxPackageInfo _ _ _ allAddSourceDeps)) comp platform installPlan buildOutcomes = - withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do + withUpdateTimestamps verbosity sandboxDir (compilerId comp) platform $ \_ -> do let allInstalled = [ pkg | InstallPlan.Configured pkg <- InstallPlan.toList installPlan @@ -1044,7 +1050,7 @@ allPathsCanonical <- mapM tryCanonicalizePath allPaths return $! filter (`S.member` allAddSourceDeps) allPathsCanonical -updateSandboxTimestampsFile _ _ _ _ _ _ = return () +updateSandboxTimestampsFile _ _ _ _ _ _ _ = return () -- ------------------------------------------------------------ -- * Actually do the installations @@ -1111,7 +1117,7 @@ platform progdb distPref - (chooseCabalVersion configFlags (libVersion miscOptions)) + (chooseCabalVersion configExFlags (libVersion miscOptions)) (Just lock) parallelInstall index @@ -1141,7 +1147,7 @@ -- If the user has specified --remote-build-reporting=detailed or -- --build-log, use more verbose logging. loggingVerbosity :: Verbosity - loggingVerbosity | overrideVerbosity = max Verbosity.verbose verbosity + loggingVerbosity | overrideVerbosity = modifyVerbosity (max verbose) verbosity | otherwise = verbosity useDefaultTemplate :: Bool @@ -1233,9 +1239,11 @@ -- In the end only one set gets passed to Setup.hs configure, depending on -- the Cabal version we are talking to. configConstraints = [ thisPackageVersion srcid - | ConfiguredId srcid _ipid <- CD.nonSetupDeps deps ], + | ConfiguredId srcid (Just PackageDescription.CLibName) _ipid + <- CD.nonSetupDeps deps ], configDependencies = [ (packageName srcid, dep_ipid) - | ConfiguredId srcid dep_ipid <- CD.nonSetupDeps deps ], + | ConfiguredId srcid (Just PackageDescription.CLibName) dep_ipid + <- CD.nonSetupDeps deps ], -- Use '--exact-configuration' if supported. configExactConfiguration = toFlag True, configBenchmarks = toFlag False, @@ -1308,8 +1316,8 @@ ++ " to " ++ tmpDirPath ++ "..." extractTarGzFile tmpDirPath relUnpackedPath tarballPath exists <- doesFileExist descFilePath - when (not exists) $ - die $ "Package .cabal file not found: " ++ show descFilePath + unless exists $ + die' verbosity $ "Package .cabal file not found: " ++ show descFilePath maybeRenameDistDir absUnpackedPath installPkg (Just absUnpackedPath) @@ -1385,7 +1393,7 @@ -- Path to the optional log file. mLogPath <- maybeLogPath - logDirChange (maybe putStr appendFile mLogPath) workingDir $ do + logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do -- Configure phase onFailure ConfigureFailed $ do when (numJobs > 1) $ notice verbosity $ @@ -1426,16 +1434,14 @@ ipkgs <- genPkgConfs mLogPath let ipkgs' = case ipkgs of [ipkg] -> [ipkg { Installed.installedUnitId = uid }] - _ -> assert (any ((== uid) - . Installed.installedUnitId) - ipkgs) ipkgs + _ -> ipkgs let packageDBs = interpretPackageDbFlags (fromFlag (configUserInstall configFlags)) (configPackageDBs configFlags) forM_ ipkgs' $ \ipkg' -> registerPackage verbosity comp progdb - NoMultiInstance - packageDBs ipkg' + packageDBs ipkg' + defaultRegisterOptions return (Right (BuildResult docsResult testsResult (find ((==uid).installedUnitId) ipkgs'))) @@ -1521,7 +1527,7 @@ pkgConfParseFailed :: Installed.PError -> IO a pkgConfParseFailed perror = - die $ "Couldn't parse the output of 'setup register --gen-pkg-config':" + die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':" ++ show perror maybeLogPath :: IO (Maybe FilePath) 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 @@ -23,6 +23,7 @@ GenericInstallPlan, PlanPackage, GenericPlanPackage(..), + foldPlanPackage, IsUnit, -- * Operations on 'InstallPlan's @@ -73,7 +74,7 @@ import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.Package - ( Package(..) + ( Package(..), HasMungedPackageId(..) , HasUnitId(..), UnitId ) import Distribution.Solver.Types.SolverPackage import Distribution.Client.JobControl @@ -96,7 +97,7 @@ ( foldl', intercalate ) import qualified Data.Foldable as Foldable (all) import Data.Maybe - ( fromMaybe, catMaybes ) + ( fromMaybe, mapMaybe ) import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (Graph, IsNode(..)) import Distribution.Compat.Binary (Binary(..)) @@ -172,6 +173,18 @@ | Installed srcpkg deriving (Eq, Show, Generic) +-- | Convenience combinator for destructing 'GenericPlanPackage'. +-- This is handy because if you case manually, you have to handle +-- 'Configured' and 'Installed' separately (where often you want +-- them to be the same.) +foldPlanPackage :: (ipkg -> a) + -> (srcpkg -> a) + -> GenericPlanPackage ipkg srcpkg + -> a +foldPlanPackage f _ (PreExisting ipkg) = f ipkg +foldPlanPackage _ g (Configured srcpkg) = g srcpkg +foldPlanPackage _ g (Installed srcpkg) = g srcpkg + type IsUnit a = (IsNode a, Key a ~ UnitId) depends :: IsUnit a => a -> [UnitId] @@ -201,6 +214,12 @@ packageId (Configured spkg) = packageId spkg packageId (Installed spkg) = packageId spkg +instance (HasMungedPackageId ipkg, HasMungedPackageId srcpkg) => + HasMungedPackageId (GenericPlanPackage ipkg srcpkg) where + mungedId (PreExisting ipkg) = mungedId ipkg + mungedId (Configured spkg) = mungedId spkg + mungedId (Installed spkg) = mungedId spkg + instance (HasUnitId ipkg, HasUnitId srcpkg) => HasUnitId (GenericPlanPackage ipkg srcpkg) where @@ -314,7 +333,7 @@ remove shouldRemove plan = mkInstallPlan "remove" newGraph (planIndepGoals plan) where - newGraph = Graph.fromList $ + newGraph = Graph.fromDistinctList $ filter (not . shouldRemove) (toList plan) -- | Change a number of packages in the 'Configured' state to the 'Installed' @@ -416,7 +435,7 @@ -> GenericInstallPlan ipkg srcpkg fromSolverInstallPlan f plan = mkInstallPlan "fromSolverInstallPlan" - (Graph.fromList pkgs'') + (Graph.fromDistinctList pkgs'') (SolverInstallPlan.planIndepGoals plan) where (_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, []) @@ -453,7 +472,7 @@ (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, []) (SolverInstallPlan.reverseTopologicalOrder plan) return $ mkInstallPlan "fromSolverInstallPlanWithProgress" - (Graph.fromList pkgs'') + (Graph.fromDistinctList pkgs'') (SolverInstallPlan.planIndepGoals plan) where f' (pidMap, ipiMap, pkgs) pkg = do @@ -476,8 +495,8 @@ -- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. -- Similar to 'elaboratedInstallPlan' -configureInstallPlan :: SolverInstallPlan -> InstallPlan -configureInstallPlan solverPlan = +configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan +configureInstallPlan configFlags solverPlan = flip fromSolverInstallPlan solverPlan $ \mapDep planpkg -> [case planpkg of SolverInstallPlan.PreExisting pkg -> @@ -493,6 +512,8 @@ configureSolverPackage mapDep spkg = ConfiguredPackage { confPkgId = Configure.computeComponentId + (Cabal.fromFlagOrDefault False + (Cabal.configDeterministic configFlags)) Cabal.NoFlag Cabal.NoFlag (packageId spkg) @@ -884,10 +905,9 @@ problems graph = [ PackageMissingDeps pkg - (catMaybes - (map + (mapMaybe (fmap nodeKey . flip Graph.lookup graph) - missingDeps)) + missingDeps) | (pkg, missingDeps) <- Graph.broken graph ] ++ [ PackageCycle cycleGroup 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 @@ -18,7 +18,8 @@ #ifdef mingw32_HOST_OS -import Distribution.Package (PackageIdentifier, UnqualComponentName) +import Distribution.Package (PackageIdentifier) +import Distribution.Types.UnqualComponentName import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Types (BuildOutcomes) import Distribution.Client.Setup (InstallFlags) @@ -50,8 +51,8 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Package - ( PackageIdentifier, UnqualComponentName, unUnqualComponentName - , Package(packageId), UnitId, installedUnitId ) + ( PackageIdentifier, Package(packageId), UnitId, installedUnitId ) +import Distribution.Types.UnqualComponentName import Distribution.Compiler ( CompilerId(..) ) import qualified Distribution.PackageDescription as PackageDescription diff --git a/cabal/cabal-install/Distribution/Client/List.hs b/cabal/cabal-install/Distribution/Client/List.hs --- a/cabal/cabal-install/Distribution/Client/List.hs +++ b/cabal/cabal-install/Distribution/Client/List.hs @@ -14,10 +14,10 @@ ) where import Distribution.Package - ( PackageName, UnqualComponentName - , Package(..), packageName, packageVersion - , Dependency(..), simplifyDependency - , UnitId ) + ( PackageName, Package(..), packageName + , packageVersion, UnitId ) +import Distribution.Types.Dependency +import Distribution.Types.UnqualComponentName import Distribution.ModuleName (ModuleName) import Distribution.License (License) import qualified Distribution.InstalledPackageInfo as Installed @@ -31,7 +31,7 @@ ( Compiler, PackageDBStack ) import Distribution.Simple.Program (ProgramDb) import Distribution.Simple.Utils - ( equating, comparing, die, notice ) + ( equating, comparing, die', notice ) import Distribution.Simple.Setup (fromFlag) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex @@ -47,10 +47,9 @@ import Distribution.Solver.Types.SourcePackage import Distribution.Client.Types - ( SourcePackageDb(..) - , UnresolvedSourcePackage ) + ( SourcePackageDb(..), PackageSpecifier(..), UnresolvedSourcePackage ) import Distribution.Client.Targets - ( UserTarget, resolveUserTargets, PackageSpecifier(..) ) + ( UserTarget, resolveUserTargets ) import Distribution.Client.Setup ( GlobalFlags(..), ListFlags(..), InfoFlags(..) , RepoContext(..) ) @@ -197,7 +196,7 @@ sourcePkgs' userTargets pkgsinfo <- sequence - [ do pkginfo <- either die return $ + [ do pkginfo <- either (die' verbosity) return $ gatherPkgInfo prefs installedPkgIndex sourcePkgIndex pkgSpecifier @@ -213,7 +212,7 @@ PackageSpecifier UnresolvedSourcePackage -> Either String PackageDisplayInfo gatherPkgInfo prefs installedPkgIndex sourcePkgIndex - (NamedPackage name constraints) + (NamedPackage name props) | null (selectedInstalledPkgs) && null (selectedSourcePkgs) = Left $ "There is no available version of " ++ display name ++ " that satisfies " @@ -238,7 +237,7 @@ -- supplied a non-trivial version constraint showPkgVersion = not (null verConstraints) verConstraint = foldr intersectVersionRanges anyVersion verConstraints - verConstraints = [ vr | PackageConstraintVersion _ vr <- constraints ] + verConstraints = [ vr | PackagePropertyVersion vr <- props ] gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (SpecificSourcePackage pkg) = @@ -328,9 +327,9 @@ showPackageDetailedInfo pkginfo = renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ char '*' <+> disp (pkgName pkginfo) - <> maybe empty (\v -> char '-' <> disp v) (selectedVersion pkginfo) + Disp.<> maybe empty (\v -> char '-' Disp.<> disp v) (selectedVersion pkginfo) <+> text (replicate (16 - length (display (pkgName pkginfo))) ' ') - <> parens pkgkind + Disp.<> parens pkgkind $+$ (nest 4 $ vcat [ entry "Synopsis" synopsis hideIfNull reflowParagraphs @@ -364,7 +363,7 @@ Just Nothing -> empty Just (Just other) -> label <+> text other where - label = text fname <> char ':' <> padding + label = text fname Disp.<> char ':' Disp.<> padding padding = text (replicate (13 - length fname ) ' ') normal = Nothing @@ -458,10 +457,8 @@ Installed.category installed, flags = maybe [] Source.genPackageFlags sourceGeneric, hasLib = isJust installed - || fromMaybe False - (fmap (isJust . Source.condLibrary) sourceGeneric), - hasExe = fromMaybe False - (fmap (not . null . Source.condExecutables) sourceGeneric), + || maybe False (isJust . Source.condLibrary) sourceGeneric, + hasExe = maybe False (not . null . Source.condExecutables) sourceGeneric, executables = map fst (maybe [] Source.condExecutables sourceGeneric), modules = combine (map Installed.exposedName . Installed.exposedModules) installed diff --git a/cabal/cabal-install/Distribution/Client/Nix.hs b/cabal/cabal-install/Distribution/Client/Nix.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Nix.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + +module Distribution.Client.Nix + ( findNixExpr + , inNixShell + , nixInstantiate + , nixShell + , nixShellIfSandboxed + ) where + +import Distribution.Client.Compat.Prelude + +import Control.Exception (bracket, catch) +import System.Directory + ( canonicalizePath, createDirectoryIfMissing, doesDirectoryExist + , doesFileExist, removeDirectoryRecursive, removeFile ) +import System.Environment (getArgs, getExecutablePath) +import System.FilePath + ( (), replaceExtension, takeDirectory, takeFileName ) +import System.IO (IOMode(..), hClose, openFile) +import System.IO.Error (isDoesNotExistError) +import System.Process (showCommandForUser) + +import Distribution.Compat.Environment + ( lookupEnv, setEnv, unsetEnv ) + +import Distribution.Verbosity + +import Distribution.Simple.Program + ( Program(..), ProgramDb + , addKnownProgram, configureProgram, emptyProgramDb, getDbProgramOutput + , runDbProgram, simpleProgram ) +import Distribution.Simple.Setup (fromFlagOrDefault) +import Distribution.Simple.Utils (debug, existsAndIsMoreRecentThan) + +import Distribution.Client.Config (SavedConfig(..)) +import Distribution.Client.GlobalFlags (GlobalFlags(..)) +import Distribution.Client.Sandbox.Types (UseSandbox(..)) + + +configureOneProgram :: Verbosity -> Program -> IO ProgramDb +configureOneProgram verb prog = + configureProgram verb prog (addKnownProgram prog emptyProgramDb) + + +touchFile :: FilePath -> IO () +touchFile path = do + catch (removeFile path) (\e -> when (isDoesNotExistError e) (return ())) + createDirectoryIfMissing True (takeDirectory path) + openFile path WriteMode >>= hClose + + +findNixExpr :: GlobalFlags -> SavedConfig -> IO (Maybe FilePath) +findNixExpr globalFlags config = do + -- criteria for deciding to run nix-shell + let nixEnabled = + fromFlagOrDefault False + (globalNix (savedGlobalFlags config) <> globalNix globalFlags) + + if nixEnabled + then do + let exprPaths = [ "shell.nix", "default.nix" ] + filterM doesFileExist exprPaths >>= \case + [] -> return Nothing + (path : _) -> return (Just path) + else return Nothing + + +-- set IN_NIX_SHELL so that builtins.getEnv in Nix works as in nix-shell +inFakeNixShell :: IO a -> IO a +inFakeNixShell f = + bracket (fakeEnv "IN_NIX_SHELL" "1") (resetEnv "IN_NIX_SHELL") (\_ -> f) + where + fakeEnv var new = do + old <- lookupEnv var + setEnv var new + return old + resetEnv var = maybe (unsetEnv var) (setEnv var) + + +nixInstantiate + :: Verbosity + -> FilePath + -> Bool + -> GlobalFlags + -> SavedConfig + -> IO () +nixInstantiate verb dist force globalFlags config = + findNixExpr globalFlags config >>= \case + Nothing -> return () + Just shellNix -> do + alreadyInShell <- inNixShell + shellDrv <- drvPath dist shellNix + instantiated <- doesFileExist shellDrv + -- an extra timestamp file is necessary because the derivation lives in + -- the store so its mtime is always 1. + let timestamp = timestampPath dist shellNix + upToDate <- existsAndIsMoreRecentThan timestamp shellNix + + let ready = alreadyInShell || (instantiated && upToDate && not force) + unless ready $ do + + let prog = simpleProgram "nix-instantiate" + progdb <- configureOneProgram verb prog + + removeGCRoots verb dist + touchFile timestamp + + _ <- inFakeNixShell + (getDbProgramOutput verb prog progdb + [ "--add-root", shellDrv, "--indirect", shellNix ]) + return () + + +nixShell + :: Verbosity + -> FilePath + -> GlobalFlags + -> SavedConfig + -> IO () + -- ^ The action to perform inside a nix-shell. This is also the action + -- that will be performed immediately if Nix is disabled. + -> IO () +nixShell verb dist globalFlags config go = do + + alreadyInShell <- inNixShell + + if alreadyInShell + then go + else do + findNixExpr globalFlags config >>= \case + Nothing -> go + Just shellNix -> do + + let prog = simpleProgram "nix-shell" + progdb <- configureOneProgram verb prog + + cabal <- getExecutablePath + + -- alreadyInShell == True in child process + setEnv "CABAL_IN_NIX_SHELL" "1" + + -- Run cabal with the same arguments inside nix-shell. + -- When the child process reaches the top of nixShell, it will + -- detect that it is running inside the shell and fall back + -- automatically. + shellDrv <- drvPath dist shellNix + args <- getArgs + runDbProgram verb prog progdb + [ "--add-root", gcrootPath dist "result", "--indirect", shellDrv + , "--run", showCommandForUser cabal args + ] + + +drvPath :: FilePath -> FilePath -> IO FilePath +drvPath dist path = do + -- We do not actually care about canonicity, but makeAbsolute is only + -- available in newer versions of directory. + -- We expect the path to be a symlink if it exists, so we do not canonicalize + -- the entire path because that would dereference the symlink. + distNix <- canonicalizePath (dist "nix") + -- Nix garbage collector roots must be absolute paths + return (distNix replaceExtension (takeFileName path) "drv") + + +timestampPath :: FilePath -> FilePath -> FilePath +timestampPath dist path = + dist "nix" replaceExtension (takeFileName path) "drv.timestamp" + + +gcrootPath :: FilePath -> FilePath +gcrootPath dist = dist "nix" "gcroots" + + +inNixShell :: IO Bool +inNixShell = isJust <$> lookupEnv "CABAL_IN_NIX_SHELL" + + +removeGCRoots :: Verbosity -> FilePath -> IO () +removeGCRoots verb dist = do + let tgt = gcrootPath dist + exists <- doesDirectoryExist tgt + when exists $ do + debug verb ("removing Nix gcroots from " ++ tgt) + removeDirectoryRecursive tgt + + +nixShellIfSandboxed + :: Verbosity + -> FilePath + -> GlobalFlags + -> SavedConfig + -> UseSandbox + -> IO () + -- ^ The action to perform inside a nix-shell. This is also the action + -- that will be performed immediately if Nix is disabled. + -> IO () +nixShellIfSandboxed verb dist globalFlags config useSandbox go = + case useSandbox of + NoSandbox -> go + UseSandbox _ -> nixShell verb dist globalFlags config go diff --git a/cabal/cabal-install/Distribution/Client/Outdated.hs b/cabal/cabal-install/Distribution/Client/Outdated.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Outdated.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Outdated +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Implementation of the 'outdated' command. Checks for outdated +-- dependencies in the package description file or freeze file. +----------------------------------------------------------------------------- + +module Distribution.Client.Outdated ( outdated + , ListOutdatedSettings(..), listOutdated ) +where + +import Prelude () +import Distribution.Client.Config +import Distribution.Client.IndexUtils as IndexUtils +import Distribution.Client.Compat.Prelude +import Distribution.Client.ProjectConfig +import Distribution.Client.DistDirLayout +import Distribution.Client.RebuildMonad +import Distribution.Client.Setup hiding (quiet) +import Distribution.Client.Targets +import Distribution.Client.Types +import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackageIndex +import Distribution.Client.Sandbox.PackageEnvironment + +import Distribution.Package (PackageName + ,packageVersion) +import Distribution.PackageDescription (buildDepends) +import Distribution.PackageDescription.Configuration (finalizePD) +import Distribution.Simple.Compiler (Compiler, compilerInfo) +import Distribution.Simple.Setup (fromFlagOrDefault) +import Distribution.Simple.Utils + (die', notice, debug, tryFindPackageDesc) +import Distribution.System (Platform) +import Distribution.Text (display) +import Distribution.Types.ComponentRequestedSpec + (ComponentRequestedSpec(..)) +import Distribution.Types.Dependency + (Dependency(..), depPkgName, simplifyDependency) +import Distribution.Verbosity (Verbosity, silent) +import Distribution.Version + (Version, LowerBound(..), UpperBound(..) + ,asVersionIntervals, majorBoundVersion) +import Distribution.PackageDescription.Parsec + (readGenericPackageDescription) + +import qualified Data.Set as S +import System.Directory (getCurrentDirectory) +import System.Exit (exitFailure) +import Control.Exception (throwIO) + +-- | Entry point for the 'outdated' command. +outdated :: Verbosity -> OutdatedFlags -> RepoContext + -> Compiler -> Platform + -> IO () +outdated verbosity0 outdatedFlags repoContext comp platform = do + let freezeFile = fromFlagOrDefault False (outdatedFreezeFile outdatedFlags) + newFreezeFile = fromFlagOrDefault False + (outdatedNewFreezeFile outdatedFlags) + simpleOutput = fromFlagOrDefault False + (outdatedSimpleOutput outdatedFlags) + quiet = fromFlagOrDefault False (outdatedQuiet outdatedFlags) + exitCode = fromFlagOrDefault quiet (outdatedExitCode outdatedFlags) + ignorePred = let ignoreSet = S.fromList (outdatedIgnore outdatedFlags) + in \pkgname -> pkgname `S.member` ignoreSet + minorPred = case outdatedMinor outdatedFlags of + Nothing -> const False + Just IgnoreMajorVersionBumpsNone -> const False + Just IgnoreMajorVersionBumpsAll -> const True + Just (IgnoreMajorVersionBumpsSome pkgs) -> + let minorSet = S.fromList pkgs + in \pkgname -> pkgname `S.member` minorSet + verbosity = if quiet then silent else verbosity0 + + sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext + let pkgIndex = packageIndex sourcePkgDb + deps <- if freezeFile + then depsFromFreezeFile verbosity + else if newFreezeFile + then depsFromNewFreezeFile verbosity + else depsFromPkgDesc verbosity comp platform + debug verbosity $ "Dependencies loaded: " + ++ (intercalate ", " $ map display deps) + let outdatedDeps = listOutdated deps pkgIndex + (ListOutdatedSettings ignorePred minorPred) + when (not quiet) $ + showResult verbosity outdatedDeps simpleOutput + if (exitCode && (not . null $ outdatedDeps)) + then exitFailure + else return () + +-- | Print either the list of all outdated dependencies, or a message +-- that there are none. +showResult :: Verbosity -> [(Dependency,Version)] -> Bool -> IO () +showResult verbosity outdatedDeps simpleOutput = + if (not . null $ outdatedDeps) + then + do when (not simpleOutput) $ + notice verbosity "Outdated dependencies:" + for_ outdatedDeps $ \(d@(Dependency pn _), v) -> + let outdatedDep = if simpleOutput then display pn + else display d ++ " (latest: " ++ display v ++ ")" + in notice verbosity outdatedDep + else notice verbosity "All dependencies are up to date." + +-- | Convert a list of 'UserConstraint's to a 'Dependency' list. +userConstraintsToDependencies :: [UserConstraint] -> [Dependency] +userConstraintsToDependencies ucnstrs = + mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs + +-- | Read the list of dependencies from the freeze file. +depsFromFreezeFile :: Verbosity -> IO [Dependency] +depsFromFreezeFile verbosity = do + cwd <- getCurrentDirectory + userConfig <- loadUserConfig verbosity cwd Nothing + let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $ + userConfig + deps = userConstraintsToDependencies ucnstrs + debug verbosity "Reading the list of dependencies from the freeze file" + return deps + +-- | Read the list of dependencies from the new-style freeze file. +depsFromNewFreezeFile :: Verbosity -> IO [Dependency] +depsFromNewFreezeFile verbosity = do + projectRoot <- either throwIO return =<< + findProjectRoot Nothing + {- TODO: Support '--project-file': -} Nothing + let distDirLayout = defaultDistDirLayout projectRoot + {- TODO: Support dist dir override -} Nothing + projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ + readProjectLocalFreezeConfig verbosity distDirLayout + let ucnstrs = map fst . projectConfigConstraints . projectConfigShared + $ projectConfig + deps = userConstraintsToDependencies ucnstrs + debug verbosity + "Reading the list of dependencies from the new-style freeze file" + return deps + +-- | Read the list of dependencies from the package description. +depsFromPkgDesc :: Verbosity -> Compiler -> Platform -> IO [Dependency] +depsFromPkgDesc verbosity comp platform = do + cwd <- getCurrentDirectory + path <- tryFindPackageDesc cwd + gpd <- readGenericPackageDescription verbosity path + let cinfo = compilerInfo comp + epd = finalizePD mempty (ComponentRequestedSpec True True) + (const True) platform cinfo [] gpd + case epd of + Left _ -> die' verbosity "finalizePD failed" + Right (pd, _) -> do + let bd = buildDepends pd + debug verbosity + "Reading the list of dependencies from the package description" + return bd + +-- | Various knobs for customising the behaviour of 'listOutdated'. +data ListOutdatedSettings = ListOutdatedSettings { + -- | Should this package be ignored? + listOutdatedIgnorePred :: PackageName -> Bool, + -- | Should major version bumps should be ignored for this package? + listOutdatedMinorPred :: PackageName -> Bool + } + +-- | Find all outdated dependencies. +listOutdated :: [Dependency] + -> PackageIndex UnresolvedSourcePackage + -> ListOutdatedSettings + -> [(Dependency, Version)] +listOutdated deps pkgIndex (ListOutdatedSettings ignorePred minorPred) = + mapMaybe isOutdated $ map simplifyDependency deps + where + isOutdated :: Dependency -> Maybe (Dependency, Version) + isOutdated dep + | ignorePred (depPkgName dep) = Nothing + | otherwise = + let this = map packageVersion $ lookupDependency pkgIndex dep + latest = lookupLatest dep + in (\v -> (dep, v)) `fmap` isOutdated' this latest + + isOutdated' :: [Version] -> [Version] -> Maybe Version + isOutdated' [] _ = Nothing + isOutdated' _ [] = Nothing + isOutdated' this latest = + let this' = maximum this + latest' = maximum latest + in if this' < latest' then Just latest' else Nothing + + lookupLatest :: Dependency -> [Version] + lookupLatest dep + | minorPred (depPkgName dep) = + map packageVersion $ lookupDependency pkgIndex (relaxMinor dep) + | otherwise = + map packageVersion $ lookupPackageName pkgIndex (depPkgName dep) + + relaxMinor :: Dependency -> Dependency + relaxMinor (Dependency pn vr) = (Dependency pn vr') + where + vr' = let vis = asVersionIntervals vr + (LowerBound v0 _,upper) = last vis + in 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 @@ -29,13 +29,16 @@ hashFromTUF, ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Package ( PackageId, PackageIdentifier(..), mkComponentId , PkgconfigName ) import Distribution.System - ( Platform, OS(Windows), buildOS ) + ( Platform, OS(Windows, OSX), buildOS ) import Distribution.PackageDescription - ( unFlagName, FlagAssignment ) + ( FlagAssignment, unFlagAssignment, showFlagValue ) import Distribution.Simple.Compiler ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..) , ProfDetailLevel(..), showProfDetailLevel ) @@ -58,12 +61,7 @@ import qualified Data.Set as Set import Data.Set (Set) -import Data.Typeable -import Data.Maybe (catMaybes) -import Data.List (sortBy, intercalate) -import Data.Map (Map) import Data.Function (on) -import Distribution.Compat.Binary (Binary(..)) import Control.Exception (evaluate) import System.IO (withBinaryFile, IOMode(..)) @@ -82,6 +80,7 @@ hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId hashedInstalledPackageId | buildOS == Windows = hashedInstalledPackageIdShort + | buildOS == OSX = hashedInstalledPackageIdVeryShort | otherwise = hashedInstalledPackageIdLong -- | Calculate a 'InstalledPackageId' for a package using our nix-style @@ -135,6 +134,41 @@ truncateStr n s | length s <= n = s | otherwise = take (n-1) s ++ "_" +-- | On macOS we shorten the name very aggressively. The mach-o linker on +-- macOS has a limited load command size, to which the name of the lirbary +-- as well as it's relative path (\@rpath) entry count. To circumvent this, +-- on macOS the libraries are not stored as +-- @store//libHS.dylib@ +-- where libraryname contains the librarys name, version and abi hash, but in +-- @store/lib/libHS.dylib@ +-- where the very short library name drops all vowels from the package name, +-- and truncates the hash to 4 bytes. +-- +-- We therefore only need one \@rpath entry to @store/lib@ instead of one +-- \@rpath entry for each library. And the reduced library name saves some +-- additional space. +-- +-- This however has two major drawbacks: +-- 1) Packages can easier collide due to the shortened hash. +-- 2) The lirbaries are *not* prefix relocateable anymore as they all end up +-- in the same @store/lib@ folder. +-- +-- The ultimate solution would have to include generating proxy dynamic +-- libraries on macOS, such that the proxy libraries and the linked libraries +-- stay under the load command limit, and the recursive linker is still able +-- to link all of them. +hashedInstalledPackageIdVeryShort :: PackageHashInputs -> InstalledPackageId +hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = + mkComponentId $ + intercalate "-" + [ filter (not . flip elem "aeiou") (display name) + , display version + , showHashValue (truncateHash (hashPackageHashInputs pkghashinputs)) + ] + where + PackageIdentifier name version = pkgHashPkgId + truncateHash (HashValue h) = HashValue (BS.take 4 h) + -- | All the information that contribues to a package's hash, and thus its -- 'InstalledPackageId'. -- @@ -168,6 +202,7 @@ pkgHashCoverage :: Bool, pkgHashOptimization :: OptimisationLevel, pkgHashSplitObjs :: Bool, + pkgHashSplitSections :: Bool, pkgHashStripLibs :: Bool, pkgHashStripExes :: Bool, pkgHashDebugInfo :: DebugInfoLevel, @@ -233,7 +268,7 @@ -- and then all the config , entry "compilerid" display pkgHashCompilerId , entry "platform" display pkgHashPlatform - , opt "flags" [] showFlagAssignment pkgHashFlagAssignment + , opt "flags" mempty showFlagAssignment pkgHashFlagAssignment , opt "configure-script" [] unwords pkgHashConfigureScriptArgs , opt "vanilla-lib" True display pkgHashVanillaLib , opt "shared-lib" False display pkgHashSharedLib @@ -246,6 +281,7 @@ , opt "hpc" False display pkgHashCoverage , opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization , opt "split-objs" False display pkgHashSplitObjs + , opt "split-sections" False display pkgHashSplitSections , opt "stripped-lib" False display pkgHashStripLibs , opt "stripped-exe" True display pkgHashStripExes , opt "debug-info" NormalDebugInfo (show . fromEnum) pkgHashDebugInfo @@ -262,10 +298,7 @@ | value == def = Nothing | otherwise = entry key format value - showFlagAssignment = unwords . map showEntry . sortBy (compare `on` fst) - where - showEntry (fname, False) = '-' : unFlagName fname - showEntry (fname, True) = '+' : unFlagName fname + showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst) . unFlagAssignment ----------------------------------------------- -- The specific choice of hash implementation diff --git a/cabal/cabal-install/Distribution/Client/PackageUtils.hs b/cabal/cabal-install/Distribution/Client/PackageUtils.hs --- a/cabal/cabal-install/Distribution/Client/PackageUtils.hs +++ b/cabal/cabal-install/Distribution/Client/PackageUtils.hs @@ -15,7 +15,9 @@ ) where import Distribution.Package - ( packageVersion, packageName, Dependency(..), packageNameToUnqualComponentName ) + ( packageVersion, packageName ) +import Distribution.Types.Dependency +import Distribution.Types.UnqualComponentName import Distribution.PackageDescription ( PackageDescription(..), libName ) import Distribution.Version diff --git a/cabal/cabal-install/Distribution/Client/ParseUtils.hs b/cabal/cabal-install/Distribution/Client/ParseUtils.hs --- a/cabal/cabal-install/Distribution/Client/ParseUtils.hs +++ b/cabal/cabal-install/Distribution/Client/ParseUtils.hs @@ -46,10 +46,10 @@ ( OptionField, viewAsFieldDescr ) import Control.Monad ( foldM ) -import Text.PrettyPrint ( (<>), (<+>), ($+$) ) +import Text.PrettyPrint ( (<+>), ($+$) ) import qualified Data.Map as Map import qualified Text.PrettyPrint as Disp - ( Doc, text, colon, vcat, empty, isEmpty, nest ) + ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest ) ------------------------- @@ -162,8 +162,8 @@ ppField name mdef cur | Disp.isEmpty cur = maybe Disp.empty (\def -> Disp.text "--" <+> Disp.text name - <> Disp.colon <+> def) mdef - | otherwise = Disp.text name <> Disp.colon <+> cur + Disp.<> Disp.colon <+> def) mdef + | otherwise = Disp.text name Disp.<> Disp.colon <+> cur -- | Pretty print a section. -- 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 @@ -35,12 +35,17 @@ BuildFailureReason(..), ) where +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + import Distribution.Client.PackageHash (renderPackageHashInputs) import Distribution.Client.RebuildMonad import Distribution.Client.ProjectConfig import Distribution.Client.ProjectPlanning import Distribution.Client.ProjectPlanning.Types import Distribution.Client.ProjectBuilding.Types +import Distribution.Client.Store import Distribution.Client.Types hiding (BuildOutcomes, BuildOutcome, @@ -64,14 +69,16 @@ import qualified Distribution.PackageDescription as PD import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.Simple.BuildPaths (haddockDirName) +import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Types.BuildType import Distribution.Simple.Program import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Command (CommandUI) import qualified Distribution.Simple.Register as Cabal -import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo (ComponentName) -import qualified Distribution.Simple.Program.HcPkg as HcPkg +import Distribution.Simple.Compiler + ( Compiler, compilerId, PackageDB(..) ) import Distribution.Simple.Utils hiding (matchFileGlob) import Distribution.Version @@ -85,6 +92,7 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Data.ByteString.Lazy as LBS +import Data.List (isPrefixOf) import Control.Monad import Control.Exception @@ -94,6 +102,12 @@ import System.IO import System.Directory +#if !MIN_VERSION_directory(1,2,5) +listDirectory :: FilePath -> IO [FilePath] +listDirectory path = + (filter f) <$> (getDirectoryContents path) + where f filename = filename /= "." && filename /= ".." +#endif ------------------------------------------------------------------------------ -- * Overall building strategy. @@ -352,7 +366,9 @@ -- elab_config = elab { - elabBuildTargets = [], + elabBuildTargets = [], + elabTestTargets = [], + elabBenchTargets = [], elabReplTarget = Nothing, elabBuildHaddocks = False } @@ -510,6 +526,7 @@ -- rebuildTargets :: Verbosity -> DistDirLayout + -> StoreDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> BuildStatusMap @@ -517,6 +534,7 @@ -> IO BuildOutcomes rebuildTargets verbosity distDirLayout@DistDirLayout{..} + storeDirLayout installPlan sharedPackageConfig@ElaboratedSharedConfig { pkgConfigCompiler = compiler, @@ -537,6 +555,12 @@ cacheLock <- newLock -- serialise access to setup exe cache --TODO: [code cleanup] eliminate setup exe cache + debug verbosity $ + "Executing install plan " + ++ if isParallelBuild + then " in parallel using " ++ show buildSettingNumJobs ++ " threads." + else " serially." + createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory createDirectoryIfMissingVerbose verbosity True distTempDirectory mapM_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse @@ -559,10 +583,11 @@ rebuildTarget verbosity distDirLayout + storeDirLayout buildSettings downloadMap registerLock cacheLock sharedPackageConfig - pkg + installPlan pkg pkgBuildStatus where isParallelBuild = buildSettingNumJobs >= 2 @@ -573,28 +598,46 @@ (Set.toList . Set.fromList) [ pkgdb | InstallPlan.Configured elab <- InstallPlan.toList installPlan - , (pkgdb:_) <- map reverse [ elabBuildPackageDBStack elab, - elabRegisterPackageDBStack elab, - elabSetupPackageDBStack elab ] + , pkgdb <- concat [ elabBuildPackageDBStack elab + , elabRegisterPackageDBStack elab + , elabSetupPackageDBStack elab ] ] + +-- | Create a package DB if it does not currently exist. Note that this action +-- is /not/ safe to run concurrently. +-- +createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb + -> PackageDB -> IO () +createPackageDBIfMissing verbosity compiler progdb + (SpecificPackageDB dbPath) = do + exists <- Cabal.doesPackageDBExist dbPath + unless exists $ do + createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) + Cabal.createPackageDB verbosity compiler progdb False dbPath +createPackageDBIfMissing _ _ _ _ = return () + + -- | Given all the context and resources, (re)build an individual package. -- rebuildTarget :: Verbosity -> DistDirLayout + -> StoreDirLayout -> BuildTimeSettings -> AsyncFetchMap -> Lock -> Lock -> ElaboratedSharedConfig + -> ElaboratedInstallPlan -> ElaboratedReadyPackage -> BuildStatus -> IO BuildResult rebuildTarget verbosity distDirLayout@DistDirLayout{distBuildDirectory} + storeDirLayout buildSettings downloadMap registerLock cacheLock sharedPackageConfig - rpkg@(ReadyPackage pkg) + plan rpkg@(ReadyPackage pkg) pkgBuildStatus = -- We rely on the 'BuildStatus' to decide which phase to start from: @@ -643,7 +686,7 @@ buildAndInstall srcdir builddir = buildAndInstallUnpackedPackage - verbosity distDirLayout + verbosity distDirLayout storeDirLayout buildSettings registerLock cacheLock sharedPackageConfig rpkg @@ -658,12 +701,13 @@ verbosity distDirLayout buildSettings registerLock cacheLock sharedPackageConfig - rpkg + plan rpkg buildStatus srcdir builddir ---TODO: [nice to have] do we need to use a with-style for the temp files for downloading http --- packages, or are we going to cache them persistently? +-- TODO: [nice to have] do we need to use a with-style for the temp +-- files for downloading http packages, or are we going to cache them +-- persistently? -- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the -- packages we have to download and fork off an async action to download them. @@ -794,8 +838,8 @@ -- Sanity check -- exists <- doesFileExist cabalFile - when (not exists) $ - die $ "Package .cabal file not found in the tarball: " ++ cabalFile + unless exists $ + die' verbosity $ "Package .cabal file not found in the tarball: " ++ cabalFile -- Overwrite the .cabal with the one from the index, when appropriate -- @@ -837,6 +881,7 @@ buildAndInstallUnpackedPackage :: Verbosity -> DistDirLayout + -> StoreDirLayout -> BuildTimeSettings -> Lock -> Lock -> ElaboratedSharedConfig -> ElaboratedReadyPackage @@ -844,6 +889,9 @@ -> IO BuildResult buildAndInstallUnpackedPackage verbosity DistDirLayout{distTempDirectory} + storeDirLayout@StoreDirLayout { + storePackageDBStack + } BuildTimeSettings { buildSettingNumJobs, buildSettingLogFile @@ -872,7 +920,7 @@ let dispname = case elabPkgOrComp pkg of ElabPackage _ -> display pkgid - ++ " (all, due to Custom setup)" + ++ " (all, legacy fallback)" ElabComponent comp -> display pkgid ++ " (" ++ maybe "custom" display (compComponentName comp) ++ ")" @@ -890,41 +938,72 @@ -- Install phase annotateFailure mlogFile InstallFailed $ do - --TODO: [required eventually] need to lock installing this ipkig so other processes don't - -- stomp on our files, since we don't have ABI compat, not safe to replace - -- TODO: [required eventually] note that for nix-style installations it is not necessary to do - -- the 'withWin32SelfUpgrade' dance, but it would be necessary for a - -- shared bin dir. + let copyPkgFiles tmpDir = do + setup Cabal.copyCommand (copyFlags tmpDir) + -- Note that the copy command has put the files into + -- @$tmpDir/$prefix@ so we need to return this dir so + -- the store knows which dir will be the final store entry. + let prefix = dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) + entryDir = tmpDir prefix + LBS.writeFile + (entryDir "cabal-hash.txt") + (renderPackageHashInputs (packageHashInputs pkgshared pkg)) - -- Actual installation - setup Cabal.copyCommand copyFlags + -- Ensure that there are no files in `tmpDir`, that are not in `entryDir` + -- While this breaks the prefix-relocatable property of the lirbaries + -- it is necessary on macOS to stay under the load command limit of the + -- macOS mach-o linker. See also @PackageHash.hashedInstalledPackageIdVeryShort@. + otherFiles <- filter (not . isPrefixOf entryDir) <$> listFilesRecursive tmpDir + -- here's where we could keep track of the installed files ourselves + -- if we wanted to by making a manifest of the files in the tmp dir + return (entryDir, otherFiles) + where + listFilesRecursive :: FilePath -> IO [FilePath] + listFilesRecursive path = do + files <- fmap (path ) <$> (listDirectory path) + allFiles <- forM files $ \file -> do + isDir <- doesDirectoryExist file + if isDir + then listFilesRecursive file + else return [file] + return (concat allFiles) - LBS.writeFile - (InstallDirs.prefix (elabInstallDirs pkg) "cabal-hash.txt") $ - (renderPackageHashInputs (packageHashInputs pkgshared pkg)) + registerPkg + | not (elabRequiresRegistration pkg) = + debug verbosity $ + "registerPkg: elab does NOT require registration for " ++ display uid + | otherwise = do + -- We register ourselves rather than via Setup.hs. We need to + -- grab and modify the InstalledPackageInfo. We decide what + -- the installed package id is, not the build system. + ipkg0 <- generateInstalledPackageInfo + let ipkg = ipkg0 { Installed.installedUnitId = uid } + assert ( elabRegisterPackageDBStack pkg + == storePackageDBStack compid) (return ()) + criticalSection registerLock $ + Cabal.registerPackage + verbosity compiler progdb + (storePackageDBStack compid) ipkg + Cabal.defaultRegisterOptions { + Cabal.registerMultiInstance = True, + Cabal.registerSuppressFilesCheck = True + } - -- here's where we could keep track of the installed files ourselves if - -- we wanted by calling copy to an image dir and then we would make a - -- manifest and move it to its final location - --TODO: [nice to have] we should actually have it make an image in store/incomming and - -- then when it's done, move it to its final location, to reduce problems - -- with installs failing half-way. Could also register and then move. + -- Actual installation + void $ newStoreEntry verbosity storeDirLayout + compid uid + copyPkgFiles registerPkg - if elabRequiresRegistration pkg - then do - -- We register ourselves rather than via Setup.hs. We need to - -- grab and modify the InstalledPackageInfo. We decide what - -- the installed package id is, not the build system. - ipkg0 <- generateInstalledPackageInfo - let ipkg = ipkg0 { Installed.installedUnitId = uid } + --TODO: [nice to have] we currently rely on Setup.hs copy to do the right + -- thing. Although we do copy into an image dir and do the move into the + -- final location ourselves, perhaps we ought to do some sanity checks on + -- the image dir first. - criticalSection registerLock $ - Cabal.registerPackage verbosity compiler progdb - HcPkg.MultiInstance - (elabRegisterPackageDBStack pkg) ipkg - else return () + -- TODO: [required eventually] note that for nix-style installations it is not necessary to do + -- the 'withWin32SelfUpgrade' dance, but it would be necessary for a + -- shared bin dir. --TODO: [required feature] docs and test phases let docsResult = DocsNotTried @@ -938,7 +1017,8 @@ where pkgid = packageId rpkg - uid = installedUnitId rpkg + uid = installedUnitId rpkg + compid = compilerId compiler isParallelBuild = buildSettingNumJobs >= 2 @@ -961,7 +1041,8 @@ pkgConfDest setup Cabal.registerCommand registerFlags - copyFlags _ = setupHsCopyFlags pkg pkgshared verbosity builddir + copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity + builddir destdir scriptOptions = setupHsScriptOptions rpkg pkgshared srcdir builddir isParallelBuild cacheLock @@ -1002,6 +1083,7 @@ -> DistDirLayout -> BuildTimeSettings -> Lock -> Lock -> ElaboratedSharedConfig + -> ElaboratedInstallPlan -> ElaboratedReadyPackage -> BuildStatusRebuild -> FilePath -> FilePath @@ -1009,7 +1091,8 @@ buildInplaceUnpackedPackage verbosity distDirLayout@DistDirLayout { distTempDirectory, - distPackageCacheDirectory + distPackageCacheDirectory, + distDirectory } BuildTimeSettings{buildSettingNumJobs} registerLock cacheLock @@ -1017,6 +1100,7 @@ pkgConfigCompiler = compiler, pkgConfigCompilerProgs = progdb } + plan rpkg@(ReadyPackage pkg) buildStatus srcdir builddir = do @@ -1073,9 +1157,12 @@ | otherwise -> listSimple + let dep_monitors = map monitorFileHashed + $ elabInplaceDependencyBuildCacheFiles + distDirLayout pkgshared plan pkg updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp pkg buildStatus - monitors buildResult + (monitors ++ dep_monitors) buildResult -- PURPOSELY omitted: no copy! @@ -1089,15 +1176,23 @@ -- the installed package id is, not the build system. let ipkg = ipkg0 { Installed.installedUnitId = ipkgid } criticalSection registerLock $ - Cabal.registerPackage verbosity compiler progdb HcPkg.NoMultiInstance + Cabal.registerPackage verbosity compiler progdb (elabRegisterPackageDBStack pkg) - ipkg + ipkg Cabal.defaultRegisterOptions return (Just ipkg) else return Nothing updatePackageRegFileMonitor packageFileMonitor srcdir mipkg + whenTest $ do + annotateFailureNoLog TestsFailed $ + setup testCommand testFlags testArgs + + whenBench $ + annotateFailureNoLog BenchFailed $ + setup benchCommand benchFlags benchArgs + -- Repl phase -- whenRepl $ @@ -1106,8 +1201,15 @@ -- Haddock phase whenHaddock $ - annotateFailureNoLog HaddocksFailed $ - setup haddockCommand haddockFlags [] + annotateFailureNoLog HaddocksFailed $ do + setup haddockCommand haddockFlags [] + let haddockTarget = elabHaddockForHackage pkg + when (haddockTarget == Cabal.ForHackage) $ do + let dest = distDirectory name <.> "tar.gz" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = distBuildDirectory distDirLayout dparams "doc" "html" + Tar.createTarGzFile dest docDir name + notice verbosity $ "Documentation tarball created: " ++ dest return BuildResult { buildResultDocs = docsResult, @@ -1128,9 +1230,20 @@ _ -> return () whenRebuild action - | null (elabBuildTargets pkg) = return () + | null (elabBuildTargets pkg) + -- NB: we have to build the test/bench suite! + , null (elabTestTargets pkg) + , null (elabBenchTargets pkg) = return () + | otherwise = action + + whenTest action + | null (elabTestTargets pkg) = return () | otherwise = action + whenBench action + | null (elabBenchTargets pkg) = return () + | otherwise = action + whenRepl action | isNothing (elabReplTarget pkg) = return () | otherwise = action @@ -1142,9 +1255,9 @@ whenReRegister action = case buildStatus of -- We registered the package already - BuildStatusBuild (Just _) _ -> return () + BuildStatusBuild (Just _) _ -> info verbosity "whenReRegister: previously registered" -- There is nothing to register - _ | null (elabBuildTargets pkg) -> return () + _ | null (elabBuildTargets pkg) -> info verbosity "whenReRegister: nothing to register" | otherwise -> action configureCommand = Cabal.configureCommand defaultProgramDb @@ -1158,6 +1271,16 @@ verbosity builddir buildArgs = setupHsBuildArgs pkg + testCommand = Cabal.testCommand -- defaultProgramDb + testFlags _ = setupHsTestFlags pkg pkgshared + verbosity builddir + testArgs = setupHsTestArgs pkg + + benchCommand = Cabal.benchmarkCommand + benchFlags _ = setupHsBenchFlags pkg pkgshared + verbosity builddir + benchArgs = setupHsBenchArgs pkg + replCommand = Cabal.replCommand defaultProgramDb replFlags _ = setupHsReplFlags pkg pkgshared verbosity builddir @@ -1211,7 +1334,7 @@ where pkgConfParseFailed :: Installed.PError -> IO a pkgConfParseFailed perror = - die $ "Couldn't parse the output of 'setup register --gen-pkg-config':" + die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':" ++ show perror readPkgConf pkgConfDir pkgConfFile = do diff --git a/cabal/cabal-install/Distribution/Client/ProjectBuilding/Types.hs b/cabal/cabal-install/Distribution/Client/ProjectBuilding/Types.hs --- a/cabal/cabal-install/Distribution/Client/ProjectBuilding/Types.hs +++ b/cabal/cabal-install/Distribution/Client/ProjectBuilding/Types.hs @@ -201,6 +201,7 @@ | ReplFailed SomeException | HaddocksFailed SomeException | TestsFailed SomeException + | BenchFailed SomeException | InstallFailed SomeException deriving Show 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 @@ -13,9 +13,15 @@ MapLast(..), MapMappend(..), - -- * Project config files + -- * Project root findProjectRoot, + ProjectRoot(..), + BadProjectRoot(..), + + -- * Project config files readProjectConfig, + readGlobalConfig, + readProjectLocalFreezeConfig, writeProjectLocalExtraConfig, writeProjectLocalFreezeConfig, writeProjectConfigFile, @@ -54,47 +60,48 @@ import Distribution.Client.Types import Distribution.Client.DistDirLayout - ( CabalDirLayout(..) ) + ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..) ) import Distribution.Client.GlobalFlags ( RepoContext(..), withRepoContext' ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.Config - ( loadConfig, defaultConfigFile ) -import Distribution.Client.IndexUtils.Timestamp - ( IndexState(..) ) + ( loadConfig, getConfigFilePath ) import Distribution.Solver.Types.SourcePackage import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty(..) ) import Distribution.Package - ( PackageName, PackageId, packageId, UnitId, Dependency ) + ( PackageName, PackageId, packageId, UnitId ) +import Distribution.Types.Dependency import Distribution.System ( Platform ) import Distribution.PackageDescription ( SourceRepo(..) ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription ) import Distribution.Simple.Compiler ( Compiler, compilerInfo ) import Distribution.Simple.Program ( ConfiguredProgram(..) ) import Distribution.Simple.Setup ( Flag(Flag), toFlag, flagToMaybe, flagToList - , fromFlag, fromFlagOrDefault, AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) + , fromFlag, fromFlagOrDefault ) import Distribution.Client.Setup - ( defaultSolver, defaultMaxBackjumps, ) + ( defaultSolver, defaultMaxBackjumps ) import Distribution.Simple.InstallDirs ( PathTemplate, fromPathTemplate , toPathTemplate, substPathTemplate, initialPathTemplateEnv ) import Distribution.Simple.Utils - ( die, warn ) + ( die', warn ) import Distribution.Client.Utils ( determineNumJobs ) import Distribution.Utils.NubList ( fromNubList ) import Distribution.Verbosity - ( Verbosity, verbose ) + ( Verbosity, modifyVerbosity, verbose ) import Distribution.Text import Distribution.ParseUtils ( ParseResult(..), locatedErrorMsg, showPWarning ) @@ -102,7 +109,6 @@ import Control.Monad import Control.Monad.Trans (liftIO) import Control.Exception -import Data.Maybe import Data.Either import qualified Data.Map as Map import Data.Set (Set) @@ -192,16 +198,17 @@ (getMapMappend projectConfigSpecificPackage) solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion solverSettingSolver = fromFlag projectConfigSolver - solverSettingAllowOlder = fromJust projectConfigAllowOlder - solverSettingAllowNewer = fromJust projectConfigAllowNewer + solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder + solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of n | n < 0 -> Nothing | otherwise -> Just n solverSettingReorderGoals = fromFlag projectConfigReorderGoals solverSettingCountConflicts = fromFlag projectConfigCountConflicts solverSettingStrongFlags = fromFlag projectConfigStrongFlags - solverSettingIndexState = fromFlagOrDefault IndexStateHead projectConfigIndexState - --solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals + solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls + solverSettingIndexState = flagToMaybe projectConfigIndexState + solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals --solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs --solverSettingReinstall = fromFlag projectConfigReinstall --solverSettingAvoidReinstalls = fromFlag projectConfigAvoidReinstalls @@ -212,13 +219,14 @@ defaults = mempty { projectConfigSolver = Flag defaultSolver, - projectConfigAllowOlder = Just (AllowOlder RelaxDepsNone), - projectConfigAllowNewer = Just (AllowNewer RelaxDepsNone), + projectConfigAllowOlder = Just (AllowOlder mempty), + projectConfigAllowNewer = Just (AllowNewer mempty), projectConfigMaxBackjumps = Flag defaultMaxBackjumps, projectConfigReorderGoals = Flag (ReorderGoals False), projectConfigCountConflicts = Flag (CountConflicts True), - projectConfigStrongFlags = Flag (StrongFlags False) - --projectConfigIndependentGoals = Flag False, + projectConfigStrongFlags = Flag (StrongFlags False), + projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + projectConfigIndependentGoals = Flag (IndependentGoals False) --projectConfigShadowPkgs = Flag False, --projectConfigReinstall = Flag False, --projectConfigAvoidReinstalls = Flag False, @@ -232,20 +240,19 @@ -- resolveBuildTimeSettings :: Verbosity -> CabalDirLayout - -> ProjectConfigShared - -> ProjectConfigBuildOnly - -> ProjectConfigBuildOnly + -> ProjectConfig -> BuildTimeSettings resolveBuildTimeSettings verbosity CabalDirLayout { cabalLogsDirectory } - ProjectConfigShared { - projectConfigRemoteRepos, - projectConfigLocalRepos - } - fromProjectFile - fromCommandLine = + ProjectConfig { + projectConfigShared = ProjectConfigShared { + projectConfigRemoteRepos, + projectConfigLocalRepos + }, + projectConfigBuildOnly + } = BuildTimeSettings {..} where buildSettingDryRun = fromFlag projectConfigDryRun @@ -269,8 +276,7 @@ = fromFlag projectConfigReportPlanningFailure ProjectConfigBuildOnly{..} = defaults - <> fromProjectFile - <> fromCommandLine + <> projectConfigBuildOnly defaults = mempty { projectConfigDryRun = toFlag False, @@ -323,7 +329,7 @@ -- --build-log, use more verbose logging. -- buildSettingLogVerbosity - | overrideVerbosity = max verbose verbosity + | overrideVerbosity = modifyVerbosity (max verbose) verbosity | otherwise = verbosity overrideVerbosity @@ -343,43 +349,82 @@ -- parent directories. If no project file is found then the current dir is the -- project root (and the project will use an implicit config). -- -findProjectRoot :: IO FilePath -findProjectRoot = do +findProjectRoot :: Maybe FilePath -- ^ starting directory, or current directory + -> Maybe FilePath -- ^ @cabal.project@ file name override + -> IO (Either BadProjectRoot ProjectRoot) +findProjectRoot _ (Just projectFile) + | isAbsolute projectFile = do + exists <- doesFileExist projectFile + if exists + then do projectFile' <- canonicalizePath projectFile + let projectRoot = ProjectRootExplicit (takeDirectory projectFile') + (takeFileName projectFile') + return (Right projectRoot) + else return (Left (BadProjectRootExplicitFile projectFile)) - curdir <- getCurrentDirectory - homedir <- getHomeDirectory +findProjectRoot mstartdir mprojectFile = do + startdir <- maybe getCurrentDirectory canonicalizePath mstartdir + homedir <- getHomeDirectory + probe startdir homedir + where + projectFileName = fromMaybe "cabal.project" mprojectFile -- Search upwards. If we get to the users home dir or the filesystem root, -- then use the current dir - let probe dir | isDrive dir || dir == homedir - = return curdir -- implicit project root - probe dir = do - exists <- doesFileExist (dir "cabal.project") + probe startdir homedir = go startdir + where + go dir | isDrive dir || dir == homedir = + case mprojectFile of + Nothing -> return (Right (ProjectRootImplicit startdir)) + Just file -> return (Left (BadProjectRootExplicitFile file)) + go dir = do + exists <- doesFileExist (dir projectFileName) if exists - then return dir -- explicit project root - else probe (takeDirectory dir) + then return (Right (ProjectRootExplicit dir projectFileName)) + else go (takeDirectory dir) - probe curdir --TODO: [nice to have] add compat support for old style sandboxes +-- | Errors returned by 'findProjectRoot'. +-- +data BadProjectRoot = BadProjectRootExplicitFile FilePath +#if MIN_VERSION_base(4,8,0) + deriving (Show, Typeable) +#else + deriving (Typeable) + +instance Show BadProjectRoot where + show = renderBadProjectRoot +#endif + +instance Exception BadProjectRoot where +#if MIN_VERSION_base(4,8,0) + displayException = renderBadProjectRoot +#endif + +renderBadProjectRoot :: BadProjectRoot -> String +renderBadProjectRoot (BadProjectRootExplicitFile projectFile) = + "The given project file '" ++ projectFile ++ "' does not exist." + + -- | Read all the config relevant for a project. This includes the project -- file if any, plus other global config. -- -readProjectConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig -readProjectConfig verbosity projectRootDir = do - global <- readGlobalConfig verbosity - local <- readProjectLocalConfig verbosity projectRootDir - freeze <- readProjectLocalFreezeConfig verbosity projectRootDir - extra <- readProjectLocalExtraConfig verbosity projectRootDir +readProjectConfig :: Verbosity -> Flag FilePath -> DistDirLayout -> Rebuild ProjectConfig +readProjectConfig verbosity configFileFlag distDirLayout = do + global <- readGlobalConfig verbosity configFileFlag + local <- readProjectLocalConfig verbosity distDirLayout + freeze <- readProjectLocalFreezeConfig verbosity distDirLayout + extra <- readProjectLocalExtraConfig verbosity distDirLayout return (global <> local <> freeze <> extra) -- | Reads an explicit @cabal.project@ file in the given project root dir, -- or returns the default project config for an implicitly defined project. -- -readProjectLocalConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig -readProjectLocalConfig verbosity projectRootDir = do +readProjectLocalConfig :: Verbosity -> DistDirLayout -> Rebuild ProjectConfig +readProjectLocalConfig verbosity DistDirLayout{distProjectFile} = do usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile if usesExplicitProjectRoot then do @@ -390,7 +435,7 @@ return defaultImplicitProjectConfig where - projectFile = projectRootDir "cabal.project" + projectFile = distProjectFile "" readProjectFile = reportParseResult verbosity "project file" projectFile . parseProjectConfig @@ -418,26 +463,28 @@ -- or returns empty. This file gets written by @cabal configure@, or in -- principle can be edited manually or by other tools. -- -readProjectLocalExtraConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig -readProjectLocalExtraConfig verbosity = - readProjectExtensionFile verbosity "local" +readProjectLocalExtraConfig :: Verbosity -> DistDirLayout + -> Rebuild ProjectConfig +readProjectLocalExtraConfig verbosity distDirLayout = + readProjectExtensionFile verbosity distDirLayout "local" "project local configuration file" -- | Reads a @cabal.project.freeze@ file in the given project root dir, -- or returns empty. This file gets written by @cabal freeze@, or in -- principle can be edited manually or by other tools. -- -readProjectLocalFreezeConfig :: Verbosity -> FilePath -> Rebuild ProjectConfig -readProjectLocalFreezeConfig verbosity = - readProjectExtensionFile verbosity "freeze" +readProjectLocalFreezeConfig :: Verbosity -> DistDirLayout + -> Rebuild ProjectConfig +readProjectLocalFreezeConfig verbosity distDirLayout = + readProjectExtensionFile verbosity distDirLayout "freeze" "project freeze file" -- | Reads a named config file in the given project root dir, or returns empty. -- -readProjectExtensionFile :: Verbosity -> String -> FilePath - -> FilePath -> Rebuild ProjectConfig -readProjectExtensionFile verbosity extensionName extensionDescription - projectRootDir = do +readProjectExtensionFile :: Verbosity -> DistDirLayout -> String -> FilePath + -> Rebuild ProjectConfig +readProjectExtensionFile verbosity DistDirLayout{distProjectFile} + extensionName extensionDescription = do exists <- liftIO $ doesFileExist extensionFile if exists then do monitorFiles [monitorFileHashed extensionFile] @@ -445,7 +492,7 @@ else do monitorFiles [monitorNonExistentFile extensionFile] return mempty where - extensionFile = projectRootDir "cabal.project" <.> extensionName + extensionFile = distProjectFile extensionName readExtensionFile = reportParseResult verbosity extensionDescription extensionFile @@ -476,20 +523,16 @@ -- | Write a @cabal.project.local@ file in the given project root dir. -- -writeProjectLocalExtraConfig :: FilePath -> ProjectConfig -> IO () -writeProjectLocalExtraConfig projectRootDir = - writeProjectConfigFile projectExtraConfigFile - where - projectExtraConfigFile = projectRootDir "cabal.project.local" +writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO () +writeProjectLocalExtraConfig DistDirLayout{distProjectFile} = + writeProjectConfigFile (distProjectFile "local") -- | Write a @cabal.project.freeze@ file in the given project root dir. -- -writeProjectLocalFreezeConfig :: FilePath -> ProjectConfig -> IO () -writeProjectLocalFreezeConfig projectRootDir = - writeProjectConfigFile projectFreezeConfigFile - where - projectFreezeConfigFile = projectRootDir "cabal.project.freeze" +writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO () +writeProjectLocalFreezeConfig DistDirLayout{distProjectFile} = + writeProjectConfigFile (distProjectFile "freeze") -- | Write in the @cabal.project@ format to the given file. @@ -501,25 +544,22 @@ -- | Read the user's @~/.cabal/config@ file. -- -readGlobalConfig :: Verbosity -> Rebuild ProjectConfig -readGlobalConfig verbosity = do - config <- liftIO (loadConfig verbosity mempty) - configFile <- liftIO defaultConfigFile +readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig +readGlobalConfig verbosity configFileFlag = do + config <- liftIO (loadConfig verbosity configFileFlag) + configFile <- liftIO (getConfigFilePath configFileFlag) monitorFiles [monitorFileHashed configFile] return (convertLegacyGlobalConfig config) - --TODO: do this properly, there's several possible locations - -- and env vars, and flags for selecting the global config - reportParseResult :: Verbosity -> String -> FilePath -> ParseResult a -> IO a reportParseResult verbosity _filetype filename (ParseOk warnings x) = do unless (null warnings) $ let msg = unlines (map (showPWarning filename) warnings) in warn verbosity msg return x -reportParseResult _verbosity filetype filename (ParseFailed err) = +reportParseResult verbosity filetype filename (ParseFailed err) = let (line, msg) = locatedErrorMsg err - in die $ "Error parsing " ++ filetype ++ " " ++ filename + in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg @@ -670,9 +710,10 @@ -- -- Throws 'BadPackageLocations'. -- -findProjectPackages :: FilePath -> ProjectConfig +findProjectPackages :: DistDirLayout -> ProjectConfig -> Rebuild [ProjectPackageLocation] -findProjectPackages projectRootDir ProjectConfig{..} = do +findProjectPackages DistDirLayout{distProjectRootDirectory} + ProjectConfig{..} = do requiredPkgs <- findPackageLocations True projectPackages optionalPkgs <- findPackageLocations False projectPackagesOptional @@ -715,29 +756,30 @@ :: String -> Rebuild (Maybe (Either BadPackageLocation [ProjectPackageLocation])) checkIsUriPackage pkglocstr = - return $! case parseAbsoluteURI pkglocstr of Just uri@URI { uriScheme = scheme, - uriAuthority = Just URIAuth { uriRegName = host } + uriAuthority = Just URIAuth { uriRegName = host }, + uriPath = path, + uriQuery = query, + uriFragment = frag } | recognisedScheme && not (null host) -> - Just (Right [ProjectPackageRemoteTarball uri]) + return (Just (Right [ProjectPackageRemoteTarball uri])) - --TODO: [required eventually] handle file: urls which do have a null - -- host. translate URI into filepath and use ProjectPackageLocalTarball - -- or keep as file url and use ProjectPackageRemoteTarball? + | scheme == "file:" && null host && null query && null frag -> + checkIsSingleFilePackage path | not recognisedScheme && not (null host) -> - Just (Left (BadLocUnexpectedUriScheme pkglocstr)) + return (Just (Left (BadLocUnexpectedUriScheme pkglocstr))) | recognisedScheme && null host -> - Just (Left (BadLocUnrecognisedUri pkglocstr)) + return (Just (Left (BadLocUnrecognisedUri pkglocstr))) where recognisedScheme = scheme == "http:" || scheme == "https:" || scheme == "file:" - _ -> Nothing + _ -> return Nothing checkIsFileGlobPackage pkglocstr = @@ -763,7 +805,7 @@ checkIsSingleFilePackage pkglocstr = do - let filename = projectRootDir pkglocstr + let filename = distProjectRootDirectory pkglocstr isFile <- liftIO $ doesFileExist filename isDir <- liftIO $ doesDirectoryExist filename if isFile || isDir @@ -779,7 +821,7 @@ -- The pkglocstr may be absolute or may be relative to the project root. -- Either way, does the right thing here. We return relative paths if -- they were relative in the first place. - let abspath = projectRootDir pkglocstr + let abspath = distProjectRootDirectory pkglocstr isFile <- liftIO $ doesFileExist abspath isDir <- liftIO $ doesDirectoryExist abspath parentDirExists <- case takeDirectory abspath of @@ -845,7 +887,7 @@ -- paths. -- readSourcePackage :: Verbosity -> ProjectPackageLocation - -> Rebuild UnresolvedSourcePackage + -> Rebuild (PackageSpecifier UnresolvedSourcePackage) readSourcePackage verbosity (ProjectPackageLocalCabalFile cabalFile) = readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile) where @@ -854,16 +896,28 @@ readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile) = do monitorFiles [monitorFileHashed cabalFile] root <- askRoot - pkgdesc <- liftIO $ readPackageDescription verbosity (root cabalFile) - return SourcePackage { + pkgdesc <- liftIO $ readGenericPackageDescription verbosity (root cabalFile) + return $ SpecificSourcePackage SourcePackage { packageInfoId = packageId pkgdesc, packageDescription = pkgdesc, packageSource = LocalUnpackedPackage (root dir), packageDescrOverride = Nothing } + +readSourcePackage _ (ProjectPackageNamed (Dependency pkgname verrange)) = + return $ NamedPackage pkgname [PackagePropertyVersion verrange] + readSourcePackage _verbosity _ = fail $ "TODO: add support for fetching and reading local tarballs, remote " ++ "tarballs, remote repos and passing named packages through" + + +-- TODO: add something like this, here or in the project planning +-- Based on the package location, which packages will be built inplace in the +-- build tree vs placed in the store. This has various implications on what we +-- can do with the package, e.g. can we run tests, ghci etc. +-- +-- packageIsLocalToProject :: ProjectPackageLocation -> Bool --------------------------------------------- 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 @@ -25,7 +25,9 @@ import Distribution.Client.ProjectConfig.Types import Distribution.Client.Types - ( RemoteRepo(..), emptyRemoteRepo ) + ( RemoteRepo(..), emptyRemoteRepo + , AllowNewer(..), AllowOlder(..) ) + import Distribution.Client.Config ( SavedConfig(..), remoteRepoFields ) @@ -33,7 +35,8 @@ import Distribution.Package import Distribution.PackageDescription - ( SourceRepo(..), RepoKind(..) ) + ( SourceRepo(..), RepoKind(..) + , dispFlagAssignment, parseFlagAssignment ) import Distribution.PackageDescription.Parse ( sourceRepoFieldDescrs ) import Distribution.Simple.Compiler @@ -43,7 +46,7 @@ , ConfigFlags(..), configureOptions , HaddockFlags(..), haddockOptions, defaultHaddockFlags , programDbPaths', splitArgs - , AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) + ) import Distribution.Client.Setup ( GlobalFlags(..), globalCommand , ConfigExFlags(..), configureExOptions, defaultConfigExFlags @@ -52,8 +55,6 @@ ( programName, knownPrograms ) import Distribution.Simple.Program.Db ( ProgramDb, defaultProgramDb ) -import Distribution.Client.Targets - ( dispFlagAssignment, parseFlagAssignment ) import Distribution.Simple.Utils ( lowercase ) import Distribution.Utils.NubList @@ -269,31 +270,33 @@ ProjectConfigShared{..} where GlobalFlags { - globalConfigFile = _, -- TODO: [required feature] + globalConfigFile = projectConfigConfigFile, globalSandboxConfigFile = _, -- ?? globalRemoteRepos = projectConfigRemoteRepos, globalLocalRepos = projectConfigLocalRepos } = globalFlags ConfigFlags { + configDistPref = projectConfigDistDir, configHcFlavor = projectConfigHcFlavor, configHcPath = projectConfigHcPath, - configHcPkg = projectConfigHcPkg, + configHcPkg = projectConfigHcPkg --configInstallDirs = projectConfigInstallDirs, --configUserInstall = projectConfigUserInstall, --configPackageDBs = projectConfigPackageDBs, - configAllowOlder = projectConfigAllowOlder, - configAllowNewer = projectConfigAllowNewer } = configFlags ConfigExFlags { configCabalVersion = projectConfigCabalVersion, configExConstraints = projectConfigConstraints, configPreferences = projectConfigPreferences, - configSolver = projectConfigSolver + configSolver = projectConfigSolver, + configAllowOlder = projectConfigAllowOlder, + configAllowNewer = projectConfigAllowNewer } = configExFlags InstallFlags { + installProjectFileName = projectConfigProjectFile, installHaddockIndex = projectConfigHaddockIndex, --installReinstall = projectConfigReinstall, --installAvoidReinstalls = projectConfigAvoidReinstalls, @@ -303,9 +306,11 @@ --installUpgradeDeps = projectConfigUpgradeDeps, installReorderGoals = projectConfigReorderGoals, installCountConflicts = projectConfigCountConflicts, - --installIndependentGoals = projectConfigIndependentGoals, + installPerComponent = projectConfigPerComponent, + installIndependentGoals = projectConfigIndependentGoals, --installShadowPkgs = projectConfigShadowPkgs, - installStrongFlags = projectConfigStrongFlags + installStrongFlags = projectConfigStrongFlags, + installAllowBootLibInstalls = projectConfigAllowBootLibInstalls } = installFlags @@ -325,6 +330,7 @@ configVanillaLib = packageConfigVanillaLib, configProfLib = packageConfigProfLib, configSharedLib = packageConfigSharedLib, + configStaticLib = packageConfigStaticLib, configDynExe = packageConfigDynExe, configProfExe = packageConfigProfExe, configProf = packageConfigProf, @@ -335,6 +341,7 @@ configProgPrefix = packageConfigProgPrefix, configProgSuffix = packageConfigProgSuffix, configGHCiLib = packageConfigGHCiLib, + configSplitSections = packageConfigSplitSections, configSplitObjs = packageConfigSplitObjs, configStripExes = packageConfigStripExes, configStripLibs = packageConfigStripLibs, @@ -365,6 +372,7 @@ haddockHtml = packageConfigHaddockHtml, haddockHtmlLocation = packageConfigHaddockHtmlLocation, haddockForeignLibs = packageConfigHaddockForeignLibs, + haddockForHackage = packageConfigHaddockForHackage, haddockExecutables = packageConfigHaddockExecutables, haddockTestSuites = packageConfigHaddockTestSuites, haddockBenchmarks = packageConfigHaddockBenchmarks, @@ -392,7 +400,8 @@ globalLogsDir = projectConfigLogsDir, globalWorldFile = _, globalHttpTransport = projectConfigHttpTransport, - globalIgnoreExpiry = projectConfigIgnoreExpiry + globalIgnoreExpiry = projectConfigIgnoreExpiry, + globalStoreDir = projectConfigStoreDir } = globalFlags ConfigFlags { @@ -460,7 +469,7 @@ globalFlags = GlobalFlags { globalVersion = mempty, globalNumericVersion = mempty, - globalConfigFile = mempty, + globalConfigFile = projectConfigConfigFile, globalSandboxConfigFile = mempty, globalConstraintsFile = mempty, globalRemoteRepos = projectConfigRemoteRepos, @@ -471,20 +480,24 @@ globalRequireSandbox = mempty, globalIgnoreSandbox = mempty, globalIgnoreExpiry = projectConfigIgnoreExpiry, - globalHttpTransport = projectConfigHttpTransport + globalHttpTransport = projectConfigHttpTransport, + globalNix = mempty, + globalStoreDir = projectConfigStoreDir } configFlags = mempty { configVerbosity = projectConfigVerbosity, - configAllowOlder = projectConfigAllowOlder, - configAllowNewer = projectConfigAllowNewer + configDistPref = projectConfigDistDir } configExFlags = ConfigExFlags { configCabalVersion = projectConfigCabalVersion, configExConstraints = projectConfigConstraints, configPreferences = projectConfigPreferences, - configSolver = projectConfigSolver + configSolver = projectConfigSolver, + configAllowOlder = projectConfigAllowOlder, + configAllowNewer = projectConfigAllowNewer + } installFlags = InstallFlags { @@ -498,9 +511,10 @@ installUpgradeDeps = mempty, --projectConfigUpgradeDeps, installReorderGoals = projectConfigReorderGoals, installCountConflicts = projectConfigCountConflicts, - installIndependentGoals = mempty, --projectConfigIndependentGoals, + installIndependentGoals = projectConfigIndependentGoals, installShadowPkgs = mempty, --projectConfigShadowPkgs, installStrongFlags = projectConfigStrongFlags, + installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, installOnly = mempty, installOnlyDeps = projectConfigOnlyDeps, installIndexState = projectConfigIndexState, @@ -510,11 +524,13 @@ installBuildReports = projectConfigBuildReports, installReportPlanningFailure = projectConfigReportPlanningFailure, installSymlinkBinDir = projectConfigSymlinkBinDir, + installPerComponent = projectConfigPerComponent, installOneShot = projectConfigOneShot, installNumJobs = projectConfigNumJobs, installKeepGoing = projectConfigKeepGoing, installRunTests = mempty, - installOfflineMode = projectConfigOfflineMode + installOfflineMode = projectConfigOfflineMode, + installProjectFileName = projectConfigProjectFile } @@ -544,6 +560,7 @@ configVanillaLib = mempty, configProfLib = mempty, configSharedLib = mempty, + configStaticLib = mempty, configDynExe = mempty, configProfExe = mempty, configProf = mempty, @@ -561,6 +578,7 @@ configUserInstall = mempty, --projectConfigUserInstall, configPackageDBs = mempty, --projectConfigPackageDBs, configGHCiLib = mempty, + configSplitSections = mempty, configSplitObjs = mempty, configStripExes = mempty, configStripLibs = mempty, @@ -569,6 +587,7 @@ configConstraints = mempty, configDependencies = mempty, configExtraIncludeDirs = mempty, + configDeterministic = mempty, configIPID = mempty, configCID = mempty, configConfigurationsFlags = mempty, @@ -580,8 +599,7 @@ configFlagError = mempty, --TODO: ??? configRelocatable = mempty, configDebugInfo = mempty, - configAllowOlder = mempty, - configAllowNewer = mempty + configUseResponseFiles = mempty } haddockFlags = mempty { @@ -610,6 +628,7 @@ configVanillaLib = packageConfigVanillaLib, configProfLib = packageConfigProfLib, configSharedLib = packageConfigSharedLib, + configStaticLib = packageConfigStaticLib, configDynExe = packageConfigDynExe, configProfExe = packageConfigProfExe, configProf = packageConfigProf, @@ -627,6 +646,7 @@ configUserInstall = mempty, configPackageDBs = mempty, configGHCiLib = packageConfigGHCiLib, + configSplitSections = packageConfigSplitSections, configSplitObjs = packageConfigSplitObjs, configStripExes = packageConfigStripExes, configStripLibs = packageConfigStripLibs, @@ -637,6 +657,7 @@ configExtraIncludeDirs = packageConfigExtraIncludeDirs, configIPID = mempty, configCID = mempty, + configDeterministic = mempty, configConfigurationsFlags = packageConfigFlagAssignment, configTests = packageConfigTests, configCoverage = packageConfigCoverage, --TODO: don't merge @@ -646,8 +667,7 @@ configFlagError = mempty, --TODO: ??? configRelocatable = packageConfigRelocatable, configDebugInfo = packageConfigDebugInfo, - configAllowOlder = mempty, - configAllowNewer = mempty + configUseResponseFiles = mempty } installFlags = mempty { @@ -661,7 +681,7 @@ haddockHoogle = packageConfigHaddockHoogle, haddockHtml = packageConfigHaddockHtml, haddockHtmlLocation = packageConfigHaddockHtmlLocation, - haddockForHackage = mempty, --TODO: added recently + haddockForHackage = packageConfigHaddockForHackage, haddockForeignLibs = packageConfigHaddockForeignLibs, haddockExecutables = packageConfigHaddockExecutables, haddockTestSuites = packageConfigHaddockTestSuites, @@ -790,7 +810,7 @@ ] . filterFields [ "remote-repo-cache" - , "logs-dir", "ignore-expiry", "http-transport" + , "logs-dir", "store-dir", "ignore-expiry", "http-transport" ] . commandOptionsToFields ) (commandOptions (globalCommand []) ParseArgs) @@ -798,19 +818,7 @@ ( liftFields legacyConfigureShFlags (\flags conf -> conf { legacyConfigureShFlags = flags }) - . addFields - [ simpleField "allow-older" - (maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps) - (fmap unAllowOlder . configAllowOlder) - (\v conf -> conf { configAllowOlder = fmap AllowOlder v }) - ] - . addFields - [ simpleField "allow-newer" - (maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps) - (fmap unAllowNewer . configAllowNewer) - (\v conf -> conf { configAllowNewer = fmap AllowNewer v }) - ] - . filterFields ["verbose"] + . filterFields ["verbose", "builddir" ] . commandOptionsToFields ) (configureOptions ParseArgs) ++ @@ -825,6 +833,16 @@ , commaNewLineListField "preferences" disp parse configPreferences (\v conf -> conf { configPreferences = v }) + + , monoidField "allow-older" + (maybe mempty disp) (fmap Just parse) + (fmap unAllowOlder . configAllowOlder) + (\v conf -> conf { configAllowOlder = fmap AllowOlder v }) + + , monoidField "allow-newer" + (maybe mempty disp) (fmap Just parse) + (fmap unAllowNewer . configAllowNewer) + (\v conf -> conf { configAllowNewer = fmap AllowNewer v }) ] . filterFields [ "cabal-lib-version", "solver" @@ -847,29 +865,17 @@ , "root-cmd", "symlink-bindir" , "build-log" , "remote-build-reporting", "report-planning-failure" - , "one-shot", "jobs", "keep-going", "offline" + , "one-shot", "jobs", "keep-going", "offline", "per-component" -- solver flags: - , "max-backjumps", "reorder-goals", "count-conflicts", "strong-flags" - , "index-state" + , "max-backjumps", "reorder-goals", "count-conflicts", "independent-goals" + , "strong-flags" , "allow-boot-library-installs", "index-state" ] . commandOptionsToFields ) (installOptions ParseArgs) where constraintSrc = ConstraintSourceProjectConfig "TODO" -parseRelaxDeps :: ReadP r RelaxDeps -parseRelaxDeps = - ((const RelaxDepsNone <$> (Parse.string "none" +++ Parse.string "None")) - +++ (const RelaxDepsAll <$> (Parse.string "all" +++ Parse.string "All"))) - <++ ( RelaxDepsSome <$> parseOptCommaList parse) -dispRelaxDeps :: RelaxDeps -> Doc -dispRelaxDeps RelaxDepsNone = Disp.text "None" -dispRelaxDeps (RelaxDepsSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma - . map disp $ pkgs -dispRelaxDeps RelaxDepsAll = Disp.text "All" - - legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig] legacyPackageConfigFieldDescrs = ( liftFields @@ -905,10 +911,10 @@ [ "with-compiler", "with-hc-pkg" , "program-prefix", "program-suffix" , "library-vanilla", "library-profiling" - , "shared", "executable-dynamic" + , "shared", "static", "executable-dynamic" , "profiling", "executable-profiling" , "profiling-detail", "library-profiling-detail" - , "library-for-ghci", "split-objs" + , "library-for-ghci", "split-objs", "split-sections" , "executable-stripping", "library-stripping" , "tests", "benchmarks" , "coverage", "library-coverage" @@ -942,6 +948,12 @@ (\flags conf -> conf { legacyHaddockFlags = flags }) . mapFieldNames ("haddock-"++) + . addFields + [ simpleField "for-hackage" + -- TODO: turn this into a library function + (fromFlagOrDefault Disp.empty . fmap disp) (Parse.option mempty (fmap toFlag parse)) + haddockForHackage (\v conf -> conf { haddockForHackage = v }) + ] . filterFields [ "hoogle", "html", "html-location" , "foreign-libraries" @@ -1245,6 +1257,15 @@ where set' xs b = set (get' b ++ xs) b showF' = separator . map showF + +-- | Parser combinator for simple fields which uses the field type's +-- 'Monoid' instance for combining multiple occurences 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 = + liftField get' set' $ ParseUtils.field name showF readF + where + set' xs b = set (get' b `mappend` xs) b --TODO: [code cleanup] local redefinition that should replace the version in -- D.ParseUtils. This version avoid parse ambiguity for list element parsers 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 @@ -21,7 +21,7 @@ ) where import Distribution.Client.Types - ( RemoteRepo ) + ( RemoteRepo, AllowNewer(..), AllowOlder(..) ) import Distribution.Client.Dependency.Types ( PreSolver ) import Distribution.Client.Targets @@ -36,7 +36,8 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Package - ( PackageName, PackageId, UnitId, Dependency ) + ( PackageName, PackageId, UnitId ) +import Distribution.Types.Dependency import Distribution.Version ( Version ) import Distribution.System @@ -47,7 +48,7 @@ ( Compiler, CompilerFlavor , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) import Distribution.Simple.Setup - ( Flag, AllowNewer(..), AllowOlder(..) ) + ( Flag, HaddockTarget(..) ) import Distribution.Simple.InstallDirs ( PathTemplate ) import Distribution.Utils.NubList @@ -142,7 +143,8 @@ projectConfigHttpTransport :: Flag String, projectConfigIgnoreExpiry :: Flag Bool, projectConfigCacheDir :: Flag FilePath, - projectConfigLogsDir :: Flag FilePath + projectConfigLogsDir :: Flag FilePath, + projectConfigStoreDir :: Flag FilePath } deriving (Eq, Show, Generic) @@ -152,6 +154,9 @@ -- data ProjectConfigShared = ProjectConfigShared { + projectConfigDistDir :: Flag FilePath, + projectConfigConfigFile :: Flag FilePath, + projectConfigProjectFile :: Flag FilePath, projectConfigHcFlavor :: Flag CompilerFlavor, projectConfigHcPath :: Flag FilePath, projectConfigHcPkg :: Flag FilePath, @@ -180,11 +185,13 @@ projectConfigMaxBackjumps :: Flag Int, projectConfigReorderGoals :: Flag ReorderGoals, projectConfigCountConflicts :: Flag CountConflicts, - projectConfigStrongFlags :: Flag StrongFlags + projectConfigStrongFlags :: Flag StrongFlags, + projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls, + projectConfigPerComponent :: Flag Bool, + projectConfigIndependentGoals :: Flag IndependentGoals -- More things that only make sense for manual mode, not --local mode -- too much control! - --projectConfigIndependentGoals :: Flag Bool, --projectConfigShadowPkgs :: Flag Bool, --projectConfigReinstall :: Flag Bool, --projectConfigAvoidReinstalls :: Flag Bool, @@ -221,6 +228,7 @@ packageConfigFlagAssignment :: FlagAssignment, packageConfigVanillaLib :: Flag Bool, packageConfigSharedLib :: Flag Bool, + packageConfigStaticLib :: Flag Bool, packageConfigDynExe :: Flag Bool, packageConfigProf :: Flag Bool, --TODO: [code cleanup] sort out packageConfigProfLib :: Flag Bool, -- this duplication @@ -235,6 +243,7 @@ packageConfigExtraFrameworkDirs :: [FilePath], packageConfigExtraIncludeDirs :: [FilePath], packageConfigGHCiLib :: Flag Bool, + packageConfigSplitSections :: Flag Bool, packageConfigSplitObjs :: Flag Bool, packageConfigStripExes :: Flag Bool, packageConfigStripLibs :: Flag Bool, @@ -256,7 +265,8 @@ packageConfigHaddockCss :: Flag FilePath, --TODO: [required eventually] use this packageConfigHaddockHscolour :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockHscolourCss :: Flag FilePath, --TODO: [required eventually] use this - packageConfigHaddockContents :: Flag PathTemplate --TODO: [required eventually] use this + packageConfigHaddockContents :: Flag PathTemplate, --TODO: [required eventually] use this + packageConfigHaddockForHackage :: Flag HaddockTarget } deriving (Eq, Show, Generic) @@ -277,7 +287,7 @@ mappend = (<>) instance Ord k => Semigroup (MapLast k v) where - MapLast a <> MapLast b = MapLast (flip Map.union a b) + MapLast a <> MapLast b = MapLast $ Map.union b a -- rather than Map.union which is the normal Map monoid instance @@ -354,10 +364,11 @@ solverSettingReorderGoals :: ReorderGoals, solverSettingCountConflicts :: CountConflicts, solverSettingStrongFlags :: StrongFlags, - solverSettingIndexState :: IndexState + solverSettingAllowBootLibInstalls :: AllowBootLibInstalls, + solverSettingIndexState :: Maybe IndexState, + solverSettingIndependentGoals :: IndependentGoals -- Things that only make sense for manual mode, not --local mode -- too much control! - --solverSettingIndependentGoals :: Bool, --solverSettingShadowPkgs :: Bool, --solverSettingReinstall :: Bool, --solverSettingAvoidReinstalls :: Bool, 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 @@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} -- | This module deals with building and incrementally rebuilding a collection -- of packages. It is what backs the @cabal build@ and @configure@ commands, --- as well as being a core part of @run@, @test@, @bench@ and others. +-- as well as being a core part of @run@, @test@, @bench@ and others. -- -- The primary thing is in fact rebuilding (and trying to make that quick by -- not redoing unnecessary work), so building from scratch is just a special @@ -32,21 +33,54 @@ -- This division helps us keep the code under control, making it easier to -- understand, test and debug. So when you are extending these modules, please -- think about which parts of your change belong in which part. It is --- perfectly ok to extend the description of what to do (i.e. the +-- perfectly ok to extend the description of what to do (i.e. the -- 'ElaboratedInstallPlan') if that helps keep the policy decisions in the -- first phase. Also, the second phase does not have direct access to any of -- the input configuration anyway; all the information has to flow via the -- 'ElaboratedInstallPlan'. -- module Distribution.Client.ProjectOrchestration ( + -- * Discovery phase: what is in the project? + establishProjectBaseContext, + ProjectBaseContext(..), + BuildTimeSettings(..), + commandLineFlagsToProjectConfig, + -- * Pre-build phase: decide what to do. runProjectPreBuildPhase, - CliConfigFlags, - PreBuildHooks(..), ProjectBuildContext(..), + -- ** Selecting what targets we mean + readTargetSelectors, + reportTargetSelectorProblems, + resolveTargets, + TargetsMap, + TargetSelector(..), + PackageId, + AvailableTarget(..), + AvailableTargetStatus(..), + TargetRequested(..), + ComponentName(..), + ComponentKind(..), + ComponentTarget(..), + SubComponentTarget(..), + TargetProblemCommon(..), + selectComponentTargetBasic, + distinctTargetComponents, + -- ** Utils for selecting targets + filterTargetsKind, + filterTargetsKindWith, + selectBuildableTargets, + selectBuildableTargetsWith, + selectBuildableTargets', + selectBuildableTargetsWith', + forgetTargetsDetail, + -- ** Adjusting the plan - selectTargets, + pruneInstallPlanToTargets, + TargetAction(..), + pruneInstallPlanToDependencies, + CannotPruneDependencies(..), printPlan, -- * Build phase: now do it. @@ -55,20 +89,28 @@ -- * Post build actions runProjectPostBuildPhase, dieOnBuildFailures, + + -- * Shared CLI utils + cmdCommonHelpTextNewBuildBeta, ) where import Distribution.Client.ProjectConfig import Distribution.Client.ProjectPlanning + hiding ( pruneInstallPlanToTargets ) +import qualified Distribution.Client.ProjectPlanning as ProjectPlanning + ( pruneInstallPlanToTargets ) import Distribution.Client.ProjectPlanning.Types import Distribution.Client.ProjectBuilding import Distribution.Client.ProjectPlanOutput import Distribution.Client.Types - ( GenericReadyPackage(..), PackageLocation(..) ) + ( GenericReadyPackage(..), UnresolvedSourcePackage + , PackageSpecifier(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.BuildTarget - ( UserBuildTarget, resolveUserBuildTargets - , BuildTarget(..), buildTargetPackage ) +import Distribution.Client.TargetSelector + ( TargetSelector(..) + , ComponentKind(..), componentKind + , readTargetSelectors, reportTargetSelectorProblems ) import Distribution.Client.DistDirLayout import Distribution.Client.Config (defaultCabalDir) import Distribution.Client.Setup hiding (packageName) @@ -77,17 +119,22 @@ import Distribution.Package hiding (InstalledPackageId, installedPackageId) -import qualified Distribution.PackageDescription as PD -import Distribution.PackageDescription (FlagAssignment) -import Distribution.Simple.Setup (HaddockFlags) +import Distribution.PackageDescription + ( FlagAssignment, unFlagAssignment, showFlagValue + , diffFlagAssignment ) +import Distribution.Simple.LocalBuildInfo + ( ComponentName(..), pkgComponents ) import qualified Distribution.Simple.Setup as Setup import Distribution.Simple.Command (commandShowOptions) import Distribution.Simple.Utils - ( die, dieMsg, dieMsgNoWrap, info - , notice, noticeNoWrap, debug, debugNoWrap ) + ( die' + , notice, noticeNoWrap, debugNoWrap ) import Distribution.Verbosity import Distribution.Text +import Distribution.Simple.Compiler + ( showCompilerId + , OptimisationLevel(..)) import qualified Data.Monoid as Mon import qualified Data.Set as Set @@ -96,42 +143,74 @@ import Data.List import Data.Maybe import Data.Either -import Control.Exception (Exception(..), throwIO) +import Control.Monad (void) +import Control.Exception (Exception(..), throwIO, assert) import System.Exit (ExitCode(..), exitFailure) -import qualified System.Process.Internals as Process (translate) #ifdef MIN_VERSION_unix import System.Posix.Signals (sigKILL, sigSEGV) #endif --- | Command line configuration flags. These are used to extend\/override the --- project configuration. +-- | This holds the context of a project prior to solving: the content of the +-- @cabal.project@ and all the local package @.cabal@ files. -- -type CliConfigFlags = ( GlobalFlags - , ConfigFlags, ConfigExFlags - , InstallFlags, HaddockFlags ) +data ProjectBaseContext = ProjectBaseContext { + distDirLayout :: DistDirLayout, + cabalDirLayout :: CabalDirLayout, + projectConfig :: ProjectConfig, + localPackages :: [PackageSpecifier UnresolvedSourcePackage], + buildSettings :: BuildTimeSettings + } --- | Hooks to alter the behaviour of 'runProjectPreBuildPhase'. --- --- For example the @configure@, @build@ and @repl@ commands use this to get --- their different behaviour. --- -data PreBuildHooks = PreBuildHooks { - hookPrePlanning :: FilePath - -> DistDirLayout +establishProjectBaseContext :: Verbosity -> ProjectConfig - -> IO (), - hookSelectPlanSubset :: BuildTimeSettings - -> ElaboratedInstallPlan - -> IO ElaboratedInstallPlan - } + -> IO ProjectBaseContext +establishProjectBaseContext verbosity cliConfig = do + cabalDir <- defaultCabalDir + projectRoot <- either throwIO return =<< + findProjectRoot Nothing mprojectFile + + let distDirLayout = defaultDistDirLayout projectRoot + mdistDirectory + + (projectConfig, localPackages) <- + rebuildProjectConfig verbosity + distDirLayout + cliConfig + + let ProjectConfigBuildOnly { + projectConfigLogsDir, + projectConfigStoreDir + } = projectConfigBuildOnly projectConfig + + mlogsDir = Setup.flagToMaybe projectConfigLogsDir + mstoreDir = Setup.flagToMaybe projectConfigStoreDir + cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + + buildSettings = resolveBuildTimeSettings + verbosity cabalDirLayout + projectConfig + + return ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + buildSettings + } + where + mdistDirectory = Setup.flagToMaybe projectConfigDistDir + mprojectFile = Setup.flagToMaybe projectConfigProjectFile + ProjectConfigShared { + projectConfigDistDir, + projectConfigProjectFile + } = projectConfigShared cliConfig + + -- | This holds the context between the pre-build, build and post-build phases. -- data ProjectBuildContext = ProjectBuildContext { - projectRootDir :: FilePath, - distDirLayout :: DistDirLayout, - -- | This is the improved plan, before we select a plan subset based on -- the build targets, and before we do the dry-run. So this contains -- all packages in the project. @@ -152,60 +231,45 @@ -- the 'elaboratedPlanToExecute'. pkgsBuildStatus :: BuildStatusMap, - buildSettings :: BuildTimeSettings + -- | The targets selected by @selectPlanSubset@. This is useful eg. in + -- CmdRun, where we need a valid target to execute. + targetsMap :: TargetsMap } -- | Pre-build phase: decide what to do. -- -runProjectPreBuildPhase :: Verbosity - -> CliConfigFlags - -> PreBuildHooks - -> IO ProjectBuildContext runProjectPreBuildPhase + :: Verbosity + -> ProjectBaseContext + -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap)) + -> IO ProjectBuildContext +runProjectPreBuildPhase verbosity - ( globalFlags - , configFlags, configExFlags - , installFlags, haddockFlags ) - PreBuildHooks{..} = do - - cabalDir <- defaultCabalDir - let cabalDirLayout = defaultCabalDirLayout cabalDir - - projectRootDir <- findProjectRoot - let distDirLayout = defaultDistDirLayout projectRootDir - - let cliConfig = commandLineFlagsToProjectConfig - globalFlags configFlags configExFlags - installFlags haddockFlags - - hookPrePlanning - projectRootDir - distDirLayout - cliConfig + ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages + } + selectPlanSubset = do -- Take the project configuration and make a plan for how to build -- everything in the project. This is independent of any specific targets -- the user has asked for. -- - (elaboratedPlan, _, elaboratedShared, projectConfig) <- + (elaboratedPlan, _, elaboratedShared) <- rebuildInstallPlan verbosity - projectRootDir distDirLayout cabalDirLayout - cliConfig + distDirLayout cabalDirLayout + projectConfig + localPackages - let buildSettings = resolveBuildTimeSettings - verbosity cabalDirLayout - (projectConfigShared projectConfig) - (projectConfigBuildOnly projectConfig) - (projectConfigBuildOnly cliConfig) - info verbosity $ "Number of threads used: " - ++ (show . buildSettingNumJobs $ buildSettings) ++ "." -- The plan for what to do is represented by an 'ElaboratedInstallPlan' -- Now given the specific targets the user has asked for, decide -- which bits of the plan we will want to execute. -- - elaboratedPlan' <- hookSelectPlanSubset buildSettings elaboratedPlan + (elaboratedPlan', targets) <- selectPlanSubset elaboratedPlan -- Check which packages need rebuilding. -- This also gives us more accurate reasons for the --dry-run output. @@ -220,13 +284,11 @@ debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') return ProjectBuildContext { - projectRootDir, - distDirLayout, elaboratedPlanOriginal = elaboratedPlan, - elaboratedPlanToExecute = elaboratedPlan'', + elaboratedPlanToExecute = elaboratedPlan'', elaboratedShared, pkgsBuildStatus, - buildSettings + targetsMap = targets } @@ -236,16 +298,19 @@ -- rebuild the various packages needed. -- runProjectBuildPhase :: Verbosity + -> ProjectBaseContext -> ProjectBuildContext -> IO BuildOutcomes -runProjectBuildPhase _ ProjectBuildContext {buildSettings} +runProjectBuildPhase _ ProjectBaseContext{buildSettings} _ | buildSettingDryRun buildSettings = return Map.empty -runProjectBuildPhase verbosity ProjectBuildContext {..} = +runProjectBuildPhase verbosity + ProjectBaseContext{..} ProjectBuildContext {..} = fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $ rebuildTargets verbosity distDirLayout + (cabalStoreDirLayout cabalDirLayout) elaboratedPlanToExecute elaboratedShared pkgsBuildStatus @@ -263,14 +328,17 @@ -- Update bits of state based on the build outcomes and report any failures. -- runProjectPostBuildPhase :: Verbosity + -> ProjectBaseContext -> ProjectBuildContext -> BuildOutcomes -> IO () -runProjectPostBuildPhase _ ProjectBuildContext {buildSettings} _ +runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _ | buildSettingDryRun buildSettings = return () -runProjectPostBuildPhase verbosity ProjectBuildContext {..} buildOutcomes = do +runProjectPostBuildPhase verbosity + ProjectBaseContext {..} ProjectBuildContext {..} + buildOutcomes = do -- Update other build artefacts -- TODO: currently none, but could include: -- - bin symlinks/wrappers @@ -285,10 +353,11 @@ pkgsBuildStatus buildOutcomes - writePlanGhcEnvironment projectRootDir - elaboratedPlanOriginal - elaboratedShared - postBuildStatus + void $ writePlanGhcEnvironment (distProjectRootDirectory + distDirLayout) + elaboratedPlanOriginal + elaboratedShared + postBuildStatus -- Finally if there were any build failures then report them and throw -- an exception to terminate the program @@ -308,53 +377,69 @@ -- on it) all go into the install plan. -- Notionally, the 'BuildFlags' should be things that do not affect what - -- we build, just how we do it. These ones of course do + -- we build, just how we do it. These ones of course do ------------------------------------------------------------------------------ -- Taking targets into account, selecting what to build -- --- | Adjust an 'ElaboratedInstallPlan' by selecting just those parts of it --- required to build the given user targets. +-- | The set of components to build, represented as a mapping from 'UnitId's +-- to the 'ComponentTarget's within the unit that will be selected +-- (e.g. selected to build, test or repl). -- --- How to get the 'PackageTarget's from the 'UserBuildTarget' is customisable, --- so that we can change the meaning of @pkgname@ to target a build or --- repl depending on which command is calling it. +-- Associated with each 'ComponentTarget' is the set of 'TargetSelector's that +-- matched this target. Typically this is exactly one, but in general it is +-- possible to for different selectors to match the same target. This extra +-- information is primarily to help make helpful error messages. -- --- Conceptually, every target identifies one or more roots in the --- 'ElaboratedInstallPlan', which we then use to determine the closure --- of what packages need to be built, dropping everything from --- 'ElaboratedInstallPlan' that is unnecessary. +type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector PackageId])] + +-- | Given a set of 'TargetSelector's, resolve which 'UnitId's and +-- 'ComponentTarget's they ought to refer to. -- --- There is a complication, however: In an ideal world, every --- possible target would be a node in the graph. However, it is --- currently not possible (and possibly not even desirable) to invoke a --- Setup script to build *just* one file. Similarly, it is not possible --- to invoke a pre Cabal-1.25 custom Setup script and build only one --- component. In these cases, we want to build the entire package, BUT --- only actually building some of the files/components. This is what --- 'pkgBuildTargets', 'pkgReplTarget' and 'pkgBuildHaddock' control. --- Arguably, these should an out-of-band mechanism rather than stored --- in 'ElaboratedInstallPlan', but it's what we have. We have --- to fiddle around with the ElaboratedConfiguredPackage roots to say --- what it will build. +-- The idea is that every user target identifies one or more roots in the +-- 'ElaboratedInstallPlan', which we will use to determine the closure +-- of what packages need to be built, dropping everything from the plan +-- that is unnecessary. This closure and pruning is done by +-- 'pruneInstallPlanToTargets' and this needs to be told the roots in terms +-- of 'UnitId's and the 'ComponentTarget's within those. -- -selectTargets :: Verbosity -> PackageTarget - -> (ComponentTarget -> PackageTarget) - -> [UserBuildTarget] - -> Bool - -> ElaboratedInstallPlan - -> IO ElaboratedInstallPlan -selectTargets verbosity targetDefaultComponents targetSpecificComponent - userBuildTargets onlyDependencies installPlan = do - - -- Match the user targets against the available targets. If no targets are - -- given this uses the package in the current directory, if any. - -- - buildTargets <- resolveUserBuildTargets localPackages userBuildTargets - --TODO: [required eventually] report something if there are no targets - +-- This means we first need to translate the 'TargetSelector's into the +-- 'UnitId's and 'ComponentTarget's. This translation has to be different for +-- the different command line commands, like @build@, @repl@ etc. For example +-- the command @build pkgfoo@ could select a different set of components in +-- pkgfoo than @repl pkgfoo@. The @build@ command would select any library and +-- all executables, whereas @repl@ would select the library or a single +-- executable. Furthermore, both of these examples could fail, and fail in +-- different ways and each needs to be able to produce helpful error messages. +-- +-- So 'resolveTargets' takes two helpers: one to select the targets to be used +-- by user targets that refer to a whole package ('TargetPackage'), and +-- another to check user targets that refer to a component (or a module or +-- file within a component). These helpers can fail, and use their own error +-- type. Both helpers get given the 'AvailableTarget' info about the +-- component(s). +-- +-- While commands vary quite a bit in their behaviour about which components to +-- select for a whole-package target, most commands have the same behaviour for +-- checking a user target that refers to a specific component. To help with +-- this commands can use 'selectComponentTargetBasic', either directly or as +-- a basis for their own @selectComponentTarget@ implementation. +-- +resolveTargets :: forall err. + (forall k. TargetSelector PackageId + -> [AvailableTarget k] + -> Either err [k]) + -> (forall k. PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k + -> Either err k ) + -> (TargetProblemCommon -> err) + -> ElaboratedInstallPlan + -> [TargetSelector PackageId] + -> Either [err] TargetsMap +resolveTargets selectPackageTargets selectComponentTarget liftProblem + installPlan targetSelectors = --TODO: [required eventually] -- we cannot resolve names of packages other than those that are -- directly in the current plan. We ought to keep a set of the known @@ -362,135 +447,206 @@ -- really need that until we can do something sensible with packages -- outside of the project. - -- Now check if those targets belong to the current project or not. - -- Ultimately we want to do something sensible for targets not in this - -- project, but for now we just bail. This gives us back the ipkgid from - -- the plan. - -- - buildTargets' <- either reportBuildTargetProblems return - $ resolveAndCheckTargets - targetDefaultComponents - targetSpecificComponent - installPlan - buildTargets - debug verbosity ("buildTargets': " ++ show buildTargets') - - -- Finally, prune the install plan to cover just those target packages - -- and their deps (or only their deps with the --only-dependencies flag). - -- - let installPlan' = pruneInstallPlanToTargets - buildTargets' installPlan - if onlyDependencies - then either throwIO return $ - pruneInstallPlanToDependencies - (Map.keysSet buildTargets') installPlan' - else return installPlan' - where - localPackages = - [ (elabPkgDescription elab, elabPkgSourceLocation elab) - | InstallPlan.Configured elab <- InstallPlan.toList installPlan ] - --TODO: [code cleanup] is there a better way to identify local packages? - - + case partitionEithers + [ fmap ((,) targetSelector) (checkTarget targetSelector) + | targetSelector <- targetSelectors ] of + ([], targets) -> Right + . Map.map nubComponentTargets + $ Map.fromListWith (++) + [ (uid, [(ct, ts)]) + | (ts, cts) <- targets + , (uid, ct) <- cts ] -resolveAndCheckTargets :: PackageTarget - -> (ComponentTarget -> PackageTarget) - -> ElaboratedInstallPlan - -> [BuildTarget PackageName] - -> Either [BuildTargetProblem] - (Map UnitId [PackageTarget]) -resolveAndCheckTargets targetDefaultComponents - targetSpecificComponent - installPlan targets = - case partitionEithers (map checkTarget targets) of - ([], targets') -> Right $ Map.fromListWith (++) - [ (uid, [t]) | (uids, t) <- targets' - , uid <- uids ] - (problems, _) -> Left problems + (problems, _) -> Left problems where -- TODO [required eventually] currently all build targets refer to packages -- inside the project. Ultimately this has to be generalised to allow -- referring to other packages and targets. + checkTarget :: TargetSelector PackageId + -> Either err [(UnitId, ComponentTarget)] -- We can ask to build any whole package, project-local or a dependency - checkTarget (BuildTargetPackage pn) - | Just ipkgid <- Map.lookup pn projAllPkgs - = Right (ipkgid, targetDefaultComponents) + checkTarget bt@(TargetPackage _ pkgid mkfilter) + | Just ats <- fmap (maybe id filterTargetsKind mkfilter) + $ Map.lookup pkgid availableTargetsByPackage + = case selectPackageTargets bt ats of + Left e -> Left e + Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent) + | (unitid, cname) <- ts ] - -- But if we ask to build an individual component, then that component - -- had better be in a package that is local to the project. - -- TODO: and if it's an optional stanza, then that stanza must be available - checkTarget t@(BuildTargetComponent pn cn) - | Just ipkgid <- Map.lookup pn projLocalPkgs - = Right (ipkgid, targetSpecificComponent - (ComponentTarget cn WholeComponent)) + | otherwise + = Left (liftProblem (TargetProblemNoSuchPackage pkgid)) - | Map.member pn projAllPkgs - = Left (BuildTargetComponentNotProjectLocal t) + checkTarget bt@(TargetAllPackages mkfilter) = + let ats = maybe id filterTargetsKind mkfilter + $ filter availableTargetLocalToProject + $ concat (Map.elems availableTargetsByPackage) + in case selectPackageTargets bt ats of + Left e -> Left e + Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent) + | (unitid, cname) <- ts ] - checkTarget t@(BuildTargetModule pn cn mn) - | Just ipkgid <- Map.lookup pn projLocalPkgs - = Right (ipkgid, BuildSpecificComponent (ComponentTarget cn (ModuleTarget mn))) + checkTarget (TargetComponent pkgid cname subtarget) + | Just ats <- Map.lookup (pkgid, cname) availableTargetsByComponent + = case partitionEithers + (map (selectComponentTarget pkgid cname subtarget) ats) of + (e:_,_) -> Left e + ([],ts) -> Right [ (unitid, ctarget) + | let ctarget = ComponentTarget cname subtarget + , (unitid, _) <- ts ] - | Map.member pn projAllPkgs - = Left (BuildTargetComponentNotProjectLocal t) + | Map.member pkgid availableTargetsByPackage + = Left (liftProblem (TargetProblemNoSuchComponent pkgid cname)) - checkTarget t@(BuildTargetFile pn cn fn) - | Just ipkgid <- Map.lookup pn projLocalPkgs - = Right (ipkgid, BuildSpecificComponent (ComponentTarget cn (FileTarget fn))) + | otherwise + = Left (liftProblem (TargetProblemNoSuchPackage pkgid)) - | Map.member pn projAllPkgs - = Left (BuildTargetComponentNotProjectLocal t) + checkTarget bt@(TargetPackageName pkgname) + | Just ats <- Map.lookup pkgname availableTargetsByPackageName + = case selectPackageTargets bt ats of + Left e -> Left e + Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent) + | (unitid, cname) <- ts ] - checkTarget t - = Left (BuildTargetNotInProject (buildTargetPackage t)) + | otherwise + = Left (liftProblem (TargetNotInProject pkgname)) + --TODO: check if the package is in the plan, even if it's not local + --TODO: check if the package is in hackage and return different + -- error cases here so the commands can handle things appropriately + availableTargetsByPackage :: Map PackageId [AvailableTarget (UnitId, ComponentName)] + availableTargetsByPackageName :: Map PackageName [AvailableTarget (UnitId, ComponentName)] + availableTargetsByComponent :: Map (PackageId, ComponentName) [AvailableTarget (UnitId, ComponentName)] - -- NB: It's a list of 'InstalledPackageId', because each component - -- in the install plan from a single package needs to be associated with - -- the same 'PackageName'. - projAllPkgs, projLocalPkgs :: Map PackageName [UnitId] - projAllPkgs = - Map.fromListWith (++) - [ (packageName pkg, [installedUnitId pkg]) - | pkg <- InstallPlan.toList installPlan ] + availableTargetsByComponent = availableTargets installPlan + availableTargetsByPackage = Map.mapKeysWith + (++) (\(pkgid, _cname) -> pkgid) + availableTargetsByComponent + `Map.union` availableTargetsEmptyPackages + availableTargetsByPackageName = Map.mapKeysWith + (++) packageName + availableTargetsByPackage - projLocalPkgs = - Map.fromListWith (++) - [ (packageName elab, [installedUnitId elab]) - | InstallPlan.Configured elab <- InstallPlan.toList installPlan - , case elabPkgSourceLocation elab of - LocalUnpackedPackage _ -> True; _ -> False - --TODO: [code cleanup] is there a better way to identify local packages? + -- Add in all the empty packages. These do not appear in the + -- availableTargetsByComponent map, since that only contains components + -- so packages with no components are invisible from that perspective. + -- The empty packages need to be there for proper error reporting, so users + -- can select the empty package and then we can report that it is empty, + -- otherwise we falsely report there is no such package at all. + availableTargetsEmptyPackages = + Map.fromList + [ (packageId pkg, []) + | InstallPlan.Configured pkg <- InstallPlan.toList installPlan + , case elabPkgOrComp pkg of + ElabComponent _ -> False + ElabPackage _ -> null (pkgComponents (elabPkgDescription pkg)) ] --TODO: [research required] what if the solution has multiple versions of this package? -- e.g. due to setup deps or due to multiple independent sets of -- packages being built (e.g. ghc + ghcjs in a project) -data BuildTargetProblem - = BuildTargetNotInProject PackageName - | BuildTargetComponentNotProjectLocal (BuildTarget PackageName) - | BuildTargetOptionalStanzaDisabled Bool - -- ^ @True@: explicitly disabled by user - -- @False@: disabled by solver +filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k] +filterTargetsKind ckind = filterTargetsKindWith (== ckind) -reportBuildTargetProblems :: [BuildTargetProblem] -> IO a -reportBuildTargetProblems = die . unlines . map reportBuildTargetProblem +filterTargetsKindWith :: (ComponentKind -> Bool) + -> [AvailableTarget k] -> [AvailableTarget k] +filterTargetsKindWith p ts = + [ t | t@(AvailableTarget _ cname _ _) <- ts + , p (componentKind cname) ] -reportBuildTargetProblem :: BuildTargetProblem -> String -reportBuildTargetProblem (BuildTargetNotInProject pn) = - "Cannot build the package " ++ display pn ++ ", it is not in this project." - ++ "(either directly or indirectly). If you want to add it to the " - ++ "project then edit the cabal.project file." +selectBuildableTargets :: [AvailableTarget k] -> [k] +selectBuildableTargets ts = + [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ] -reportBuildTargetProblem (BuildTargetComponentNotProjectLocal t) = - "The package " ++ display (buildTargetPackage t) ++ " is in the " - ++ "project but it is not a locally unpacked package, so " +selectBuildableTargetsWith :: (TargetRequested -> Bool) + -> [AvailableTarget k] -> [k] +selectBuildableTargetsWith p ts = + [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ] -reportBuildTargetProblem (BuildTargetOptionalStanzaDisabled _) = undefined +selectBuildableTargets' :: [AvailableTarget k] -> ([k], [AvailableTarget ()]) +selectBuildableTargets' ts = + (,) [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ] + [ forgetTargetDetail t + | t@(AvailableTarget _ _ (TargetBuildable _ _) _) <- ts ] +selectBuildableTargetsWith' :: (TargetRequested -> Bool) + -> [AvailableTarget k] -> ([k], [AvailableTarget ()]) +selectBuildableTargetsWith' p ts = + (,) [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ] + [ forgetTargetDetail t + | t@(AvailableTarget _ _ (TargetBuildable _ req) _) <- ts, p req ] + +forgetTargetDetail :: AvailableTarget k -> AvailableTarget () +forgetTargetDetail = fmap (const ()) + +forgetTargetsDetail :: [AvailableTarget k] -> [AvailableTarget ()] +forgetTargetsDetail = map forgetTargetDetail + +-- | A basic @selectComponentTarget@ implementation to use or pass to +-- 'resolveTargets', that does the basic checks that the component is +-- buildable and isn't a test suite or benchmark that is disabled. This +-- can also be used to do these basic checks as part of a custom impl that +-- +selectComponentTargetBasic :: PackageId + -> ComponentName + -> SubComponentTarget + -> AvailableTarget k + -> Either TargetProblemCommon k +selectComponentTargetBasic pkgid cname subtarget AvailableTarget {..} = + case availableTargetStatus of + TargetDisabledByUser -> + Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget) + + TargetDisabledBySolver -> + Left (TargetOptionalStanzaDisabledBySolver pkgid cname subtarget) + + TargetNotLocal -> + Left (TargetComponentNotProjectLocal pkgid cname subtarget) + + TargetNotBuildable -> + Left (TargetComponentNotBuildable pkgid cname subtarget) + + TargetBuildable targetKey _ -> + Right targetKey + +data TargetProblemCommon + = TargetNotInProject PackageName + | TargetComponentNotProjectLocal PackageId ComponentName SubComponentTarget + | TargetComponentNotBuildable PackageId ComponentName SubComponentTarget + | TargetOptionalStanzaDisabledByUser PackageId ComponentName SubComponentTarget + | TargetOptionalStanzaDisabledBySolver PackageId ComponentName SubComponentTarget + + -- The target matching stuff only returns packages local to the project, + -- so these lookups should never fail, but if 'resolveTargets' is called + -- directly then of course it can. + | TargetProblemNoSuchPackage PackageId + | TargetProblemNoSuchComponent PackageId ComponentName + deriving (Eq, Show) + +-- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts +-- for the extra unneeded info in the 'TargetsMap'. +-- +pruneInstallPlanToTargets :: TargetAction -> TargetsMap + -> ElaboratedInstallPlan -> ElaboratedInstallPlan +pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = + assert (Map.size targetsMap > 0) $ + ProjectPlanning.pruneInstallPlanToTargets + targetActionType + (Map.map (map fst) targetsMap) + elaboratedPlan + +-- | Utility used by repl and run to check if the targets spans multiple +-- components, since those commands do not support multiple components. +-- +distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName) +distinctTargetComponents targetsMap = + Set.fromList [ (uid, cname) + | (uid, cts) <- Map.toList targetsMap + , (ComponentTarget cname _, _) <- cts ] + + ------------------------------------------------------------------------------ -- Displaying what we plan to do -- @@ -498,13 +654,21 @@ -- | Print a user-oriented presentation of the install plan, indicating what -- will be built. -- -printPlan :: Verbosity -> ProjectBuildContext -> IO () +printPlan :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> IO () printPlan verbosity + ProjectBaseContext { + buildSettings = BuildTimeSettings{buildSettingDryRun}, + projectConfig = ProjectConfig { + projectConfigLocalPackages = PackageConfig {packageConfigOptimization} + } + } ProjectBuildContext { elaboratedPlanToExecute = elaboratedPlan, elaboratedShared, - pkgsBuildStatus, - buildSettings = BuildTimeSettings{buildSettingDryRun} + pkgsBuildStatus } | null pkgs @@ -512,7 +676,7 @@ | otherwise = noticeNoWrap verbosity $ unlines $ - ("In order, the following " ++ wouldWill ++ " be built" ++ + (showBuildProfile ++ "In order, the following " ++ wouldWill ++ " be built" ++ ifNormal " (use -v for more details)" ++ ":") : map showPkgAndReason pkgs @@ -531,22 +695,32 @@ showPkgAndReason :: ElaboratedReadyPackage -> String showPkgAndReason (ReadyPackage elab) = " - " ++ - (if verbosity >= verbose + (if verbosity >= deafening then display (installedUnitId elab) else display (packageId elab) ) ++ (case elabPkgOrComp elab of ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas pkg) ElabComponent comp -> - " (" ++ maybe "custom" display (compComponentName comp) ++ ")" + " (" ++ showComp elab comp ++ ")" ) ++ showFlagAssignment (nonDefaultFlags elab) ++ showConfigureFlags elab ++ let buildStatus = pkgsBuildStatus Map.! installedUnitId elab in " (" ++ showBuildStatus buildStatus ++ ")" + showComp elab comp = + maybe "custom" display (compComponentName comp) ++ + if Map.null (elabInstantiatedWith elab) + then "" + else " with " ++ + intercalate ", " + -- TODO: Abbreviate the UnitIds + [ display k ++ "=" ++ display v + | (k,v) <- Map.toList (elabInstantiatedWith elab) ] + nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment - nonDefaultFlags elab = elabFlagAssignment elab \\ elabFlagDefaults elab + nonDefaultFlags elab = elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab showStanzas pkg = concat $ [ " *test" @@ -560,12 +734,8 @@ = " (" ++ intercalate ", " [ showComponentTarget (packageId elab) t | t <- elabBuildTargets elab ] ++ ")" - -- TODO: [code cleanup] this should be a proper function in a proper place showFlagAssignment :: FlagAssignment -> String - showFlagAssignment = concatMap ((' ' :) . showFlagValue) - showFlagValue (f, True) = '+' : showFlagName f - showFlagValue (f, False) = '-' : showFlagName f - showFlagName = PD.unFlagName + showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment showConfigureFlags elab = let fullConfigureFlags @@ -596,7 +766,8 @@ nubFlag tryLibProfiling (configProfLib fullConfigureFlags) -- Maybe there are more we can add } - in unwords . ("":) . map Process.translate $ + -- Not necessary to "escape" it, it's just for user output + in unwords . ("":) $ commandShowOptions (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared)) partialConfigureFlags @@ -623,6 +794,14 @@ showMonitorChangedReason MonitorFirstRun = "first run" showMonitorChangedReason MonitorCorruptCache = "cannot read state cache" + showBuildProfile = "Build profile: " ++ unwords [ + "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared, + "-O" ++ (case packageConfigOptimization of + Setup.Flag NoOptimisation -> "0" + Setup.Flag NormalOptimisation -> "1" + Setup.Flag MaximumOptimisation -> "2" + Setup.NoFlag -> "1")] + ++ "\n" -- | If there are build failures then report them and throw an exception. -- @@ -636,18 +815,17 @@ | otherwise = do -- For failures where we have a build log, print the log plus a header sequence_ - [ do dieMsg verbosity $ + [ do notice verbosity $ '\n' : renderFailureDetail False pkg reason ++ "\nBuild log ( " ++ logfile ++ " ):" - readFile logfile >>= dieMsgNoWrap - | verbosity >= normal - , (pkg, ShowBuildSummaryAndLog reason logfile) + readFile logfile >>= noticeNoWrap verbosity + | (pkg, ShowBuildSummaryAndLog reason logfile) <- failuresClassification ] -- For all failures, print either a short summary (if we showed the -- build log) or all details - die $ unlines + die' verbosity $ unlines [ case failureClassification of ShowBuildSummaryAndLog reason _ | verbosity > normal @@ -745,6 +923,7 @@ ReplFailed _ -> "repl failed for " ++ pkgstr HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr TestsFailed _ -> "Tests failed for " ++ pkgstr + BenchFailed _ -> "Benchmarks failed for " ++ pkgstr InstallFailed _ -> "Failed to build " ++ pkgstr DependentFailed depid -> "Failed to build " ++ display (packageId pkg) @@ -828,6 +1007,7 @@ ReplFailed e -> Just e HaddocksFailed e -> Just e TestsFailed e -> Just e + BenchFailed e -> Just e InstallFailed e -> Just e DependentFailed _ -> Nothing @@ -835,3 +1015,15 @@ ShowBuildSummaryOnly BuildFailureReason | ShowBuildSummaryAndLog BuildFailureReason FilePath + +cmdCommonHelpTextNewBuildBeta :: String +cmdCommonHelpTextNewBuildBeta = + "Note: this command is part of the new project-based system (aka " + ++ "nix-style\nlocal builds). These features are currently in beta. " + ++ "Please see\n" + ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html " + ++ "for\ndetails and advice on what you can expect to work. If you " + ++ "encounter problems\nplease file issues at " + ++ "https://github.com/haskell/cabal/issues and if you\nhave any time " + ++ "to get involved and help with testing, fixing bugs etc then\nthat " + ++ "is very much appreciated.\n" 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 @@ -1,8 +1,6 @@ {-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns, DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} module Distribution.Client.ProjectPlanOutput ( -- * Plan output @@ -12,7 +10,9 @@ -- | Several outputs rely on having a general overview of PostBuildProjectStatus(..), updatePostBuildProjectStatus, + createPackageEnvironment, writePlanGhcEnvironment, + argsEquivalentOfGhcEnvironmentFile, ) where import Distribution.Client.ProjectPlanning.Types @@ -31,10 +31,11 @@ import Distribution.System import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.PackageDescription as PD -import Distribution.Compiler (CompilerFlavor(GHC)) +import Distribution.Compiler (CompilerFlavor(GHC, GHCJS)) import Distribution.Simple.Compiler ( PackageDBStack, PackageDB(..) - , compilerVersion, compilerFlavor, showCompilerId ) + , compilerVersion, compilerFlavor, showCompilerId + , compilerId, CompilerId(..), Compiler ) import Distribution.Simple.GHC ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles) , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile @@ -43,23 +44,23 @@ import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (Graph, Node) import qualified Distribution.Compat.Binary as Binary -import qualified Distribution.Utils.BinaryWithFingerprint as Binary import Distribution.Simple.Utils import Distribution.Verbosity import qualified Paths_cabal_install as Our (version) -import Data.Maybe (maybeToList, fromMaybe) -import Data.Monoid +import Prelude () +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 -import GHC.Generics import System.FilePath import System.IO +import Distribution.Simple.Program.GHC (packageDbArgsDb) ----------------------------------------------------------------------------- -- Writing plan.json files @@ -136,7 +137,7 @@ , "pkg-name" J..= (jdisplay . pkgName . packageId) elab , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab , "flags" J..= J.object [ PD.unFlagName fn J..= v - | (fn,v) <- elabFlagAssignment elab ] + | (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ] , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) ] ++ [ "pkg-src-sha256" J..= J.String (showHashValue hash) @@ -328,15 +329,6 @@ type PackageIdSet = Set UnitId type PackagesUpToDate = PackageIdSet -newtype PackagesUpToDateG = PackagesUpToDateG { unPackagesUpToDateG :: PackagesUpToDate } - -instance Binary.Binary PackagesUpToDateG - -instance Generic PackagesUpToDateG where - type Rep PackagesUpToDateG = Rep [UnitId] - from = from . Set.toList . unPackagesUpToDateG - to = PackagesUpToDateG . Set.fromList . to - data PostBuildProjectStatus = PostBuildProjectStatus { -- | Packages that are known to be up to date. These were found to be @@ -524,7 +516,7 @@ -- The plan graph but only counting dependency-on-library edges packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) packagesLibDepGraph = - Graph.fromList + Graph.fromDistinctList [ Graph.N pkg (installedUnitId pkg) libdeps | pkg <- InstallPlan.toList plan , let libdeps = case pkg of @@ -655,8 +647,7 @@ handleDoesNotExist Set.empty $ handleDecodeFailure $ withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd -> - fmap (fmap unPackagesUpToDateG) . - Binary.decodeWithFingerprintOrFailIO =<< BS.hGetContents hnd + Binary.decodeOrFailIO =<< BS.hGetContents hnd where handleDecodeFailure = fmap (either (const Set.empty) id) @@ -667,8 +658,45 @@ writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO () writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate = writeFileAtomic (distProjectCacheFile "up-to-date") $ - Binary.encodeWithFingerprint (PackagesUpToDateG upToDate) + Binary.encode upToDate +-- | Prepare a package environment that includes all the library dependencies +-- for a plan. +-- +-- When running cabal new-exec, we want to set things up so that the compiler +-- can find all the right packages (and nothing else). This function is +-- intended to do that work. It takes a location where it can write files +-- temporarily, in case the compiler wants to learn this information via the +-- filesystem, and returns any environment variable overrides the compiler +-- needs. +createPackageEnvironment :: Verbosity + -> FilePath + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> PostBuildProjectStatus + -> IO [(String, Maybe String)] +createPackageEnvironment verbosity + path + elaboratedPlan + elaboratedShared + buildStatus + | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC + = do + envFileM <- writePlanGhcEnvironment + path + elaboratedPlan + elaboratedShared + buildStatus + case envFileM of + Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)] + Nothing -> do + warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail" + return [] + | otherwise + = do + warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail" + return [] + -- Writing .ghc.environment files -- @@ -676,8 +704,8 @@ -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> PostBuildProjectStatus - -> IO () -writePlanGhcEnvironment projectRootDir + -> IO (Maybe FilePath) +writePlanGhcEnvironment path elaboratedInstallPlan ElaboratedSharedConfig { pkgConfigCompiler = compiler, @@ -687,24 +715,24 @@ | compilerFlavor compiler == GHC , supportsPkgEnvFiles (getImplInfo compiler) --TODO: check ghcjs compat - = writeGhcEnvironmentFile - projectRootDir + = fmap Just $ writeGhcEnvironmentFile + path platform (compilerVersion compiler) - (renderGhcEnviromentFile projectRootDir - elaboratedInstallPlan - postBuildStatus) + (renderGhcEnvironmentFile path + elaboratedInstallPlan + postBuildStatus) --TODO: [required eventually] support for writing user-wide package -- environments, e.g. like a global project, but we would not put the -- env file in the home dir, rather it lives under ~/.ghc/ -writePlanGhcEnvironment _ _ _ _ = return () +writePlanGhcEnvironment _ _ _ _ = return Nothing -renderGhcEnviromentFile :: FilePath - -> ElaboratedInstallPlan - -> PostBuildProjectStatus - -> [GhcEnvironmentFileEntry] -renderGhcEnviromentFile projectRootDir elaboratedInstallPlan - postBuildStatus = +renderGhcEnvironmentFile :: FilePath + -> ElaboratedInstallPlan + -> PostBuildProjectStatus + -> [GhcEnvironmentFileEntry] +renderGhcEnvironmentFile projectRootDir elaboratedInstallPlan + postBuildStatus = headerComment : simpleGhcEnvironmentFile packageDBs unitIds where @@ -715,11 +743,46 @@ ++ "But you still need to use cabal repl $target to get the environment\n" ++ "of specific components (libs, exes, tests etc) because each one can\n" ++ "have its own source dirs, cpp flags etc.\n\n" - unitIds = selectGhcEnviromentFileLibraries postBuildStatus + unitIds = selectGhcEnvironmentFileLibraries postBuildStatus packageDBs = relativePackageDBPaths projectRootDir $ - selectGhcEnviromentFilePackageDbs elaboratedInstallPlan + selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan +argsEquivalentOfGhcEnvironmentFile + :: Compiler + -> DistDirLayout + -> ElaboratedInstallPlan + -> PostBuildProjectStatus + -> [String] +argsEquivalentOfGhcEnvironmentFile compiler = + case compilerId compiler + of CompilerId GHC _ -> argsEquivalentOfGhcEnvironmentFileGhc + CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc + CompilerId _ _ -> error "Only GHC and GHCJS are supported" + +-- TODO remove this when we drop support for non-.ghc.env ghc +argsEquivalentOfGhcEnvironmentFileGhc + :: DistDirLayout + -> ElaboratedInstallPlan + -> PostBuildProjectStatus + -> [String] +argsEquivalentOfGhcEnvironmentFileGhc + distDirLayout + elaboratedInstallPlan + postBuildStatus = + clearPackageDbStackFlag + ++ packageDbArgsDb packageDBs + ++ foldMap packageIdFlag packageIds + where + projectRootDir = distProjectRootDirectory distDirLayout + packageIds = selectGhcEnvironmentFileLibraries postBuildStatus + packageDBs = relativePackageDBPaths projectRootDir $ + selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan + -- TODO use proper flags? but packageDbArgsDb is private + clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"] + packageIdFlag uid = ["-package-id", display uid] + + -- We're producing an environment for users to use in ghci, so of course -- that means libraries only (can't put exes into the ghc package env!). -- The library environment should be /consistent/ with the environment @@ -752,10 +815,10 @@ -- to find the libs) then those exes still end up in our list so we have -- to filter them out at the end. -- -selectGhcEnviromentFileLibraries :: PostBuildProjectStatus -> [UnitId] -selectGhcEnviromentFileLibraries PostBuildProjectStatus{..} = +selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId] +selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} = case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of - Nothing -> error "renderGhcEnviromentFile: broken dep closure" + Nothing -> error "renderGhcEnvironmentFile: broken dep closure" Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes , hasUpToDateLib pkg ] where @@ -773,8 +836,8 @@ && installedUnitId pkg `Set.member` packagesProbablyUpToDate -selectGhcEnviromentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack -selectGhcEnviromentFilePackageDbs elaboratedInstallPlan = +selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack +selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan = -- If we have any inplace packages then their package db stack is the -- one we should use since it'll include the store + the local db but -- it's certainly possible to have no local inplace packages @@ -787,7 +850,7 @@ case ordNub (map elabBuildPackageDBStack pkgs) of [packageDbs] -> packageDbs [] -> [] - _ -> error $ "renderGhcEnviromentFile: packages with " + _ -> error $ "renderGhcEnvironmentFile: packages with " ++ "different package db stacks" -- This should not happen at the moment but will happen as soon -- as we support projects where we build packages with different 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 @@ -3,2969 +3,3490 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-} {-# LANGUAGE DeriveDataTypeable #-} - --- | Planning how to build everything in a project. --- -module Distribution.Client.ProjectPlanning ( - -- * elaborated install plan types - ElaboratedInstallPlan, - ElaboratedConfiguredPackage(..), - ElaboratedPlanPackage, - ElaboratedSharedConfig(..), - ElaboratedReadyPackage, - BuildStyle(..), - CabalFileText, - - -- * Producing the elaborated install plan - rebuildInstallPlan, - - -- * Build targets - PackageTarget(..), - ComponentTarget(..), - SubComponentTarget(..), - showComponentTarget, - - -- * Selecting a plan subset - pruneInstallPlanToTargets, - pruneInstallPlanToDependencies, - - -- * Utils required for building - pkgHasEphemeralBuildTargets, - elabBuildTargetWholeComponents, - - -- * Setup.hs CLI flags for building - setupHsScriptOptions, - setupHsConfigureFlags, - setupHsConfigureArgs, - setupHsBuildFlags, - setupHsBuildArgs, - setupHsReplFlags, - setupHsReplArgs, - setupHsCopyFlags, - setupHsRegisterFlags, - setupHsHaddockFlags, - - packageHashInputs, - - -- TODO: [code cleanup] utils that should live in some shared place? - createPackageDBIfMissing - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.PackageHash -import Distribution.Client.RebuildMonad -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectPlanOutput - -import Distribution.Client.Types -import qualified Distribution.Client.InstallPlan as InstallPlan -import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan -import Distribution.Client.Dependency -import Distribution.Client.Dependency.Types -import qualified Distribution.Client.IndexUtils as IndexUtils -import Distribution.Client.Targets (userToPackageConstraint) -import Distribution.Client.DistDirLayout -import Distribution.Client.SetupWrapper -import Distribution.Client.JobControl -import Distribution.Client.FetchUtils -import qualified Hackage.Security.Client as Sec -import Distribution.Client.Setup hiding (packageName, cabalVersion) -import Distribution.Utils.NubList -import Distribution.Utils.LogProgress -import Distribution.Utils.Progress (failProgress) -import Distribution.Utils.MapAccum - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PkgConfigDb -import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.SolverId -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.InstSolverPackage -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Settings - -import Distribution.ModuleName -import Distribution.Package hiding - (InstalledPackageId, installedPackageId) -import Distribution.System -import qualified Distribution.PackageDescription as Cabal -import qualified Distribution.PackageDescription as PD -import qualified Distribution.PackageDescription.Configuration as PD -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.Simple.Compiler hiding (Flag) -import qualified Distribution.Simple.GHC as GHC --TODO: [code cleanup] eliminate -import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate -import Distribution.Simple.Program -import Distribution.Simple.Program.Db -import Distribution.Simple.Program.Find -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Setup - (Flag, toFlag, flagToMaybe, flagToList, fromFlagOrDefault) -import qualified Distribution.Simple.Configure as Cabal -import qualified Distribution.Simple.LocalBuildInfo as Cabal -import Distribution.Simple.LocalBuildInfo (ComponentName(..)) -import qualified Distribution.Simple.Register as Cabal -import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.InstalledPackageInfo as IPI - -import Distribution.Backpack.ConfiguredComponent -import Distribution.Backpack.LinkedComponent -import Distribution.Backpack.ComponentsGraph -import Distribution.Backpack.ModuleShape -import Distribution.Backpack.FullUnitId -import Distribution.Backpack - -import Distribution.Simple.Utils hiding (matchFileGlob) -import Distribution.Version -import Distribution.Verbosity -import Distribution.Text - -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph(IsNode(..)) - -import Text.PrettyPrint hiding ((<>)) -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 -import Control.Monad.State as State -import Control.Exception -import Data.List (groupBy) -import Data.Either -import Data.Function -import System.FilePath - ------------------------------------------------------------------------------- --- * Elaborated install plan ------------------------------------------------------------------------------- - --- "Elaborated" -- worked out with great care and nicety of detail; --- executed with great minuteness: elaborate preparations; --- elaborate care. --- --- So here's the idea: --- --- Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc --- all passed in as separate args and which are then further selected, --- transformed etc during the execution of the build. Instead we construct --- an elaborated install plan that includes everything we will need, and then --- during the execution of the plan we do as little transformation of this --- info as possible. --- --- So we're trying to split the work into two phases: construction of the --- elaborated install plan (which as far as possible should be pure) and --- then simple execution of that plan without any smarts, just doing what the --- plan says to do. --- --- So that means we need a representation of this fully elaborated install --- plan. The representation consists of two parts: --- --- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a --- representation of source packages that includes a lot more detail about --- that package's individual configuration --- --- * A 'ElaboratedSharedConfig'. Some package configuration is the same for --- every package in a plan. Rather than duplicate that info every entry in --- the 'GenericInstallPlan' we keep that separately. --- --- The division between the shared and per-package config is /not set in stone --- for all time/. For example if we wanted to generalise the install plan to --- describe a situation where we want to build some packages with GHC and some --- with GHCJS then the platform and compiler would no longer be shared between --- all packages but would have to be per-package (probably with some sanity --- condition on the graph structure). --- - --- Refer to ProjectPlanning.Types for details of these important types: - --- type ElaboratedInstallPlan = ... --- type ElaboratedPlanPackage = ... --- data ElaboratedSharedConfig = ... --- data ElaboratedConfiguredPackage = ... --- data BuildStyle = - - --- | Check that an 'ElaboratedConfiguredPackage' actually makes --- sense under some 'ElaboratedSharedConfig'. -sanityCheckElaboratedConfiguredPackage - :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> a - -> a -sanityCheckElaboratedConfiguredPackage sharedConfig - elab@ElaboratedConfiguredPackage{..} = - (case elabPkgOrComp of - ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg - ElabComponent comp -> sanityCheckElaboratedComponent elab comp) - - -- either a package is being built inplace, or the - -- 'installedPackageId' we assigned is consistent with - -- the 'hashedInstalledPackageId' we would compute from - -- the elaborated configured package - . assert (elabBuildStyle == BuildInplaceOnly || - elabComponentId == hashedInstalledPackageId - (packageHashInputs sharedConfig elab)) - - -- the stanzas explicitly disabled should not be available - . assert (Set.null (Map.keysSet (Map.filter not elabStanzasRequested) - `Set.intersection` elabStanzasAvailable)) - - -- either a package is built inplace, or we are not attempting to - -- build any test suites or benchmarks (we never build these - -- for remote packages!) - . assert (elabBuildStyle == BuildInplaceOnly || - Set.null elabStanzasAvailable) - -sanityCheckElaboratedComponent - :: ElaboratedConfiguredPackage - -> ElaboratedComponent - -> a - -> a -sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..} - ElaboratedComponent{..} = - - -- Should not be building bench or test if not inplace. - assert (elabBuildStyle == BuildInplaceOnly || - case compComponentName of - Nothing -> True - Just CLibName -> True - Just (CSubLibName _) -> True - Just (CExeName _) -> True - -- This is interesting: there's no way to declare a dependency - -- on a foreign library at the moment, but you may still want - -- to install these to the store - Just (CFLibName _) -> True - Just (CBenchName _) -> False - Just (CTestName _) -> False) - - -sanityCheckElaboratedPackage - :: ElaboratedConfiguredPackage - -> ElaboratedPackage - -> a - -> a -sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..} - ElaboratedPackage{..} = - -- we should only have enabled stanzas that actually can be built - -- (according to the solver) - assert (pkgStanzasEnabled `Set.isSubsetOf` elabStanzasAvailable) - - -- the stanzas that the user explicitly requested should be - -- enabled (by the previous test, they are also available) - . assert (Map.keysSet (Map.filter id elabStanzasRequested) - `Set.isSubsetOf` pkgStanzasEnabled) - ------------------------------------------------------------------------------- --- * Deciding what to do: making an 'ElaboratedInstallPlan' ------------------------------------------------------------------------------- - --- | Return an up-to-date elaborated install plan and associated config. --- --- Two variants of the install plan are returned: with and without packages --- from the store. That is, the \"improved\" plan where source packages are --- replaced by pre-existing installed packages from the store (when their ids --- match), and also the original elaborated plan which uses primarily source --- packages. - --- The improved plan is what we use for building, but the original elaborated --- plan is useful for reporting and configuration. For example the @freeze@ --- command needs the source package info to know about flag choices and --- dependencies of executables and setup scripts. --- -rebuildInstallPlan :: Verbosity - -> FilePath -> DistDirLayout -> CabalDirLayout - -> ProjectConfig - -> IO ( ElaboratedInstallPlan -- with store packages - , ElaboratedInstallPlan -- with source packages - , ElaboratedSharedConfig - , ProjectConfig ) - -- ^ @(improvedPlan, elaboratedPlan, _, _)@ -rebuildInstallPlan verbosity - projectRootDir - distDirLayout@DistDirLayout { - distDirectory, - distProjectCacheFile, - distProjectCacheDirectory - } - cabalDirLayout@CabalDirLayout { - cabalStoreDirectory, - cabalStorePackageDB - } - cliConfig = - runRebuild projectRootDir $ do - progsearchpath <- liftIO $ getSystemSearchPath - let cliConfigPersistent = cliConfig { projectConfigBuildOnly = mempty } - - -- The overall improved plan is cached - rerunIfChanged verbosity fileMonitorImprovedPlan - -- react to changes in command line args and the path - (cliConfigPersistent, progsearchpath) $ do - - -- And so is the elaborated plan that the improved plan based on - (elaboratedPlan, elaboratedShared, - projectConfig) <- - rerunIfChanged verbosity fileMonitorElaboratedPlan - (cliConfigPersistent, progsearchpath) $ do - - (projectConfig, projectConfigTransient) <- phaseReadProjectConfig - localPackages <- phaseReadLocalPackages projectConfig - compilerEtc <- phaseConfigureCompiler projectConfig - _ <- phaseConfigurePrograms projectConfig compilerEtc - (solverPlan, pkgConfigDB) - <- phaseRunSolver projectConfigTransient - compilerEtc - localPackages - (elaboratedPlan, - elaboratedShared) <- phaseElaboratePlan projectConfigTransient - compilerEtc pkgConfigDB - solverPlan - localPackages - - phaseMaintainPlanOutputs elaboratedPlan elaboratedShared - let instantiatedPlan = phaseInstantiatePlan elaboratedPlan - liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) - - return (instantiatedPlan, elaboratedShared, projectConfig) - - -- The improved plan changes each time we install something, whereas - -- the underlying elaborated plan only changes when input config - -- changes, so it's worth caching them separately. - improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared - - return (improvedPlan, elaboratedPlan, elaboratedShared, projectConfig) - - where - fileMonitorCompiler = newFileMonitorInCacheDir "compiler" - fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan" - fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes" - fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan" - fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan" - - newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b - newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile - - -- Read the cabal.project (or implicit config) and combine it with - -- arguments from the command line - -- - phaseReadProjectConfig :: Rebuild (ProjectConfig, ProjectConfig) - phaseReadProjectConfig = do - liftIO $ do - info verbosity "Project settings changed, reconfiguring..." - createDirectoryIfMissingVerbose verbosity True distDirectory - createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - - projectConfig <- readProjectConfig verbosity projectRootDir - - -- The project config comming from the command line includes "build only" - -- flags that we don't cache persistently (because like all "build only" - -- flags they do not affect the value of the outcome) but that we do - -- sometimes using during planning (in particular the http transport) - let projectConfigTransient = projectConfig <> cliConfig - projectConfigPersistent = projectConfig - <> cliConfig { - projectConfigBuildOnly = mempty - } - liftIO $ writeProjectConfigFile (distProjectCacheFile "config") - projectConfigPersistent - return (projectConfigPersistent, projectConfigTransient) - - -- Look for all the cabal packages in the project - -- some of which may be local src dirs, tarballs etc - -- - phaseReadLocalPackages :: ProjectConfig - -> Rebuild [UnresolvedSourcePackage] - phaseReadLocalPackages projectConfig = do - - localCabalFiles <- findProjectPackages projectRootDir projectConfig - mapM (readSourcePackage verbosity) localCabalFiles - - - -- Configure the compiler we're using. - -- - -- This is moderately expensive and doesn't change that often so we cache - -- it independently. - -- - phaseConfigureCompiler :: ProjectConfig - -> Rebuild (Compiler, Platform, ProgramDb) - phaseConfigureCompiler ProjectConfig { - projectConfigShared = ProjectConfigShared { - projectConfigHcFlavor, - projectConfigHcPath, - projectConfigHcPkg - }, - projectConfigLocalPackages = PackageConfig { - packageConfigProgramPaths, - packageConfigProgramArgs, - packageConfigProgramPathExtra - } - } = do - progsearchpath <- liftIO $ getSystemSearchPath - rerunIfChanged verbosity fileMonitorCompiler - (hcFlavor, hcPath, hcPkg, progsearchpath, - packageConfigProgramPaths, - packageConfigProgramArgs, - packageConfigProgramPathExtra) $ do - - liftIO $ info verbosity "Compiler settings changed, reconfiguring..." - result@(_, _, progdb') <- liftIO $ - Cabal.configCompilerEx - hcFlavor hcPath hcPkg - progdb verbosity - - -- Note that we added the user-supplied program locations and args - -- for /all/ programs, not just those for the compiler prog and - -- compiler-related utils. In principle we don't know which programs - -- the compiler will configure (and it does vary between compilers). - -- We do know however that the compiler will only configure the - -- programs it cares about, and those are the ones we monitor here. - monitorFiles (programsMonitorFiles progdb') - - return result - where - hcFlavor = flagToMaybe projectConfigHcFlavor - hcPath = flagToMaybe projectConfigHcPath - hcPkg = flagToMaybe projectConfigHcPkg - progdb = - userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) - . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) - . modifyProgramSearchPath - (++ [ ProgramSearchPathDir dir - | dir <- fromNubList packageConfigProgramPathExtra ]) - $ defaultProgramDb - - - -- Configuring other programs. - -- - -- Having configred the compiler, now we configure all the remaining - -- programs. This is to check we can find them, and to monitor them for - -- changes. - -- - -- TODO: [required eventually] we don't actually do this yet. - -- - -- We rely on the fact that the previous phase added the program config for - -- all local packages, but that all the programs configured so far are the - -- compiler program or related util programs. - -- - phaseConfigurePrograms :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> Rebuild () - phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do - -- Users are allowed to specify program locations independently for - -- each package (e.g. to use a particular version of a pre-processor - -- for some packages). However they cannot do this for the compiler - -- itself as that's just not going to work. So we check for this. - liftIO $ checkBadPerPackageCompilerPaths - (configuredPrograms compilerprogdb) - (getMapMappend (projectConfigSpecificPackage projectConfig)) - - --TODO: [required eventually] find/configure other programs that the - -- user specifies. - - --TODO: [required eventually] find/configure all build-tools - -- but note that some of them may be built as part of the plan. - - - -- Run the solver to get the initial install plan. - -- This is expensive so we cache it independently. - -- - phaseRunSolver :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> [UnresolvedSourcePackage] - -> Rebuild (SolverInstallPlan, PkgConfigDb) - phaseRunSolver projectConfig@ProjectConfig { - projectConfigShared, - projectConfigBuildOnly - } - (compiler, platform, progdb) - localPackages = - rerunIfChanged verbosity fileMonitorSolverPlan - (solverSettings, - localPackages, localPackagesEnabledStanzas, - compiler, platform, programDbSignature progdb) $ do - - installedPkgIndex <- getInstalledPackages verbosity - compiler progdb platform - corePackageDbs - sourcePkgDb <- getSourcePackages verbosity withRepoCtx - (solverSettingIndexState solverSettings) - pkgConfigDB <- getPkgConfigDb verbosity progdb - - --TODO: [code cleanup] it'd be better if the Compiler contained the - -- ConfiguredPrograms that it needs, rather than relying on the progdb - -- since we don't need to depend on all the programs here, just the - -- ones relevant for the compiler. - - liftIO $ do - solver <- chooseSolver verbosity - (solverSettingSolver solverSettings) - (compilerInfo compiler) - - notice verbosity "Resolving dependencies..." - plan <- foldProgress logMsg die return $ - planPackages compiler platform solver solverSettings - installedPkgIndex sourcePkgDb pkgConfigDB - localPackages localPackagesEnabledStanzas - return (plan, pkgConfigDB) - where - corePackageDbs = [GlobalPackageDB] - withRepoCtx = projectConfigWithSolverRepoContext verbosity - projectConfigShared - projectConfigBuildOnly - solverSettings = resolveSolverSettings projectConfig - logMsg message rest = debugNoWrap verbosity message >> rest - - localPackagesEnabledStanzas = - Map.fromList - [ (pkgname, stanzas) - | pkg <- localPackages - , let pkgname = packageName pkg - testsEnabled = lookupLocalPackageConfig - packageConfigTests - projectConfig pkgname - benchmarksEnabled = lookupLocalPackageConfig - packageConfigBenchmarks - projectConfig pkgname - stanzas = - Map.fromList $ - [ (TestStanzas, enabled) - | enabled <- flagToList testsEnabled ] - ++ [ (BenchStanzas , enabled) - | enabled <- flagToList benchmarksEnabled ] - ] - - -- Elaborate the solver's install plan to get a fully detailed plan. This - -- version of the plan has the final nix-style hashed ids. - -- - phaseElaboratePlan :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> PkgConfigDb - -> SolverInstallPlan - -> [SourcePackage loc] - -> Rebuild ( ElaboratedInstallPlan - , ElaboratedSharedConfig ) - phaseElaboratePlan ProjectConfig { - projectConfigShared, - projectConfigLocalPackages, - projectConfigSpecificPackage, - projectConfigBuildOnly - } - (compiler, platform, progdb) pkgConfigDB - solverPlan localPackages = do - - liftIO $ debug verbosity "Elaborating the install plan..." - - sourcePackageHashes <- - rerunIfChanged verbosity fileMonitorSourceHashes - (packageLocationsSignature solverPlan) $ - getPackageSourceHashes verbosity withRepoCtx solverPlan - - defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler - (elaboratedPlan, elaboratedShared) - <- liftIO . runLogProgress verbosity $ - elaborateInstallPlan - verbosity - platform compiler progdb pkgConfigDB - distDirLayout - cabalDirLayout - solverPlan - localPackages - sourcePackageHashes - defaultInstallDirs - projectConfigShared - projectConfigLocalPackages - (getMapMappend projectConfigSpecificPackage) - liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan) - return (elaboratedPlan, elaboratedShared) - where - withRepoCtx = projectConfigWithSolverRepoContext verbosity - projectConfigShared - projectConfigBuildOnly - - phaseInstantiatePlan :: ElaboratedInstallPlan - -> ElaboratedInstallPlan - phaseInstantiatePlan plan = instantiateInstallPlan plan - - -- Update the files we maintain that reflect our current build environment. - -- In particular we maintain a JSON representation of the elaborated - -- install plan (but not the improved plan since that reflects the state - -- of the build rather than just the input environment). - -- - phaseMaintainPlanOutputs :: ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> Rebuild () - phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do - debug verbosity "Updating plan.json" - writePlanExternalRepresentation - distDirLayout - elaboratedPlan - elaboratedShared - - - -- Improve the elaborated install plan. The elaborated plan consists - -- mostly of source packages (with full nix-style hashed ids). Where - -- corresponding installed packages already exist in the store, replace - -- them in the plan. - -- - -- Note that we do monitor the store's package db here, so we will redo - -- this improvement phase when the db changes -- including as a result of - -- executing a plan and installing things. - -- - phaseImprovePlan :: ElaboratedInstallPlan - -> ElaboratedSharedConfig - -> Rebuild ElaboratedInstallPlan - phaseImprovePlan elaboratedPlan elaboratedShared = do - - liftIO $ debug verbosity "Improving the install plan..." - createDirectoryMonitored True storeDirectory - liftIO $ createPackageDBIfMissing verbosity - compiler progdb - storePackageDb - storePkgIdSet <- getInstalledStorePackages storeDirectory - let improvedPlan = improveInstallPlanWithInstalledPackages - storePkgIdSet - elaboratedPlan - liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan) - -- TODO: [nice to have] having checked which packages from the store - -- we're using, it may be sensible to sanity check those packages - -- by loading up the compiler package db and checking everything - -- matches up as expected, e.g. no dangling deps, files deleted. - return improvedPlan - where - storeDirectory = cabalStoreDirectory (compilerId compiler) - storePackageDb = cabalStorePackageDB (compilerId compiler) - ElaboratedSharedConfig { - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = progdb - } = elaboratedShared - - -programsMonitorFiles :: ProgramDb -> [MonitorFilePath] -programsMonitorFiles progdb = - [ monitor - | prog <- configuredPrograms progdb - , monitor <- monitorFileSearchPath (programMonitorFiles prog) - (programPath prog) - ] - --- | Select the bits of a 'ProgramDb' to monitor for value changes. --- Use 'programsMonitorFiles' for the files to monitor. --- -programDbSignature :: ProgramDb -> [ConfiguredProgram] -programDbSignature progdb = - [ prog { programMonitorFiles = [] - , programOverrideEnv = filter ((/="PATH") . fst) - (programOverrideEnv prog) } - | prog <- configuredPrograms progdb ] - -getInstalledPackages :: Verbosity - -> Compiler -> ProgramDb -> Platform - -> PackageDBStack - -> Rebuild InstalledPackageIndex -getInstalledPackages verbosity compiler progdb platform packagedbs = do - monitorFiles . map monitorFileOrDirectory - =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles - verbosity compiler - packagedbs progdb platform) - liftIO $ IndexUtils.getInstalledPackages - verbosity compiler - packagedbs progdb - -{- ---TODO: [nice to have] use this but for sanity / consistency checking -getPackageDBContents :: Verbosity - -> Compiler -> ProgramDb -> Platform - -> PackageDB - -> Rebuild InstalledPackageIndex -getPackageDBContents verbosity compiler progdb platform packagedb = do - monitorFiles . map monitorFileOrDirectory - =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles - verbosity compiler - [packagedb] progdb platform) - liftIO $ do - createPackageDBIfMissing verbosity compiler progdb packagedb - Cabal.getPackageDBContents verbosity compiler - packagedb progdb --} - --- | Return the 'UnitId's of all packages\/components already installed in the --- store. --- -getInstalledStorePackages :: FilePath -- ^ store directory - -> Rebuild (Set UnitId) -getInstalledStorePackages storeDirectory = do - paths <- getDirectoryContentsMonitored storeDirectory - return $ Set.fromList [ newSimpleUnitId (mkComponentId path) - | path <- paths, valid path ] - where - valid ('.':_) = False - valid "package.db" = False - valid _ = True - -getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a) - -> IndexUtils.IndexState -> Rebuild SourcePackageDb -getSourcePackages verbosity withRepoCtx idxState = do - (sourcePkgDb, repos) <- - liftIO $ - withRepoCtx $ \repoctx -> do - sourcePkgDb <- IndexUtils.getSourcePackagesAtIndexState verbosity - repoctx idxState - return (sourcePkgDb, repoContextRepos repoctx) - - monitorFiles . map monitorFile - . IndexUtils.getSourcePackagesMonitorFiles - $ repos - return sourcePkgDb - - --- | Create a package DB if it does not currently exist. Note that this action --- is /not/ safe to run concurrently. --- -createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb - -> PackageDB -> IO () -createPackageDBIfMissing verbosity compiler progdb - (SpecificPackageDB dbPath) = do - exists <- liftIO $ Cabal.doesPackageDBExist dbPath - unless exists $ do - createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) - Cabal.createPackageDB verbosity compiler progdb False dbPath -createPackageDBIfMissing _ _ _ _ = return () - - -getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb -getPkgConfigDb verbosity progdb = do - dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb - -- Just monitor the dirs so we'll notice new .pc files. - -- Alternatively we could monitor all the .pc files too. - mapM_ monitorDirectoryStatus dirs - liftIO $ readPkgConfigDb verbosity progdb - - --- | Select the config values to monitor for changes package source hashes. -packageLocationsSignature :: SolverInstallPlan - -> [(PackageId, PackageLocation (Maybe FilePath))] -packageLocationsSignature solverPlan = - [ (packageId pkg, packageSource pkg) - | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) - <- SolverInstallPlan.toList solverPlan - ] - - --- | Get the 'HashValue' for all the source packages where we use hashes, --- and download any packages required to do so. --- --- Note that we don't get hashes for local unpacked packages. --- -getPackageSourceHashes :: Verbosity - -> (forall a. (RepoContext -> IO a) -> IO a) - -> SolverInstallPlan - -> Rebuild (Map PackageId PackageSourceHash) -getPackageSourceHashes verbosity withRepoCtx solverPlan = do - - -- Determine if and where to get the package's source hash from. - -- - let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))] - allPkgLocations = - [ (packageId pkg, packageSource pkg) - | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) - <- SolverInstallPlan.toList solverPlan ] - - -- Tarballs that were local in the first place. - -- We'll hash these tarball files directly. - localTarballPkgs :: [(PackageId, FilePath)] - localTarballPkgs = - [ (pkgid, tarball) - | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ] - - -- Tarballs from remote URLs. We must have downloaded these already - -- (since we extracted the .cabal file earlier) - --TODO: [required eventually] finish remote tarball functionality --- allRemoteTarballPkgs = --- [ (pkgid, ) --- | (pkgid, RemoteTarballPackage ) <- allPkgLocations ] - - -- Tarballs from repositories, either where the repository provides - -- hashes as part of the repo metadata, or where we will have to - -- download and hash the tarball. - repoTarballPkgsWithMetadata :: [(PackageId, Repo)] - repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)] - (repoTarballPkgsWithMetadata, - repoTarballPkgsWithoutMetadata) = - partitionEithers - [ case repo of - RepoSecure{} -> Left (pkgid, repo) - _ -> Right (pkgid, repo) - | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ] - - -- For tarballs from repos that do not have hashes available we now have - -- to check if the packages were downloaded already. - -- - (repoTarballPkgsToDownload, - repoTarballPkgsDownloaded) - <- fmap partitionEithers $ - liftIO $ sequence - [ do mtarball <- checkRepoTarballFetched repo pkgid - case mtarball of - Nothing -> return (Left (pkgid, repo)) - Just tarball -> return (Right (pkgid, tarball)) - | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ] - - (hashesFromRepoMetadata, - repoTarballPkgsNewlyDownloaded) <- - -- Avoid having to initialise the repository (ie 'withRepoCtx') if we - -- don't have to. (The main cost is configuring the http client.) - if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata - then return (Map.empty, []) - else liftIO $ withRepoCtx $ \repoctx -> do - - -- For tarballs from repos that do have hashes available as part of the - -- repo metadata we now load up the index for each repo and retrieve - -- the hashes for the packages - -- - hashesFromRepoMetadata <- - Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions - fmap (Map.fromList . concat) $ - sequence - -- Reading the repo index is expensive so we group the packages by repo - [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> - Sec.withIndex secureRepo $ \repoIndex -> - sequence - [ do hash <- Sec.trusted <$> -- strip off Trusted tag - Sec.indexLookupHash repoIndex pkgid - -- Note that hackage-security currently uses SHA256 - -- but this API could in principle give us some other - -- choice in future. - return (pkgid, hashFromTUF hash) - | pkgid <- pkgids ] - | (repo, pkgids) <- - map (\grp@((_,repo):_) -> (repo, map fst grp)) - . groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) - . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) - $ repoTarballPkgsWithMetadata - ] - - -- For tarballs from repos that do not have hashes available, download - -- the ones we previously determined we need. - -- - repoTarballPkgsNewlyDownloaded <- - sequence - [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid - return (pkgid, tarball) - | (pkgid, repo) <- repoTarballPkgsToDownload ] - - return (hashesFromRepoMetadata, - repoTarballPkgsNewlyDownloaded) - - -- Hash tarball files for packages where we have to do that. This includes - -- tarballs that were local in the first place, plus tarballs from repos, - -- either previously cached or freshly downloaded. - -- - let allTarballFilePkgs :: [(PackageId, FilePath)] - allTarballFilePkgs = localTarballPkgs - ++ repoTarballPkgsDownloaded - ++ repoTarballPkgsNewlyDownloaded - hashesFromTarballFiles <- liftIO $ - fmap Map.fromList $ - sequence - [ do srchash <- readFileHashValue tarball - return (pkgid, srchash) - | (pkgid, tarball) <- allTarballFilePkgs - ] - monitorFiles [ monitorFile tarball - | (_pkgid, tarball) <- allTarballFilePkgs ] - - -- Return the combination - return $! hashesFromRepoMetadata - <> hashesFromTarballFiles - - --- ------------------------------------------------------------ --- * Installation planning --- ------------------------------------------------------------ - -planPackages :: Compiler - -> Platform - -> Solver -> SolverSettings - -> InstalledPackageIndex - -> SourcePackageDb - -> PkgConfigDb - -> [UnresolvedSourcePackage] - -> Map PackageName (Map OptionalStanza Bool) - -> Progress String String SolverInstallPlan -planPackages comp platform solver SolverSettings{..} - installedPkgIndex sourcePkgDb pkgConfigDB - localPackages pkgStanzasEnable = - - resolveDependencies - platform (compilerInfo comp) - pkgConfigDB solver - resolverParams - - where - - --TODO: [nice to have] disable multiple instances restriction in the solver, but then - -- make sure we can cope with that in the output. - resolverParams = - - setMaxBackjumps solverSettingMaxBackjumps - - --TODO: [required eventually] should only be configurable for custom installs - -- . setIndependentGoals solverSettingIndependentGoals - - . setReorderGoals solverSettingReorderGoals - - . setCountConflicts solverSettingCountConflicts - - --TODO: [required eventually] should only be configurable for custom installs - -- . setAvoidReinstalls solverSettingAvoidReinstalls - - --TODO: [required eventually] should only be configurable for custom installs - -- . setShadowPkgs solverSettingShadowPkgs - - . setStrongFlags solverSettingStrongFlags - - --TODO: [required eventually] decide if we need to prefer installed for - -- global packages, or prefer latest even for global packages. Perhaps - -- should be configurable but with a different name than "upgrade-dependencies". - . setPreferenceDefault PreferLatestForSelected - {-(if solverSettingUpgradeDeps - then PreferAllLatest - else PreferLatestForSelected)-} - - . removeLowerBounds solverSettingAllowOlder - . removeUpperBounds solverSettingAllowNewer - - . addDefaultSetupDependencies (defaultSetupDeps comp platform - . PD.packageDescription - . packageDescription) - - . addPreferences - -- preferences from the config file or command line - [ PackageVersionPreference name ver - | Dependency name ver <- solverSettingPreferences ] - - . addConstraints - - -- If a package has a custom setup then we need to add a setup-depends - -- on Cabal. For now it's easier to add this unconditionally. Once - -- qualified constraints land we can turn this into a custom setup - -- only constraint. - -- - -- TODO: use a qualified constraint - [ LabeledPackageConstraint (PackageConstraintVersion cabalPkgname - (orLaterVersion (mkVersion [1,20]))) - ConstraintNewBuildCustomSetupLowerBoundCabal - ] . addConstraints - -- version constraints from the config file or command line - [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- solverSettingConstraints ] - - . addPreferences - -- enable stanza preference where the user did not specify - [ PackageStanzasPreference pkgname stanzas - | pkg <- localPackages - , let pkgname = packageName pkg - stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable - stanzas = [ stanza | stanza <- [minBound..maxBound] - , Map.lookup stanza stanzaM == Nothing ] - , not (null stanzas) - ] - - . addConstraints - -- enable stanza constraints where the user asked to enable - [ LabeledPackageConstraint - (PackageConstraintStanzas pkgname stanzas) - ConstraintSourceConfigFlagOrTarget - | pkg <- localPackages - , let pkgname = packageName pkg - stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable - stanzas = [ stanza | stanza <- [minBound..maxBound] - , Map.lookup stanza stanzaM == Just True ] - , not (null stanzas) - ] - - . addConstraints - --TODO: [nice to have] should have checked at some point that the - -- package in question actually has these flags. - [ LabeledPackageConstraint - (PackageConstraintFlags pkgname flags) - ConstraintSourceConfigFlagOrTarget - | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ] - - . addConstraints - --TODO: [nice to have] we have user-supplied flags for unspecified - -- local packages (as well as specific per-package flags). For the - -- former we just apply all these flags to all local targets which - -- is silly. We should check if the flags are appropriate. - [ LabeledPackageConstraint - (PackageConstraintFlags pkgname flags) - ConstraintSourceConfigFlagOrTarget - | let flags = solverSettingFlagAssignment - , not (null flags) - , pkg <- localPackages - , let pkgname = packageName pkg ] - - $ stdResolverParams - - stdResolverParams = - -- Note: we don't use the standardInstallPolicy here, since that uses - -- its own addDefaultSetupDependencies that is not appropriate for us. - basicInstallPolicy - installedPkgIndex sourcePkgDb - (map SpecificSourcePackage localPackages) - - ------------------------------------------------------------------------------- --- * Install plan post-processing ------------------------------------------------------------------------------- - --- This phase goes from the InstallPlan we get from the solver and has to --- make an elaborated install plan. --- --- We go in two steps: --- --- 1. elaborate all the source packages that the solver has chosen. --- 2. swap source packages for pre-existing installed packages wherever --- possible. --- --- We do it in this order, elaborating and then replacing, because the easiest --- way to calculate the installed package ids used for the replacement step is --- from the elaborated configuration for each package. - - - - ------------------------------------------------------------------------------- --- * Install plan elaboration ------------------------------------------------------------------------------- - --- | Produce an elaborated install plan using the policy for local builds with --- a nix-style shared store. --- --- In theory should be able to make an elaborated install plan with a policy --- matching that of the classic @cabal install --user@ or @--global@ --- -elaborateInstallPlan - :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb - -> DistDirLayout - -> CabalDirLayout - -> SolverInstallPlan - -> [SourcePackage loc] - -> Map PackageId PackageSourceHash - -> InstallDirs.InstallDirTemplates - -> ProjectConfigShared - -> PackageConfig - -> Map PackageName PackageConfig - -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) -elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB - DistDirLayout{..} - cabalDirLayout@CabalDirLayout{cabalStorePackageDB} - solverPlan localPackages - sourcePackageHashes - defaultInstallDirs - _sharedPackageConfig - localPackagesConfig - perPackageConfig = do - x <- elaboratedInstallPlan - return (x, elaboratedSharedConfig) - where - elaboratedSharedConfig = - ElaboratedSharedConfig { - pkgConfigPlatform = platform, - pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = compilerprogdb - } - - preexistingInstantiatedPkgs = - Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan)) - where - f (SolverInstallPlan.PreExisting inst) - | not (IPI.indefinite ipkg) - = Just (IPI.installedUnitId ipkg, - (FullUnitId (IPI.installedComponentId ipkg) - (Map.fromList (IPI.instantiatedWith ipkg)))) - where ipkg = instSolverPkgIPI inst - f _ = Nothing - - elaboratedInstallPlan = - flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> - case planpkg of - SolverInstallPlan.PreExisting pkg -> - return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] - - SolverInstallPlan.Configured pkg -> - map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg - - -- NB: We don't INSTANTIATE packages at this point. That's - -- a post-pass. This makes it simpler to compute dependencies. - elaborateSolverToComponents - :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverPackage UnresolvedPkgLoc - -> LogProgress [ElaboratedConfiguredPackage] - elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) - | Right g <- toComponentsGraph (elabEnabledSpec elab0) pd = do - infoProgress $ hang (text "Component graph for" <+> disp pkgid <<>> colon) - 4 (dispComponentsGraph g) - (_, comps) <- mapAccumM buildComponent - ((Map.empty, Map.empty), Map.empty, Map.empty) - (map fst g) - let is_public_lib ElaboratedConfiguredPackage{..} = - case elabPkgOrComp of - ElabComponent comp -> compSolverName comp == CD.ComponentLib - _ -> False - modShape = case find is_public_lib comps of - Nothing -> emptyModuleShape - Just ElaboratedConfiguredPackage{..} -> elabModuleShape - return $ if eligible - then comps - else [(elaborateSolverToPackage mapDep spkg) { - elabModuleShape = modShape - }] - | otherwise = failProgress (text "component cycle in" <+> disp pkgid) - where - eligible - -- At this point in time, only non-Custom setup scripts - -- are supported. Implementing per-component builds with - -- Custom would require us to create a new 'ElabSetup' - -- type, and teach all of the code paths how to handle it. - -- Once you've implemented this, swap it for the code below. - = fromMaybe PD.Custom (PD.buildType (elabPkgDescription elab0)) /= PD.Custom - {- - -- Only non-Custom or sufficiently recent Custom - -- scripts can be build per-component. - = (fromMaybe PD.Custom (PD.buildType pd) /= PD.Custom) - || PD.specVersion pd >= mkVersion [1,25,0] - -} - - elab0 = elaborateSolverToCommon mapDep spkg - pkgid = elabPkgSourceId elab0 - pd = elabPkgDescription elab0 - - buildComponent - :: (ConfiguredComponentMap, - LinkedComponentMap, - Map ComponentId FilePath) - -> Cabal.Component - -> LogProgress - ((ConfiguredComponentMap, - LinkedComponentMap, - Map ComponentId FilePath), - ElaboratedConfiguredPackage) - buildComponent (cc_map, lc_map, exe_map) comp = do - -- Before we get too far, check if we depended on something - -- unbuildable. If we did, give a good error. (If we don't - -- check, the 'toConfiguredComponent' will assert fail, see #3978). - case unbuildable_external_lib_deps of - [] -> return () - deps -> failProgress $ - text "The package" <+> disp pkgid <+> - text "depends on unbuildable libraries:" <+> - hsep (punctuate comma (map (disp.solverSrcId) deps)) - case unbuildable_external_exe_deps of - [] -> return () - deps -> failProgress $ - text "The package" <+> disp pkgid <+> - text "depends on unbuildable executables:" <+> - hsep (punctuate comma (map (disp.solverSrcId) deps)) - infoProgress $ dispConfiguredComponent cc - let -- Use of invariant: DefUnitId indicates that if - -- there is no hash, it must have an empty - -- instantiation. - lookup_uid def_uid = - case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of - Just full -> full - Nothing -> error ("lookup_uid: " ++ display def_uid) - lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0) - (Map.union external_lc_map lc_map) cc - let lc_map' = extendLinkedComponentMap lc lc_map - infoProgress $ dispLinkedComponent lc - -- NB: For inplace NOT InstallPaths.bindir installDirs; for an - -- inplace build those values are utter nonsense. So we - -- have to guess where the directory is going to be. - -- Fortunately this is "stable" part of Cabal API. - -- But the way we get the build directory is A HORRIBLE - -- HACK. - let elab = elab1 { - elabModuleShape = lc_shape lc, - elabUnitId = abstractUnitId (lc_uid lc), - elabComponentId = lc_cid lc, - elabLinkedInstantiatedWith = Map.fromList (lc_insts lc), - elabPkgOrComp = ElabComponent $ elab_comp { - compLinkedLibDependencies = map fst (lc_depends lc), - compNonSetupDependencies = - ordNub (map (abstractUnitId . fst) (lc_depends lc)) - } - } - inplace_bin_dir - | shouldBuildInplaceOnly spkg - = distBuildDirectory - (elabDistDirParams elaboratedSharedConfig elab) - "build" case Cabal.componentNameString cname of - Just n -> display n - Nothing -> "" - | otherwise - = InstallDirs.bindir install_dirs - exe_map' = Map.insert cid inplace_bin_dir exe_map - return ((cc_map', lc_map', exe_map'), elab) - where - elab1 = elab0 { - elabInstallDirs = install_dirs, - elabRequiresRegistration = requires_reg, - elabPkgOrComp = ElabComponent $ elab_comp - } - elab_comp = ElaboratedComponent {..} - compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" - compNonSetupDependencies = error "buildComponent: compNonSetupDependencies" - - cc = toConfiguredComponent pd cid external_cc_map cc_map comp - cc_map' = extendConfiguredComponentMap cc cc_map - - cid :: ComponentId - cid = case elabBuildStyle elab0 of - BuildInplaceOnly -> - mkComponentId $ - display pkgid ++ "-inplace" ++ - (case Cabal.componentNameString cname of - Nothing -> "" - Just s -> "-" ++ display s) - BuildAndInstall -> - hashedInstalledPackageId - (packageHashInputs - elaboratedSharedConfig - elab1) -- knot tied - - cname = Cabal.componentName comp - requires_reg = case cname of - CLibName -> True - CSubLibName _ -> True - _ -> False - compComponentName = Just cname - compSolverName = CD.componentNameToComponent cname - -- NB: compLinkedLibDependencies and - -- compNonSetupDependencies are defined when we define - -- 'elab'. - compLibDependencies = - concatMap (elaborateLibSolverId mapDep) external_lib_dep_sids - compExeDependencies = - map confInstId - (concatMap (elaborateExeSolverId mapDep) external_exe_dep_sids) ++ - cc_internal_build_tools cc - compExeDependencyPaths = - concatMap (elaborateExePath mapDep) - (CD.select (== compSolverName) exe_deps0) ++ - [ path - | cid' <- compExeDependencies - , Just path <- [Map.lookup cid' exe_map]] - - bi = Cabal.componentBuildInfo comp - compPkgConfigDependencies = - [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! " - ++ display pn ++ " from " - ++ display (elabPkgSourceId elab1)) - (pkgConfigDbPkgVersion pkgConfigDB pn)) - | PkgconfigDependency pn _ <- PD.pkgconfigDepends bi ] - - compSetupDependencies = concatMap (elaborateLibSolverId mapDep) (CD.setupDeps deps0) - - install_dirs - | shouldBuildInplaceOnly spkg - -- use the ordinary default install dirs - = (InstallDirs.absoluteInstallDirs - pkgid - (newSimpleUnitId cid) - (compilerInfo compiler) - InstallDirs.NoCopyDest - platform - defaultInstallDirs) { - - InstallDirs.libsubdir = "", -- absoluteInstallDirs sets these as - InstallDirs.datasubdir = "" -- 'undefined' but we have to use - } -- them as "Setup.hs configure" args - - | otherwise - -- use special simplified install dirs - = storePackageInstallDirs - cabalDirLayout - (compilerId compiler) - cid - - external_lib_dep_sids = CD.select (== compSolverName) deps0 - external_lib_dep_pkgs = concatMap (elaborateLibSolverId' mapDep) external_lib_dep_sids - external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 - external_cc_map = Map.fromList (map mkPkgNameMapping external_lib_dep_pkgs) - external_lc_map = Map.fromList (map mkShapeMapping external_lib_dep_pkgs) - - unbuildable_external_lib_deps = - filter (null . elaborateLibSolverId mapDep) external_lib_dep_sids - unbuildable_external_exe_deps = - filter (null . elaborateExeSolverId mapDep) external_exe_dep_sids - - mkPkgNameMapping :: ElaboratedPlanPackage - -> (PackageName, (ComponentId, PackageId)) - mkPkgNameMapping dpkg = - (packageName dpkg, (getComponentId dpkg, packageId dpkg)) - - mkShapeMapping :: ElaboratedPlanPackage - -> (ComponentId, (OpenUnitId, ModuleShape)) - mkShapeMapping dpkg = - (getComponentId dpkg, (indef_uid, shape)) - where - (dcid, shape) = case dpkg of - InstallPlan.PreExisting dipkg -> - (IPI.installedComponentId dipkg, shapeInstalledPackage dipkg) - InstallPlan.Configured elab' -> - (elabComponentId elab', elabModuleShape elab') - InstallPlan.Installed elab' -> - (elabComponentId elab', elabModuleShape elab') - indef_uid = - IndefFullUnitId dcid - (Map.fromList [ (req, OpenModuleVar req) - | req <- Set.toList (modShapeRequires shape)]) - - elaborateLibSolverId' :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverId -> [ElaboratedPlanPackage] - elaborateLibSolverId' mapDep = filter is_lib . mapDep - where is_lib (InstallPlan.PreExisting _) = True - is_lib (InstallPlan.Configured elab) = - case elabPkgOrComp elab of - ElabPackage _ -> True - ElabComponent comp -> compSolverName comp == CD.ComponentLib - is_lib (InstallPlan.Installed _) = unexpectedState - - elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverId -> [ConfiguredId] - elaborateLibSolverId mapDep = map configuredId . elaborateLibSolverId' mapDep - - elaborateExeSolverId :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverId -> [ConfiguredId] - elaborateExeSolverId mapDep = map configuredId . filter is_exe . mapDep - where is_exe (InstallPlan.PreExisting _) = False - is_exe (InstallPlan.Configured elab) = - case elabPkgOrComp elab of - ElabPackage _ -> True - ElabComponent comp -> - case compSolverName comp of - CD.ComponentExe _ -> True - _ -> False - is_exe (InstallPlan.Installed _) = unexpectedState - - elaborateExePath :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverId -> [FilePath] - elaborateExePath mapDep = concatMap get_exe_path . mapDep - where - -- Pre-existing executables are assumed to be in PATH - -- already. In fact, this should be impossible. - -- Modest duplication with 'inplace_bin_dir' - get_exe_path (InstallPlan.PreExisting _) = [] - get_exe_path (InstallPlan.Configured elab) = - [if elabBuildStyle elab == BuildInplaceOnly - then distBuildDirectory - (elabDistDirParams elaboratedSharedConfig elab) - "build" - case elabPkgOrComp elab of - ElabPackage _ -> "" - ElabComponent comp -> - case fmap Cabal.componentNameString - (compComponentName comp) of - Just (Just n) -> display n - _ -> "" - else InstallDirs.bindir (elabInstallDirs elab)] - get_exe_path (InstallPlan.Installed _) = unexpectedState - - unexpectedState = error "elaborateInstallPlan: unexpected Installed state" - - elaborateSolverToPackage :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverPackage UnresolvedPkgLoc - -> ElaboratedConfiguredPackage - elaborateSolverToPackage - mapDep - pkg@(SolverPackage (SourcePackage pkgid _gdesc _srcloc _descOverride) - _flags _stanzas deps0 exe_deps0) = - -- Knot tying: the final elab includes the - -- pkgInstalledId, which is calculated by hashing many - -- of the other fields of the elaboratedPackage. - elab - where - elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon mapDep pkg - elab = elab0 { - elabUnitId = newSimpleUnitId pkgInstalledId, - elabComponentId = pkgInstalledId, - elabLinkedInstantiatedWith = Map.empty, - elabInstallDirs = install_dirs, - elabRequiresRegistration = requires_reg, - elabPkgOrComp = ElabPackage $ ElaboratedPackage {..} - } - - deps = fmap (concatMap (elaborateLibSolverId mapDep)) deps0 - - requires_reg = PD.hasPublicLib elabPkgDescription - pkgInstalledId - | shouldBuildInplaceOnly pkg - = mkComponentId (display pkgid ++ "-inplace") - - | otherwise - = assert (isJust elabPkgSourceHash) $ - hashedInstalledPackageId - (packageHashInputs - elaboratedSharedConfig - elab) -- recursive use of elab - - | otherwise - = error $ "elaborateInstallPlan: non-inplace package " - ++ " is missing a source hash: " ++ display pkgid - - pkgLibDependencies = deps - pkgExeDependencies = fmap (concatMap (elaborateExeSolverId mapDep)) exe_deps0 - pkgExeDependencyPaths = fmap (concatMap (elaborateExePath mapDep)) exe_deps0 - pkgPkgConfigDependencies = - ordNub - $ [ (pn, fromMaybe (error $ "pkgPkgConfigDependencies: impossible! " - ++ display pn ++ " from " ++ display pkgid) - (pkgConfigDbPkgVersion pkgConfigDB pn)) - | PkgconfigDependency pn _ <- concatMap PD.pkgconfigDepends - (PD.allBuildInfo elabPkgDescription) - ] - - -- Filled in later - pkgStanzasEnabled = Set.empty - - install_dirs - | shouldBuildInplaceOnly pkg - -- use the ordinary default install dirs - = (InstallDirs.absoluteInstallDirs - pkgid - (newSimpleUnitId pkgInstalledId) - (compilerInfo compiler) - InstallDirs.NoCopyDest - platform - defaultInstallDirs) { - - InstallDirs.libsubdir = "", -- absoluteInstallDirs sets these as - InstallDirs.datasubdir = "" -- 'undefined' but we have to use - } -- them as "Setup.hs configure" args - - | otherwise - -- use special simplified install dirs - = storePackageInstallDirs - cabalDirLayout - (compilerId compiler) - pkgInstalledId - - elaborateSolverToCommon :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverPackage UnresolvedPkgLoc - -> ElaboratedConfiguredPackage - elaborateSolverToCommon mapDep - pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride) - flags stanzas deps0 _exe_deps0) = - elaboratedPackage - where - elaboratedPackage = ElaboratedConfiguredPackage {..} - - -- These get filled in later - elabUnitId = error "elaborateSolverToCommon: elabUnitId" - elabComponentId = error "elaborateSolverToCommon: elabComponentId" - elabInstantiatedWith = Map.empty - elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith" - elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp" - elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs" - elabRequiresRegistration = error "elaborateSolverToCommon: elabRequiresRegistration" - elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" - - elabPkgSourceId = pkgid - elabPkgDescription = let Right (desc, _) = - PD.finalizePD - flags elabEnabledSpec (const True) - platform (compilerInfo compiler) - [] gdesc - in desc - elabInternalPackages = Cabal.getInternalPackages gdesc - elabFlagAssignment = flags - elabFlagDefaults = [ (Cabal.flagName flag, Cabal.flagDefault flag) - | flag <- PD.genPackageFlags gdesc ] - - elabEnabledSpec = enableStanzas stanzas - elabStanzasAvailable = Set.fromList stanzas - elabStanzasRequested = - -- NB: even if a package stanza is requested, if the package - -- doesn't actually have any of that stanza we omit it from - -- the request, to ensure that we don't decide that this - -- package needs to be rebuilt. (It needs to be done here, - -- because the ElaboratedConfiguredPackage is where we test - -- whether or not there have been changes.) - Map.fromList $ [ (TestStanzas, v) | v <- maybeToList tests - , _ <- PD.testSuites elabPkgDescription ] - ++ [ (BenchStanzas, v) | v <- maybeToList benchmarks - , _ <- PD.benchmarks elabPkgDescription ] - where - tests, benchmarks :: Maybe Bool - tests = perPkgOptionMaybe pkgid packageConfigTests - benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks - - -- This is a placeholder which will get updated by 'pruneInstallPlanPass1' - -- and 'pruneInstallPlanPass2'. We can't populate it here - -- because whether or not tests/benchmarks should be enabled - -- is heuristically calculated based on whether or not the - -- dependencies of the test suite have already been installed, - -- but this function doesn't know what is installed (since - -- we haven't improved the plan yet), so we do it in another pass. - -- Check the comments of those functions for more details. - elabBuildTargets = [] - elabReplTarget = Nothing - elabBuildHaddocks = False - - elabPkgSourceLocation = srcloc - elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes - elabLocalToProject = isLocalToProject pkg - elabBuildStyle = if shouldBuildInplaceOnly pkg - then BuildInplaceOnly else BuildAndInstall - elabBuildPackageDBStack = buildAndRegisterDbs - elabRegisterPackageDBStack = buildAndRegisterDbs - - elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription - -- Computing the deps here is a little awful - deps = fmap (concatMap (elaborateLibSolverId mapDep)) deps0 - elabSetupScriptCliVersion = packageSetupScriptSpecVersion - elabSetupScriptStyle elabPkgDescription deps - elabSetupPackageDBStack = buildAndRegisterDbs - - buildAndRegisterDbs - | shouldBuildInplaceOnly pkg = inplacePackageDbs - | otherwise = storePackageDbs - - elabPkgDescriptionOverride = descOverride - - elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively - elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary - elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe - elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still - - elabProfExe = perPkgOptionFlag pkgid False packageConfigProf - elabProfLib = pkgid `Set.member` pkgsUseProfilingLibrary - - (elabProfExeDetail, - elabProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault - packageConfigProfDetail - packageConfigProfLibDetail - elabCoverage = perPkgOptionFlag pkgid False packageConfigCoverage - - elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization - elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs - elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs - elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes - elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo - - -- Combine the configured compiler prog settings with the user-supplied - -- config. For the compiler progs any user-supplied config was taken - -- into account earlier when configuring the compiler so its ok that - -- our configured settings for the compiler override the user-supplied - -- config here. - elabProgramPaths = Map.fromList - [ (programId prog, programPath prog) - | prog <- configuredPrograms compilerprogdb ] - <> perPkgOptionMapLast pkgid packageConfigProgramPaths - elabProgramArgs = Map.fromList - [ (programId prog, args) - | prog <- configuredPrograms compilerprogdb - , let args = programOverrideArgs prog - , not (null args) - ] - <> perPkgOptionMapMappend pkgid packageConfigProgramArgs - elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra - elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs - elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs - elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs - elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs - elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix - elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix - - - elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle - elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml - elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation - elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs - elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables - elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites - elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks - elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal - elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss - elabHaddockHscolour = perPkgOptionFlag pkgid False packageConfigHaddockHscolour - elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss - elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents - - perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a - perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a - perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] - - perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f) - perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) - perPkgOptionList pkgid f = lookupPerPkgOption pkgid f - perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) - perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) - perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) - - perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) - where - exe = fromFlagOrDefault def bothflag - lib = fromFlagOrDefault def (bothflag <> libflag) - - bothflag = lookupPerPkgOption pkgid fboth - libflag = lookupPerPkgOption pkgid flib - - lookupPerPkgOption :: (Package pkg, Monoid m) - => pkg -> (PackageConfig -> m) -> m - lookupPerPkgOption pkg f - -- the project config specifies values that apply to packages local to - -- but by default non-local packages get all default config values - -- the project, and can specify per-package values for any package, - | isLocalToProject pkg = local `mappend` perpkg - | otherwise = perpkg - where - local = f localPackagesConfig - perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) - - inplacePackageDbs = storePackageDbs - ++ [ distPackageDB (compilerId compiler) ] - - storePackageDbs = [ GlobalPackageDB - , cabalStorePackageDB (compilerId compiler) ] - - -- For this local build policy, every package that lives in a local source - -- dir (as opposed to a tarball), or depends on such a package, will be - -- built inplace into a shared dist dir. Tarball packages that depend on - -- source dir packages will also get unpacked locally. - shouldBuildInplaceOnly :: SolverPackage loc -> Bool - shouldBuildInplaceOnly pkg = Set.member (packageId pkg) - pkgsToBuildInplaceOnly - - pkgsToBuildInplaceOnly :: Set PackageId - pkgsToBuildInplaceOnly = - Set.fromList - $ map packageId - $ SolverInstallPlan.reverseDependencyClosure - solverPlan - [ PlannedId (packageId pkg) - | pkg <- localPackages ] - - isLocalToProject :: Package pkg => pkg -> Bool - isLocalToProject pkg = Set.member (packageId pkg) - pkgsLocalToProject - - pkgsLocalToProject :: Set PackageId - pkgsLocalToProject = Set.fromList [ packageId pkg | pkg <- localPackages ] - - pkgsUseSharedLibrary :: Set PackageId - pkgsUseSharedLibrary = - packagesWithLibDepsDownwardClosedProperty needsSharedLib - where - needsSharedLib pkg = - fromMaybe compilerShouldUseSharedLibByDefault - (liftM2 (||) pkgSharedLib pkgDynExe) - where - pkgid = packageId pkg - pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib - pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe - - --TODO: [code cleanup] move this into the Cabal lib. It's currently open - -- coded in Distribution.Simple.Configure, but should be made a proper - -- function of the Compiler or CompilerInfo. - compilerShouldUseSharedLibByDefault = - case compilerFlavor compiler of - GHC -> GHC.isDynamic compiler - GHCJS -> GHCJS.isDynamic compiler - _ -> False - - pkgsUseProfilingLibrary :: Set PackageId - pkgsUseProfilingLibrary = - packagesWithLibDepsDownwardClosedProperty needsProfilingLib - where - needsProfilingLib pkg = - fromFlagOrDefault False (profBothFlag <> profLibFlag) - where - pkgid = packageId pkg - profBothFlag = lookupPerPkgOption pkgid packageConfigProf - profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib - --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe - - libDepGraph = Graph.fromList (map NonSetupLibDepSolverPlanPackage - (SolverInstallPlan.toList solverPlan)) - - packagesWithLibDepsDownwardClosedProperty property = - Set.fromList - . map packageId - . fromMaybe [] - $ Graph.closure - libDepGraph - [ Graph.nodeKey pkg - | pkg <- SolverInstallPlan.toList solverPlan - , property pkg ] -- just the packages that satisfy the propety - --TODO: [nice to have] this does not check the config consistency, - -- e.g. a package explicitly turning off profiling, but something - -- depending on it that needs profiling. This really needs a separate - -- package config validation/resolution pass. - - --TODO: [nice to have] config consistency checking: - -- + profiling libs & exes, exe needs lib, recursive - -- + shared libs & exes, exe needs lib, recursive - -- + vanilla libs & exes, exe needs lib, recursive - -- + ghci or shared lib needed by TH, recursive, ghc version dependent - --- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the --- dependency graph considers only dependencies on libraries which are --- NOT from setup dependencies. Used to compute the set --- of packages needed for profiling and dynamic libraries. -newtype NonSetupLibDepSolverPlanPackage - = NonSetupLibDepSolverPlanPackage - { unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage } - -instance Package NonSetupLibDepSolverPlanPackage where - packageId = packageId . unNonSetupLibDepSolverPlanPackage - -instance IsNode NonSetupLibDepSolverPlanPackage where - type Key NonSetupLibDepSolverPlanPackage = SolverId - nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage - nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg) - = ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg) - -type InstS = Map UnitId ElaboratedPlanPackage -type InstM a = State InstS a - -getComponentId :: ElaboratedPlanPackage - -> ComponentId -getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg -getComponentId (InstallPlan.Configured elab) = elabComponentId elab -getComponentId (InstallPlan.Installed elab) = elabComponentId elab - -instantiateInstallPlan :: ElaboratedInstallPlan -> ElaboratedInstallPlan -instantiateInstallPlan plan = - InstallPlan.new (IndependentGoals False) (Graph.fromList (Map.elems ready_map)) - where - pkgs = InstallPlan.toList plan - - cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ] - - instantiateUnitId :: ComponentId -> Map ModuleName Module - -> InstM DefUnitId - instantiateUnitId cid insts = state $ \s -> - case Map.lookup uid s of - Nothing -> - -- Knot tied - let (r, s') = runState (instantiateComponent uid cid insts) - (Map.insert uid r s) - in (def_uid, Map.insert uid r s') - Just _ -> (def_uid, s) - where - def_uid = mkDefUnitId cid insts - uid = unDefUnitId def_uid - - instantiateComponent - :: UnitId -> ComponentId -> Map ModuleName Module - -> InstM ElaboratedPlanPackage - instantiateComponent uid cid insts - | Just planpkg <- Map.lookup cid cmap - = case planpkg of - InstallPlan.Configured (elab@ElaboratedConfiguredPackage - { elabPkgOrComp = ElabComponent comp }) -> do - deps <- mapM (substUnitId insts) - (compLinkedLibDependencies comp) - let getDep (Module dep_uid _) = [dep_uid] - return $ InstallPlan.Configured elab { - elabUnitId = uid, - elabComponentId = cid, - elabInstantiatedWith = insts, - elabPkgOrComp = ElabComponent comp { - compNonSetupDependencies = - (if Map.null insts then [] else [newSimpleUnitId cid]) ++ - ordNub (map unDefUnitId - (deps ++ concatMap getDep (Map.elems insts))) - } - } - _ -> return planpkg - | otherwise = error ("instantiateComponent: " ++ display cid) - - substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId - substUnitId _ (DefiniteUnitId uid) = - return uid - substUnitId subst (IndefFullUnitId cid insts) = do - insts' <- substSubst subst insts - instantiateUnitId cid insts' - - -- NB: NOT composition - substSubst :: Map ModuleName Module - -> Map ModuleName OpenModule - -> InstM (Map ModuleName Module) - substSubst subst insts = T.mapM (substModule subst) insts - - substModule :: Map ModuleName Module -> OpenModule -> InstM Module - substModule subst (OpenModuleVar mod_name) - | Just m <- Map.lookup mod_name subst = return m - | otherwise = error "substModule: non-closing substitution" - substModule subst (OpenModule uid mod_name) = do - uid' <- substUnitId subst uid - return (Module uid' mod_name) - - indefiniteUnitId :: ComponentId -> InstM UnitId - indefiniteUnitId cid = do - let uid = newSimpleUnitId cid - r <- indefiniteComponent uid cid - state $ \s -> (uid, Map.insert uid r s) - - indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage - indefiniteComponent _uid cid - | Just planpkg <- Map.lookup cid cmap - = case planpkg of - InstallPlan.Configured elab@ElaboratedConfiguredPackage - { elabPkgOrComp = ElabComponent comp } -> - return $ InstallPlan.Configured elab { - elabPkgOrComp = ElabComponent comp { - compNonSetupDependencies = - ordNub (map abstractUnitId (compLinkedLibDependencies comp)) - } - } - _ -> return planpkg -- shouldn't happen - | otherwise = error ("indefiniteComponent: " ++ display cid) - - ready_map = execState work Map.empty - - work = forM_ pkgs $ \pkg -> - case pkg of - InstallPlan.Configured elab - | not (Map.null (elabLinkedInstantiatedWith elab)) - -> indefiniteUnitId (elabComponentId elab) - >> return () - _ -> instantiateUnitId (getComponentId pkg) Map.empty - >> return () - ---------------------------- --- Build targets --- - --- Refer to ProjectPlanning.Types for details of these important types: - --- data PackageTarget = ... --- data ComponentTarget = ... --- data SubComponentTarget = ... - - ---TODO: this needs to report some user target/config errors -elaboratePackageTargets :: ElaboratedConfiguredPackage -> [PackageTarget] - -> ([ComponentTarget], Maybe ComponentTarget, Bool) -elaboratePackageTargets ElaboratedConfiguredPackage{..} targets = - let buildTargets = nubComponentTargets - . map compatSubComponentTargets - . concatMap elaborateBuildTarget - $ targets - --TODO: instead of listToMaybe we should be reporting an error here - replTargets = listToMaybe - . nubComponentTargets - . map compatSubComponentTargets - . concatMap elaborateReplTarget - $ targets - buildHaddocks = HaddockDefaultComponents `elem` targets - - in (buildTargets, replTargets, buildHaddocks) - where - --TODO: need to report an error here if defaultComponents is empty - elaborateBuildTarget BuildDefaultComponents = pkgDefaultComponents - elaborateBuildTarget (BuildSpecificComponent t) = [t] - elaborateBuildTarget _ = [] - - --TODO: need to report an error here if defaultComponents is empty - elaborateReplTarget ReplDefaultComponent = take 1 pkgDefaultComponents - elaborateReplTarget (ReplSpecificComponent t) = [t] - elaborateReplTarget _ = [] - - pkgDefaultComponents = - [ ComponentTarget cname WholeComponent - | c <- Cabal.pkgComponents elabPkgDescription - , PD.buildable (Cabal.componentBuildInfo c) - , let cname = Cabal.componentName c - , enabledOptionalStanza cname - ] - where - enabledOptionalStanza cname = - case componentOptionalStanza cname of - Nothing -> True - Just stanza -> Map.lookup stanza elabStanzasRequested - == Just True - - -- Not all Cabal Setup.hs versions support sub-component targets, so switch - -- them over to the whole component - compatSubComponentTargets :: ComponentTarget -> ComponentTarget - compatSubComponentTargets target@(ComponentTarget cname _subtarget) - | not setupHsSupportsSubComponentTargets - = ComponentTarget cname WholeComponent - | otherwise = target - - -- Actually the reality is that no current version of Cabal's Setup.hs - -- build command actually support building specific files or modules. - setupHsSupportsSubComponentTargets = False - -- TODO: when that changes, adjust this test, e.g. - -- | pkgSetupScriptCliVersion >= Version [x,y] [] - - nubComponentTargets :: [ComponentTarget] -> [ComponentTarget] - nubComponentTargets = - concatMap (wholeComponentOverrides . map snd) - . groupBy ((==) `on` fst) - . sortBy (compare `on` fst) - . map (\t@(ComponentTarget cname _) -> (cname, t)) - - -- If we're building the whole component then that the only target all we - -- need, otherwise we can have several targets within the component. - wholeComponentOverrides :: [ComponentTarget] -> [ComponentTarget] - wholeComponentOverrides ts = - case [ t | t@(ComponentTarget _ WholeComponent) <- ts ] of - (t:_) -> [t] - [] -> ts - -pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool -pkgHasEphemeralBuildTargets elab = - isJust (elabReplTarget elab) - || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab - , subtarget /= WholeComponent ] - --- | The components that we'll build all of, meaning that after they're built --- we can skip building them again (unlike with building just some modules or --- other files within a component). --- -elabBuildTargetWholeComponents :: ElaboratedConfiguredPackage - -> Set ComponentName -elabBuildTargetWholeComponents elab = - Set.fromList - [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ] - - - ------------------------------------------------------------------------------- --- * Install plan pruning ------------------------------------------------------------------------------- - --- | Given a set of package targets (and optionally component targets within --- those packages), take the subset of the install plan needed to build those --- targets. Also, update the package config to specify which optional stanzas --- to enable, and which targets within each package to build. --- -pruneInstallPlanToTargets :: Map UnitId [PackageTarget] - -> ElaboratedInstallPlan -> ElaboratedInstallPlan -pruneInstallPlanToTargets perPkgTargetsMap elaboratedPlan = - InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) - . Graph.fromList - -- We have to do this in two passes - . pruneInstallPlanPass2 - . pruneInstallPlanPass1 perPkgTargetsMap - . InstallPlan.toList - $ elaboratedPlan - --- | This is a temporary data type, where we temporarily --- override the graph dependencies of an 'ElaboratedPackage', --- so we can take a closure over them. We'll throw out the --- overriden dependencies when we're done so it's strictly temporary. --- --- For 'ElaboratedComponent', this the cached unit IDs always --- coincide with the real thing. -data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId] - -instance Package PrunedPackage where - packageId (PrunedPackage elab _) = packageId elab - -instance HasUnitId PrunedPackage where - installedUnitId = nodeKey - -instance IsNode PrunedPackage where - type Key PrunedPackage = UnitId - nodeKey (PrunedPackage elab _) = nodeKey elab - nodeNeighbors (PrunedPackage _ deps) = deps - -fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage -fromPrunedPackage (PrunedPackage elab _) = elab - --- | The first pass does three things: --- --- * Set the build targets based on the user targets (but not rev deps yet). --- * A first go at determining which optional stanzas (testsuites, benchmarks) --- are needed. We have a second go in the next pass. --- * Take the dependency closure using pruned dependencies. We prune deps that --- are used only by unneeded optional stanzas. These pruned deps are only --- used for the dependency closure and are not persisted in this pass. --- -pruneInstallPlanPass1 :: Map UnitId [PackageTarget] - -> [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] -pruneInstallPlanPass1 perPkgTargetsMap pkgs = - map (mapConfiguredPackage fromPrunedPackage) - (fromMaybe [] $ Graph.closure g roots) - where - pkgs' = map (mapConfiguredPackage prune) pkgs - g = Graph.fromList pkgs' - - prune elab = - let elab' = (pruneOptionalStanzas . setElabBuildTargets) elab - in PrunedPackage elab' (pruneOptionalDependencies elab') - - roots = mapMaybe find_root pkgs' - find_root (InstallPlan.Configured (PrunedPackage elab _)) = - if not (null (elabBuildTargets elab) - && isNothing (elabReplTarget elab) - && not (elabBuildHaddocks elab)) - then Just (installedUnitId elab) - else Nothing - find_root _ = Nothing - - -- Elaborate and set the targets we'll build for this package. This is just - -- based on the targets from the user, not targets implied by reverse - -- dependencies. Those comes in the second pass once we know the rev deps. - -- - setElabBuildTargets elab = - elab { - elabBuildTargets = mapMaybe targetForElab buildTargets, - elabReplTarget = replTarget >>= targetForElab, - elabBuildHaddocks = buildHaddocks - } - where - (buildTargets, replTarget, buildHaddocks) - = elaboratePackageTargets elab targets - targets = fromMaybe [] - $ Map.lookup (installedUnitId elab) perPkgTargetsMap - targetForElab tgt@(ComponentTarget cname _) = - case elabPkgOrComp elab of - ElabPackage _ -> Just tgt -- always valid - ElabComponent comp - -- Only if the component name matches - | compComponentName comp == Just cname -> Just tgt - | otherwise -> Nothing - - -- Decide whether or not to enable testsuites and benchmarks - -- - -- The testsuite and benchmark targets are somewhat special in that we need - -- to configure the packages with them enabled, and we need to do that even - -- if we only want to build one of several testsuites. - -- - -- There are two cases in which we will enable the testsuites (or - -- benchmarks): if one of the targets is a testsuite, or if all of the - -- testsuite dependencies are already cached in the store. The rationale - -- for the latter is to minimise how often we have to reconfigure due to - -- the particular targets we choose to build. Otherwise choosing to build - -- a testsuite target, and then later choosing to build an exe target - -- would involve unnecessarily reconfiguring the package with testsuites - -- disabled. Technically this introduces a little bit of stateful - -- behaviour to make this "sticky", but it should be benign. - -- - pruneOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage - pruneOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } = - elab { - elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas }) - } - where - stanzas :: Set OptionalStanza - stanzas = optionalStanzasRequiredByTargets elab - <> optionalStanzasRequestedByDefault elab - <> optionalStanzasWithDepsAvailable availablePkgs elab pkg - pruneOptionalStanzas elab = elab - - -- Calculate package dependencies but cut out those needed only by - -- optional stanzas that we've determined we will not enable. - -- These pruned deps are not persisted in this pass since they're based on - -- the optional stanzas and we'll make further tweaks to the optional - -- stanzas in the next pass. - -- - pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId] - pruneOptionalDependencies elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent _ } - = InstallPlan.depends elab -- no pruning - pruneOptionalDependencies ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } - = (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg) - where - keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas - keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas - keepNeeded _ _ = True - stanzas = pkgStanzasEnabled pkg - - optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage - -> Set OptionalStanza - optionalStanzasRequiredByTargets pkg = - Set.fromList - [ stanza - | ComponentTarget cname _ <- elabBuildTargets pkg - ++ maybeToList (elabReplTarget pkg) - , stanza <- maybeToList (componentOptionalStanza cname) - ] - - optionalStanzasRequestedByDefault :: ElaboratedConfiguredPackage - -> Set OptionalStanza - optionalStanzasRequestedByDefault = - Map.keysSet - . Map.filter (id :: Bool -> Bool) - . elabStanzasRequested - - availablePkgs = - Set.fromList - [ installedUnitId pkg - | InstallPlan.PreExisting pkg <- pkgs ] - --- | Given a set of already installed packages @availablePkgs@, --- determine the set of available optional stanzas from @pkg@ --- which have all of their dependencies already installed. This is used --- to implement "sticky" testsuites, where once we have installed --- all of the deps needed for the test suite, we go ahead and --- enable it always. -optionalStanzasWithDepsAvailable :: Set UnitId - -> ElaboratedConfiguredPackage - -> ElaboratedPackage - -> Set OptionalStanza -optionalStanzasWithDepsAvailable availablePkgs elab pkg = - Set.fromList - [ stanza - | stanza <- Set.toList (elabStanzasAvailable elab) - , let deps :: [UnitId] - deps = CD.select (optionalStanzaDeps stanza) - -- TODO: probably need to select other - -- dep types too eventually - (pkgOrderDependencies pkg) - , all (`Set.member` availablePkgs) deps - ] - where - optionalStanzaDeps TestStanzas (CD.ComponentTest _) = True - optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True - optionalStanzaDeps _ _ = False - - --- The second pass does three things: --- --- * A second go at deciding which optional stanzas to enable. --- * Prune the dependencies based on the final choice of optional stanzas. --- * Extend the targets within each package to build, now we know the reverse --- dependencies, ie we know which libs are needed as deps by other packages. --- --- Achieving sticky behaviour with enabling\/disabling optional stanzas is --- tricky. The first approximation was handled by the first pass above, but --- it's not quite enough. That pass will enable stanzas if all of the deps --- of the optional stanza are already installed /in the store/. That's important --- but it does not account for dependencies that get built inplace as part of --- the project. We cannot take those inplace build deps into account in the --- pruning pass however because we don't yet know which ones we're going to --- build. Once we do know, we can have another go and enable stanzas that have --- all their deps available. Now we can consider all packages in the pruned --- plan to be available, including ones we already decided to build from --- source. --- --- Deciding which targets to build depends on knowing which packages have --- reverse dependencies (ie are needed). This requires the result of first --- pass, which is another reason we have to split it into two passes. --- --- Note that just because we might enable testsuites or benchmarks (in the --- first or second pass) doesn't mean that we build all (or even any) of them. --- That depends on which targets we picked in the first pass. --- -pruneInstallPlanPass2 :: [ElaboratedPlanPackage] - -> [ElaboratedPlanPackage] -pruneInstallPlanPass2 pkgs = - map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs - where - setStanzasDepsAndTargets elab = - elab { - elabBuildTargets = ordNub - $ elabBuildTargets elab - ++ libTargetsRequiredForRevDeps - ++ exeTargetsRequiredForRevDeps, - elabPkgOrComp = - case elabPkgOrComp elab of - ElabPackage pkg -> - let stanzas = pkgStanzasEnabled pkg - <> optionalStanzasWithDepsAvailable availablePkgs elab pkg - keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas - keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas - keepNeeded _ _ = True - in ElabPackage $ pkg { - pkgStanzasEnabled = stanzas, - pkgLibDependencies = CD.filterDeps keepNeeded (pkgLibDependencies pkg), - pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg), - pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg) - } - r@(ElabComponent _) -> r - } - where - libTargetsRequiredForRevDeps = - [ ComponentTarget Cabal.defaultLibName WholeComponent - | installedUnitId elab `Set.member` hasReverseLibDeps - ] - exeTargetsRequiredForRevDeps = - -- TODO: allow requesting executable with different name - -- than package name - [ ComponentTarget (Cabal.CExeName - $ packageNameToUnqualComponentName - $ packageName $ elabPkgSourceId elab) - WholeComponent - | installedUnitId elab `Set.member` hasReverseExeDeps - ] - - - availablePkgs :: Set UnitId - availablePkgs = Set.fromList (map installedUnitId pkgs) - - hasReverseLibDeps :: Set UnitId - hasReverseLibDeps = - Set.fromList [ depid - | InstallPlan.Configured pkg <- pkgs - , depid <- elabOrderLibDependencies pkg ] - - hasReverseExeDeps :: Set UnitId - hasReverseExeDeps = - Set.fromList [ depid - | InstallPlan.Configured pkg <- pkgs - , depid <- elabOrderExeDependencies pkg ] - -mapConfiguredPackage :: (srcpkg -> srcpkg') - -> InstallPlan.GenericPlanPackage ipkg srcpkg - -> InstallPlan.GenericPlanPackage ipkg srcpkg' -mapConfiguredPackage f (InstallPlan.Configured pkg) = - InstallPlan.Configured (f pkg) -mapConfiguredPackage f (InstallPlan.Installed pkg) = - InstallPlan.Installed (f pkg) -mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = - InstallPlan.PreExisting pkg - -componentOptionalStanza :: Cabal.ComponentName -> Maybe OptionalStanza -componentOptionalStanza (Cabal.CTestName _) = Just TestStanzas -componentOptionalStanza (Cabal.CBenchName _) = Just BenchStanzas -componentOptionalStanza _ = Nothing - ------------------------------------- --- Support for --only-dependencies --- - --- | Try to remove the given targets from the install plan. --- --- This is not always possible. --- -pruneInstallPlanToDependencies :: Set UnitId - -> ElaboratedInstallPlan - -> Either CannotPruneDependencies - ElaboratedInstallPlan -pruneInstallPlanToDependencies pkgTargets installPlan = - assert (all (isJust . InstallPlan.lookup installPlan) - (Set.toList pkgTargets)) $ - - fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) - . checkBrokenDeps - . Graph.fromList - . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) - . InstallPlan.toList - $ installPlan - where - -- Our strategy is to remove the packages we don't want and then check - -- if the remaining graph is broken or not, ie any packages with dangling - -- dependencies. If there are then we cannot prune the given targets. - checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage - -> Either CannotPruneDependencies - (Graph.Graph ElaboratedPlanPackage) - checkBrokenDeps graph = - case Graph.broken graph of - [] -> Right graph - brokenPackages -> - Left $ CannotPruneDependencies - [ (pkg, missingDeps) - | (pkg, missingDepIds) <- brokenPackages - , let missingDeps = catMaybes (map lookupDep missingDepIds) - ] - where - -- lookup in the original unpruned graph - lookupDep = InstallPlan.lookup installPlan - --- | It is not always possible to prune to only the dependencies of a set of --- targets. It may be the case that removing a package leaves something else --- that still needed the pruned package. --- --- This lists all the packages that would be broken, and their dependencies --- that would be missing if we did prune. --- -newtype CannotPruneDependencies = - CannotPruneDependencies [(ElaboratedPlanPackage, - [ElaboratedPlanPackage])] -#if MIN_VERSION_base(4,8,0) - deriving (Show, Typeable) -#else - deriving (Typeable) - -instance Show CannotPruneDependencies where - show = renderCannotPruneDependencies -#endif - -instance Exception CannotPruneDependencies where -#if MIN_VERSION_base(4,8,0) - displayException = renderCannotPruneDependencies -#endif - -renderCannotPruneDependencies :: CannotPruneDependencies -> String -renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) = - "Cannot select only the dependencies (as requested by the " - ++ "'--only-dependencies' flag), " - ++ (case pkgids of - [pkgid] -> "the package " ++ display pkgid ++ " is " - _ -> "the packages " - ++ intercalate ", " (map display pkgids) ++ " are ") - ++ "required by a dependency of one of the other targets." - where - -- throw away the details and just list the deps that are needed - pkgids :: [PackageId] - pkgids = nub . map packageId . concatMap snd $ brokenPackages - - ---------------------------- --- Setup.hs script policy --- - --- Handling for Setup.hs scripts is a bit tricky, part of it lives in the --- solver phase, and part in the elaboration phase. We keep the helper --- functions for both phases together here so at least you can see all of it --- in one place. --- --- There are four major cases for Setup.hs handling: --- --- 1. @build-type@ Custom with a @custom-setup@ section --- 2. @build-type@ Custom without a @custom-setup@ section --- 3. @build-type@ not Custom with @cabal-version > $our-cabal-version@ --- 4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@ --- --- It's also worth noting that packages specifying @cabal-version: >= 1.23@ --- or later that have @build-type@ Custom will always have a @custom-setup@ --- section. Therefore in case 2, the specified @cabal-version@ will always be --- less than 1.23. --- --- In cases 1 and 2 we obviously have to build an external Setup.hs script, --- while in case 4 we can use the internal library API. In case 3 we also have --- to build an external Setup.hs script because the package needs a later --- Cabal lib version than we can support internally. --- --- data SetupScriptStyle = ... -- see ProjectPlanning.Types - --- | Work out the 'SetupScriptStyle' given the package description. --- -packageSetupScriptStyle :: PD.PackageDescription -> SetupScriptStyle -packageSetupScriptStyle pkg - | buildType == PD.Custom - , Just setupbi <- PD.setupBuildInfo pkg -- does have a custom-setup stanza - , not (PD.defaultSetupDepends setupbi) -- but not one we added internally - = SetupCustomExplicitDeps - - | buildType == PD.Custom - , Just setupbi <- PD.setupBuildInfo pkg -- we get this case post-solver as - , PD.defaultSetupDepends setupbi -- the solver fills in the deps - = SetupCustomImplicitDeps - - | buildType == PD.Custom - , Nothing <- PD.setupBuildInfo pkg -- we get this case pre-solver - = SetupCustomImplicitDeps - - | PD.specVersion pkg > cabalVersion -- one cabal-install is built against - = SetupNonCustomExternalLib - - | otherwise - = SetupNonCustomInternalLib - where - buildType = fromMaybe PD.Custom (PD.buildType pkg) - - --- | Part of our Setup.hs handling policy is implemented by getting the solver --- to work out setup dependencies for packages. The solver already handles --- packages that explicitly specify setup dependencies, but we can also tell --- the solver to treat other packages as if they had setup dependencies. --- That's what this function does, it gets called by the solver for all --- packages that don't already have setup dependencies. --- --- The dependencies we want to add is different for each 'SetupScriptStyle'. --- --- Note that adding default deps means these deps are actually /added/ to the --- packages that we get out of the solver in the 'SolverInstallPlan'. Making --- implicit setup deps explicit is a problem in the post-solver stages because --- we still need to distinguish the case of explicit and implict setup deps. --- See 'rememberImplicitSetupDeps'. --- -defaultSetupDeps :: Compiler -> Platform - -> PD.PackageDescription - -> Maybe [Dependency] -defaultSetupDeps compiler platform pkg = - case packageSetupScriptStyle pkg of - - -- For packages with build type custom that do not specify explicit - -- setup dependencies, we add a dependency on Cabal and a number - -- of other packages. - SetupCustomImplicitDeps -> - Just $ - [ Dependency depPkgname anyVersion - | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++ - [ Dependency cabalPkgname cabalConstraint - | packageName pkg /= cabalPkgname ] - where - -- The Cabal dep is slightly special: - -- * We omit the dep for the Cabal lib itself, since it bootstraps. - -- * We constrain it to be >= 1.18 < 2 - -- - -- Note: cabalCompatMinVer only gets applied WHEN WE ARE ADDING a - -- default setup build info, i.e., when there is no custom-setup - -- stanza. If there is a custom-setup stanza, this codepath never gets - -- invoked (that's why there's an error case for - -- SetupCustomExplicitDeps). - -- - -- One way we could solve this problem is by also modifying - -- custom-setup stanzas when they exist, but we're going to take a - -- different approach: add an extra constraint on Cabal globally to - -- make sure the solver respects it regardless of whether or not there - -- is an explicit setup build info or not. See planPackages. - cabalConstraint = orLaterVersion cabalCompatMinVer - `intersectVersionRanges` - orLaterVersion (PD.specVersion pkg) - `intersectVersionRanges` - earlierVersion cabalCompatMaxVer - -- The idea here is that at some point we will make significant - -- breaking changes to the Cabal API that Setup.hs scripts use. - -- So for old custom Setup scripts that do not specify explicit - -- constraints, we constrain them to use a compatible Cabal version. - cabalCompatMaxVer = mkVersion [1,25] - -- In principle we can talk to any old Cabal version, and we need to - -- be able to do that for custom Setup scripts that require older - -- Cabal lib versions. However in practice we have currently have - -- problems with Cabal-1.16. (1.16 does not know about build targets) - -- If this is fixed we can relax this constraint. - cabalCompatMinVer = mkVersion [1,18] - - -- For other build types (like Simple) if we still need to compile an - -- external Setup.hs, it'll be one of the simple ones that only depends - -- on Cabal and base. - SetupNonCustomExternalLib -> - Just [ Dependency cabalPkgname cabalConstraint - , Dependency basePkgname anyVersion ] - where - cabalConstraint = orLaterVersion (PD.specVersion pkg) - - -- The internal setup wrapper method has no deps at all. - SetupNonCustomInternalLib -> Just [] - - -- This case gets ruled out by the caller, planPackages, see the note - -- above in the SetupCustomIplicitDeps case. - SetupCustomExplicitDeps -> - error $ "defaultSetupDeps: called for a package with explicit " - ++ "setup deps: " ++ display (packageId pkg) - - --- | Work out which version of the Cabal spec we will be using to talk to the --- Setup.hs interface for this package. --- --- This depends somewhat on the 'SetupScriptStyle' but most cases are a result --- of what the solver picked for us, based on the explicit setup deps or the --- ones added implicitly by 'defaultSetupDeps'. --- -packageSetupScriptSpecVersion :: Package pkg - => SetupScriptStyle - -> PD.PackageDescription - -> ComponentDeps [pkg] - -> Version - --- We're going to be using the internal Cabal library, so the spec version of --- that is simply the version of the Cabal library that cabal-install has been --- built with. -packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ = - cabalVersion - --- If we happen to be building the Cabal lib itself then because that --- bootstraps itself then we use the version of the lib we're building. -packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ - | packageName pkg == cabalPkgname - = packageVersion pkg - --- In all other cases we have a look at what version of the Cabal lib the --- solver picked. Or if it didn't depend on Cabal at all (which is very rare) --- then we look at the .cabal file to see what spec version it declares. -packageSetupScriptSpecVersion _ pkg deps = - case find ((cabalPkgname ==) . packageName) (CD.setupDeps deps) of - Just dep -> packageVersion dep - Nothing -> PD.specVersion pkg - - -cabalPkgname, basePkgname :: PackageName -cabalPkgname = mkPackageName "Cabal" -basePkgname = mkPackageName "base" - - -legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName] -legacyCustomSetupPkgs compiler (Platform _ os) = - map mkPackageName $ - [ "array", "base", "binary", "bytestring", "containers" - , "deepseq", "directory", "filepath", "old-time", "pretty" - , "process", "time", "transformers" ] - ++ [ "Win32" | os == Windows ] - ++ [ "unix" | os /= Windows ] - ++ [ "ghc-prim" | isGHC ] - ++ [ "template-haskell" | isGHC ] - where - isGHC = compilerCompatFlavor GHC compiler - --- The other aspects of our Setup.hs policy lives here where we decide on --- the 'SetupScriptOptions'. --- --- Our current policy for the 'SetupCustomImplicitDeps' case is that we --- try to make the implicit deps cover everything, and we don't allow the --- compiler to pick up other deps. This may or may not be sustainable, and --- we might have to allow the deps to be non-exclusive, but that itself would --- be tricky since we would have to allow the Setup access to all the packages --- in the store and local dbs. - -setupHsScriptOptions :: ElaboratedReadyPackage - -> ElaboratedSharedConfig - -> FilePath - -> FilePath - -> Bool - -> Lock - -> SetupScriptOptions --- TODO: Fix this so custom is a separate component. Custom can ALWAYS --- be a separate component!!! -setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - ElaboratedSharedConfig{..} srcdir builddir - isParallelBuild cacheLock = - SetupScriptOptions { - useCabalVersion = thisVersion elabSetupScriptCliVersion, - useCabalSpecVersion = Just elabSetupScriptCliVersion, - useCompiler = Just pkgConfigCompiler, - usePlatform = Just pkgConfigPlatform, - usePackageDB = elabSetupPackageDBStack, - usePackageIndex = Nothing, - useDependencies = [ (uid, srcid) - | ConfiguredId srcid uid - <- elabSetupDependencies elab ], - useDependenciesExclusive = True, - useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps, - useProgramDb = pkgConfigCompilerProgs, - useDistPref = builddir, - useLoggingHandle = Nothing, -- this gets set later - useWorkingDir = Just srcdir, - useExtraPathEnv = elabExeDependencyPaths elab, - useWin32CleanHack = False, --TODO: [required eventually] - forceExternalSetupMethod = isParallelBuild, - setupCacheLock = Just cacheLock, - isInteractive = False - } - - --- | To be used for the input for elaborateInstallPlan. --- --- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure. --- -userInstallDirTemplates :: Compiler - -> IO InstallDirs.InstallDirTemplates -userInstallDirTemplates compiler = do - InstallDirs.defaultInstallDirs - (compilerFlavor compiler) - True -- user install - False -- unused - -storePackageInstallDirs :: CabalDirLayout - -> CompilerId - -> InstalledPackageId - -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs CabalDirLayout{cabalStorePackageDirectory} - compid ipkgid = - InstallDirs.InstallDirs {..} - where - prefix = cabalStorePackageDirectory compid ipkgid - bindir = prefix "bin" - libdir = prefix "lib" - libsubdir = "" - dynlibdir = libdir - flibdir = libdir - libexecdir = prefix "libexec" - includedir = libdir "include" - datadir = prefix "share" - datasubdir = "" - docdir = datadir "doc" - mandir = datadir "man" - htmldir = docdir "html" - haddockdir = htmldir - sysconfdir = prefix "etc" - - ---TODO: [code cleanup] perhaps reorder this code --- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, --- make the various Setup.hs {configure,build,copy} flags - - -setupHsConfigureFlags :: ElaboratedReadyPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.ConfigFlags -setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - sharedConfig@ElaboratedSharedConfig{..} - verbosity builddir = - sanityCheckElaboratedConfiguredPackage sharedConfig elab - (Cabal.ConfigFlags {..}) - where - configArgs = mempty -- unused, passed via args - configDistPref = toFlag builddir - configCabalFilePath = mempty - configVerbosity = toFlag verbosity - - configInstantiateWith = Map.toList elabInstantiatedWith - - configIPID = case elabPkgOrComp of - ElabPackage pkg -> toFlag (display (pkgInstalledId pkg)) - ElabComponent _ -> mempty - configCID = case elabPkgOrComp of - ElabPackage _ -> mempty - ElabComponent _ -> toFlag elabComponentId - - configProgramPaths = Map.toList elabProgramPaths - configProgramArgs = Map.toList elabProgramArgs - configProgramPathExtra = toNubList elabProgramPathExtra - configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) - configHcPath = mempty -- we use configProgramPaths instead - configHcPkg = mempty -- we use configProgramPaths instead - - configVanillaLib = toFlag elabVanillaLib - configSharedLib = toFlag elabSharedLib - configDynExe = toFlag elabDynExe - configGHCiLib = toFlag elabGHCiLib - configProfExe = mempty - configProfLib = toFlag elabProfLib - configProf = toFlag elabProfExe - - -- configProfDetail is for exe+lib, but overridden by configProfLibDetail - -- so we specify both so we can specify independently - configProfDetail = toFlag elabProfExeDetail - configProfLibDetail = toFlag elabProfLibDetail - - configCoverage = toFlag elabCoverage - configLibCoverage = mempty - - configOptimization = toFlag elabOptimization - configSplitObjs = toFlag elabSplitObjs - configStripExes = toFlag elabStripExes - configStripLibs = toFlag elabStripLibs - configDebugInfo = toFlag elabDebugInfo - configAllowOlder = mempty -- we use configExactConfiguration True - configAllowNewer = mempty -- we use configExactConfiguration True - - configConfigurationsFlags = elabFlagAssignment - configConfigureArgs = elabConfigureScriptArgs - configExtraLibDirs = elabExtraLibDirs - configExtraFrameworkDirs = elabExtraFrameworkDirs - configExtraIncludeDirs = elabExtraIncludeDirs - configProgPrefix = maybe mempty toFlag elabProgPrefix - configProgSuffix = maybe mempty toFlag elabProgSuffix - - configInstallDirs = fmap (toFlag . InstallDirs.toPathTemplate) - elabInstallDirs - - -- we only use configDependencies, unless we're talking to an old Cabal - -- in which case we use configConstraints - -- NB: This does NOT use InstallPlan.depends, which includes executable - -- dependencies which should NOT be fed in here (also you don't have - -- enough info anyway) - configDependencies = [ (packageName srcid, cid) - | ConfiguredId srcid cid <- elabLibDependencies elab ] - configConstraints = - case elabPkgOrComp of - ElabPackage _ -> - [ thisPackageVersion srcid - | ConfiguredId srcid _uid <- elabLibDependencies elab ] - ElabComponent _ -> [] - - - -- explicitly clear, then our package db stack - -- TODO: [required eventually] have to do this differently for older Cabal versions - configPackageDBs = Nothing : map Just elabBuildPackageDBStack - - configTests = case elabPkgOrComp of - ElabPackage pkg -> toFlag (TestStanzas `Set.member` pkgStanzasEnabled pkg) - ElabComponent _ -> mempty - configBenchmarks = case elabPkgOrComp of - ElabPackage pkg -> toFlag (BenchStanzas `Set.member` pkgStanzasEnabled pkg) - ElabComponent _ -> mempty - - configExactConfiguration = toFlag True - configFlagError = mempty --TODO: [research required] appears not to be implemented - configRelocatable = mempty --TODO: [research required] ??? - configScratchDir = mempty -- never use - configUserInstall = mempty -- don't rely on defaults - configPrograms_ = mempty -- never use, shouldn't exist - - -setupHsConfigureArgs :: ElaboratedConfiguredPackage - -> [String] -setupHsConfigureArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) = [] -setupHsConfigureArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) = - [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)] - where - cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup") - (compComponentName comp) - -setupHsBuildFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.BuildFlags -setupHsBuildFlags _ _ verbosity builddir = - Cabal.BuildFlags { - buildProgramPaths = mempty, --unused, set at configure time - buildProgramArgs = mempty, --unused, set at configure time - buildVerbosity = toFlag verbosity, - buildDistPref = toFlag builddir, - buildNumJobs = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs), - buildArgs = mempty -- unused, passed via args not flags - } - - -setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String] -setupHsBuildArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) - -- Fix for #3335, don't pass build arguments if it's not supported - | elabSetupScriptCliVersion elab >= mkVersion [1,17] - = map (showComponentTarget (packageId elab)) (elabBuildTargets elab) - | otherwise - = [] -setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _ }) - = [] - - -setupHsReplFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.ReplFlags -setupHsReplFlags _ _ verbosity builddir = - Cabal.ReplFlags { - replProgramPaths = mempty, --unused, set at configure time - replProgramArgs = mempty, --unused, set at configure time - replVerbosity = toFlag verbosity, - replDistPref = toFlag builddir, - replReload = mempty --only used as callback from repl - } - - -setupHsReplArgs :: ElaboratedConfiguredPackage -> [String] -setupHsReplArgs elab = - maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab) - --TODO: should be able to give multiple modules in one component - - -setupHsCopyFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.CopyFlags -setupHsCopyFlags _ _ verbosity builddir = - Cabal.CopyFlags { - --TODO: [nice to have] we currently just rely on Setup.hs copy to always do the right - -- thing, but perhaps we ought really to copy into an image dir and do - -- some sanity checks and move into the final location ourselves - copyArgs = [], -- TODO: could use this to only copy what we enabled - copyDest = toFlag InstallDirs.NoCopyDest, - copyDistPref = toFlag builddir, - copyVerbosity = toFlag verbosity - } - -setupHsRegisterFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> FilePath - -> Cabal.RegisterFlags -setupHsRegisterFlags ElaboratedConfiguredPackage{..} _ - verbosity builddir pkgConfFile = - Cabal.RegisterFlags { - regPackageDB = mempty, -- misfeature - regGenScript = mempty, -- never use - regGenPkgConf = toFlag (Just pkgConfFile), - regInPlace = case elabBuildStyle of - BuildInplaceOnly -> toFlag True - _ -> toFlag False, - regPrintId = mempty, -- never use - regDistPref = toFlag builddir, - regArgs = [], - regVerbosity = toFlag verbosity - } - -setupHsHaddockFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.HaddockFlags --- TODO: reconsider whether or not Executables/TestSuites/... --- needed for component -setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = - Cabal.HaddockFlags { - haddockProgramPaths = mempty, --unused, set at configure time - haddockProgramArgs = mempty, --unused, set at configure time - haddockHoogle = toFlag elabHaddockHoogle, - haddockHtml = toFlag elabHaddockHtml, - haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation, - haddockForHackage = mempty, --TODO: new flag - haddockForeignLibs = toFlag elabHaddockForeignLibs, - haddockExecutables = toFlag elabHaddockExecutables, - haddockTestSuites = toFlag elabHaddockTestSuites, - haddockBenchmarks = toFlag elabHaddockBenchmarks, - haddockInternal = toFlag elabHaddockInternal, - haddockCss = maybe mempty toFlag elabHaddockCss, - haddockHscolour = toFlag elabHaddockHscolour, - haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss, - haddockContents = maybe mempty toFlag elabHaddockContents, - haddockDistPref = toFlag builddir, - haddockKeepTempFiles = mempty, --TODO: from build settings - haddockVerbosity = toFlag verbosity - } - -{- -setupHsTestFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig - -> Verbosity - -> FilePath - -> Cabal.TestFlags -setupHsTestFlags _ _ verbosity builddir = - Cabal.TestFlags { - } --} - ------------------------------------------------------------------------------- --- * Sharing installed packages ------------------------------------------------------------------------------- - --- --- Nix style store management for tarball packages --- --- So here's our strategy: --- --- We use a per-user nix-style hashed store, but /only/ for tarball packages. --- So that includes packages from hackage repos (and other http and local --- tarballs). For packages in local directories we do not register them into --- the shared store by default, we just build them locally inplace. --- --- The reason we do it like this is that it's easy to make stable hashes for --- tarball packages, and these packages benefit most from sharing. By contrast --- unpacked dir packages are harder to hash and they tend to change more --- frequently so there's less benefit to sharing them. --- --- When using the nix store approach we have to run the solver *without* --- looking at the packages installed in the store, just at the source packages --- (plus core\/global installed packages). Then we do a post-processing pass --- to replace configured packages in the plan with pre-existing ones, where --- possible. Where possible of course means where the nix-style package hash --- equals one that's already in the store. --- --- One extra wrinkle is that unless we know package tarball hashes upfront, we --- will have to download the tarballs to find their hashes. So we have two --- options: delay replacing source with pre-existing installed packages until --- the point during the execution of the install plan where we have the --- tarball, or try to do as much up-front as possible and then check again --- during plan execution. The former isn't great because we would end up --- telling users we're going to re-install loads of packages when in fact we --- would just share them. It'd be better to give as accurate a prediction as --- we can. The latter is better for users, but we do still have to check --- during plan execution because it's important that we don't replace existing --- installed packages even if they have the same package hash, because we --- don't guarantee ABI stability. - --- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but --- not replace installed packages with ghc-pkg. - -packageHashInputs :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> PackageHashInputs -packageHashInputs - pkgshared - elab@(ElaboratedConfiguredPackage { - elabPkgSourceHash = Just srchash - }) = - PackageHashInputs { - pkgHashPkgId = packageId elab, - pkgHashComponent = - case elabPkgOrComp elab of - ElabPackage _ -> Nothing - ElabComponent comp -> Just (compSolverName comp), - pkgHashSourceHash = srchash, - pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab), - pkgHashDirectDeps = - case elabPkgOrComp elab of - ElabPackage (ElaboratedPackage{..}) -> - Set.fromList $ - [ confInstId dep - | dep <- CD.select relevantDeps pkgLibDependencies ] ++ - [ confInstId dep - | dep <- CD.select relevantDeps pkgExeDependencies ] - ElabComponent comp -> - Set.fromList (map confInstId (compLibDependencies comp) - ++ compExeDependencies comp), - pkgHashOtherConfig = packageHashConfigInputs pkgshared elab - } - where - -- Obviously the main deps are relevant - relevantDeps CD.ComponentLib = True - relevantDeps (CD.ComponentSubLib _) = True - relevantDeps (CD.ComponentFLib _) = True - relevantDeps (CD.ComponentExe _) = True - -- Setup deps can affect the Setup.hs behaviour and thus what is built - relevantDeps CD.ComponentSetup = True - -- However testsuites and benchmarks do not get installed and should not - -- affect the result, so we do not include them. - relevantDeps (CD.ComponentTest _) = False - relevantDeps (CD.ComponentBench _) = False - -packageHashInputs _ pkg = - error $ "packageHashInputs: only for packages with source hashes. " - ++ display (packageId pkg) - -packageHashConfigInputs :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> PackageHashConfigInputs -packageHashConfigInputs - ElaboratedSharedConfig{..} - ElaboratedConfiguredPackage{..} = - - PackageHashConfigInputs { - pkgHashCompilerId = compilerId pkgConfigCompiler, - pkgHashPlatform = pkgConfigPlatform, - pkgHashFlagAssignment = elabFlagAssignment, - pkgHashConfigureScriptArgs = elabConfigureScriptArgs, - pkgHashVanillaLib = elabVanillaLib, - pkgHashSharedLib = elabSharedLib, - pkgHashDynExe = elabDynExe, - pkgHashGHCiLib = elabGHCiLib, - pkgHashProfLib = elabProfLib, - pkgHashProfExe = elabProfExe, - pkgHashProfLibDetail = elabProfLibDetail, - pkgHashProfExeDetail = elabProfExeDetail, - pkgHashCoverage = elabCoverage, - pkgHashOptimization = elabOptimization, - pkgHashSplitObjs = elabSplitObjs, - pkgHashStripLibs = elabStripLibs, - pkgHashStripExes = elabStripExes, - pkgHashDebugInfo = elabDebugInfo, - pkgHashProgramArgs = elabProgramArgs, - pkgHashExtraLibDirs = elabExtraLibDirs, - pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs, - pkgHashExtraIncludeDirs = elabExtraIncludeDirs, - pkgHashProgPrefix = elabProgPrefix, - pkgHashProgSuffix = elabProgSuffix - } - - --- | Given the 'InstalledPackageIndex' for a nix-style package store, and an --- 'ElaboratedInstallPlan', replace configured source packages by installed --- packages from the store whenever they exist. --- -improveInstallPlanWithInstalledPackages :: Set UnitId - -> ElaboratedInstallPlan - -> ElaboratedInstallPlan -improveInstallPlanWithInstalledPackages installedPkgIdSet = - InstallPlan.installed canPackageBeImproved - where - canPackageBeImproved pkg = - installedUnitId pkg `Set.member` installedPkgIdSet - --TODO: sanity checks: - -- * the installed package must have the expected deps etc - -- * the installed package must not be broken, valid dep closure - - --TODO: decide what to do if we encounter broken installed packages, - -- since overwriting is never safe. +{-# LANGUAGE DeriveFunctor #-} + +-- | Planning how to build everything in a project. +-- +module Distribution.Client.ProjectPlanning ( + -- * elaborated install plan types + ElaboratedInstallPlan, + ElaboratedConfiguredPackage(..), + ElaboratedPlanPackage, + ElaboratedSharedConfig(..), + ElaboratedReadyPackage, + BuildStyle(..), + CabalFileText, + + -- * Producing the elaborated install plan + rebuildProjectConfig, + rebuildInstallPlan, + + -- * Build targets + availableTargets, + AvailableTarget(..), + AvailableTargetStatus(..), + TargetRequested(..), + ComponentTarget(..), + SubComponentTarget(..), + showComponentTarget, + nubComponentTargets, + + -- * Selecting a plan subset + pruneInstallPlanToTargets, + TargetAction(..), + pruneInstallPlanToDependencies, + CannotPruneDependencies(..), + + -- * Utils required for building + pkgHasEphemeralBuildTargets, + elabBuildTargetWholeComponents, + + -- * Setup.hs CLI flags for building + setupHsScriptOptions, + setupHsConfigureFlags, + setupHsConfigureArgs, + setupHsBuildFlags, + setupHsBuildArgs, + setupHsReplFlags, + setupHsReplArgs, + setupHsTestFlags, + setupHsTestArgs, + setupHsBenchFlags, + setupHsBenchArgs, + setupHsCopyFlags, + setupHsRegisterFlags, + setupHsHaddockFlags, + + packageHashInputs, + + -- * Path construction + binDirectoryFor, + binDirectories + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.ProjectPlanning.Types as Ty +import Distribution.Client.PackageHash +import Distribution.Client.RebuildMonad +import Distribution.Client.Store +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectPlanOutput + +import Distribution.Client.Types +import qualified Distribution.Client.InstallPlan as InstallPlan +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.Dependency +import Distribution.Client.Dependency.Types +import qualified Distribution.Client.IndexUtils as IndexUtils +import Distribution.Client.Targets (userToPackageConstraint) +import Distribution.Client.DistDirLayout +import Distribution.Client.SetupWrapper +import Distribution.Client.JobControl +import Distribution.Client.FetchUtils +import qualified Hackage.Security.Client as Sec +import Distribution.Client.Setup hiding (packageName, cabalVersion) +import Distribution.Utils.NubList +import Distribution.Utils.LogProgress +import Distribution.Utils.MapAccum + +import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PkgConfigDb +import Distribution.Solver.Types.ResolverPackage +import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.InstSolverPackage +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Settings + +import Distribution.ModuleName +import Distribution.Package hiding + (InstalledPackageId, installedPackageId) +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentName +import Distribution.Types.PkgconfigDependency +import Distribution.Types.UnqualComponentName +import Distribution.System +import qualified Distribution.PackageDescription as Cabal +import qualified Distribution.PackageDescription as PD +import qualified Distribution.PackageDescription.Configuration as PD +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Simple.Compiler hiding (Flag) +import qualified Distribution.Simple.GHC as GHC --TODO: [code cleanup] eliminate +import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate +import Distribution.Simple.Program +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Find +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Setup + (Flag, toFlag, flagToMaybe, flagToList, fromFlagOrDefault) +import qualified Distribution.Simple.Configure as Cabal +import qualified Distribution.Simple.LocalBuildInfo as Cabal +import Distribution.Simple.LocalBuildInfo + ( Component(..), pkgComponents, componentBuildInfo + , componentName ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.InstalledPackageInfo as IPI + +import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.ComponentsGraph +import Distribution.Backpack.ModuleShape +import Distribution.Backpack.FullUnitId +import Distribution.Backpack +import Distribution.Types.ComponentInclude + +import Distribution.Simple.Utils hiding (matchFileGlob) +import Distribution.Version +import Distribution.Verbosity +import Distribution.Text + +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph(IsNode(..)) + +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 +import Control.Monad.State as State +import Control.Exception +import Data.List (groupBy) +import Data.Either +import Data.Function +import System.FilePath + +------------------------------------------------------------------------------ +-- * Elaborated install plan +------------------------------------------------------------------------------ + +-- "Elaborated" -- worked out with great care and nicety of detail; +-- executed with great minuteness: elaborate preparations; +-- elaborate care. +-- +-- So here's the idea: +-- +-- Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc +-- all passed in as separate args and which are then further selected, +-- transformed etc during the execution of the build. Instead we construct +-- an elaborated install plan that includes everything we will need, and then +-- during the execution of the plan we do as little transformation of this +-- info as possible. +-- +-- So we're trying to split the work into two phases: construction of the +-- elaborated install plan (which as far as possible should be pure) and +-- then simple execution of that plan without any smarts, just doing what the +-- plan says to do. +-- +-- So that means we need a representation of this fully elaborated install +-- plan. The representation consists of two parts: +-- +-- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a +-- representation of source packages that includes a lot more detail about +-- that package's individual configuration +-- +-- * A 'ElaboratedSharedConfig'. Some package configuration is the same for +-- every package in a plan. Rather than duplicate that info every entry in +-- the 'GenericInstallPlan' we keep that separately. +-- +-- The division between the shared and per-package config is /not set in stone +-- for all time/. For example if we wanted to generalise the install plan to +-- describe a situation where we want to build some packages with GHC and some +-- with GHCJS then the platform and compiler would no longer be shared between +-- all packages but would have to be per-package (probably with some sanity +-- condition on the graph structure). +-- + +-- Refer to ProjectPlanning.Types for details of these important types: + +-- type ElaboratedInstallPlan = ... +-- type ElaboratedPlanPackage = ... +-- data ElaboratedSharedConfig = ... +-- data ElaboratedConfiguredPackage = ... +-- data BuildStyle = + + +-- | Check that an 'ElaboratedConfiguredPackage' actually makes +-- sense under some 'ElaboratedSharedConfig'. +sanityCheckElaboratedConfiguredPackage + :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> a + -> a +sanityCheckElaboratedConfiguredPackage sharedConfig + elab@ElaboratedConfiguredPackage{..} = + (case elabPkgOrComp of + ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg + ElabComponent comp -> sanityCheckElaboratedComponent elab comp) + + -- either a package is being built inplace, or the + -- 'installedPackageId' we assigned is consistent with + -- the 'hashedInstalledPackageId' we would compute from + -- the elaborated configured package + . assert (elabBuildStyle == BuildInplaceOnly || + elabComponentId == hashedInstalledPackageId + (packageHashInputs sharedConfig elab)) + + -- the stanzas explicitly disabled should not be available + . assert (Set.null (Map.keysSet (Map.filter not elabStanzasRequested) + `Set.intersection` elabStanzasAvailable)) + + -- either a package is built inplace, or we are not attempting to + -- build any test suites or benchmarks (we never build these + -- for remote packages!) + . assert (elabBuildStyle == BuildInplaceOnly || + Set.null elabStanzasAvailable) + +sanityCheckElaboratedComponent + :: ElaboratedConfiguredPackage + -> ElaboratedComponent + -> a + -> a +sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..} + ElaboratedComponent{..} = + + -- Should not be building bench or test if not inplace. + assert (elabBuildStyle == BuildInplaceOnly || + case compComponentName of + Nothing -> True + Just CLibName -> True + Just (CSubLibName _) -> True + Just (CExeName _) -> True + -- This is interesting: there's no way to declare a dependency + -- on a foreign library at the moment, but you may still want + -- to install these to the store + Just (CFLibName _) -> True + Just (CBenchName _) -> False + Just (CTestName _) -> False) + + +sanityCheckElaboratedPackage + :: ElaboratedConfiguredPackage + -> ElaboratedPackage + -> a + -> a +sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..} + ElaboratedPackage{..} = + -- we should only have enabled stanzas that actually can be built + -- (according to the solver) + assert (pkgStanzasEnabled `Set.isSubsetOf` elabStanzasAvailable) + + -- the stanzas that the user explicitly requested should be + -- enabled (by the previous test, they are also available) + . assert (Map.keysSet (Map.filter id elabStanzasRequested) + `Set.isSubsetOf` pkgStanzasEnabled) + +------------------------------------------------------------------------------ +-- * Deciding what to do: making an 'ElaboratedInstallPlan' +------------------------------------------------------------------------------ + +-- | Return the up-to-date project config and information about the local +-- packages within the project. +-- +rebuildProjectConfig :: Verbosity + -> DistDirLayout + -> ProjectConfig + -> IO (ProjectConfig, + [PackageSpecifier UnresolvedSourcePackage]) +rebuildProjectConfig verbosity + distDirLayout@DistDirLayout { + distProjectRootDirectory, + distDirectory, + distProjectCacheFile, + distProjectCacheDirectory + } + cliConfig = do + + (projectConfig, localPackages) <- + runRebuild distProjectRootDirectory $ + rerunIfChanged verbosity fileMonitorProjectConfig () $ do + + projectConfig <- phaseReadProjectConfig + localPackages <- phaseReadLocalPackages projectConfig + return (projectConfig, localPackages) + + return (projectConfig <> cliConfig, localPackages) + + where + ProjectConfigShared { + projectConfigConfigFile + } = projectConfigShared cliConfig + + fileMonitorProjectConfig = newFileMonitor (distProjectCacheFile "config") + + -- Read the cabal.project (or implicit config) and combine it with + -- arguments from the command line + -- + phaseReadProjectConfig :: Rebuild ProjectConfig + phaseReadProjectConfig = do + liftIO $ do + info verbosity "Project settings changed, reconfiguring..." + readProjectConfig verbosity projectConfigConfigFile distDirLayout + + -- Look for all the cabal packages in the project + -- some of which may be local src dirs, tarballs etc + -- + phaseReadLocalPackages :: ProjectConfig + -> Rebuild [PackageSpecifier UnresolvedSourcePackage] + phaseReadLocalPackages projectConfig = do + localCabalFiles <- findProjectPackages distDirLayout projectConfig + + -- Create folder only if findProjectPackages did not throw a + -- BadPackageLocations exception. + liftIO $ do + createDirectoryIfMissingVerbose verbosity True distDirectory + createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory + + mapM (readSourcePackage verbosity) localCabalFiles + + +-- | Return an up-to-date elaborated install plan. +-- +-- Two variants of the install plan are returned: with and without packages +-- from the store. That is, the \"improved\" plan where source packages are +-- replaced by pre-existing installed packages from the store (when their ids +-- match), and also the original elaborated plan which uses primarily source +-- packages. + +-- The improved plan is what we use for building, but the original elaborated +-- plan is useful for reporting and configuration. For example the @freeze@ +-- command needs the source package info to know about flag choices and +-- dependencies of executables and setup scripts. +-- +rebuildInstallPlan :: Verbosity + -> DistDirLayout -> CabalDirLayout + -> ProjectConfig + -> [PackageSpecifier UnresolvedSourcePackage] + -> IO ( ElaboratedInstallPlan -- with store packages + , ElaboratedInstallPlan -- with source packages + , ElaboratedSharedConfig ) + -- ^ @(improvedPlan, elaboratedPlan, _, _)@ +rebuildInstallPlan verbosity + distDirLayout@DistDirLayout { + distProjectRootDirectory, + distProjectCacheFile + } + CabalDirLayout { + cabalStoreDirLayout + } = \projectConfig localPackages -> + runRebuild distProjectRootDirectory $ do + progsearchpath <- liftIO $ getSystemSearchPath + let projectConfigMonitored = projectConfig { projectConfigBuildOnly = mempty } + + -- The overall improved plan is cached + rerunIfChanged verbosity fileMonitorImprovedPlan + -- react to changes in the project config, + -- the package .cabal files and the path + (projectConfigMonitored, localPackages, progsearchpath) $ do + + -- And so is the elaborated plan that the improved plan based on + (elaboratedPlan, elaboratedShared) <- + rerunIfChanged verbosity fileMonitorElaboratedPlan + (projectConfigMonitored, localPackages, + progsearchpath) $ do + + compilerEtc <- phaseConfigureCompiler projectConfig + _ <- phaseConfigurePrograms projectConfig compilerEtc + (solverPlan, pkgConfigDB) + <- phaseRunSolver projectConfig + compilerEtc + localPackages + (elaboratedPlan, + elaboratedShared) <- phaseElaboratePlan projectConfig + compilerEtc pkgConfigDB + solverPlan + localPackages + + phaseMaintainPlanOutputs elaboratedPlan elaboratedShared + return (elaboratedPlan, elaboratedShared) + + -- The improved plan changes each time we install something, whereas + -- the underlying elaborated plan only changes when input config + -- changes, so it's worth caching them separately. + improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared + + return (improvedPlan, elaboratedPlan, elaboratedShared) + + where + fileMonitorCompiler = newFileMonitorInCacheDir "compiler" + fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan" + fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes" + fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan" + fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan" + + newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b + newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile + + + -- Configure the compiler we're using. + -- + -- This is moderately expensive and doesn't change that often so we cache + -- it independently. + -- + phaseConfigureCompiler :: ProjectConfig + -> Rebuild (Compiler, Platform, ProgramDb) + phaseConfigureCompiler ProjectConfig { + projectConfigShared = ProjectConfigShared { + projectConfigHcFlavor, + projectConfigHcPath, + projectConfigHcPkg + }, + projectConfigLocalPackages = PackageConfig { + packageConfigProgramPaths, + packageConfigProgramArgs, + packageConfigProgramPathExtra + } + } = do + progsearchpath <- liftIO $ getSystemSearchPath + rerunIfChanged verbosity fileMonitorCompiler + (hcFlavor, hcPath, hcPkg, progsearchpath, + packageConfigProgramPaths, + packageConfigProgramArgs, + packageConfigProgramPathExtra) $ do + + liftIO $ info verbosity "Compiler settings changed, reconfiguring..." + result@(_, _, progdb') <- liftIO $ + Cabal.configCompilerEx + hcFlavor hcPath hcPkg + progdb verbosity + + -- Note that we added the user-supplied program locations and args + -- for /all/ programs, not just those for the compiler prog and + -- compiler-related utils. In principle we don't know which programs + -- the compiler will configure (and it does vary between compilers). + -- We do know however that the compiler will only configure the + -- programs it cares about, and those are the ones we monitor here. + monitorFiles (programsMonitorFiles progdb') + + return result + where + hcFlavor = flagToMaybe projectConfigHcFlavor + hcPath = flagToMaybe projectConfigHcPath + hcPkg = flagToMaybe projectConfigHcPkg + progdb = + userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) + . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) + . modifyProgramSearchPath + (++ [ ProgramSearchPathDir dir + | dir <- fromNubList packageConfigProgramPathExtra ]) + $ defaultProgramDb + + + -- Configuring other programs. + -- + -- Having configred the compiler, now we configure all the remaining + -- programs. This is to check we can find them, and to monitor them for + -- changes. + -- + -- TODO: [required eventually] we don't actually do this yet. + -- + -- We rely on the fact that the previous phase added the program config for + -- all local packages, but that all the programs configured so far are the + -- compiler program or related util programs. + -- + phaseConfigurePrograms :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> Rebuild () + phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do + -- Users are allowed to specify program locations independently for + -- each package (e.g. to use a particular version of a pre-processor + -- for some packages). However they cannot do this for the compiler + -- itself as that's just not going to work. So we check for this. + liftIO $ checkBadPerPackageCompilerPaths + (configuredPrograms compilerprogdb) + (getMapMappend (projectConfigSpecificPackage projectConfig)) + + --TODO: [required eventually] find/configure other programs that the + -- user specifies. + + --TODO: [required eventually] find/configure all build-tools + -- but note that some of them may be built as part of the plan. + + + -- Run the solver to get the initial install plan. + -- This is expensive so we cache it independently. + -- + phaseRunSolver :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> [PackageSpecifier UnresolvedSourcePackage] + -> Rebuild (SolverInstallPlan, PkgConfigDb) + phaseRunSolver projectConfig@ProjectConfig { + projectConfigShared, + projectConfigBuildOnly + } + (compiler, platform, progdb) + localPackages = + rerunIfChanged verbosity fileMonitorSolverPlan + (solverSettings, + localPackages, localPackagesEnabledStanzas, + compiler, platform, programDbSignature progdb) $ do + + installedPkgIndex <- getInstalledPackages verbosity + compiler progdb platform + corePackageDbs + sourcePkgDb <- getSourcePackages verbosity withRepoCtx + (solverSettingIndexState solverSettings) + pkgConfigDB <- getPkgConfigDb verbosity progdb + + --TODO: [code cleanup] it'd be better if the Compiler contained the + -- ConfiguredPrograms that it needs, rather than relying on the progdb + -- since we don't need to depend on all the programs here, just the + -- ones relevant for the compiler. + + liftIO $ do + solver <- chooseSolver verbosity + (solverSettingSolver solverSettings) + (compilerInfo compiler) + + notice verbosity "Resolving dependencies..." + plan <- foldProgress logMsg (die' verbosity) return $ + planPackages verbosity compiler platform solver solverSettings + installedPkgIndex sourcePkgDb pkgConfigDB + localPackages localPackagesEnabledStanzas + return (plan, pkgConfigDB) + where + corePackageDbs = [GlobalPackageDB] + withRepoCtx = projectConfigWithSolverRepoContext verbosity + projectConfigShared + projectConfigBuildOnly + solverSettings = resolveSolverSettings projectConfig + logMsg message rest = debugNoWrap verbosity message >> rest + + localPackagesEnabledStanzas = + Map.fromList + [ (pkgname, stanzas) + | pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg + testsEnabled = lookupLocalPackageConfig + packageConfigTests + projectConfig pkgname + benchmarksEnabled = lookupLocalPackageConfig + packageConfigBenchmarks + projectConfig pkgname + stanzas = + Map.fromList $ + [ (TestStanzas, enabled) + | enabled <- flagToList testsEnabled ] + ++ [ (BenchStanzas , enabled) + | enabled <- flagToList benchmarksEnabled ] + ] + + -- Elaborate the solver's install plan to get a fully detailed plan. This + -- version of the plan has the final nix-style hashed ids. + -- + phaseElaboratePlan :: ProjectConfig + -> (Compiler, Platform, ProgramDb) + -> PkgConfigDb + -> SolverInstallPlan + -> [PackageSpecifier (SourcePackage loc)] + -> Rebuild ( ElaboratedInstallPlan + , ElaboratedSharedConfig ) + phaseElaboratePlan ProjectConfig { + projectConfigShared, + projectConfigLocalPackages, + projectConfigSpecificPackage, + projectConfigBuildOnly + } + (compiler, platform, progdb) pkgConfigDB + solverPlan localPackages = do + + liftIO $ debug verbosity "Elaborating the install plan..." + + sourcePackageHashes <- + rerunIfChanged verbosity fileMonitorSourceHashes + (packageLocationsSignature solverPlan) $ + getPackageSourceHashes verbosity withRepoCtx solverPlan + + defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler + (elaboratedPlan, elaboratedShared) + <- liftIO . runLogProgress verbosity $ + elaborateInstallPlan + verbosity + platform compiler progdb pkgConfigDB + distDirLayout + cabalStoreDirLayout + solverPlan + localPackages + sourcePackageHashes + defaultInstallDirs + projectConfigShared + projectConfigLocalPackages + (getMapMappend projectConfigSpecificPackage) + let instantiatedPlan = instantiateInstallPlan elaboratedPlan + liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) + return (instantiatedPlan, elaboratedShared) + where + withRepoCtx = projectConfigWithSolverRepoContext verbosity + projectConfigShared + projectConfigBuildOnly + + -- Update the files we maintain that reflect our current build environment. + -- In particular we maintain a JSON representation of the elaborated + -- install plan (but not the improved plan since that reflects the state + -- of the build rather than just the input environment). + -- + phaseMaintainPlanOutputs :: ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> Rebuild () + phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do + debug verbosity "Updating plan.json" + writePlanExternalRepresentation + distDirLayout + elaboratedPlan + elaboratedShared + + + -- Improve the elaborated install plan. The elaborated plan consists + -- mostly of source packages (with full nix-style hashed ids). Where + -- corresponding installed packages already exist in the store, replace + -- them in the plan. + -- + -- Note that we do monitor the store's package db here, so we will redo + -- this improvement phase when the db changes -- including as a result of + -- executing a plan and installing things. + -- + phaseImprovePlan :: ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> Rebuild ElaboratedInstallPlan + phaseImprovePlan elaboratedPlan elaboratedShared = do + + liftIO $ debug verbosity "Improving the install plan..." + storePkgIdSet <- getStoreEntries cabalStoreDirLayout compid + let improvedPlan = improveInstallPlanWithInstalledPackages + storePkgIdSet + elaboratedPlan + liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan) + -- TODO: [nice to have] having checked which packages from the store + -- we're using, it may be sensible to sanity check those packages + -- by loading up the compiler package db and checking everything + -- matches up as expected, e.g. no dangling deps, files deleted. + return improvedPlan + where + compid = compilerId (pkgConfigCompiler elaboratedShared) + + +programsMonitorFiles :: ProgramDb -> [MonitorFilePath] +programsMonitorFiles progdb = + [ monitor + | prog <- configuredPrograms progdb + , monitor <- monitorFileSearchPath (programMonitorFiles prog) + (programPath prog) + ] + +-- | Select the bits of a 'ProgramDb' to monitor for value changes. +-- Use 'programsMonitorFiles' for the files to monitor. +-- +programDbSignature :: ProgramDb -> [ConfiguredProgram] +programDbSignature progdb = + [ prog { programMonitorFiles = [] + , programOverrideEnv = filter ((/="PATH") . fst) + (programOverrideEnv prog) } + | prog <- configuredPrograms progdb ] + +getInstalledPackages :: Verbosity + -> Compiler -> ProgramDb -> Platform + -> PackageDBStack + -> Rebuild InstalledPackageIndex +getInstalledPackages verbosity compiler progdb platform packagedbs = do + monitorFiles . map monitorFileOrDirectory + =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles + verbosity compiler + packagedbs progdb platform) + liftIO $ IndexUtils.getInstalledPackages + verbosity compiler + packagedbs progdb + +{- +--TODO: [nice to have] use this but for sanity / consistency checking +getPackageDBContents :: Verbosity + -> Compiler -> ProgramDb -> Platform + -> PackageDB + -> Rebuild InstalledPackageIndex +getPackageDBContents verbosity compiler progdb platform packagedb = do + monitorFiles . map monitorFileOrDirectory + =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles + verbosity compiler + [packagedb] progdb platform) + liftIO $ do + createPackageDBIfMissing verbosity compiler progdb packagedb + Cabal.getPackageDBContents verbosity compiler + packagedb progdb +-} + +getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a) + -> Maybe IndexUtils.IndexState -> Rebuild SourcePackageDb +getSourcePackages verbosity withRepoCtx idxState = do + (sourcePkgDb, repos) <- + liftIO $ + withRepoCtx $ \repoctx -> do + sourcePkgDb <- IndexUtils.getSourcePackagesAtIndexState verbosity + repoctx idxState + return (sourcePkgDb, repoContextRepos repoctx) + + mapM_ needIfExists + . IndexUtils.getSourcePackagesMonitorFiles + $ repos + return sourcePkgDb + + +getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb +getPkgConfigDb verbosity progdb = do + dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb + -- Just monitor the dirs so we'll notice new .pc files. + -- Alternatively we could monitor all the .pc files too. + mapM_ monitorDirectoryStatus dirs + liftIO $ readPkgConfigDb verbosity progdb + + +-- | Select the config values to monitor for changes package source hashes. +packageLocationsSignature :: SolverInstallPlan + -> [(PackageId, PackageLocation (Maybe FilePath))] +packageLocationsSignature solverPlan = + [ (packageId pkg, packageSource pkg) + | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) + <- SolverInstallPlan.toList solverPlan + ] + + +-- | Get the 'HashValue' for all the source packages where we use hashes, +-- and download any packages required to do so. +-- +-- Note that we don't get hashes for local unpacked packages. +-- +getPackageSourceHashes :: Verbosity + -> (forall a. (RepoContext -> IO a) -> IO a) + -> SolverInstallPlan + -> Rebuild (Map PackageId PackageSourceHash) +getPackageSourceHashes verbosity withRepoCtx solverPlan = do + + -- Determine if and where to get the package's source hash from. + -- + let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))] + allPkgLocations = + [ (packageId pkg, packageSource pkg) + | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg}) + <- SolverInstallPlan.toList solverPlan ] + + -- Tarballs that were local in the first place. + -- We'll hash these tarball files directly. + localTarballPkgs :: [(PackageId, FilePath)] + localTarballPkgs = + [ (pkgid, tarball) + | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ] + + -- Tarballs from remote URLs. We must have downloaded these already + -- (since we extracted the .cabal file earlier) + --TODO: [required eventually] finish remote tarball functionality +-- allRemoteTarballPkgs = +-- [ (pkgid, ) +-- | (pkgid, RemoteTarballPackage ) <- allPkgLocations ] + + -- Tarballs from repositories, either where the repository provides + -- hashes as part of the repo metadata, or where we will have to + -- download and hash the tarball. + repoTarballPkgsWithMetadata :: [(PackageId, Repo)] + repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)] + (repoTarballPkgsWithMetadata, + repoTarballPkgsWithoutMetadata) = + partitionEithers + [ case repo of + RepoSecure{} -> Left (pkgid, repo) + _ -> Right (pkgid, repo) + | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ] + + -- For tarballs from repos that do not have hashes available we now have + -- to check if the packages were downloaded already. + -- + (repoTarballPkgsToDownload, + repoTarballPkgsDownloaded) + <- fmap partitionEithers $ + liftIO $ sequence + [ do mtarball <- checkRepoTarballFetched repo pkgid + case mtarball of + Nothing -> return (Left (pkgid, repo)) + Just tarball -> return (Right (pkgid, tarball)) + | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ] + + (hashesFromRepoMetadata, + repoTarballPkgsNewlyDownloaded) <- + -- Avoid having to initialise the repository (ie 'withRepoCtx') if we + -- don't have to. (The main cost is configuring the http client.) + if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata + then return (Map.empty, []) + else liftIO $ withRepoCtx $ \repoctx -> do + + -- For tarballs from repos that do have hashes available as part of the + -- repo metadata we now load up the index for each repo and retrieve + -- the hashes for the packages + -- + hashesFromRepoMetadata <- + Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions + fmap (Map.fromList . concat) $ + sequence + -- Reading the repo index is expensive so we group the packages by repo + [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> + Sec.withIndex secureRepo $ \repoIndex -> + sequence + [ do hash <- Sec.trusted <$> -- strip off Trusted tag + Sec.indexLookupHash repoIndex pkgid + -- Note that hackage-security currently uses SHA256 + -- but this API could in principle give us some other + -- choice in future. + return (pkgid, hashFromTUF hash) + | pkgid <- pkgids ] + | (repo, pkgids) <- + map (\grp@((_,repo):_) -> (repo, map fst grp)) + . groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) + . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) + $ repoTarballPkgsWithMetadata + ] + + -- For tarballs from repos that do not have hashes available, download + -- the ones we previously determined we need. + -- + repoTarballPkgsNewlyDownloaded <- + sequence + [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid + return (pkgid, tarball) + | (pkgid, repo) <- repoTarballPkgsToDownload ] + + return (hashesFromRepoMetadata, + repoTarballPkgsNewlyDownloaded) + + -- Hash tarball files for packages where we have to do that. This includes + -- tarballs that were local in the first place, plus tarballs from repos, + -- either previously cached or freshly downloaded. + -- + let allTarballFilePkgs :: [(PackageId, FilePath)] + allTarballFilePkgs = localTarballPkgs + ++ repoTarballPkgsDownloaded + ++ repoTarballPkgsNewlyDownloaded + hashesFromTarballFiles <- liftIO $ + fmap Map.fromList $ + sequence + [ do srchash <- readFileHashValue tarball + return (pkgid, srchash) + | (pkgid, tarball) <- allTarballFilePkgs + ] + monitorFiles [ monitorFile tarball + | (_pkgid, tarball) <- allTarballFilePkgs ] + + -- Return the combination + return $! hashesFromRepoMetadata + <> hashesFromTarballFiles + + +-- ------------------------------------------------------------ +-- * Installation planning +-- ------------------------------------------------------------ + +planPackages :: Verbosity + -> Compiler + -> Platform + -> Solver -> SolverSettings + -> InstalledPackageIndex + -> SourcePackageDb + -> PkgConfigDb + -> [PackageSpecifier UnresolvedSourcePackage] + -> Map PackageName (Map OptionalStanza Bool) + -> Progress String String SolverInstallPlan +planPackages verbosity comp platform solver SolverSettings{..} + installedPkgIndex sourcePkgDb pkgConfigDB + localPackages pkgStanzasEnable = + + resolveDependencies + platform (compilerInfo comp) + pkgConfigDB solver + resolverParams + + where + + --TODO: [nice to have] disable multiple instances restriction in the solver, but then + -- make sure we can cope with that in the output. + resolverParams = + + setMaxBackjumps solverSettingMaxBackjumps + + . setIndependentGoals solverSettingIndependentGoals + + . setReorderGoals solverSettingReorderGoals + + . setCountConflicts solverSettingCountConflicts + + --TODO: [required eventually] should only be configurable for custom installs + -- . setAvoidReinstalls solverSettingAvoidReinstalls + + --TODO: [required eventually] should only be configurable for custom installs + -- . setShadowPkgs solverSettingShadowPkgs + + . setStrongFlags solverSettingStrongFlags + + . setAllowBootLibInstalls solverSettingAllowBootLibInstalls + + . setSolverVerbosity verbosity + + --TODO: [required eventually] decide if we need to prefer installed for + -- global packages, or prefer latest even for global packages. Perhaps + -- should be configurable but with a different name than "upgrade-dependencies". + . setPreferenceDefault PreferLatestForSelected + {-(if solverSettingUpgradeDeps + then PreferAllLatest + else PreferLatestForSelected)-} + + . removeLowerBounds solverSettingAllowOlder + . removeUpperBounds solverSettingAllowNewer + + . addDefaultSetupDependencies (defaultSetupDeps comp platform + . PD.packageDescription + . packageDescription) + + . addSetupCabalMinVersionConstraint (mkVersion [1,20]) + -- While we can talk to older Cabal versions (we need to be able to + -- do so for custom Setup scripts that require older Cabal lib + -- versions), we have problems talking to some older versions that + -- don't support certain features. + -- + -- For example, Cabal-1.16 and older do not know about build targets. + -- Even worse, 1.18 and older only supported the --constraint flag + -- with source package ids, not --dependency with installed package + -- ids. That is bad because we cannot reliably select the right + -- dependencies in the presence of multiple instances (i.e. the + -- store). See issue #3932. So we require Cabal 1.20 as a minimum. + + . addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | Dependency name ver <- solverSettingPreferences ] + + . addConstraints + -- version constraints from the config file or command line + [ LabeledPackageConstraint (userToPackageConstraint pc) src + | (pc, src) <- solverSettingConstraints ] + + . addPreferences + -- enable stanza preference where the user did not specify + [ PackageStanzasPreference pkgname stanzas + | pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg + stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable + stanzas = [ stanza | stanza <- [minBound..maxBound] + , Map.lookup stanza stanzaM == Nothing ] + , not (null stanzas) + ] + + . addConstraints + -- enable stanza constraints where the user asked to enable + [ LabeledPackageConstraint + (PackageConstraint (scopeToplevel pkgname) + (PackagePropertyStanzas stanzas)) + ConstraintSourceConfigFlagOrTarget + | pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg + stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable + stanzas = [ stanza | stanza <- [minBound..maxBound] + , Map.lookup stanza stanzaM == Just True ] + , not (null stanzas) + ] + + . addConstraints + --TODO: [nice to have] should have checked at some point that the + -- package in question actually has these flags. + [ LabeledPackageConstraint + (PackageConstraint (scopeToplevel pkgname) + (PackagePropertyFlags flags)) + ConstraintSourceConfigFlagOrTarget + | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ] + + . addConstraints + --TODO: [nice to have] we have user-supplied flags for unspecified + -- local packages (as well as specific per-package flags). For the + -- former we just apply all these flags to all local targets which + -- is silly. We should check if the flags are appropriate. + [ LabeledPackageConstraint + (PackageConstraint (scopeToplevel pkgname) + (PackagePropertyFlags flags)) + ConstraintSourceConfigFlagOrTarget + | let flags = solverSettingFlagAssignment + , not (PD.nullFlagAssignment flags) + , pkg <- localPackages + , let pkgname = pkgSpecifierTarget pkg ] + + $ stdResolverParams + + stdResolverParams = + -- Note: we don't use the standardInstallPolicy here, since that uses + -- its own addDefaultSetupDependencies that is not appropriate for us. + basicInstallPolicy + installedPkgIndex sourcePkgDb + localPackages + + +------------------------------------------------------------------------------ +-- * Install plan post-processing +------------------------------------------------------------------------------ + +-- This phase goes from the InstallPlan we get from the solver and has to +-- make an elaborated install plan. +-- +-- We go in two steps: +-- +-- 1. elaborate all the source packages that the solver has chosen. +-- 2. swap source packages for pre-existing installed packages wherever +-- possible. +-- +-- We do it in this order, elaborating and then replacing, because the easiest +-- way to calculate the installed package ids used for the replacement step is +-- from the elaborated configuration for each package. + + + + +------------------------------------------------------------------------------ +-- * Install plan elaboration +------------------------------------------------------------------------------ + +-- Note [SolverId to ConfiguredId] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Dependency solving is a per package affair, so after we're done, we +-- end up with 'SolverInstallPlan' that records in 'solverPkgLibDeps' +-- and 'solverPkgExeDeps' what packages provide the libraries and executables +-- needed by each component of the package (phew!) For example, if I have +-- +-- library +-- build-depends: lib +-- build-tool-depends: pkg:exe1 +-- build-tools: alex +-- +-- After dependency solving, I find out that this library component has +-- library dependencies on lib-0.2, and executable dependencies on pkg-0.1 +-- and alex-0.3 (other components of the package may have different +-- dependencies). Note that I've "lost" the knowledge that I depend +-- *specifically* on the exe1 executable from pkg. +-- +-- So, we have a this graph of packages, and we need to transform it into +-- a graph of components which we are actually going to build. In particular: +-- +-- NODE changes from PACKAGE (SolverPackage) to COMPONENTS (ElaboratedConfiguredPackage) +-- EDGE changes from PACKAGE DEP (SolverId) to COMPONENT DEPS (ConfiguredId) +-- +-- In both cases, what was previously a single node/edge may turn into multiple +-- nodes/edges. Multiple components, because there may be multiple components +-- in a package; multiple component deps, because we may depend upon multiple +-- executables from the same package (and maybe, some day, multiple libraries +-- from the same package.) +-- +-- Let's talk about how to do this transformation. Naively, we might consider +-- just processing each package, converting it into (zero or) one or more +-- components. But we also have to update the edges; this leads to +-- two complications: +-- +-- 1. We don't know what the ConfiguredId of a component is until +-- we've configured it, but we cannot configure a component unless +-- we know the ConfiguredId of all its dependencies. Thus, we must +-- process the 'SolverInstallPlan' in topological order. +-- +-- 2. When we process a package, we know the SolverIds of its +-- dependencies, but we have to do some work to turn these into +-- ConfiguredIds. For example, in the case of build-tool-depends, the +-- SolverId isn't enough to uniquely determine the ConfiguredId we should +-- elaborate to: we have to look at the executable name attached to +-- the package name in the package description to figure it out. +-- At the same time, we NEED to use the SolverId, because there might +-- be multiple versions of the same package in the build plan +-- (due to setup dependencies); we can't just look up the package name +-- from the package description. +-- +-- However, we do have the following INVARIANT: a component never directly +-- depends on multiple versions of the same package. Thus, we can +-- adopt the following strategy: +-- +-- * When a package is transformed into components, record +-- a mapping from SolverId to ALL of the components +-- which were elaborated. +-- +-- * When we look up an edge, we use our knowledge of the +-- component name to *filter* the list of components into +-- the ones we actually wanted to refer to. +-- +-- By the way, we can tell that SolverInstallPlan is not the "right" type +-- because a SolverId cannot adequately represent all possible dependency +-- solver states: we may need to record foo-0.1 multiple times in +-- the solver install plan with different dependencies. The solver probably +-- doesn't handle this correctly... but it should. The right way to solve +-- this is to come up with something very much like a 'ConfiguredId', in that +-- it incorporates the version choices of its dependencies, but less +-- fine grained. Fortunately, this doesn't seem to have affected anyone, +-- but it is good to watch out about. + + +-- | Produce an elaborated install plan using the policy for local builds with +-- a nix-style shared store. +-- +-- In theory should be able to make an elaborated install plan with a policy +-- matching that of the classic @cabal install --user@ or @--global@ +-- +elaborateInstallPlan + :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb + -> DistDirLayout + -> StoreDirLayout + -> SolverInstallPlan + -> [PackageSpecifier (SourcePackage loc)] + -> Map PackageId PackageSourceHash + -> InstallDirs.InstallDirTemplates + -> ProjectConfigShared + -> PackageConfig + -> Map PackageName PackageConfig + -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) +elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB + distDirLayout@DistDirLayout{..} + storeDirLayout@StoreDirLayout{storePackageDBStack} + solverPlan localPackages + sourcePackageHashes + defaultInstallDirs + sharedPackageConfig + localPackagesConfig + perPackageConfig = do + x <- elaboratedInstallPlan + return (x, elaboratedSharedConfig) + where + elaboratedSharedConfig = + ElaboratedSharedConfig { + pkgConfigPlatform = platform, + pkgConfigCompiler = compiler, + pkgConfigCompilerProgs = compilerprogdb + } + + preexistingInstantiatedPkgs = + Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan)) + where + f (SolverInstallPlan.PreExisting inst) + | let ipkg = instSolverPkgIPI inst + , not (IPI.indefinite ipkg) + = Just (IPI.installedUnitId ipkg, + (FullUnitId (IPI.installedComponentId ipkg) + (Map.fromList (IPI.instantiatedWith ipkg)))) + f _ = Nothing + + elaboratedInstallPlan = + flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> + case planpkg of + SolverInstallPlan.PreExisting pkg -> + return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] + + SolverInstallPlan.Configured pkg -> + let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace" + | otherwise = Disp.empty + in addProgressCtx (text "In the" <+> inplace_doc <+> text "package" <+> + quotes (disp (packageId pkg))) $ + map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg + + -- NB: We don't INSTANTIATE packages at this point. That's + -- a post-pass. This makes it simpler to compute dependencies. + elaborateSolverToComponents + :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverPackage UnresolvedPkgLoc + -> LogProgress [ElaboratedConfiguredPackage] + elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) + = case mkComponentsGraph (elabEnabledSpec elab0) pd of + Right g -> do + let src_comps = componentsGraphToList g + infoProgress $ hang (text "Component graph for" <+> disp pkgid <<>> colon) + 4 (dispComponentsWithDeps src_comps) + (_, comps) <- mapAccumM buildComponent + (Map.empty, Map.empty, Map.empty) + (map fst src_comps) + let not_per_component_reasons = why_not_per_component src_comps + if null not_per_component_reasons + then return comps + else do checkPerPackageOk comps not_per_component_reasons + return [elaborateSolverToPackage mapDep spkg g $ + comps ++ maybeToList setupComponent] + Left cns -> + dieProgress $ + hang (text "Dependency cycle between the following components:") 4 + (vcat (map (text . componentNameStanza) cns)) + where + -- You are eligible to per-component build if this list is empty + why_not_per_component g + = cuz_custom ++ cuz_spec ++ cuz_length ++ cuz_flag + where + cuz reason = [text reason] + -- At this point in time, only non-Custom setup scripts + -- are supported. Implementing per-component builds with + -- Custom would require us to create a new 'ElabSetup' + -- type, and teach all of the code paths how to handle it. + -- Once you've implemented this, swap it for the code below. + cuz_custom = + case PD.buildType (elabPkgDescription elab0) of + Nothing -> cuz "build-type is not specified" + Just PD.Custom -> cuz "build-type is Custom" + Just _ -> [] + -- cabal-format versions prior to 1.8 have different build-depends semantics + -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 + -- see, https://github.com/haskell/cabal/issues/4121 + cuz_spec + | PD.specVersion pd >= mkVersion [1,8] = [] + | otherwise = cuz "cabal-version is less than 1.8" + -- In the odd corner case that a package has no components at all + -- then keep it as a whole package, since otherwise it turns into + -- 0 component graph nodes and effectively vanishes. We want to + -- keep it around at least for error reporting purposes. + cuz_length + | length g > 0 = [] + | otherwise = cuz "there are no buildable components" + -- For ease of testing, we let per-component builds be toggled + -- at the top level + cuz_flag + | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) + = [] + | otherwise = cuz "you passed --disable-per-component" + + -- | Sometimes a package may make use of features which are only + -- supported in per-package mode. If this is the case, we should + -- give an error when this occurs. + checkPerPackageOk comps reasons = do + let is_sublib (CSubLibName _) = True + is_sublib _ = False + when (any (matchElabPkg is_sublib) comps) $ + dieProgress $ + text "Internal libraries only supported with per-component builds." $$ + text "Per-component builds were disabled because" <+> + fsep (punctuate comma reasons) + -- TODO: Maybe exclude Backpack too + + elab0 = elaborateSolverToCommon mapDep spkg + pkgid = elabPkgSourceId elab0 + pd = elabPkgDescription elab0 + + -- TODO: This is just a skeleton to get elaborateSolverToPackage + -- working correctly + -- TODO: When we actually support building these components, we + -- have to add dependencies on this from all other components + setupComponent :: Maybe ElaboratedConfiguredPackage + setupComponent + | fromMaybe PD.Custom (PD.buildType (elabPkgDescription elab0)) == PD.Custom + = Just elab0 { + elabModuleShape = emptyModuleShape, + elabUnitId = notImpl "elabUnitId", + elabComponentId = notImpl "elabComponentId", + elabLinkedInstantiatedWith = Map.empty, + elabInstallDirs = notImpl "elabInstallDirs", + elabPkgOrComp = ElabComponent (ElaboratedComponent {..}) + } + | otherwise + = Nothing + where + compSolverName = CD.ComponentSetup + compComponentName = Nothing + dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0 + compLibDependencies + = map configuredId dep_pkgs + compLinkedLibDependencies = notImpl "compLinkedLibDependencies" + compOrderLibDependencies = notImpl "compOrderLibDependencies" + -- Not supported: + compExeDependencies = [] + compExeDependencyPaths = [] + compPkgConfigDependencies = [] + + notImpl f = + error $ "Distribution.Client.ProjectPlanning.setupComponent: " ++ + f ++ " not implemented yet" + + + buildComponent + :: (ConfiguredComponentMap, + LinkedComponentMap, + Map ComponentId FilePath) + -> Cabal.Component + -> LogProgress + ((ConfiguredComponentMap, + LinkedComponentMap, + Map ComponentId FilePath), + ElaboratedConfiguredPackage) + buildComponent (cc_map, lc_map, exe_map) comp = + addProgressCtx (text "In the stanza" <+> + quotes (text (componentNameStanza cname))) $ do + + -- 1. Configure the component, but with a place holder ComponentId. + cc0 <- toConfiguredComponent pd + (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") + (Map.unionWith Map.union external_cc_map cc_map) comp + + -- 2. Read out the dependencies from the ConfiguredComponent cc0 + let compLibDependencies = + -- Nub because includes can show up multiple times + ordNub (map (annotatedIdToConfiguredId . ci_ann_id) + (cc_includes cc0)) + compExeDependencies = + map annotatedIdToConfiguredId + (cc_exe_deps cc0) + compExeDependencyPaths = + [ (annotatedIdToConfiguredId aid', path) + | aid' <- cc_exe_deps cc0 + , Just path <- [Map.lookup (ann_id aid') exe_map1]] + elab_comp = ElaboratedComponent {..} + + -- 3. Construct a preliminary ElaboratedConfiguredPackage, + -- and use this to compute the component ID. Fix up cc_id + -- correctly. + let elab1 = elab0 { + elabPkgOrComp = ElabComponent $ elab_comp + } + cid = case elabBuildStyle elab0 of + BuildInplaceOnly -> + mkComponentId $ + display pkgid ++ "-inplace" ++ + (case Cabal.componentNameString cname of + Nothing -> "" + Just s -> "-" ++ display s) + BuildAndInstall -> + hashedInstalledPackageId + (packageHashInputs + elaboratedSharedConfig + elab1) -- knot tied + cc = cc0 { cc_ann_id = fmap (const cid) (cc_ann_id cc0) } + infoProgress $ dispConfiguredComponent cc + + -- 4. Perform mix-in linking + let lookup_uid def_uid = + case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of + Just full -> full + Nothing -> error ("lookup_uid: " ++ display def_uid) + lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0) + (Map.union external_lc_map lc_map) cc + infoProgress $ dispLinkedComponent lc + -- NB: elab is setup to be the correct form for an + -- indefinite library, or a definite library with no holes. + -- We will modify it in 'instantiateInstallPlan' to handle + -- instantiated packages. + + -- 5. Construct the final ElaboratedConfiguredPackage + let + elab = elab1 { + elabModuleShape = lc_shape lc, + elabUnitId = abstractUnitId (lc_uid lc), + elabComponentId = lc_cid lc, + elabLinkedInstantiatedWith = Map.fromList (lc_insts lc), + elabPkgOrComp = ElabComponent $ elab_comp { + compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)), + compOrderLibDependencies = + ordNub (map (abstractUnitId . ci_id) + (lc_includes lc ++ lc_sig_includes lc)) + }, + elabInstallDirs = install_dirs cid + } + + -- 6. Construct the updated local maps + let cc_map' = extendConfiguredComponentMap cc cc_map + lc_map' = extendLinkedComponentMap lc lc_map + exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map + + return ((cc_map', lc_map', exe_map'), elab) + where + compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" + compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" + + cname = Cabal.componentName comp + compComponentName = Just cname + compSolverName = CD.componentNameToComponent cname + + -- NB: compLinkedLibDependencies and + -- compOrderLibDependencies are defined when we define + -- 'elab'. + external_lib_dep_sids = CD.select (== compSolverName) deps0 + external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 + -- TODO: The fact that lib SolverIds and exe SolverIds are + -- jammed together here means that we're losing information! + external_dep_sids = external_lib_dep_sids ++ external_exe_dep_sids + external_dep_pkgs = concatMap mapDep external_dep_sids + + external_exe_map = Map.fromList $ + [ (getComponentId pkg, path) + | pkg <- external_dep_pkgs + , Just path <- [planPackageExePath pkg] ] + exe_map1 = Map.union external_exe_map exe_map + + external_cc_map = Map.fromListWith Map.union + $ map mkCCMapping external_dep_pkgs + external_lc_map = Map.fromList (map mkShapeMapping external_dep_pkgs) + + compPkgConfigDependencies = + [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! " + ++ display pn ++ " from " + ++ display (elabPkgSourceId elab0)) + (pkgConfigDbPkgVersion pkgConfigDB pn)) + | 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 + elaboratedSharedConfig + elab $ + case Cabal.componentNameString cname of + Just n -> display n + Nothing -> "" + + + -- | Given a 'SolverId' referencing a dependency on a library, return + -- the 'ElaboratedPlanPackage' corresponding to the library. This + -- returns at most one result. + elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverId -> [ElaboratedPlanPackage] + elaborateLibSolverId mapDep = filter (matchPlanPkg (== CLibName)) . mapDep + + -- | Given an 'ElaboratedPlanPackage', return the path to where the + -- executable that this package represents would be installed. + planPackageExePath :: ElaboratedPlanPackage -> Maybe FilePath + planPackageExePath = + -- Pre-existing executables are assumed to be in PATH + -- already. In fact, this should be impossible. + InstallPlan.foldPlanPackage (const Nothing) $ \elab -> Just $ + binDirectoryFor + distDirLayout + elaboratedSharedConfig + elab $ + case elabPkgOrComp elab of + ElabPackage _ -> "" + ElabComponent comp -> + case fmap Cabal.componentNameString + (compComponentName comp) of + Just (Just n) -> display n + _ -> "" + + elaborateSolverToPackage :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverPackage UnresolvedPkgLoc + -> ComponentsGraph + -> [ElaboratedConfiguredPackage] + -> ElaboratedConfiguredPackage + elaborateSolverToPackage + mapDep + pkg@(SolverPackage (SourcePackage pkgid _gdesc _srcloc _descOverride) + _flags _stanzas _deps0 _exe_deps0) + compGraph comps = + -- Knot tying: the final elab includes the + -- pkgInstalledId, which is calculated by hashing many + -- of the other fields of the elaboratedPackage. + elab + where + elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon mapDep pkg + elab = elab0 { + elabUnitId = newSimpleUnitId pkgInstalledId, + elabComponentId = pkgInstalledId, + elabLinkedInstantiatedWith = Map.empty, + elabInstallDirs = install_dirs, + elabPkgOrComp = ElabPackage $ ElaboratedPackage {..}, + elabModuleShape = modShape + } + + modShape = case find (matchElabPkg (== CLibName)) comps of + Nothing -> emptyModuleShape + Just e -> Ty.elabModuleShape e + + pkgInstalledId + | shouldBuildInplaceOnly pkg + = mkComponentId (display pkgid ++ "-inplace") + + | otherwise + = assert (isJust elabPkgSourceHash) $ + hashedInstalledPackageId + (packageHashInputs + elaboratedSharedConfig + elab) -- recursive use of elab + + | otherwise + = error $ "elaborateInstallPlan: non-inplace package " + ++ " is missing a source hash: " ++ display pkgid + + -- Need to filter out internal dependencies, because they don't + -- correspond to anything real anymore. + isExt confid = confSrcId confid /= pkgid + filterExt = filter isExt + filterExt' = filter (isExt . fst) + + pkgLibDependencies + = buildComponentDeps (filterExt . compLibDependencies) + pkgExeDependencies + = buildComponentDeps (filterExt . compExeDependencies) + pkgExeDependencyPaths + = buildComponentDeps (filterExt' . compExeDependencyPaths) + -- TODO: Why is this flat? + pkgPkgConfigDependencies + = CD.flatDeps $ buildComponentDeps compPkgConfigDependencies + + pkgDependsOnSelfLib + = CD.fromList [ (CD.componentNameToComponent cn, [()]) + | Graph.N _ cn _ <- fromMaybe [] mb_closure ] + where + mb_closure = Graph.revClosure compGraph [ k | k <- Graph.keys compGraph, is_lib k ] + is_lib CLibName = True + -- NB: this case should not occur, because sub-libraries + -- are not supported without per-component builds + is_lib (CSubLibName _) = True + is_lib _ = False + + buildComponentDeps f + = CD.fromList [ (compSolverName comp, f comp) + | ElaboratedConfiguredPackage{ + elabPkgOrComp = ElabComponent comp + } <- comps + ] + + -- Filled in later + pkgStanzasEnabled = Set.empty + + 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 :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverPackage UnresolvedPkgLoc + -> ElaboratedConfiguredPackage + elaborateSolverToCommon mapDep + pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride) + flags stanzas deps0 _exe_deps0) = + elaboratedPackage + where + elaboratedPackage = ElaboratedConfiguredPackage {..} + + -- These get filled in later + elabUnitId = error "elaborateSolverToCommon: elabUnitId" + elabComponentId = error "elaborateSolverToCommon: elabComponentId" + elabInstantiatedWith = Map.empty + elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith" + elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp" + elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs" + elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" + + elabIsCanonical = True + elabPkgSourceId = pkgid + elabPkgDescription = let Right (desc, _) = + PD.finalizePD + flags elabEnabledSpec (const True) + platform (compilerInfo compiler) + [] gdesc + in desc + elabFlagAssignment = flags + elabFlagDefaults = PD.mkFlagAssignment + [ (Cabal.flagName flag, Cabal.flagDefault flag) + | flag <- PD.genPackageFlags gdesc ] + + elabEnabledSpec = enableStanzas stanzas + elabStanzasAvailable = Set.fromList stanzas + elabStanzasRequested = + -- NB: even if a package stanza is requested, if the package + -- doesn't actually have any of that stanza we omit it from + -- the request, to ensure that we don't decide that this + -- package needs to be rebuilt. (It needs to be done here, + -- because the ElaboratedConfiguredPackage is where we test + -- whether or not there have been changes.) + Map.fromList $ [ (TestStanzas, v) | v <- maybeToList tests + , _ <- PD.testSuites elabPkgDescription ] + ++ [ (BenchStanzas, v) | v <- maybeToList benchmarks + , _ <- PD.benchmarks elabPkgDescription ] + where + tests, benchmarks :: Maybe Bool + tests = perPkgOptionMaybe pkgid packageConfigTests + benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks + + -- This is a placeholder which will get updated by 'pruneInstallPlanPass1' + -- and 'pruneInstallPlanPass2'. We can't populate it here + -- because whether or not tests/benchmarks should be enabled + -- is heuristically calculated based on whether or not the + -- dependencies of the test suite have already been installed, + -- but this function doesn't know what is installed (since + -- we haven't improved the plan yet), so we do it in another pass. + -- Check the comments of those functions for more details. + elabBuildTargets = [] + elabTestTargets = [] + elabBenchTargets = [] + elabReplTarget = Nothing + elabBuildHaddocks = False + + elabPkgSourceLocation = srcloc + elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes + elabLocalToProject = isLocalToProject pkg + elabBuildStyle = if shouldBuildInplaceOnly pkg + then BuildInplaceOnly else BuildAndInstall + elabBuildPackageDBStack = buildAndRegisterDbs + elabRegisterPackageDBStack = buildAndRegisterDbs + + elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription + -- Computing the deps here is a little awful + deps = fmap (concatMap (elaborateLibSolverId mapDep)) deps0 + elabSetupScriptCliVersion = packageSetupScriptSpecVersion + elabSetupScriptStyle elabPkgDescription deps + elabSetupPackageDBStack = buildAndRegisterDbs + + buildAndRegisterDbs + | shouldBuildInplaceOnly pkg = inplacePackageDbs + | otherwise = storePackageDbs + + elabPkgDescriptionOverride = descOverride + + elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively + elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary + elabStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib + elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe + elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still + + elabProfExe = perPkgOptionFlag pkgid False packageConfigProf + elabProfLib = pkgid `Set.member` pkgsUseProfilingLibrary + + (elabProfExeDetail, + elabProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault + packageConfigProfDetail + packageConfigProfLibDetail + elabCoverage = perPkgOptionFlag pkgid False packageConfigCoverage + + elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization + elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs + elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections + elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs + elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes + elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo + + -- Combine the configured compiler prog settings with the user-supplied + -- config. For the compiler progs any user-supplied config was taken + -- into account earlier when configuring the compiler so its ok that + -- our configured settings for the compiler override the user-supplied + -- config here. + elabProgramPaths = Map.fromList + [ (programId prog, programPath prog) + | prog <- configuredPrograms compilerprogdb ] + <> perPkgOptionMapLast pkgid packageConfigProgramPaths + elabProgramArgs = Map.fromList + [ (programId prog, args) + | prog <- configuredPrograms compilerprogdb + , let args = programOverrideArgs prog + , not (null args) + ] + <> perPkgOptionMapMappend pkgid packageConfigProgramArgs + elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra + elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs + elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs + elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs + elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs + elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix + elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix + + + elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle + elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml + elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation + elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs + elabHaddockForHackage = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage + elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables + elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites + elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks + elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal + elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss + elabHaddockHscolour = perPkgOptionFlag pkgid False packageConfigHaddockHscolour + elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss + elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents + + perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a + perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a + perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] + + perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f) + perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) + perPkgOptionList pkgid f = lookupPerPkgOption pkgid f + perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) + perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) + perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) + + perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) + where + exe = fromFlagOrDefault def bothflag + lib = fromFlagOrDefault def (bothflag <> libflag) + + bothflag = lookupPerPkgOption pkgid fboth + libflag = lookupPerPkgOption pkgid flib + + lookupPerPkgOption :: (Package pkg, Monoid m) + => pkg -> (PackageConfig -> m) -> m + lookupPerPkgOption pkg f + -- the project config specifies values that apply to packages local to + -- but by default non-local packages get all default config values + -- the project, and can specify per-package values for any package, + | isLocalToProject pkg = local `mappend` perpkg + | otherwise = perpkg + where + local = f localPackagesConfig + perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) + + inplacePackageDbs = storePackageDbs + ++ [ distPackageDB (compilerId compiler) ] + + storePackageDbs = storePackageDBStack (compilerId compiler) + + -- For this local build policy, every package that lives in a local source + -- dir (as opposed to a tarball), or depends on such a package, will be + -- built inplace into a shared dist dir. Tarball packages that depend on + -- source dir packages will also get unpacked locally. + shouldBuildInplaceOnly :: SolverPackage loc -> Bool + shouldBuildInplaceOnly pkg = Set.member (packageId pkg) + pkgsToBuildInplaceOnly + + pkgsToBuildInplaceOnly :: Set PackageId + pkgsToBuildInplaceOnly = + Set.fromList + $ map packageId + $ SolverInstallPlan.reverseDependencyClosure + solverPlan + (map PlannedId (Set.toList pkgsLocalToProject)) + + isLocalToProject :: Package pkg => pkg -> Bool + isLocalToProject pkg = Set.member (packageId pkg) + pkgsLocalToProject + + pkgsLocalToProject :: Set PackageId + pkgsLocalToProject = + Set.fromList (catMaybes (map shouldBeLocal localPackages)) + --TODO: localPackages is a misnomer, it's all project packages + -- here is where we decide which ones will be local! + where + shouldBeLocal :: PackageSpecifier (SourcePackage loc) -> Maybe PackageId + shouldBeLocal NamedPackage{} = Nothing + shouldBeLocal (SpecificSourcePackage pkg) = Just (packageId pkg) + -- TODO: It's not actually obvious for all of the + -- 'ProjectPackageLocation's that they should all be local. We might + -- need to provide the user with a choice. + -- Also, review use of SourcePackage's loc vs ProjectPackageLocation + + pkgsUseSharedLibrary :: Set PackageId + pkgsUseSharedLibrary = + packagesWithLibDepsDownwardClosedProperty needsSharedLib + where + needsSharedLib pkg = + fromMaybe compilerShouldUseSharedLibByDefault + (liftM2 (||) pkgSharedLib pkgDynExe) + where + pkgid = packageId pkg + pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib + pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe + + --TODO: [code cleanup] move this into the Cabal lib. It's currently open + -- coded in Distribution.Simple.Configure, but should be made a proper + -- function of the Compiler or CompilerInfo. + compilerShouldUseSharedLibByDefault = + case compilerFlavor compiler of + GHC -> GHC.isDynamic compiler + GHCJS -> GHCJS.isDynamic compiler + _ -> False + + pkgsUseProfilingLibrary :: Set PackageId + pkgsUseProfilingLibrary = + packagesWithLibDepsDownwardClosedProperty needsProfilingLib + where + needsProfilingLib pkg = + fromFlagOrDefault False (profBothFlag <> profLibFlag) + where + pkgid = packageId pkg + profBothFlag = lookupPerPkgOption pkgid packageConfigProf + profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib + --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe + + libDepGraph = Graph.fromDistinctList $ + map NonSetupLibDepSolverPlanPackage + (SolverInstallPlan.toList solverPlan) + + packagesWithLibDepsDownwardClosedProperty property = + Set.fromList + . map packageId + . fromMaybe [] + $ Graph.closure + libDepGraph + [ Graph.nodeKey pkg + | pkg <- SolverInstallPlan.toList solverPlan + , property pkg ] -- just the packages that satisfy the property + --TODO: [nice to have] this does not check the config consistency, + -- e.g. a package explicitly turning off profiling, but something + -- depending on it that needs profiling. This really needs a separate + -- package config validation/resolution pass. + + --TODO: [nice to have] config consistency checking: + -- + profiling libs & exes, exe needs lib, recursive + -- + shared libs & exes, exe needs lib, recursive + -- + vanilla libs & exes, exe needs lib, recursive + -- + ghci or shared lib needed by TH, recursive, ghc version dependent + +-- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping + +-- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. +matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool +matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p) + +-- | Get the appropriate 'ComponentName' which identifies an installed +-- component. +ipiComponentName :: IPI.InstalledPackageInfo -> ComponentName +ipiComponentName ipkg = + case IPI.sourceLibName ipkg of + Nothing -> CLibName + Just n -> (CSubLibName n) + +-- | Given a 'ElaboratedConfiguredPackage', report if it matches a +-- 'ComponentName'. +matchElabPkg :: (ComponentName -> Bool) -> ElaboratedConfiguredPackage -> Bool +matchElabPkg p elab = + case elabPkgOrComp elab of + ElabComponent comp -> maybe False p (compComponentName comp) + ElabPackage _ -> + -- So, what should we do here? One possibility is to + -- unconditionally return 'True', because whatever it is + -- that we're looking for, it better be in this package. + -- But this is a bit dodgy if the package doesn't actually + -- have, e.g., a library. Fortunately, it's not possible + -- for the build of the library/executables to be toggled + -- by 'pkgStanzasEnabled', so the only thing we have to + -- test is if the component in question is *buildable.* + any (p . componentName) + (Cabal.pkgBuildableComponents (elabPkgDescription elab)) + +-- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName' +-- and 'ComponentName' to the 'ComponentId' that that should be used +-- in this case. +mkCCMapping :: ElaboratedPlanPackage + -> (PackageName, Map ComponentName (AnnotatedId ComponentId)) +mkCCMapping = + InstallPlan.foldPlanPackage + (\ipkg -> (packageName ipkg, + Map.singleton (ipiComponentName ipkg) + -- TODO: libify + (AnnotatedId { + ann_id = IPI.installedComponentId ipkg, + ann_pid = packageId ipkg, + ann_cname = IPI.sourceComponentName ipkg + }))) + $ \elab -> + let mk_aid cn = AnnotatedId { + ann_id = elabComponentId elab, + ann_pid = packageId elab, + ann_cname = cn + } + in (packageName elab, + case elabPkgOrComp elab of + ElabComponent comp -> + case compComponentName comp of + Nothing -> Map.empty + Just n -> Map.singleton n (mk_aid n) + ElabPackage _ -> + Map.fromList $ + map (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn)) + (Cabal.pkgBuildableComponents (elabPkgDescription elab))) + +-- | Given an 'ElaboratedPlanPackage', generate the mapping from 'ComponentId' +-- to the shape of this package, as per mix-in linking. +mkShapeMapping :: ElaboratedPlanPackage + -> (ComponentId, (OpenUnitId, ModuleShape)) +mkShapeMapping dpkg = + (getComponentId dpkg, (indef_uid, shape)) + where + (dcid, shape) = + InstallPlan.foldPlanPackage + -- Uses Monad (->) + (liftM2 (,) IPI.installedComponentId shapeInstalledPackage) + (liftM2 (,) elabComponentId elabModuleShape) + dpkg + indef_uid = + IndefFullUnitId dcid + (Map.fromList [ (req, OpenModuleVar req) + | req <- Set.toList (modShapeRequires shape)]) + +-- | Get the bin\/ directories that a package's executables should reside in. +-- +-- The result may be empty if the package does not build any executables. +-- +-- The result may have several entries if this is an inplace build of a package +-- with multiple executables. +binDirectories + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> [FilePath] +binDirectories layout config package = case elabBuildStyle package of + -- quick sanity check: no sense returning a bin directory if we're not going + -- to put any executables in it, that will just clog up the PATH + _ | noExecutables -> [] + BuildAndInstall -> [installedBinDirectory package] + BuildInplaceOnly -> map (root) $ case elabPkgOrComp package of + ElabComponent comp -> case compSolverName comp of + CD.ComponentExe n -> [display n] + _ -> [] + ElabPackage _ -> map (display . PD.exeName) + . PD.executables + . elabPkgDescription + $ package + where + noExecutables = null . PD.executables . elabPkgDescription $ package + root = distBuildDirectory layout (elabDistDirParams config package) + "build" + +-- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the +-- dependency graph considers only dependencies on libraries which are +-- NOT from setup dependencies. Used to compute the set +-- of packages needed for profiling and dynamic libraries. +newtype NonSetupLibDepSolverPlanPackage + = NonSetupLibDepSolverPlanPackage + { unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage } + +instance Package NonSetupLibDepSolverPlanPackage where + packageId = packageId . unNonSetupLibDepSolverPlanPackage + +instance IsNode NonSetupLibDepSolverPlanPackage where + type Key NonSetupLibDepSolverPlanPackage = SolverId + nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage + nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg) + = ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg) + +type InstS = Map UnitId ElaboratedPlanPackage +type InstM a = State InstS a + +getComponentId :: ElaboratedPlanPackage + -> ComponentId +getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg +getComponentId (InstallPlan.Configured elab) = elabComponentId elab +getComponentId (InstallPlan.Installed elab) = elabComponentId elab + +instantiateInstallPlan :: ElaboratedInstallPlan -> ElaboratedInstallPlan +instantiateInstallPlan plan = + InstallPlan.new (IndependentGoals False) + (Graph.fromDistinctList (Map.elems ready_map)) + where + pkgs = InstallPlan.toList plan + + cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ] + + instantiateUnitId :: ComponentId -> Map ModuleName Module + -> InstM DefUnitId + instantiateUnitId cid insts = state $ \s -> + case Map.lookup uid s of + Nothing -> + -- Knot tied + let (r, s') = runState (instantiateComponent uid cid insts) + (Map.insert uid r s) + in (def_uid, Map.insert uid r s') + Just _ -> (def_uid, s) + where + def_uid = mkDefUnitId cid insts + uid = unDefUnitId def_uid + + instantiateComponent + :: UnitId -> ComponentId -> Map ModuleName Module + -> InstM ElaboratedPlanPackage + instantiateComponent uid cid insts + | Just planpkg <- Map.lookup cid cmap + = case planpkg of + InstallPlan.Configured (elab@ElaboratedConfiguredPackage + { elabPkgOrComp = ElabComponent comp }) -> do + deps <- mapM (substUnitId insts) + (compLinkedLibDependencies comp) + let getDep (Module dep_uid _) = [dep_uid] + return $ InstallPlan.Configured elab { + elabUnitId = uid, + elabComponentId = cid, + elabInstantiatedWith = insts, + elabIsCanonical = Map.null insts, + elabPkgOrComp = ElabComponent comp { + compOrderLibDependencies = + (if Map.null insts then [] else [newSimpleUnitId cid]) ++ + ordNub (map unDefUnitId + (deps ++ concatMap getDep (Map.elems insts))) + } + } + _ -> return planpkg + | otherwise = error ("instantiateComponent: " ++ display cid) + + substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId + substUnitId _ (DefiniteUnitId uid) = + return uid + substUnitId subst (IndefFullUnitId cid insts) = do + insts' <- substSubst subst insts + instantiateUnitId cid insts' + + -- NB: NOT composition + substSubst :: Map ModuleName Module + -> Map ModuleName OpenModule + -> InstM (Map ModuleName Module) + substSubst subst insts = T.mapM (substModule subst) insts + + substModule :: Map ModuleName Module -> OpenModule -> InstM Module + substModule subst (OpenModuleVar mod_name) + | Just m <- Map.lookup mod_name subst = return m + | otherwise = error "substModule: non-closing substitution" + substModule subst (OpenModule uid mod_name) = do + uid' <- substUnitId subst uid + return (Module uid' mod_name) + + indefiniteUnitId :: ComponentId -> InstM UnitId + indefiniteUnitId cid = do + let uid = newSimpleUnitId cid + r <- indefiniteComponent uid cid + state $ \s -> (uid, Map.insert uid r s) + + indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage + indefiniteComponent _uid cid + | Just planpkg <- Map.lookup cid cmap + = return planpkg + | otherwise = error ("indefiniteComponent: " ++ display cid) + + ready_map = execState work Map.empty + + work = forM_ pkgs $ \pkg -> + case pkg of + InstallPlan.Configured elab + | not (Map.null (elabLinkedInstantiatedWith elab)) + -> indefiniteUnitId (elabComponentId elab) + >> return () + _ -> instantiateUnitId (getComponentId pkg) Map.empty + >> return () + +--------------------------- +-- Build targets +-- + +-- Refer to ProjectPlanning.Types for details of these important types: + +-- data ComponentTarget = ... +-- data SubComponentTarget = ... + +-- One step in the build system is to translate higher level intentions like +-- "build this package", "test that package", or "repl that component" into +-- a more detailed specification of exactly which components to build (or other +-- actions like repl or build docs). This translation is somewhat different for +-- different commands. For example "test" for a package will build a different +-- set of components than "build". In addition, the translation of these +-- intentions can fail. For example "run" for a package is only unambiguous +-- when the package has a single executable. +-- +-- So we need a little bit of infrastructure to make it easy for the command +-- implementations to select what component targets are meant when a user asks +-- to do something with a package or component. To do this (and to be able to +-- produce good error messages for mistakes and when targets are not available) +-- we need to gather and summarise accurate information about all the possible +-- targets, both available and unavailable. Then a command implementation can +-- decide which of the available component targets should be selected. + +-- | An available target represents a component within a package that a user +-- command could plausibly refer to. In this sense, all the components defined +-- within the package are things the user could refer to, whether or not it +-- would actually be possible to build that component. +-- +-- In particular the available target contains an 'AvailableTargetStatus' which +-- informs us about whether it's actually possible to select this component to +-- be built, and if not why not. This detail makes it possible for command +-- implementations (like @build@, @test@ etc) to accurately report why a target +-- cannot be used. +-- +-- Note that the type parameter is used to help enforce that command +-- implementations can only select targets that can actually be built (by +-- forcing them to return the @k@ value for the selected targets). +-- In particular 'resolveTargets' makes use of this (with @k@ as +-- @('UnitId', ComponentName')@) to identify the targets thus selected. +-- +data AvailableTarget k = AvailableTarget { + availableTargetPackageId :: PackageId, + availableTargetComponentName :: ComponentName, + availableTargetStatus :: AvailableTargetStatus k, + availableTargetLocalToProject :: Bool + } + deriving (Eq, Show, Functor) + +-- | The status of a an 'AvailableTarget' component. This tells us whether +-- it's actually possible to select this component to be built, and if not +-- why not. +-- +data AvailableTargetStatus k = + TargetDisabledByUser -- ^ When the user does @tests: False@ + | TargetDisabledBySolver -- ^ When the solver could not enable tests + | TargetNotBuildable -- ^ When the component has @buildable: False@ + | TargetNotLocal -- ^ When the component is non-core in a non-local package + | TargetBuildable k TargetRequested -- ^ The target can or should be built + deriving (Eq, Ord, Show, Functor) + +-- | This tells us whether a target ought to be built by default, or only if +-- specifically requested. The policy is that components like libraries and +-- executables are built by default by @build@, but test suites and benchmarks +-- are not, unless this is overridden in the project configuration. +-- +data TargetRequested = + TargetRequestedByDefault -- ^ To be built by default + | TargetNotRequestedByDefault -- ^ Not to be built by default + deriving (Eq, Ord, Show) + +-- | Given the install plan, produce the set of 'AvailableTarget's for each +-- package-component pair. +-- +-- Typically there will only be one such target for each component, but for +-- example if we have a plan with both normal and profiling variants of a +-- component then we would get both as available targets, or similarly if we +-- had a plan that contained two instances of the same version of a package. +-- This approach makes it relatively easy to select all instances\/variants +-- of a component. +-- +availableTargets :: ElaboratedInstallPlan + -> Map (PackageId, ComponentName) + [AvailableTarget (UnitId, ComponentName)] +availableTargets installPlan = + let rs = [ (pkgid, cname, fake, target) + | pkg <- InstallPlan.toList installPlan + , (pkgid, cname, fake, target) <- case pkg of + InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg + InstallPlan.Installed elab -> availableSourceTargets elab + InstallPlan.Configured elab -> availableSourceTargets elab + ] + in Map.union + (Map.fromListWith (++) + [ ((pkgid, cname), [target]) + | (pkgid, cname, fake, target) <- rs, not fake]) + (Map.fromList + [ ((pkgid, cname), [target]) + | (pkgid, cname, fake, target) <- rs, fake]) + -- The normal targets mask the fake ones. We get all instances of the + -- normal ones and only one copy of the fake ones (as there are many + -- duplicates of the fake ones). See 'availableSourceTargets' below for + -- more details on this fake stuff is about. + +availableInstalledTargets :: IPI.InstalledPackageInfo + -> [(PackageId, ComponentName, Bool, + AvailableTarget (UnitId, ComponentName))] +availableInstalledTargets ipkg = + let unitid = installedUnitId ipkg + cname = CLibName + status = TargetBuildable (unitid, cname) TargetRequestedByDefault + target = AvailableTarget (packageId ipkg) cname status False + fake = False + in [(packageId ipkg, cname, fake, target)] + +availableSourceTargets :: ElaboratedConfiguredPackage + -> [(PackageId, ComponentName, Bool, + AvailableTarget (UnitId, ComponentName))] +availableSourceTargets elab = + -- We have a somewhat awkward problem here. We need to know /all/ the + -- components from /all/ the packages because these are the things that + -- users could refer to. Unfortunately, at this stage the elaborated install + -- plan does /not/ contain all components: some components have already + -- been deleted because they cannot possibly be built. This is the case + -- for components that are marked @buildable: False@ in their .cabal files. + -- (It's not unreasonable that the unbuildable components have been pruned + -- as the plan invariant is considerably simpler if all nodes can be built) + -- + -- We can recover the missing components but it's not exactly elegant. For + -- a graph node corresponding to a component we still have the information + -- about the package that it came from, and this includes the names of + -- /all/ the other components in the package. So in principle this lets us + -- find the names of all components, plus full details of the buildable + -- components. + -- + -- Consider for example a package with 3 exe components: foo, bar and baz + -- where foo and bar are buildable, but baz is not. So the plan contains + -- nodes for the components foo and bar. Now we look at each of these two + -- nodes and look at the package they come from and the names of the + -- components in this package. This will give us the names foo, bar and + -- baz, twice (once for each of the two buildable components foo and bar). + -- + -- We refer to these reconstructed missing components as fake targets. + -- It is an invariant that they are not available to be built. + -- + -- To produce the final set of targets we put the fake targets in a finite + -- map (thus eliminating the duplicates) and then we overlay that map with + -- the normal buildable targets. (This is done above in 'availableTargets'.) + -- + [ (packageId elab, cname, fake, target) + | component <- pkgComponents (elabPkgDescription elab) + , let cname = componentName component + status = componentAvailableTargetStatus component + target = AvailableTarget { + availableTargetPackageId = packageId elab, + availableTargetComponentName = cname, + availableTargetStatus = status, + availableTargetLocalToProject = elabLocalToProject elab + } + fake = isFakeTarget cname + + -- TODO: The goal of this test is to exclude "instantiated" + -- packages as available targets. This means that you can't + -- ask for a particular instantiated component to be built; + -- it will only get built by a dependency. Perhaps the + -- correct way to implement this is to run selection + -- prior to instantiating packages. If you refactor + -- this, then you can delete this test. + , elabIsCanonical elab + + -- Filter out some bogus parts of the cross product that are never needed + , case status of + TargetBuildable{} | fake -> False + _ -> True + ] + where + isFakeTarget cname = + case elabPkgOrComp elab of + ElabPackage _ -> False + ElabComponent elabComponent -> compComponentName elabComponent + /= Just cname + + componentAvailableTargetStatus + :: Component -> AvailableTargetStatus (UnitId, ComponentName) + componentAvailableTargetStatus component = + case componentOptionalStanza (componentName component) of + -- it is not an optional stanza, so a library, exe or foreign lib + Nothing + | not buildable -> TargetNotBuildable + | otherwise -> TargetBuildable (elabUnitId elab, cname) + TargetRequestedByDefault + + -- it is not an optional stanza, so a testsuite or benchmark + Just stanza -> + case (Map.lookup stanza (elabStanzasRequested elab), + Set.member stanza (elabStanzasAvailable elab)) of + _ | not withinPlan -> TargetNotLocal + (Just False, _) -> TargetDisabledByUser + (Nothing, False) -> TargetDisabledBySolver + _ | not buildable -> TargetNotBuildable + (Just True, True) -> TargetBuildable (elabUnitId elab, cname) + TargetRequestedByDefault + (Nothing, True) -> TargetBuildable (elabUnitId elab, cname) + TargetNotRequestedByDefault + (Just True, False) -> + error "componentAvailableTargetStatus: impossible" + where + cname = componentName component + buildable = PD.buildable (componentBuildInfo component) + withinPlan = elabLocalToProject elab + || case elabPkgOrComp elab of + ElabComponent elabComponent -> + compComponentName elabComponent == Just cname + ElabPackage _ -> + case componentName component of + CLibName -> True + CExeName _ -> True + --TODO: what about sub-libs and foreign libs? + _ -> False + +-- | Merge component targets that overlap each other. Specially when we have +-- multiple targets for the same component and one of them refers to the whole +-- component (rather than a module or file within) then all the other targets +-- for that component are subsumed. +-- +-- We also allow for information associated with each component target, and +-- whenever we targets subsume each other we aggregate their associated info. +-- +nubComponentTargets :: [(ComponentTarget, a)] -> [(ComponentTarget, [a])] +nubComponentTargets = + concatMap (wholeComponentOverrides . map snd) + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + . map (\t@((ComponentTarget cname _, _)) -> (cname, t)) + . map compatSubComponentTargets + where + -- If we're building the whole component then that the only target all we + -- need, otherwise we can have several targets within the component. + wholeComponentOverrides :: [(ComponentTarget, a )] + -> [(ComponentTarget, [a])] + wholeComponentOverrides ts = + case [ t | (t@(ComponentTarget _ WholeComponent), _) <- ts ] of + (t:_) -> [ (t, map snd ts) ] + [] -> [ (t,[x]) | (t,x) <- ts ] + + -- Not all Cabal Setup.hs versions support sub-component targets, so switch + -- them over to the whole component + compatSubComponentTargets :: (ComponentTarget, a) -> (ComponentTarget, a) + compatSubComponentTargets target@(ComponentTarget cname _subtarget, x) + | not setupHsSupportsSubComponentTargets + = (ComponentTarget cname WholeComponent, x) + | otherwise = target + + -- Actually the reality is that no current version of Cabal's Setup.hs + -- build command actually support building specific files or modules. + setupHsSupportsSubComponentTargets = False + -- TODO: when that changes, adjust this test, e.g. + -- | pkgSetupScriptCliVersion >= Version [x,y] [] + +pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool +pkgHasEphemeralBuildTargets elab = + isJust (elabReplTarget elab) + || (not . null) (elabTestTargets elab) + || (not . null) (elabBenchTargets elab) + || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab + , subtarget /= WholeComponent ] + +-- | The components that we'll build all of, meaning that after they're built +-- we can skip building them again (unlike with building just some modules or +-- other files within a component). +-- +elabBuildTargetWholeComponents :: ElaboratedConfiguredPackage + -> Set ComponentName +elabBuildTargetWholeComponents elab = + Set.fromList + [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ] + + + +------------------------------------------------------------------------------ +-- * Install plan pruning +------------------------------------------------------------------------------ + +-- | How 'pruneInstallPlanToTargets' should interpret the per-package +-- 'ComponentTarget's: as build, repl or haddock targets. +-- +data TargetAction = TargetActionBuild + | TargetActionRepl + | TargetActionTest + | TargetActionBench + | TargetActionHaddock + +-- | Given a set of per-package\/per-component targets, take the subset of the +-- install plan needed to build those targets. Also, update the package config +-- to specify which optional stanzas to enable, and which targets within each +-- package to build. +-- +pruneInstallPlanToTargets :: TargetAction + -> Map UnitId [ComponentTarget] + -> ElaboratedInstallPlan -> ElaboratedInstallPlan +pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = + InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) + . Graph.fromDistinctList + -- We have to do the pruning in two passes + . pruneInstallPlanPass2 + . pruneInstallPlanPass1 + -- Set the targets that will be the roots for pruning + . setRootTargets targetActionType perPkgTargetsMap + . InstallPlan.toList + $ elaboratedPlan + +-- | This is a temporary data type, where we temporarily +-- override the graph dependencies of an 'ElaboratedPackage', +-- so we can take a closure over them. We'll throw out the +-- overriden dependencies when we're done so it's strictly temporary. +-- +-- For 'ElaboratedComponent', this the cached unit IDs always +-- coincide with the real thing. +data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId] + +instance Package PrunedPackage where + packageId (PrunedPackage elab _) = packageId elab + +instance HasUnitId PrunedPackage where + installedUnitId = nodeKey + +instance IsNode PrunedPackage where + type Key PrunedPackage = UnitId + nodeKey (PrunedPackage elab _) = nodeKey elab + nodeNeighbors (PrunedPackage _ deps) = deps + +fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage +fromPrunedPackage (PrunedPackage elab _) = elab + +-- | Set the build targets based on the user targets (but not rev deps yet). +-- This is required before we can prune anything. +-- +setRootTargets :: TargetAction + -> Map UnitId [ComponentTarget] + -> [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] +setRootTargets targetAction perPkgTargetsMap = + assert (not (Map.null perPkgTargetsMap)) $ + assert (all (not . null) (Map.elems perPkgTargetsMap)) $ + + map (mapConfiguredPackage setElabBuildTargets) + where + -- Set the targets we'll build for this package/component. This is just + -- based on the root targets from the user, not targets implied by reverse + -- dependencies. Those comes in the second pass once we know the rev deps. + -- + setElabBuildTargets elab = + case (Map.lookup (installedUnitId elab) perPkgTargetsMap, + targetAction) of + (Nothing, _) -> elab + (Just tgts, TargetActionBuild) -> elab { elabBuildTargets = tgts } + (Just tgts, TargetActionTest) -> elab { elabTestTargets = tgts } + (Just tgts, TargetActionBench) -> elab { elabBenchTargets = tgts } + (Just [tgt], TargetActionRepl) -> elab { elabReplTarget = Just tgt } + (Just _, TargetActionHaddock) -> elab { elabBuildHaddocks = True } + (Just _, TargetActionRepl) -> + error "pruneInstallPlanToTargets: multiple repl targets" + +-- | Assuming we have previously set the root build targets (i.e. the user +-- targets but not rev deps yet), the first pruning pass does two things: +-- +-- * A first go at determining which optional stanzas (testsuites, benchmarks) +-- are needed. We have a second go in the next pass. +-- * Take the dependency closure using pruned dependencies. We prune deps that +-- are used only by unneeded optional stanzas. These pruned deps are only +-- used for the dependency closure and are not persisted in this pass. +-- +pruneInstallPlanPass1 :: [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] +pruneInstallPlanPass1 pkgs = + map (mapConfiguredPackage fromPrunedPackage) + (fromMaybe [] $ Graph.closure graph roots) + where + pkgs' = map (mapConfiguredPackage prune) pkgs + graph = Graph.fromDistinctList pkgs' + roots = mapMaybe find_root pkgs' + + prune elab = PrunedPackage elab' (pruneOptionalDependencies elab') + where elab' = pruneOptionalStanzas elab + + find_root (InstallPlan.Configured (PrunedPackage elab _)) = + if not (null (elabBuildTargets elab) + && null (elabTestTargets elab) + && null (elabBenchTargets elab) + && isNothing (elabReplTarget elab) + && not (elabBuildHaddocks elab)) + then Just (installedUnitId elab) + else Nothing + find_root _ = Nothing + + -- Decide whether or not to enable testsuites and benchmarks + -- + -- The testsuite and benchmark targets are somewhat special in that we need + -- to configure the packages with them enabled, and we need to do that even + -- if we only want to build one of several testsuites. + -- + -- There are two cases in which we will enable the testsuites (or + -- benchmarks): if one of the targets is a testsuite, or if all of the + -- testsuite dependencies are already cached in the store. The rationale + -- for the latter is to minimise how often we have to reconfigure due to + -- the particular targets we choose to build. Otherwise choosing to build + -- a testsuite target, and then later choosing to build an exe target + -- would involve unnecessarily reconfiguring the package with testsuites + -- disabled. Technically this introduces a little bit of stateful + -- behaviour to make this "sticky", but it should be benign. + -- + pruneOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage + pruneOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } = + elab { + elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas }) + } + where + stanzas :: Set OptionalStanza + stanzas = optionalStanzasRequiredByTargets elab + <> optionalStanzasRequestedByDefault elab + <> optionalStanzasWithDepsAvailable availablePkgs elab pkg + pruneOptionalStanzas elab = elab + + -- Calculate package dependencies but cut out those needed only by + -- optional stanzas that we've determined we will not enable. + -- These pruned deps are not persisted in this pass since they're based on + -- the optional stanzas and we'll make further tweaks to the optional + -- stanzas in the next pass. + -- + pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId] + pruneOptionalDependencies elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent _ } + = InstallPlan.depends elab -- no pruning + pruneOptionalDependencies ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } + = (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg) + where + keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas + keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas + keepNeeded _ _ = True + stanzas = pkgStanzasEnabled pkg + + optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage + -> Set OptionalStanza + optionalStanzasRequiredByTargets pkg = + Set.fromList + [ stanza + | ComponentTarget cname _ <- elabBuildTargets pkg + ++ elabTestTargets pkg + ++ elabBenchTargets pkg + ++ maybeToList (elabReplTarget pkg) + , stanza <- maybeToList (componentOptionalStanza cname) + ] + + optionalStanzasRequestedByDefault :: ElaboratedConfiguredPackage + -> Set OptionalStanza + optionalStanzasRequestedByDefault = + Map.keysSet + . Map.filter (id :: Bool -> Bool) + . elabStanzasRequested + + availablePkgs = + Set.fromList + [ installedUnitId pkg + | InstallPlan.PreExisting pkg <- pkgs ] + +-- | Given a set of already installed packages @availablePkgs@, +-- determine the set of available optional stanzas from @pkg@ +-- which have all of their dependencies already installed. This is used +-- to implement "sticky" testsuites, where once we have installed +-- all of the deps needed for the test suite, we go ahead and +-- enable it always. +optionalStanzasWithDepsAvailable :: Set UnitId + -> ElaboratedConfiguredPackage + -> ElaboratedPackage + -> Set OptionalStanza +optionalStanzasWithDepsAvailable availablePkgs elab pkg = + Set.fromList + [ stanza + | stanza <- Set.toList (elabStanzasAvailable elab) + , let deps :: [UnitId] + deps = CD.select (optionalStanzaDeps stanza) + -- TODO: probably need to select other + -- dep types too eventually + (pkgOrderDependencies pkg) + , all (`Set.member` availablePkgs) deps + ] + where + optionalStanzaDeps TestStanzas (CD.ComponentTest _) = True + optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True + optionalStanzaDeps _ _ = False + + +-- The second pass does three things: +-- +-- * A second go at deciding which optional stanzas to enable. +-- * Prune the dependencies based on the final choice of optional stanzas. +-- * Extend the targets within each package to build, now we know the reverse +-- dependencies, ie we know which libs are needed as deps by other packages. +-- +-- Achieving sticky behaviour with enabling\/disabling optional stanzas is +-- tricky. The first approximation was handled by the first pass above, but +-- it's not quite enough. That pass will enable stanzas if all of the deps +-- of the optional stanza are already installed /in the store/. That's important +-- but it does not account for dependencies that get built inplace as part of +-- the project. We cannot take those inplace build deps into account in the +-- pruning pass however because we don't yet know which ones we're going to +-- build. Once we do know, we can have another go and enable stanzas that have +-- all their deps available. Now we can consider all packages in the pruned +-- plan to be available, including ones we already decided to build from +-- source. +-- +-- Deciding which targets to build depends on knowing which packages have +-- reverse dependencies (ie are needed). This requires the result of first +-- pass, which is another reason we have to split it into two passes. +-- +-- Note that just because we might enable testsuites or benchmarks (in the +-- first or second pass) doesn't mean that we build all (or even any) of them. +-- That depends on which targets we picked in the first pass. +-- +pruneInstallPlanPass2 :: [ElaboratedPlanPackage] + -> [ElaboratedPlanPackage] +pruneInstallPlanPass2 pkgs = + map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs + where + setStanzasDepsAndTargets elab = + elab { + elabBuildTargets = ordNub + $ elabBuildTargets elab + ++ libTargetsRequiredForRevDeps + ++ exeTargetsRequiredForRevDeps, + elabPkgOrComp = + case elabPkgOrComp elab of + ElabPackage pkg -> + let stanzas = pkgStanzasEnabled pkg + <> optionalStanzasWithDepsAvailable availablePkgs elab pkg + keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas + keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas + keepNeeded _ _ = True + in ElabPackage $ pkg { + pkgStanzasEnabled = stanzas, + pkgLibDependencies = CD.filterDeps keepNeeded (pkgLibDependencies pkg), + pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg), + pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg) + } + r@(ElabComponent _) -> r + } + where + libTargetsRequiredForRevDeps = + [ ComponentTarget Cabal.defaultLibName WholeComponent + | installedUnitId elab `Set.member` hasReverseLibDeps + ] + exeTargetsRequiredForRevDeps = + -- TODO: allow requesting executable with different name + -- than package name + [ ComponentTarget (Cabal.CExeName + $ packageNameToUnqualComponentName + $ packageName $ elabPkgSourceId elab) + WholeComponent + | installedUnitId elab `Set.member` hasReverseExeDeps + ] + + + availablePkgs :: Set UnitId + availablePkgs = Set.fromList (map installedUnitId pkgs) + + hasReverseLibDeps :: Set UnitId + hasReverseLibDeps = + Set.fromList [ depid + | InstallPlan.Configured pkg <- pkgs + , depid <- elabOrderLibDependencies pkg ] + + hasReverseExeDeps :: Set UnitId + hasReverseExeDeps = + Set.fromList [ depid + | InstallPlan.Configured pkg <- pkgs + , depid <- elabOrderExeDependencies pkg ] + +mapConfiguredPackage :: (srcpkg -> srcpkg') + -> InstallPlan.GenericPlanPackage ipkg srcpkg + -> InstallPlan.GenericPlanPackage ipkg srcpkg' +mapConfiguredPackage f (InstallPlan.Configured pkg) = + InstallPlan.Configured (f pkg) +mapConfiguredPackage f (InstallPlan.Installed pkg) = + InstallPlan.Installed (f pkg) +mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = + InstallPlan.PreExisting pkg + +componentOptionalStanza :: Cabal.ComponentName -> Maybe OptionalStanza +componentOptionalStanza (Cabal.CTestName _) = Just TestStanzas +componentOptionalStanza (Cabal.CBenchName _) = Just BenchStanzas +componentOptionalStanza _ = Nothing + +------------------------------------ +-- Support for --only-dependencies +-- + +-- | Try to remove the given targets from the install plan. +-- +-- This is not always possible. +-- +pruneInstallPlanToDependencies :: Set UnitId + -> ElaboratedInstallPlan + -> Either CannotPruneDependencies + ElaboratedInstallPlan +pruneInstallPlanToDependencies pkgTargets installPlan = + assert (all (isJust . InstallPlan.lookup installPlan) + (Set.toList pkgTargets)) $ + + fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) + . checkBrokenDeps + . Graph.fromDistinctList + . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) + . InstallPlan.toList + $ installPlan + where + -- Our strategy is to remove the packages we don't want and then check + -- if the remaining graph is broken or not, ie any packages with dangling + -- dependencies. If there are then we cannot prune the given targets. + checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage + -> Either CannotPruneDependencies + (Graph.Graph ElaboratedPlanPackage) + checkBrokenDeps graph = + case Graph.broken graph of + [] -> Right graph + brokenPackages -> + Left $ CannotPruneDependencies + [ (pkg, missingDeps) + | (pkg, missingDepIds) <- brokenPackages + , let missingDeps = mapMaybe lookupDep missingDepIds + ] + where + -- lookup in the original unpruned graph + lookupDep = InstallPlan.lookup installPlan + +-- | It is not always possible to prune to only the dependencies of a set of +-- targets. It may be the case that removing a package leaves something else +-- that still needed the pruned package. +-- +-- This lists all the packages that would be broken, and their dependencies +-- that would be missing if we did prune. +-- +newtype CannotPruneDependencies = + CannotPruneDependencies [(ElaboratedPlanPackage, + [ElaboratedPlanPackage])] + deriving (Show) + + +--------------------------- +-- Setup.hs script policy +-- + +-- Handling for Setup.hs scripts is a bit tricky, part of it lives in the +-- solver phase, and part in the elaboration phase. We keep the helper +-- functions for both phases together here so at least you can see all of it +-- in one place. +-- +-- There are four major cases for Setup.hs handling: +-- +-- 1. @build-type@ Custom with a @custom-setup@ section +-- 2. @build-type@ Custom without a @custom-setup@ section +-- 3. @build-type@ not Custom with @cabal-version > $our-cabal-version@ +-- 4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@ +-- +-- It's also worth noting that packages specifying @cabal-version: >= 1.23@ +-- or later that have @build-type@ Custom will always have a @custom-setup@ +-- section. Therefore in case 2, the specified @cabal-version@ will always be +-- less than 1.23. +-- +-- In cases 1 and 2 we obviously have to build an external Setup.hs script, +-- while in case 4 we can use the internal library API. In case 3 we also have +-- to build an external Setup.hs script because the package needs a later +-- Cabal lib version than we can support internally. +-- +-- data SetupScriptStyle = ... -- see ProjectPlanning.Types + +-- | Work out the 'SetupScriptStyle' given the package description. +-- +packageSetupScriptStyle :: PD.PackageDescription -> SetupScriptStyle +packageSetupScriptStyle pkg + | buildType == PD.Custom + , Just setupbi <- PD.setupBuildInfo pkg -- does have a custom-setup stanza + , not (PD.defaultSetupDepends setupbi) -- but not one we added internally + = SetupCustomExplicitDeps + + | buildType == PD.Custom + , Just setupbi <- PD.setupBuildInfo pkg -- we get this case post-solver as + , PD.defaultSetupDepends setupbi -- the solver fills in the deps + = SetupCustomImplicitDeps + + | buildType == PD.Custom + , Nothing <- PD.setupBuildInfo pkg -- we get this case pre-solver + = SetupCustomImplicitDeps + + | PD.specVersion pkg > cabalVersion -- one cabal-install is built against + = SetupNonCustomExternalLib + + | otherwise + = SetupNonCustomInternalLib + where + buildType = fromMaybe PD.Custom (PD.buildType pkg) + + +-- | Part of our Setup.hs handling policy is implemented by getting the solver +-- to work out setup dependencies for packages. The solver already handles +-- packages that explicitly specify setup dependencies, but we can also tell +-- the solver to treat other packages as if they had setup dependencies. +-- That's what this function does, it gets called by the solver for all +-- packages that don't already have setup dependencies. +-- +-- The dependencies we want to add is different for each 'SetupScriptStyle'. +-- +-- Note that adding default deps means these deps are actually /added/ to the +-- packages that we get out of the solver in the 'SolverInstallPlan'. Making +-- implicit setup deps explicit is a problem in the post-solver stages because +-- we still need to distinguish the case of explicit and implict setup deps. +-- See 'rememberImplicitSetupDeps'. +-- +-- Note in addition to adding default setup deps, we also use +-- 'addSetupCabalMinVersionConstraint' (in 'planPackages') to require +-- @Cabal >= 1.20@ for Setup scripts. +-- +defaultSetupDeps :: Compiler -> Platform + -> PD.PackageDescription + -> Maybe [Dependency] +defaultSetupDeps compiler platform pkg = + case packageSetupScriptStyle pkg of + + -- For packages with build type custom that do not specify explicit + -- setup dependencies, we add a dependency on Cabal and a number + -- of other packages. + SetupCustomImplicitDeps -> + Just $ + [ Dependency depPkgname anyVersion + | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++ + [ Dependency cabalPkgname cabalConstraint + | packageName pkg /= cabalPkgname ] + where + -- The Cabal dep is slightly special: + -- * We omit the dep for the Cabal lib itself, since it bootstraps. + -- * We constrain it to be < 1.25 + -- + -- Note: we also add a global constraint to require Cabal >= 1.20 + -- for Setup scripts (see use addSetupCabalMinVersionConstraint). + -- + cabalConstraint = orLaterVersion (PD.specVersion pkg) + `intersectVersionRanges` + earlierVersion cabalCompatMaxVer + -- The idea here is that at some point we will make significant + -- breaking changes to the Cabal API that Setup.hs scripts use. + -- So for old custom Setup scripts that do not specify explicit + -- constraints, we constrain them to use a compatible Cabal version. + cabalCompatMaxVer = mkVersion [1,25] + + -- For other build types (like Simple) if we still need to compile an + -- external Setup.hs, it'll be one of the simple ones that only depends + -- on Cabal and base. + SetupNonCustomExternalLib -> + Just [ Dependency cabalPkgname cabalConstraint + , Dependency basePkgname anyVersion ] + where + cabalConstraint = orLaterVersion (PD.specVersion pkg) + + -- The internal setup wrapper method has no deps at all. + SetupNonCustomInternalLib -> Just [] + + -- This case gets ruled out by the caller, planPackages, see the note + -- above in the SetupCustomImplicitDeps case. + SetupCustomExplicitDeps -> + error $ "defaultSetupDeps: called for a package with explicit " + ++ "setup deps: " ++ display (packageId pkg) + + +-- | Work out which version of the Cabal spec we will be using to talk to the +-- Setup.hs interface for this package. +-- +-- This depends somewhat on the 'SetupScriptStyle' but most cases are a result +-- of what the solver picked for us, based on the explicit setup deps or the +-- ones added implicitly by 'defaultSetupDeps'. +-- +packageSetupScriptSpecVersion :: Package pkg + => SetupScriptStyle + -> PD.PackageDescription + -> ComponentDeps [pkg] + -> Version + +-- We're going to be using the internal Cabal library, so the spec version of +-- that is simply the version of the Cabal library that cabal-install has been +-- built with. +packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ = + cabalVersion + +-- If we happen to be building the Cabal lib itself then because that +-- bootstraps itself then we use the version of the lib we're building. +packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ + | packageName pkg == cabalPkgname + = packageVersion pkg + +-- In all other cases we have a look at what version of the Cabal lib the +-- solver picked. Or if it didn't depend on Cabal at all (which is very rare) +-- then we look at the .cabal file to see what spec version it declares. +packageSetupScriptSpecVersion _ pkg deps = + case find ((cabalPkgname ==) . packageName) (CD.setupDeps deps) of + Just dep -> packageVersion dep + Nothing -> PD.specVersion pkg + + +cabalPkgname, basePkgname :: PackageName +cabalPkgname = mkPackageName "Cabal" +basePkgname = mkPackageName "base" + + +legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName] +legacyCustomSetupPkgs compiler (Platform _ os) = + map mkPackageName $ + [ "array", "base", "binary", "bytestring", "containers" + , "deepseq", "directory", "filepath", "old-time", "pretty" + , "process", "time", "transformers" ] + ++ [ "Win32" | os == Windows ] + ++ [ "unix" | os /= Windows ] + ++ [ "ghc-prim" | isGHC ] + ++ [ "template-haskell" | isGHC ] + where + isGHC = compilerCompatFlavor GHC compiler + +-- The other aspects of our Setup.hs policy lives here where we decide on +-- the 'SetupScriptOptions'. +-- +-- Our current policy for the 'SetupCustomImplicitDeps' case is that we +-- try to make the implicit deps cover everything, and we don't allow the +-- compiler to pick up other deps. This may or may not be sustainable, and +-- we might have to allow the deps to be non-exclusive, but that itself would +-- be tricky since we would have to allow the Setup access to all the packages +-- in the store and local dbs. + +setupHsScriptOptions :: ElaboratedReadyPackage + -> ElaboratedSharedConfig + -> FilePath + -> FilePath + -> Bool + -> Lock + -> SetupScriptOptions +-- TODO: Fix this so custom is a separate component. Custom can ALWAYS +-- be a separate component!!! +setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) + ElaboratedSharedConfig{..} srcdir builddir + isParallelBuild cacheLock = + SetupScriptOptions { + useCabalVersion = thisVersion elabSetupScriptCliVersion, + useCabalSpecVersion = Just elabSetupScriptCliVersion, + useCompiler = Just pkgConfigCompiler, + usePlatform = Just pkgConfigPlatform, + usePackageDB = elabSetupPackageDBStack, + usePackageIndex = Nothing, + useDependencies = [ (uid, srcid) + | ConfiguredId srcid (Just CLibName) uid + <- elabSetupDependencies elab ], + useDependenciesExclusive = True, + useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps, + useProgramDb = pkgConfigCompilerProgs, + useDistPref = builddir, + useLoggingHandle = Nothing, -- this gets set later + useWorkingDir = Just srcdir, + useExtraPathEnv = elabExeDependencyPaths elab, + useWin32CleanHack = False, --TODO: [required eventually] + forceExternalSetupMethod = isParallelBuild, + setupCacheLock = Just cacheLock, + isInteractive = False + } + + +-- | To be used for the input for elaborateInstallPlan. +-- +-- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure. +-- +userInstallDirTemplates :: Compiler + -> IO InstallDirs.InstallDirTemplates +userInstallDirTemplates compiler = do + InstallDirs.defaultInstallDirs + (compilerFlavor compiler) + True -- user install + False -- unused + +storePackageInstallDirs :: StoreDirLayout + -> CompilerId + -> InstalledPackageId + -> InstallDirs.InstallDirs FilePath +storePackageInstallDirs StoreDirLayout{ storePackageDirectory + , storeDirectory } + compid ipkgid = + InstallDirs.InstallDirs {..} + where + store = storeDirectory compid + prefix = storePackageDirectory compid (newSimpleUnitId ipkgid) + bindir = prefix "bin" + libdir = prefix "lib" + libsubdir = "" + -- Note: on macOS, we place libraries into + -- @store/lib@ to work around the load + -- command size limit of macOSs mach-o linker. + -- See also @PackageHash.hashedInstalledPackageIdVeryShort@ + dynlibdir | buildOS == OSX = store "lib" + | otherwise = libdir + flibdir = libdir + libexecdir = prefix "libexec" + libexecsubdir= "" + includedir = libdir "include" + datadir = prefix "share" + datasubdir = "" + docdir = datadir "doc" + mandir = datadir "man" + htmldir = docdir "html" + haddockdir = htmldir + sysconfdir = prefix "etc" + + +--TODO: [code cleanup] perhaps reorder this code +-- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, +-- make the various Setup.hs {configure,build,copy} flags + + +setupHsConfigureFlags :: ElaboratedReadyPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.ConfigFlags +setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) + sharedConfig@ElaboratedSharedConfig{..} + verbosity builddir = + sanityCheckElaboratedConfiguredPackage sharedConfig elab + (Cabal.ConfigFlags {..}) + where + configArgs = mempty -- unused, passed via args + configDistPref = toFlag builddir + configCabalFilePath = mempty + configVerbosity = toFlag verbosity + + configInstantiateWith = Map.toList elabInstantiatedWith + + configDeterministic = mempty -- doesn't matter, configIPID/configCID overridese + configIPID = case elabPkgOrComp of + ElabPackage pkg -> toFlag (display (pkgInstalledId pkg)) + ElabComponent _ -> mempty + configCID = case elabPkgOrComp of + ElabPackage _ -> mempty + ElabComponent _ -> toFlag elabComponentId + + configProgramPaths = Map.toList elabProgramPaths + configProgramArgs + | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True + -- workaround for + -- + -- It turns out, that even with Cabal 2.0, there's still cases such as e.g. + -- custom Setup.hs scripts calling out to GHC even when going via + -- @runProgram ghcProgram@, as e.g. happy does in its + -- + -- (see also ) + -- + -- So for now, let's pass the rather harmless and idempotent + -- `-hide-all-packages` flag to all invocations (which has + -- the benefit that every GHC invocation starts with a + -- conistently well-defined clean slate) until we find a + -- better way. + = Map.toList $ + Map.insertWith (++) "ghc" ["-hide-all-packages"] + elabProgramArgs + | otherwise = Map.toList elabProgramArgs + configProgramPathExtra = toNubList elabProgramPathExtra + configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) + configHcPath = mempty -- we use configProgramPaths instead + configHcPkg = mempty -- we use configProgramPaths instead + + configVanillaLib = toFlag elabVanillaLib + configSharedLib = toFlag elabSharedLib + configStaticLib = toFlag elabStaticLib + + configDynExe = toFlag elabDynExe + configGHCiLib = toFlag elabGHCiLib + configProfExe = mempty + configProfLib = toFlag elabProfLib + configProf = toFlag elabProfExe + + -- configProfDetail is for exe+lib, but overridden by configProfLibDetail + -- so we specify both so we can specify independently + configProfDetail = toFlag elabProfExeDetail + configProfLibDetail = toFlag elabProfLibDetail + + configCoverage = toFlag elabCoverage + configLibCoverage = mempty + + configOptimization = toFlag elabOptimization + configSplitSections = toFlag elabSplitSections + configSplitObjs = toFlag elabSplitObjs + configStripExes = toFlag elabStripExes + configStripLibs = toFlag elabStripLibs + configDebugInfo = toFlag elabDebugInfo + + configConfigurationsFlags = elabFlagAssignment + configConfigureArgs = elabConfigureScriptArgs + configExtraLibDirs = elabExtraLibDirs + configExtraFrameworkDirs = elabExtraFrameworkDirs + configExtraIncludeDirs = elabExtraIncludeDirs + configProgPrefix = maybe mempty toFlag elabProgPrefix + configProgSuffix = maybe mempty toFlag elabProgSuffix + + configInstallDirs = fmap (toFlag . InstallDirs.toPathTemplate) + elabInstallDirs + + -- we only use configDependencies, unless we're talking to an old Cabal + -- in which case we use configConstraints + -- NB: This does NOT use InstallPlan.depends, which includes executable + -- dependencies which should NOT be fed in here (also you don't have + -- enough info anyway) + configDependencies = [ (case mb_cn of + -- Special case for internal libraries + Just (CSubLibName uqn) + | packageId elab == srcid + -> mkPackageName (unUnqualComponentName uqn) + _ -> packageName srcid, + cid) + | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab ] + configConstraints = + case elabPkgOrComp of + ElabPackage _ -> + [ thisPackageVersion srcid + | ConfiguredId srcid _ _uid <- elabLibDependencies elab ] + ElabComponent _ -> [] + + + -- explicitly clear, then our package db stack + -- TODO: [required eventually] have to do this differently for older Cabal versions + configPackageDBs = Nothing : map Just elabBuildPackageDBStack + + configTests = case elabPkgOrComp of + ElabPackage pkg -> toFlag (TestStanzas `Set.member` pkgStanzasEnabled pkg) + ElabComponent _ -> mempty + configBenchmarks = case elabPkgOrComp of + ElabPackage pkg -> toFlag (BenchStanzas `Set.member` pkgStanzasEnabled pkg) + ElabComponent _ -> mempty + + configExactConfiguration = toFlag True + configFlagError = mempty --TODO: [research required] appears not to be implemented + configRelocatable = mempty --TODO: [research required] ??? + configScratchDir = mempty -- never use + configUserInstall = mempty -- don't rely on defaults + configPrograms_ = mempty -- never use, shouldn't exist + configUseResponseFiles = mempty + +setupHsConfigureArgs :: ElaboratedConfiguredPackage + -> [String] +setupHsConfigureArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) = [] +setupHsConfigureArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) = + [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)] + where + cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup") + (compComponentName comp) + +setupHsBuildFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.BuildFlags +setupHsBuildFlags _ _ verbosity builddir = + Cabal.BuildFlags { + buildProgramPaths = mempty, --unused, set at configure time + buildProgramArgs = mempty, --unused, set at configure time + buildVerbosity = toFlag verbosity, + buildDistPref = toFlag builddir, + buildNumJobs = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs), + buildArgs = mempty -- unused, passed via args not flags + } + + +setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String] +setupHsBuildArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) + -- Fix for #3335, don't pass build arguments if it's not supported + | elabSetupScriptCliVersion elab >= mkVersion [1,17] + = map (showComponentTarget (packageId elab)) (elabBuildTargets elab) + | otherwise + = [] +setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _ }) + = [] + + +setupHsTestFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.TestFlags +setupHsTestFlags _ _ verbosity builddir = Cabal.TestFlags + { testDistPref = toFlag builddir + , testVerbosity = toFlag verbosity + , testMachineLog = mempty + , testHumanLog = mempty + , testShowDetails = toFlag Cabal.Always + , testKeepTix = mempty + , testOptions = mempty + } + +setupHsTestArgs :: ElaboratedConfiguredPackage -> [String] +-- TODO: Does the issue #3335 affects test as well +setupHsTestArgs elab = + mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab) + + +setupHsBenchFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.BenchmarkFlags +setupHsBenchFlags _ _ verbosity builddir = Cabal.BenchmarkFlags + { benchmarkDistPref = toFlag builddir + , benchmarkVerbosity = toFlag verbosity + , benchmarkOptions = mempty + } + +setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String] +setupHsBenchArgs elab = + mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab) + + +setupHsReplFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.ReplFlags +setupHsReplFlags _ _ verbosity builddir = + Cabal.ReplFlags { + replProgramPaths = mempty, --unused, set at configure time + replProgramArgs = mempty, --unused, set at configure time + replVerbosity = toFlag verbosity, + replDistPref = toFlag builddir, + replReload = mempty --only used as callback from repl + } + + +setupHsReplArgs :: ElaboratedConfiguredPackage -> [String] +setupHsReplArgs elab = + maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab) + --TODO: should be able to give multiple modules in one component + + +setupHsCopyFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> FilePath + -> Cabal.CopyFlags +setupHsCopyFlags _ _ verbosity builddir destdir = + Cabal.CopyFlags { + copyArgs = [], -- TODO: could use this to only copy what we enabled + copyDest = toFlag (InstallDirs.CopyTo destdir), + copyDistPref = toFlag builddir, + copyVerbosity = toFlag verbosity + } + +setupHsRegisterFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> FilePath + -> Cabal.RegisterFlags +setupHsRegisterFlags ElaboratedConfiguredPackage{..} _ + verbosity builddir pkgConfFile = + Cabal.RegisterFlags { + regPackageDB = mempty, -- misfeature + regGenScript = mempty, -- never use + regGenPkgConf = toFlag (Just pkgConfFile), + regInPlace = case elabBuildStyle of + BuildInplaceOnly -> toFlag True + _ -> toFlag False, + regPrintId = mempty, -- never use + regDistPref = toFlag builddir, + regArgs = [], + regVerbosity = toFlag verbosity + } + +setupHsHaddockFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.HaddockFlags +-- TODO: reconsider whether or not Executables/TestSuites/... +-- needed for component +setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = + Cabal.HaddockFlags { + haddockProgramPaths = mempty, --unused, set at configure time + haddockProgramArgs = mempty, --unused, set at configure time + haddockHoogle = toFlag elabHaddockHoogle, + haddockHtml = toFlag elabHaddockHtml, + haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation, + haddockForHackage = toFlag elabHaddockForHackage, + haddockForeignLibs = toFlag elabHaddockForeignLibs, + haddockExecutables = toFlag elabHaddockExecutables, + haddockTestSuites = toFlag elabHaddockTestSuites, + haddockBenchmarks = toFlag elabHaddockBenchmarks, + haddockInternal = toFlag elabHaddockInternal, + haddockCss = maybe mempty toFlag elabHaddockCss, + haddockHscolour = toFlag elabHaddockHscolour, + haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss, + haddockContents = maybe mempty toFlag elabHaddockContents, + haddockDistPref = toFlag builddir, + haddockKeepTempFiles = mempty, --TODO: from build settings + haddockVerbosity = toFlag verbosity + } + +{- +setupHsTestFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.TestFlags +setupHsTestFlags _ _ verbosity builddir = + Cabal.TestFlags { + } +-} + +------------------------------------------------------------------------------ +-- * Sharing installed packages +------------------------------------------------------------------------------ + +-- +-- Nix style store management for tarball packages +-- +-- So here's our strategy: +-- +-- We use a per-user nix-style hashed store, but /only/ for tarball packages. +-- So that includes packages from hackage repos (and other http and local +-- tarballs). For packages in local directories we do not register them into +-- the shared store by default, we just build them locally inplace. +-- +-- The reason we do it like this is that it's easy to make stable hashes for +-- tarball packages, and these packages benefit most from sharing. By contrast +-- unpacked dir packages are harder to hash and they tend to change more +-- frequently so there's less benefit to sharing them. +-- +-- When using the nix store approach we have to run the solver *without* +-- looking at the packages installed in the store, just at the source packages +-- (plus core\/global installed packages). Then we do a post-processing pass +-- to replace configured packages in the plan with pre-existing ones, where +-- possible. Where possible of course means where the nix-style package hash +-- equals one that's already in the store. +-- +-- One extra wrinkle is that unless we know package tarball hashes upfront, we +-- will have to download the tarballs to find their hashes. So we have two +-- options: delay replacing source with pre-existing installed packages until +-- the point during the execution of the install plan where we have the +-- tarball, or try to do as much up-front as possible and then check again +-- during plan execution. The former isn't great because we would end up +-- telling users we're going to re-install loads of packages when in fact we +-- would just share them. It'd be better to give as accurate a prediction as +-- we can. The latter is better for users, but we do still have to check +-- during plan execution because it's important that we don't replace existing +-- installed packages even if they have the same package hash, because we +-- don't guarantee ABI stability. + +-- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but +-- not replace installed packages with ghc-pkg. + +packageHashInputs :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> PackageHashInputs +packageHashInputs + pkgshared + elab@(ElaboratedConfiguredPackage { + elabPkgSourceHash = Just srchash + }) = + PackageHashInputs { + pkgHashPkgId = packageId elab, + pkgHashComponent = + case elabPkgOrComp elab of + ElabPackage _ -> Nothing + ElabComponent comp -> Just (compSolverName comp), + pkgHashSourceHash = srchash, + pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab), + pkgHashDirectDeps = + case elabPkgOrComp elab of + ElabPackage (ElaboratedPackage{..}) -> + Set.fromList $ + [ confInstId dep + | dep <- CD.select relevantDeps pkgLibDependencies ] ++ + [ confInstId dep + | dep <- CD.select relevantDeps pkgExeDependencies ] + ElabComponent comp -> + Set.fromList (map confInstId (compLibDependencies comp + ++ compExeDependencies comp)), + pkgHashOtherConfig = packageHashConfigInputs pkgshared elab + } + where + -- Obviously the main deps are relevant + relevantDeps CD.ComponentLib = True + relevantDeps (CD.ComponentSubLib _) = True + relevantDeps (CD.ComponentFLib _) = True + relevantDeps (CD.ComponentExe _) = True + -- Setup deps can affect the Setup.hs behaviour and thus what is built + relevantDeps CD.ComponentSetup = True + -- However testsuites and benchmarks do not get installed and should not + -- affect the result, so we do not include them. + relevantDeps (CD.ComponentTest _) = False + relevantDeps (CD.ComponentBench _) = False + +packageHashInputs _ pkg = + error $ "packageHashInputs: only for packages with source hashes. " + ++ display (packageId pkg) + +packageHashConfigInputs :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> PackageHashConfigInputs +packageHashConfigInputs + ElaboratedSharedConfig{..} + ElaboratedConfiguredPackage{..} = + + PackageHashConfigInputs { + pkgHashCompilerId = compilerId pkgConfigCompiler, + pkgHashPlatform = pkgConfigPlatform, + pkgHashFlagAssignment = elabFlagAssignment, + pkgHashConfigureScriptArgs = elabConfigureScriptArgs, + pkgHashVanillaLib = elabVanillaLib, + pkgHashSharedLib = elabSharedLib, + pkgHashDynExe = elabDynExe, + pkgHashGHCiLib = elabGHCiLib, + pkgHashProfLib = elabProfLib, + pkgHashProfExe = elabProfExe, + pkgHashProfLibDetail = elabProfLibDetail, + pkgHashProfExeDetail = elabProfExeDetail, + pkgHashCoverage = elabCoverage, + pkgHashOptimization = elabOptimization, + pkgHashSplitSections = elabSplitSections, + pkgHashSplitObjs = elabSplitObjs, + pkgHashStripLibs = elabStripLibs, + pkgHashStripExes = elabStripExes, + pkgHashDebugInfo = elabDebugInfo, + pkgHashProgramArgs = elabProgramArgs, + pkgHashExtraLibDirs = elabExtraLibDirs, + pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs, + pkgHashExtraIncludeDirs = elabExtraIncludeDirs, + pkgHashProgPrefix = elabProgPrefix, + pkgHashProgSuffix = elabProgSuffix + } + + +-- | Given the 'InstalledPackageIndex' for a nix-style package store, and an +-- 'ElaboratedInstallPlan', replace configured source packages by installed +-- packages from the store whenever they exist. +-- +improveInstallPlanWithInstalledPackages :: Set UnitId + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan +improveInstallPlanWithInstalledPackages installedPkgIdSet = + InstallPlan.installed canPackageBeImproved + where + canPackageBeImproved pkg = + installedUnitId pkg `Set.member` installedPkgIdSet + --TODO: sanity checks: + -- * the installed package must have the expected deps etc + -- * the installed package must not be broken, valid dep closure + + --TODO: decide what to do if we encounter broken installed packages, + -- since overwriting is never safe. + + +-- Path construction +------ + +-- | The path to the directory that contains a specific executable. +-- NB: For inplace NOT InstallPaths.bindir installDirs; for an +-- inplace build those values are utter nonsense. So we +-- have to guess where the directory is going to be. +-- Fortunately this is "stable" part of Cabal API. +-- But the way we get the build directory is A HORRIBLE +-- HACK. +binDirectoryFor + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> FilePath + -> FilePath +binDirectoryFor layout config package exe = case elabBuildStyle package of + BuildAndInstall -> installedBinDirectory package + BuildInplaceOnly -> inplaceBinRoot layout config package exe + +-- package has been built and installed. +installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath +installedBinDirectory = InstallDirs.bindir . elabInstallDirs + +-- | The path to the @build@ directory for an inplace build. +inplaceBinRoot + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> FilePath +inplaceBinRoot layout config package + = distBuildDirectory layout (elabDistDirParams config package) + "build" 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 @@ -21,9 +21,12 @@ elabOrderExeDependencies, elabSetupDependencies, elabPkgConfigDependencies, + elabInplaceDependencyBuildCacheFiles, + elabRequiresRegistration, elabPlanPackageName, elabConfiguredName, + elabComponentName, ElaboratedPackageOrComponent(..), ElaboratedComponent(..), @@ -36,18 +39,24 @@ CabalFileText, -- * Build targets - PackageTarget(..), ComponentTarget(..), showComponentTarget, + showTestComponentTarget, + showBenchComponentTarget, SubComponentTarget(..), + isTestComponentTarget, + -- * Setup script SetupScriptStyle(..), ) where +import Distribution.Client.TargetSelector + ( SubComponentTarget(..) ) import Distribution.Client.PackageHash import Distribution.Client.Types +import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan ( GenericInstallPlan, GenericPlanPackage(..) ) import Distribution.Client.SolverInstallPlan @@ -72,6 +81,7 @@ import Distribution.Simple.LocalBuildInfo (ComponentName(..)) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.InstallDirs (PathTemplate) +import Distribution.Simple.Setup (HaddockTarget) import Distribution.Version import qualified Distribution.Solver.Types.ComponentDeps as CD @@ -87,6 +97,7 @@ import GHC.Generics (Generic) import qualified Data.Monoid as Mon import Data.Typeable +import Control.Monad @@ -142,13 +153,17 @@ elabInstantiatedWith :: Map ModuleName Module, elabLinkedInstantiatedWith :: Map ModuleName OpenModule, + -- | This is true if this is an indefinite package, or this is a + -- package with no signatures. (Notably, it's not true for instantiated + -- packages.) The motivation for this is if you ask to build + -- @foo-indef@, this probably means that you want to typecheck + -- it, NOT that you want to rebuild all of the various + -- instantiations of it. + elabIsCanonical :: Bool, + -- | The 'PackageId' of the originating package elabPkgSourceId :: PackageId, - -- | Mapping from 'PackageName's to 'ComponentName', for every - -- package that is overloaded with an internal component name - elabInternalPackages :: Map PackageName ComponentName, - -- | Shape of the package/component, for Backpack. elabModuleShape :: ModuleShape, @@ -211,14 +226,12 @@ elabBuildPackageDBStack :: PackageDBStack, elabRegisterPackageDBStack :: PackageDBStack, - -- | The package/component contains/is a library and so must be registered - elabRequiresRegistration :: Bool, - elabPkgDescriptionOverride :: Maybe CabalFileText, -- TODO: make per-component variants of these flags elabVanillaLib :: Bool, elabSharedLib :: Bool, + elabStaticLib :: Bool, elabDynExe :: Bool, elabGHCiLib :: Bool, elabProfLib :: Bool, @@ -228,6 +241,7 @@ elabCoverage :: Bool, elabOptimization :: OptimisationLevel, elabSplitObjs :: Bool, + elabSplitSections :: Bool, elabStripLibs :: Bool, elabStripExes :: Bool, elabDebugInfo :: DebugInfoLevel, @@ -248,6 +262,7 @@ elabHaddockHtml :: Bool, elabHaddockHtmlLocation :: Maybe String, elabHaddockForeignLibs :: Bool, + elabHaddockForHackage :: HaddockTarget, elabHaddockExecutables :: Bool, elabHaddockTestSuites :: Bool, elabHaddockBenchmarks :: Bool, @@ -271,6 +286,8 @@ -- Build time related: elabBuildTargets :: [ComponentTarget], + elabTestTargets :: [ComponentTarget], + elabBenchTargets :: [ComponentTarget], elabReplTarget :: Maybe ComponentTarget, elabBuildHaddocks :: Bool, @@ -282,11 +299,50 @@ } deriving (Eq, Show, Generic, Typeable) +-- | The package/component contains/is a library and so must be registered +elabRequiresRegistration :: ElaboratedConfiguredPackage -> Bool +elabRequiresRegistration elab = + case elabPkgOrComp elab of + ElabComponent comp -> + case compComponentName comp of + Just cn -> is_lib cn && build_target + _ -> False + ElabPackage pkg -> + -- Tricky! Not only do we have to test if the user selected + -- a library as a build target, we also have to test if + -- the library was TRANSITIVELY depended upon, since we will + -- also require a register in this case. + -- + -- NB: It would have been far nicer to just unconditionally + -- register in all cases, but some Custom Setups will fall + -- over if you try to do that, ESPECIALLY if there actually is + -- a library but they hadn't built it. + build_target || any (depends_on_lib pkg) (elabBuildTargets elab) + where + depends_on_lib pkg (ComponentTarget cn _) = + not (null (CD.select (== CD.componentNameToComponent cn) + (pkgDependsOnSelfLib pkg))) + build_target = + if not (null (elabBuildTargets elab)) + then any is_lib_target (elabBuildTargets elab) + -- Empty build targets mean we build /everything/; + -- that means we have to look more carefully to see + -- if there is anything to register + else Cabal.hasLibs (elabPkgDescription elab) + -- NB: this means we DO NOT reregister if you just built a + -- single file + is_lib_target (ComponentTarget cn WholeComponent) = is_lib cn + is_lib_target _ = False + is_lib CLibName = True + is_lib (CSubLibName _) = True + is_lib _ = False + instance Package ElaboratedConfiguredPackage where packageId = elabPkgSourceId instance HasConfiguredId ElaboratedConfiguredPackage where - configuredId elab = ConfiguredId (packageId elab) (elabComponentId elab) + configuredId elab = + ConfiguredId (packageId elab) (elabComponentName elab) (elabComponentId elab) instance HasUnitId ElaboratedConfiguredPackage where installedUnitId = elabUnitId @@ -305,6 +361,12 @@ instance Binary ElaboratedPackageOrComponent +elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName +elabComponentName elab = + case elabPkgOrComp elab of + ElabPackage _ -> Just CLibName -- there could be more, but default this + ElabComponent comp -> compComponentName comp + -- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'. elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String elabConfiguredName verbosity elab @@ -355,7 +417,8 @@ elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] elabOrderLibDependencies elab = case elabPkgOrComp elab of - ElabPackage _ -> map (newSimpleUnitId . confInstId) (elabLibDependencies elab) + ElabPackage pkg -> map (newSimpleUnitId . confInstId) $ + ordNub $ CD.flatDeps (pkgLibDependencies pkg) ElabComponent comp -> compOrderLibDependencies comp -- | The library dependencies (i.e., the libraries we depend on, NOT @@ -377,10 +440,9 @@ -- these are the executables we must add to the PATH before we invoke -- the setup script. elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId] -elabExeDependencies elab = +elabExeDependencies elab = map confInstId $ case elabPkgOrComp elab of - -- TODO: pkgExeDependencies being ConfiguredId is slightly awkward - ElabPackage pkg -> map confInstId (CD.nonSetupDeps (pkgExeDependencies pkg)) + ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) ElabComponent comp -> compExeDependencies comp -- | This returns the paths of all the executables we depend on; we @@ -390,8 +452,8 @@ elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath] elabExeDependencyPaths elab = case elabPkgOrComp elab of - ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencyPaths pkg) - ElabComponent comp -> compExeDependencyPaths comp + ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) + ElabComponent comp -> map snd (compExeDependencyPaths comp) -- | The setup dependencies (the library dependencies of the setup executable; -- note that it is not legal for setup scripts to have executable @@ -399,8 +461,10 @@ elabSetupDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] elabSetupDependencies elab = case elabPkgOrComp elab of - ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg) - ElabComponent comp -> compSetupDependencies comp + ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg) + -- TODO: Custom setups not supported for components yet. When + -- they are, need to do this differently + ElabComponent _ -> [] elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe Version)] elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } @@ -408,6 +472,39 @@ elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } = compPkgConfigDependencies comp +-- | The cache files of all our inplace dependencies which, +-- when updated, require us to rebuild. See #4202 for +-- more details. Essentially, this is a list of filepaths +-- that, if our dependencies get rebuilt, will themselves +-- get updated. +-- +-- Note: the hash of these cache files gets built into +-- the build cache ourselves, which means that we end +-- up tracking transitive dependencies! +-- +-- Note: This tracks the "build" cache file, but not +-- "registration" or "config" cache files. Why not? +-- Arguably we should... +-- +-- Note: This is a bit of a hack, because it is not really +-- the hashes of the SOURCES of our (transitive) dependencies +-- that we should use to decide whether or not to rebuild, +-- but the output BUILD PRODUCTS. The strategy we use +-- here will never work if we want to implement unchanging +-- rebuilds. +elabInplaceDependencyBuildCacheFiles + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedConfiguredPackage + -> [FilePath] +elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab = + go =<< InstallPlan.directDeps plan (nodeKey root_elab) + where + go = InstallPlan.foldPlanPackage (const []) $ \elab -> do + guard (elabBuildStyle elab == BuildInplaceOnly) + return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build" + -- | Some extra metadata associated with an -- 'ElaboratedConfiguredPackage' which indicates that the "package" -- in question is actually a single component to be built. Arguably @@ -425,24 +522,25 @@ -- | The *external* library dependencies of this component. We -- pass this to the configure script. compLibDependencies :: [ConfiguredId], - -- | The linked dependencies of the component which combined with the - -- substitution in 'elabComponentId' specify the dependencies we - -- care about from the perspective of ORDERING builds. It's more - -- precise than 'compLibDependencies', and also stores information - -- about internal dependencies. + -- | In a component prior to instantiation, this list specifies + -- the 'OpenUnitId's which, after instantiation, are the + -- actual dependencies of this package. Note that this does + -- NOT include signature packages, which do not turn into real + -- ordering dependencies when we instantiate. This is intended to be + -- a purely temporary field, to carry some information to the + -- instantiation phase. It's more precise than + -- 'compLibDependencies', and also stores information about internal + -- dependencies. compLinkedLibDependencies :: [OpenUnitId], -- | The executable dependencies of this component (including -- internal executables). - compExeDependencies :: [ComponentId], + compExeDependencies :: [ConfiguredId], -- | The @pkg-config@ dependencies of the component compPkgConfigDependencies :: [(PkgconfigName, Maybe Version)], -- | The paths all our executable dependencies will be installed -- to once they are installed. - compExeDependencyPaths :: [FilePath], - compNonSetupDependencies :: [UnitId], - -- | The setup dependencies. TODO: Remove this when setups - -- are components of their own. - compSetupDependencies :: [ConfiguredId] + compExeDependencyPaths :: [(ConfiguredId, FilePath)], + compOrderLibDependencies :: [UnitId] } deriving (Eq, Show, Generic) @@ -456,13 +554,7 @@ -- | See 'elabOrderExeDependencies'. compOrderExeDependencies :: ElaboratedComponent -> [UnitId] -compOrderExeDependencies = map newSimpleUnitId . compExeDependencies - --- | See 'elabOrderLibDependencies'. -compOrderLibDependencies :: ElaboratedComponent -> [UnitId] -compOrderLibDependencies comp = - compNonSetupDependencies comp - ++ map (newSimpleUnitId . confInstId) (compSetupDependencies comp) +compOrderExeDependencies = map (newSimpleUnitId . confInstId) . compExeDependencies data ElaboratedPackage = ElaboratedPackage { @@ -472,13 +564,20 @@ -- pkgLibDependencies :: ComponentDeps [ConfiguredId], + -- | Components which depend (transitively) on an internally + -- defined library. These are used by 'elabRequiresRegistration', + -- to determine if a user-requested build is going to need + -- a library registration + -- + pkgDependsOnSelfLib :: ComponentDeps [()], + -- | Dependencies on executable packages. -- pkgExeDependencies :: ComponentDeps [ConfiguredId], -- | Paths where executable dependencies live. -- - pkgExeDependencyPaths :: ComponentDeps [FilePath], + pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)], -- | Dependencies on @pkg-config@ packages. -- NB: this is NOT per-component (although it could be) @@ -535,32 +634,13 @@ -- Build targets -- --- | The various targets within a package. This is more of a high level --- specification than a elaborated prescription. +-- | Specific targets within a package or component to act on e.g. to build, +-- haddock or open a repl. -- -data PackageTarget = - -- | Build the default components in this package. This usually means - -- just the lib and exes, but it can also mean the testsuites and - -- benchmarks if the user explicitly requested them. - BuildDefaultComponents - -- | Build a specific component in this package. - | BuildSpecificComponent ComponentTarget - | ReplDefaultComponent - | ReplSpecificComponent ComponentTarget - | HaddockDefaultComponents - deriving (Eq, Show, Generic) - data ComponentTarget = ComponentTarget ComponentName SubComponentTarget deriving (Eq, Ord, Show, Generic) -data SubComponentTarget = WholeComponent - | ModuleTarget ModuleName - | FileTarget FilePath - deriving (Eq, Ord, Show, Generic) - -instance Binary PackageTarget instance Binary ComponentTarget -instance Binary SubComponentTarget -- | Unambiguously render a 'ComponentTarget', e.g., to pass -- to a Cabal Setup script. @@ -575,7 +655,17 @@ ModuleTarget mname -> Cabal.BuildTargetModule cname mname FileTarget fname -> Cabal.BuildTargetFile cname fname +showTestComponentTarget :: PackageId -> ComponentTarget -> Maybe String +showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ display n +showTestComponentTarget _ _ = Nothing +isTestComponentTarget :: ComponentTarget -> Bool +isTestComponentTarget (ComponentTarget (CTestName _) _) = True +isTestComponentTarget _ = False + +showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String +showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ display n +showBenchComponentTarget _ _ = Nothing --------------------------- -- Setup.hs script policy diff --git a/cabal/cabal-install/Distribution/Client/RebuildMonad.hs b/cabal/cabal-install/Distribution/Client/RebuildMonad.hs --- a/cabal/cabal-install/Distribution/Client/RebuildMonad.hs +++ b/cabal/cabal-install/Distribution/Client/RebuildMonad.hs @@ -112,7 +112,7 @@ -- -- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'. -- -rerunIfChanged :: (Binary a, Binary b, Typeable a, Typeable b) +rerunIfChanged :: (Binary a, Binary b) => Verbosity -> FileMonitor a b -> a @@ -160,8 +160,10 @@ getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath] getDirectoryContentsMonitored dir = do - monitorFiles [monitorDirectory dir] - liftIO $ getDirectoryContents dir + exists <- monitorDirectoryStatus dir + if exists + then liftIO $ getDirectoryContents dir + else return [] createDirectoryMonitored :: Bool -> FilePath -> Rebuild () createDirectoryMonitored createParents dir = do @@ -170,12 +172,13 @@ -- | Monitor a directory as in 'monitorDirectory' if it currently exists or -- as 'monitorNonExistentDirectory' if it does not. -monitorDirectoryStatus :: FilePath -> Rebuild () +monitorDirectoryStatus :: FilePath -> Rebuild Bool monitorDirectoryStatus dir = do exists <- liftIO $ doesDirectoryExist dir monitorFiles [if exists then monitorDirectory dir else monitorNonExistentDirectory dir] + return exists -- | Like 'doesFileExist', but in the 'Rebuild' monad. This does -- NOT track the contents of 'FilePath'; use 'need' in that case. diff --git a/cabal/cabal-install/Distribution/Client/Reconfigure.hs b/cabal/cabal-install/Distribution/Client/Reconfigure.hs --- a/cabal/cabal-install/Distribution/Client/Reconfigure.hs +++ b/cabal/cabal-install/Distribution/Client/Reconfigure.hs @@ -1,10 +1,9 @@ module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where -import Control.Monad ( unless, when ) -import Data.Monoid hiding ( (<>) ) -import System.Directory ( doesFileExist ) +import Distribution.Client.Compat.Prelude -import Distribution.Compat.Semigroup +import Data.Monoid ( Any(..) ) +import System.Directory ( doesFileExist ) import Distribution.Verbosity @@ -15,6 +14,7 @@ import Distribution.Client.Config ( SavedConfig(..) ) import Distribution.Client.Configure ( readConfigFlags ) +import Distribution.Client.Nix ( findNixExpr, inNixShell, nixInstantiate ) import Distribution.Client.Sandbox ( WereDepsReinstalled(..), findSavedDistPref, getSandboxConfigFilePath , maybeReinstallAddSourceDeps, updateInstallDirs ) @@ -29,9 +29,9 @@ -- | @Check@ represents a function to check some condition on type @a@. The -- returned 'Any' is 'True' if any part of the condition failed. newtype Check a = Check { - runCheck :: Any -- ^ Did any previous check fail? - -> a -- ^ value returned by previous checks - -> IO (Any, a) -- ^ Did this check fail? What value is returned? + runCheck :: Any -- Did any previous check fail? + -> a -- value returned by previous checks + -> IO (Any, a) -- Did this check fail? What value is returned? } instance Semigroup (Check a) where @@ -111,21 +111,42 @@ savedFlags@(_, _) <- readConfigFlags dist - let checks = - checkVerb - <> checkDist - <> checkOutdated - <> check - <> checkAddSourceDeps - (Any force, flags@(configFlags, _)) <- runCheck checks mempty savedFlags + useNix <- fmap isJust (findNixExpr globalFlags config) + alreadyInNixShell <- inNixShell - let (_, config') = - updateInstallDirs - (configUserInstall configFlags) - (useSandbox, config) + if useNix && not alreadyInNixShell + then do - when force $ configureAction flags extraArgs globalFlags - return config' + -- If we are using Nix, we must reinstantiate the derivation outside + -- the shell. Eventually, the caller will invoke 'nixShell' which will + -- rerun cabal inside the shell. That will bring us back to 'reconfigure', + -- but inside the shell we'll take the second branch, below. + + -- This seems to have a problem: won't 'configureAction' call 'nixShell' + -- yet again, spawning an infinite tree of subprocesses? + -- No, because 'nixShell' doesn't spawn a new process if it is already + -- running in a Nix shell. + + nixInstantiate verbosity dist False globalFlags config + return config + + else do + + let checks = + checkVerb + <> checkDist + <> checkOutdated + <> check + <> checkAddSourceDeps + (Any force, flags@(configFlags, _)) <- runCheck checks mempty savedFlags + + let (_, config') = + updateInstallDirs + (configUserInstall configFlags) + (useSandbox, config) + + when force $ configureAction flags extraArgs globalFlags + return config' where diff --git a/cabal/cabal-install/Distribution/Client/Run.hs b/cabal/cabal-install/Distribution/Client/Run.hs --- a/cabal/cabal-install/Distribution/Client/Run.hs +++ b/cabal/cabal-install/Distribution/Client/Run.hs @@ -18,9 +18,7 @@ import Distribution.Client.Utils (tryCanonicalizePath) -import Distribution.Package (UnqualComponentName, - mkUnqualComponentName, - unUnqualComponentName) +import Distribution.Types.UnqualComponentName import Distribution.PackageDescription (Executable (..), TestSuite(..), Benchmark(..), @@ -32,7 +30,7 @@ import Distribution.Simple.LocalBuildInfo (ComponentName (..), LocalBuildInfo (..), depLibraryPaths) -import Distribution.Simple.Utils (die, notice, warn, +import Distribution.Simple.Utils (die', notice, warn, rawSystemExitWithEnv, addLibraryPath) import Distribution.System (Platform (..)) @@ -54,7 +52,7 @@ case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest) Left err -> do warn verbosity `traverse_` maybeWarning -- If there is a warning, print it. - die err + die' verbosity err Right (True, exe, xs) -> return (exe, xs) Right (False, exe, xs) -> do let addition = " Interpreting all parameters to `run` as a parameter to" @@ -136,8 +134,8 @@ then do let (Platform _ os) = hostPlatform lbi clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of [target] -> return (targetCLBI target) - [] -> die "run: Could not find executable in LocalBuildInfo" - _ -> die "run: Found multiple matching exes in LocalBuildInfo" + [] -> die' verbosity "run: Could not find executable in LocalBuildInfo" + _ -> die' verbosity "run: Found multiple matching exes in LocalBuildInfo" paths <- depLibraryPaths True False lbi clbi return (addLibraryPath os paths env) else return env 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -79,7 +80,7 @@ , tryFindAddSourcePackageDesc) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) -import Distribution.PackageDescription.Parse ( readPackageDescription ) +import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) import Distribution.Simple.Compiler ( Compiler(..), PackageDB(..) ) import Distribution.Simple.Configure ( configCompilerAuxEx , getPackageDBContents @@ -92,7 +93,7 @@ import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..) , fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.SrcDist ( prepareTree ) -import Distribution.Simple.Utils ( die, debug, notice, info, warn +import Distribution.Simple.Utils ( die', debug, notice, info, warn , debugNoWrap, defaultPackageDesc , topHandlerWith , createDirectoryIfMissingVerbose ) @@ -206,16 +207,16 @@ (globalConfigFile globalFlags) -- | Return the name of the package index file for this package environment. -tryGetIndexFilePath :: SavedConfig -> IO FilePath -tryGetIndexFilePath config = tryGetIndexFilePath' (savedGlobalFlags config) +tryGetIndexFilePath :: Verbosity -> SavedConfig -> IO FilePath +tryGetIndexFilePath verbosity config = tryGetIndexFilePath' verbosity (savedGlobalFlags config) -- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of -- 'SavedConfig'. -tryGetIndexFilePath' :: GlobalFlags -> IO FilePath -tryGetIndexFilePath' globalFlags = do +tryGetIndexFilePath' :: Verbosity -> GlobalFlags -> IO FilePath +tryGetIndexFilePath' verbosity globalFlags = do let paths = fromNubList $ globalLocalRepos globalFlags case paths of - [] -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ + [] -> die' verbosity $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ "no local repos found. " ++ checkConfiguration _ -> return $ (last paths) Index.defaultIndexFileName where @@ -224,19 +225,19 @@ -- | Try to extract a 'PackageDB' from 'ConfigFlags'. Gives a better error -- message than just pattern-matching. -getSandboxPackageDB :: ConfigFlags -> IO PackageDB -getSandboxPackageDB configFlags = do +getSandboxPackageDB :: Verbosity -> ConfigFlags -> IO PackageDB +getSandboxPackageDB verbosity configFlags = do case configPackageDBs configFlags of [Just sandboxDB@(SpecificPackageDB _)] -> return sandboxDB -- TODO: should we allow multiple package DBs (e.g. with 'inherit')? [] -> - die $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt + die' verbosity $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt [_] -> - die $ "Unexpected contents of the 'package-db' field. " + die' verbosity $ "Unexpected contents of the 'package-db' field. " ++ sandboxConfigCorrupt _ -> - die $ "Too many package DBs provided. " ++ sandboxConfigCorrupt + die' verbosity $ "Too many package DBs provided. " ++ sandboxConfigCorrupt where sandboxConfigCorrupt = "Your 'cabal.sandbox.config' is probably corrupt." @@ -247,7 +248,7 @@ -> Compiler -> ProgramDb -> IO InstalledPackageIndex getInstalledPackagesInSandbox verbosity configFlags comp progdb = do - sandboxDB <- getSandboxPackageDB configFlags + sandboxDB <- getSandboxPackageDB verbosity configFlags getPackageDBContents verbosity comp sandboxDB progdb -- | Temporarily add $SANDBOX_DIR/bin to $PATH. @@ -279,7 +280,7 @@ -> Compiler -> ProgramDb -> IO () initPackageDBIfNeeded verbosity configFlags comp progdb = do - SpecificPackageDB dbPath <- getSandboxPackageDB configFlags + SpecificPackageDB dbPath <- getSandboxPackageDB verbosity configFlags packageDBExists <- doesDirectoryExist dbPath unless packageDBExists $ Register.initPackageDB verbosity comp progdb dbPath @@ -324,7 +325,7 @@ configFlags = savedConfigureFlags config -- Create the index file if it doesn't exist. - indexFile <- tryGetIndexFilePath config + indexFile <- tryGetIndexFilePath verbosity config indexFileExists <- doesFileExist indexFile if indexFileExists then notice verbosity $ "Using an existing sandbox located at " ++ sandboxDir @@ -363,7 +364,7 @@ curDir defaultSandboxLocation when isNonDefaultSandboxLocation $ - die $ "Non-default sandbox location used: '" ++ sandboxDir + die' verbosity $ "Non-default sandbox location used: '" ++ sandboxDir ++ "'.\nAssuming a shared sandbox. Please delete '" ++ sandboxDir ++ "' manually." @@ -395,7 +396,7 @@ -> IO () doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do let savedConfig = pkgEnvSavedConfig pkgEnv - indexFile <- tryGetIndexFilePath savedConfig + indexFile <- tryGetIndexFilePath verbosity savedConfig -- If we're running 'sandbox add-source' for the first time for this compiler, -- we need to create an initial timestamp record. @@ -403,7 +404,7 @@ maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile (compilerId comp) platform - withAddTimestamps sandboxDir $ do + withAddTimestamps verbosity sandboxDir $ do -- Path canonicalisation is done in addBuildTreeRefs, but we do it -- twice because of the timestamps file. buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs @@ -436,7 +437,7 @@ pkgs <- forM buildTreeRefs $ \buildTreeRef -> inDir (Just buildTreeRef) $ return . flattenPackageDescription - =<< readPackageDescription verbosity + =<< readGenericPackageDescription verbosity =<< defaultPackageDesc verbosity -- Copy the package sources to "snapshots/$PKGNAME-$VERSION-tmp". If @@ -470,7 +471,7 @@ -> IO () sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags - indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) + indexFile <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv) (results, convDict) <- Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs @@ -479,7 +480,7 @@ removedRefs = fmap convDict removedPaths unless (null removedPaths) $ do - removeTimestamps sandboxDir removedPaths + removeTimestamps verbosity sandboxDir removedPaths notice verbosity $ "Success deleting sources: " ++ showL removedRefs ++ "\n\n" @@ -487,7 +488,7 @@ unless (null failedPaths) $ do let groupedFailures = groupBy errorType failedPaths mapM_ handleErrors groupedFailures - die $ "The sources with the above errors were skipped. (" ++ + die' verbosity $ "The sources with the above errors were skipped. (" ++ showL (fmap getPath failedPaths) ++ ")" notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++ @@ -525,7 +526,7 @@ -> IO () sandboxListSources verbosity _sandboxFlags globalFlags = do (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags - indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) + indexFile <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv) refs <- Index.listBuildTreeRefs verbosity Index.ListIgnored Index.LinksAndSnapshots indexFile @@ -631,7 +632,7 @@ flag = (globalRequireSandbox . savedGlobalFlags $ config) `mappend` (globalRequireSandbox globalFlags) checkFlag (Flag True) = - die $ "'require-sandbox' is set to True, but no sandbox is present. " + die' verbosity $ "'require-sandbox' is set to True, but no sandbox is present. " ++ "Use '--no-require-sandbox' if you want to override " ++ "'require-sandbox' temporarily." checkFlag (Flag False) = return () @@ -690,7 +691,7 @@ -- might want to use some lower-level features this in the future. withSandboxBinDirOnSearchPath sandboxDir $ do installContext <- makeInstallContext verbosity args Nothing - installPlan <- foldProgress logMsg die' return =<< + installPlan <- foldProgress logMsg die'' return =<< makeInstallPlan verbosity args installContext processInstallPlan verbosity args installContext installPlan @@ -699,7 +700,7 @@ readIORef retVal where - die' message = die (message ++ installFailedInSandbox) + die'' message = die' verbosity (message ++ installFailedInSandbox) -- TODO: use a better error message, remove duplication. installFailedInSandbox = "Note: when using a sandbox, all packages are required to have " @@ -724,7 +725,7 @@ withSandboxPackageInfo verbosity configFlags globalFlags comp platform progdb sandboxDir cont = do -- List all add-source deps. - indexFile <- tryGetIndexFilePath' globalFlags + indexFile <- tryGetIndexFilePath' verbosity globalFlags buildTreeRefs <- Index.listBuildTreeRefs verbosity Index.DontListIgnored Index.OnlyLinks indexFile let allAddSourceDepsSet = S.fromList buildTreeRefs @@ -734,8 +735,8 @@ configFlags comp progdb let err = "Error reading sandbox package information." -- Get the package descriptions for all add-source deps. - depsCabalFiles <- mapM (flip tryFindAddSourcePackageDesc err) buildTreeRefs - depsPkgDescs <- mapM (readPackageDescription verbosity) depsCabalFiles + depsCabalFiles <- mapM (flip (tryFindAddSourcePackageDesc verbosity) err) buildTreeRefs + depsPkgDescs <- mapM (readGenericPackageDescription verbosity) depsCabalFiles let depsMap = M.fromList (zip buildTreeRefs depsPkgDescs) isInstalled pkgid = not . null . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid diff --git a/cabal/cabal-install/Distribution/Client/Sandbox/Index.hs b/cabal/cabal-install/Distribution/Client/Sandbox/Index.hs --- a/cabal/cabal-install/Distribution/Client/Sandbox/Index.hs +++ b/cabal/cabal-install/Distribution/Client/Sandbox/Index.hs @@ -34,7 +34,7 @@ , makeAbsoluteToCwd, tryCanonicalizePath , tryFindAddSourcePackageDesc ) -import Distribution.Simple.Utils ( die, debug ) +import Distribution.Simple.Utils ( die', debug ) import Distribution.Compat.Exception ( tryIO ) import Distribution.Verbosity ( Verbosity ) @@ -43,7 +43,7 @@ import Control.Monad ( liftM, unless ) import Control.Monad.Writer.Lazy (WriterT(..), runWriterT, tell) import Data.List ( (\\), intersect, nub, find ) -import Data.Maybe ( catMaybes, fromMaybe ) +import Data.Maybe ( catMaybes ) import Data.Either (partitionEithers) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist, @@ -61,12 +61,12 @@ defaultIndexFileName = "00-index.tar" -- | Given a path, ensure that it refers to a local build tree. -buildTreeRefFromPath :: BuildTreeRefType -> FilePath -> IO (Maybe BuildTreeRef) -buildTreeRefFromPath refType dir = do +buildTreeRefFromPath :: Verbosity -> BuildTreeRefType -> FilePath -> IO (Maybe BuildTreeRef) +buildTreeRefFromPath verbosity refType dir = do dirExists <- doesDirectoryExist dir unless dirExists $ - die $ "directory '" ++ dir ++ "' does not exist" - _ <- tryFindAddSourcePackageDesc dir "Error adding source reference." + die' verbosity $ "directory '" ++ dir ++ "' does not exist" + _ <- tryFindAddSourcePackageDesc verbosity dir "Error adding source reference." return . Just $ BuildTreeRef refType dir -- | Given a tar archive entry, try to parse it as a local build tree reference. @@ -120,14 +120,14 @@ -- | Check that the provided path is either an existing directory, or a tar -- archive in an existing directory. -validateIndexPath :: FilePath -> IO FilePath -validateIndexPath path' = do +validateIndexPath :: Verbosity -> FilePath -> IO FilePath +validateIndexPath verbosity path' = do path <- makeAbsoluteToCwd path' if (== ".tar") . takeExtension $ path then return path else do dirExists <- doesDirectoryExist path unless dirExists $ - die $ "directory does not exist: '" ++ path ++ "'" + die' verbosity $ "directory does not exist: '" ++ path ++ "'" return $ path defaultIndexFileName -- | Create an empty index file. @@ -149,11 +149,11 @@ addBuildTreeRefs _ _ [] _ = error "Distribution.Client.Sandbox.Index.addBuildTreeRefs: unexpected" addBuildTreeRefs verbosity path l' refType = do - checkIndexExists path + checkIndexExists verbosity path l <- liftM nub . mapM tryCanonicalizePath $ l' treesInIndex <- fmap (map buildTreePath) (readBuildTreeRefsFromFile path) -- Add only those paths that aren't already in the index. - treesToAdd <- mapM (buildTreeRefFromPath refType) (l \\ treesInIndex) + treesToAdd <- mapM (buildTreeRefFromPath verbosity refType) (l \\ treesInIndex) let entries = map writeBuildTreeRef (catMaybes treesToAdd) unless (null entries) $ do withBinaryFile path ReadWriteMode $ \h -> do @@ -176,7 +176,7 @@ removeBuildTreeRefs _ _ [] = error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected" removeBuildTreeRefs verbosity indexPath l = do - checkIndexExists indexPath + checkIndexExists verbosity indexPath let tmpFile = indexPath <.> "tmp" canonRes <- mapM (\btr -> do res <- tryIO $ canonicalizePath btr @@ -224,7 +224,7 @@ then tell [pth] >> return False else return True - convertWith dict pth = fromMaybe pth $ fmap fst $ find ((==pth) . snd) dict + convertWith dict pth = maybe pth fst $ find ((==pth) . snd) dict -- | A build tree ref can become ignored if the user later adds a build tree ref -- with the same package ID. We display ignored build tree refs when the user @@ -240,7 +240,7 @@ -> FilePath -> IO [FilePath] listBuildTreeRefs verbosity listIgnored refTypesToList path = do - checkIndexExists path + checkIndexExists verbosity path buildTreeRefs <- case listIgnored of DontListIgnored -> do @@ -274,8 +274,8 @@ -- | Check that the package index file exists and exit with error if it does not. -checkIndexExists :: FilePath -> IO () -checkIndexExists path = do +checkIndexExists :: Verbosity -> FilePath -> IO () +checkIndexExists verbosity path = do indexExists <- doesFileExist path unless indexExists $ - die $ "index does not exist: '" ++ path ++ "'" + die' verbosity $ "index does not exist: '" ++ path ++ "'" diff --git a/cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs b/cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs --- a/cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs +++ b/cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -50,7 +50,7 @@ import Distribution.Simple.Setup ( Flag(..) , ConfigFlags(..), HaddockFlags(..) , fromFlagOrDefault, toFlag, flagToMaybe ) -import Distribution.Simple.Utils ( die, info, notice, warn ) +import Distribution.Simple.Utils ( die', info, notice, warn, debug ) import Distribution.Solver.Types.ConstraintSource import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..) , commaListField, commaNewLineListField @@ -60,7 +60,7 @@ , syntaxError, warning ) import Distribution.System ( Platform ) import Distribution.Verbosity ( Verbosity, normal ) -import Control.Monad ( foldM, liftM2, when, unless ) +import Control.Monad ( foldM, liftM2, unless ) import Data.List ( partition, sortBy ) import Data.Maybe ( isJust ) import Data.Ord ( comparing ) @@ -277,17 +277,27 @@ -- | Load the user package environment if it exists (the optional "cabal.config" -- file). If it does not exist locally, attempt to load an optional global one. -userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath -> IO PackageEnvironment +userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath + -> IO PackageEnvironment userPackageEnvironment verbosity pkgEnvDir globalConfigLocation = do let path = pkgEnvDir userPackageEnvironmentFile - minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path) mempty path + minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path) + mempty path case (minp, globalConfigLocation) of (Just parseRes, _) -> processConfigParse path parseRes - (_, Just globalLoc) -> maybe (warn verbosity ("no constraints file found at " ++ globalLoc) >> return mempty) (processConfigParse globalLoc) =<< readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc) mempty globalLoc - _ -> return mempty + (_, Just globalLoc) -> do + minp' <- readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc) + mempty globalLoc + maybe (warn verbosity ("no constraints file found at " ++ globalLoc) + >> return mempty) + (processConfigParse globalLoc) + minp' + _ -> do + debug verbosity ("no user package environment file found at " ++ pkgEnvDir) + return mempty where processConfigParse path (ParseOk warns parseResult) = do - when (not $ null warns) $ warn verbosity $ + unless (null warns) $ warn verbosity $ unlines (map (showPWarning path) warns) return parseResult processConfigParse path (ParseFailed err) = do @@ -299,7 +309,8 @@ -- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig. loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig loadUserConfig verbosity pkgEnvDir globalConfigLocation = - fmap pkgEnvSavedConfig $ userPackageEnvironment verbosity pkgEnvDir globalConfigLocation + fmap pkgEnvSavedConfig $ + userPackageEnvironment verbosity pkgEnvDir globalConfigLocation -- | Common error handling code used by 'tryLoadSandboxPackageEnvironment' and -- 'updatePackageEnvironment'. @@ -308,15 +319,15 @@ -> IO PackageEnvironment handleParseResult verbosity path minp = case minp of - Nothing -> die $ + Nothing -> die' verbosity $ "The package environment file '" ++ path ++ "' doesn't exist" Just (ParseOk warns parseResult) -> do - when (not $ null warns) $ warn verbosity $ + unless (null warns) $ warn verbosity $ unlines (map (showPWarning path) warns) return parseResult Just (ParseFailed err) -> do let (line, msg) = locatedErrorMsg err - die $ "Error parsing package environment file " ++ path + die' verbosity $ "Error parsing package environment file " ++ path ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg -- | Try to load the given package environment file, exiting with error if it @@ -341,7 +352,7 @@ dirExists <- doesDirectoryExist sandboxDir -- TODO: Also check for an initialised package DB? unless dirExists $ - die ("No sandbox exists at " ++ sandboxDir) + die' verbosity ("No sandbox exists at " ++ sandboxDir) info verbosity $ "Using a sandbox located at " ++ sandboxDir let base = basePackageEnvironment @@ -401,7 +412,8 @@ , commaNewLineListField "constraints" (Text.disp . fst) ((\pc -> (pc, src)) `fmap` Text.parse) - (sortConstraints . configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig) + (sortConstraints . configExConstraints + . savedConfigureExFlags . pkgEnvSavedConfig) (\v pkgEnv -> updateConfigureExFlags pkgEnv (\flags -> flags { configExConstraints = v })) diff --git a/cabal/cabal-install/Distribution/Client/Sandbox/Timestamp.hs b/cabal/cabal-install/Distribution/Client/Sandbox/Timestamp.hs --- a/cabal/cabal-install/Distribution/Client/Sandbox/Timestamp.hs +++ b/cabal/cabal-install/Distribution/Client/Sandbox/Timestamp.hs @@ -29,7 +29,7 @@ import qualified Data.Map as M import Distribution.Compiler (CompilerId) -import Distribution.Simple.Utils (debug, die, warn) +import Distribution.Simple.Utils (debug, die', warn) import Distribution.System (Platform) import Distribution.Text (display) import Distribution.Verbosity (Verbosity) @@ -67,8 +67,8 @@ -- | Read the timestamp file. Exits with error if the timestamp file is -- corrupted. Returns an empty list if the file doesn't exist. -readTimestampFile :: FilePath -> IO [TimestampFileRecord] -readTimestampFile timestampFile = do +readTimestampFile :: Verbosity -> FilePath -> IO [TimestampFileRecord] +readTimestampFile verbosity timestampFile = do timestampString <- readFile timestampFile `catchIO` \_ -> return "[]" case reads timestampString of [(version, s)] @@ -91,8 +91,8 @@ _ -> dieCorrupted _ -> dieCorrupted where - dieWrongFormat = die $ wrongFormat ++ deleteAndRecreate - dieCorrupted = die $ corrupted ++ deleteAndRecreate + dieWrongFormat = die' verbosity $ wrongFormat ++ deleteAndRecreate + dieCorrupted = die' verbosity $ corrupted ++ deleteAndRecreate wrongFormat = "The timestamps file is in the wrong format." corrupted = "The timestamps file is corrupted." deleteAndRecreate = " Please delete and recreate the sandbox." @@ -107,12 +107,12 @@ timestampTmpFile = timestampFile <.> "tmp" -- | Read, process and write the timestamp file in one go. -withTimestampFile :: FilePath +withTimestampFile :: Verbosity -> FilePath -> ([TimestampFileRecord] -> IO [TimestampFileRecord]) -> IO () -withTimestampFile sandboxDir process = do +withTimestampFile verbosity sandboxDir process = do let timestampFile = sandboxDir timestampFileName - timestampRecords <- readTimestampFile timestampFile >>= process + timestampRecords <- readTimestampFile verbosity timestampFile >>= process writeTimestampFile timestampFile timestampRecords -- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps @@ -156,7 +156,7 @@ maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile compId platform = do let key = timestampRecordKey compId platform - withTimestampFile sandboxDir $ \timestampRecords -> do + withTimestampFile verbosity sandboxDir $ \timestampRecords -> do case lookup key timestampRecords of Just _ -> return timestampRecords Nothing -> do @@ -168,21 +168,21 @@ -- | Given an IO action that returns a list of build tree refs, add those -- build tree refs to the timestamps file (for all compilers). -withAddTimestamps :: FilePath -> IO [FilePath] -> IO () -withAddTimestamps sandboxDir act = do +withAddTimestamps :: Verbosity -> FilePath -> IO [FilePath] -> IO () +withAddTimestamps verbosity sandboxDir act = do let initialTimestamp = minBound - withActionOnAllTimestamps (addTimestamps initialTimestamp) sandboxDir act + withActionOnAllTimestamps (addTimestamps initialTimestamp) verbosity sandboxDir act -- | Given a list of build tree refs, remove those -- build tree refs from the timestamps file (for all compilers). -removeTimestamps :: FilePath -> [FilePath] -> IO () -removeTimestamps idxFile = - withActionOnAllTimestamps removeTimestamps' idxFile . return +removeTimestamps :: Verbosity -> FilePath -> [FilePath] -> IO () +removeTimestamps verbosity idxFile = + withActionOnAllTimestamps removeTimestamps' verbosity idxFile . return -- | Given an IO action that returns a list of build tree refs, update the -- timestamps of the returned build tree refs to the current time (only for the -- given compiler & platform). -withUpdateTimestamps :: FilePath -> CompilerId -> Platform +withUpdateTimestamps :: Verbosity -> FilePath -> CompilerId -> Platform ->([AddSourceTimestamp] -> IO [FilePath]) -> IO () withUpdateTimestamps = @@ -194,11 +194,12 @@ -- updates the timestamp file. The IO action is run only once. withActionOnAllTimestamps :: ([AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]) + -> Verbosity -> FilePath -> IO [FilePath] -> IO () -withActionOnAllTimestamps f sandboxDir act = - withTimestampFile sandboxDir $ \timestampRecords -> do +withActionOnAllTimestamps f verbosity sandboxDir act = + withTimestampFile verbosity sandboxDir $ \timestampRecords -> do paths <- act return [(key, f timestamps paths) | (key, timestamps) <- timestampRecords] @@ -208,14 +209,15 @@ withActionOnCompilerTimestamps :: ([AddSourceTimestamp] -> [FilePath] -> ModTime -> [AddSourceTimestamp]) + -> Verbosity -> FilePath -> CompilerId -> Platform -> ([AddSourceTimestamp] -> IO [FilePath]) -> IO () -withActionOnCompilerTimestamps f sandboxDir compId platform act = do +withActionOnCompilerTimestamps f verbosity sandboxDir compId platform act = do let needle = timestampRecordKey compId platform - withTimestampFile sandboxDir $ \timestampRecords -> do + withTimestampFile verbosity sandboxDir $ \timestampRecords -> do timestampRecords' <- forM timestampRecords $ \r@(key, timestamps) -> if key == needle then do paths <- act timestamps @@ -255,7 +257,7 @@ -- ^ The set of all installed add-source deps. -> IO [FilePath] listModifiedDeps verbosity sandboxDir compId platform installedDepsMap = do - timestampRecords <- readTimestampFile (sandboxDir timestampFileName) + timestampRecords <- readTimestampFile verbosity (sandboxDir timestampFileName) let needle = timestampRecordKey compId platform timestamps <- maybe noTimestampRecord return (lookup needle timestampRecords) @@ -265,7 +267,7 @@ $ timestamps where - noTimestampRecord = die $ "Сouldn't find a timestamp record for the given " + noTimestampRecord = die' verbosity $ "Сouldn't find a timestamp record for the given " ++ "compiler/platform pair. " ++ "Please report this on the Cabal bug tracker: " ++ "https://github.com/haskell/cabal/issues/new ." diff --git a/cabal/cabal-install/Distribution/Client/Security/DNS.hs b/cabal/cabal-install/Distribution/Client/Security/DNS.hs --- a/cabal/cabal-install/Distribution/Client/Security/DNS.hs +++ b/cabal/cabal-install/Distribution/Client/Security/DNS.hs @@ -1,18 +1,24 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DoAndIfThenElse #-} + module Distribution.Client.Security.DNS ( queryBootstrapMirrors ) where import Prelude () import Distribution.Client.Compat.Prelude - +import Network.URI (URI(..), URIAuth(..), parseURI) +import Distribution.Verbosity import Control.Monad import Control.DeepSeq (force) import Control.Exception (SomeException, evaluate, try) -import Network.URI (URI(..), URIAuth(..), parseURI) - import Distribution.Simple.Utils -import Distribution.Verbosity +import Distribution.Compat.Exception (displayException) + +#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) +import Network.DNS (queryTXT, Name(..), CharStr(..)) +import qualified Data.ByteString.Char8 as BS.Char8 +#else import Distribution.Simple.Program.Db ( emptyProgramDb, addKnownProgram , configureAllKnownPrograms, lookupProgram ) @@ -20,7 +26,7 @@ ( simpleProgram , programInvocation , getProgramInvocationOutput ) -import Distribution.Compat.Exception (displayException) +#endif -- | Try to lookup RFC1464-encoded mirror urls for a Hackage -- repository url by performing a DNS TXT lookup on the @@ -43,8 +49,48 @@ -- constitute a significant new attack vector anyway. -- queryBootstrapMirrors :: Verbosity -> URI -> IO [URI] + +#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) +-- use @resolv@ package for performing DNS queries queryBootstrapMirrors verbosity repoUri | Just auth <- uriAuthority repoUri = do + let mirrorsDnsName = Name (BS.Char8.pack ("_mirrors." ++ uriRegName auth)) + + mirrors' <- try $ do + txts <- queryTXT mirrorsDnsName + evaluate (force $ extractMirrors (map snd txts)) + + mirrors <- case mirrors' of + Left e -> do + warn verbosity ("Caught exception during _mirrors lookup:"++ + displayException (e :: SomeException)) + return [] + Right v -> return v + + if null mirrors + then warn verbosity ("No mirrors found for " ++ show repoUri) + else do info verbosity ("located " ++ show (length mirrors) ++ + " mirrors for " ++ show repoUri ++ " :") + forM_ mirrors $ \url -> info verbosity ("- " ++ show url) + + return mirrors + + | otherwise = return [] + +-- | Extract list of mirrors from 'queryTXT' result +extractMirrors :: [[CharStr]] -> [URI] +extractMirrors txtChunks = mapMaybe (parseURI . snd) . sort $ vals + where + vals = [ (kn,v) | CharStr e <- concat txtChunks + , Just (k,v) <- [splitRfc1464 (BS.Char8.unpack e)] + , Just kn <- [isUrlBase k] + ] + +---------------------------------------------------------------------------- +#else /* !defined(MIN_VERSION_resolv) */ +-- use external method via @nslookup@ +queryBootstrapMirrors verbosity repoUri + | Just auth <- uriAuthority repoUri = do progdb <- configureAllKnownPrograms verbosity $ addKnownProgram nslookupProg emptyProgramDb @@ -91,13 +137,6 @@ , Just kn <- [isUrlBase k] ] - isUrlBase :: String -> Maybe Int - isUrlBase s - | isSuffixOf ".urlbase" s, not (null ns), all isDigit ns = readMaybe ns - | otherwise = Nothing - where - ns = take (length s - 8) s - -- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly parseNsLookupTxt :: String -> Maybe [(String,[String])] parseNsLookupTxt = go0 [] [] @@ -128,6 +167,17 @@ qstr acc ('"':cs) = Just (reverse acc, cs) qstr acc (c:cs) = qstr (c:acc) cs qstr _ [] = Nothing + +#endif +---------------------------------------------------------------------------- + +-- | Helper used by 'extractMirrors' for extracting @urlbase@ keys from Rfc1464-encoded data +isUrlBase :: String -> Maybe Int +isUrlBase s + | ".urlbase" `isSuffixOf` s, not (null ns), all isDigit ns = readMaybe ns + | otherwise = Nothing + where + ns = take (length s - 8) s -- | Split a TXT string into key and value according to RFC1464. -- Returns 'Nothing' if parsing fails. 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 @@ -26,13 +26,14 @@ , installCommand, InstallFlags(..), installOptions, defaultInstallFlags , defaultSolver, defaultMaxBackjumps , listCommand, ListFlags(..) - , updateCommand + , updateCommand, UpdateFlags(..), defaultUpdateFlags , upgradeCommand , uninstallCommand , infoCommand, InfoFlags(..) , fetchCommand, FetchFlags(..) , freezeCommand, FreezeFlags(..) , genBoundsCommand + , outdatedCommand, OutdatedFlags(..), IgnoreMajorVersionBumps(..) , getCommand, unpackCommand, GetFlags(..) , checkCommand , formatCommand @@ -44,10 +45,11 @@ , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..) , actAsSetupCommand, ActAsSetupFlags(..) , sandboxCommand, defaultSandboxLocation, SandboxFlags(..) - , execCommand, ExecFlags(..) + , execCommand, ExecFlags(..), defaultExecFlags , userConfigCommand, UserConfigFlags(..) , manpageCommand + , applyFlagDefaults , parsePackageArgs --TODO: stop exporting these: , showRepo @@ -59,15 +61,15 @@ import Distribution.Client.Compat.Prelude hiding (get) import Distribution.Client.Types - ( Username(..), Password(..), RemoteRepo(..) ) + ( Username(..), Password(..), RemoteRepo(..) + , AllowNewer(..), AllowOlder(..), RelaxDeps(..) + ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.Dependency.Types ( PreSolver(..) ) - import Distribution.Client.IndexUtils.Timestamp - ( IndexState ) - + ( IndexState(..) ) import qualified Distribution.Client.Init.Types as IT ( InitFlags(..), PackageType(..) ) import Distribution.Client.Targets @@ -90,17 +92,18 @@ , TestFlags(..), BenchmarkFlags(..) , SDistFlags(..), HaddockFlags(..) , readPackageDbList, showPackageDbList - , Flag(..), toFlag, flagToMaybe, flagToList + , Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag , BooleanFlag(..), optionVerbosity , boolOpt, boolOpt', trueArg, falseArg - , readPToMaybe, optionNumJobs ) + , optionNumJobs ) import Distribution.Simple.InstallDirs - ( PathTemplate, InstallDirs(dynlibdir, sysconfdir) - , toPathTemplate, fromPathTemplate ) + ( PathTemplate, InstallDirs(..) + , toPathTemplate, fromPathTemplate, combinePathTemplate ) import Distribution.Version ( Version, mkVersion, nullVersion, anyVersion, thisVersion ) import Distribution.Package - ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) + ( PackageIdentifier, PackageName, packageName, packageVersion ) +import Distribution.Types.Dependency import Distribution.PackageDescription ( BuildType(..), RepoKind(..) ) import Distribution.System ( Platform ) @@ -109,9 +112,11 @@ import Distribution.ReadE ( ReadE(..), readP_to_E, succeedReadE ) import qualified Distribution.Compat.ReadP as Parse - ( ReadP, char, munch1, pfail, (+++) ) + ( ReadP, char, munch1, pfail, sepBy1, (+++) ) +import Distribution.ParseUtils + ( readPToMaybe ) import Distribution.Verbosity - ( Verbosity, lessVerbose, normal ) + ( Verbosity, lessVerbose, normal, verboseNoFlags, verboseNoTimestamp ) import Distribution.Simple.Utils ( wrapText, wrapLine ) import Distribution.Client.GlobalFlags @@ -126,6 +131,15 @@ import Network.URI ( parseAbsoluteURI, uriToString ) +applyFlagDefaults :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +applyFlagDefaults (configFlags, configExFlags, installFlags, haddockFlags) = + ( commandDefaultFlags configureCommand <> configFlags + , defaultConfigExFlags <> configExFlags + , defaultInstallFlags <> installFlags + , Cabal.defaultHaddockFlags <> haddockFlags + ) + globalCommand :: [Command action] -> CommandUI GlobalFlags globalCommand commands = CommandUI { commandName = "", @@ -156,6 +170,7 @@ , "get" , "init" , "configure" + , "reconfigure" , "build" , "clean" , "run" @@ -168,12 +183,22 @@ , "report" , "freeze" , "gen-bounds" + , "outdated" + , "doctest" , "haddock" , "hscolour" , "copy" , "register" , "sandbox" , "exec" + , "new-build" + , "new-configure" + , "new-repl" + , "new-freeze" + , "new-run" + , "new-test" + , "new-bench" + , "new-haddock" ] maxlen = maximum $ [length name | (name, _) <- cmdDescs] align str = str ++ replicate (maxlen - length str) ' ' @@ -219,15 +244,28 @@ , par , addCmd "freeze" , addCmd "gen-bounds" + , addCmd "outdated" + , addCmd "doctest" , addCmd "haddock" , addCmd "hscolour" , addCmd "copy" , addCmd "register" + , addCmd "reconfigure" , par , startGroup "sandbox" , addCmd "sandbox" , addCmd "exec" , addCmdCustom "repl" "Open interpreter with access to sandbox packages." + , par + , startGroup "new-style projects (beta)" + , addCmd "new-build" + , addCmd "new-configure" + , addCmd "new-repl" + , addCmd "new-run" + , addCmd "new-test" + , addCmd "new-bench" + , addCmd "new-freeze" + , addCmd "new-haddock" ] ++ if null otherCmds then [] else par :startGroup "other" :[addCmd n | n <- otherCmds]) @@ -297,6 +335,10 @@ "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')" globalHttpTransport (\v flags -> flags { globalHttpTransport = v }) (reqArgFlag "HttpTransport") + ,option [] ["nix"] + "Nix integration: run commands through nix-shell if a 'shell.nix' file exists" + globalNix (\v flags -> flags { globalNix = v }) + (boolOpt [] []) ] -- arguments we don't want shown in the help @@ -326,6 +368,11 @@ "The location of the world file" globalWorldFile (\v flags -> flags { globalWorldFile = v }) (reqArgFlag "FILE") + + ,option [] ["store-dir"] + "The location of the nix-local-build store" + globalStoreDir (\v flags -> flags { globalStoreDir = v }) + (reqArgFlag "DIR") ] -- ------------------------------------------------------------ @@ -363,7 +410,7 @@ filterConfigureFlags flags cabalLibVersion -- NB: we expect the latest version to be the most common case, -- so test it first. - | cabalLibVersion >= mkVersion [1,25,0] = flags_latest + | cabalLibVersion >= mkVersion [2,1,0] = flags_latest -- The naming convention is that flags_version gives flags with -- all flags *introduced* in version eliminated. -- It is NOT the latest version of Cabal library that @@ -380,21 +427,37 @@ | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0 | cabalLibVersion < mkVersion [1,23,0] = flags_1_23_0 | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0 + | cabalLibVersion < mkVersion [2,1,0] = flags_2_1_0 | otherwise = flags_latest where flags_latest = flags { -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'. - configConstraints = [], - -- Passing '--allow-{older,newer}' to Setup.hs is unnecessary, we use - -- '--exact-configuration' instead. - configAllowOlder = Just (Cabal.AllowOlder Cabal.RelaxDepsNone), - configAllowNewer = Just (Cabal.AllowNewer Cabal.RelaxDepsNone) + configConstraints = [] } - -- Cabal < 1.25.0 doesn't know about --dynlibdir. - flags_1_25_0 = flags_latest { configInstallDirs = configInstallDirs_1_25_0} - configInstallDirs_1_25_0 = (configInstallDirs flags) { dynlibdir = NoFlag } + flags_2_1_0 = flags_latest { + -- Cabal < 2.1 doesn't know about -v +timestamp modifier + configVerbosity = fmap verboseNoTimestamp (configVerbosity flags_latest) + -- Cabal < 2.1 doesn't know about ---static + , configStaticLib = NoFlag + , configSplitSections = NoFlag + } + flags_1_25_0 = flags_2_1_0 { + -- Cabal < 1.25.0 doesn't know about --dynlibdir. + configInstallDirs = configInstallDirs_1_25_0, + -- Cabal < 1.25 doesn't have extended verbosity syntax + configVerbosity = fmap verboseNoFlags (configVerbosity flags_2_1_0), + -- Cabal < 1.25 doesn't support --deterministic + configDeterministic = mempty + } + configInstallDirs_1_25_0 = let dirs = configInstallDirs flags in + dirs { dynlibdir = NoFlag + , libexecsubdir = NoFlag + , libexecdir = maybeToFlag $ + combinePathTemplate <$> flagToMaybe (libexecdir dirs) + <*> flagToMaybe (libexecsubdir dirs) + } -- Cabal < 1.23 doesn't know about '--profiling-detail'. -- Cabal < 1.23 has a hacked up version of 'enable-profiling' -- which we shouldn't use. @@ -465,7 +528,9 @@ configCabalVersion :: Flag Version, configExConstraints:: [(UserConstraint, ConstraintSource)], configPreferences :: [Dependency], - configSolver :: Flag PreSolver + configSolver :: Flag PreSolver, + configAllowNewer :: Maybe AllowNewer, + configAllowOlder :: Maybe AllowOlder } deriving (Eq, Generic) @@ -514,8 +579,35 @@ , optionSolver configSolver (\v flags -> flags { configSolver = v }) + , option [] ["allow-older"] + ("Ignore lower bounds in all dependencies or DEPS") + (fmap unAllowOlder . configAllowOlder) + (\v flags -> flags { configAllowOlder = fmap AllowOlder v}) + (optArg "DEPS" + (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser) + (Just RelaxDepsAll) relaxDepsPrinter) + + , option [] ["allow-newer"] + ("Ignore upper bounds in all dependencies or DEPS") + (fmap unAllowNewer . configAllowNewer) + (\v flags -> flags { configAllowNewer = fmap AllowNewer v}) + (optArg "DEPS" + (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser) + (Just RelaxDepsAll) relaxDepsPrinter) + ] + +relaxDepsParser :: Parse.ReadP r (Maybe RelaxDeps) +relaxDepsParser = + (Just . RelaxDepsSome) `fmap` Parse.sepBy1 parse (Parse.char ',') + +relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String] +relaxDepsPrinter Nothing = [] +relaxDepsPrinter (Just RelaxDepsAll) = [Nothing] +relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . display) $ pkgs + + instance Monoid ConfigExFlags where mempty = gmempty mappend = (<>) @@ -672,6 +764,7 @@ fetchIndependentGoals :: Flag IndependentGoals, fetchShadowPkgs :: Flag ShadowPkgs, fetchStrongFlags :: Flag StrongFlags, + fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls, fetchVerbosity :: Flag Verbosity } @@ -687,6 +780,7 @@ fetchIndependentGoals = Flag (IndependentGoals False), fetchShadowPkgs = Flag (ShadowPkgs False), fetchStrongFlags = Flag (StrongFlags False), + fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False), fetchVerbosity = toFlag normal } @@ -734,6 +828,7 @@ fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) fetchStrongFlags (\v flags -> flags { fetchStrongFlags = v }) + fetchAllowBootLibInstalls (\v flags -> flags { fetchAllowBootLibInstalls = v }) } @@ -752,6 +847,7 @@ freezeIndependentGoals :: Flag IndependentGoals, freezeShadowPkgs :: Flag ShadowPkgs, freezeStrongFlags :: Flag StrongFlags, + freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls, freezeVerbosity :: Flag Verbosity } @@ -767,6 +863,7 @@ freezeIndependentGoals = Flag (IndependentGoals False), freezeShadowPkgs = Flag (ShadowPkgs False), freezeStrongFlags = Flag (StrongFlags False), + freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False), freezeVerbosity = toFlag normal } @@ -786,7 +883,8 @@ commandUsage = usageFlags "freeze", commandDefaultFlags = defaultFreezeFlags, commandOptions = \ showOrParseArgs -> [ - optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v }) + optionVerbosity freezeVerbosity + (\v flags -> flags { freezeVerbosity = v }) , option [] ["dry-run"] "Do not freeze anything, only print what would be frozen" @@ -794,18 +892,21 @@ trueArg , option [] ["tests"] - "freezing of the dependencies of any tests suites in the package description file." + ("freezing of the dependencies of any tests suites " + ++ "in the package description file.") freezeTests (\v flags -> flags { freezeTests = v }) (boolOpt [] []) , option [] ["benchmarks"] - "freezing of the dependencies of any benchmarks suites in the package description file." + ("freezing of the dependencies of any benchmarks suites " + ++ "in the package description file.") freezeBenchmarks (\v flags -> flags { freezeBenchmarks = v }) (boolOpt [] []) ] ++ - optionSolver freezeSolver (\v flags -> flags { freezeSolver = v }) : + optionSolver + freezeSolver (\v flags -> flags { freezeSolver = v }): optionSolverFlags showOrParseArgs freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v }) freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v }) @@ -813,16 +914,22 @@ freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v }) freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v }) freezeStrongFlags (\v flags -> flags { freezeStrongFlags = v }) + freezeAllowBootLibInstalls (\v flags -> flags { freezeAllowBootLibInstalls = v }) } +-- ------------------------------------------------------------ +-- * 'gen-bounds' command +-- ------------------------------------------------------------ + genBoundsCommand :: CommandUI FreezeFlags genBoundsCommand = CommandUI { commandName = "gen-bounds", commandSynopsis = "Generate dependency bounds.", commandDescription = Just $ \_ -> wrapText $ "Generates bounds for all dependencies that do not currently have them. " - ++ "Generated bounds are printed to stdout. You can then paste them into your .cabal file.\n" + ++ "Generated bounds are printed to stdout. " + ++ "You can then paste them into your .cabal file.\n" ++ "\n", commandNotes = Nothing, commandUsage = usageFlags "gen-bounds", @@ -833,10 +940,133 @@ } -- ------------------------------------------------------------ --- * Other commands +-- * 'outdated' command -- ------------------------------------------------------------ -updateCommand :: CommandUI (Flag Verbosity) +data IgnoreMajorVersionBumps = IgnoreMajorVersionBumpsNone + | IgnoreMajorVersionBumpsAll + | IgnoreMajorVersionBumpsSome [PackageName] + +instance Monoid IgnoreMajorVersionBumps where + mempty = IgnoreMajorVersionBumpsNone + mappend = (<>) + +instance Semigroup IgnoreMajorVersionBumps where + IgnoreMajorVersionBumpsNone <> r = r + l@IgnoreMajorVersionBumpsAll <> _ = l + l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone = l + (IgnoreMajorVersionBumpsSome _) <> r@IgnoreMajorVersionBumpsAll = r + (IgnoreMajorVersionBumpsSome a) <> (IgnoreMajorVersionBumpsSome b) = + IgnoreMajorVersionBumpsSome (a ++ b) + +data OutdatedFlags = OutdatedFlags { + outdatedVerbosity :: Flag Verbosity, + outdatedFreezeFile :: Flag Bool, + outdatedNewFreezeFile :: Flag Bool, + outdatedSimpleOutput :: Flag Bool, + outdatedExitCode :: Flag Bool, + outdatedQuiet :: Flag Bool, + outdatedIgnore :: [PackageName], + outdatedMinor :: Maybe IgnoreMajorVersionBumps + } + +defaultOutdatedFlags :: OutdatedFlags +defaultOutdatedFlags = OutdatedFlags { + outdatedVerbosity = toFlag normal, + outdatedFreezeFile = mempty, + outdatedNewFreezeFile = mempty, + outdatedSimpleOutput = mempty, + outdatedExitCode = mempty, + outdatedQuiet = mempty, + outdatedIgnore = mempty, + outdatedMinor = mempty + } + +outdatedCommand :: CommandUI OutdatedFlags +outdatedCommand = CommandUI { + commandName = "outdated", + commandSynopsis = "Check for outdated dependencies", + commandDescription = Just $ \_ -> wrapText $ + "Checks for outdated dependencies in the package description file " + ++ "or freeze file", + commandNotes = Nothing, + commandUsage = usageFlags "outdated", + commandDefaultFlags = defaultOutdatedFlags, + commandOptions = \ _ -> [ + optionVerbosity outdatedVerbosity + (\v flags -> flags { outdatedVerbosity = v }) + + ,option [] ["freeze-file"] + "Act on the freeze file" + outdatedFreezeFile (\v flags -> flags { outdatedFreezeFile = v }) + trueArg + + ,option [] ["new-freeze-file"] + "Act on the new-style freeze file" + outdatedNewFreezeFile (\v flags -> flags { outdatedNewFreezeFile = v }) + trueArg + + ,option [] ["simple-output"] + "Only print names of outdated dependencies, one per line" + outdatedSimpleOutput (\v flags -> flags { outdatedSimpleOutput = v }) + trueArg + + ,option [] ["exit-code"] + "Exit with non-zero when there are outdated dependencies" + outdatedExitCode (\v flags -> flags { outdatedExitCode = v }) + trueArg + + ,option ['q'] ["quiet"] + "Don't print any output. Implies '--exit-code' and '-v0'" + outdatedQuiet (\v flags -> flags { outdatedQuiet = v }) + trueArg + + ,option [] ["ignore"] + "Packages to ignore" + outdatedIgnore (\v flags -> flags { outdatedIgnore = v }) + (reqArg "PKGS" pkgNameListParser (map display)) + + ,option [] ["minor"] + "Ignore major version bumps for these packages" + outdatedMinor (\v flags -> flags { outdatedMinor = v }) + (optArg "PKGS" ignoreMajorVersionBumpsParser + (Just IgnoreMajorVersionBumpsAll) ignoreMajorVersionBumpsPrinter) + ] + } + where + ignoreMajorVersionBumpsPrinter :: (Maybe IgnoreMajorVersionBumps) + -> [Maybe String] + ignoreMajorVersionBumpsPrinter Nothing = [] + ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= [] + ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing] + ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) = + map (Just . display) $ pkgs + + ignoreMajorVersionBumpsParser = + (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser + + pkgNameListParser = readP_to_E + ("Couldn't parse the list of package names: " ++) + (Parse.sepBy1 parse (Parse.char ',')) + +-- ------------------------------------------------------------ +-- * Update command +-- ------------------------------------------------------------ + +data UpdateFlags + = UpdateFlags { + updateVerbosity :: Flag Verbosity, + updateIndexState :: Flag IndexState + } deriving Generic + +defaultUpdateFlags :: UpdateFlags +defaultUpdateFlags + = UpdateFlags { + updateVerbosity = toFlag normal, + updateIndexState = toFlag IndexStateHead + } + +updateCommand :: CommandUI UpdateFlags updateCommand = CommandUI { commandName = "update", commandSynopsis = "Updates list of known packages.", @@ -847,10 +1077,27 @@ ,"remote-repo-cache" ,"local-repo"], commandUsage = usageFlags "update", - commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [optionVerbosity id const] + commandDefaultFlags = defaultUpdateFlags, + commandOptions = \_ -> [ + optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v }), + option [] ["index-state"] + ("Update the source package index to its state as it existed at a previous time. " ++ + "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').") + updateIndexState (\v flags -> flags { updateIndexState = v }) + (reqArg "STATE" (readP_to_E (const $ "index-state must be a " ++ + "unix-timestamps (e.g. '@1474732068'), " ++ + "a ISO8601 UTC timestamp " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") + (toFlag `fmap` parse)) + (flagToList . fmap display)) + ] } +-- ------------------------------------------------------------ +-- * Other commands +-- ------------------------------------------------------------ + upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) upgradeCommand = configureCommand { commandName = "upgrade", @@ -1012,6 +1259,7 @@ data GetFlags = GetFlags { getDestDir :: Flag FilePath, getPristine :: Flag Bool, + getIndexState :: Flag IndexState, getSourceRepository :: Flag (Maybe RepoKind), getVerbosity :: Flag Verbosity } deriving Generic @@ -1020,6 +1268,7 @@ defaultGetFlags = GetFlags { getDestDir = mempty, getPristine = mempty, + getIndexState = mempty, getSourceRepository = mempty, getVerbosity = toFlag normal } @@ -1057,6 +1306,20 @@ (Flag Nothing) (map (fmap show) . flagToList)) + , option [] ["index-state"] + ("Use source package index state as it existed at a previous time. " ++ + "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD'). " ++ + "This determines which package versions are available as well as " ++ + ".cabal file revision is selected (unless --pristine is used).") + getIndexState (\v flags -> flags { getIndexState = v }) + (reqArg "STATE" (readP_to_E (const $ "index-state must be a " ++ + "unix-timestamps (e.g. '@1474732068'), " ++ + "a ISO8601 UTC timestamp " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") + (toFlag `fmap` parse)) + (flagToList . fmap display)) + , option [] ["pristine"] ("Unpack the original pristine tarball, rather than updating the " ++ ".cabal file with the latest revision from the package archive.") @@ -1216,6 +1479,7 @@ installIndependentGoals :: Flag IndependentGoals, installShadowPkgs :: Flag ShadowPkgs, installStrongFlags :: Flag StrongFlags, + installAllowBootLibInstalls :: Flag AllowBootLibInstalls, installReinstall :: Flag Bool, installAvoidReinstalls :: Flag AvoidReinstalls, installOverrideReinstall :: Flag Bool, @@ -1229,11 +1493,20 @@ installBuildReports :: Flag ReportLevel, installReportPlanningFailure :: Flag Bool, installSymlinkBinDir :: Flag FilePath, + installPerComponent :: Flag Bool, installOneShot :: Flag Bool, installNumJobs :: Flag (Maybe Int), installKeepGoing :: Flag Bool, installRunTests :: Flag Bool, - installOfflineMode :: Flag Bool + installOfflineMode :: Flag Bool, + -- | The cabal project file name; defaults to @cabal.project@. + -- Th name itself denotes the cabal project file name, but it also + -- is the base of auxiliary project files, such as + -- @cabal.project.local@ and @cabal.project.freeze@ which are also + -- read and written out in some cases. If the path is not found + -- in the current working directory, we will successively probe + -- relative to parent directories until this name is found. + installProjectFileName :: Flag FilePath } deriving (Eq, Generic) @@ -1250,6 +1523,7 @@ installIndependentGoals= Flag (IndependentGoals False), installShadowPkgs = Flag (ShadowPkgs False), installStrongFlags = Flag (StrongFlags False), + installAllowBootLibInstalls = Flag (AllowBootLibInstalls False), installReinstall = Flag False, installAvoidReinstalls = Flag (AvoidReinstalls False), installOverrideReinstall = Flag False, @@ -1263,11 +1537,13 @@ installBuildReports = Flag NoReports, installReportPlanningFailure = Flag False, installSymlinkBinDir = mempty, + installPerComponent = Flag True, installOneShot = Flag False, installNumJobs = mempty, installKeepGoing = Flag False, installRunTests = mempty, - installOfflineMode = Flag False + installOfflineMode = Flag False, + installProjectFileName = mempty } where docIndexFile = toPathTemplate ("$datadir" "doc" @@ -1362,7 +1638,7 @@ , name `elem` ["hoogle", "html", "html-location" ,"executables", "tests", "benchmarks", "all", "internal", "css" ,"hyperlink-source", "hscolour-css" - ,"contents-location"] + ,"contents-location", "for-hackage"] ] where fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a @@ -1396,7 +1672,8 @@ installCountConflicts (\v flags -> flags { installCountConflicts = v }) installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) - installStrongFlags (\v flags -> flags { installStrongFlags = v }) ++ + installStrongFlags (\v flags -> flags { installStrongFlags = v }) + installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v }) ++ [ option [] ["reinstall"] "Install even if it means installing the same version again." @@ -1475,6 +1752,11 @@ installReportPlanningFailure (\v flags -> flags { installReportPlanningFailure = v }) trueArg + , option "" ["per-component"] + "Per-component builds when possible" + installPerComponent (\v flags -> flags { installPerComponent = v }) + (boolOpt [] []) + , option [] ["one-shot"] "Do not record the packages in the world file." installOneShot (\v flags -> flags { installOneShot = v }) @@ -1497,6 +1779,11 @@ "Don't download packages from the Internet." installOfflineMode (\v flags -> flags { installOfflineMode = v }) (yesNoOpt showOrParseArgs) + + , option [] ["project-file"] + "Set the name of the cabal.project file to search for in parent directories" + installProjectFileName (\v flags -> flags {installProjectFileName = v}) + (reqArgFlag "FILE") ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" -- avoids ParseArgs -> @@ -1725,6 +2012,12 @@ (\v flags -> flags { IT.packageType = v }) (noArg (Flag IT.Executable)) + , option [] ["is-libandexe"] + "Build a library and an executable." + IT.packageType + (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.LibraryAndExecutable)) + , option [] ["main-is"] "Specify the main module." IT.mainIs @@ -2027,12 +2320,14 @@ -- ------------------------------------------------------------ data ExecFlags = ExecFlags { - execVerbosity :: Flag Verbosity + execVerbosity :: Flag Verbosity, + execDistPref :: Flag FilePath } deriving Generic defaultExecFlags :: ExecFlags defaultExecFlags = ExecFlags { - execVerbosity = toFlag normal + execVerbosity = toFlag normal, + execDistPref = NoFlag } execCommand :: CommandUI ExecFlags @@ -2073,9 +2368,12 @@ "Usage: " ++ pname ++ " exec [FLAGS] [--] COMMAND [--] [ARGS]\n", commandDefaultFlags = defaultExecFlags, - commandOptions = \_ -> + commandOptions = \showOrParseArgs -> [ optionVerbosity execVerbosity (\v flags -> flags { execVerbosity = v }) + , Cabal.optionDistPref + execDistPref (\d flags -> flags { execDistPref = d }) + showOrParseArgs ] } @@ -2171,8 +2469,10 @@ -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags) -> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags) -> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags) + -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags) -> [OptionField flags] -optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc _getig _setig getsip setsip getstrfl setstrfl = +optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc getig setig + getsip setsip getstrfl setstrfl getib setib = [ option [] ["max-backjumps"] ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") getmbj setmbj @@ -2188,14 +2488,11 @@ (fmap asBool . getcc) (setcc . fmap CountConflicts) (yesNoOpt showOrParseArgs) - -- TODO: Disabled for now because it may not be necessary -{- , option [] ["independent-goals"] "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." (fmap asBool . getig) (setig . fmap IndependentGoals) (yesNoOpt showOrParseArgs) --} , option [] ["shadow-installed-packages"] "If multiple package instances of the same version are installed, treat all but one as shadowed." (fmap asBool . getsip) @@ -2205,6 +2502,11 @@ "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)." (fmap asBool . getstrfl) (setstrfl . fmap StrongFlags) + (yesNoOpt showOrParseArgs) + , option [] ["allow-boot-library-installs"] + "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell." + (fmap asBool . getib) + (setib . fmap AllowBootLibInstalls) (yesNoOpt showOrParseArgs) ] 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 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.SetupWrapper @@ -33,13 +34,14 @@ import qualified Distribution.Backpack as Backpack import Distribution.Package ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId, PackageId, mkPackageName - , PackageIdentifier(..), packageVersion, packageName, Dependency(..) ) + , PackageIdentifier(..), packageVersion, packageName ) +import Distribution.Types.Dependency import Distribution.PackageDescription ( GenericPackageDescription(packageDescription) , PackageDescription(..), specVersion , BuildType(..), knownBuildTypes, defaultRenaming ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription ) import Distribution.Simple.Configure ( configCompilerEx ) import Distribution.Compiler @@ -79,7 +81,7 @@ import Distribution.Simple.Setup ( Flag(..) ) import Distribution.Simple.Utils - ( die, debug, info, cabalVersion, tryFindPackageDesc, comparing + ( die', debug, info, infoNoWrap, cabalVersion, tryFindPackageDesc, comparing , createDirectoryIfMissingVerbose, installExecutableFile , copyFileVerbose, rewriteFile ) import Distribution.Client.Utils @@ -89,15 +91,17 @@ , canonicalizePathNoThrow #endif ) + +import Distribution.ReadE import Distribution.System ( Platform(..), buildPlatform ) import Distribution.Text ( display ) import Distribution.Utils.NubList ( toNubListR ) import Distribution.Verbosity - ( Verbosity, normal ) import Distribution.Compat.Exception ( catchIO ) +import Distribution.Compat.Stack import System.Directory ( doesFileExist ) import System.FilePath ( (), (<.>) ) @@ -138,7 +142,7 @@ | ExternalMethod FilePath -- ^ run Cabal commands through a custom \"Setup\" executable ---TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two +-- TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two -- parts: one that has no policy and just does as it's told with all the -- explicit options, and an optional initial part that applies certain -- policies (like if we should add the Cabal lib as a dep, and if so which @@ -301,11 +305,11 @@ } where getPkg = tryFindPackageDesc (fromMaybe "." (useWorkingDir options)) - >>= readPackageDescription verbosity + >>= readGenericPackageDescription verbosity >>= return . packageDescription checkBuildType (UnknownBuildType name) = - die $ "The build-type '" ++ name ++ "' is not known. Use one of: " + die' verbosity $ "The build-type '" ++ name ++ "' is not known. Use one of: " ++ intercalate ", " (map display knownBuildTypes) ++ "." checkBuildType _ = return () @@ -329,7 +333,7 @@ return (cabalVersion, SelfExecMethod, options) | otherwise = return (cabalVersion, InternalMethod, options) -runSetupMethod :: SetupMethod -> SetupRunner +runSetupMethod :: WithCallStack (SetupMethod -> SetupRunner) runSetupMethod InternalMethod = internalSetupMethod runSetupMethod (ExternalMethod path) = externalSetupMethod path runSetupMethod SelfExecMethod = selfExecSetupMethod @@ -338,12 +342,50 @@ runSetup :: Verbosity -> Setup -> [String] -- ^ command-line arguments -> IO () -runSetup verbosity setup args = +runSetup verbosity setup args0 = do let method = setupMethod setup options = setupScriptOptions setup bt = setupBuildType setup - in runSetupMethod method verbosity options bt args + args = verbosityHack (setupVersion setup) args0 + when (verbosity >= deafening {- avoid test if not debug -} && args /= args0) $ + infoNoWrap verbose $ + "Applied verbosity hack:\n" ++ + " Before: " ++ show args0 ++ "\n" ++ + " After: " ++ show args ++ "\n" + runSetupMethod method verbosity options bt args +-- | This is a horrible hack to make sure passing fancy verbosity +-- flags (e.g., @-v'info +callstack'@) doesn't break horribly on +-- old Setup. We can't do it in 'filterConfigureFlags' because +-- verbosity applies to ALL commands. +verbosityHack :: Version -> [String] -> [String] +verbosityHack ver args0 + | ver >= mkVersion [2,1] = args0 + | otherwise = go args0 + where + go (('-':'v':rest) : args) + | Just rest' <- munch rest = ("-v" ++ rest') : go args + go (('-':'-':'v':'e':'r':'b':'o':'s':'e':'=':rest) : args) + | Just rest' <- munch rest = ("--verbose=" ++ rest') : go args + go ("--verbose" : rest : args) + | Just rest' <- munch rest = "--verbose" : rest' : go args + go rest@("--" : _) = rest + go (arg:args) = arg : go args + go [] = [] + + munch rest = + case runReadE flagToVerbosity rest of + Right v + | ver < mkVersion [2,0], verboseHasFlags v + -- We could preserve the prefix, but since we're assuming + -- it's Cabal's verbosity flag, we can assume that + -- any format is OK + -> Just (showForCabal (verboseNoFlags v)) + | ver < mkVersion [2,1], isVerboseTimestamp v + -- +timestamp wasn't yet available in Cabal-2.0.0 + -> Just (showForCabal (verboseNoTimestamp v)) + _ -> Nothing + -- | Run a command through a configured 'Setup'. runSetupCommand :: Verbosity -> Setup -> CommandUI flags -- ^ command definition @@ -453,7 +495,7 @@ -- * External SetupMethod -- ------------------------------------------------------------ -externalSetupMethod :: FilePath -> SetupRunner +externalSetupMethod :: WithCallStack (FilePath -> SetupRunner) externalSetupMethod path verbosity options _ args = do info verbosity $ unwords (path : args) case useLoggingHandle options of @@ -637,7 +679,7 @@ updateSetupScript _ Custom = do useHs <- doesFileExist customSetupHs useLhs <- doesFileExist customSetupLhs - unless (useHs || useLhs) $ die + unless (useHs || useLhs) $ die' verbosity "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." let src = (if useHs then customSetupHs else customSetupLhs) srcNewer <- src `moreRecentFile` setupHs @@ -649,7 +691,7 @@ customSetupLhs = workingDir options "Setup.lhs" updateSetupScript cabalLibVersion _ = - rewriteFile setupHs (buildTypeScript cabalLibVersion) + rewriteFile verbosity setupHs (buildTypeScript cabalLibVersion) buildTypeScript :: Version -> String buildTypeScript cabalLibVersion = case bt of @@ -665,12 +707,15 @@ installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramDb -> IO (Version, Maybe InstalledPackageId ,SetupScriptOptions) + installedCabalVersion options' _ _ | packageName pkg == mkPackageName "Cabal" + && bt == Custom = + return (packageVersion pkg, Nothing, options') installedCabalVersion options' compiler progdb = do index <- maybeGetInstalledPackages options' compiler progdb let cabalDep = Dependency (mkPackageName "Cabal") (useCabalVersion options') options'' = options' { usePackageIndex = Just index } case PackageIndex.lookupDependency index cabalDep of - [] -> die $ "The package '" ++ display (packageName pkg) + [] -> die' verbosity $ "The package '" ++ display (packageName pkg) ++ "' requires Cabal library version " ++ display (useCabalVersion options) ++ " but no suitable version is installed." @@ -742,8 +787,8 @@ buildTypeString = show bt cabalVersionString = "Cabal-" ++ (display cabalLibVersion) compilerVersionString = display $ - fromMaybe buildCompilerId - (fmap compilerId . useCompiler $ options') + maybe buildCompilerId compilerId + $ useCompiler options' platformString = display platform -- | Look up the setup executable in the cache; update the cache if the setup @@ -777,8 +822,7 @@ cachedSetupProgFile return cachedSetupProgFile where - criticalSection' = fromMaybe id - (fmap criticalSection $ setupCacheLock options') + criticalSection' = maybe id criticalSection $ setupCacheLock options' -- | If the Setup.hs is out of date wrt the executable then recompile it. -- Currently this is GHC/GHCJS only. It should really be generalised. @@ -845,8 +889,8 @@ } let ghcCmdLine = renderGhcOptions compiler platform ghcOptions when (useVersionMacros options') $ - rewriteFile cppMacrosFile (generatePackageVersionMacros - [ pid | (_ipid, pid) <- selectedDeps ]) + rewriteFile verbosity cppMacrosFile + (generatePackageVersionMacros (map snd selectedDeps)) case useLoggingHandle options of Nothing -> runDbProgram verbosity program progdb ghcCmdLine 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 @@ -70,7 +70,7 @@ import Data.List ( intercalate ) import Data.Maybe - ( fromMaybe, catMaybes ) + ( fromMaybe, mapMaybe ) import Distribution.Compat.Binary (Binary(..)) import Distribution.Compat.Graph (Graph, IsNode(..)) import qualified Data.Graph as OldGraph @@ -121,12 +121,11 @@ (index, indepGoals) <- get return $! mkInstallPlan index indepGoals -showPlanIndex :: SolverPlanIndex -> String -showPlanIndex index = - intercalate "\n" (map showPlanPackage (Graph.toList index)) +showPlanIndex :: [SolverPlanPackage] -> String +showPlanIndex = intercalate "\n" . map showPlanPackage showInstallPlan :: SolverInstallPlan -> String -showInstallPlan = showPlanIndex . planIndex +showInstallPlan = showPlanIndex . toList showPlanPackage :: SolverPlanPackage -> String showPlanPackage (PreExisting ipkg) = "PreExisting " ++ display (packageId ipkg) @@ -163,7 +162,7 @@ remove shouldRemove plan = new (planIndepGoals plan) newIndex where - newIndex = Graph.fromList $ + newIndex = Graph.fromDistinctList $ filter (not . shouldRemove) (toList plan) -- ------------------------------------------------------------ @@ -227,10 +226,9 @@ problems indepGoals index = [ PackageMissingDeps pkg - (catMaybes - (map + (mapMaybe (fmap packageId . flip Graph.lookup index) - missingDeps)) + missingDeps) | (pkg, missingDeps) <- Graph.broken index ] ++ [ PackageCycle cycleGroup diff --git a/cabal/cabal-install/Distribution/Client/SolverPlanIndex.hs b/cabal/cabal-install/Distribution/Client/SolverPlanIndex.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Client/SolverPlanIndex.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- | These graph traversal functions mirror the ones in Cabal, but work with --- the more complete (and fine-grained) set of dependencies provided by --- PackageFixedDeps rather than only the library dependencies provided by --- PackageInstalled. -module Distribution.Client.SolverPlanIndex ( - -- * Graph traversal functions - brokenPackages - , dependencyCycles - , dependencyGraph - , dependencyInconsistencies - ) where - -import Prelude () -import Distribution.Client.Compat.Prelude - --- import Prelude hiding (lookup) -import qualified Data.Map as Map -import qualified Data.Graph as Graph -import Data.Array ((!)) -import Data.Map (Map) --- import Data.Maybe (isNothing) -import Data.Either (rights) - -import Distribution.Package - ( PackageName, PackageIdentifier(..), UnitId(..) - , Package(..), packageName, packageVersion - ) -import Distribution.Version - ( Version ) - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.PackageFixedDeps -import Distribution.Solver.Types.Settings - -import Distribution.Simple.PackageIndex - ( PackageIndex, allPackages, insert, lookupUnitId ) -import Distribution.Package - ( HasUnitId(..), PackageId ) - --- | All packages that have dependencies that are not in the index. --- --- Returns such packages along with the dependencies that they're missing. --- -brokenPackages :: (PackageFixedDeps pkg) - => PackageIndex pkg - -> [(pkg, [UnitId])] -brokenPackages index = - [ (pkg, missing) - | pkg <- allPackages index - , let missing = - [ pkg' | pkg' <- CD.flatDeps (depends pkg) - , isNothing (lookupUnitId index pkg') ] - , not (null missing) ] - --- | Compute all roots of the install plan, and verify that the transitive --- plans from those roots are all consistent. --- --- NOTE: This does not check for dependency cycles. Moreover, dependency cycles --- may be absent from the subplans even if the larger plan contains a dependency --- cycle. Such cycles may or may not be an issue; either way, we don't check --- for them here. -dependencyInconsistencies :: forall pkg. (PackageFixedDeps pkg, HasUnitId pkg) - => IndependentGoals - -> PackageIndex pkg - -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies indepGoals index = - concatMap dependencyInconsistencies' subplans - where - subplans :: [PackageIndex pkg] - subplans = rights $ - map (dependencyClosure index) - (rootSets indepGoals index) - --- | Compute the root sets of a plan --- --- A root set is a set of packages whose dependency closure must be consistent. --- This is the set of all top-level library roots (taken together normally, or --- as singletons sets if we are considering them as independent goals), along --- with all setup dependencies of all packages. -rootSets :: (PackageFixedDeps pkg, HasUnitId pkg) - => IndependentGoals -> PackageIndex pkg -> [[UnitId]] -rootSets (IndependentGoals indepGoals) index = - if indepGoals then map (:[]) libRoots else [libRoots] - ++ setupRoots index - where - libRoots = libraryRoots index - --- | Compute the library roots of a plan --- --- The library roots are the set of packages with no reverse dependencies --- (no reverse library dependencies but also no reverse setup dependencies). -libraryRoots :: (PackageFixedDeps pkg, HasUnitId pkg) - => PackageIndex pkg -> [UnitId] -libraryRoots index = - map toPkgId roots - where - (graph, toPkgId, _) = dependencyGraph index - indegree = Graph.indegree graph - roots = filter isRoot (Graph.vertices graph) - isRoot v = indegree ! v == 0 - --- | The setup dependencies of each package in the plan -setupRoots :: PackageFixedDeps pkg => PackageIndex pkg -> [[UnitId]] -setupRoots = filter (not . null) - . map (CD.setupDeps . depends) - . allPackages - --- | 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 --- if the dependencies within it use consistent versions of each package. --- Return all cases where multiple packages depend on different versions of --- some other package. --- --- Each element in the result is a package name along with the packages that --- depend on it and the versions they require. These are guaranteed to be --- distinct. --- -dependencyInconsistencies' :: forall pkg. - (PackageFixedDeps pkg, HasUnitId pkg) - => PackageIndex pkg - -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies' index = - [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids]) - | (name, ipid_map) <- Map.toList inverseIndex - , let uses = Map.elems ipid_map - , reallyIsInconsistent (map fst uses) - ] - where - -- For each package name (of a dependency, somewhere) - -- and each installed ID of that that package - -- the associated package instance - -- and a list of reverse dependencies (as source IDs) - inverseIndex :: Map PackageName (Map UnitId (pkg, [PackageId])) - inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) - [ (packageName dep, Map.fromList [(ipid,(dep,[packageId pkg]))]) - | -- For each package @pkg@ - pkg <- allPackages index - -- Find out which @ipid@ @pkg@ depends on - , ipid <- CD.nonSetupDeps (depends pkg) - -- And look up those @ipid@ (i.e., @ipid@ is the ID of @dep@) - , Just dep <- [lookupUnitId index ipid] - ] - - -- If, in a single install plan, we depend on more than one version of a - -- package, then this is ONLY okay in the (rather special) case that we - -- depend on precisely two versions of that package, and one of them - -- depends on the other. This is necessary for example for the base where - -- we have base-3 depending on base-4. - reallyIsInconsistent :: [pkg] -> Bool - reallyIsInconsistent [] = False - reallyIsInconsistent [_p] = False - reallyIsInconsistent [p1, p2] = - let pid1 = installedUnitId p1 - pid2 = installedUnitId p2 - in pid1 `notElem` CD.nonSetupDeps (depends p2) - && pid2 `notElem` CD.nonSetupDeps (depends p1) - reallyIsInconsistent _ = True - - - --- | Find if there are any cycles in the dependency graph. If there are no --- cycles the result is @[]@. --- --- This actually computes the strongly connected components. So it gives us a --- list of groups of packages where within each group they all depend on each --- other, directly or indirectly. --- -dependencyCycles :: (PackageFixedDeps pkg, HasUnitId pkg) - => PackageIndex pkg - -> [[pkg]] -dependencyCycles index = - [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] - where - adjacencyList = [ (pkg, installedUnitId pkg, - CD.flatDeps (depends pkg)) - | pkg <- allPackages index ] - - --- | Tries to take the transitive closure of the package dependencies. --- --- If the transitive closure is complete then it returns that subset of the --- index. Otherwise it returns the broken packages as in 'brokenPackages'. --- --- * Note that if the result is @Right []@ it is because at least one of --- the original given 'PackageIdentifier's do not occur in the index. -dependencyClosure :: (PackageFixedDeps pkg, HasUnitId pkg) - => PackageIndex pkg - -> [UnitId] - -> Either [(pkg, [UnitId])] - (PackageIndex pkg) -dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of - (completed, []) -> Right completed - (completed, _) -> Left (brokenPackages completed) - where - closure completed failed [] = (completed, failed) - closure completed failed (pkgid:pkgids) = - case lookupUnitId index pkgid of - Nothing -> closure completed (pkgid:failed) pkgids - Just pkg -> - case lookupUnitId completed - (installedUnitId pkg) of - Just _ -> closure completed failed pkgids - Nothing -> closure completed' failed pkgids' - where completed' = insert pkg completed - pkgids' = CD.nonSetupDeps (depends pkg) ++ pkgids - - --- | Builds a graph of the package dependencies. --- --- Dependencies on other packages that are not in the index are discarded. --- You can check if there are any such dependencies with 'brokenPackages'. --- -dependencyGraph :: (PackageFixedDeps pkg, HasUnitId pkg) - => PackageIndex pkg - -> (Graph.Graph, - Graph.Vertex -> UnitId, - UnitId -> Maybe Graph.Vertex) -dependencyGraph index = (graph, vertexToPkg, idToVertex) - where - (graph, vertexToPkg', idToVertex) = Graph.graphFromEdges edges - vertexToPkg v = case vertexToPkg' v of - ((), pkgid, _targets) -> pkgid - - pkgs = allPackages index - edges = map edgesFrom pkgs - - resolve pid = pid - edgesFrom pkg = ( () - , resolve (installedUnitId pkg) - , CD.flatDeps (depends pkg) - ) diff --git a/cabal/cabal-install/Distribution/Client/SrcDist.hs b/cabal/cabal-install/Distribution/Client/SrcDist.hs --- a/cabal/cabal-install/Distribution/Client/SrcDist.hs +++ b/cabal/cabal-install/Distribution/Client/SrcDist.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE FlexibleContexts #-} -- Implements the \"@.\/cabal sdist@\" command, which creates a source @@ -19,11 +20,11 @@ ( PackageDescription ) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, defaultPackageDesc - , warn, die, notice, withTempDirectory ) + , warn, die', notice, withTempDirectory ) import Distribution.Client.Setup ( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) ) import Distribution.Simple.Setup @@ -51,7 +52,7 @@ sdist :: SDistFlags -> SDistExFlags -> IO () sdist flags exflags = do pkg <- liftM flattenPackageDescription - (readPackageDescription verbosity =<< defaultPackageDesc verbosity) + (readGenericPackageDescription verbosity =<< defaultPackageDesc verbosity) let withDir :: (FilePath -> IO a) -> IO a withDir = if not needMakeArchive then \f -> f tmpTargetDir else withTempDirectory verbosity tmpTargetDir "sdist." @@ -142,7 +143,7 @@ Nothing Nothing Nothing Nothing exitCode <- waitForProcess hnd unless (exitCode == ExitSuccess) $ - die $ "Generating the zip file failed " + die' verbosity $ "Generating the zip file failed " ++ "(zip returned exit code " ++ show exitCode ++ ")" notice verbosity $ "Source zip archive created: " ++ zipfile where @@ -155,8 +156,8 @@ allPackageSourceFiles verbosity setupOpts0 packageDir = do pkg <- do let err = "Error reading source files of package." - desc <- tryFindAddSourcePackageDesc packageDir err - flattenPackageDescription `fmap` readPackageDescription verbosity desc + desc <- tryFindAddSourcePackageDesc verbosity packageDir err + flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc globalTmp <- getTemporaryDirectory withTempDirectory verbosity globalTmp "cabal-list-sources." $ \tempDir -> do let file = tempDir "cabal-sdist-list-sources" diff --git a/cabal/cabal-install/Distribution/Client/Store.hs b/cabal/cabal-install/Distribution/Client/Store.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Store.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} + + +-- | Management for the installed package store. +-- +module Distribution.Client.Store ( + + -- * The store layout + StoreDirLayout(..), + defaultStoreDirLayout, + + -- * Reading store entries + getStoreEntries, + doesStoreEntryExist, + + -- * Creating store entries + newStoreEntry, + NewStoreEntryOutcome(..), + + -- * Concurrency strategy + -- $concurrency + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude +import Distribution.Client.Compat.FileLock + +import Distribution.Client.DistDirLayout +import Distribution.Client.RebuildMonad + +import Distribution.Package (UnitId, mkUnitId) +import Distribution.Compiler (CompilerId) + +import Distribution.Simple.Utils + ( withTempDirectory, debug, info ) +import Distribution.Verbosity +import Distribution.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 + + +-- $concurrency +-- +-- We access and update the store concurrently. Our strategy to do that safely +-- is as follows. +-- +-- The store entries once created are immutable. This alone simplifies matters +-- considerably. +-- +-- Additionally, the way 'UnitId' hashes are constructed means that if a store +-- entry exists already then we can assume its content is ok to reuse, rather +-- than having to re-recreate. This is the nix-style input hashing concept. +-- +-- A consequence of this is that with a little care it is /safe/ to race +-- updates against each other. Consider two independent concurrent builds that +-- both want to build a particular 'UnitId', where that entry does not yet +-- exist in the store. It is safe for both to build and try to install this +-- entry into the store provided that: +-- +-- * only one succeeds +-- * the looser discovers that they lost, they abandon their own build and +-- re-use the store entry installed by the winner. +-- +-- Note that because builds are not reproducible in general (nor even +-- necessarily ABI compatible) then it is essential that the loser abandon +-- their build and use the one installed by the winner, so that subsequent +-- packages are built against the exact package from the store rather than some +-- morally equivalent package that may not be ABI compatible. +-- +-- Our overriding goal is that store reads be simple, cheap and not require +-- locking. We will derive our write-side protocol to make this possible. +-- +-- The read-side protocol is simply: +-- +-- * check for the existence of a directory entry named after the 'UnitId' in +-- question. That is, if the dir entry @$root/foo-1.0-fe56a...@ exists then +-- the store entry can be assumed to be complete and immutable. +-- +-- Given our read-side protocol, the final step on the write side must be to +-- atomically rename a fully-formed store entry directory into its final +-- location. While this will indeed be the final step, the preparatory steps +-- are more complicated. The tricky aspect is that the store also contains a +-- number of shared package databases (one per compiler version). Our read +-- strategy means that by the time we install the store dir entry the package +-- db must already have been updated. We cannot do the package db update +-- as part of atomically renaming the store entry directory however. Furthermore +-- it is not safe to allow either package db update because the db entry +-- contains the ABI hash and this is not guaranteed to be deterministic. So we +-- must register the new package prior to the atomic dir rename. Since this +-- combination of steps are not atomic then we need locking. +-- +-- The write-side protocol is: +-- +-- * Create a unique temp dir and write all store entry files into it. +-- +-- * Take a lock named after the 'UnitId' in question. +-- +-- * Once holding the lock, check again for the existence of the final store +-- entry directory. If the entry exists then the process lost the race and it +-- must abandon, unlock and re-use the existing store entry. If the entry +-- does not exist then the process won the race and it can proceed. +-- +-- * Register the package into the package db. Note that the files are not in +-- their final location at this stage so registration file checks may need +-- to be disabled. +-- +-- * Atomically rename the temp dir to the final store entry location. +-- +-- * Release the previously-acquired lock. +-- +-- Obviously this means it is possible to fail after registering but before +-- installing the store entry, leaving a dangling package db entry. This is not +-- much of a problem because this entry does not determine package existence +-- for cabal. It does mean however that the package db update should be insert +-- or replace, i.e. not failing if the db entry already exists. + + +-- | Check if a particular 'UnitId' exists in the store. +-- +doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool +doesStoreEntryExist StoreDirLayout{storePackageDirectory} compid unitid = + doesDirectoryExist (storePackageDirectory compid unitid) + + +-- | Return the 'UnitId's of all packages\/components already installed in the +-- store. +-- +getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId) +getStoreEntries StoreDirLayout{storeDirectory} compid = do + paths <- getDirectoryContentsMonitored (storeDirectory compid) + return $! mkEntries paths + where + mkEntries = Set.delete (mkUnitId "package.db") + . Set.delete (mkUnitId "incoming") + . Set.fromList + . map mkUnitId + . filter valid + valid ('.':_) = False + valid _ = True + + +-- | The outcome of 'newStoreEntry': either the store entry was newly created +-- or it existed already. The latter case happens if there was a race between +-- two builds of the same store entry. +-- +data NewStoreEntryOutcome = UseNewStoreEntry + | UseExistingStoreEntry + deriving (Eq, Show) + +-- | Place a new entry into the store. See the concurrency strategy description +-- for full details. +-- +-- In particular, it takes two actions: one to place files into a temporary +-- location, and a second to perform any necessary registration. The first +-- action is executed without any locks held (the temp dir is unique). The +-- second action holds a lock that guarantees that only one cabal process is +-- able to install this store entry. This means it is safe to register into +-- the compiler package DB or do other similar actions. +-- +-- Note that if you need to use the registration information later then you +-- /must/ check the 'NewStoreEntryOutcome' and if it's'UseExistingStoreEntry' +-- then you must read the existing registration information (unless your +-- registration information is constructed fully deterministically). +-- +newStoreEntry :: Verbosity + -> StoreDirLayout + -> CompilerId + -> UnitId + -> (FilePath -> IO (FilePath, [FilePath])) -- ^ Action to place files. + -> IO () -- ^ Register action, if necessary. + -> IO NewStoreEntryOutcome +newStoreEntry verbosity storeDirLayout@StoreDirLayout{..} + compid unitid + copyFiles register = + -- See $concurrency above for an explanation of the concurrency protocol + + withTempIncomingDir storeDirLayout compid $ \incomingTmpDir -> do + + -- Write all store entry files within the temp dir and return the prefix. + (incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir + + -- Take a lock named after the 'UnitId' in question. + withIncomingUnitIdLock verbosity storeDirLayout compid unitid $ do + + -- Check for the existence of the final store entry directory. + exists <- doesStoreEntryExist storeDirLayout compid unitid + + if exists + -- If the entry exists then we lost the race and we must abandon, + -- unlock and re-use the existing store entry. + then do + info verbosity $ + "Concurrent build race: abandoning build in favour of existing " + ++ "store entry " ++ display compid display unitid + return UseExistingStoreEntry + + -- If the entry does not exist then we won the race and can proceed. + else do + + -- Register the package into the package db (if appropriate). + register + + -- Atomically rename the temp dir to the final store entry location. + renameDirectory incomingEntryDir finalEntryDir + forM_ otherFiles $ \file -> do + let finalStoreFile = storeDirectory compid makeRelative (incomingTmpDir (dropDrive (storeDirectory compid))) file + createDirectoryIfMissing True (takeDirectory finalStoreFile) + renameFile file finalStoreFile + + debug verbosity $ + "Installed store entry " ++ display compid display unitid + return UseNewStoreEntry + where + finalEntryDir = storePackageDirectory compid unitid + + +withTempIncomingDir :: StoreDirLayout -> CompilerId + -> (FilePath -> IO a) -> IO a +withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compid action = do + createDirectoryIfMissing True incomingDir + withTempDirectory silent incomingDir "new" action + where + incomingDir = storeIncomingDirectory compid + + +withIncomingUnitIdLock :: Verbosity -> StoreDirLayout + -> CompilerId -> UnitId + -> IO a -> IO a +withIncomingUnitIdLock verbosity StoreDirLayout{storeIncomingLock} + compid unitid action = + bracket takeLock releaseLock (\_hnd -> action) + where + takeLock = do + h <- openFile (storeIncomingLock compid unitid) ReadWriteMode + -- First try non-blocking, but if we would have to wait then + -- log an explanation and do it again in blocking mode. + gotlock <- hTryLock h ExclusiveLock + unless gotlock $ do + info verbosity $ "Waiting for file lock on store entry " + ++ display compid display unitid + hLock h ExclusiveLock + return h + + releaseLock = hClose + diff --git a/cabal/cabal-install/Distribution/Client/TargetSelector.hs b/cabal/cabal-install/Distribution/Client/TargetSelector.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/TargetSelector.hs @@ -0,0 +1,2253 @@ +{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, RecordWildCards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.TargetSelector +-- Copyright : (c) Duncan Coutts 2012, 2015, 2016 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Handling for user-specified target selectors. +-- +----------------------------------------------------------------------------- +module Distribution.Client.TargetSelector ( + + -- * Target selectors + TargetSelector(..), + TargetImplicitCwd(..), + ComponentKind(..), + ComponentKindFilter, + SubComponentTarget(..), + QualLevel(..), + componentKind, + + -- * Reading target selectors + readTargetSelectors, + TargetSelectorProblem(..), + reportTargetSelectorProblems, + showTargetSelector, + TargetString, + showTargetString, + parseTargetString, + -- ** non-IO + readTargetSelectorsWith, + DirActions(..), + defaultDirActions, + ) where + +import Distribution.Package + ( Package(..), PackageId, PackageIdentifier(..) + , PackageName, packageName, mkPackageName ) +import Distribution.Version + ( mkVersion ) +import Distribution.Types.UnqualComponentName ( unUnqualComponentName ) +import Distribution.Client.Types + ( PackageLocation(..), PackageSpecifier(..) ) + +import Distribution.Verbosity +import Distribution.PackageDescription + ( PackageDescription + , Executable(..) + , TestSuite(..), TestSuiteInterface(..), testModules + , Benchmark(..), BenchmarkInterface(..), benchmarkModules + , BuildInfo(..), explicitLibModules, exeModules ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage(..) ) +import Distribution.ModuleName + ( ModuleName, toFilePath ) +import Distribution.Simple.LocalBuildInfo + ( Component(..), ComponentName(..) + , pkgComponents, componentName, componentBuildInfo ) +import Distribution.Types.ForeignLib + +import Distribution.Text + ( display, simpleParse ) +import Distribution.Simple.Utils + ( die', lowercase, ordNub ) +import Distribution.Client.Utils + ( makeRelativeCanonical ) + +import Data.Either + ( partitionEithers ) +import Data.Function + ( on ) +import Data.List + ( nubBy, stripPrefix, partition, intercalate, sortBy, groupBy ) +import Data.Maybe + ( maybeToList ) +import Data.Ord + ( comparing ) +import Distribution.Compat.Binary (Binary) +import GHC.Generics (Generic) +#if MIN_VERSION_containers(0,5,0) +import qualified Data.Map.Lazy as Map.Lazy +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +#else +import qualified Data.Map as Map.Lazy +import qualified Data.Map as Map +import Data.Map (Map) +#endif +import qualified Data.Set as Set +import Control.Arrow ((&&&)) +import Control.Monad +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative (Applicative(..), (<$>)) +#endif +import Control.Applicative (Alternative(..)) +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.ReadP + ( (+++), (<++) ) +import Distribution.ParseUtils + ( readPToMaybe ) +import Data.Char + ( isSpace, isAlphaNum ) +import System.FilePath as FilePath + ( takeExtension, dropExtension + , splitDirectories, joinPath, splitPath ) +import qualified System.Directory as IO + ( doesFileExist, doesDirectoryExist, canonicalizePath + , getCurrentDirectory ) +import System.FilePath + ( (), (<.>), normalise, dropTrailingPathSeparator ) +import Text.EditDistance + ( defaultEditCosts, restrictedDamerauLevenshteinDistance ) + + +-- ------------------------------------------------------------ +-- * Target selector terms +-- ------------------------------------------------------------ + +-- | A target selector is expression selecting a set of components (as targets +-- for a actions like @build@, @run@, @test@ etc). A target selector +-- corresponds to the user syntax for referring to targets on the command line. +-- +-- From the users point of view a target can be many things: packages, dirs, +-- component names, files etc. Internally we consider a target to be a specific +-- component (or module\/file within a component), and all the users' notions +-- of targets are just different ways of referring to these component targets. +-- +-- So target selectors are expressions in the sense that they are interpreted +-- to refer to one or more components. For example a 'TargetPackage' gets +-- interpreted differently by different commands to refer to all or a subset +-- of components within the package. +-- +-- The syntax has lots of optional parts: +-- +-- > [ package name | package dir | package .cabal file ] +-- > [ [lib:|exe:] component name ] +-- > [ module name | source file ] +-- +data TargetSelector pkg = + + -- | A package as a whole: the default components for the package or all + -- components of a particular kind. + -- + TargetPackage TargetImplicitCwd pkg (Maybe ComponentKindFilter) + + -- | All packages, or all components of a particular kind in all packages. + -- + | TargetAllPackages (Maybe ComponentKindFilter) + + -- | A specific component in a package. + -- + | TargetComponent pkg ComponentName SubComponentTarget + + -- | A named package, but not a known local package. It could for example + -- resolve to a dependency of a local package or to a package from + -- hackage. Either way, it requires further processing to resolve. + -- + | TargetPackageName PackageName + deriving (Eq, Ord, Functor, Show, Generic) + +-- | Does this 'TargetPackage' selector arise from syntax referring to a +-- package in the current directory (e.g. @tests@ or no giving no explicit +-- target at all) or does it come from syntax referring to a package name +-- or location. +-- +data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed + deriving (Eq, Ord, Show, Generic) + +data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind + deriving (Eq, Ord, Enum, Show) + +type ComponentKindFilter = ComponentKind + +-- | Either the component as a whole or detail about a file or module target +-- within a component. +-- +data SubComponentTarget = + + -- | The component as a whole + WholeComponent + + -- | A specific module within a component. + | ModuleTarget ModuleName + + -- | A specific file within a component. + | FileTarget FilePath + deriving (Eq, Ord, Show, Generic) + +instance Binary SubComponentTarget + + +-- ------------------------------------------------------------ +-- * Top level, do everything +-- ------------------------------------------------------------ + + +-- | Parse a bunch of command line args as 'TargetSelector's, failing with an +-- error if any are unrecognised. The possible target selectors are based on +-- the available packages (and their locations). +-- +readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))] + -> [String] + -> IO (Either [TargetSelectorProblem] + [TargetSelector PackageId]) +readTargetSelectors = readTargetSelectorsWith defaultDirActions + +readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m + -> [PackageSpecifier (SourcePackage (PackageLocation a))] + -> [String] + -> m (Either [TargetSelectorProblem] + [TargetSelector PackageId]) +readTargetSelectorsWith dirActions@DirActions{..} pkgs targetStrs = + case parseTargetStrings targetStrs of + ([], utargets) -> do + utargets' <- mapM (getTargetStringFileStatus dirActions) utargets + pkgs' <- sequence [ selectPackageInfo dirActions pkg + | SpecificSourcePackage pkg <- pkgs ] + cwd <- getCurrentDirectory + let (cwdPkg, otherPkgs) = selectCwdPackage cwd pkgs' + case resolveTargetSelectors cwdPkg otherPkgs utargets' of + ([], btargets) -> return (Right (map (fmap packageId) btargets)) + (problems, _) -> return (Left problems) + (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) + where + selectCwdPackage :: FilePath + -> [PackageInfo] + -> ([PackageInfo], [PackageInfo]) + selectCwdPackage cwd pkgs' = + let (cwdpkg, others) = partition isPkgDirCwd pkgs' + in (cwdpkg, others) + where + isPkgDirCwd PackageInfo { pinfoDirectory = Just (dir,_) } + | dir == cwd = True + isPkgDirCwd _ = False + +data DirActions m = DirActions { + doesFileExist :: FilePath -> m Bool, + doesDirectoryExist :: FilePath -> m Bool, + canonicalizePath :: FilePath -> m FilePath, + getCurrentDirectory :: m FilePath + } + +defaultDirActions :: DirActions IO +defaultDirActions = + DirActions { + doesFileExist = IO.doesFileExist, + doesDirectoryExist = IO.doesDirectoryExist, + -- Workaround for + canonicalizePath = IO.canonicalizePath . dropTrailingPathSeparator, + getCurrentDirectory = IO.getCurrentDirectory + } + +makeRelativeToCwd :: Applicative m => DirActions m -> FilePath -> m FilePath +makeRelativeToCwd DirActions{..} path = + makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory + + +-- ------------------------------------------------------------ +-- * Parsing target strings +-- ------------------------------------------------------------ + +-- | The outline parse of a target selector. It takes one of the forms: +-- +-- > str1 +-- > str1:str2 +-- > str1:str2:str3 +-- > str1:str2:str3:str4 +-- +data TargetString = + TargetString1 String + | TargetString2 String String + | TargetString3 String String String + | TargetString4 String String String String + | TargetString5 String String String String String + | TargetString7 String String String String String String String + deriving (Show, Eq) + +-- | Parse a bunch of 'TargetString's (purely without throwing exceptions). +-- +parseTargetStrings :: [String] -> ([String], [TargetString]) +parseTargetStrings = + partitionEithers + . map (\str -> maybe (Left str) Right (parseTargetString str)) + +parseTargetString :: String -> Maybe TargetString +parseTargetString = + readPToMaybe parseTargetApprox + where + parseTargetApprox :: Parse.ReadP r TargetString + parseTargetApprox = + (do a <- tokenQ + return (TargetString1 a)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- tokenQ + return (TargetString2 a b)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- tokenQ + _ <- Parse.char ':' + c <- tokenQ + return (TargetString3 a b c)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + return (TargetString4 a b c d)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + _ <- Parse.char ':' + e <- tokenQ + return (TargetString5 a b c d e)) + +++ (do a <- tokenQ0 + _ <- Parse.char ':' + b <- token + _ <- Parse.char ':' + c <- tokenQ + _ <- Parse.char ':' + d <- tokenQ + _ <- Parse.char ':' + e <- tokenQ + _ <- Parse.char ':' + f <- tokenQ + _ <- Parse.char ':' + g <- tokenQ + return (TargetString7 a b c d e f g)) + + token = Parse.munch1 (\x -> not (isSpace x) && x /= ':') + tokenQ = parseHaskellString <++ token + token0 = Parse.munch (\x -> not (isSpace x) && x /= ':') + tokenQ0= parseHaskellString <++ token0 + parseHaskellString :: Parse.ReadP r String + parseHaskellString = Parse.readS_to_P reads + + +-- | Render a 'TargetString' back as the external syntax. This is mainly for +-- error messages. +-- +showTargetString :: TargetString -> String +showTargetString = intercalate ":" . components + where + components (TargetString1 s1) = [s1] + components (TargetString2 s1 s2) = [s1,s2] + components (TargetString3 s1 s2 s3) = [s1,s2,s3] + components (TargetString4 s1 s2 s3 s4) = [s1,s2,s3,s4] + components (TargetString5 s1 s2 s3 s4 s5) = [s1,s2,s3,s4,s5] + components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1,s2,s3,s4,s5,s6,s7] + +showTargetSelector :: Package p => TargetSelector p -> String +showTargetSelector ts = + case [ t | ql <- [QL1 .. QLFull] + , t <- renderTargetSelector ql ts ] + of (t':_) -> showTargetString (forgetFileStatus t') + [] -> "" + +showTargetSelectorKind :: TargetSelector a -> String +showTargetSelectorKind bt = case bt of + TargetPackage TargetExplicitNamed _ Nothing -> "package" + TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter" + TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package" + TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter" + TargetAllPackages Nothing -> "all-packages" + TargetAllPackages (Just _) -> "all-packages:filter" + TargetComponent _ _ WholeComponent -> "component" + TargetComponent _ _ ModuleTarget{} -> "module" + TargetComponent _ _ FileTarget{} -> "file" + TargetPackageName{} -> "package name" + + +-- ------------------------------------------------------------ +-- * Checking if targets exist as files +-- ------------------------------------------------------------ + +data TargetStringFileStatus = + TargetStringFileStatus1 String FileStatus + | TargetStringFileStatus2 String FileStatus String + | TargetStringFileStatus3 String FileStatus String String + | TargetStringFileStatus4 String String String String + | TargetStringFileStatus5 String String String String String + | TargetStringFileStatus7 String String String String String String String + deriving (Eq, Ord, Show) + +data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath + | FileStatusExistsDir FilePath -- the canonicalised filepath + | FileStatusNotExists Bool -- does the parent dir exist even? + deriving (Eq, Ord, Show) + +noFileStatus :: FileStatus +noFileStatus = FileStatusNotExists False + +getTargetStringFileStatus :: (Applicative m, Monad m) => DirActions m + -> TargetString -> m TargetStringFileStatus +getTargetStringFileStatus DirActions{..} t = + case t of + TargetString1 s1 -> + (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1 + TargetString2 s1 s2 -> + (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1 + TargetString3 s1 s2 s3 -> + (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 + TargetString4 s1 s2 s3 s4 -> + return (TargetStringFileStatus4 s1 s2 s3 s4) + TargetString5 s1 s2 s3 s4 s5 -> + return (TargetStringFileStatus5 s1 s2 s3 s4 s5) + TargetString7 s1 s2 s3 s4 s5 s6 s7 -> + return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7) + where + fileStatus f = do + fexists <- doesFileExist f + dexists <- doesDirectoryExist f + case splitPath f of + _ | fexists -> FileStatusExistsFile <$> canonicalizePath f + | dexists -> FileStatusExistsDir <$> canonicalizePath f + (d:_) -> FileStatusNotExists <$> doesDirectoryExist d + _ -> pure (FileStatusNotExists False) + +forgetFileStatus :: TargetStringFileStatus -> TargetString +forgetFileStatus t = case t of + TargetStringFileStatus1 s1 _ -> TargetString1 s1 + TargetStringFileStatus2 s1 _ s2 -> TargetString2 s1 s2 + TargetStringFileStatus3 s1 _ s2 s3 -> TargetString3 s1 s2 s3 + TargetStringFileStatus4 s1 s2 s3 s4 -> TargetString4 s1 s2 s3 s4 + TargetStringFileStatus5 s1 s2 s3 s4 + s5 -> TargetString5 s1 s2 s3 s4 s5 + TargetStringFileStatus7 s1 s2 s3 s4 + s5 s6 s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7 + + +-- ------------------------------------------------------------ +-- * Resolving target strings to target selectors +-- ------------------------------------------------------------ + + +-- | Given a bunch of user-specified targets, try to resolve what it is they +-- refer to. +-- +resolveTargetSelectors :: [PackageInfo] -- any pkg in the cur dir + -> [PackageInfo] -- all the other local packages + -> [TargetStringFileStatus] + -> ([TargetSelectorProblem], + [TargetSelector PackageInfo]) + +-- default local dir target if there's no given target: +resolveTargetSelectors [] [] [] = + ([TargetSelectorNoTargetsInProject], []) + +resolveTargetSelectors [] _opinfo [] = + ([TargetSelectorNoTargetsInCwd], []) + +resolveTargetSelectors ppinfo _opinfo [] = + ([], [TargetPackage TargetImplicitCwd (head ppinfo) Nothing]) + --TODO: in future allow multiple packages in the same dir + +resolveTargetSelectors ppinfo opinfo targetStrs = + partitionEithers + . map (resolveTargetSelector ppinfo opinfo) + $ targetStrs + +resolveTargetSelector :: [PackageInfo] -> [PackageInfo] + -> TargetStringFileStatus + -> Either TargetSelectorProblem + (TargetSelector PackageInfo) +resolveTargetSelector ppinfo opinfo targetStrStatus = + case findMatch (matcher targetStrStatus) of + + Unambiguous _ + | projectIsEmpty -> Left TargetSelectorNoTargetsInProject + + Unambiguous (TargetPackage TargetImplicitCwd _ mkfilter) + | null ppinfo -> Left (TargetSelectorNoCurrentPackage targetStr) + | otherwise -> Right (TargetPackage TargetImplicitCwd + (head ppinfo) mkfilter) + --TODO: in future allow multiple packages in the same dir + + Unambiguous target -> Right target + + None errs + | TargetStringFileStatus1 str _ <- targetStrStatus + , validPackageName str -> Right (TargetPackageName (mkPackageName str)) + | projectIsEmpty -> Left TargetSelectorNoTargetsInProject + | otherwise -> Left (classifyMatchErrors errs) + + Ambiguous exactMatch targets -> + case disambiguateTargetSelectors + matcher targetStrStatus exactMatch + targets of + Right targets' -> Left (TargetSelectorAmbiguous targetStr + (map (fmap (fmap packageId)) targets')) + Left ((m, ms):_) -> Left (MatchingInternalError targetStr + (fmap packageId m) + (map (fmap (map (fmap packageId))) ms)) + Left [] -> internalError "resolveTargetSelector" + where + matcher = matchTargetSelector ppinfo opinfo + + targetStr = forgetFileStatus targetStrStatus + + projectIsEmpty = null ppinfo && null opinfo + + classifyMatchErrors errs + | not (null expected) + = let (things, got:_) = unzip expected in + TargetSelectorExpected targetStr things got + + | not (null nosuch) + = TargetSelectorNoSuch targetStr nosuch + + | otherwise + = internalError $ "classifyMatchErrors: " ++ show errs + where + expected = [ (thing, got) + | (_, MatchErrorExpected thing got) + <- map (innerErr Nothing) errs ] + -- Trim the list of alternatives by dropping duplicates and + -- retaining only at most three most similar (by edit distance) ones. + nosuch = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $ + [ ((inside, thing, got), Set.fromList alts) + | (inside, MatchErrorNoSuch thing got alts) + <- map (innerErr Nothing) errs + ] + + genResults (inside, thing, got) alts acc = ( + inside + , thing + , got + , take maxResults + $ map fst + $ takeWhile distanceLow + $ sortBy (comparing snd) + $ map addLevDist + $ Set.toList alts + ) : acc + where + addLevDist = id &&& restrictedDamerauLevenshteinDistance + defaultEditCosts got + + distanceLow (_, dist) = dist < length got `div` 2 + + maxResults = 3 + + innerErr _ (MatchErrorIn kind thing m) + = innerErr (Just (kind,thing)) m + innerErr c m = (c,m) + +-- | The various ways that trying to resolve a 'TargetString' to a +-- 'TargetSelector' can fail. +-- +data TargetSelectorProblem + = TargetSelectorExpected TargetString [String] String + -- ^ [expected thing] (actually got) + | TargetSelectorNoSuch TargetString + [(Maybe (String, String), String, String, [String])] + -- ^ [([in thing], no such thing, actually got, alternatives)] + | TargetSelectorAmbiguous TargetString + [(TargetString, TargetSelector PackageId)] + + | MatchingInternalError TargetString (TargetSelector PackageId) + [(TargetString, [TargetSelector PackageId])] + | TargetSelectorUnrecognised String + -- ^ Syntax error when trying to parse a target string. + | TargetSelectorNoCurrentPackage TargetString + | TargetSelectorNoTargetsInCwd + | TargetSelectorNoTargetsInProject + deriving (Show, Eq) + +data QualLevel = QL1 | QL2 | QL3 | QLFull + deriving (Eq, Enum, Show) + +disambiguateTargetSelectors + :: (TargetStringFileStatus -> Match (TargetSelector PackageInfo)) + -> TargetStringFileStatus -> Bool + -> [TargetSelector PackageInfo] + -> Either [(TargetSelector PackageInfo, + [(TargetString, [TargetSelector PackageInfo])])] + [(TargetString, TargetSelector PackageInfo)] +disambiguateTargetSelectors matcher matchInput exactMatch matchResults = + case partitionEithers results of + (errs@(_:_), _) -> Left errs + ([], ok) -> Right ok + where + -- So, here's the strategy. We take the original match results, and make a + -- table of all their renderings at all qualification levels. + -- Note there can be multiple renderings at each qualification level. + matchResultsRenderings :: [(TargetSelector PackageInfo, + [TargetStringFileStatus])] + matchResultsRenderings = + [ (matchResult, matchRenderings) + | matchResult <- matchResults + , let matchRenderings = + [ rendering + | ql <- [QL1 .. QLFull] + , rendering <- renderTargetSelector ql matchResult ] + ] + + -- Of course the point is that we're looking for renderings that are + -- unambiguous matches. So we build another memo table of all the matches + -- for all of those renderings. So by looking up in this table we can see + -- if we've got an unambiguous match. + + memoisedMatches :: Map TargetStringFileStatus + (Match (TargetSelector PackageInfo)) + memoisedMatches = + -- avoid recomputing the main one if it was an exact match + (if exactMatch then Map.insert matchInput (ExactMatch 0 matchResults) + else id) + $ Map.Lazy.fromList + [ (rendering, matcher rendering) + | rendering <- concatMap snd matchResultsRenderings ] + + -- Finally, for each of the match results, we go through all their + -- possible renderings (in order of qualification level, though remember + -- there can be multiple renderings per level), and find the first one + -- that has an unambiguous match. + results :: [Either (TargetSelector PackageInfo, + [(TargetString, [TargetSelector PackageInfo])]) + (TargetString, TargetSelector PackageInfo)] + results = + [ case findUnambiguous originalMatch matchRenderings of + Just unambiguousRendering -> + Right ( forgetFileStatus unambiguousRendering + , originalMatch) + + -- This case is an internal error, but we bubble it up and report it + Nothing -> + Left ( originalMatch + , [ (forgetFileStatus rendering, matches) + | rendering <- matchRenderings + , let (ExactMatch _ matches) = + memoisedMatches Map.! rendering + ] ) + + | (originalMatch, matchRenderings) <- matchResultsRenderings ] + + findUnambiguous :: TargetSelector PackageInfo + -> [TargetStringFileStatus] + -> Maybe TargetStringFileStatus + findUnambiguous _ [] = Nothing + findUnambiguous t (r:rs) = + case memoisedMatches Map.! r of + ExactMatch _ [t'] | fmap packageName t == fmap packageName t' + -> Just r + ExactMatch _ _ -> findUnambiguous t rs + InexactMatch _ _ -> internalError "InexactMatch" + NoMatch _ _ -> internalError "NoMatch" + +internalError :: String -> a +internalError msg = + error $ "TargetSelector: internal error: " ++ msg + + +-- | Throw an exception with a formatted message if there are any problems. +-- +reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a +reportTargetSelectorProblems verbosity problems = do + + case [ str | TargetSelectorUnrecognised str <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Unrecognised target syntax for '" ++ name ++ "'." + | name <- targets ] + + case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of + [] -> return () + ((target, originalMatch, renderingsAndMatches):_) -> + die' verbosity $ "Internal error in target matching. It should always " + ++ "be possible to find a syntax that's sufficiently qualified to " + ++ "give an unambiguous match. However when matching '" + ++ showTargetString target ++ "' we found " + ++ showTargetSelector originalMatch + ++ " (" ++ showTargetSelectorKind originalMatch ++ ") which does " + ++ "not have an unambiguous syntax. The possible syntax and the " + ++ "targets they match are as follows:\n" + ++ unlines + [ "'" ++ showTargetString rendering ++ "' which matches " + ++ intercalate ", " + [ showTargetSelector match ++ + " (" ++ showTargetSelectorKind match ++ ")" + | match <- matches ] + | (rendering, matches) <- renderingsAndMatches ] + + case [ (t, e, g) | TargetSelectorExpected t e g <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Unrecognised target '" ++ showTargetString target + ++ "'.\n" + ++ "Expected a " ++ intercalate " or " expected + ++ ", rather than '" ++ got ++ "'." + | (target, expected, got) <- targets ] + + case [ (t, e) | TargetSelectorNoSuch t e <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Unknown target '" ++ showTargetString target ++ + "'.\n" ++ unlines + [ (case inside of + Just (kind, "") + -> "The " ++ kind ++ " has no " + Just (kind, thing) + -> "The " ++ kind ++ " " ++ thing ++ " has no " + Nothing -> "There is no ") + ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" + | (thing, got, _alts) <- nosuch' ] ++ "." + ++ if null alternatives then "" else + "\nPerhaps you meant " ++ intercalate ";\nor " + [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?" + | (thing, alts) <- alternatives ] + | (inside, nosuch') <- groupByContainer nosuch + , let alternatives = + [ (thing, alts) + | (thing,_got,alts@(_:_)) <- nosuch' ] + ] + | (target, nosuch) <- targets + , let groupByContainer = + map (\g@((inside,_,_,_):_) -> + (inside, [ (thing,got,alts) + | (_,thing,got,alts) <- g ])) + . groupBy ((==) `on` (\(x,_,_,_) -> x)) + . sortBy (compare `on` (\(x,_,_,_) -> x)) + ] + where + mungeThing "file" = "file target" + mungeThing thing = thing + + case [ (t, ts) | TargetSelectorAmbiguous t ts <- problems ] of + [] -> return () + targets -> + die' verbosity $ unlines + [ "Ambiguous target '" ++ showTargetString target + ++ "'. It could be:\n " + ++ unlines [ " "++ showTargetString ut ++ + " (" ++ showTargetSelectorKind bt ++ ")" + | (ut, bt) <- amb ] + | (target, amb) <- targets ] + + case [ t | TargetSelectorNoCurrentPackage t <- problems ] of + [] -> return () + target:_ -> + die' verbosity $ + "The target '" ++ showTargetString target ++ "' refers to the " + ++ "components in the package in the current directory, but there " + ++ "is no package in the current directory (or at least not listed " + ++ "as part of the project)." + --TODO: report a different error if there is a .cabal file but it's + -- not a member of the project + + case [ () | TargetSelectorNoTargetsInCwd <- problems ] of + [] -> return () + _:_ -> + die' verbosity $ + "No targets given and there is no package in the current " + ++ "directory. Use the target 'all' for all packages in the " + ++ "project or specify packages or components by name or location. " + ++ "See 'cabal build --help' for more details on target options." + + case [ () | TargetSelectorNoTargetsInProject <- problems ] of + [] -> return () + _:_ -> + die' verbosity $ + "There is no .cabal package file or cabal.project file. " + ++ "To build packages locally you need at minimum a .cabal " + ++ "file. You can use 'cabal init' to create one.\n" + ++ "\n" + ++ "For non-trivial projects you will also want a cabal.project " + ++ "file in the root directory of your project. This file lists the " + ++ "packages in your project and all other build configuration. " + ++ "See the Cabal user guide for full details." + + fail "reportTargetSelectorProblems: internal error" + + +---------------------------------- +-- Syntax type +-- + +-- | Syntax for the 'TargetSelector': the matcher and renderer +-- +data Syntax = Syntax QualLevel Matcher Renderer + | AmbiguousAlternatives Syntax Syntax + | ShadowingAlternatives Syntax Syntax + +type Matcher = TargetStringFileStatus -> Match (TargetSelector PackageInfo) +type Renderer = TargetSelector PackageId -> [TargetStringFileStatus] + +foldSyntax :: (a -> a -> a) -> (a -> a -> a) + -> (QualLevel -> Matcher -> Renderer -> a) + -> (Syntax -> a) +foldSyntax ambiguous unambiguous syntax = go + where + go (Syntax ql match render) = syntax ql match render + go (AmbiguousAlternatives a b) = ambiguous (go a) (go b) + go (ShadowingAlternatives a b) = unambiguous (go a) (go b) + + +---------------------------------- +-- Top level renderer and matcher +-- + +renderTargetSelector :: Package p => QualLevel -> TargetSelector p + -> [TargetStringFileStatus] +renderTargetSelector ql ts = + foldSyntax + (++) (++) + (\ql' _ render -> guard (ql == ql') >> render (fmap packageId ts)) + syntax + where + syntax = syntaxForms [] [] -- don't need pinfo for rendering + +matchTargetSelector :: [PackageInfo] -> [PackageInfo] + -> TargetStringFileStatus + -> Match (TargetSelector PackageInfo) +matchTargetSelector ppinfo opinfo = \utarget -> + nubMatchesBy ((==) `on` (fmap packageName)) $ + + let ql = targetQualLevel utarget in + foldSyntax + (<|>) () + (\ql' match _ -> guard (ql == ql') >> match utarget) + syntax + where + syntax = syntaxForms ppinfo opinfo + + targetQualLevel TargetStringFileStatus1{} = QL1 + targetQualLevel TargetStringFileStatus2{} = QL2 + targetQualLevel TargetStringFileStatus3{} = QL3 + targetQualLevel TargetStringFileStatus4{} = QLFull + targetQualLevel TargetStringFileStatus5{} = QLFull + targetQualLevel TargetStringFileStatus7{} = QLFull + + +---------------------------------- +-- Syntax forms +-- + +-- | All the forms of syntax for 'TargetSelector'. +-- +syntaxForms :: [PackageInfo] -> [PackageInfo] -> Syntax +syntaxForms ppinfo opinfo = + -- The various forms of syntax here are ambiguous in many cases. + -- Our policy is by default we expose that ambiguity and report + -- ambiguous matches. In certain cases we override the ambiguity + -- by having some forms shadow others. + -- + -- We make modules shadow files because module name "Q" clashes + -- with file "Q" with no extension but these refer to the same + -- thing anyway so it's not a useful ambiguity. Other cases are + -- not ambiguous like "Q" vs "Q.hs" or "Data.Q" vs "Data/Q". + + ambiguousAlternatives + -- convenient single-component forms + [ shadowingAlternatives + [ ambiguousAlternatives + [ syntaxForm1All + , syntaxForm1Filter + , shadowingAlternatives + [ syntaxForm1Component pcinfo + , syntaxForm1Package pinfo + ] + ] + , syntaxForm1Component ocinfo + , syntaxForm1Module cinfo + , syntaxForm1File pinfo + ] + + -- two-component partially qualified forms + -- fully qualified form for 'all' + , syntaxForm2MetaAll + , syntaxForm2AllFilter + , syntaxForm2NamespacePackage pinfo + , syntaxForm2PackageComponent pinfo + , syntaxForm2PackageFilter pinfo + , syntaxForm2KindComponent cinfo + , shadowingAlternatives + [ syntaxForm2PackageModule pinfo + , syntaxForm2PackageFile pinfo + ] + , shadowingAlternatives + [ syntaxForm2ComponentModule cinfo + , syntaxForm2ComponentFile cinfo + ] + + -- rarely used partially qualified forms + , syntaxForm3PackageKindComponent pinfo + , shadowingAlternatives + [ syntaxForm3PackageComponentModule pinfo + , syntaxForm3PackageComponentFile pinfo + ] + , shadowingAlternatives + [ syntaxForm3KindComponentModule cinfo + , syntaxForm3KindComponentFile cinfo + ] + , syntaxForm3NamespacePackageFilter pinfo + + -- fully-qualified forms for all and cwd with filter + , syntaxForm3MetaAllFilter + , syntaxForm3MetaCwdFilter + + -- fully-qualified form for package and package with filter + , syntaxForm3MetaNamespacePackage pinfo + , syntaxForm4MetaNamespacePackageFilter pinfo + + -- fully-qualified forms for component, module and file + , syntaxForm5MetaNamespacePackageKindComponent pinfo + , syntaxForm7MetaNamespacePackageKindComponentNamespaceModule pinfo + , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile pinfo + ] + where + ambiguousAlternatives = foldr1 AmbiguousAlternatives + shadowingAlternatives = foldr1 ShadowingAlternatives + pinfo = ppinfo ++ opinfo + cinfo = concatMap pinfoComponents pinfo + pcinfo = concatMap pinfoComponents ppinfo + ocinfo = concatMap pinfoComponents opinfo + + +-- | Syntax: "all" to select all packages in the project +-- +-- > cabal build all +-- +syntaxForm1All :: Syntax +syntaxForm1All = + syntaxForm1 render $ \str1 _fstatus1 -> do + guardMetaAll str1 + return (TargetAllPackages Nothing) + where + render (TargetAllPackages Nothing) = + [TargetStringFileStatus1 "all" noFileStatus] + render _ = [] + +-- | Syntax: filter +-- +-- > cabal build tests +-- +syntaxForm1Filter :: Syntax +syntaxForm1Filter = + syntaxForm1 render $ \str1 _fstatus1 -> do + kfilter <- matchComponentKindFilter str1 + return (TargetPackage TargetImplicitCwd dummyPackageInfo (Just kfilter)) + where + render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = + [TargetStringFileStatus1 (dispF kfilter) noFileStatus] + render _ = [] + +-- Only used for TargetPackage TargetImplicitCwd +dummyPackageInfo :: PackageInfo +dummyPackageInfo = + PackageInfo { + pinfoId = PackageIdentifier + (mkPackageName "dummyPackageInfo") + (mkVersion []), + pinfoDirectory = unused, + pinfoPackageFile = unused, + pinfoComponents = unused + } + where + unused = error "dummyPackageInfo" + +-- | Syntax: package (name, dir or file) +-- +-- > cabal build foo +-- > cabal build ../bar ../bar/bar.cabal +-- +syntaxForm1Package :: [PackageInfo] -> Syntax +syntaxForm1Package pinfo = + syntaxForm1 render $ \str1 fstatus1 -> do + guardPackage str1 fstatus1 + p <- matchPackage pinfo str1 fstatus1 + return (TargetPackage TargetExplicitNamed p Nothing) + where + render (TargetPackage TargetExplicitNamed p Nothing) = + [TargetStringFileStatus1 (dispP p) noFileStatus] + render _ = [] + +-- | Syntax: component +-- +-- > cabal build foo +-- +syntaxForm1Component :: [ComponentInfo] -> Syntax +syntaxForm1Component cs = + syntaxForm1 render $ \str1 _fstatus1 -> do + guardComponentName str1 + c <- matchComponentName cs str1 + return (TargetComponent (cinfoPackage c) (cinfoName c) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus1 (dispC p c) noFileStatus] + render _ = [] + +-- | Syntax: module +-- +-- > cabal build Data.Foo +-- +syntaxForm1Module :: [ComponentInfo] -> Syntax +syntaxForm1Module cs = + syntaxForm1 render $ \str1 _fstatus1 -> do + guardModuleName str1 + let ms = [ (m,c) | c <- cs, m <- cinfoModules c ] + (m,c) <- matchModuleNameAnd ms str1 + return (TargetComponent (cinfoPackage c) (cinfoName c) (ModuleTarget m)) + where + render (TargetComponent _p _c (ModuleTarget m)) = + [TargetStringFileStatus1 (dispM m) noFileStatus] + render _ = [] + +-- | Syntax: file name +-- +-- > cabal build Data/Foo.hs bar/Main.hsc +-- +syntaxForm1File :: [PackageInfo] -> Syntax +syntaxForm1File ps = + -- Note there's a bit of an inconsistency here vs the other syntax forms + -- for files. For the single-part syntax the target has to point to a file + -- that exists (due to our use of matchPackageDirectoryPrefix), whereas for + -- all the other forms we don't require that. + syntaxForm1 render $ \str1 fstatus1 -> + expecting "file" str1 $ do + (pkgfile, p) <- matchPackageDirectoryPrefix ps fstatus1 + orNoThingIn "package" (display (packageName p)) $ do + (filepath, c) <- matchComponentFile (pinfoComponents p) pkgfile + return (TargetComponent p (cinfoName c) (FileTarget filepath)) + where + render (TargetComponent _p _c (FileTarget f)) = + [TargetStringFileStatus1 f noFileStatus] + render _ = [] + +--- + +-- | Syntax: :all +-- +-- > cabal build :all +-- +syntaxForm2MetaAll :: Syntax +syntaxForm2MetaAll = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardNamespaceMeta str1 + guardMetaAll str2 + return (TargetAllPackages Nothing) + where + render (TargetAllPackages Nothing) = + [TargetStringFileStatus2 "" noFileStatus "all"] + render _ = [] + +-- | Syntax: all : filer +-- +-- > cabal build all:tests +-- +syntaxForm2AllFilter :: Syntax +syntaxForm2AllFilter = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardMetaAll str1 + kfilter <- matchComponentKindFilter str2 + return (TargetAllPackages (Just kfilter)) + where + render (TargetAllPackages (Just kfilter)) = + [TargetStringFileStatus2 "all" noFileStatus (dispF kfilter)] + render _ = [] + +-- | Syntax: package : filer +-- +-- > cabal build foo:tests +-- +syntaxForm2PackageFilter :: [PackageInfo] -> Syntax +syntaxForm2PackageFilter ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + p <- matchPackage ps str1 fstatus1 + kfilter <- matchComponentKindFilter str2 + return (TargetPackage TargetExplicitNamed p (Just kfilter)) + where + render (TargetPackage TargetExplicitNamed p (Just kfilter)) = + [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)] + render _ = [] + +-- | Syntax: pkg : package name +-- +-- > cabal build pkg:foo +-- +syntaxForm2NamespacePackage :: [PackageInfo] -> Syntax +syntaxForm2NamespacePackage pinfo = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardNamespacePackage str1 + guardPackageName str2 + p <- matchPackage pinfo str2 noFileStatus + return (TargetPackage TargetExplicitNamed p Nothing) + where + render (TargetPackage TargetExplicitNamed p Nothing) = + [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)] + render _ = [] + +-- | Syntax: package : component +-- +-- > cabal build foo:foo +-- > cabal build ./foo:foo +-- > cabal build ./foo.cabal:foo +-- +syntaxForm2PackageComponent :: [PackageInfo] -> Syntax +syntaxForm2PackageComponent ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + guardComponentName str2 + p <- matchPackage ps str1 fstatus1 + orNoThingIn "package" (display (packageName p)) $ do + c <- matchComponentName (pinfoComponents p) str2 + return (TargetComponent p (cinfoName c) WholeComponent) + --TODO: the error here ought to say there's no component by that name in + -- this package, and name the package + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)] + render _ = [] + +-- | Syntax: namespace : component +-- +-- > cabal build lib:foo exe:foo +-- +syntaxForm2KindComponent :: [ComponentInfo] -> Syntax +syntaxForm2KindComponent cs = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + return (TargetComponent (cinfoPackage c) (cinfoName c) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus2 (dispK c) noFileStatus (dispC p c)] + render _ = [] + +-- | Syntax: package : module +-- +-- > cabal build foo:Data.Foo +-- > cabal build ./foo:Data.Foo +-- > cabal build ./foo.cabal:Data.Foo +-- +syntaxForm2PackageModule :: [PackageInfo] -> Syntax +syntaxForm2PackageModule ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + guardModuleName str2 + p <- matchPackage ps str1 fstatus1 + orNoThingIn "package" (display (packageName p)) $ do + let ms = [ (m,c) | c <- pinfoComponents p, m <- cinfoModules c ] + (m,c) <- matchModuleNameAnd ms str2 + return (TargetComponent p (cinfoName c) (ModuleTarget m)) + where + render (TargetComponent p _c (ModuleTarget m)) = + [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)] + render _ = [] + +-- | Syntax: component : module +-- +-- > cabal build foo:Data.Foo +-- +syntaxForm2ComponentModule :: [ComponentInfo] -> Syntax +syntaxForm2ComponentModule cs = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardComponentName str1 + guardModuleName str2 + c <- matchComponentName cs str1 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str2 + return (TargetComponent (cinfoPackage c) (cinfoName c) + (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus2 (dispC p c) noFileStatus (dispM m)] + render _ = [] + +-- | Syntax: package : filename +-- +-- > cabal build foo:Data/Foo.hs +-- > cabal build ./foo:Data/Foo.hs +-- > cabal build ./foo.cabal:Data/Foo.hs +-- +syntaxForm2PackageFile :: [PackageInfo] -> Syntax +syntaxForm2PackageFile ps = + syntaxForm2 render $ \str1 fstatus1 str2 -> do + guardPackage str1 fstatus1 + p <- matchPackage ps str1 fstatus1 + orNoThingIn "package" (display (packageName p)) $ do + (filepath, c) <- matchComponentFile (pinfoComponents p) str2 + return (TargetComponent p (cinfoName c) (FileTarget filepath)) + where + render (TargetComponent p _c (FileTarget f)) = + [TargetStringFileStatus2 (dispP p) noFileStatus f] + render _ = [] + +-- | Syntax: component : filename +-- +-- > cabal build foo:Data/Foo.hs +-- +syntaxForm2ComponentFile :: [ComponentInfo] -> Syntax +syntaxForm2ComponentFile cs = + syntaxForm2 render $ \str1 _fstatus1 str2 -> do + guardComponentName str1 + c <- matchComponentName cs str1 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath, _) <- matchComponentFile [c] str2 + return (TargetComponent (cinfoPackage c) (cinfoName c) + (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus2 (dispC p c) noFileStatus f] + render _ = [] + +--- + +-- | Syntax: :all : filter +-- +-- > cabal build :all:tests +-- +syntaxForm3MetaAllFilter :: Syntax +syntaxForm3MetaAllFilter = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespaceMeta str1 + guardMetaAll str2 + kfilter <- matchComponentKindFilter str3 + return (TargetAllPackages (Just kfilter)) + where + render (TargetAllPackages (Just kfilter)) = + [TargetStringFileStatus3 "" noFileStatus "all" (dispF kfilter)] + render _ = [] + +syntaxForm3MetaCwdFilter :: Syntax +syntaxForm3MetaCwdFilter = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespaceMeta str1 + guardNamespaceCwd str2 + kfilter <- matchComponentKindFilter str3 + return (TargetPackage TargetImplicitCwd dummyPackageInfo (Just kfilter)) + where + render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = + [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)] + render _ = [] + +-- | Syntax: :pkg : package name +-- +-- > cabal build :pkg:foo +-- +syntaxForm3MetaNamespacePackage :: [PackageInfo] -> Syntax +syntaxForm3MetaNamespacePackage pinfo = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + p <- matchPackage pinfo str3 noFileStatus + return (TargetPackage TargetExplicitNamed p Nothing) + where + render (TargetPackage TargetExplicitNamed p Nothing) = + [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)] + render _ = [] + +-- | Syntax: package : namespace : component +-- +-- > cabal build foo:lib:foo +-- > cabal build foo/:lib:foo +-- > cabal build foo.cabal:lib:foo +-- +syntaxForm3PackageKindComponent :: [PackageInfo] -> Syntax +syntaxForm3PackageKindComponent ps = + syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do + guardPackage str1 fstatus1 + ckind <- matchComponentKind str2 + guardComponentName str3 + p <- matchPackage ps str1 fstatus1 + orNoThingIn "package" (display (packageName p)) $ do + c <- matchComponentKindAndName (pinfoComponents p) ckind str3 + return (TargetComponent p (cinfoName c) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus3 (dispP p) noFileStatus (dispK c) (dispC p c)] + render _ = [] + +-- | Syntax: package : component : module +-- +-- > cabal build foo:foo:Data.Foo +-- > cabal build foo/:foo:Data.Foo +-- > cabal build foo.cabal:foo:Data.Foo +-- +syntaxForm3PackageComponentModule :: [PackageInfo] -> Syntax +syntaxForm3PackageComponentModule ps = + syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do + guardPackage str1 fstatus1 + guardComponentName str2 + guardModuleName str3 + p <- matchPackage ps str1 fstatus1 + orNoThingIn "package" (display (packageName p)) $ do + c <- matchComponentName (pinfoComponents p) str2 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (TargetComponent p (cinfoName c) (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)] + render _ = [] + +-- | Syntax: namespace : component : module +-- +-- > cabal build lib:foo:Data.Foo +-- +syntaxForm3KindComponentModule :: [ComponentInfo] -> Syntax +syntaxForm3KindComponentModule cs = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + guardModuleName str3 + c <- matchComponentKindAndName cs ckind str2 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (TargetComponent (cinfoPackage c) (cinfoName c) + (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus3 (dispK c) noFileStatus (dispC p c) (dispM m)] + render _ = [] + +-- | Syntax: package : component : filename +-- +-- > cabal build foo:foo:Data/Foo.hs +-- > cabal build foo/:foo:Data/Foo.hs +-- > cabal build foo.cabal:foo:Data/Foo.hs +-- +syntaxForm3PackageComponentFile :: [PackageInfo] -> Syntax +syntaxForm3PackageComponentFile ps = + syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do + guardPackage str1 fstatus1 + guardComponentName str2 + p <- matchPackage ps str1 fstatus1 + orNoThingIn "package" (display (packageName p)) $ do + c <- matchComponentName (pinfoComponents p) str2 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath, _) <- matchComponentFile [c] str3 + return (TargetComponent p (cinfoName c) (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f] + render _ = [] + +-- | Syntax: namespace : component : filename +-- +-- > cabal build lib:foo:Data/Foo.hs +-- +syntaxForm3KindComponentFile :: [ComponentInfo] -> Syntax +syntaxForm3KindComponentFile cs = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath, _) <- matchComponentFile [c] str3 + return (TargetComponent (cinfoPackage c) (cinfoName c) + (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus3 (dispK c) noFileStatus (dispC p c) f] + render _ = [] + +syntaxForm3NamespacePackageFilter :: [PackageInfo] -> Syntax +syntaxForm3NamespacePackageFilter ps = + syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do + guardNamespacePackage str1 + guardPackageName str2 + p <- matchPackage ps str2 noFileStatus + kfilter <- matchComponentKindFilter str3 + return (TargetPackage TargetExplicitNamed p (Just kfilter)) + where + render (TargetPackage TargetExplicitNamed p (Just kfilter)) = + [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)] + render _ = [] + +-- + +syntaxForm4MetaNamespacePackageFilter :: [PackageInfo] -> Syntax +syntaxForm4MetaNamespacePackageFilter ps = + syntaxForm4 render $ \str1 str2 str3 str4 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + p <- matchPackage ps str3 noFileStatus + kfilter <- matchComponentKindFilter str4 + return (TargetPackage TargetExplicitNamed p (Just kfilter)) + where + render (TargetPackage TargetExplicitNamed p (Just kfilter)) = + [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)] + render _ = [] + +-- | Syntax: :pkg : package : namespace : component +-- +-- > cabal build :pkg:foo:lib:foo +-- +syntaxForm5MetaNamespacePackageKindComponent :: [PackageInfo] -> Syntax +syntaxForm5MetaNamespacePackageKindComponent ps = + syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + ckind <- matchComponentKind str4 + guardComponentName str5 + p <- matchPackage ps str3 noFileStatus + orNoThingIn "package" (display (packageName p)) $ do + c <- matchComponentKindAndName (pinfoComponents p) ckind str5 + return (TargetComponent p (cinfoName c) WholeComponent) + where + render (TargetComponent p c WholeComponent) = + [TargetStringFileStatus5 "" "pkg" (dispP p) (dispK c) (dispC p c)] + render _ = [] + +-- | Syntax: :pkg : package : namespace : component : module : module +-- +-- > cabal build :pkg:foo:lib:foo:module:Data.Foo +-- +syntaxForm7MetaNamespacePackageKindComponentNamespaceModule + :: [PackageInfo] -> Syntax +syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = + syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + ckind <- matchComponentKind str4 + guardComponentName str5 + guardNamespaceModule str6 + p <- matchPackage ps str3 noFileStatus + orNoThingIn "package" (display (packageName p)) $ do + c <- matchComponentKindAndName (pinfoComponents p) ckind str5 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str7 + return (TargetComponent p (cinfoName c) (ModuleTarget m)) + where + render (TargetComponent p c (ModuleTarget m)) = + [TargetStringFileStatus7 "" "pkg" (dispP p) + (dispK c) (dispC p c) + "module" (dispM m)] + render _ = [] + +-- | Syntax: :pkg : package : namespace : component : file : filename +-- +-- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs +-- +syntaxForm7MetaNamespacePackageKindComponentNamespaceFile + :: [PackageInfo] -> Syntax +syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = + syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do + guardNamespaceMeta str1 + guardNamespacePackage str2 + guardPackageName str3 + ckind <- matchComponentKind str4 + guardComponentName str5 + guardNamespaceFile str6 + p <- matchPackage ps str3 noFileStatus + orNoThingIn "package" (display (packageName p)) $ do + c <- matchComponentKindAndName (pinfoComponents p) ckind str5 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath,_) <- matchComponentFile [c] str7 + return (TargetComponent p (cinfoName c) (FileTarget filepath)) + where + render (TargetComponent p c (FileTarget f)) = + [TargetStringFileStatus7 "" "pkg" (dispP p) + (dispK c) (dispC p c) + "file" f] + render _ = [] + + +--------------------------------------- +-- Syntax utils +-- + +type Match1 = String -> FileStatus -> Match (TargetSelector PackageInfo) +type Match2 = String -> FileStatus -> String + -> Match (TargetSelector PackageInfo) +type Match3 = String -> FileStatus -> String -> String + -> Match (TargetSelector PackageInfo) +type Match4 = String -> String -> String -> String + -> Match (TargetSelector PackageInfo) +type Match5 = String -> String -> String -> String -> String + -> Match (TargetSelector PackageInfo) +type Match7 = String -> String -> String -> String -> String -> String -> String + -> Match (TargetSelector PackageInfo) + +syntaxForm1 :: Renderer -> Match1 -> Syntax +syntaxForm2 :: Renderer -> Match2 -> Syntax +syntaxForm3 :: Renderer -> Match3 -> Syntax +syntaxForm4 :: Renderer -> Match4 -> Syntax +syntaxForm5 :: Renderer -> Match5 -> Syntax +syntaxForm7 :: Renderer -> Match7 -> Syntax + +syntaxForm1 render f = + Syntax QL1 match render + where + match = \(TargetStringFileStatus1 str1 fstatus1) -> + f str1 fstatus1 + +syntaxForm2 render f = + Syntax QL2 match render + where + match = \(TargetStringFileStatus2 str1 fstatus1 str2) -> + f str1 fstatus1 str2 + +syntaxForm3 render f = + Syntax QL3 match render + where + match = \(TargetStringFileStatus3 str1 fstatus1 str2 str3) -> + f str1 fstatus1 str2 str3 + +syntaxForm4 render f = + Syntax QLFull match render + where + match (TargetStringFileStatus4 str1 str2 str3 str4) + = f str1 str2 str3 str4 + match _ = mzero + +syntaxForm5 render f = + Syntax QLFull match render + where + match (TargetStringFileStatus5 str1 str2 str3 str4 str5) + = f str1 str2 str3 str4 str5 + match _ = mzero + +syntaxForm7 render f = + Syntax QLFull match render + where + match (TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7) + = f str1 str2 str3 str4 str5 str6 str7 + match _ = mzero + +dispP :: Package p => p -> String +dispP = display . packageName + +dispC :: Package p => p -> ComponentName -> String +dispC = componentStringName + +dispK :: ComponentName -> String +dispK = showComponentKindShort . componentKind + +dispF :: ComponentKind -> String +dispF = showComponentKindFilterShort + +dispM :: ModuleName -> String +dispM = display + + +------------------------------- +-- Package and component info +-- + +data PackageInfo = PackageInfo { + pinfoId :: PackageId, + pinfoDirectory :: Maybe (FilePath, FilePath), + pinfoPackageFile :: Maybe (FilePath, FilePath), + pinfoComponents :: [ComponentInfo] + } + -- not instance of Show due to recursive construction + +data ComponentInfo = ComponentInfo { + cinfoName :: ComponentName, + cinfoStrName :: ComponentStringName, + cinfoPackage :: PackageInfo, + cinfoSrcDirs :: [FilePath], + cinfoModules :: [ModuleName], + cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) + cinfoCFiles :: [FilePath], + cinfoJsFiles :: [FilePath] + } + -- not instance of Show due to recursive construction + +type ComponentStringName = String + +instance Package PackageInfo where + packageId = pinfoId + +selectPackageInfo :: (Applicative m, Monad m) => DirActions m + -> SourcePackage (PackageLocation a) -> m PackageInfo +selectPackageInfo dirActions@DirActions{..} + SourcePackage { + packageDescription = pkg, + packageSource = loc + } = do + (pkgdir, pkgfile) <- + case loc of + --TODO: local tarballs, remote tarballs etc + LocalUnpackedPackage dir -> do + dirabs <- canonicalizePath dir + dirrel <- makeRelativeToCwd dirActions dirabs + --TODO: ought to get this earlier in project reading + let fileabs = dirabs display (packageName pkg) <.> "cabal" + filerel = dirrel display (packageName pkg) <.> "cabal" + exists <- doesFileExist fileabs + return ( Just (dirabs, dirrel) + , if exists then Just (fileabs, filerel) else Nothing + ) + _ -> return (Nothing, Nothing) + let pinfo = + PackageInfo { + pinfoId = packageId pkg, + pinfoDirectory = pkgdir, + pinfoPackageFile = pkgfile, + pinfoComponents = selectComponentInfo pinfo + (flattenPackageDescription pkg) + } + return pinfo + + +selectComponentInfo :: PackageInfo -> PackageDescription -> [ComponentInfo] +selectComponentInfo pinfo pkg = + [ ComponentInfo { + cinfoName = componentName c, + cinfoStrName = componentStringName pkg (componentName c), + cinfoPackage = pinfo, + cinfoSrcDirs = ordNub (hsSourceDirs bi), +-- [ pkgroot srcdir +-- | (pkgroot,_) <- maybeToList (pinfoDirectory pinfo) +-- , srcdir <- hsSourceDirs bi ], + cinfoModules = ordNub (componentModules c), + cinfoHsFiles = ordNub (componentHsFiles c), + cinfoCFiles = ordNub (cSources bi), + cinfoJsFiles = ordNub (jsSources bi) + } + | c <- pkgComponents pkg + , let bi = componentBuildInfo c ] + + +componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName +componentStringName pkg CLibName = display (packageName pkg) +componentStringName _ (CSubLibName name) = unUnqualComponentName name +componentStringName _ (CFLibName name) = unUnqualComponentName name +componentStringName _ (CExeName name) = unUnqualComponentName name +componentStringName _ (CTestName name) = unUnqualComponentName name +componentStringName _ (CBenchName name) = unUnqualComponentName name + +componentModules :: Component -> [ModuleName] +-- I think it's unlikely users will ask to build a requirement +-- which is not mentioned locally. +componentModules (CLib lib) = explicitLibModules lib +componentModules (CFLib flib) = foreignLibModules flib +componentModules (CExe exe) = exeModules exe +componentModules (CTest test) = testModules test +componentModules (CBench bench) = benchmarkModules bench + +componentHsFiles :: Component -> [FilePath] +componentHsFiles (CExe exe) = [modulePath exe] +componentHsFiles (CTest TestSuite { + testInterface = TestSuiteExeV10 _ mainfile + }) = [mainfile] +componentHsFiles (CBench Benchmark { + benchmarkInterface = BenchmarkExeV10 _ mainfile + }) = [mainfile] +componentHsFiles _ = [] + + +------------------------------ +-- Matching meta targets +-- + +guardNamespaceMeta :: String -> Match () +guardNamespaceMeta = guardToken [""] "meta namespace" + +guardMetaAll :: String -> Match () +guardMetaAll = guardToken ["all"] "meta-target 'all'" + +guardNamespacePackage :: String -> Match () +guardNamespacePackage = guardToken ["pkg", "package"] "'pkg' namespace" + +guardNamespaceCwd :: String -> Match () +guardNamespaceCwd = guardToken ["cwd"] "'cwd' namespace" + +guardNamespaceModule :: String -> Match () +guardNamespaceModule = guardToken ["mod", "module"] "'module' namespace" + +guardNamespaceFile :: String -> Match () +guardNamespaceFile = guardToken ["file"] "'file' namespace" + +guardToken :: [String] -> String -> String -> Match () +guardToken tokens msg s + | caseFold s `elem` tokens = increaseConfidence + | otherwise = matchErrorExpected msg s + + +------------------------------ +-- Matching component kinds +-- + +componentKind :: ComponentName -> ComponentKind +componentKind CLibName = LibKind +componentKind (CSubLibName _) = LibKind +componentKind (CFLibName _) = FLibKind +componentKind (CExeName _) = ExeKind +componentKind (CTestName _) = TestKind +componentKind (CBenchName _) = BenchKind + +cinfoKind :: ComponentInfo -> ComponentKind +cinfoKind = componentKind . cinfoName + +matchComponentKind :: String -> Match ComponentKind +matchComponentKind s + | s' `elem` liblabels = increaseConfidence >> return LibKind + | s' `elem` fliblabels = increaseConfidence >> return FLibKind + | s' `elem` exelabels = increaseConfidence >> return ExeKind + | s' `elem` testlabels = increaseConfidence >> return TestKind + | s' `elem` benchlabels = increaseConfidence >> return BenchKind + | otherwise = matchErrorExpected "component kind" s + where + s' = caseFold s + liblabels = ["lib", "library"] + fliblabels = ["flib", "foreign-library"] + exelabels = ["exe", "executable"] + testlabels = ["tst", "test", "test-suite"] + benchlabels = ["bench", "benchmark"] + +matchComponentKindFilter :: String -> Match ComponentKind +matchComponentKindFilter s + | s' `elem` liblabels = increaseConfidence >> return LibKind + | s' `elem` fliblabels = increaseConfidence >> return FLibKind + | s' `elem` exelabels = increaseConfidence >> return ExeKind + | s' `elem` testlabels = increaseConfidence >> return TestKind + | s' `elem` benchlabels = increaseConfidence >> return BenchKind + | otherwise = matchErrorExpected "component kind filter" s + where + s' = caseFold s + liblabels = ["libs", "libraries"] + fliblabels = ["flibs", "foreign-libraries"] + exelabels = ["exes", "executables"] + testlabels = ["tests", "test-suites"] + benchlabels = ["benches", "benchmarks"] + +showComponentKind :: ComponentKind -> String +showComponentKind LibKind = "library" +showComponentKind FLibKind = "foreign library" +showComponentKind ExeKind = "executable" +showComponentKind TestKind = "test-suite" +showComponentKind BenchKind = "benchmark" + +showComponentKindShort :: ComponentKind -> String +showComponentKindShort LibKind = "lib" +showComponentKindShort FLibKind = "flib" +showComponentKindShort ExeKind = "exe" +showComponentKindShort TestKind = "test" +showComponentKindShort BenchKind = "bench" + +showComponentKindFilterShort :: ComponentKind -> String +showComponentKindFilterShort LibKind = "libs" +showComponentKindFilterShort FLibKind = "flibs" +showComponentKindFilterShort ExeKind = "exes" +showComponentKindFilterShort TestKind = "tests" +showComponentKindFilterShort BenchKind = "benchmarks" + + +------------------------------ +-- Matching package targets +-- + +guardPackage :: String -> FileStatus -> Match () +guardPackage str fstatus = + guardPackageName str + <|> guardPackageDir str fstatus + <|> guardPackageFile str fstatus + + +guardPackageName :: String -> Match () +guardPackageName s + | validPackageName s = increaseConfidence + | otherwise = matchErrorExpected "package name" s + +validPackageName :: String -> Bool +validPackageName s = + all validPackageNameChar s + && not (null s) + where + validPackageNameChar c = isAlphaNum c || c == '-' + + +guardPackageDir :: String -> FileStatus -> Match () +guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence +guardPackageDir str _ = matchErrorExpected "package directory" str + + +guardPackageFile :: String -> FileStatus -> Match () +guardPackageFile _ (FileStatusExistsFile file) + | takeExtension file == ".cabal" + = increaseConfidence +guardPackageFile str _ = matchErrorExpected "package .cabal file" str + + +matchPackage :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo +matchPackage pinfo = \str fstatus -> + orNoThingIn "project" "" $ + matchPackageName pinfo str + (matchPackageDir pinfo str fstatus + <|> matchPackageFile pinfo str fstatus) + + +matchPackageName :: [PackageInfo] -> String -> Match PackageInfo +matchPackageName ps = \str -> do + guard (validPackageName str) + orNoSuchThing "package" str + (map (display . packageName) ps) $ + increaseConfidenceFor $ + matchInexactly caseFold (display . packageName) ps str + + +matchPackageDir :: [PackageInfo] + -> String -> FileStatus -> Match PackageInfo +matchPackageDir ps = \str fstatus -> + case fstatus of + FileStatusExistsDir canondir -> + orNoSuchThing "package directory" str (map (snd . fst) dirs) $ + increaseConfidenceFor $ + fmap snd $ matchExactly (fst . fst) dirs canondir + _ -> mzero + where + dirs = [ ((dabs,drel),p) + | p@PackageInfo{ pinfoDirectory = Just (dabs,drel) } <- ps ] + + +matchPackageFile :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo +matchPackageFile ps = \str fstatus -> do + case fstatus of + FileStatusExistsFile canonfile -> + orNoSuchThing "package .cabal file" str (map (snd . fst) files) $ + increaseConfidenceFor $ + fmap snd $ matchExactly (fst . fst) files canonfile + _ -> mzero + where + files = [ ((fabs,frel),p) + | p@PackageInfo{ pinfoPackageFile = Just (fabs,frel) } <- ps ] + +--TODO: test outcome when dir exists but doesn't match any known one + +--TODO: perhaps need another distinction, vs no such thing, point is the +-- thing is not known, within the project, but could be outside project + + +------------------------------ +-- Matching component targets +-- + + +guardComponentName :: String -> Match () +guardComponentName s + | all validComponentChar s + && not (null s) = increaseConfidence + | otherwise = matchErrorExpected "component name" s + where + validComponentChar c = isAlphaNum c || c == '.' + || c == '_' || c == '-' || c == '\'' + + +matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo +matchComponentName cs str = + orNoSuchThing "component" str (map cinfoStrName cs) + $ increaseConfidenceFor + $ matchInexactly caseFold cinfoStrName cs str + + +matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String + -> Match ComponentInfo +matchComponentKindAndName cs ckind str = + orNoSuchThing (showComponentKind ckind ++ " component") str + (map render cs) + $ increaseConfidenceFor + $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) + (\c -> (cinfoKind c, cinfoStrName c)) + cs + (ckind, str) + where + render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c + + +------------------------------ +-- Matching module targets +-- + +guardModuleName :: String -> Match () +guardModuleName s = + case simpleParse s :: Maybe ModuleName of + Just _ -> increaseConfidence + _ | all validModuleChar s + && not (null s) -> return () + | otherwise -> matchErrorExpected "module name" s + where + validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' + + +matchModuleName :: [ModuleName] -> String -> Match ModuleName +matchModuleName ms str = + orNoSuchThing "module" str (map display ms) + $ increaseConfidenceFor + $ matchInexactly caseFold display ms str + + +matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a) +matchModuleNameAnd ms str = + orNoSuchThing "module" str (map (display . fst) ms) + $ increaseConfidenceFor + $ matchInexactly caseFold (display . fst) ms str + + +------------------------------ +-- Matching file targets +-- + +matchPackageDirectoryPrefix :: [PackageInfo] -> FileStatus + -> Match (FilePath, PackageInfo) +matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) = + increaseConfidenceFor $ + matchDirectoryPrefix pkgdirs filepath + where + pkgdirs = [ (dir, p) + | p@PackageInfo { pinfoDirectory = Just (dir,_) } <- ps ] +matchPackageDirectoryPrefix _ _ = mzero + + +matchComponentFile :: [ComponentInfo] -> String + -> Match (FilePath, ComponentInfo) +matchComponentFile cs str = + orNoSuchThing "file" str [] $ + matchComponentModuleFile cs str + <|> matchComponentOtherFile cs str + + +matchComponentOtherFile :: [ComponentInfo] -> String + -> Match (FilePath, ComponentInfo) +matchComponentOtherFile cs = + matchFile + [ (file, c) + | c <- cs + , file <- cinfoHsFiles c + ++ cinfoCFiles c + ++ cinfoJsFiles c + ] + + +matchComponentModuleFile :: [ComponentInfo] -> String + -> Match (FilePath, ComponentInfo) +matchComponentModuleFile cs str = do + matchFile + [ (normalise (d toFilePath m), c) + | c <- cs + , d <- cinfoSrcDirs c + , m <- cinfoModules c + ] + (dropExtension (normalise str)) + +-- utils + +matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) +matchFile fs = + increaseConfidenceFor + . matchInexactly caseFold fst fs + +matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) +matchDirectoryPrefix dirs filepath = + tryEach $ + [ (file, x) + | (dir,x) <- dirs + , file <- maybeToList (stripDirectory dir) ] + where + stripDirectory :: FilePath -> Maybe FilePath + stripDirectory dir = + joinPath `fmap` stripPrefix (splitDirectories dir) filepathsplit + + filepathsplit = splitDirectories filepath + + +------------------------------ +-- Matching monad +-- + +-- | A matcher embodies a way to match some input as being some recognised +-- value. In particular it deals with multiple and ambiguous matches. +-- +-- There are various matcher primitives ('matchExactly', 'matchInexactly'), +-- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we +-- can run a matcher against an input using 'findMatch'. +-- +data Match a = NoMatch Confidence [MatchError] + | ExactMatch Confidence [a] + | InexactMatch Confidence [a] + deriving Show + +type Confidence = Int + +data MatchError = MatchErrorExpected String String -- thing got + | MatchErrorNoSuch String String [String] -- thing got alts + | MatchErrorIn String String MatchError -- kind thing + deriving (Show, Eq) + + +instance Functor Match where + fmap _ (NoMatch d ms) = NoMatch d ms + fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) + fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) + +instance Applicative Match where + pure a = ExactMatch 0 [a] + (<*>) = ap + +instance Alternative Match where + empty = NoMatch 0 [] + (<|>) = matchPlus + +instance Monad Match where + return = pure + NoMatch d ms >>= _ = NoMatch d ms + ExactMatch d xs >>= f = addDepth d + $ msum (map f xs) + InexactMatch d xs >>= f = addDepth d . forceInexact + $ msum (map f xs) + +instance MonadPlus Match where + mzero = empty + mplus = matchPlus + +() :: Match a -> Match a -> Match a +() = matchPlusShadowing + +infixl 3 + +addDepth :: Confidence -> Match a -> Match a +addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs +addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs +addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs + +forceInexact :: Match a -> Match a +forceInexact (ExactMatch d ys) = InexactMatch d ys +forceInexact m = m + +-- | Combine two matchers. Exact matches are used over inexact matches +-- but if we have multiple exact, or inexact then the we collect all the +-- ambiguous matches. +-- +-- This operator is associative, has unit 'mzero' and is also commutative. +-- +matchPlus :: Match a -> Match a -> Match a +matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = + ExactMatch (max d1 d2) (xs ++ xs') +matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a +matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a +matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b +matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = + InexactMatch (max d1 d2) (xs ++ xs') +matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a +matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b +matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b +matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') + | d1 > d2 = a + | d1 < d2 = b + | otherwise = NoMatch d1 (ms ++ ms') + +-- | Combine two matchers. This is similar to 'matchPlus' with the +-- difference that an exact match from the left matcher shadows any exact +-- match on the right. Inexact matches are still collected however. +-- +-- This operator is associative, has unit 'mzero' and is not commutative. +-- +matchPlusShadowing :: Match a -> Match a -> Match a +matchPlusShadowing a@(ExactMatch _ _) _ = a +matchPlusShadowing a b = matchPlus a b + + +------------------------------ +-- Various match primitives +-- + +matchErrorExpected :: String -> String -> Match a +matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] + +matchErrorNoSuch :: String -> String -> [String] -> Match a +matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts] + +expecting :: String -> String -> Match a -> Match a +expecting thing got (NoMatch 0 _) = matchErrorExpected thing got +expecting _ _ m = m + +orNoSuchThing :: String -> String -> [String] -> Match a -> Match a +orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts +orNoSuchThing _ _ _ m = m + +orNoThingIn :: String -> String -> Match a -> Match a +orNoThingIn kind name (NoMatch n ms) = + NoMatch n [ MatchErrorIn kind name m | m <- ms ] +orNoThingIn _ _ m = m + +increaseConfidence :: Match () +increaseConfidence = ExactMatch 1 [()] + +increaseConfidenceFor :: Match a -> Match a +increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r + +nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a +nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs +nubMatchesBy eq (ExactMatch d xs) = ExactMatch d (nubBy eq xs) +nubMatchesBy eq (InexactMatch d xs) = InexactMatch d (nubBy eq xs) + +-- | Lift a list of matches to an exact match. +-- +exactMatches, inexactMatches :: [a] -> Match a + +exactMatches [] = mzero +exactMatches xs = ExactMatch 0 xs + +inexactMatches [] = mzero +inexactMatches xs = InexactMatch 0 xs + +tryEach :: [a] -> Match a +tryEach = exactMatches + + +------------------------------ +-- Top level match runner +-- + +-- | Given a matcher and a key to look up, use the matcher to find all the +-- possible matches. There may be 'None', a single 'Unambiguous' match or +-- you may have an 'Ambiguous' match with several possibilities. +-- +findMatch :: Match a -> MaybeAmbiguous a +findMatch match = case match of + NoMatch _ msgs -> None msgs + ExactMatch _ [x] -> Unambiguous x + InexactMatch _ [x] -> Unambiguous x + ExactMatch _ [] -> error "findMatch: impossible: ExactMatch []" + InexactMatch _ [] -> error "findMatch: impossible: InexactMatch []" + ExactMatch _ xs -> Ambiguous True xs + InexactMatch _ xs -> Ambiguous False xs + +data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous Bool [a] + deriving Show + + +------------------------------ +-- Basic matchers +-- + +-- | A primitive matcher that looks up a value in a finite 'Map'. The +-- value must match exactly. +-- +matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a) +matchExactly key xs = + \k -> case Map.lookup k m of + Nothing -> mzero + Just ys -> exactMatches ys + where + m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] + +-- | A primitive matcher that looks up a value in a finite 'Map'. It checks +-- for an exact or inexact match. We get an inexact match if the match +-- is not exact, but the canonical forms match. It takes a canonicalisation +-- function for this purpose. +-- +-- So for example if we used string case fold as the canonicalisation +-- function, then we would get case insensitive matching (but it will still +-- report an exact match when the case matches too). +-- +matchInexactly :: (Ord k, Ord k') => (k -> k') -> (a -> k) + -> [a] -> (k -> Match a) +matchInexactly cannonicalise key xs = + \k -> case Map.lookup k m of + Just ys -> exactMatches ys + Nothing -> case Map.lookup (cannonicalise k) m' of + Just ys -> inexactMatches ys + Nothing -> mzero + where + m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] + + -- the map of canonicalised keys to groups of inexact matches + m' = Map.mapKeysWith (++) cannonicalise m + + +------------------------------ +-- Utils +-- + +caseFold :: String -> String +caseFold = lowercase + + +------------------------------ +-- Example inputs +-- + +{- +ex1pinfo :: [PackageInfo] +ex1pinfo = + [ addComponent (CExeName (mkUnqualComponentName "foo-exe")) [] ["Data.Foo"] $ + PackageInfo { + pinfoId = PackageIdentifier (mkPackageName "foo") (mkVersion [1]), + pinfoDirectory = Just ("/the/foo", "foo"), + pinfoPackageFile = Just ("/the/foo/foo.cabal", "foo/foo.cabal"), + pinfoComponents = [] + } + , PackageInfo { + pinfoId = PackageIdentifier (mkPackageName "bar") (mkVersion [1]), + pinfoDirectory = Just ("/the/bar", "bar"), + pinfoPackageFile = Just ("/the/bar/bar.cabal", "bar/bar.cabal"), + pinfoComponents = [] + } + ] + where + addComponent n ds ms p = + p { + pinfoComponents = + ComponentInfo n (componentStringName (pinfoId p) n) + p ds (map mkMn ms) + [] [] [] + : pinfoComponents p + } + + mkMn :: String -> ModuleName + mkMn = ModuleName.fromString +-} +{- +stargets = + [ TargetComponent (CExeName "foo") WholeComponent + , TargetComponent (CExeName "foo") (ModuleTarget (mkMn "Foo")) + , TargetComponent (CExeName "tst") (ModuleTarget (mkMn "Foo")) + ] + where + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + +ex_pkgid :: PackageIdentifier +Just ex_pkgid = simpleParse "thelib" +-} + +{- +ex_cs :: [ComponentInfo] +ex_cs = + [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) + , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) + ] + where + mkC n ds ms = ComponentInfo n (componentStringName n) ds (map mkMn ms) + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + pkgid :: PackageIdentifier + Just pkgid = simpleParse "thelib" +-} diff --git a/cabal/cabal-install/Distribution/Client/Targets.hs b/cabal/cabal-install/Distribution/Client/Targets.hs --- a/cabal/cabal-install/Distribution/Client/Targets.hs +++ b/cabal/cabal-install/Distribution/Client/Targets.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} ----------------------------------------------------------------------------- -- | @@ -16,11 +18,6 @@ UserTarget(..), readUserTargets, - -- * Package specifiers - PackageSpecifier(..), - pkgSpecifierTarget, - pkgSpecifierConstraints, - -- * Resolving user targets to package specifiers resolveUserTargets, @@ -41,12 +38,12 @@ disambiguatePackageName, -- * User constraints + UserQualifier(..), + UserConstraintScope(..), UserConstraint(..), userConstraintPackageName, readUserConstraint, userToPackageConstraint, - dispFlagAssignment, - parseFlagAssignment, ) where @@ -55,16 +52,15 @@ import Distribution.Package ( Package(..), PackageName, unPackageName, mkPackageName - , PackageIdentifier(..), packageName, packageVersion - , Dependency(Dependency) ) + , PackageIdentifier(..), packageName, packageVersion ) +import Distribution.Types.Dependency import Distribution.Client.Types - ( PackageLocation(..) - , ResolvedPkgLoc, UnresolvedSourcePackage ) + ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage + , PackageSpecifier(..) ) -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PackageIndex (PackageIndex) import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import Distribution.Solver.Types.SourcePackage @@ -79,32 +75,30 @@ ( RepoContext(..) ) import Distribution.PackageDescription - ( GenericPackageDescription, mkFlagName, unFlagName, FlagAssignment ) -import Distribution.PackageDescription.Parse - ( readPackageDescription, parsePackageDescription, ParseResult(..) ) + ( GenericPackageDescription, parseFlagAssignment, nullFlagAssignment ) import Distribution.Version - ( nullVersion, thisVersion, anyVersion, isAnyVersion - , VersionRange ) + ( nullVersion, thisVersion, anyVersion, isAnyVersion ) import Distribution.Text ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils - ( die, warn, fromUTF8, lowercase, ignoreBOM ) + ( die', warn, lowercase ) +import Distribution.PackageDescription.Parsec + ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe ) + -- import Data.List ( find, nub ) import Data.Either ( partitionEithers ) import qualified Data.Map as Map import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Distribution.Client.GZipUtils as GZipUtils import Control.Monad (mapM) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ( (+++), (<++) ) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint - ( (<+>) ) +import Distribution.ParseUtils + ( readPToMaybe ) import System.FilePath ( takeExtension, dropExtension, takeDirectory, splitPath ) import System.Directory @@ -170,51 +164,14 @@ -- ------------------------------------------------------------ --- * Package specifier --- ------------------------------------------------------------ - --- | A fully or partially resolved reference to a package. --- -data PackageSpecifier pkg = - - -- | A partially specified reference to a package (either source or - -- installed). It is specified by package name and optionally some - -- additional constraints. Use a dependency resolver to pick a specific - -- package satisfying these constraints. - -- - NamedPackage PackageName [PackageConstraint] - - -- | A fully specified source package. - -- - | SpecificSourcePackage pkg - deriving (Eq, Show, Generic) - -instance Binary pkg => Binary (PackageSpecifier pkg) - -pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName -pkgSpecifierTarget (NamedPackage name _) = name -pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg - -pkgSpecifierConstraints :: Package pkg - => PackageSpecifier pkg -> [LabeledPackageConstraint] -pkgSpecifierConstraints (NamedPackage _ constraints) = map toLpc constraints - where - toLpc pc = LabeledPackageConstraint pc ConstraintSourceUserTarget -pkgSpecifierConstraints (SpecificSourcePackage pkg) = - [LabeledPackageConstraint pc ConstraintSourceUserTarget] - where - pc = PackageConstraintVersion (packageName pkg) - (thisVersion (packageVersion pkg)) - --- ------------------------------------------------------------ -- * Parsing and checking user targets -- ------------------------------------------------------------ readUserTargets :: Verbosity -> [String] -> IO [UserTarget] -readUserTargets _verbosity targetStrs = do +readUserTargets verbosity targetStrs = do (problems, targets) <- liftM partitionEithers (mapM readUserTarget targetStrs) - reportUserTargetProblems problems + reportUserTargetProblems verbosity problems return targets @@ -301,16 +258,12 @@ v | v == nullVersion -> Dependency (packageName p) anyVersion | otherwise -> Dependency (packageName p) (thisVersion v) -readPToMaybe :: Parse.ReadP a a -> String -> Maybe a -readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str - , all isSpace s ] - -reportUserTargetProblems :: [UserTargetProblem] -> IO () -reportUserTargetProblems problems = do +reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO () +reportUserTargetProblems verbosity problems = do case [ target | UserTargetUnrecognised target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "Unrecognised target '" ++ name ++ "'." | name <- target ] @@ -322,18 +275,18 @@ case [ () | UserTargetBadWorldPkg <- problems ] of [] -> return () - _ -> die "The special 'world' target does not take any version." + _ -> die' verbosity "The special 'world' target does not take any version." case [ target | UserTargetNonexistantFile target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "The file does not exist '" ++ name ++ "'." | name <- target ] case [ target | UserTargetUnexpectedFile target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "Unrecognised file target '" ++ name ++ "'." | name <- target ] @@ -342,7 +295,7 @@ case [ target | UserTargetUnexpectedUriScheme target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "URL target not supported '" ++ name ++ "'." | name <- target ] @@ -350,7 +303,7 @@ case [ target | UserTargetUnrecognisedUri target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "Unrecognise URL target '" ++ name ++ "'." | name <- target ] @@ -377,7 +330,7 @@ -- package references packageTargets <- mapM (readPackageTarget verbosity) =<< mapM (fetchPackageTarget verbosity repoCtxt) . concat - =<< mapM (expandUserTarget worldFile) userTargets + =<< mapM (expandUserTarget verbosity worldFile) userTargets -- users are allowed to give package names case-insensitively, so we must -- disambiguate named package references @@ -401,13 +354,13 @@ -- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. -- data PackageTarget pkg = - PackageTargetNamed PackageName [PackageConstraint] UserTarget + PackageTargetNamed PackageName [PackageProperty] UserTarget -- | A package identified by name, but case insensitively, so it needs -- to be resolved to the right case-sensitive name. - | PackageTargetNamedFuzzy PackageName [PackageConstraint] UserTarget + | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget | PackageTargetLocation pkg - deriving Show + deriving (Show, Functor, Foldable, Traversable) -- ------------------------------------------------------------ @@ -417,32 +370,33 @@ -- | Given a user-specified target, expand it to a bunch of package targets -- (each of which refers to only one package). -- -expandUserTarget :: FilePath +expandUserTarget :: Verbosity + -> FilePath -> UserTarget -> IO [PackageTarget (PackageLocation ())] -expandUserTarget worldFile userTarget = case userTarget of +expandUserTarget verbosity worldFile userTarget = case userTarget of UserTargetNamed (Dependency name vrange) -> - let constraints = [ PackageConstraintVersion name vrange - | not (isAnyVersion vrange) ] - in return [PackageTargetNamedFuzzy name constraints userTarget] + let props = [ PackagePropertyVersion vrange + | not (isAnyVersion vrange) ] + in return [PackageTargetNamedFuzzy name props userTarget] UserTargetWorld -> do - worldPkgs <- World.getContents worldFile + worldPkgs <- World.getContents verbosity worldFile --TODO: should we warn if there are no world targets? - return [ PackageTargetNamed name constraints userTarget + return [ PackageTargetNamed name props userTarget | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs - , let constraints = [ PackageConstraintVersion name vrange - | not (isAnyVersion vrange) ] - ++ [ PackageConstraintFlags name flags - | not (null flags) ] ] + , let props = [ PackagePropertyVersion vrange + | not (isAnyVersion vrange) ] + ++ [ PackagePropertyFlags flags + | not (nullFlagAssignment flags) ] ] UserTargetLocalDir dir -> return [ PackageTargetLocation (LocalUnpackedPackage dir) ] UserTargetLocalCabalFile file -> do let dir = takeDirectory file - _ <- tryFindPackageDesc dir (localPackageError dir) -- just as a check + _ <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check return [ PackageTargetLocation (LocalUnpackedPackage dir) ] UserTargetLocalTarball tarballFile -> @@ -466,12 +420,8 @@ -> RepoContext -> PackageTarget (PackageLocation ()) -> IO (PackageTarget ResolvedPkgLoc) -fetchPackageTarget verbosity repoCtxt target = case target of - PackageTargetNamed n cs ut -> return (PackageTargetNamed n cs ut) - PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut) - PackageTargetLocation location -> do - location' <- fetchPackage verbosity repoCtxt (fmap (const Nothing) location) - return (PackageTargetLocation location') +fetchPackageTarget verbosity repoCtxt = traverse $ + fetchPackage verbosity repoCtxt . fmap (const Nothing) -- | Given a package target that has been fetched, read the .cabal file. @@ -481,26 +431,19 @@ readPackageTarget :: Verbosity -> PackageTarget ResolvedPkgLoc -> IO (PackageTarget UnresolvedSourcePackage) -readPackageTarget verbosity target = case target of - - PackageTargetNamed pkgname constraints userTarget -> - return (PackageTargetNamed pkgname constraints userTarget) - - PackageTargetNamedFuzzy pkgname constraints userTarget -> - return (PackageTargetNamedFuzzy pkgname constraints userTarget) - - PackageTargetLocation location -> case location of +readPackageTarget verbosity = traverse modifyLocation + where + modifyLocation location = case location of LocalUnpackedPackage dir -> do - pkg <- tryFindPackageDesc dir (localPackageError dir) >>= - readPackageDescription verbosity - return $ PackageTargetLocation $ - SourcePackage { - packageInfoId = packageId pkg, - packageDescription = pkg, - packageSource = fmap Just location, - packageDescrOverride = Nothing - } + pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>= + readGenericPackageDescription verbosity + return $ SourcePackage { + packageInfoId = packageId pkg, + packageDescription = pkg, + packageSource = fmap Just location, + packageDescrOverride = Nothing + } LocalTarballPackage tarballFile -> readTarballPackageTarget location tarballFile tarballFile @@ -512,26 +455,24 @@ error "TODO: readPackageTarget RepoTarballPackage" -- For repo tarballs this info should be obtained from the index. - where readTarballPackageTarget location tarballFile tarballOriginalLoc = do (filename, content) <- extractTarballPackageCabalFile tarballFile tarballOriginalLoc case parsePackageDescription' content of - Nothing -> die $ "Could not parse the cabal file " + Nothing -> die' verbosity $ "Could not parse the cabal file " ++ filename ++ " in " ++ tarballFile Just pkg -> - return $ PackageTargetLocation $ - SourcePackage { - packageInfoId = packageId pkg, - packageDescription = pkg, - packageSource = fmap Just location, - packageDescrOverride = Nothing - } + return $ SourcePackage { + packageInfoId = packageId pkg, + packageDescription = pkg, + packageSource = fmap Just location, + packageDescrOverride = Nothing + } extractTarballPackageCabalFile :: FilePath -> String -> IO (FilePath, BS.ByteString) extractTarballPackageCabalFile tarballFile tarballOriginalLoc = - either (die . formatErr) return + either (die' verbosity . formatErr) return . check . accumEntryMap . Tar.filterEntries isCabalFile @@ -562,11 +503,8 @@ _ -> False parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription - parsePackageDescription' content = - case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of - ParseOk _ pkg -> Just pkg - _ -> Nothing - + parsePackageDescription' bs = + parseGenericPackageDescriptionMaybe (BS.toStrict bs) -- ------------------------------------------------------------ -- * Checking package targets @@ -593,20 +531,18 @@ disambiguatePackageTarget packageTarget = case packageTarget of PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) - PackageTargetNamed pkgname constraints userTarget + PackageTargetNamed pkgname props userTarget | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) -> Left (PackageNameUnknown pkgname userTarget) - | otherwise -> Right (NamedPackage pkgname constraints) + | otherwise -> Right (NamedPackage pkgname props) - PackageTargetNamedFuzzy pkgname constraints userTarget -> + PackageTargetNamedFuzzy pkgname props userTarget -> case disambiguatePackageName packageNameEnv pkgname of None -> Left (PackageNameUnknown pkgname userTarget) Ambiguous pkgnames -> Left (PackageNameAmbiguous pkgname pkgnames userTarget) - Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints') - where - constraints' = map (renamePackageConstraint pkgname') constraints + Unambiguous pkgname' -> Right (NamedPackage pkgname' props) -- use any extra specific available packages to help us disambiguate packageNameEnv :: PackageNameEnv @@ -622,7 +558,7 @@ case [ pkg | PackageNameUnknown pkg originalTarget <- problems , not (isUserTagetWorld originalTarget) ] of [] -> return () - pkgs -> die $ unlines + pkgs -> die' verbosity $ unlines [ "There is no package named '" ++ display name ++ "'. " | name <- pkgs ] ++ "You may need to run 'hackport update' to get the latest " @@ -630,11 +566,14 @@ case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of [] -> return () - ambiguities -> die $ unlines - [ "The package name '" ++ display name - ++ "' is ambiguous. It could be: " - ++ intercalate ", " (map display matches) - | (name, matches) <- ambiguities ] + ambiguities -> die' verbosity $ unlines + [ "There is no package named '" ++ display name ++ "'. " + ++ (if length matches > 1 + then "However, the following package names exist: " + else "However, the following package name exists: ") + ++ intercalate ", " [ "'" ++ display m ++ "'" | m <- matches] + ++ "." + | (name, matches) <- ambiguities ] case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of [] -> return () @@ -653,19 +592,22 @@ data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a] --- | Given a package name and a list of matching names, figure out which one it --- might be referring to. If there is an exact case-sensitive match then that's --- ok. If it matches just one package case-insensitively then that's also ok. --- The only problem is if it matches multiple packages case-insensitively, in --- that case it is ambiguous. +-- | Given a package name and a list of matching names, figure out +-- which one it might be referring to. If there is an exact +-- case-sensitive match then that's ok (i.e. returned via +-- 'Unambiguous'). If it matches just one package case-insensitively +-- or if it matches multiple packages case-insensitively, in that case +-- the result is 'Ambiguous'. -- +-- Note: Before cabal 2.2, when only a single package matched +-- case-insensitively it would be considered 'Unambigious'. +-- disambiguatePackageName :: PackageNameEnv -> PackageName -> MaybeAmbiguous PackageName disambiguatePackageName (PackageNameEnv pkgNameLookup) name = case nub (pkgNameLookup name) of [] -> None - [name'] -> Unambiguous name' names -> case find (name==) names of Just name' -> Unambiguous name' Nothing -> Ambiguous names @@ -701,40 +643,65 @@ -- * Package constraints -- ------------------------------------------------------------ -data UserConstraint = - UserConstraintVersion PackageName VersionRange - | UserConstraintInstalled PackageName - | UserConstraintSource PackageName - | UserConstraintFlags PackageName FlagAssignment - | UserConstraintStanzas PackageName [OptionalStanza] +-- | Version of 'Qualifier' that a user may specify on the +-- command line. +data UserQualifier = + -- | Top-level dependency. + UserQualToplevel + + -- | Setup dependency. + | UserQualSetup PackageName + + -- | Executable dependency. + | UserQualExe PackageName PackageName deriving (Eq, Show, Generic) +instance Binary UserQualifier + +-- | Version of 'ConstraintScope' that a user may specify on the +-- command line. +data UserConstraintScope = + -- | Scope that applies to the package when it has the specified qualifier. + UserQualified UserQualifier PackageName + + -- | Scope that applies to the package when it has a setup qualifier. + | UserAnySetupQualifier PackageName + + -- | Scope that applies to the package when it has any qualifier. + | UserAnyQualifier PackageName + deriving (Eq, Show, Generic) + +instance Binary UserConstraintScope + +fromUserQualifier :: UserQualifier -> Qualifier +fromUserQualifier UserQualToplevel = QualToplevel +fromUserQualifier (UserQualSetup name) = QualSetup name +fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2 + +fromUserConstraintScope :: UserConstraintScope -> ConstraintScope +fromUserConstraintScope (UserQualified q pn) = + ScopeQualified (fromUserQualifier q) pn +fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn +fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn + +-- | Version of 'PackageConstraint' that the user can specify on +-- the command line. +data UserConstraint = + UserConstraint UserConstraintScope PackageProperty + deriving (Eq, Show, Generic) + instance Binary UserConstraint userConstraintPackageName :: UserConstraint -> PackageName -userConstraintPackageName uc = case uc of - UserConstraintVersion name _ -> name - UserConstraintInstalled name -> name - UserConstraintSource name -> name - UserConstraintFlags name _ -> name - UserConstraintStanzas name _ -> name +userConstraintPackageName (UserConstraint scope _) = scopePN scope + where + scopePN (UserQualified _ pn) = pn + scopePN (UserAnyQualifier pn) = pn + scopePN (UserAnySetupQualifier pn) = pn userToPackageConstraint :: UserConstraint -> PackageConstraint --- At the moment, the types happen to be directly equivalent -userToPackageConstraint uc = case uc of - UserConstraintVersion name ver -> PackageConstraintVersion name ver - UserConstraintInstalled name -> PackageConstraintInstalled name - UserConstraintSource name -> PackageConstraintSource name - UserConstraintFlags name flags -> PackageConstraintFlags name flags - UserConstraintStanzas name stanzas -> PackageConstraintStanzas name stanzas - -renamePackageConstraint :: PackageName -> PackageConstraint -> PackageConstraint -renamePackageConstraint name pc = case pc of - PackageConstraintVersion _ ver -> PackageConstraintVersion name ver - PackageConstraintInstalled _ -> PackageConstraintInstalled name - PackageConstraintSource _ -> PackageConstraintSource name - PackageConstraintFlags _ flags -> PackageConstraintFlags name flags - PackageConstraintStanzas _ stanzas -> PackageConstraintStanzas name stanzas +userToPackageConstraint (UserConstraint scope prop) = + PackageConstraint (fromUserConstraintScope scope) prop readUserConstraint :: String -> Either String UserConstraint readUserConstraint str = @@ -743,72 +710,64 @@ Just c -> Right c where msgCannotParse = - "expected a package name followed by a constraint, which is " - ++ "either a version range, 'installed', 'source' or flags" + "expected a (possibly qualified) package name followed by a " ++ + "constraint, which is either a version range, 'installed', " ++ + "'source', 'test', 'bench', or flags" instance Text UserConstraint where - disp (UserConstraintVersion pkgname verrange) = disp pkgname - <+> disp verrange - disp (UserConstraintInstalled pkgname) = disp pkgname - <+> Disp.text "installed" - disp (UserConstraintSource pkgname) = disp pkgname - <+> Disp.text "source" - disp (UserConstraintFlags pkgname flags) = disp pkgname - <+> dispFlagAssignment flags - disp (UserConstraintStanzas pkgname stanzas) = disp pkgname - <+> dispStanzas stanzas - where - dispStanzas = Disp.hsep . map dispStanza - dispStanza TestStanzas = Disp.text "test" - dispStanza BenchStanzas = Disp.text "bench" - - parse = parse >>= parseConstraint - where - parseConstraint pkgname = - ((parse >>= return . UserConstraintVersion pkgname) - +++ (do skipSpaces1 - _ <- Parse.string "installed" - return (UserConstraintInstalled pkgname)) - +++ (do skipSpaces1 - _ <- Parse.string "source" - return (UserConstraintSource pkgname)) - +++ (do skipSpaces1 - _ <- Parse.string "test" - return (UserConstraintStanzas pkgname [TestStanzas])) - +++ (do skipSpaces1 - _ <- Parse.string "bench" - return (UserConstraintStanzas pkgname [BenchStanzas]))) - <++ (do skipSpaces1 - flags <- parseFlagAssignment - return (UserConstraintFlags pkgname flags)) - ---TODO: [code cleanup] move these somewhere else -dispFlagAssignment :: FlagAssignment -> Disp.Doc -dispFlagAssignment = Disp.hsep . map dispFlagValue - where - dispFlagValue (f, True) = Disp.char '+' <<>> dispFlagName f - dispFlagValue (f, False) = Disp.char '-' <<>> dispFlagName f - dispFlagName = Disp.text . unFlagName - -parseFlagAssignment :: Parse.ReadP r FlagAssignment -parseFlagAssignment = Parse.sepBy1 parseFlagValue skipSpaces1 - where - parseFlagValue = - (do Parse.optional (Parse.char '+') - f <- parseFlagName - return (f, True)) - +++ (do _ <- Parse.char '-' - f <- parseFlagName - return (f, False)) - parseFlagName = liftM (mkFlagName . lowercase) ident - - ident :: Parse.ReadP r String - ident = Parse.munch1 identChar >>= \s -> check s >> return s - where - identChar c = isAlphaNum c || c == '_' || c == '-' - check ('-':_) = Parse.pfail - check _ = return () - -skipSpaces1 :: Parse.ReadP r () -skipSpaces1 = Parse.satisfy isSpace >> Parse.skipSpaces + disp (UserConstraint scope prop) = + dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop + + parse = + let parseConstraintScope :: Parse.ReadP a UserConstraintScope + parseConstraintScope = + do + _ <- Parse.string "any." + pn <- parse + return (UserAnyQualifier pn) + +++ + do + _ <- Parse.string "setup." + pn <- parse + return (UserAnySetupQualifier pn) + +++ + do + -- Qualified name + pn <- parse + (return (UserQualified UserQualToplevel pn) + +++ + do _ <- Parse.string ":setup." + pn2 <- parse + return (UserQualified (UserQualSetup pn) pn2)) + -- -- TODO: Re-enable parsing of UserQualExe once we decide on a syntax. + -- + -- +++ + -- do _ <- Parse.string ":" + -- pn2 <- parse + -- _ <- Parse.string ":exe." + -- pn3 <- parse + -- return (UserQualExe pn pn2, pn3) + in do + scope <- parseConstraintScope + + -- Package property + let keyword str x = Parse.skipSpaces1 >> Parse.string str >> return x + prop <- ((parse >>= return . PackagePropertyVersion) + +++ + keyword "installed" PackagePropertyInstalled + +++ + keyword "source" PackagePropertySource + +++ + keyword "test" (PackagePropertyStanzas [TestStanzas]) + +++ + keyword "bench" (PackagePropertyStanzas [BenchStanzas])) + -- Note: the parser is left-biased here so that we + -- don't get an ambiguous parse from 'installed', + -- 'source', etc. being regarded as flags. + <++ + (Parse.skipSpaces1 >> parseFlagAssignment + >>= return . PackagePropertyFlags) + + -- Result + return (UserConstraint scope prop) 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 @@ -20,35 +20,54 @@ ----------------------------------------------------------------------------- module Distribution.Client.Types where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Package - ( PackageName, PackageId, Package(..) - , UnitId, ComponentId, HasUnitId(..) + ( Package(..), HasMungedPackageId(..), HasUnitId(..) + , PackageIdentifier(..), packageVersion, packageName , PackageInstalled(..), newSimpleUnitId ) import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, installedComponentId ) + ( InstalledPackageInfo, installedComponentId, sourceComponentName ) import Distribution.PackageDescription ( FlagAssignment ) import Distribution.Version - ( VersionRange ) + ( VersionRange, nullVersion, thisVersion ) +import Distribution.Types.ComponentId + ( ComponentId ) +import Distribution.Types.MungedPackageId + ( computeCompatPackageId ) +import Distribution.Types.PackageId + ( PackageId ) +import Distribution.Types.AnnotatedId +import Distribution.Types.UnitId + ( UnitId ) +import Distribution.Types.PackageName + ( PackageName, mkPackageName ) +import Distribution.Types.ComponentName + ( ComponentName(..) ) import Distribution.Solver.Types.PackageIndex ( PackageIndex ) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.PackageFixedDeps import Distribution.Solver.Types.SourcePackage import Distribution.Compat.Graph (IsNode(..)) +import qualified Distribution.Compat.ReadP as Parse +import Distribution.ParseUtils (parseOptCommaList) import Distribution.Simple.Utils (ordNub) +import Distribution.Text (Text(..)) -import Data.Map (Map) import Network.URI (URI(..), URIAuth(..), nullURI) import Control.Exception ( Exception, SomeException ) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import Distribution.Compat.Binary (Binary(..)) +import qualified Text.PrettyPrint as Disp newtype Username = Username { unUsername :: String } @@ -108,7 +127,7 @@ -- 'ElaboratedPackage' and 'ElaboratedComponent'. -- instance HasConfiguredId (ConfiguredPackage loc) where - configuredId pkg = ConfiguredId (packageId pkg) (confPkgId pkg) + configuredId pkg = ConfiguredId (packageId pkg) (Just CLibName) (confPkgId pkg) -- 'ConfiguredPackage' is the legacy codepath, we are guaranteed -- to never have a nontrivial 'UnitId' @@ -136,14 +155,22 @@ -- configuration parameters and dependencies have been specified). data ConfiguredId = ConfiguredId { confSrcId :: PackageId + , confCompName :: Maybe ComponentName , confInstId :: ComponentId } deriving (Eq, Ord, Generic) +annotatedIdToConfiguredId :: AnnotatedId ComponentId -> ConfiguredId +annotatedIdToConfiguredId aid = ConfiguredId { + confSrcId = ann_pid aid, + confCompName = Just (ann_cname aid), + confInstId = ann_id aid + } + instance Binary ConfiguredId instance Show ConfiguredId where - show = show . confSrcId + show cid = show (confInstId cid) instance Package ConfiguredId where packageId = confSrcId @@ -151,6 +178,9 @@ instance Package (ConfiguredPackage loc) where packageId cpkg = packageId (confPkgSource cpkg) +instance HasMungedPackageId (ConfiguredPackage loc) where + mungedId cpkg = computeCompatPackageId (packageId cpkg) Nothing + -- Never has nontrivial UnitId instance HasUnitId (ConfiguredPackage loc) where installedUnitId = newSimpleUnitId . confPkgId @@ -164,13 +194,15 @@ -- NB: This instance is slightly dangerous, in that you'll lose -- information about the specific UnitId you depended on. instance HasConfiguredId InstalledPackageInfo where - configuredId ipkg = ConfiguredId (packageId ipkg) (installedComponentId ipkg) + configuredId ipkg = ConfiguredId (packageId ipkg) + (Just (sourceComponentName ipkg)) + (installedComponentId ipkg) -- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be -- installed already, hence itself ready to be installed. newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'. deriving (Eq, Show, Generic, Package, PackageFixedDeps, - HasUnitId, PackageInstalled, Binary) + HasMungedPackageId, HasUnitId, PackageInstalled, Binary) -- Can't newtype derive this instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where @@ -183,7 +215,49 @@ -- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'. type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc + -- ------------------------------------------------------------ +-- * Package specifier +-- ------------------------------------------------------------ + +-- | A fully or partially resolved reference to a package. +-- +data PackageSpecifier pkg = + + -- | A partially specified reference to a package (either source or + -- installed). It is specified by package name and optionally some + -- required properties. Use a dependency resolver to pick a specific + -- package satisfying these properties. + -- + NamedPackage PackageName [PackageProperty] + + -- | A fully specified source package. + -- + | SpecificSourcePackage pkg + deriving (Eq, Show, Generic) + +instance Binary pkg => Binary (PackageSpecifier pkg) + +pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName +pkgSpecifierTarget (NamedPackage name _) = name +pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg + +pkgSpecifierConstraints :: Package pkg + => PackageSpecifier pkg -> [LabeledPackageConstraint] +pkgSpecifierConstraints (NamedPackage name props) = map toLpc props + where + toLpc prop = LabeledPackageConstraint + (PackageConstraint (scopeToplevel name) prop) + ConstraintSourceUserTarget +pkgSpecifierConstraints (SpecificSourcePackage pkg) = + [LabeledPackageConstraint pc ConstraintSourceUserTarget] + where + pc = PackageConstraint + (ScopeTarget $ packageName pkg) + (PackagePropertyVersion $ thisVersion (packageVersion pkg)) + + +-- ------------------------------------------------------------ -- * Package locations and repositories -- ------------------------------------------------------------ @@ -294,6 +368,11 @@ instance Binary Repo -- | Check if this is a remote repo +isRepoRemote :: Repo -> Bool +isRepoRemote RepoLocal{} = False +isRepoRemote _ = True + +-- | Extract @RemoteRepo@ from @Repo@ if remote. maybeRepoRemote :: Repo -> Maybe RemoteRepo maybeRepoRemote (RepoLocal _localDir) = Nothing maybeRepoRemote (RepoRemote r _localDir) = Just r @@ -345,3 +424,167 @@ instance Binary SomeException where put _ = return () get = fail "cannot serialise exceptions" + + +-- ------------------------------------------------------------ +-- * --allow-newer/--allow-older +-- ------------------------------------------------------------ + +-- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled, +-- it may make sense to move these definitions to the Solver.Types +-- module + +-- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag) +newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps } + deriving (Eq, Read, Show, Generic) + +-- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag) +newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps } + deriving (Eq, Read, Show, Generic) + +-- | Generic data type for policy when relaxing bounds in dependencies. +-- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending +-- on whether or not you are relaxing an lower or upper bound +-- (respectively). +data RelaxDeps = + + -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages. + -- + -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all + -- dependencies, never choose versions newer (resp. older) than allowed. + RelaxDepsSome [RelaxedDep] + + -- | Ignore upper (resp. lower) bounds in dependencies on all packages. + -- + -- __Note__: This is should be semantically equivalent to + -- + -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] + -- + -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep') + | RelaxDepsAll + deriving (Eq, Read, Show, Generic) + +-- | Dependencies can be relaxed either for all packages in the install plan, or +-- only for some packages. +data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject + deriving (Eq, Read, Show, Generic) + +-- | Specify the scope of a relaxation, i.e. limit which depending +-- packages are allowed to have their version constraints relaxed. +data RelaxDepScope = RelaxDepScopeAll + -- ^ Apply relaxation in any package + | RelaxDepScopePackage !PackageName + -- ^ Apply relaxation to in all versions of a package + | RelaxDepScopePackageId !PackageId + -- ^ Apply relaxation to a specific version of a package only + deriving (Eq, Read, Show, Generic) + +-- | Modifier for dependency relaxation +data RelaxDepMod = RelaxDepModNone -- ^ Default semantics + | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints + deriving (Eq, Read, Show, Generic) + +-- | Express whether to relax bounds /on/ @all@ packages, or a single package +data RelaxDepSubject = RelaxDepSubjectAll + | RelaxDepSubjectPkg !PackageName + deriving (Eq, Ord, Read, Show, Generic) + +instance Text RelaxedDep where + disp (RelaxedDep scope rdmod subj) = case scope of + RelaxDepScopeAll -> Disp.text "all:" Disp.<> modDep + RelaxDepScopePackage p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep + RelaxDepScopePackageId p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep + where + modDep = case rdmod of + RelaxDepModNone -> disp subj + RelaxDepModCaret -> Disp.char '^' Disp.<> disp subj + + parse = RelaxedDep <$> scopeP <*> modP <*> parse + where + -- "greedy" choices + scopeP = (pure RelaxDepScopeAll <* Parse.char '*' <* Parse.char ':') + Parse.<++ (pure RelaxDepScopeAll <* Parse.string "all:") + Parse.<++ (RelaxDepScopePackageId <$> pidP <* Parse.char ':') + Parse.<++ (RelaxDepScopePackage <$> parse <* Parse.char ':') + Parse.<++ (pure RelaxDepScopeAll) + + modP = (pure RelaxDepModCaret <* Parse.char '^') + Parse.<++ (pure RelaxDepModNone) + + -- | Stricter 'PackageId' parser which doesn't overlap with 'PackageName' parser + pidP = do + p0 <- parse + when (pkgVersion p0 == nullVersion) Parse.pfail + pure p0 + +instance Text RelaxDepSubject where + disp RelaxDepSubjectAll = Disp.text "all" + disp (RelaxDepSubjectPkg pn) = disp pn + + parse = (pure RelaxDepSubjectAll <* Parse.char '*') Parse.<++ pkgn + where + pkgn = do + pn <- parse + pure (if (pn == mkPackageName "all") + then RelaxDepSubjectAll + else RelaxDepSubjectPkg pn) + +instance Text RelaxDeps where + disp rd | not (isRelaxDeps rd) = Disp.text "none" + disp (RelaxDepsSome pkgs) = Disp.fsep . + Disp.punctuate Disp.comma . + map disp $ pkgs + disp RelaxDepsAll = Disp.text "all" + + parse = (const mempty <$> ((Parse.string "none" Parse.+++ + Parse.string "None") <* Parse.eof)) + Parse.<++ (const RelaxDepsAll <$> ((Parse.string "all" Parse.+++ + Parse.string "All" Parse.+++ + Parse.string "*") <* Parse.eof)) + Parse.<++ ( RelaxDepsSome <$> parseOptCommaList parse) + +instance Binary RelaxDeps +instance Binary RelaxDepMod +instance Binary RelaxDepScope +instance Binary RelaxDepSubject +instance Binary RelaxedDep +instance Binary AllowNewer +instance Binary AllowOlder + +-- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations +-- +-- Equivalent to @isRelaxDeps = (/= 'mempty')@ +isRelaxDeps :: RelaxDeps -> Bool +isRelaxDeps (RelaxDepsSome []) = False +isRelaxDeps (RelaxDepsSome (_:_)) = True +isRelaxDeps RelaxDepsAll = True + +-- | 'RelaxDepsAll' is the /absorbing element/ +instance Semigroup RelaxDeps where + -- identity element + RelaxDepsSome [] <> r = r + l@(RelaxDepsSome _) <> RelaxDepsSome [] = l + -- absorbing element + l@RelaxDepsAll <> _ = l + (RelaxDepsSome _) <> r@RelaxDepsAll = r + -- combining non-{identity,absorbing} elements + (RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b) + +-- | @'RelaxDepsSome' []@ is the /identity element/ +instance Monoid RelaxDeps where + mempty = RelaxDepsSome [] + mappend = (<>) + +instance Semigroup AllowNewer where + AllowNewer x <> AllowNewer y = AllowNewer (x <> y) + +instance Semigroup AllowOlder where + AllowOlder x <> AllowOlder y = AllowOlder (x <> y) + +instance Monoid AllowNewer where + mempty = AllowNewer mempty + mappend = (<>) + +instance Monoid AllowOlder where + mempty = AllowOlder mempty + mappend = (<>) diff --git a/cabal/cabal-install/Distribution/Client/Update.hs b/cabal/cabal-install/Distribution/Client/Update.hs --- a/cabal/cabal-install/Distribution/Client/Update.hs +++ b/cabal/cabal-install/Distribution/Client/Update.hs @@ -15,40 +15,46 @@ ( update ) where +import Distribution.Simple.Setup + ( fromFlag ) import Distribution.Client.Types ( Repo(..), RemoteRepo(..), maybeRepoRemote ) import Distribution.Client.HttpUtils ( DownloadResult(..) ) import Distribution.Client.FetchUtils ( downloadIndex ) +import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.IndexUtils - ( updateRepoIndexCache, Index(..) ) + ( updateRepoIndexCache, Index(..), writeIndexTimestamp + , currentIndexTimestamp ) import Distribution.Client.JobControl ( newParallelJobControl, spawnJob, collectJob ) import Distribution.Client.Setup - ( RepoContext(..) ) + ( RepoContext(..), UpdateFlags(..) ) +import Distribution.Text + ( display ) import Distribution.Verbosity - ( Verbosity ) import Distribution.Simple.Utils - ( writeFileAtomic, warn, notice ) + ( writeFileAtomic, warn, notice, noticeNoWrap ) import qualified Data.ByteString.Lazy as BS import Distribution.Client.GZipUtils (maybeDecompress) import System.FilePath (dropExtension) -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import Data.Time (getCurrentTime) +import Control.Monad import qualified Hackage.Security.Client as Sec -- | 'update' downloads the package list from all known servers -update :: Verbosity -> RepoContext -> IO () -update verbosity repoCtxt | null (repoContextRepos repoCtxt) = do +update :: Verbosity -> UpdateFlags -> RepoContext -> IO () +update verbosity _ repoCtxt | null (repoContextRepos repoCtxt) = do warn verbosity $ "No remote package servers have been specified. Usually " ++ "you would have one specified in the config file." -update verbosity repoCtxt = do +update verbosity updateFlags repoCtxt = do let repos = repoContextRepos repoCtxt - remoteRepos = catMaybes (map maybeRepoRemote repos) + remoteRepos = mapMaybe maybeRepoRemote repos case remoteRepos of [] -> return () [remoteRepo] -> @@ -58,11 +64,11 @@ $ "Downloading the latest package lists from: " : map (("- " ++) . remoteRepoName) remoteRepos jobCtrl <- newParallelJobControl (length repos) - mapM_ (spawnJob jobCtrl . updateRepo verbosity repoCtxt) repos + mapM_ (spawnJob jobCtrl . updateRepo verbosity updateFlags repoCtxt) repos mapM_ (\_ -> collectJob jobCtrl) repos -updateRepo :: Verbosity -> RepoContext -> Repo -> IO () -updateRepo verbosity repoCtxt repo = do +updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> Repo -> IO () +updateRepo verbosity updateFlags repoCtxt repo = do transport <- repoContextGetTransport repoCtxt case repo of RepoLocal{..} -> return () @@ -75,6 +81,12 @@ =<< BS.readFile indexPath updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do + let index = RepoIndex repoCtxt repo + -- NB: This may be a nullTimestamp if we've never updated before + current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo + -- NB: always update the timestamp, even if we didn't actually + -- download anything + writeIndexTimestamp index (fromFlag (updateIndexState updateFlags)) ce <- if repoContextIgnoreExpiry repoCtxt then Just `fmap` getCurrentTime else return Nothing @@ -85,4 +97,11 @@ Sec.NoUpdates -> return () Sec.HasUpdates -> - updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) + updateRepoIndexCache verbosity index + -- TODO: This will print multiple times if there are multiple + -- repositories: main problem is we don't have a way of updating + -- a specific repo. Once we implement that, update this. + when (current_ts /= nullTimestamp) $ + noticeNoWrap verbosity $ + "To revert to previous state run:\n" ++ + " cabal update --index-state='" ++ display current_ts ++ "'\n" diff --git a/cabal/cabal-install/Distribution/Client/Upload.hs b/cabal/cabal-install/Distribution/Client/Upload.hs --- a/cabal/cabal-install/Distribution/Client/Upload.hs +++ b/cabal/cabal-install/Distribution/Client/Upload.hs @@ -7,7 +7,7 @@ import Distribution.Client.Setup ( IsCandidate(..), RepoContext(..) ) -import Distribution.Simple.Utils (notice, warn, info, die) +import Distribution.Simple.Utils (notice, warn, info, die') import Distribution.Verbosity (Verbosity) import Distribution.Text (display) import Distribution.Client.Config @@ -18,14 +18,14 @@ import Network.URI (URI(uriPath)) import Network.HTTP (Header(..), HeaderName(..)) -import System.IO (hFlush, stdin, stdout, hGetEcho, hSetEcho) +import System.IO (hFlush, stdout) +import System.IO.Echo (withoutInputEcho) import System.Exit (exitFailure) -import Control.Exception (bracket) import System.FilePath ((), takeExtension, takeFileName, dropExtension) import qualified System.FilePath.Posix as FilePath.Posix (()) import System.Directory import Control.Monad (forM_, when, foldM) -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import Data.Char (isSpace) type Auth = Maybe (String, String) @@ -49,8 +49,8 @@ transport <- repoContextGetTransport repoCtxt targetRepo <- case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of - [] -> die "Cannot upload. No remote repositories are configured." - rs -> remoteRepoTryUpgradeToHttps transport (last rs) + [] -> die' verbosity "Cannot upload. No remote repositories are configured." + rs -> remoteRepoTryUpgradeToHttps verbosity transport (last rs) let targetRepoURI = remoteRepoURI targetRepo rootIfEmpty x = if null x then "/" else x uploadURI = targetRepoURI { @@ -78,7 +78,7 @@ (packageURI pkgid) auth isCandidate path -- This case shouldn't really happen, since we check in Main that we -- only pass tar.gz files to upload. - Nothing -> die $ "Not a tar.gz file: " ++ path + Nothing -> die' verbosity $ "Not a tar.gz file: " ++ path uploadDoc :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath @@ -88,8 +88,8 @@ transport <- repoContextGetTransport repoCtxt targetRepo <- case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of - [] -> die $ "Cannot upload. No remote repositories are configured." - rs -> remoteRepoTryUpgradeToHttps transport (last rs) + [] -> die' verbosity $ "Cannot upload. No remote repositories are configured." + rs -> remoteRepoTryUpgradeToHttps verbosity transport (last rs) let targetRepoURI = remoteRepoURI targetRepo rootIfEmpty x = if null x then "/" else x uploadURI = targetRepoURI { @@ -102,12 +102,21 @@ , "/docs" ] } + packageUri = targetRepoURI { + uriPath = rootIfEmpty (uriPath targetRepoURI) + FilePath.Posix. concat + [ "package/", pkgid + , case isCandidate of + IsCandidate -> "/candidate" + IsPublished -> "" + ] + } (reverseSuffix, reversePkgid) = break (== '-') (reverse (takeFileName path)) pkgid = reverse $ tail reversePkgid when (reverse reverseSuffix /= "docs.tar.gz" || null reversePkgid || head reversePkgid /= '-') $ - die "Expected a file name matching the pattern -docs.tar.gz" + die' verbosity "Expected a file name matching the pattern -docs.tar.gz" Username username <- maybe promptUsername return mUsername Password password <- maybe promptPassword return mPassword @@ -122,14 +131,24 @@ -- Hackage responds with 204 No Content when docs are uploaded -- successfully. (code,_) | code `elem` [200,204] -> do - notice verbosity "Ok" + notice verbosity $ okMessage packageUri (code,err) -> do notice verbosity $ "Error uploading documentation " ++ path ++ ": " ++ "http code " ++ show code ++ "\n" ++ err exitFailure + where + okMessage packageUri = case isCandidate of + IsCandidate -> + "Documentation successfully uploaded for package candidate. " + ++ "You can now preview the result at '" ++ show packageUri + ++ "'. To upload non-candidate documentation, use 'cabal upload --publish'." + IsPublished -> + "Package documentation successfully published. You can now view it at '" + ++ show packageUri ++ "'." + promptUsername :: IO Username promptUsername = do putStr "Hackage username: " @@ -140,10 +159,8 @@ promptPassword = do putStr "Hackage password: " hFlush stdout - -- save/restore the terminal echoing status - passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do - hSetEcho stdin False -- no echoing for entering the password - fmap Password getLine + -- save/restore the terminal echoing status (no echoing for entering the password) + passwd <- withoutInputEcho $ fmap Password getLine putStrLn "" return passwd @@ -153,7 +170,7 @@ Password password <- maybe promptPassword return mPassword let auth = (username, password) repos = repoContextRepos repoCtxt - remoteRepos = catMaybes (map maybeRepoRemote repos) + remoteRepos = mapMaybe maybeRepoRemote repos forM_ remoteRepos $ \remoteRepo -> do dotCabal <- defaultCabalDir let srcDir = dotCabal "reports" remoteRepoName remoteRepo diff --git a/cabal/cabal-install/Distribution/Client/Utils.hs b/cabal/cabal-install/Distribution/Client/Utils.hs --- a/cabal/cabal-install/Distribution/Client/Utils.hs +++ b/cabal/cabal-install/Distribution/Client/Utils.hs @@ -10,6 +10,7 @@ , withTempFileName , makeAbsoluteToCwd , makeRelativeToCwd, makeRelativeToDir + , makeRelativeCanonical , filePathToByteString , byteStringToFilePath, tryCanonicalizePath , canonicalizePathNoThrow @@ -26,7 +27,8 @@ import Distribution.Compat.Exception ( catchIO ) import Distribution.Compat.Time ( getModTime ) import Distribution.Simple.Setup ( Flag(..) ) -import Distribution.Simple.Utils ( die, findPackageDesc ) +import Distribution.Verbosity +import Distribution.Simple.Utils ( die', findPackageDesc ) import qualified Data.ByteString.Lazy as BS import Data.Bits ( (.|.), shiftL, shiftR ) @@ -297,17 +299,17 @@ return () -- |Like 'tryFindPackageDesc', but with error specific to add-source deps. -tryFindAddSourcePackageDesc :: FilePath -> String -> IO FilePath -tryFindAddSourcePackageDesc depPath err = tryFindPackageDesc depPath $ +tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> String -> IO FilePath +tryFindAddSourcePackageDesc verbosity depPath err = tryFindPackageDesc verbosity depPath $ err ++ "\n" ++ "Failed to read cabal file of add-source dependency: " ++ depPath -- |Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be -- found, with @err@ prefixing the error message. This function simply allows -- us to give a more descriptive error than that provided by @findPackageDesc@. -tryFindPackageDesc :: FilePath -> String -> IO FilePath -tryFindPackageDesc depPath err = do +tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath +tryFindPackageDesc verbosity depPath err = do errOrCabalFile <- findPackageDesc depPath case errOrCabalFile of Right file -> return file - Left _ -> die err + Left _ -> die' verbosity err diff --git a/cabal/cabal-install/Distribution/Client/Utils/Assertion.hs b/cabal/cabal-install/Distribution/Client/Utils/Assertion.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Utils/Assertion.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP #-} +module Distribution.Client.Utils.Assertion (expensiveAssert) where + +#ifdef DEBUG_EXPENSIVE_ASSERTIONS +import Control.Exception (assert) +import Distribution.Compat.Stack +#endif + +-- | Like 'assert', but only enabled with -fdebug-expensive-assertions. This +-- function can be used for expensive assertions that should only be turned on +-- during testing or debugging. +#ifdef DEBUG_EXPENSIVE_ASSERTIONS +expensiveAssert :: WithCallStack (Bool -> a -> a) +expensiveAssert = assert +#else +expensiveAssert :: Bool -> a -> a +expensiveAssert _ = id +#endif diff --git a/cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs b/cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs --- a/cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs +++ b/cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs @@ -212,7 +212,7 @@ #else import Distribution.Verbosity (Verbosity) -import Distribution.Simple.Utils (die) +import Distribution.Simple.Utils (die') possibleSelfUpgrade :: Verbosity -> [FilePath] @@ -220,6 +220,6 @@ possibleSelfUpgrade _ _ action = action deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () -deleteOldExeFile _ _ _ = die "win32selfupgrade not needed except on win32" +deleteOldExeFile verbosity _ _ = die' verbosity "win32selfupgrade not needed except on win32" #endif diff --git a/cabal/cabal-install/Distribution/Client/World.hs b/cabal/cabal-install/Distribution/Client/World.hs --- a/cabal/cabal-install/Distribution/Client/World.hs +++ b/cabal/cabal-install/Distribution/Client/World.hs @@ -29,32 +29,31 @@ getContents, ) where -import Distribution.Package - ( Dependency(..) ) -import Distribution.Package.TextClass - () +import Prelude (sequence) +import Distribution.Client.Compat.Prelude hiding (getContents) + +import Distribution.Types.Dependency import Distribution.PackageDescription - ( FlagAssignment, mkFlagName, unFlagName ) + ( FlagAssignment, mkFlagAssignment, unFlagAssignment + , mkFlagName, unFlagName ) import Distribution.Verbosity ( Verbosity ) import Distribution.Simple.Utils - ( die, info, chattyTry, writeFileAtomic ) + ( die', info, chattyTry, writeFileAtomic ) import Distribution.Text ( Text(..), display, simpleParse ) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.Exception ( catchIO ) import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ( (<>), (<+>) ) import Data.Char as Char import Data.List - ( unionBy, deleteFirstsBy, nubBy ) + ( unionBy, deleteFirstsBy ) import System.IO.Error ( isDoesNotExistError ) import qualified Data.ByteString.Lazy.Char8 as B -import Prelude hiding (getContents) data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment @@ -93,7 +92,7 @@ modifyWorld _ _ _ [] = return () modifyWorld f verbosity world pkgs = chattyTry "Error while updating world-file. " $ do - pkgsOldWorld <- getContents world + pkgsOldWorld <- getContents verbosity world -- Filter out packages that are not in the world file: let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld -- 'Dependency' is not an Ord instance, so we need to check for @@ -109,12 +108,12 @@ -- | Returns the content of the world file as a list -getContents :: FilePath -> IO [WorldPkgInfo] -getContents world = do +getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo] +getContents verbosity world = do content <- safelyReadFile world let result = map simpleParse (lines $ B.unpack content) case sequence result of - Nothing -> die "Could not parse world file." + Nothing -> die' verbosity "Could not parse world file." Just xs -> return xs where safelyReadFile :: FilePath -> IO B.ByteString @@ -125,21 +124,21 @@ instance Text WorldPkgInfo where - disp (WorldPkgInfo dep flags) = disp dep <+> dispFlags flags + disp (WorldPkgInfo dep flags) = disp dep Disp.<+> dispFlags (unFlagAssignment flags) where dispFlags [] = Disp.empty dispFlags fs = Disp.text "--flags=" - <> Disp.doubleQuotes (flagAssToDoc fs) + <<>> Disp.doubleQuotes (flagAssToDoc fs) flagAssToDoc = foldr (\(fname,val) flagAssDoc -> (if not val then Disp.char '-' else Disp.empty) - Disp.<> Disp.text (unFlagName fname) + <<>> Disp.text (unFlagName fname) Disp.<+> flagAssDoc) Disp.empty parse = do dep <- parse Parse.skipSpaces - flagAss <- Parse.option [] parseFlagAssignment + flagAss <- Parse.option mempty parseFlagAssignment return $ WorldPkgInfo dep flagAss where parseFlagAssignment :: Parse.ReadP r FlagAssignment @@ -148,7 +147,7 @@ Parse.skipSpaces _ <- Parse.char '=' Parse.skipSpaces - inDoubleQuotes $ Parse.many1 flag + mkFlagAssignment <$> (inDoubleQuotes $ Parse.many1 flag) where inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"') diff --git a/cabal/cabal-install/Distribution/Solver/Compat/Prelude.hs b/cabal/cabal-install/Distribution/Solver/Compat/Prelude.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Solver/Compat/Prelude.hs @@ -0,0 +1,19 @@ +-- to suppress WARNING in "Distribution.Compat.Prelude.Internal" +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +-- | This module does two things: +-- +-- * Acts as a compatiblity layer, like @base-compat@. +-- +-- * Provides commonly used imports. +-- +-- This module is a superset of "Distribution.Compat.Prelude" (which +-- this module re-exports) +-- +module Distribution.Solver.Compat.Prelude + ( module Distribution.Compat.Prelude.Internal + , Prelude.IO + ) where + +import Prelude (IO) +import Distribution.Compat.Prelude.Internal hiding (IO) 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 @@ -9,10 +9,6 @@ -- and finally, we have to convert back the resulting install -- plan. -import Data.Function - ( on ) -import Data.List - ( nubBy ) import Data.Map as M ( fromListWith ) import Distribution.Compat.Graph @@ -34,13 +30,16 @@ import Distribution.Solver.Types.DependencyResolver import Distribution.System ( Platform(..) ) +import Distribution.Simple.Utils + ( ordNubBy ) + -- | Ties the two worlds together: classic cabal-install vs. the modular -- solver. Performs the necessary translations before and after. modularResolver :: SolverConfig -> DependencyResolver loc modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns = - fmap (uncurry postprocess) $ -- convert install plan - logToProgress (maxBackjumps sc) $ -- convert log format into progress format + fmap (uncurry postprocess) $ -- convert install plan + logToProgress (solverVerbosity sc) (maxBackjumps sc) $ -- convert log format into progress format solve sc cinfo idx pkgConfigDB pprefs gcs pns where -- Indices have to be converted into solver-specific uniform index. @@ -53,14 +52,9 @@ -- Results have to be converted into an install plan. 'convCP' removes -- package qualifiers, which means that linked packages become duplicates -- and can be removed. - -- TODO: Use ordNubBy instead of nubBy. - postprocess a rdm = nubBy ((==) `on` nodeKey) $ + postprocess a rdm = ordNubBy nodeKey $ map (convCP iidx sidx) (toCPs a rdm) -- Helper function to extract the PN from a constraint. pcName :: PackageConstraint -> PN - pcName (PackageConstraintVersion pn _) = pn - pcName (PackageConstraintInstalled pn ) = pn - pcName (PackageConstraintSource pn ) = pn - pcName (PackageConstraintFlags pn _) = pn - pcName (PackageConstraintStanzas pn _) = pn + pcName (PackageConstraint scope _) = scopeToPackageName scope diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Assignment.hs b/cabal/cabal-install/Distribution/Solver/Modular/Assignment.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Assignment.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Assignment.hs @@ -1,23 +1,20 @@ module Distribution.Solver.Modular.Assignment ( Assignment(..) + , PAssignment , FAssignment , SAssignment - , PreAssignment(..) - , extend , toCPs ) where -import Control.Applicative -import Control.Monad +import Prelude () +import Distribution.Solver.Compat.Prelude hiding (pi) + import Data.Array as A import Data.List as L import Data.Map as M import Data.Maybe -import Prelude hiding (pi) -import Language.Haskell.Extension (Extension, Language) - -import Distribution.PackageDescription (FlagAssignment) -- from Cabal +import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component) import qualified Distribution.Solver.Types.ComponentDeps as CD @@ -29,17 +26,11 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.LabeledGraph import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.Version -- | A (partial) package assignment. Qualified package names -- are associated with instances. type PAssignment = Map QPN I --- | A (partial) package preassignment. Qualified package names --- are associated with constrained instances. Constrained instances --- record constraints about the instances that can still be chosen, --- and in the extreme case fix a concrete instance. -type PPreAssignment = Map QPN (CI QPN) type FAssignment = Map QFN Bool type SAssignment = Map QSN Bool @@ -47,55 +38,6 @@ data Assignment = A PAssignment FAssignment SAssignment deriving (Show, Eq) --- | A preassignment comprises knowledge about variables, but not --- necessarily fixed values. -data PreAssignment = PA PPreAssignment FAssignment SAssignment - --- | Extend a package preassignment. --- --- Takes the variable that causes the new constraints, a current preassignment --- and a set of new dependency constraints. --- --- We're trying to extend the preassignment with each dependency one by one. --- Each dependency is for a particular variable. We check if we already have --- constraints for that variable in the current preassignment. If so, we're --- trying to merge the constraints. --- --- Either returns a witness of the conflict that would arise during the merge, --- or the successfully extended assignment. -extend :: (Extension -> Bool) -- ^ is a given extension supported - -> (Language -> Bool) -- ^ is a given language supported - -> (PkgconfigName -> VR -> Bool) -- ^ is a given pkg-config requirement satisfiable - -> Var QPN - -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment -extend extSupported langSupported pkgPresent var = foldM extendSingle - where - - extendSingle :: PPreAssignment -> Dep QPN - -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment - extendSingle a (Ext ext ) = - if extSupported ext then Right a - else Left (varToConflictSet var, [Ext ext]) - extendSingle a (Lang lang) = - if langSupported lang then Right a - else Left (varToConflictSet var, [Lang lang]) - extendSingle a (Pkg pn vr) = - if pkgPresent pn vr then Right a - else Left (varToConflictSet var, [Pkg pn vr]) - extendSingle a (Dep is_exe qpn ci) = - let ci' = M.findWithDefault (Constrained []) qpn a - in case (\ x -> M.insert qpn x a) <$> merge ci' ci of - Left (c, (d, d')) -> Left (c, L.map (Dep is_exe qpn) (simplify (P qpn) d d')) - Right x -> Right x - - -- We're trying to remove trivial elements of the conflict. If we're just - -- making a choice pkg == instance, and pkg => pkg == instance is a part - -- of the conflict, then this info is clear from the context and does not - -- have to be repeated. - simplify v (Fixed _ var') c | v == var && var' == var = [c] - simplify v c (Fixed _ var') | v == var && var' == var = [c] - simplify _ c d = [c, d] - -- | Delivers an ordered list of fully configured packages. -- -- TODO: This function is (sort of) ok. However, there's an open bug @@ -124,14 +66,14 @@ -- Determine the flags per package, by walking over and regrouping the -- complete flag assignment by package. fapp :: Map QPN FlagAssignment - fapp = M.fromListWith (++) $ - L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $ + fapp = M.fromListWith mappend $ + L.map (\ ((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $ M.toList $ fa -- Stanzas per package. sapp :: Map QPN [OptionalStanza] sapp = M.fromListWith (++) $ - L.map (\ ((SN (PI qpn _) sn), b) -> (qpn, if b then [sn] else [])) $ + L.map (\ ((SN qpn sn), b) -> (qpn, if b then [sn] else [])) $ M.toList $ sa -- Dependencies per package. @@ -146,7 +88,7 @@ depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp in L.map (\ pi@(PI qpn _) -> CP pi - (M.findWithDefault [] qpn fapp) - (M.findWithDefault [] qpn sapp) + (M.findWithDefault mempty qpn fapp) + (M.findWithDefault mempty qpn sapp) (depp' qpn)) ps diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Builder.hs b/cabal/cabal-install/Distribution/Solver/Modular/Builder.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Builder.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Builder.hs @@ -1,4 +1,8 @@ -module Distribution.Solver.Modular.Builder (buildTree) where +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Solver.Modular.Builder ( + buildTree + , splits -- for testing + ) where -- Building the search tree. -- @@ -23,170 +27,263 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.PSQ (PSQ) import qualified Distribution.Solver.Modular.PSQ as P import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.WeightedPSQ as W -import Distribution.Solver.Types.ComponentDeps (Component) import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Settings --- | The state needed during the build phase of the search tree. +-- | All state needed to build and link the search tree. It has a type variable +-- because the linking phase doesn't need to know about the state used to build +-- the tree. +data Linker a = Linker { + buildState :: a, + linkingState :: LinkingState +} + +-- | The state needed to build the search tree without creating any linked nodes. data BuildState = BS { - index :: Index, -- ^ information about packages and their dependencies - rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies - open :: PSQ (OpenGoal ()) (), -- ^ set of still open goals (flag and package goals) - next :: BuildType, -- ^ kind of node to generate next - qualifyOptions :: QualifyOptions -- ^ qualification options + index :: Index, -- ^ information about packages and their dependencies + rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies + open :: [OpenGoal], -- ^ set of still open goals (flag and package goals) + next :: BuildType, -- ^ kind of node to generate next + qualifyOptions :: QualifyOptions -- ^ qualification options } +-- | Map of available linking targets. +type LinkingState = Map (PN, I) [PackagePath] + -- | Extend the set of open goals with the new goals listed. -- -- We also adjust the map of overall goals, and keep track of the -- reverse dependencies of each of the goals. -extendOpen :: QPN -> [OpenGoal Component] -> BuildState -> BuildState +extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs where - go :: RevDepMap -> PSQ (OpenGoal ()) () -> [OpenGoal Component] -> BuildState - go g o [] = s { rdeps = g, open = o } - go g o (ng@(OpenGoal (Flagged _ _ _ _) _gr) : ngs) = go g (cons' ng () o) ngs + go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState + go g o [] = s { rdeps = g, open = o } + go g o ((Flagged fn@(FN qpn _) fInfo t f) : ngs) = + go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs -- Note: for 'Flagged' goals, we always insert, so later additions win. -- This is important, because in general, if a goal is inserted twice, -- the later addition will have better dependency information. - go g o (ng@(OpenGoal (Stanza _ _ ) _gr) : ngs) = go g (cons' ng () o) ngs - go g o (ng@(OpenGoal (Simple (Dep _ qpn _) c) _gr) : ngs) + go g o ((Stanza sn@(SN qpn _) t) : ngs) = + go g (StanzaGoal sn t (flagGR qpn) : o) ngs + go g o ((Simple (LDep dr (Dep _ qpn _)) c) : ngs) | qpn == qpn' = go g o ngs -- we ignore self-dependencies at this point; TODO: more care may be needed - | qpn `M.member` g = go (M.adjust ((c, qpn'):) qpn g) o ngs - | otherwise = go (M.insert qpn [(c, qpn')] g) (cons' ng () o) ngs + | qpn `M.member` g = go (M.adjust (addIfAbsent (c, qpn')) qpn g) o ngs + | otherwise = go (M.insert qpn [(c, qpn')] g) (PkgGoal qpn (DependencyGoal dr) : o) ngs -- code above is correct; insert/adjust have different arg order - go g o ( (OpenGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs - go g o ( (OpenGoal (Simple (Lang _lang)_) _gr) : ngs) = go g o ngs - go g o ( (OpenGoal (Simple (Pkg _pn _vr)_) _gr) : ngs)= go g o ngs + go g o ((Simple (LDep _dr (Ext _ext )) _) : ngs) = go g o ngs + go g o ((Simple (LDep _dr (Lang _lang))_) : ngs) = go g o ngs + go g o ((Simple (LDep _dr (Pkg _pn _vr))_) : ngs) = go g o ngs - cons' = P.cons . forgetCompOpenGoal + addIfAbsent :: Eq a => a -> [a] -> [a] + addIfAbsent x xs = if x `elem` xs then xs else x : xs + -- GoalReason for a flag or stanza. Each flag/stanza is introduced only by + -- its containing package. + flagGR :: qpn -> GoalReason qpn + flagGR qpn = DependencyGoal (DependencyReason qpn [] []) + -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly. -scopedExtendOpen :: QPN -> I -> QGoalReason -> FlaggedDeps Component PN -> FlagInfo -> +scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo -> BuildState -> BuildState -scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s +scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s where -- Qualify all package names qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps -- Introduce all package flags - qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs + qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs -- Combine new package and flag goals - gs = L.map (flip OpenGoal gr) (qfdefs ++ qfdeps) + gs = qfdefs ++ qfdeps -- NOTE: -- -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially -- multiple times, both via the flag declaration and via dependencies. - -- The order is potentially important, because the occurrences via - -- dependencies may record flag-dependency information. After a number - -- of bugs involving computing this information incorrectly, however, - -- we're currently not using carefully computed inter-flag dependencies - -- anymore, but instead use 'simplifyVar' when computing conflict sets - -- to map all flags of one package to a single flag for conflict set - -- purposes, thereby treating them all as interdependent. - -- - -- If we ever move to a more clever algorithm again, then the line above - -- needs to be looked at very carefully, and probably be replaced by - -- more systematically computed flag dependency information. -- | Datatype that encodes what to build next data BuildType = - Goals -- ^ build a goal choice node - | OneGoal (OpenGoal ()) -- ^ build a node for this goal - | Instance QPN I PInfo QGoalReason -- ^ build a tree for a concrete instance - deriving Show + Goals -- ^ build a goal choice node + | OneGoal OpenGoal -- ^ build a node for this goal + | Instance QPN PInfo -- ^ build a tree for a concrete instance -build :: BuildState -> Tree () QGoalReason +build :: Linker BuildState -> Tree () QGoalReason build = ana go where - go :: BuildState -> TreeF () QGoalReason BuildState + go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState) + go s = addLinking (linkingState s) $ addChildren (buildState s) - -- If we have a choice between many goals, we just record the choice in - -- the tree. We select each open goal in turn, and before we descend, remove - -- it from the queue of open goals. - go bs@(BS { rdeps = rds, open = gs, next = Goals }) - | P.null gs = DoneF rds () - | otherwise = GoalChoiceF $ P.mapKeys close - $ P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' }) - $ P.splits gs +addChildren :: BuildState -> TreeF () QGoalReason BuildState - -- If we have already picked a goal, then the choice depends on the kind - -- of goal. - -- - -- For a package, we look up the instances available in the global info, - -- and then handle each instance in turn. - go (BS { index = _ , next = OneGoal (OpenGoal (Simple (Ext _ ) _) _ ) }) = - error "Distribution.Solver.Modular.Builder: build.go called with Ext goal" - go (BS { index = _ , next = OneGoal (OpenGoal (Simple (Lang _ ) _) _ ) }) = - error "Distribution.Solver.Modular.Builder: build.go called with Lang goal" - go (BS { index = _ , next = OneGoal (OpenGoal (Simple (Pkg _ _ ) _) _ ) }) = - error "Distribution.Solver.Modular.Builder: build.go called with Pkg goal" - go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep _ qpn@(Q _ pn) _) _) gr) }) = - -- If the package does not exist in the index, we construct an emty PChoiceF node for it - -- After all, we have no choices here. Alternatively, we could immediately construct - -- a Fail node here, but that would complicate the construction of conflict sets. - -- We will probably want to give this case special treatment when generating error - -- messages though. - case M.lookup pn idx of - Nothing -> PChoiceF qpn gr (W.fromList []) - Just pis -> PChoiceF qpn gr (W.fromList (L.map (\ (i, info) -> - ([], POption i Nothing, bs { next = Instance qpn i info gr })) - (M.toList pis))) - -- TODO: data structure conversion is rather ugly here +-- If we have a choice between many goals, we just record the choice in +-- the tree. We select each open goal in turn, and before we descend, remove +-- it from the queue of open goals. +addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals }) + | L.null gs = DoneF rdm () + | otherwise = GoalChoiceF rdm $ P.fromList + $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' })) + $ splits gs - -- For a flag, we create only two subtrees, and we create them in the order - -- that is indicated by the flag default. - -- - -- TODO: Should we include the flag default in the tree? - go bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) = - FChoiceF qfn gr weak m (W.fromList - [([if b then 0 else 1], True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }), - ([if b then 1 else 0], False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })]) - where - trivial = L.null t && L.null f - weak = WeakOrTrivial $ unWeakOrTrivial w || trivial +-- If we have already picked a goal, then the choice depends on the kind +-- of goal. +-- +-- For a package, we look up the instances available in the global info, +-- and then handle each instance in turn. +addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) = + -- If the package does not exist in the index, we construct an emty PChoiceF node for it + -- After all, we have no choices here. Alternatively, we could immediately construct + -- a Fail node here, but that would complicate the construction of conflict sets. + -- We will probably want to give this case special treatment when generating error + -- messages though. + case M.lookup pn idx of + Nothing -> PChoiceF qpn rdm gr (W.fromList []) + Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> + ([], POption i Nothing, bs { next = Instance qpn info })) + (M.toList pis))) + -- TODO: data structure conversion is rather ugly here - -- For a stanza, we also create only two subtrees. The order is initially - -- False, True. This can be changed later by constraints (force enabling - -- the stanza by replacing the False branch with failure) or preferences - -- (try enabling the stanza if possible by moving the True branch first). +-- For a flag, we create only two subtrees, and we create them in the order +-- that is indicated by the flag default. +addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) = + FChoiceF qfn rdm gr weak m b (W.fromList + [([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals }), + ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })]) + where + trivial = L.null t && L.null f + weak = WeakOrTrivial $ unWeakOrTrivial w || trivial - go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) = - SChoiceF qsn gr trivial (W.fromList - [([0], False, bs { next = Goals }), - ([1], True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })]) - where - trivial = WeakOrTrivial (L.null t) +-- For a stanza, we also create only two subtrees. The order is initially +-- False, True. This can be changed later by constraints (force enabling +-- the stanza by replacing the False branch with failure) or preferences +-- (try enabling the stanza if possible by moving the True branch first). - -- For a particular instance, we change the state: we update the scope, - -- and furthermore we update the set of goals. - -- - -- TODO: We could inline this above. - go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) _gr }) = - go ((scopedExtendOpen qpn i (PDependency (PI qpn i)) fdeps fdefs bs) - { next = Goals }) +addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) = + SChoiceF qsn rdm gr trivial (W.fromList + [([0], False, bs { next = Goals }), + ([1], True, (extendOpen qpn t bs) { next = Goals })]) + where + trivial = WeakOrTrivial (L.null t) +-- For a particular instance, we change the state: we update the scope, +-- and furthermore we update the set of goals. +-- +-- TODO: We could inline this above. +addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) = + addChildren ((scopedExtendOpen qpn fdeps fdefs bs) + { next = Goals }) + +{------------------------------------------------------------------------------- + Add linking +-------------------------------------------------------------------------------} + +-- | Introduce link nodes into the tree +-- +-- Linking is a phase that adapts package choice nodes and adds the option to +-- link wherever appropriate: Package goals are called "related" if they are for +-- the same instance of the same package (but have different prefixes). A link +-- option is available in a package choice node whenever we can choose an +-- instance that has already been chosen for a related goal at a higher position +-- in the tree. We only create link options for related goals that are not +-- themselves linked, because the choice to link to a linked goal is the same as +-- the choice to link to the target of that goal's linking. +-- +-- The code here proceeds by maintaining a finite map recording choices that +-- have been made at higher positions in the tree. For each pair of package name +-- and instance, it stores the prefixes at which we have made a choice for this +-- package instance. Whenever we make an unlinked choice, we extend the map. +-- Whenever we find a choice, we look into the map in order to find out what +-- link options we have to add. +-- +-- A separate tree traversal would be simpler. However, 'addLinking' creates +-- linked nodes from existing unlinked nodes, which leads to sharing between the +-- nodes. If we copied the nodes when they were full trees of type +-- 'Tree () QGoalReason', then the sharing would cause a space leak during +-- exploration of the tree. Instead, we only copy the 'BuildState', which is +-- relatively small, while the tree is being constructed. See +-- https://github.com/haskell/cabal/issues/2899 +addLinking :: LinkingState -> TreeF () c a -> TreeF () c (Linker a) +-- The only nodes of interest are package nodes +addLinking ls (PChoiceF qpn@(Q pp pn) rdm gr cs) = + let linkedCs = fmap (\bs -> Linker bs ls) $ + W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs) + unlinkedCs = W.mapWithKey goP cs + allCs = unlinkedCs `W.union` linkedCs + + -- Recurse underneath package choices. Here we just need to make sure + -- that we record the package choice so that it is available below + goP :: POption -> a -> Linker a + goP (POption i Nothing) bs = Linker bs $ M.insertWith (++) (pn, i) [pp] ls + goP _ _ = alreadyLinked + in PChoiceF qpn rdm gr allCs +addLinking ls t = fmap (\bs -> Linker bs ls) t + +linkChoices :: forall a w . LinkingState + -> QPN + -> (w, POption, a) + -> [(w, POption, a)] +linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) = + L.map aux (M.findWithDefault [] (pn, i) related) + where + aux :: PackagePath -> (w, POption, a) + aux pp = (weight, POption i (Just pp), subtree) +linkChoices _ _ (_, POption _ (Just _), _) = + alreadyLinked + +alreadyLinked :: a +alreadyLinked = error "addLinking called on tree that already contains linked nodes" + +------------------------------------------------------------------------------- + -- | Interface to the tree builder. Just takes an index and a list of package names, -- and computes the initial state and then the tree from there. buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason buildTree idx (IndependentGoals ind) igs = - build BS { - index = idx - , rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns) - , open = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns) - , next = Goals - , qualifyOptions = defaultQualifyOptions idx + build Linker { + buildState = BS { + index = idx + , rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns) + , open = L.map topLevelGoal qpns + , next = Goals + , qualifyOptions = defaultQualifyOptions idx + } + , linkingState = M.empty } where - -- Should a top-level goal allowed to be an executable style - -- dependency? Well, I don't think it would make much difference - topLevelGoal qpn = OpenGoal (Simple (Dep False {- not exe -} qpn (Constrained [])) ()) UserGoal + topLevelGoal qpn = PkgGoal qpn UserGoal - qpns | ind = makeIndependent igs - | otherwise = L.map (Q (PackagePath DefaultNamespace Unqualified)) igs + qpns | ind = L.map makeIndependent igs + | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs + +{------------------------------------------------------------------------------- + Goals +-------------------------------------------------------------------------------} + +-- | Information needed about a dependency before it is converted into a Goal. +data OpenGoal = + FlagGoal (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason + | StanzaGoal (SN QPN) (FlaggedDeps QPN) QGoalReason + | PkgGoal QPN QGoalReason + +-- | Closes a goal, i.e., removes all the extraneous information that we +-- need only during the build phase. +close :: OpenGoal -> Goal QPN +close (FlagGoal qfn _ _ _ gr) = Goal (F qfn) gr +close (StanzaGoal qsn _ gr) = Goal (S qsn) gr +close (PkgGoal qpn gr) = Goal (P qpn) gr + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Pairs each element of a list with the list resulting from removal of that +-- element from the original list. +splits :: [a] -> [(a, [a])] +splits = go id + where + go :: ([a] -> [a]) -> [a] -> [(a, [a])] + go _ [] = [] + go f (x : xs) = (x, f xs) : go (f . (x :)) xs diff --git a/cabal/cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal/cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs @@ -59,7 +59,7 @@ case loc of Inst pi -> Left (PreExistingId sourceId pi) _otherwise - | Exe _ pn' <- q + | QualExe _ pn' <- q -- NB: the dependencies of the executable are also -- qualified. So the way to tell if this is an executable -- dependency is to make sure the qualifier is pointing diff --git a/cabal/cabal-install/Distribution/Solver/Modular/ConflictSet.hs b/cabal/cabal-install/Distribution/Solver/Modular/ConflictSet.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/ConflictSet.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/ConflictSet.hs @@ -10,10 +10,13 @@ -- > import qualified Distribution.Solver.Modular.ConflictSet as CS module Distribution.Solver.Modular.ConflictSet ( ConflictSet -- opaque + , ConflictMap #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin #endif - , showCS + , showConflictSet + , showCSSortedByFrequency + , showCSWithFrequency -- Set-like operations , toList , union @@ -27,10 +30,12 @@ ) where import Prelude hiding (filter) -import Data.List (intercalate) +import Data.List (intercalate, sortBy) +import Data.Map (Map) import Data.Set (Set) import Data.Function (on) import qualified Data.Set as S +import qualified Data.Map as M #ifdef DEBUG_CONFLICT_SETS import Data.Tree @@ -44,9 +49,9 @@ -- -- Since these variables should be preprocessed in some way, this type is -- kept abstract. -data ConflictSet qpn = CS { +data ConflictSet = CS { -- | The set of variables involved on the conflict - conflictSetToSet :: Set (Var qpn) + conflictSetToSet :: Set (Var QPN) #ifdef DEBUG_CONFLICT_SETS -- | The origin of the conflict set @@ -64,27 +69,43 @@ } deriving (Show) -instance Eq qpn => Eq (ConflictSet qpn) where +instance Eq ConflictSet where (==) = (==) `on` conflictSetToSet -instance Ord qpn => Ord (ConflictSet qpn) where +instance Ord ConflictSet where compare = compare `on` conflictSetToSet -showCS :: ConflictSet QPN -> String -showCS = intercalate ", " . map showVar . toList +showConflictSet :: ConflictSet -> String +showConflictSet = intercalate ", " . map showVar . toList +showCSSortedByFrequency :: ConflictMap -> ConflictSet -> String +showCSSortedByFrequency = showCS False + +showCSWithFrequency :: ConflictMap -> ConflictSet -> String +showCSWithFrequency = showCS True + +showCS :: Bool -> ConflictMap -> ConflictSet -> String +showCS showCount cm = + intercalate ", " . map showWithFrequency . indexByFrequency + where + indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList + showWithFrequency (conflict, maybeFrequency) = case maybeFrequency of + Just frequency + | showCount -> showVar conflict ++ " (" ++ show frequency ++ ")" + _ -> showVar conflict + {------------------------------------------------------------------------------- Set-like operations -------------------------------------------------------------------------------} -toList :: ConflictSet qpn -> [Var qpn] +toList :: ConflictSet -> [Var QPN] toList = S.toList . conflictSetToSet union :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif - Ord qpn => ConflictSet qpn -> ConflictSet qpn -> ConflictSet qpn + ConflictSet -> ConflictSet -> ConflictSet union cs cs' = CS { conflictSetToSet = S.union (conflictSetToSet cs) (conflictSetToSet cs') #ifdef DEBUG_CONFLICT_SETS @@ -96,7 +117,7 @@ #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif - Ord qpn => [ConflictSet qpn] -> ConflictSet qpn + [ConflictSet] -> ConflictSet unions css = CS { conflictSetToSet = S.unions (map conflictSetToSet css) #ifdef DEBUG_CONFLICT_SETS @@ -108,9 +129,9 @@ #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif - Ord qpn => Var qpn -> ConflictSet qpn -> ConflictSet qpn + Var QPN -> ConflictSet -> ConflictSet insert var cs = CS { - conflictSetToSet = S.insert (simplifyVar var) (conflictSetToSet cs) + conflictSetToSet = S.insert var (conflictSetToSet cs) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] #endif @@ -120,7 +141,7 @@ #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif - ConflictSet qpn + ConflictSet empty = CS { conflictSetToSet = S.empty #ifdef DEBUG_CONFLICT_SETS @@ -132,25 +153,22 @@ #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif - Var qpn -> ConflictSet qpn + Var QPN -> ConflictSet singleton var = CS { - conflictSetToSet = S.singleton (simplifyVar var) + conflictSetToSet = S.singleton var #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif } -member :: Ord qpn => Var qpn -> ConflictSet qpn -> Bool -member var = S.member (simplifyVar var) . conflictSetToSet +member :: Var QPN -> ConflictSet -> Bool +member var = S.member var . conflictSetToSet filter :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif -#if !MIN_VERSION_containers(0,5,0) - Ord qpn => -#endif - (Var qpn -> Bool) -> ConflictSet qpn -> ConflictSet qpn + (Var QPN -> Bool) -> ConflictSet -> ConflictSet filter p cs = CS { conflictSetToSet = S.filter p (conflictSetToSet cs) #ifdef DEBUG_CONFLICT_SETS @@ -162,10 +180,13 @@ #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif - Ord qpn => [Var qpn] -> ConflictSet qpn + [Var QPN] -> ConflictSet fromList vars = CS { - conflictSetToSet = S.fromList (map simplifyVar vars) + conflictSetToSet = S.fromList vars #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif } + +type ConflictMap = Map (Var QPN) Int + diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Cycles.hs b/cabal/cabal-install/Distribution/Solver/Modular/Cycles.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Cycles.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Cycles.hs @@ -1,50 +1,118 @@ +{-# LANGUAGE TypeFamilies #-} module Distribution.Solver.Modular.Cycles ( detectCyclesPhase ) where import Prelude hiding (cycle) -import Data.Graph (SCC) -import qualified Data.Graph as Gr -import qualified Data.Map as Map +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Distribution.Compat.Graph as G +import Distribution.Simple.Utils (ordNub) import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Types.ComponentDeps (Component) import Distribution.Solver.Types.PackagePath --- | Find and reject any solutions that are cyclic +-- | Find and reject any nodes with cyclic dependencies detectCyclesPhase :: Tree d c -> Tree d c detectCyclesPhase = cata go where - -- The only node of interest is DoneF + -- Only check children of choice nodes. go :: TreeF d c (Tree d c) -> Tree d c - go (PChoiceF qpn gr cs) = PChoice qpn gr cs - go (FChoiceF qfn gr w m cs) = FChoice qfn gr w m cs - go (SChoiceF qsn gr w cs) = SChoice qsn gr w cs - go (GoalChoiceF cs) = GoalChoice cs - go (FailF cs reason) = Fail cs reason + go (PChoiceF qpn rdm gr cs) = + PChoice qpn rdm gr $ fmap (checkChild qpn) cs + go (FChoiceF qfn@(FN qpn _) rdm gr w m d cs) = + FChoice qfn rdm gr w m d $ fmap (checkChild qpn) cs + go (SChoiceF qsn@(SN qpn _) rdm gr w cs) = + SChoice qsn rdm gr w $ fmap (checkChild qpn) cs + go x = inn x - -- We check for cycles only if we have actually found a solution - -- This minimizes the number of cycle checks we do as cycles are rare - go (DoneF revDeps s) = do - case findCycles revDeps of - Nothing -> Done revDeps s + checkChild :: QPN -> Tree d c -> Tree d c + checkChild qpn x@(PChoice _ rdm _ _) = failIfCycle qpn rdm x + checkChild qpn x@(FChoice _ rdm _ _ _ _ _) = failIfCycle qpn rdm x + checkChild qpn x@(SChoice _ rdm _ _ _) = failIfCycle qpn rdm x + checkChild qpn x@(GoalChoice rdm _) = failIfCycle qpn rdm x + checkChild _ x@(Fail _ _) = x + checkChild qpn x@(Done rdm _) = failIfCycle qpn rdm x + + failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c + failIfCycle qpn rdm x = + case findCycles qpn rdm of + Nothing -> x Just relSet -> Fail relSet CyclicDependencies --- | Given the reverse dependency map from a 'Done' node in the tree, check +-- | Given the reverse dependency map from a node in the tree, check -- if the solution is cyclic. If it is, return the conflict set containing -- all decisions that could potentially break the cycle. -findCycles :: RevDepMap -> Maybe (ConflictSet QPN) -findCycles revDeps = - case cycles of - [] -> Nothing - c:_ -> Just $ CS.unions $ map (varToConflictSet . P) c +-- +-- TODO: The conflict set should also contain flag and stanza variables. +findCycles :: QPN -> RevDepMap -> Maybe ConflictSet +findCycles pkg rdm = + -- This function has two parts: a faster cycle check that is called at every + -- step and a slower calculation of the conflict set. + -- + -- 'hasCycle' checks for cycles incrementally by only looking for cycles + -- containing the current package, 'pkg'. It searches for cycles in the + -- 'RevDepMap', which is the data structure used to store reverse + -- dependencies in the search tree. We store the reverse dependencies in a + -- map, because Data.Map is smaller and/or has better sharing than + -- Distribution.Compat.Graph. + -- + -- If there is a cycle, we call G.cycles to find a strongly connected + -- component. Then we choose one cycle from the component to use for the + -- conflict set. Choosing only one cycle can lead to a smaller conflict set, + -- such as when a choice to enable testing introduces many cycles at once. + -- In that case, all cycles contain the current package and are in one large + -- strongly connected component. + -- + if hasCycle + then let scc :: G.Graph RevDepMapNode + scc = case G.cycles $ revDepMapToGraph rdm of + [] -> findCyclesError "cannot find a strongly connected component" + c : _ -> G.fromDistinctList c + + next :: QPN -> QPN + next p = case G.neighbors scc p of + Just (n : _) -> G.nodeKey n + _ -> findCyclesError "cannot find next node in the cycle" + + -- This function also assumes that all cycles contain 'pkg'. + oneCycle :: [QPN] + oneCycle = case iterate next pkg of + [] -> findCyclesError "empty cycle" + x : xs -> x : takeWhile (/= x) xs + in Just $ CS.fromList $ map P oneCycle + else Nothing where - cycles :: [[QPN]] - cycles = [vs | Gr.CyclicSCC vs <- scc] + hasCycle :: Bool + hasCycle = pkg `S.member` closure (neighbors pkg) - scc :: [SCC QPN] - scc = Gr.stronglyConnComp . map aux . Map.toList $ revDeps + closure :: [QPN] -> S.Set QPN + closure = foldl go S.empty + where + go :: S.Set QPN -> QPN -> S.Set QPN + go s x = + if x `S.member` s + then s + else foldl go (S.insert x s) $ neighbors x - aux :: (QPN, [(comp, QPN)]) -> (QPN, QPN, [QPN]) - aux (fr, to) = (fr, fr, map snd to) + neighbors :: QPN -> [QPN] + neighbors x = case x `M.lookup` rdm of + Nothing -> findCyclesError "cannot find node" + Just xs -> map snd xs + + findCyclesError = error . ("Distribution.Solver.Modular.Cycles.findCycles: " ++) + +data RevDepMapNode = RevDepMapNode QPN [(Component, QPN)] + +instance G.IsNode RevDepMapNode where + type Key RevDepMapNode = QPN + nodeKey (RevDepMapNode qpn _) = qpn + nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns + +revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode +revDepMapToGraph rdm = G.fromDistinctList + [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm] diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Degree.hs b/cabal/cabal-install/Distribution/Solver/Modular/Degree.hs deleted file mode 100644 --- a/cabal/cabal-install/Distribution/Solver/Modular/Degree.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Distribution.Solver.Modular.Degree where - --- | Approximation of the branching degree. --- --- This is designed for computing the branching degree of a goal choice --- node. If the degree is 0 or 1, it is always good to take that goal, --- because we can either abort immediately, or have no other choice anyway. --- --- So we do not actually want to compute the full degree (which is --- somewhat costly) in cases where we have such an easy choice. --- -data Degree = ZeroOrOne | Two | Other - deriving (Show, Eq) - -instance Ord Degree where - compare ZeroOrOne _ = LT -- lazy approximation - compare _ ZeroOrOne = GT -- approximation - compare Two Two = EQ - compare Two Other = LT - compare Other Two = GT - compare Other Other = EQ diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Dependency.hs b/cabal/cabal-install/Distribution/Solver/Modular/Dependency.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Dependency.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Dependency.hs @@ -1,59 +1,45 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} -#ifdef DEBUG_CONFLICT_SETS -{-# LANGUAGE ImplicitParams #-} -#endif module Distribution.Solver.Modular.Dependency ( -- * Variables Var(..) - , simplifyVar - , varPI , showVar + , varPN -- * Conflict sets , ConflictSet - , CS.showCS + , ConflictMap + , CS.showConflictSet -- * Constrained instances , CI(..) - , merge -- * Flagged dependencies , FlaggedDeps , FlaggedDep(..) + , LDep(..) , Dep(..) - , showDep + , DependencyReason(..) + , showDependencyReason , flattenFlaggedDeps , QualifyOptions(..) , qualifyDeps , unqualifyDeps - -- ** Setting/forgetting components - , forgetCompOpenGoal - , setCompFlaggedDeps -- * Reverse dependency map , RevDepMap -- * Goals , Goal(..) , GoalReason(..) , QGoalReason - , ResetVar(..) , goalToVar - , goalVarToConflictSet , varToConflictSet - , goalReasonToVars - -- * Open goals - , OpenGoal(..) - , close + , goalReasonToCS + , dependencyReasonToCS ) where -import Prelude hiding (pi) - -import Data.Map (Map) -import qualified Data.List as L +import Prelude () +import Distribution.Client.Compat.Prelude hiding (pi) import Language.Haskell.Extension (Extension(..), Language(..)) -import Distribution.Text - -import Distribution.Solver.Modular.ConflictSet (ConflictSet) +import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap) import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Var @@ -62,56 +48,16 @@ import Distribution.Solver.Types.ComponentDeps (Component(..)) import Distribution.Solver.Types.PackagePath - -#ifdef DEBUG_CONFLICT_SETS -import GHC.Stack (CallStack) -#endif +import Distribution.Types.UnqualComponentName {------------------------------------------------------------------------------- Constrained instances -------------------------------------------------------------------------------} --- | Constrained instance. If the choice has already been made, this is --- a fixed instance, and we record the package name for which the choice --- is for convenience. Otherwise, it is a list of version ranges paired with --- the goals / variables that introduced them. -data CI qpn = Fixed I (Var qpn) | Constrained [VROrigin qpn] - deriving (Eq, Show, Functor) - -showCI :: CI QPN -> String -showCI (Fixed i _) = "==" ++ showI i -showCI (Constrained vr) = showVR (collapse vr) - --- | Merge constrained instances. We currently adopt a lazy strategy for --- merging, i.e., we only perform actual checking if one of the two choices --- is fixed. If the merge fails, we return a conflict set indicating the --- variables responsible for the failure, as well as the two conflicting --- fragments. --- --- Note that while there may be more than one conflicting pair of version --- ranges, we only return the first we find. --- --- TODO: Different pairs might have different conflict sets. We're --- obviously interested to return a conflict that has a "better" conflict --- set in the sense the it contains variables that allow us to backjump --- further. We might apply some heuristics here, such as to change the --- order in which we check the constraints. -merge :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn) -merge c@(Fixed i g1) d@(Fixed j g2) - | i == j = Right c - | otherwise = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, d)) -merge c@(Fixed (I v _) g1) (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ... - where - go [] = Right c - go (d@(vr, g2) : vrs) - | checkVR vr v = go vrs - | otherwise = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, Constrained [d])) -merge c@(Constrained _) d@(Fixed _ _) = merge d c -merge (Constrained rs) (Constrained ss) = Right (Constrained (rs ++ ss)) +-- | Constrained instance. It represents the allowed instances for a package, +-- which can be either a fixed instance or a version range. +data CI = Fixed I | Constrained VR + deriving (Eq, Show) {------------------------------------------------------------------------------- Flagged dependencies @@ -123,80 +69,67 @@ -- rather than having the dependencies indexed by component, each dependency -- defines what component it is in. -- --- However, top-level goals are also modelled as dependencies, but of course --- these don't actually belong in any component of any package. Therefore, we --- parameterize 'FlaggedDeps' and derived datatypes with a type argument that --- specifies whether or not we have a component: we only ever instantiate this --- type argument with @()@ for top-level goals, or 'Component' for everything --- else (we could express this as a kind at the type-level, but that would --- require a very recent GHC). --- --- Note however, crucially, that independent of the type parameters, the list --- of dependencies underneath a flag choice or stanza choices _always_ uses --- Component as the type argument. This is important: when we pick a value for --- a flag, we _must_ know what component the new dependencies belong to, or --- else we don't be able to construct fine-grained reverse dependencies. -type FlaggedDeps comp qpn = [FlaggedDep comp qpn] +-- Note that each dependency is associated with a Component. We must know what +-- component the dependencies belong to, or else we won't be able to construct +-- fine-grained reverse dependencies. +type FlaggedDeps qpn = [FlaggedDep qpn] -- | Flagged dependencies can either be plain dependency constraints, -- or flag-dependent dependency trees. -data FlaggedDep comp qpn = +data FlaggedDep qpn = -- | Dependencies which are conditional on a flag choice. Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) -- | Dependencies which are conditional on whether or not a stanza -- (e.g., a test suite or benchmark) is enabled. | Stanza (SN qpn) (TrueFlaggedDeps qpn) - -- | Dependencies for which are always enabled, for the component - -- 'comp' (or requested for the user, if comp is @()@). - | Simple (Dep qpn) comp - deriving (Eq, Show) + -- | Dependencies which are always enabled, for the component 'comp'. + | Simple (LDep qpn) Component -- | Conversatively flatten out flagged dependencies -- -- NOTE: We do not filter out duplicates. -flattenFlaggedDeps :: FlaggedDeps Component qpn -> [(Dep qpn, Component)] +flattenFlaggedDeps :: FlaggedDeps qpn -> [(LDep qpn, Component)] flattenFlaggedDeps = concatMap aux where - aux :: FlaggedDep Component qpn -> [(Dep qpn, Component)] + aux :: FlaggedDep qpn -> [(LDep qpn, Component)] aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f aux (Stanza _ t) = flattenFlaggedDeps t aux (Simple d c) = [(d, c)] -type TrueFlaggedDeps qpn = FlaggedDeps Component qpn -type FalseFlaggedDeps qpn = FlaggedDeps Component qpn - --- | Is this dependency on an executable -type IsExe = Bool +type TrueFlaggedDeps qpn = FlaggedDeps qpn +type FalseFlaggedDeps qpn = FlaggedDeps qpn --- | A dependency (constraint) associates a package name with a --- constrained instance. +-- | A 'Dep' labeled with the reason it was introduced. -- --- 'Dep' intentionally has no 'Functor' instance because the type variable +-- 'LDep' intentionally has no 'Functor' instance because the type variable -- is used both to record the dependencies as well as who's doing the -- depending; having a 'Functor' instance makes bugs where we don't distinguish --- these two far too likely. (By rights 'Dep' ought to have two type variables.) -data Dep qpn = Dep IsExe qpn (CI qpn) -- ^ dependency on a package (possibly for executable - | Ext Extension -- ^ dependency on a language extension - | Lang Language -- ^ dependency on a language version - | Pkg PkgconfigName VR -- ^ dependency on a pkg-config package - deriving (Eq, Show) +-- these two far too likely. (By rights 'LDep' ought to have two type variables.) +data LDep qpn = LDep (DependencyReason qpn) (Dep qpn) -showDep :: Dep QPN -> String -showDep (Dep is_exe qpn (Fixed i v) ) = - (if P qpn /= v then showVar v ++ " => " else "") ++ - showQPN qpn ++ - (if is_exe then " (exe) " else "") ++ "==" ++ showI i -showDep (Dep is_exe qpn (Constrained [(vr, v)])) = - showVar v ++ " => " ++ showQPN qpn ++ - (if is_exe then " (exe) " else "") ++ showVR vr -showDep (Dep is_exe qpn ci ) = - showQPN qpn ++ (if is_exe then " (exe) " else "") ++ showCI ci -showDep (Ext ext) = "requires " ++ display ext -showDep (Lang lang) = "requires " ++ display lang -showDep (Pkg pn vr) = "requires pkg-config package " - ++ display pn ++ display vr - ++ ", not found in the pkg-config database" +-- | A dependency (constraint) associates a package name with a constrained +-- instance. It can also represent other types of dependencies, such as +-- dependencies on language extensions. +data Dep qpn = Dep (Maybe UnqualComponentName) qpn CI -- ^ dependency on a package (possibly for executable) + | Ext Extension -- ^ dependency on a language extension + | Lang Language -- ^ dependency on a language version + | Pkg PkgconfigName VR -- ^ dependency on a pkg-config package + deriving Functor +-- | The reason that a dependency is active. It identifies the package and any +-- flag and stanza choices that introduced the dependency. It contains +-- everything needed for creating ConflictSets or describing conflicts in solver +-- log messages. +data DependencyReason qpn = DependencyReason qpn [(Flag, FlagValue)] [Stanza] + deriving (Functor, Eq, Show) + +-- | Print the reason that a dependency was introduced. +showDependencyReason :: DependencyReason QPN -> String +showDependencyReason (DependencyReason qpn flags stanzas) = + intercalate " " $ + showQPN qpn + : map (uncurry showFlagValue) flags ++ map (\s -> showSBool s True) stanzas + -- | Options for goal qualification (used in 'qualifyDeps') -- -- See also 'defaultQualifyOptions' @@ -219,34 +152,37 @@ -- -- NOTE: It's the _dependencies_ of a package that may or may not be independent -- from the package itself. Package flag choices must of course be consistent. -qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps Component PN -> FlaggedDeps Component QPN +qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps PN -> FlaggedDeps QPN qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go where - go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN + go :: FlaggedDeps PN -> FlaggedDeps QPN go = map go1 - go1 :: FlaggedDep Component PN -> FlaggedDep Component QPN + go1 :: FlaggedDep PN -> FlaggedDep QPN go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f) go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t) - go1 (Simple dep comp) = Simple (goD dep comp) comp + go1 (Simple dep comp) = Simple (goLDep dep comp) comp -- Suppose package B has a setup dependency on package A. -- This will be recorded as something like -- - -- > Dep "A" (Constrained [(AnyVersion, Goal (P "B") reason]) + -- > LDep (DependencyReason "B") (Dep Nothing "A" (Constrained AnyVersion)) -- -- Observe that when we qualify this dependency, we need to turn that -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier - -- to the goal or the goal reason chain. + -- to the DependencyReason. + goLDep :: LDep PN -> Component -> LDep QPN + goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp) + goD :: Dep PN -> Component -> Dep QPN goD (Ext ext) _ = Ext ext goD (Lang lang) _ = Lang lang goD (Pkg pkn vr) _ = Pkg pkn vr - goD (Dep is_exe dep ci) comp - | is_exe = Dep is_exe (Q (PackagePath ns (Exe pn dep)) dep) (fmap (Q pp) ci) - | qBase dep = Dep is_exe (Q (PackagePath ns (Base pn)) dep) (fmap (Q pp) ci) - | qSetup comp = Dep is_exe (Q (PackagePath ns (Setup pn)) dep) (fmap (Q pp) ci) - | otherwise = Dep is_exe (Q (PackagePath ns inheritedQ) dep) (fmap (Q pp) ci) + goD (Dep mExe dep ci) comp + | isJust mExe = Dep mExe (Q (PackagePath ns (QualExe pn dep)) dep) ci + | qBase dep = Dep mExe (Q (PackagePath ns (QualBase pn )) dep) ci + | qSetup comp = Dep mExe (Q (PackagePath ns (QualSetup pn )) dep) ci + | otherwise = Dep mExe (Q (PackagePath ns inheritedQ ) dep) ci -- If P has a setup dependency on Q, and Q has a regular dependency on R, then -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup @@ -257,10 +193,10 @@ -- a detailed discussion. inheritedQ :: Qualifier inheritedQ = case q of - Setup _ -> q - Exe _ _ -> q - Unqualified -> q - Base _ -> Unqualified + QualSetup _ -> q + QualExe _ _ -> q + QualToplevel -> q + QualBase _ -> QualToplevel -- Should we qualify this goal with the 'Base' package path? qBase :: PN -> Bool @@ -277,56 +213,24 @@ -- what to link these dependencies to, we need to requalify @Q.B@ to become -- @Q'.B@; we do this by first removing all qualifiers and then calling -- 'qualifyDeps' again. -unqualifyDeps :: FlaggedDeps comp QPN -> FlaggedDeps comp PN +unqualifyDeps :: FlaggedDeps QPN -> FlaggedDeps PN unqualifyDeps = go where - go :: FlaggedDeps comp QPN -> FlaggedDeps comp PN + go :: FlaggedDeps QPN -> FlaggedDeps PN go = map go1 - go1 :: FlaggedDep comp QPN -> FlaggedDep comp PN + go1 :: FlaggedDep QPN -> FlaggedDep PN go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f) go1 (Stanza sn t) = Stanza (fmap unq sn) (go t) - go1 (Simple dep comp) = Simple (goD dep) comp + go1 (Simple dep comp) = Simple (goLDep dep) comp - goD :: Dep QPN -> Dep PN - goD (Dep is_exe qpn ci) = Dep is_exe (unq qpn) (fmap unq ci) - goD (Ext ext) = Ext ext - goD (Lang lang) = Lang lang - goD (Pkg pn vr) = Pkg pn vr + goLDep :: LDep QPN -> LDep PN + goLDep (LDep dr dep) = LDep (fmap unq dr) (fmap unq dep) unq :: QPN -> PN unq (Q _ pn) = pn {------------------------------------------------------------------------------- - Setting/forgetting the Component --------------------------------------------------------------------------------} - -forgetCompOpenGoal :: OpenGoal Component -> OpenGoal () -forgetCompOpenGoal = mapCompOpenGoal $ const () - -setCompFlaggedDeps :: Component -> FlaggedDeps () qpn -> FlaggedDeps Component qpn -setCompFlaggedDeps = mapCompFlaggedDeps . const - -{------------------------------------------------------------------------------- - Auxiliary: Mapping over the Component goal - - We don't export these, because the only type instantiations for 'a' and 'b' - here should be () or Component. (We could express this at the type level - if we relied on newer versions of GHC.) --------------------------------------------------------------------------------} - -mapCompOpenGoal :: (a -> b) -> OpenGoal a -> OpenGoal b -mapCompOpenGoal g (OpenGoal d gr) = OpenGoal (mapCompFlaggedDep g d) gr - -mapCompFlaggedDeps :: (a -> b) -> FlaggedDeps a qpn -> FlaggedDeps b qpn -mapCompFlaggedDeps = L.map . mapCompFlaggedDep - -mapCompFlaggedDep :: (a -> b) -> FlaggedDep a qpn -> FlaggedDep b qpn -mapCompFlaggedDep _ (Flagged fn nfo t f) = Flagged fn nfo t f -mapCompFlaggedDep _ (Stanza sn t ) = Stanza sn t -mapCompFlaggedDep g (Simple pn a ) = Simple pn (g a) - -{------------------------------------------------------------------------------- Reverse dependency map -------------------------------------------------------------------------------} @@ -345,86 +249,34 @@ -- | Reason why a goal is being added to a goal set. data GoalReason qpn = - UserGoal - | PDependency (PI qpn) - | FDependency (FN qpn) Bool - | SDependency (SN qpn) + UserGoal -- introduced by a build target + | DependencyGoal (DependencyReason qpn) -- introduced by a package deriving (Eq, Show, Functor) type QGoalReason = GoalReason QPN -class ResetVar f where - resetVar :: Var qpn -> f qpn -> f qpn - -instance ResetVar CI where - resetVar v (Fixed i _) = Fixed i v - resetVar v (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetVar v y)) vrs) - -instance ResetVar Dep where - resetVar v (Dep is_exe qpn ci) = Dep is_exe qpn (resetVar v ci) - resetVar _ (Ext ext) = Ext ext - resetVar _ (Lang lang) = Lang lang - resetVar _ (Pkg pn vr) = Pkg pn vr - -instance ResetVar Var where - resetVar = const - goalToVar :: Goal a -> Var a goalToVar (Goal v _) = v --- | Compute a singleton conflict set from a goal, containing just --- the goal variable. --- --- NOTE: This is just a call to 'varToConflictSet' under the hood; --- the 'GoalReason' is ignored. -goalVarToConflictSet :: Goal qpn -> ConflictSet qpn -goalVarToConflictSet (Goal g _gr) = varToConflictSet g - -- | Compute a singleton conflict set from a 'Var' -varToConflictSet :: Var qpn -> ConflictSet qpn +varToConflictSet :: Var QPN -> ConflictSet varToConflictSet = CS.singleton --- | A goal reason is mostly just a variable paired with the --- decision we made for that variable (except for user goals, --- where we cannot really point to a solver variable). This --- function drops the decision and recovers the list of --- variables (which will be empty or contain one element). --- -goalReasonToVars :: GoalReason qpn -> [Var qpn] -goalReasonToVars UserGoal = [] -goalReasonToVars (PDependency (PI qpn _)) = [P qpn] -goalReasonToVars (FDependency qfn _) = [F qfn] -goalReasonToVars (SDependency qsn) = [S qsn] - -{------------------------------------------------------------------------------- - Open goals --------------------------------------------------------------------------------} - --- | For open goals as they occur during the build phase, we need to store --- additional information about flags. -data OpenGoal comp = OpenGoal (FlaggedDep comp QPN) QGoalReason - deriving (Eq, Show) - --- | Closes a goal, i.e., removes all the extraneous information that we --- need only during the build phase. -close :: OpenGoal comp -> Goal QPN -close (OpenGoal (Simple (Dep _ qpn _) _) gr) = Goal (P qpn) gr -close (OpenGoal (Simple (Ext _) _) _ ) = - error "Distribution.Solver.Modular.Dependency.close: called on Ext goal" -close (OpenGoal (Simple (Lang _) _) _ ) = - error "Distribution.Solver.Modular.Dependency.close: called on Lang goal" -close (OpenGoal (Simple (Pkg _ _) _) _ ) = - error "Distribution.Solver.Modular.Dependency.close: called on Pkg goal" -close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr -close (OpenGoal (Stanza qsn _) gr) = Goal (S qsn) gr - -{------------------------------------------------------------------------------- - Version ranges paired with origins --------------------------------------------------------------------------------} +goalReasonToCS :: GoalReason QPN -> ConflictSet +goalReasonToCS UserGoal = CS.empty +goalReasonToCS (DependencyGoal dr) = dependencyReasonToCS dr -type VROrigin qpn = (VR, Var qpn) +-- | This function returns the solver variables responsible for the dependency. +-- It drops the flag and stanza values, which are only needed for log messages. +dependencyReasonToCS :: DependencyReason QPN -> ConflictSet +dependencyReasonToCS (DependencyReason qpn flags stanzas) = + CS.fromList $ P qpn : flagVars ++ map stanzaToVar stanzas + where + -- Filter out any flags that introduced the dependency with both values. + -- They don't need to be included in the conflict set, because changing the + -- flag value can't remove the dependency. + flagVars :: [Var QPN] + flagVars = [F (FN qpn fn) | (fn, fv) <- flags, fv /= FlagBoth] --- | Helper function to collapse a list of version ranges with origins into --- a single, simplified, version range. -collapse :: [VROrigin qpn] -> VR -collapse = simplifyVR . L.foldr ((.&&.) . fst) anyVR + stanzaToVar :: Stanza -> Var QPN + stanzaToVar = S . SN qpn diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Explore.hs b/cabal/cabal-install/Distribution/Solver/Modular/Explore.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Explore.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Explore.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Solver.Modular.Explore ( backjump @@ -20,11 +21,10 @@ import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts(..)) --- | This function takes the variable we're currently considering, an --- initial conflict set and a --- list of children's logs. Each log yields either a solution or a --- conflict set. The result is a combined log for the parent node that --- has explored a prefix of the children. +-- | This function takes the variable we're currently considering, a +-- last conflict set and a list of children's logs. Each log yields +-- either a solution or a conflict set. The result is a combined log for +-- the parent node that has explored a prefix of the children. -- -- We can stop traversing the children's logs if we find an individual -- conflict set that does not contain the current variable. In this @@ -37,37 +37,39 @@ -- return it immediately. If all children contain conflict sets, we can -- take the union as the combined conflict set. -- --- The initial conflict set corresponds to the justification that we +-- The last conflict set corresponds to the justification that we -- have to choose this goal at all. There is a reason why we have -- introduced the goal in the first place, and this reason is in conflict -- with the (virtual) option not to choose anything for the current -- variable. See also the comments for 'avoidSet'. -- backjump :: EnableBackjumping -> Var QPN - -> ConflictSet QPN -> W.WeightedPSQ w k (ConflictMap -> ConflictSetLog a) + -> ConflictSet -> W.WeightedPSQ w k (ConflictMap -> ConflictSetLog a) -> ConflictMap -> ConflictSetLog a -backjump (EnableBackjumping enableBj) var initial xs = - F.foldr combine logBackjump xs initial +backjump (EnableBackjumping enableBj) var lastCS xs = + F.foldr combine avoidGoal xs CS.empty where combine :: forall a . (ConflictMap -> ConflictSetLog a) - -> (ConflictSet QPN -> ConflictMap -> ConflictSetLog a) - -> ConflictSet QPN -> ConflictMap -> ConflictSetLog a + -> (ConflictSet -> ConflictMap -> ConflictSetLog a) + -> ConflictSet -> ConflictMap -> ConflictSetLog a combine x f csAcc cm = retry (x cm) next where - next :: (ConflictSet QPN, ConflictMap) -> ConflictSetLog a + next :: (ConflictSet, ConflictMap) -> ConflictSetLog a next (cs, cm') | enableBj && not (var `CS.member` cs) = logBackjump cs cm' | otherwise = f (csAcc `CS.union` cs) cm' - logBackjump :: ConflictSet QPN -> ConflictMap -> ConflictSetLog a - logBackjump cs cm = failWith (Failure cs Backjump) (cs, updateCM initial cm) - -- 'intial' instead of 'cs' here ---^ - -- since we do not want to double-count the - -- additionally accumulated conflicts. + -- This function represents the option to not choose a value for this goal. + avoidGoal :: ConflictSet -> ConflictMap -> ConflictSetLog a + avoidGoal cs !cm = logBackjump (cs `CS.union` lastCS) (updateCM lastCS cm) + -- 'lastCS' instead of 'cs' here ---^ + -- since we do not want to double-count the + -- additionally accumulated conflicts. -type ConflictSetLog = RetryLog Message (ConflictSet QPN, ConflictMap) + logBackjump :: ConflictSet -> ConflictMap -> ConflictSetLog a + logBackjump cs cm = failWith (Failure cs Backjump) (cs, cm) -type ConflictMap = Map (Var QPN) Int +type ConflictSetLog = RetryLog Message (ConflictSet, ConflictMap) getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a) getBestGoal cm = @@ -82,7 +84,7 @@ (error "getFirstGoal: empty goal choice") -- empty goal choice is an internal error (\ k v _xs -> (k, v)) -- commit to the first goal choice -updateCM :: ConflictSet QPN -> ConflictMap -> ConflictMap +updateCM :: ConflictSet -> ConflictMap -> ConflictMap updateCM cs cm = L.foldl' (\ cmc k -> M.alter inc k cmc) cm (CS.toList cs) where @@ -95,15 +97,15 @@ where go :: TreeF d c (Assignment -> Tree Assignment c) -> (Assignment -> Tree Assignment c) - go (FailF c fr) _ = Fail c fr - go (DoneF rdm _) a = Done rdm a - go (PChoiceF qpn y ts) (A pa fa sa) = PChoice qpn y $ W.mapWithKey f ts + go (FailF c fr) _ = Fail c fr + go (DoneF rdm _) a = Done rdm a + go (PChoiceF qpn rdm y ts) (A pa fa sa) = PChoice qpn rdm y $ W.mapWithKey f ts where f (POption k _) r = r (A (M.insert qpn k pa) fa sa) - go (FChoiceF qfn y t m ts) (A pa fa sa) = FChoice qfn y t m $ W.mapWithKey f ts + go (FChoiceF qfn rdm y t m d ts) (A pa fa sa) = FChoice qfn rdm y t m d $ W.mapWithKey f ts where f k r = r (A pa (M.insert qfn k fa) sa) - go (SChoiceF qsn y t ts) (A pa fa sa) = SChoice qsn y t $ W.mapWithKey f ts + go (SChoiceF qsn rdm y t ts) (A pa fa sa) = SChoice qsn rdm y t $ W.mapWithKey f ts where f k r = r (A pa fa (M.insert qsn k sa)) - go (GoalChoiceF ts) a = GoalChoice $ fmap ($ a) ts + go (GoalChoiceF rdm ts) a = GoalChoice rdm $ fmap ($ a) ts -- | A tree traversal that simultaneously propagates conflict sets up -- the tree from the leaves and creates a log. @@ -118,27 +120,25 @@ go :: TreeF Assignment QGoalReason (ConflictMap -> ConflictSetLog (Assignment, RevDepMap)) -> (ConflictMap -> ConflictSetLog (Assignment, RevDepMap)) - go (FailF c fr) = \ cm -> let failure = failWith (Failure c fr) - in if countConflicts - then failure (c, updateCM c cm) - else failure (c, cm) - go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm) - go (PChoiceF qpn gr ts) = + go (FailF c fr) = \ !cm -> failWith (Failure c fr) + (c, updateCM c cm) + go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm) + go (PChoiceF qpn _ gr ts) = backjump enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, W.mapWithKey -- when descending ... (\ k r cm -> tryWith (TryP qpn k) (r cm)) ts - go (FChoiceF qfn gr _ _ ts) = + go (FChoiceF qfn _ gr _ _ _ ts) = backjump enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, W.mapWithKey -- when descending ... (\ k r cm -> tryWith (TryF qfn k) (r cm)) ts - go (SChoiceF qsn gr _ ts) = + go (SChoiceF qsn _ gr _ ts) = backjump enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, W.mapWithKey -- when descending ... (\ k r cm -> tryWith (TryS qsn k) (r cm)) ts - go (GoalChoiceF ts) = \ cm -> + go (GoalChoiceF _ ts) = \ cm -> let (k, v) = getBestGoal' ts cm in continueWith (Next k) (v cm) @@ -150,32 +150,29 @@ -- always have to consider that we could perhaps make choices that would -- avoid the existence of the goal completely. -- --- Whenever we actual introduce a choice in the tree, we have already established +-- Whenever we actually introduce a choice in the tree, we have already established -- that the goal cannot be avoided. This is tracked in the "goal reason". -- The choice to avoid the goal therefore is a conflict between the goal itself -- and its goal reason. We build this set here, and pass it to the 'backjump' --- function as the initial conflict set. +-- function as the last conflict set. -- -- This has two effects: -- -- - In a situation where there are no choices available at all (this happens --- if an unknown package is requested), the initial conflict set becomes the +-- if an unknown package is requested), the last conflict set becomes the -- actual conflict set. -- -- - In a situation where all of the children's conflict sets contain the -- current variable, the goal reason of the current node will be added to the -- conflict set. -- -avoidSet :: Var QPN -> QGoalReason -> ConflictSet QPN +avoidSet :: Var QPN -> QGoalReason -> ConflictSet avoidSet var gr = - CS.fromList (var : goalReasonToVars gr) + CS.union (CS.singleton var) (goalReasonToCS gr) -- | Interface. backjumpAndExplore :: EnableBackjumping -> CountConflicts -> Tree d QGoalReason -> Log Message (Assignment, RevDepMap) backjumpAndExplore enableBj countConflicts = - toLog . exploreLog enableBj countConflicts . assign - where - toLog :: RetryLog step fail done -> Log step done - toLog = toProgress . mapFailure (const ()) + toProgress . exploreLog enableBj countConflicts . assign diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Flag.hs b/cabal/cabal-install/Distribution/Solver/Modular/Flag.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Flag.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Flag.hs @@ -6,43 +6,49 @@ , FN(..) , QFN , QSN + , Stanza , SN(..) , WeakOrTrivial(..) + , FlagValue(..) , mkFlag - , showFBool , showQFN , showQFNBool + , showFlagValue , showQSN , showQSNBool + , showSBool ) where import Data.Map as M import Prelude hiding (pi) -import Distribution.PackageDescription hiding (Flag) -- from Cabal +import qualified Distribution.PackageDescription as P -- from Cabal -import Distribution.Solver.Modular.Package +import Distribution.Solver.Types.Flag import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath -- | Flag name. Consists of a package instance and the flag identifier itself. -data FN qpn = FN (PI qpn) Flag +data FN qpn = FN qpn Flag deriving (Eq, Ord, Show, Functor) -- | Flag identifier. Just a string. -type Flag = FlagName +type Flag = P.FlagName +-- | Stanza identifier. +type Stanza = OptionalStanza + unFlag :: Flag -> String -unFlag = unFlagName +unFlag = P.unFlagName mkFlag :: String -> Flag -mkFlag = mkFlagName +mkFlag = P.mkFlagName -- | Flag info. Default value, whether the flag is manual, and -- whether the flag is weak. Manual flags can only be set explicitly. -- Weak flags are typically deferred by the solver. -data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool, fweak :: WeakOrTrivial } - deriving (Eq, Ord, Show) +data FInfo = FInfo { fdefault :: Bool, fmanual :: FlagType, fweak :: WeakOrTrivial } + deriving (Eq, Show) -- | Flag defaults. type FlagInfo = Map Flag FInfo @@ -51,7 +57,7 @@ type QFN = FN QPN -- | Stanza name. Paired with a package name, much like a flag. -data SN qpn = SN (PI qpn) OptionalStanza +data SN qpn = SN qpn Stanza deriving (Eq, Ord, Show, Functor) -- | Qualified stanza name. @@ -71,26 +77,32 @@ newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool } deriving (Eq, Ord, Show) -unStanza :: OptionalStanza -> String -unStanza TestStanzas = "test" -unStanza BenchStanzas = "bench" +-- | Value shown for a flag in a solver log message. The message can refer to +-- only the true choice, only the false choice, or both choices. +data FlagValue = FlagTrue | FlagFalse | FlagBoth + deriving (Eq, Show) showQFNBool :: QFN -> Bool -> String -showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b +showQFNBool qfn@(FN qpn _f) b = showQPN qpn ++ ":" ++ showFBool qfn b showQSNBool :: QSN -> Bool -> String -showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b +showQSNBool (SN qpn s) b = showQPN qpn ++ ":" ++ showSBool s b showFBool :: FN qpn -> Bool -> String -showFBool (FN _ f) True = "+" ++ unFlag f -showFBool (FN _ f) False = "-" ++ unFlag f +showFBool (FN _ f) v = P.showFlagValue (f, v) -showSBool :: SN qpn -> Bool -> String -showSBool (SN _ s) True = "*" ++ unStanza s -showSBool (SN _ s) False = "!" ++ unStanza s +-- | String representation of a flag-value pair. +showFlagValue :: P.FlagName -> FlagValue -> String +showFlagValue f FlagTrue = '+' : unFlag f +showFlagValue f FlagFalse = '-' : unFlag f +showFlagValue f FlagBoth = "+/-" ++ unFlag f +showSBool :: Stanza -> Bool -> String +showSBool s True = "*" ++ showStanza s +showSBool s False = "!" ++ showStanza s + showQFN :: QFN -> String -showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f +showQFN (FN qpn f) = showQPN qpn ++ ":" ++ unFlag f showQSN :: QSN -> String -showQSN (SN pi f) = showPI pi ++ ":" ++ unStanza f +showQSN (SN qpn s) = showQPN qpn ++ ":" ++ showStanza s diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Index.hs b/cabal/cabal-install/Distribution/Solver/Modular/Index.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Index.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Index.hs @@ -13,8 +13,7 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree - -import Distribution.Solver.Types.ComponentDeps (Component) +import Distribution.Types.UnqualComponentName -- | An index contains information about package instances. This is a nested -- dictionary. Package names are mapped to instances, which in turn is mapped @@ -22,13 +21,12 @@ type Index = Map PN (Map I PInfo) -- | Info associated with a package instance. --- Currently, dependencies, flags and failure reasons. +-- Currently, dependencies, executable names, flags and failure reasons. -- Packages that have a failure reason recorded for them are disabled -- globally, for reasons external to the solver. We currently use this -- for shadowing which essentially is a GHC limitation, and for -- installed packages that are broken. -data PInfo = PInfo (FlaggedDeps Component PN) FlagInfo (Maybe FailReason) - deriving (Show) +data PInfo = PInfo (FlaggedDeps PN) [UnqualComponentName] FlagInfo (Maybe FailReason) mkIndex :: [(PN, I, PInfo)] -> Index mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) @@ -42,9 +40,9 @@ | -- Find all versions of base .. Just is <- [M.lookup base idx] -- .. which are installed .. - , (I _ver (Inst _), PInfo deps _flagNfo _fr) <- M.toList is + , (I _ver (Inst _), PInfo deps _exes _flagNfo _fr) <- M.toList is -- .. and flatten all their dependencies .. - , (Dep _is_exe dep _ci, _comp) <- flattenFlaggedDeps deps + , (LDep _ (Dep _is_exe dep _ci), _comp) <- flattenFlaggedDeps deps ] , qoSetupIndependent = True } 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 @@ -7,18 +7,28 @@ import Data.Maybe import Data.Monoid as Mon import Data.Set as S -import Prelude hiding (pi) import Distribution.Compiler import Distribution.InstalledPackageInfo as IPI import Distribution.Package -- from Cabal +import Distribution.Simple.BuildToolDepends -- from Cabal +import Distribution.Simple.Utils (cabalVersion) -- from Cabal +import Distribution.Types.ExeDependency -- from Cabal +import Distribution.Types.PkgconfigDependency -- from Cabal +import Distribution.Types.ComponentName -- from Cabal +import Distribution.Types.UnqualComponentName -- from Cabal +import Distribution.Types.CondTree -- from Cabal +import Distribution.Types.MungedPackageId -- from Cabal +import Distribution.Types.MungedPackageName -- from Cabal import Distribution.PackageDescription as PD -- from Cabal import Distribution.PackageDescription.Configuration as PDC import qualified Distribution.Simple.PackageIndex as SI import Distribution.System import Distribution.Types.ForeignLib -import Distribution.Solver.Types.ComponentDeps (Component(..)) +import Distribution.Solver.Types.ComponentDeps + ( Component(..), componentNameToComponent ) +import Distribution.Solver.Types.Flag import Distribution.Solver.Types.OptionalStanza import qualified Distribution.Solver.Types.PackageIndex as CI import Distribution.Solver.Types.Settings @@ -44,8 +54,8 @@ -- explicitly requested. convPIs :: OS -> Arch -> CompilerInfo -> ShadowPkgs -> StrongFlags -> SolveExecutables -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> Index -convPIs os arch comp sip strfl sexes iidx sidx = - mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl sexes sidx) +convPIs os arch comp sip strfl solveExes iidx sidx = + mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl solveExes sidx) -- | Convert a Cabal installed package index to the simpler, -- more uniform index format of the solver. @@ -54,41 +64,75 @@ -- apply shadowing whenever there are multiple installed packages with -- the same version [ maybeShadow (convIP idx pkg) - | (_pkgid, pkgs) <- SI.allPackagesBySourcePackageId idx + -- IMPORTANT to get internal libraries. See + -- Note [Index conversion with internal libraries] + | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ] where -- shadowing is recorded in the package info - shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed)) - shadow x = x + shadow (pn, i, PInfo fdeps exes fds _) | sip = (pn, i, PInfo fdeps exes fds (Just Shadowed)) + shadow x = x +-- | Extract/recover the the package ID from an installed package info, and convert it to a solver's I. +convId :: InstalledPackageInfo -> (PN, I) +convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi) + where MungedPackageId mpn ver = mungedId ipi + -- HACK. See Note [Index conversion with internal libraries] + pn = mkPackageName (unMungedPackageName mpn) + -- | Convert a single installed package into the solver-specific format. convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) convIP idx ipi = - case mapM (convIPId pn idx) (IPI.depends ipi) of - Nothing -> (pn, i, PInfo [] M.empty (Just Broken)) - Just fds -> (pn, i, PInfo (setComp fds) M.empty Nothing) + case mapM (convIPId (DependencyReason pn [] []) comp idx) (IPI.depends ipi) of + Nothing -> (pn, i, PInfo [] [] M.empty (Just Broken)) + Just fds -> (pn, i, PInfo fds [] M.empty Nothing) where - -- We assume that all dependencies of installed packages are _library_ deps - ipid = IPI.installedUnitId ipi - i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid) - pn = pkgName (sourcePackageId ipi) - setComp = setCompFlaggedDeps ComponentLib + (pn, i) = convId ipi + -- 'sourceLibName' is unreliable, but for now we only really use this for + -- primary libs anyways + comp = componentNameToComponent $ libraryComponentName $ sourceLibName ipi -- TODO: Installed packages should also store their encapsulations! +-- Note [Index conversion with internal libraries] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Something very interesting happens when we have internal libraries +-- in our index. In this case, we maybe have p-0.1, which itself +-- depends on the internal library p-internal ALSO from p-0.1. +-- Here's the danger: +-- +-- - If we treat both of these packages as having PN "p", +-- then the solver will try to pick one or the other, +-- but never both. +-- +-- - If we drop the internal packages, now p-0.1 has a +-- dangling dependency on an "installed" package we know +-- nothing about. Oops. +-- +-- An expedient hack is to put p-internal into cabal-install's +-- index as a MUNGED package name, so that it doesn't conflict +-- with anyone else (except other instances of itself). But +-- yet, we ought NOT to say that PNs in the solver are munged +-- package names, because they're not; for source packages, +-- we really will never see munged package names. +-- +-- The tension here is that the installed package index is actually +-- per library, but the solver is per package. We need to smooth +-- it over, and munging the package names is a pretty good way to +-- do it. + -- | Convert dependencies specified by an installed package id into -- flagged dependencies of the solver. -- -- May return Nothing if the package can't be found in the index. That -- indicates that the original package having this dependency is broken -- and should be ignored. -convIPId :: PN -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep () PN) -convIPId pn' idx ipid = +convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep PN) +convIPId dr comp idx ipid = case SI.lookupUnitId idx ipid of Nothing -> Nothing - Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid) - pn = pkgName (sourcePackageId ipi) - in Just (D.Simple (Dep False pn (Fixed i (P pn'))) ()) + Just ipi -> let (pn, i) = convId ipi + in Just (D.Simple (LDep dr (Dep Nothing pn (Fixed i))) comp) -- NB: something we pick up from the -- InstalledPackageIndex is NEVER an executable @@ -96,13 +140,13 @@ -- more uniform index format of the solver. convSPI' :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] -convSPI' os arch cinfo strfl sexes = L.map (convSP os arch cinfo strfl sexes) . CI.allPackages +convSPI' os arch cinfo strfl solveExes = L.map (convSP os arch cinfo strfl solveExes) . CI.allPackages -- | Convert a single source package into the solver-specific format. convSP :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo) -convSP os arch cinfo strfl sexes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = +convSP os arch cinfo strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = let i = I pv InRepo - in (pn, i, convGPD os arch cinfo strfl sexes (PI pn i) gpd) + in (pn, i, convGPD os arch cinfo strfl solveExes pn gpd) -- We do not use 'flattenPackageDescription' or 'finalizePD' -- from 'Distribution.PackageDescription.Configuration' here, because we @@ -110,8 +154,8 @@ -- | Convert a generic package description to a solver-specific 'PInfo'. convGPD :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> - PI PN -> GenericPackageDescription -> PInfo -convGPD os arch cinfo strfl sexes pi + PN -> GenericPackageDescription -> PInfo +convGPD os arch cinfo strfl solveExes pn (GenericPackageDescription pkg flags mlib sub_libs flibs exes tests benchs) = let fds = flagInfo strfl flags @@ -125,30 +169,66 @@ ipns = S.fromList $ [ unqualComponentNameToPackageName nm | (nm, _) <- sub_libs ] - conv :: Mon.Monoid a => Component -> (a -> BuildInfo) -> - CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN - conv comp getInfo = convCondTree os arch cinfo pi fds comp getInfo ipns sexes . - PDC.addBuildableCondition getInfo + conv :: Mon.Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN -> + CondTree ConfVar [Dependency] a -> FlaggedDeps PN + conv comp getInfo dr = + convCondTree dr pkg os arch cinfo pn fds comp getInfo ipns solveExes . + PDC.addBuildableCondition getInfo + initDR = DependencyReason pn [] [] + flagged_deps - = concatMap (\ds -> conv ComponentLib libBuildInfo ds) (maybeToList mlib) - ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo ds) sub_libs - ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm) foreignLibBuildInfo ds) flibs - ++ concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo ds) exes - ++ prefix (Stanza (SN pi TestStanzas)) - (L.map (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo ds) tests) - ++ prefix (Stanza (SN pi BenchStanzas)) - (L.map (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo ds) benchs) - ++ maybe [] (convSetupBuildInfo pi) (setupBuildInfo pkg) + = concatMap (\ds -> conv ComponentLib libBuildInfo initDR ds) (maybeToList mlib) + ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo initDR ds) sub_libs + ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm) foreignLibBuildInfo initDR ds) flibs + ++ concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo initDR ds) exes + ++ prefix (Stanza (SN pn TestStanzas)) + (L.map (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo (addStanza TestStanzas initDR) ds) + tests) + ++ prefix (Stanza (SN pn BenchStanzas)) + (L.map (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo (addStanza BenchStanzas initDR) ds) + benchs) + ++ maybe [] (convSetupBuildInfo pn) (setupBuildInfo pkg) + addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn + addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (s : ss) + + -- | We infer the maximally supported spec-version from @lib:Cabal@'s version + -- + -- As we cannot predict the future, we can only properly support + -- spec-versions predating (and including) the @lib:Cabal@ version + -- used by @cabal-install@. + -- + -- This relies on 'cabalVersion' having always at least 3 components to avoid + -- comparisons like @2.0.0 > 2.0@ which would result in confusing results. + -- + -- NOTE: Before we can switch to a /normalised/ spec-version + -- comparison (e.g. by truncating to 3 components, and removing + -- trailing zeroes) we'd have to make sure all other places where + -- the spec-version is compared against a bound do it + -- consistently. + maxSpecVer = cabalVersion + + -- | Required/declared spec-version of the package + -- + -- We don't truncate patch-levels, as specifying a patch-level + -- spec-version is discouraged and not supported anymore starting + -- with spec-version 2.2. + reqSpecVer = specVersion pkg + + -- | A too-new specVersion is turned into a global 'FailReason' + -- which prevents the solver from selecting this release (and if + -- forced to, emit a meaningful solver error message). + fr | reqSpecVer > maxSpecVer = Just (UnsupportedSpecVer reqSpecVer) + | otherwise = Nothing in - PInfo flagged_deps fds Nothing + PInfo flagged_deps (L.map fst exes) fds fr -- | Create a flagged dependency tree from a list @fds@ of flagged -- dependencies, using @f@ to form the tree node (@f@ will be -- something like @Stanza sn@). -prefix :: (FlaggedDeps comp qpn -> FlaggedDep comp' qpn) - -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' qpn +prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) + -> [FlaggedDeps qpn] -> FlaggedDeps qpn prefix _ [] = [] prefix f fds = [f (concat fds)] @@ -156,9 +236,10 @@ -- unless strong flags have been selected explicitly. flagInfo :: StrongFlags -> [PD.Flag] -> FlagInfo flagInfo (StrongFlags strfl) = - M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (weak m))) + M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m))) where weak m = WeakOrTrivial $ not (strfl || m) + flagType m = if m then Manual else Automatic -- | Internal package names, which should not be interpreted as true -- dependencies. @@ -166,7 +247,7 @@ -- | Convenience function to delete a 'FlaggedDep' if it's -- for a 'PN' that isn't actually real. -filterIPNs :: IPNs -> Dependency -> FlaggedDep Component PN -> FlaggedDeps Component PN +filterIPNs :: IPNs -> Dependency -> FlaggedDep PN -> FlaggedDeps PN filterIPNs ipns (Dependency pn _) fd | S.notMember pn ipns = [fd] | otherwise = [] @@ -174,47 +255,32 @@ -- | Convert condition trees to flagged dependencies. Mutually -- recursive with 'convBranch'. See 'convBranch' for an explanation -- of all arguments preceeding the input 'CondTree'. -convCondTree :: OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo -> +convCondTree :: DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo -> Component -> (a -> BuildInfo) -> IPNs -> SolveExecutables -> - CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN -convCondTree os arch cinfo pi@(PI pn _) fds comp getInfo ipns sexes@(SolveExecutables sexes') (CondNode info ds branches) = + CondTree ConfVar [Dependency] a -> FlaggedDeps PN +convCondTree dr pkg os arch cinfo pn fds comp getInfo ipns solveExes@(SolveExecutables solveExes') (CondNode info ds branches) = concatMap - (\d -> filterIPNs ipns d (D.Simple (convLibDep pn d) comp)) - ds -- unconditional package dependencies - ++ L.map (\e -> D.Simple (Ext e) comp) (PD.allExtensions bi) -- unconditional extension dependencies - ++ L.map (\l -> D.Simple (Lang l) comp) (PD.allLanguages bi) -- unconditional language dependencies - ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (Pkg pkn vr) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies - ++ concatMap (convBranch os arch cinfo pi fds comp getInfo ipns sexes) branches + (\d -> filterIPNs ipns d (D.Simple (convLibDep dr d) comp)) ds -- unconditional package dependencies + ++ L.map (\e -> D.Simple (LDep dr (Ext e)) comp) (PD.allExtensions bi) -- unconditional extension dependencies + ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (PD.allLanguages bi) -- unconditional language dependencies + ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies + ++ concatMap (convBranch dr pkg os arch cinfo pn fds comp getInfo ipns solveExes) branches -- build-tools dependencies -- NB: Only include these dependencies if SolveExecutables -- is True. It might be false in the legacy solver -- codepath, in which case there won't be any record of -- an executable we need. - ++ [ D.Simple (convExeDep pn (Dependency pn' vr)) comp - | sexes' - , LegacyExeDependency exe vr <- PD.buildTools bi - , Just pn' <- return $ packageProvidingBuildTool exe + ++ [ D.Simple (convExeDep dr exeDep) comp + | solveExes' + , exeDep <- getAllToolDependencies pkg bi + , not $ isInternal pkg exeDep ] where bi = getInfo info --- | This function maps known @build-tools@ entries to Haskell package --- names which provide them. This mapping corresponds exactly to --- those build-tools that Cabal understands by default --- ('builtinPrograms'), and are cabal install'able. This mapping is --- purely for legacy; for other executables, @tool-depends@ should be --- used instead. --- -packageProvidingBuildTool :: String -> Maybe PackageName -packageProvidingBuildTool s = - if s `elem` ["hscolour", "haddock", "happy", "alex", "hsc2hs", - "c2hs", "cpphs", "greencard"] - then Just (mkPackageName s) - else Nothing - -- | Branch interpreter. Mutually recursive with 'convCondTree'. -- -- Here, we try to simplify one of Cabal's condition tree branches into the @@ -229,7 +295,7 @@ -- 1. Some pre dependency-solving known information ('OS', 'Arch', -- 'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables, -- --- 2. The package instance @'PI' 'PN'@ which this condition tree +-- 2. The package name @'PN'@ which this condition tree -- came from, so that we can correctly associate @flag()@ -- variables with the correct package name qualifier, -- @@ -246,27 +312,41 @@ -- -- 6. The set of package names which should be considered internal -- dependencies, and thus not handled as dependencies. -convBranch :: OS -> Arch -> CompilerInfo -> - PI PN -> FlagInfo -> +convBranch :: DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> + PN -> FlagInfo -> Component -> (a -> BuildInfo) -> IPNs -> SolveExecutables -> - (Condition ConfVar, - CondTree ConfVar [Dependency] a, - Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps Component PN -convBranch os arch cinfo pi@(PI pn _) fds comp getInfo ipns sexes (c', t', mf') = - go c' ( convCondTree os arch cinfo pi fds comp getInfo ipns sexes t') - (maybe [] (convCondTree os arch cinfo pi fds comp getInfo ipns sexes) mf') + CondBranch ConfVar [Dependency] a -> + FlaggedDeps PN +convBranch dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBranch c' t' mf') = + go c' + (\dr' -> convCondTree dr' pkg os arch cinfo pn fds comp getInfo ipns solveExes t') + (\dr' -> maybe [] (convCondTree dr' pkg os arch cinfo pn fds comp getInfo ipns solveExes) mf') + dr where - go :: Condition ConfVar -> - FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN + go :: Condition ConfVar + -> (DependencyReason PN -> FlaggedDeps PN) + -> (DependencyReason PN -> FlaggedDeps PN) + -> DependencyReason PN -> FlaggedDeps PN go (Lit True) t _ = t go (Lit False) _ f = f go (CNot c) t f = go c f t go (CAnd c d) t f = go c (go d t f) f go (COr c d) t f = go c t (go d t f) - go (Var (Flag fn)) t f = extractCommon t f ++ [Flagged (FN pi fn) (fds ! fn) t f] + go (Var (Flag fn)) t f = \dr' -> + -- Add each flag to the DependencyReason for all dependencies below, + -- including any extracted dependencies. Extracted dependencies are + -- introduced by both flag values (FlagBoth). Note that we don't + -- actually need to add the flag to the extracted dependencies for + -- correct backjumping; the information only improves log messages by + -- giving the user the full reason for each dependency. + let addFlagVal v = addFlag fn v dr' + in extractCommon (t (addFlagVal FlagBoth)) + (f (addFlagVal FlagBoth)) + ++ [ Flagged (FN pn fn) (fds ! fn) (t (addFlagVal FlagTrue)) + (f (addFlagVal FlagFalse)) ] go (Var (OS os')) t f | os == os' = t | otherwise = f @@ -284,35 +364,46 @@ where matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv + addFlag :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn + addFlag fn v (DependencyReason pn' flags stanzas) = + DependencyReason pn' ((fn, v) : flags) stanzas + -- If both branches contain the same package as a simple dep, we lift it to - -- the next higher-level, but without constraints. This heuristic together - -- with deferring flag choices will then usually first resolve this package, - -- and try an already installed version before imposing a default flag choice - -- that might not be what we want. + -- the next higher-level, but with the union of version ranges. This + -- heuristic together with deferring flag choices will then usually first + -- resolve this package, and try an already installed version before imposing + -- a default flag choice that might not be what we want. -- -- Note that we make assumptions here on the form of the dependencies that - -- can occur at this point. In particular, no occurrences of Fixed, and no - -- occurrences of multiple version ranges, as all dependencies below this - -- point have been generated using 'convLibDep'. + -- can occur at this point. In particular, no occurrences of Fixed, as all + -- dependencies below this point have been generated using 'convLibDep'. -- -- WARNING: This is quadratic! - extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN - extractCommon ps ps' = [ D.Simple (Dep is_exe1 pn1 (Constrained [(vr1 .||. vr2, P pn)])) comp - | D.Simple (Dep is_exe1 pn1 (Constrained [(vr1, _)])) _ <- ps - , D.Simple (Dep is_exe2 pn2 (Constrained [(vr2, _)])) _ <- ps' - , pn1 == pn2 - , is_exe1 == is_exe2 - ] + extractCommon :: Eq pn => FlaggedDeps pn -> FlaggedDeps pn -> FlaggedDeps pn + extractCommon ps ps' = + [ D.Simple (LDep (mergeDRs vs1 vs2) (Dep is_exe1 pn1 (Constrained $ vr1 .||. vr2))) comp + | D.Simple (LDep vs1 (Dep is_exe1 pn1 (Constrained vr1))) _ <- ps + , D.Simple (LDep vs2 (Dep is_exe2 pn2 (Constrained vr2))) _ <- ps' + , pn1 == pn2 + , is_exe1 == is_exe2 + ] + where + -- Merge the DependencyReasons, because the extracted dependency can be + -- avoided by removing the dependency from either side of the + -- conditional. + mergeDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn + mergeDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) = + DependencyReason pn' (nub $ fs1 ++ fs2) (nub $ ss1 ++ ss2) -- | Convert a Cabal dependency on a library to a solver-specific dependency. -convLibDep :: PN -> Dependency -> Dep PN -convLibDep pn' (Dependency pn vr) = Dep False {- not exe -} pn (Constrained [(vr, P pn')]) +convLibDep :: DependencyReason PN -> Dependency -> LDep PN +convLibDep dr (Dependency pn vr) = LDep dr $ Dep Nothing pn (Constrained vr) --- | Convert a Cabal dependency on a executable (build-tools) to a solver-specific dependency. -convExeDep :: PN -> Dependency -> Dep PN -convExeDep pn' (Dependency pn vr) = Dep True pn (Constrained [(vr, P pn')]) +-- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency. +convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN +convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (Just exe) pn (Constrained vr) -- | Convert setup dependencies -convSetupBuildInfo :: PI PN -> SetupBuildInfo -> FlaggedDeps Component PN -convSetupBuildInfo (PI pn _i) nfo = - L.map (\d -> D.Simple (convLibDep pn d) ComponentSetup) (PD.setupDepends nfo) +convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN +convSetupBuildInfo pn nfo = + L.map (\d -> D.Simple (convLibDep (DependencyReason pn [] []) d) ComponentSetup) (PD.setupDepends nfo) diff --git a/cabal/cabal-install/Distribution/Solver/Modular/LabeledGraph.hs b/cabal/cabal-install/Distribution/Solver/Modular/LabeledGraph.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/LabeledGraph.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/LabeledGraph.hs @@ -49,7 +49,7 @@ max_v = length edges0 - 1 bounds0 = (0, max_v) :: (Vertex, Vertex) sorted_edges = sortBy lt edges0 - edges1 = zipWith (,) [0..] sorted_edges + edges1 = zip [0..] sorted_edges graph = array bounds0 [(v, (mapMaybe mk_edge ks)) | (v, (_, _, ks)) <- edges1] 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 @@ -1,23 +1,23 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Solver.Modular.Linking ( - addLinking - , validateLinking + validateLinking ) where import Prelude () -import Distribution.Client.Compat.Prelude hiding (get,put) +import Distribution.Solver.Compat.Prelude hiding (get,put) import Control.Exception (assert) import Control.Monad.Reader 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 +import Distribution.Client.Utils.Assertion import Distribution.Solver.Modular.Assignment import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag @@ -29,68 +29,7 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.ComponentDeps (Component) - -{------------------------------------------------------------------------------- - Add linking --------------------------------------------------------------------------------} - -type RelatedGoals = Map (PN, I) [PackagePath] -type Linker = Reader RelatedGoals - --- | Introduce link nodes into the tree --- --- Linking is a traversal of the solver tree that adapts package choice nodes --- and adds the option to link wherever appropriate: Package goals are called --- "related" if they are for the same instance of the same package (but have --- different prefixes). A link option is available in a package choice node --- whenever we can choose an instance that has already been chosen for a related --- goal at a higher position in the tree. We only create link options for --- related goals that are not themselves linked, because the choice to link to a --- linked goal is the same as the choice to link to the target of that goal's --- linking. --- --- The code here proceeds by maintaining a finite map recording choices that --- have been made at higher positions in the tree. For each pair of package name --- and instance, it stores the prefixes at which we have made a choice for this --- package instance. Whenever we make an unlinked choice, we extend the map. --- Whenever we find a choice, we look into the map in order to find out what --- link options we have to add. -addLinking :: Tree d c -> Tree d c -addLinking = (`runReader` M.empty) . cata go - where - go :: TreeF d c (Linker (Tree d c)) -> Linker (Tree d c) - - -- The only nodes of interest are package nodes - go (PChoiceF qpn gr cs) = do - env <- ask - let linkedCs = W.fromList $ concatMap (linkChoices env qpn) (W.toList cs) - unlinkedCs = W.mapWithKey (goP qpn) cs - allCs <- T.sequence $ unlinkedCs `W.union` linkedCs - return $ PChoice qpn gr allCs - go _otherwise = - innM _otherwise - - -- Recurse underneath package choices. Here we just need to make sure - -- that we record the package choice so that it is available below - goP :: QPN -> POption -> Linker (Tree d c) -> Linker (Tree d c) - goP (Q pp pn) (POption i Nothing) = local (M.insertWith (++) (pn, i) [pp]) - goP _ _ = alreadyLinked - -linkChoices :: forall a w . RelatedGoals - -> QPN - -> (w, POption, a) - -> [(w, POption, a)] -linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) = - map aux (M.findWithDefault [] (pn, i) related) - where - aux :: PackagePath -> (w, POption, a) - aux pp = (weight, POption i (Just pp), subtree) -linkChoices _ _ (_, POption _ (Just _), _) = - alreadyLinked - -alreadyLinked :: a -alreadyLinked = error "addLinking called on tree that already contains linked nodes" +import Distribution.Types.GenericPackageDescription (unFlagName) {------------------------------------------------------------------------------- Validation @@ -120,8 +59,13 @@ , vsFlags :: FAssignment , vsStanzas :: SAssignment , vsQualifyOptions :: QualifyOptions + + -- Saved qualified dependencies. Every time 'validateLinking' makes a + -- package choice, it qualifies the package's dependencies and saves them in + -- this map. Then the qualified dependencies are available for subsequent + -- flag and stanza choices for the same package. + , vsSaved :: Map QPN (FlaggedDeps QPN) } - deriving Show type Validate = Reader ValidateState @@ -137,15 +81,15 @@ where go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c) - go (PChoiceF qpn gr cs) = - PChoice qpn gr <$> T.sequence (W.mapWithKey (goP qpn) cs) - go (FChoiceF qfn gr t m cs) = - FChoice qfn gr t m <$> T.sequence (W.mapWithKey (goF qfn) cs) - go (SChoiceF qsn gr t cs) = - SChoice qsn gr t <$> T.sequence (W.mapWithKey (goS qsn) cs) + go (PChoiceF qpn rdm gr cs) = + PChoice qpn rdm gr <$> T.sequence (W.mapWithKey (goP qpn) cs) + go (FChoiceF qfn rdm gr t m d cs) = + FChoice qfn rdm gr t m d <$> T.sequence (W.mapWithKey (goF qfn) cs) + go (SChoiceF qsn rdm gr t cs) = + SChoice qsn rdm gr t <$> T.sequence (W.mapWithKey (goS qsn) cs) -- For the other nodes we just recurse - go (GoalChoiceF cs) = GoalChoice <$> T.sequence cs + go (GoalChoiceF rdm cs) = GoalChoice rdm <$> T.sequence cs go (DoneF revDepMap s) = return $ Done revDepMap s go (FailF conflictSet failReason) = return $ Fail conflictSet failReason @@ -153,11 +97,12 @@ goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) goP qpn@(Q _pp pn) opt@(POption i _) r = do vs <- ask - let PInfo deps _ _ = vsIndex vs ! pn ! i - qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps + let PInfo deps _ _ _ = vsIndex vs ! pn ! i + qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps + newSaved = M.insert qpn qdeps (vsSaved vs) case execUpdateState (pickPOption qpn opt qdeps) vs of Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) - Right vs' -> local (const vs') r + Right vs' -> local (const vs' { vsSaved = newSaved }) r -- Flag choices goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) @@ -182,13 +127,14 @@ , vsFlags = M.empty , vsStanzas = M.empty , vsQualifyOptions = defaultQualifyOptions index + , vsSaved = M.empty } {------------------------------------------------------------------------------- Updating the validation state -------------------------------------------------------------------------------} -type Conflict = (ConflictSet QPN, String) +type Conflict = (ConflictSet, String) newtype UpdateState a = UpdateState { unUpdateState :: StateT ValidateState (Either Conflict) a @@ -198,7 +144,7 @@ instance MonadState ValidateState UpdateState where get = UpdateState $ get put st = UpdateState $ do - assert (lgInvariant $ vsLinks st) $ return () + expensiveAssert (lgInvariant $ vsLinks st) $ return () put st lift' :: Either Conflict a -> UpdateState a @@ -210,7 +156,7 @@ execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState execUpdateState = execStateT . unUpdateState -pickPOption :: QPN -> POption -> FlaggedDeps Component QPN -> UpdateState () +pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState () pickPOption qpn (POption i Nothing) _deps = pickConcrete qpn i pickPOption qpn (POption i (Just pp')) deps = pickLink qpn i pp' deps @@ -228,7 +174,7 @@ Just lg -> makeCanonical lg qpn i -pickLink :: QPN -> I -> PackagePath -> FlaggedDeps Component QPN -> UpdateState () +pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState () pickLink qpn@(Q _pp pn) i pp' deps = do vs <- get @@ -256,11 +202,11 @@ assert (sanityCheck (lgCanon lgTarget)) $ return () -- Merge the two link groups (updateLinkGroup will propagate the change) - lgTarget' <- lift' $ lgMerge [] lgSource lgTarget + lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget updateLinkGroup lgTarget' -- Make sure all dependencies are linked as well - linkDeps target [P qpn] deps + linkDeps target deps makeCanonical :: LinkGroup -> QPN -> I -> UpdateState () makeCanonical lg qpn@(Q pp _) i = @@ -284,47 +230,47 @@ -- because having the direct dependencies in a link group means that we must -- have already made or will make sooner or later a link choice for one of these -- as well, and cover their dependencies at that point. -linkDeps :: QPN -> [Var QPN] -> FlaggedDeps Component QPN -> UpdateState () -linkDeps target = \blame deps -> do +linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState () +linkDeps target = \deps -> do -- linkDeps is called in two places: when we first link one package to -- another, and when we discover more dependencies of an already linked -- package after doing some flag assignment. It is therefore important that -- flag assignments cannot influence _how_ dependencies are qualified; -- fortunately this is a documented property of 'qualifyDeps'. rdeps <- requalify deps - go blame deps rdeps + go deps rdeps where - go :: [Var QPN] -> FlaggedDeps Component QPN -> FlaggedDeps Component QPN -> UpdateState () - go = zipWithM_ . go1 + go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState () + go = zipWithM_ go1 - go1 :: [Var QPN] -> FlaggedDep Component QPN -> FlaggedDep Component QPN -> UpdateState () - go1 blame dep rdep = case (dep, rdep) of - (Simple (Dep _ qpn _) _, ~(Simple (Dep _ qpn' _) _)) -> do + go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState () + go1 dep rdep = case (dep, rdep) of + (Simple (LDep dr1 (Dep _ qpn _)) _, ~(Simple (LDep dr2 (Dep _ qpn' _)) _)) -> do vs <- get let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs - lg'' <- lift' $ lgMerge blame lg lg' + lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToCS) dr1 dr2) lg lg' updateLinkGroup lg'' (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do vs <- get case M.lookup fn (vsFlags vs) of Nothing -> return () -- flag assignment not yet known - Just True -> go (F fn:blame) t t' - Just False -> go (F fn:blame) f f' + Just True -> go t t' + Just False -> go f f' (Stanza sn t, ~(Stanza _ t')) -> do vs <- get case M.lookup sn (vsStanzas vs) of Nothing -> return () -- stanza assignment not yet known - Just True -> go (S sn:blame) t t' + Just True -> go t t' Just False -> return () -- stanza not enabled; no new deps -- For extensions and language dependencies, there is nothing to do. -- No choice is involved, just checking, so there is nothing to link. -- The same goes for for pkg-config constraints. - (Simple (Ext _) _, _) -> return () - (Simple (Lang _) _, _) -> return () - (Simple (Pkg _ _) _, _) -> return () + (Simple (LDep _ (Ext _)) _, _) -> return () + (Simple (LDep _ (Lang _)) _, _) -> return () + (Simple (LDep _ (Pkg _ _)) _, _) -> return () - requalify :: FlaggedDeps Component QPN -> UpdateState (FlaggedDeps Component QPN) + requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN) requalify deps = do vs <- get return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps) @@ -341,7 +287,7 @@ verifyStanza qsn linkNewDeps (S qsn) b --- | Link dependencies that we discover after making a flag choice. +-- | Link dependencies that we discover after making a flag or stanza choice. -- -- When we make a flag choice for a package, then new dependencies for that -- package might become available. If the package under consideration is in a @@ -351,31 +297,28 @@ linkNewDeps :: Var QPN -> Bool -> UpdateState () linkNewDeps var b = do vs <- get - let (qpn@(Q pp pn), Just i) = varPI var - PInfo deps _ _ = vsIndex vs ! pn ! i - qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps + let qpn@(Q pp pn) = varPN var + qdeps = vsSaved vs ! qpn lg = vsLinks vs ! qpn - (parents, newDeps) = findNewDeps vs qdeps + newDeps = findNewDeps vs qdeps linkedTo = S.delete pp (lgMembers lg) - forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) (P qpn : parents) newDeps + forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps where - findNewDeps :: ValidateState -> FlaggedDeps comp QPN -> ([Var QPN], FlaggedDeps Component QPN) - findNewDeps vs = concatMapUnzip (findNewDeps' vs) + findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN + findNewDeps vs = concatMap (findNewDeps' vs) - findNewDeps' :: ValidateState -> FlaggedDep comp QPN -> ([Var QPN], FlaggedDeps Component QPN) - findNewDeps' _ (Simple _ _) = ([], []) + findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN + findNewDeps' _ (Simple _ _) = [] findNewDeps' vs (Flagged qfn _ t f) = case (F qfn == var, M.lookup qfn (vsFlags vs)) of - (True, _) -> ([F qfn], if b then t else f) - (_, Nothing) -> ([], []) -- not yet known - (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else f) - in (F qfn:parents, deps) + (True, _) -> if b then t else f + (_, Nothing) -> [] -- not yet known + (_, Just b') -> findNewDeps vs (if b' then t else f) findNewDeps' vs (Stanza qsn t) = case (S qsn == var, M.lookup qsn (vsStanzas vs)) of - (True, _) -> ([S qsn], if b then t else []) - (_, Nothing) -> ([], []) -- not yet known - (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else []) - in (S qsn:parents, deps) + (True, _) -> if b then t else [] + (_, Nothing) -> [] -- not yet known + (_, Just b') -> findNewDeps vs (if b' then t else []) updateLinkGroup :: LinkGroup -> UpdateState () updateLinkGroup lg = do @@ -403,27 +346,27 @@ -- if a constructor is added to the datatype we won't notice it here Just i -> do vs <- get - let PInfo _deps finfo _ = vsIndex vs ! lgPackage lg ! i + let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i flags = M.keys finfo stanzas = [TestStanzas, BenchStanzas] forM_ flags $ \fn -> do - let flag = FN (PI (lgPackage lg) i) fn + let flag = FN (lgPackage lg) fn verifyFlag' flag lg forM_ stanzas $ \sn -> do - let stanza = SN (PI (lgPackage lg) i) sn + let stanza = SN (lgPackage lg) sn verifyStanza' stanza lg verifyFlag :: QFN -> UpdateState () -verifyFlag (FN (PI qpn@(Q _pp pn) i) fn) = do +verifyFlag (FN qpn@(Q _pp pn) fn) = do vs <- get -- We can only pick a flag after picking an instance; link group must exist - verifyFlag' (FN (PI pn i) fn) (vsLinks vs ! qpn) + verifyFlag' (FN pn fn) (vsLinks vs ! qpn) verifyStanza :: QSN -> UpdateState () -verifyStanza (SN (PI qpn@(Q _pp pn) i) sn) = do +verifyStanza (SN qpn@(Q _pp pn) sn) = do vs <- get -- We can only pick a stanza after picking an instance; link group must exist - verifyStanza' (SN (PI pn i) sn) (vsLinks vs ! qpn) + verifyStanza' (SN pn sn) (vsLinks vs ! qpn) -- | Verify that all packages in the link group agree on flag assignments -- @@ -431,14 +374,14 @@ -- that have already been made for link group members, and check that they are -- equal. verifyFlag' :: FN PN -> LinkGroup -> UpdateState () -verifyFlag' (FN (PI pn i) fn) lg = do +verifyFlag' (FN pn fn) lg = do vs <- get - let flags = map (\pp' -> FN (PI (Q pp' pn) i) fn) (S.toList (lgMembers lg)) + let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg)) vals = map (`M.lookup` vsFlags vs) flags if allEqual (catMaybes vals) -- We ignore not-yet assigned flags then return () else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg - , "flag " ++ show fn ++ " incompatible" + , "flag \"" ++ unFlagName fn ++ "\" incompatible" ) -- | Verify that all packages in the link group agree on stanza assignments @@ -449,14 +392,14 @@ -- -- This function closely mirrors 'verifyFlag''. verifyStanza' :: SN PN -> LinkGroup -> UpdateState () -verifyStanza' (SN (PI pn i) sn) lg = do +verifyStanza' (SN pn sn) lg = do vs <- get - let stanzas = map (\pp' -> SN (PI (Q pp' pn) i) sn) (S.toList (lgMembers lg)) + let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg)) vals = map (`M.lookup` vsStanzas vs) stanzas if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas then return () else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg - , "stanza " ++ show sn ++ " incompatible" + , "stanza \"" ++ showStanza sn ++ "\" incompatible" ) {------------------------------------------------------------------------------- @@ -488,7 +431,7 @@ -- | The set of variables that should be added to the conflict set if -- something goes wrong with this link set (in addition to the members -- of the link group itself) - , lgBlame :: ConflictSet QPN + , lgBlame :: ConflictSet } deriving (Show, Eq) @@ -533,14 +476,14 @@ , lgBlame = CS.empty } -lgMerge :: [Var QPN] -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup +lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup lgMerge blame lg lg' = do canon <- pick (lgCanon lg) (lgCanon lg') return LinkGroup { lgPackage = lgPackage lg , lgCanon = canon , lgMembers = lgMembers lg `S.union` lgMembers lg' - , lgBlame = CS.unions [CS.fromList blame, lgBlame lg, lgBlame lg'] + , lgBlame = CS.unions [blame, lgBlame lg, lgBlame lg'] } where pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a) @@ -550,7 +493,7 @@ pick (Just x) (Just y) = if x == y then Right $ Just x else Left ( CS.unions [ - CS.fromList blame + blame , lgConflictSet lg , lgConflictSet lg' ] @@ -558,7 +501,7 @@ ++ " and " ++ showLinkGroup lg' ) -lgConflictSet :: LinkGroup -> ConflictSet QPN +lgConflictSet :: LinkGroup -> ConflictSet lgConflictSet lg = CS.fromList (map aux (S.toList (lgMembers lg))) `CS.union` lgBlame lg @@ -573,6 +516,3 @@ allEqual [] = True allEqual [_] = True allEqual (x:y:ys) = x == y && allEqual (y:ys) - -concatMapUnzip :: (a -> ([b], [c])) -> [a] -> ([b], [c]) -concatMapUnzip f = (\(xs, ys) -> (concat xs, concat ys)) . unzip . map f diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Log.hs b/cabal/cabal-install/Distribution/Solver/Modular/Log.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Log.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Log.hs @@ -3,65 +3,55 @@ , logToProgress ) where -import Control.Applicative +import Prelude () +import Distribution.Solver.Compat.Prelude + import Data.List as L -import Data.Maybe (isNothing) -import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Progress import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Message import Distribution.Solver.Modular.Tree (FailReason(..)) import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Verbosity -- | The 'Log' datatype. -- -- Represents the progress of a computation lazily. -- -- Parameterized over the type of actual messages and the final result. -type Log m a = Progress m () a +type Log m a = Progress m (ConflictSet, ConflictMap) a messages :: Progress step fail done -> [step] messages = foldProgress (:) (const []) (const []) +data Exhaustiveness = Exhaustive | BackjumpLimitReached + -- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps. -- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the -- limit is 'Just 0', backtracking is completely disabled. -logToProgress :: Maybe Int -> Log Message a -> Progress String String a -logToProgress mbj l = let - es = proc (Just 0) l -- catch first error (always) - ms = useFirstError (proc mbj l) - in go es es -- trace for first error - (showMessages (const True) True ms) -- run with backjump limit applied +logToProgress :: Verbosity -> Maybe Int -> Log Message a -> Progress String String a +logToProgress verbosity mbj l = + let es = proc (Just 0) l -- catch first error (always) + ms = proc mbj l + in go es es -- trace for first error + (showMessages (const True) True ms) -- run with backjump limit applied where -- Proc takes the allowed number of backjumps and a 'Progress' and explores the -- messages until the maximum number of backjumps has been reached. It filters out -- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates -- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the - -- original success result or replaces the original failure with 'Nothing'. - proc :: Maybe Int -> Progress Message a b -> Progress Message (Maybe (ConflictSet QPN)) b + -- original result. + proc :: Maybe Int -> Log Message b -> Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b proc _ (Done x) = Done x - proc _ (Fail _) = Fail Nothing + proc _ (Fail (cs, cm)) = Fail (Exhaustive, cs, cm) proc mbj' (Step x@(Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _))) | cs == cs' = Step x (proc mbj' xs) -- repeated backjumps count as one - proc (Just 0) (Step (Failure cs Backjump) _) = Fail (Just cs) + proc (Just 0) (Step (Failure cs Backjump) _) = Fail (BackjumpLimitReached, cs, mempty) -- No final conflict map available proc (Just n) (Step x@(Failure _ Backjump) xs) = Step x (proc (Just (n - 1)) xs) proc mbj' (Step x xs) = Step x (proc mbj' xs) - -- Sets the conflict set from the first backjump as the final error, and records - -- whether the search was exhaustive. - useFirstError :: Progress Message (Maybe (ConflictSet QPN)) b - -> Progress Message (Bool, Maybe (ConflictSet QPN)) b - useFirstError = replace Nothing - where - replace _ (Done x) = Done x - replace cs' (Fail cs) = -- 'Nothing' means backjump limit not reached. - -- Prefer first error over later error. - Fail (isNothing cs, cs' <|> cs) - replace Nothing (Step x@(Failure cs Backjump) xs) = Step x $ replace (Just cs) xs - replace cs' (Step x xs) = Step x $ replace cs' xs - -- The first two arguments are both supposed to be the log up to the first error. -- That's the error that will always be printed in case we do not find a solution. -- We pass this log twice, because we evaluate it in parallel with the full log, @@ -69,20 +59,34 @@ -- This trick prevents a space leak! -- -- The third argument is the full log, ending with either the solution or the - -- exhaustiveness and first conflict set. - go :: Progress Message a b - -> Progress Message a b - -> Progress String (Bool, Maybe (ConflictSet QPN)) b + -- exhaustiveness and final conflict set. + go :: Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b + -> Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b + -> Progress String (Exhaustiveness, ConflictSet, ConflictMap) b -> Progress String String b - go ms (Step _ ns) (Step x xs) = Step x (go ms ns xs) - go ms r (Step x xs) = Step x (go ms r xs) - go ms _ (Fail (exh, Just cs)) = Fail $ - "Could not resolve dependencies:\n" ++ - unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs) True) False ms) ++ - (if exh then "Dependency tree exhaustively searched.\n" - else "Backjump limit reached (" ++ currlimit mbj ++ - "change with --max-backjumps or try to run with --reorder-goals).\n") - where currlimit (Just n) = "currently " ++ show n ++ ", " - currlimit Nothing = "" - go _ _ (Done s) = Done s - go _ _ (Fail (_, Nothing)) = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen + go ms (Step _ ns) (Step x xs) = Step x (go ms ns xs) + go ms r (Step x xs) = Step x (go ms r xs) + go ms (Step _ ns) r = go ms ns r + go ms (Fail (_, cs', _)) (Fail (exh, cs, cm)) = Fail $ + "Could not resolve dependencies:\n" ++ + unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs') True) False ms) ++ + case exh of + Exhaustive -> + "After searching the rest of the dependency tree exhaustively, " + ++ "these were the goals I've had most trouble fulfilling: " + ++ showCS cm cs + where + showCS = if verbosity > normal + then CS.showCSWithFrequency + else CS.showCSSortedByFrequency + BackjumpLimitReached -> + "Backjump limit reached (" ++ currlimit mbj ++ + "change with --max-backjumps or try to run with --reorder-goals).\n" + where currlimit (Just n) = "currently " ++ show n ++ ", " + currlimit Nothing = "" + go _ _ (Done s) = Done s + go _ (Done _) (Fail _) = Fail $ + -- Should not happen: Second argument is the log up to first error, + -- third one is the entire log. Therefore it should never happen that + -- the second log finishes with 'Done' and the third log with 'Fail'. + "Could not resolve dependencies; something strange happened." diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Message.hs b/cabal/cabal-install/Distribution/Solver/Modular/Message.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Message.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Message.hs @@ -14,10 +14,12 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree - ( FailReason(..), POption(..) ) + ( FailReason(..), POption(..), ConflictingDep(..) ) +import Distribution.Solver.Modular.Version import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Progress +import Distribution.Types.UnqualComponentName data Message = Enter -- ^ increase indentation level @@ -27,7 +29,7 @@ | TryS QSN Bool | Next (Goal QPN) | Success - | Failure (ConflictSet QPN) FailReason + | Failure ConflictSet FailReason -- | Transforms the structured message type to actual messages (strings). -- @@ -58,29 +60,29 @@ go !v !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = goPReject v l qpn [i] c fr ms go !v !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms) + (atLevel (F qfn : v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms) go !v !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms) + (atLevel (S qsn : v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms) go !v !l (Step (Next (Goal (P qpn) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) = - (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go (add (P qpn) v) l ms) + (atLevel (P qpn : v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go (P qpn : v) l ms) go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Fail _)) = - (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms + (atLevel (P qpn : v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms -- the previous case potentially arises in the error output, because we remove the backjump itself -- if we cut the log after the first error go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Step (Failure _c Backjump) _)) = - (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms + (atLevel (P qpn : v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms go !v !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) = - let v' = add (P qpn) v + let v' = P qpn : v in (atLevel v' l $ showPackageGoal qpn gr) $ (atLevel v' l $ showFailure c fr) (go v l ms) go !v !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _))) | c == c' = go v l ms -- standard display go !v !l (Step Enter ms) = go v (l+1) ms go !v !l (Step Leave ms) = go (drop 1 v) (l-1) ms - go !v !l (Step (TryP qpn i) ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms) - go !v !l (Step (TryF qfn b) ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms) - go !v !l (Step (TryS qsn b) ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms) - go !v !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms) + go !v !l (Step (TryP qpn i) ms) = (atLevel (P qpn : v) l $ "trying: " ++ showQPNPOpt qpn i) (go (P qpn : v) l ms) + go !v !l (Step (TryF qfn b) ms) = (atLevel (F qfn : v) l $ "trying: " ++ showQFNBool qfn b) (go (F qfn : v) l ms) + go !v !l (Step (TryS qsn b) ms) = (atLevel (S qsn : v) l $ "trying: " ++ showQSNBool qsn b) (go (S qsn : v) l ms) + go !v !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel (P qpn : v) l $ showPackageGoal qpn gr) (go v l ms) go !v !l (Step (Next _) ms) = go v l ms -- ignore flag goals in the log go !v !l (Step (Success) ms) = (atLevel v l $ "done") (go v l ms) go !v !l (Step (Failure c fr) ms) = (atLevel v l $ showFailure c fr) (go v l ms) @@ -88,18 +90,15 @@ showPackageGoal :: QPN -> QGoalReason -> String showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr - showFailure :: ConflictSet QPN -> FailReason -> String + showFailure :: ConflictSet -> FailReason -> String showFailure c fr = "fail" ++ showFR c fr - add :: Var QPN -> [Var QPN] -> [Var QPN] - add v vs = simplifyVar v : vs - -- special handler for many subsequent package rejections goPReject :: [Var QPN] -> Int -> QPN -> [POption] - -> ConflictSet QPN + -> ConflictSet -> FailReason -> Progress Message a b -> Progress String a b @@ -124,13 +123,16 @@ showGR :: QGoalReason -> String showGR UserGoal = " (user goal)" -showGR (PDependency pi) = " (dependency of " ++ showPI pi ++ ")" -showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b ++ ")" -showGR (SDependency qsn) = " (dependency of " ++ showQSNBool qsn True ++ ")" +showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")" -showFR :: ConflictSet QPN -> FailReason -> String -showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)" -showFR _ (Conflicting ds) = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")" +showFR :: ConflictSet -> FailReason -> String +showFR _ (UnsupportedExtension ext) = " (conflict: requires " ++ display ext ++ ")" +showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ display lang ++ ")" +showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ display pn ++ display vr ++ ", not found in the pkg-config database)" +showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")" +showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")" +showFR _ (NewPackageIsMissingRequiredExe exe dr) = " (does not contain executable " ++ unUnqualComponentName exe ++ ", which is required by " ++ showDependencyReason dr ++ ")" +showFR _ (PackageRequiresMissingExe qpn exe) = " (requires executable " ++ unUnqualComponentName exe ++ " from " ++ showQPN qpn ++ ", but the executable does not exist)" showFR _ CannotInstall = " (only already installed instances can be used)" showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" showFR _ Shadowed = " (shadowed by another installed package with same version)" @@ -140,10 +142,11 @@ showFR _ (GlobalConstraintSource src) = " (" ++ constraintSource src ++ " requires source instance)" showFR _ (GlobalConstraintFlag src) = " (" ++ constraintSource src ++ " requires opposite flag selection)" showFR _ ManualFlag = " (manual flag can only be changed explicitly)" -showFR c Backjump = " (backjumping, conflict set: " ++ showCS c ++ ")" +showFR c Backjump = " (backjumping, conflict set: " ++ showConflictSet c ++ ")" showFR _ MultipleInstances = " (multiple instances)" -showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showCS c ++ ")" -showFR c CyclicDependencies = " (cyclic dependencies; conflict set: " ++ showCS c ++ ")" +showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")" +showFR c CyclicDependencies = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")" +showFR _ (UnsupportedSpecVer ver) = " (unsupported spec-version " ++ display ver ++ ")" -- The following are internal failures. They should not occur. In the -- interest of not crashing unnecessarily, we still just print an error -- message though. @@ -153,3 +156,15 @@ constraintSource :: ConstraintSource -> String constraintSource src = "constraint from " ++ showConstraintSource src + +showConflictingDep :: ConflictingDep -> String +showConflictingDep (ConflictingDep dr mExe qpn ci) = + let DependencyReason qpn' _ _ = dr + exeStr = case mExe of + Just exe -> " (exe " ++ unUnqualComponentName exe ++ ")" + Nothing -> "" + in case ci of + Fixed i -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++ + showQPN qpn ++ exeStr ++ "==" ++ showI i + Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++ + exeStr ++ showVR vr diff --git a/cabal/cabal-install/Distribution/Solver/Modular/PSQ.hs b/cabal/cabal-install/Distribution/Solver/Modular/PSQ.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/PSQ.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/PSQ.hs @@ -3,12 +3,11 @@ ( PSQ(..) -- Unit test needs constructor access , casePSQ , cons - , degree - , delete - , dminimumBy , length , lookup , filter + , filterIfAny + , filterIfAnyByKeys , filterKeys , firstOnly , fromList @@ -17,17 +16,14 @@ , map , mapKeys , mapWithKey - , mapWithKeyState , maximumBy , minimumBy , null , prefer , preferByKeys - , preferOrElse , snoc , sortBy , sortByKeys - , splits , toList , union ) where @@ -39,8 +35,6 @@ -- (inefficiently implemented) lookup, because I think that queue-based -- operations and sorting turn out to be more efficiency-critical in practice. -import Distribution.Solver.Modular.Degree - import Control.Arrow (first, second) import qualified Data.Foldable as F @@ -68,15 +62,6 @@ mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs) -mapWithKeyState :: (s -> k -> a -> (b, s)) -> PSQ k a -> s -> PSQ k b -mapWithKeyState p (PSQ xs) s0 = - PSQ (F.foldr (\ (k, v) r s -> case p s k v of - (w, n) -> (k, w) : (r n)) - (const []) xs s0) - -delete :: Eq k => k -> PSQ k a -> PSQ k a -delete k (PSQ xs) = PSQ (snd (S.partition ((== k) . fst) xs)) - fromList :: [(k, a)] -> PSQ k a fromList = PSQ @@ -92,40 +77,12 @@ [] -> n (k, v) : ys -> c k v (PSQ ys) -splits :: PSQ k a -> PSQ k (a, PSQ k a) -splits = go id - where - go f xs = casePSQ xs - (PSQ []) - (\ k v ys -> cons k (v, f ys) (go (f . cons k v) ys)) - sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs) sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs) --- | Given a measure in form of a pseudo-peano-natural number, --- determine the approximate minimum. This is designed to stop --- even traversing the list as soon as we find any element with --- measure 'ZeroOrOne'. --- --- Always returns a one-element queue (except if the queue is --- empty, then we return an empty queue again). --- -dminimumBy :: (a -> Degree) -> PSQ k a -> PSQ k a -dminimumBy _ (PSQ []) = PSQ [] -dminimumBy sel (PSQ (x : xs)) = go (sel (snd x)) x xs - where - go ZeroOrOne v _ = PSQ [v] - go _ v [] = PSQ [v] - go c v (y : ys) = case compare c d of - LT -> go c v ys - EQ -> go c v ys - GT -> go d y ys - where - d = sel (snd y) - maximumBy :: (k -> Int) -> PSQ k a -> (k, a) maximumBy sel (PSQ xs) = S.minimumBy (flip (comparing (sel . fst))) xs @@ -134,32 +91,31 @@ minimumBy sel (PSQ xs) = PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))] +-- | Sort the list so that values satisfying the predicate are first. +prefer :: (a -> Bool) -> PSQ k a -> PSQ k a +prefer p = sortBy $ flip (comparing p) + +-- | Sort the list so that keys satisfying the predicate are first. +preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a +preferByKeys p = sortByKeys $ flip (comparing p) + -- | Will partition the list according to the predicate. If -- there is any element that satisfies the precidate, then only -- the elements satisfying the predicate are returned. -- Otherwise, the rest is returned. -- -prefer :: (a -> Bool) -> PSQ k a -> PSQ k a -prefer p (PSQ xs) = +filterIfAny :: (a -> Bool) -> PSQ k a -> PSQ k a +filterIfAny p (PSQ xs) = let (pro, con) = S.partition (p . snd) xs in if S.null pro then PSQ con else PSQ pro --- | Variant of 'prefer' that takes a continuation for the case --- that there are none of the desired elements. -preferOrElse :: (a -> Bool) -> (PSQ k a -> PSQ k a) -> PSQ k a -> PSQ k a -preferOrElse p k (PSQ xs) = - let - (pro, con) = S.partition (p . snd) xs - in - if S.null pro then k (PSQ con) else PSQ pro - --- | Variant of 'prefer' that takes a predicate on the keys +-- | Variant of 'filterIfAny' that takes a predicate on the keys -- rather than on the values. -- -preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a -preferByKeys p (PSQ xs) = +filterIfAnyByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a +filterIfAnyByKeys p (PSQ xs) = let (pro, con) = S.partition (p . fst) xs in @@ -173,12 +129,6 @@ length :: PSQ k a -> Int length (PSQ xs) = S.length xs - -degree :: PSQ k a -> Degree -degree (PSQ []) = ZeroOrOne -degree (PSQ [_]) = ZeroOrOne -degree (PSQ [_, _]) = Two -degree (PSQ _) = Other null :: PSQ k a -> Bool null (PSQ xs) = S.null xs diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Package.hs b/cabal/cabal-install/Distribution/Solver/Modular/Package.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Package.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Package.hs @@ -12,6 +12,7 @@ , instI , makeIndependent , primaryPP + , setupPP , showI , showPI , unPN @@ -87,14 +88,20 @@ primaryPP :: PackagePath -> Bool primaryPP (PackagePath _ns q) = go q where - go Unqualified = True - go (Base _) = True - go (Setup _) = False - go (Exe _ _) = False + go QualToplevel = True + go (QualBase _) = True + go (QualSetup _) = False + go (QualExe _ _) = False --- | Create artificial parents for each of the package names, making --- them all independent. -makeIndependent :: [PN] -> [QPN] -makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..] - , let pp = PackagePath (Independent i) Unqualified - ] +-- | Is the package a dependency of a setup script. This is used to +-- establish whether or not certain constraints should apply to this +-- dependency (grep 'setupPP' to see the use sites). +-- +setupPP :: PackagePath -> Bool +setupPP (PackagePath _ns (QualSetup _)) = True +setupPP (PackagePath _ns _) = False + +-- | Qualify a target package with its own name so that its dependencies are not +-- required to be consistent with other targets. +makeIndependent :: PN -> QPN +makeIndependent pn = Q (PackagePath (Independent pn) QualToplevel) pn diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Preference.hs b/cabal/cabal-install/Distribution/Solver/Modular/Preference.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Preference.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Preference.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} -- | Reordering or pruning the tree in order to prefer or make certain choices. module Distribution.Solver.Modular.Preference ( avoidReinstalls @@ -8,7 +9,6 @@ , enforceSingleInstanceRestriction , firstGoal , preferBaseGoalChoice - , preferEasyGoalChoices , preferLinked , preferPackagePreferences , preferReallyEasyGoalChoices @@ -17,7 +17,7 @@ ) where import Prelude () -import Distribution.Client.Compat.Prelude +import Distribution.Solver.Compat.Prelude import Data.Function (on) import qualified Data.List as L @@ -25,7 +25,9 @@ import Control.Monad.Reader hiding (sequence) import Data.Traversable (sequence) -import Distribution.Solver.Types.ConstraintSource +import Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal + +import Distribution.Solver.Types.Flag import Distribution.Solver.Types.InstalledPreference import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza @@ -53,13 +55,13 @@ addWeights fs = trav go where go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c) - go (PChoiceF qpn@(Q _ pn) x cs) = + go (PChoiceF qpn@(Q _ pn) rdm x cs) = let sortedVersions = L.sortBy (flip compare) $ L.map version (W.keys cs) weights k = [f pn sortedVersions k | f <- fs] elemsToWhnf :: [a] -> () elemsToWhnf = foldr seq () - in PChoiceF qpn x + in PChoiceF qpn rdm x -- Evaluate the children's versions before evaluating any of the -- subtrees, so that 'sortedVersions' doesn't hold onto all of the -- subtrees (referenced by cs) and cause a space leak. @@ -128,13 +130,13 @@ preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c preferPackageStanzaPreferences pcs = trav go where - go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) gr _tr ts) + go (SChoiceF qsn@(SN (Q pp pn) s) rdm gr _tr ts) | primaryPP pp && enableStanzaPref pn s = -- move True case first to try enabling the stanza let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts weight k = if k then 0 else 1 -- defer the choice by setting it to weak - in SChoiceF qsn gr (WeakOrTrivial True) ts' + in SChoiceF qsn rdm gr (WeakOrTrivial True) ts' go x = x enableStanzaPref :: PN -> OptionalStanza -> Bool @@ -146,44 +148,48 @@ -- given instance for a P-node. Translates the constraint into a -- tree-transformer that either leaves the subtree untouched, or replaces it -- with an appropriate failure node. -processPackageConstraintP :: PackagePath - -> ConflictSet QPN +processPackageConstraintP :: forall d c. QPN + -> ConflictSet -> I -> LabeledPackageConstraint -> Tree d c -> Tree d c -processPackageConstraintP pp _ _ (LabeledPackageConstraint _ src) r - | src == ConstraintSourceUserTarget && not (primaryPP pp) = r - -- the constraints arising from targets, like "foo-1.0" only apply to - -- the main packages in the solution, they don't constrain setup deps - -processPackageConstraintP _ c i (LabeledPackageConstraint pc src) r = go i pc +processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint scope prop) src) r = + if constraintScopeMatches scope qpn + then go i prop + else r where - go (I v _) (PackageConstraintVersion _ vr) + go :: I -> PackageProperty -> Tree d c + go (I v _) (PackagePropertyVersion vr) | checkVR vr v = r | otherwise = Fail c (GlobalConstraintVersion vr src) - go _ (PackageConstraintInstalled _) + go _ PackagePropertyInstalled | instI i = r | otherwise = Fail c (GlobalConstraintInstalled src) - go _ (PackageConstraintSource _) + go _ PackagePropertySource | not (instI i) = r | otherwise = Fail c (GlobalConstraintSource src) - go _ _ = r + go _ _ = r -- | Helper function that tries to enforce a single package constraint on a -- given flag setting for an F-node. Translates the constraint into a -- tree-transformer that either leaves the subtree untouched, or replaces it -- with an appropriate failure node. -processPackageConstraintF :: Flag - -> ConflictSet QPN +processPackageConstraintF :: forall d c. QPN + -> Flag + -> ConflictSet -> Bool -> LabeledPackageConstraint -> Tree d c -> Tree d c -processPackageConstraintF f c b' (LabeledPackageConstraint pc src) r = go pc +processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = + if constraintScopeMatches scope qpn + then go prop + else r where - go (PackageConstraintFlags _ fa) = - case L.lookup f fa of + go :: PackageProperty -> Tree d c + go (PackagePropertyFlags fa) = + case lookupFlagAssignment f fa of Nothing -> r Just b | b == b' -> r | otherwise -> Fail c (GlobalConstraintFlag src) @@ -193,15 +199,20 @@ -- given flag setting for an F-node. Translates the constraint into a -- tree-transformer that either leaves the subtree untouched, or replaces it -- with an appropriate failure node. -processPackageConstraintS :: OptionalStanza - -> ConflictSet QPN +processPackageConstraintS :: forall d c. QPN + -> OptionalStanza + -> ConflictSet -> Bool -> LabeledPackageConstraint -> Tree d c -> Tree d c -processPackageConstraintS s c b' (LabeledPackageConstraint pc src) r = go pc +processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = + if constraintScopeMatches scope qpn + then go prop + else r where - go (PackageConstraintStanzas _ ss) = + go :: PackageProperty -> Tree d c + go (PackagePropertyStanzas ss) = if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src) else r go _ = r @@ -214,51 +225,82 @@ -> Tree d c enforcePackageConstraints pcs = trav go where - go (PChoiceF qpn@(Q pp pn) gr ts) = + go (PChoiceF qpn@(Q _ pn) rdm gr ts) = let c = varToConflictSet (P qpn) -- compose the transformation functions for each of the relevant constraint - g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP pp c i pc) id - (M.findWithDefault [] pn pcs) - in PChoiceF qpn gr (W.mapWithKey g ts) - go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) = + g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP qpn c i pc) + id + (M.findWithDefault [] pn pcs) + in PChoiceF qpn rdm gr (W.mapWithKey g ts) + go (FChoiceF qfn@(FN qpn@(Q _ pn) f) rdm gr tr m d ts) = let c = varToConflictSet (F qfn) -- compose the transformation functions for each of the relevant constraint - g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id + g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc) + id (M.findWithDefault [] pn pcs) - in FChoiceF qfn gr tr m (W.mapWithKey g ts) - go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) = + in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts) + go (SChoiceF qsn@(SN qpn@(Q _ pn) f) rdm gr tr ts) = let c = varToConflictSet (S qsn) -- compose the transformation functions for each of the relevant constraint - g = \ b -> foldl (\ h pc -> h . processPackageConstraintS f c b pc) id + g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc) + id (M.findWithDefault [] pn pcs) - in SChoiceF qsn gr tr (W.mapWithKey g ts) + in SChoiceF qsn rdm gr tr (W.mapWithKey g ts) go x = x --- | Transformation that tries to enforce manual flags. Manual flags --- can only be re-set explicitly by the user. This transformation should --- be run after user preferences have been enforced. For manual flags, --- it checks if a user choice has been made. If not, it disables all but --- the first choice. -enforceManualFlags :: Tree d c -> Tree d c -enforceManualFlags = trav go +-- | Transformation that tries to enforce the rule that manual flags can only be +-- set by the user. +-- +-- If there are no constraints on a manual flag, this function prunes all but +-- the default value. If there are constraints, then the flag is allowed to have +-- the values specified by the constraints. Note that the type used for flag +-- values doesn't need to be Bool. +-- +-- This function makes an exception for the case where there are multiple goals +-- for a single package (with different qualifiers), and flag constraints for +-- manual flag x only apply to some of those goals. In that case, we allow the +-- unconstrained goals to use the default value for x OR any of the values in +-- the constraints on x (even though the constraints don't apply), in order to +-- allow the unconstrained goals to be linked to the constrained goals. See +-- https://github.com/haskell/cabal/issues/4299. Removing the single instance +-- restriction (SIR) would also fix #4299, so we may want to remove this +-- exception and only let the user toggle manual flags if we remove the SIR. +-- +-- This function does not enforce any of the constraints, since that is done by +-- 'enforcePackageConstraints'. +enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> Tree d c -> Tree d c +enforceManualFlags pcs = trav go where - go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $ - let c = varToConflictSet (F qfn) - in case span isDisabled (W.toList ts) of - ([], y : ys) -> W.fromList (y : L.map (\ (w, b, _) -> (w, b, Fail c ManualFlag)) ys) - _ -> ts -- something has been manually selected, leave things alone - where - isDisabled (_, _, Fail _ (GlobalConstraintFlag _)) = True - isDisabled _ = False - go x = x + go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) = + FChoiceF qfn rdm gr tr Manual d $ + let -- A list of all values specified by constraints on 'fn'. + -- We ignore the constraint scope in order to handle issue #4299. + flagConstraintValues :: [Bool] + flagConstraintValues = + [ flagVal + | let lpcs = M.findWithDefault [] pn pcs + , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs + , (fn', flagVal) <- unFlagAssignment fa + , fn' == fn ] + -- Prune flag values that are not the default and do not match any + -- of the constraints. + restrictToggling :: Eq a => a -> [a] -> a -> Tree d c -> Tree d c + restrictToggling flagDefault constraintVals flagVal r = + if flagVal `elem` constraintVals || flagVal == flagDefault + then r + else Fail (varToConflictSet (F qfn)) ManualFlag + + in W.mapWithKey (restrictToggling d flagConstraintValues) ts + go x = x + -- | Require installed packages. requireInstalled :: (PN -> Bool) -> Tree d c -> Tree d c requireInstalled p = trav go where - go (PChoiceF v@(Q _ pn) gr cs) - | p pn = PChoiceF v gr (W.mapWithKey installed cs) - | otherwise = PChoiceF v gr cs + go (PChoiceF v@(Q _ pn) rdm gr cs) + | p pn = PChoiceF v rdm gr (W.mapWithKey installed cs) + | otherwise = PChoiceF v rdm gr cs where installed (POption (I _ (Inst _)) _) x = x installed _ _ = Fail (varToConflictSet (P v)) CannotInstall @@ -280,9 +322,9 @@ avoidReinstalls :: (PN -> Bool) -> Tree d c -> Tree d c avoidReinstalls p = trav go where - go (PChoiceF qpn@(Q _ pn) gr cs) - | p pn = PChoiceF qpn gr disableReinstalls - | otherwise = PChoiceF qpn gr cs + go (PChoiceF qpn@(Q _ pn) rdm gr cs) + | p pn = PChoiceF qpn rdm gr disableReinstalls + | otherwise = PChoiceF qpn rdm gr cs where disableReinstalls = let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ] @@ -298,16 +340,16 @@ sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree d c -> Tree d c sortGoals variableOrder = trav go where - go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys goalOrder xs) - go x = x + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.sortByKeys goalOrder xs) + go x = x goalOrder :: Goal QPN -> Goal QPN -> Ordering goalOrder = variableOrder `on` (varToVariable . goalToVar) varToVariable :: Var QPN -> Variable QPN varToVariable (P qpn) = PackageVar qpn - varToVariable (F (FN (PI qpn _) fn)) = FlagVar qpn fn - varToVariable (S (SN (PI qpn _) stanza)) = StanzaVar qpn stanza + varToVariable (F (FN qpn fn)) = FlagVar qpn fn + varToVariable (S (SN qpn stanza)) = StanzaVar qpn stanza -- | Always choose the first goal in the list next, abandoning all -- other choices. @@ -318,18 +360,19 @@ firstGoal :: Tree d c -> Tree d c firstGoal = trav go where - go (GoalChoiceF xs) = GoalChoiceF (P.firstOnly xs) - go x = x + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.firstOnly xs) + go x = x -- Note that we keep empty choice nodes, because they mean success. -- | Transformation that tries to make a decision on base as early as --- possible. In nearly all cases, there's a single choice for the base --- package. Also, fixing base early should lead to better error messages. +-- possible by pruning all other goals when base is available. In nearly +-- all cases, there's a single choice for the base package. Also, fixing +-- base early should lead to better error messages. preferBaseGoalChoice :: Tree d c -> Tree d c preferBaseGoalChoice = trav go where - go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys isBase xs) - go x = x + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAnyByKeys isBase xs) + go x = x isBase :: Goal QPN -> Bool isBase (Goal (P (Q _pp pn)) _) = unPN pn == "base" @@ -340,12 +383,12 @@ deferSetupChoices :: Tree d c -> Tree d c deferSetupChoices = trav go where - go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys noSetup xs) - go x = x + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.preferByKeys noSetup xs) + go x = x noSetup :: Goal QPN -> Bool - noSetup (Goal (P (Q (PackagePath _ns (Setup _)) _)) _) = False - noSetup _ = True + noSetup (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False + noSetup _ = True -- | Transformation that tries to avoid making weak flag choices early. -- Weak flags are trivial flags (not influencing dependencies) or such @@ -353,53 +396,28 @@ deferWeakFlagChoices :: Tree d c -> Tree d c deferWeakFlagChoices = trav go where - go (GoalChoiceF xs) = GoalChoiceF (P.prefer noWeakStanza (P.prefer noWeakFlag xs)) - go x = x + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.prefer noWeakFlag (P.prefer noWeakStanza xs)) + go x = x noWeakStanza :: Tree d c -> Bool - noWeakStanza (SChoice _ _ (WeakOrTrivial True) _) = False - noWeakStanza _ = True + noWeakStanza (SChoice _ _ _ (WeakOrTrivial True) _) = False + noWeakStanza _ = True noWeakFlag :: Tree d c -> Bool - noWeakFlag (FChoice _ _ (WeakOrTrivial True) _ _) = False - noWeakFlag _ = True - --- | Transformation that sorts choice nodes so that --- child nodes with a small branching degree are preferred. --- --- Only approximates the number of choices in the branches --- using dchoices which classifies every goal by the number --- of active choices: --- --- - 0 (guaranteed failure) or 1 (no other option) active choice --- - 2 active choices --- - 3 or more active choices --- --- We pick the minimum goal according to this approximation. --- In particular, if we encounter any goal in the first class --- (0 or 1 option), we do not look any further and choose it --- immediately. --- --- Returns at most one choice. --- -preferEasyGoalChoices :: Tree d c -> Tree d c -preferEasyGoalChoices = trav go - where - go (GoalChoiceF xs) = GoalChoiceF (P.dminimumBy dchoices xs) - -- (a different implementation that seems slower): - -- GoalChoiceF (P.firstOnly (P.preferOrElse zeroOrOneChoices (P.minimumBy choices) xs)) - go x = x + noWeakFlag (FChoice _ _ _ (WeakOrTrivial True) _ _ _) = False + noWeakFlag _ = True --- | A variant of 'preferEasyGoalChoices' that just keeps the --- ones with a branching degree of 0 or 1. Note that unlike --- 'preferEasyGoalChoices', this may return more than one --- choice. +-- | Transformation that prefers goals with lower branching degrees. -- +-- When a goal choice node has at least one goal with zero or one children, this +-- function prunes all other goals. This transformation can help the solver find +-- a solution in fewer steps by allowing it to backtrack sooner when it is +-- exploring a subtree with no solutions. However, each step is more expensive. preferReallyEasyGoalChoices :: Tree d c -> Tree d c preferReallyEasyGoalChoices = trav go where - go (GoalChoiceF xs) = GoalChoiceF (P.prefer zeroOrOneChoices xs) - go x = x + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAny zeroOrOneChoices xs) + go x = x -- | Monad used internally in enforceSingleInstanceRestriction -- @@ -419,8 +437,8 @@ go :: TreeF d c (EnforceSIR (Tree d c)) -> EnforceSIR (Tree d c) -- We just verify package choices. - go (PChoiceF qpn gr cs) = - PChoice qpn gr <$> sequence (W.mapWithKey (goP qpn) cs) + go (PChoiceF qpn rdm gr cs) = + PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) cs) go _otherwise = innM _otherwise diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Solver.hs b/cabal/cabal-install/Distribution/Solver/Modular/Solver.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Solver.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Solver.hs @@ -11,7 +11,7 @@ import Data.Map as M import Data.List as L import Data.Set as S -import Distribution.Version +import Distribution.Verbosity import Distribution.Compiler (CompilerInfo) @@ -41,7 +41,6 @@ import Distribution.Simple.Setup (BooleanFlag(..)) #ifdef DEBUG_TRACETREE -import Distribution.Solver.Modular.Flag import qualified Distribution.Solver.Modular.ConflictSet as CS import qualified Distribution.Solver.Modular.WeightedPSQ as W import qualified Distribution.Text as T @@ -60,10 +59,12 @@ avoidReinstalls :: AvoidReinstalls, shadowPkgs :: ShadowPkgs, strongFlags :: StrongFlags, + allowBootLibInstalls :: AllowBootLibInstalls, maxBackjumps :: Maybe Int, enableBackjumping :: EnableBackjumping, solveExecutables :: SolveExecutables, - goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering) + goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), + solverVerbosity :: Verbosity } -- | Run all solver phases. @@ -75,22 +76,6 @@ -- has been added relatively recently. Cycles are only removed directly -- before exploration. -- --- Semantically, there is no difference. Cycle detection, as implemented --- now, only occurs for 'Done' nodes we encounter during exploration, --- and cycle detection itself does not change the shape of the tree, --- it only marks some 'Done' nodes as 'Fail', if they contain cyclic --- solutions. --- --- There is a tiny performance impact, however, in doing cycle detection --- directly after validation. Probably because cycle detection maintains --- some information, and the various reorderings implemented by --- 'preferencesPhase' and 'heuristicsPhase' are ever so slightly more --- costly if that information is already around during the reorderings. --- --- With the current positioning directly before the 'explorePhase', there --- seems to be no statistically significant performance impact of cycle --- detection in the common case where there are no cycles. --- solve :: SolverConfig -- ^ solver parameters -> CompilerInfo -> Index -- ^ all available packages as an index @@ -115,8 +100,8 @@ in case goalOrder sc of Nothing -> goalChoiceHeuristics . heuristicsTree . - P.deferWeakFlagChoices . P.deferSetupChoices . + P.deferWeakFlagChoices . P.preferBaseGoalChoice Just order -> P.firstGoal . heuristicsTree . @@ -124,35 +109,33 @@ preferencesPhase = P.preferLinked . P.preferPackagePreferences userPrefs validationPhase = traceTree "validated.json" id . - P.enforceManualFlags . -- can only be done after user constraints P.enforcePackageConstraints userConstraints . + P.enforceManualFlags userConstraints . P.enforceSingleInstanceRestriction . validateLinking idx . validateTree cinfo idx pkgConfigDB prunePhase = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) . - -- packages that can never be "upgraded": - P.requireInstalled (`elem` [ mkPackageName "base" - , mkPackageName "ghc-prim" - , mkPackageName "integer-gmp" - , mkPackageName "integer-simple" - ]) + (if asBool (allowBootLibInstalls sc) + then id + else P.requireInstalled (`elem` nonInstallable)) buildPhase = traceTree "build.json" id - $ addLinking $ buildTree idx (independentGoals sc) (S.toList userGoals) - -- Counting conflicts and reordering goals interferes, as both are strategies to - -- change the order of goals. - -- - -- We therefore change the strategy based on whether --count-conflicts is set or - -- not: - -- - -- - when --count-conflicts is set, we use preferReallyEasyGoalChoices, which - -- prefers (keeps) goals only if the have 0 or 1 enabled choice. - -- - -- - when --count-conflicts is not set, we use preferEasyGoalChoices, which - -- (next to preferring goals with 0 or 1 enabled choice) - -- also prefers goals that have 2 enabled choices over goals with more than - -- two enabled choices. + -- packages that can never be installed or upgraded + -- If you change this enumeration, make sure to update the list in + -- "Distribution.Client.Dependency" as well + nonInstallable :: [PackageName] + nonInstallable = + L.map mkPackageName + [ "base" + , "ghc-prim" + , "integer-gmp" + , "integer-simple" + , "template-haskell" + ] + + -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which + -- prefers (keeps) goals only if the have 0 or 1 enabled choice. -- -- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes -- to just a single option. This was a way to work around a space leak that was @@ -164,9 +147,8 @@ -- Otherwise, we simply choose the first remaining goal. -- goalChoiceHeuristics - | asBool (reorderGoals sc) && asBool (countConflicts sc) = P.preferReallyEasyGoalChoices - | asBool (reorderGoals sc) = P.preferEasyGoalChoices - | otherwise = id {- P.firstGoal -} + | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices + | otherwise = id {- P.firstGoal -} -- | Dump solver tree to a file (in debugging mode) -- @@ -186,31 +168,31 @@ #endif #ifdef DEBUG_TRACETREE -instance GSimpleTree (Tree d QGoalReason) where +instance GSimpleTree (Tree d c) where fromGeneric = go where - go :: Tree d QGoalReason -> SimpleTree - go (PChoice qpn _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq - go (FChoice _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq - go (SChoice _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq - go (GoalChoice psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq - go (Done _rdm _s) = Node "D" $ Assoc [] - go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)] + go :: Tree d c -> SimpleTree + go (PChoice qpn _ _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq + go (FChoice _ _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq + go (SChoice _ _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq + go (GoalChoice _ psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq + go (Done _rdm _s) = Node "D" $ Assoc [] + go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)] psqToList :: W.WeightedPSQ w k v -> [(k, v)] psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList -- Show package choice - goP :: QPN -> POption -> Tree d QGoalReason -> (String, SimpleTree) + goP :: QPN -> POption -> Tree d c -> (String, SimpleTree) goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree) goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree) -- Show flag or stanza choice - goFS :: Bool -> Tree d QGoalReason -> (String, SimpleTree) + goFS :: Bool -> Tree d c -> (String, SimpleTree) goFS val subtree = (show val, go subtree) -- Show goal choice - goG :: Goal QPN -> Tree d QGoalReason -> (String, SimpleTree) + goG :: Goal QPN -> Tree d c -> (String, SimpleTree) goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree) -- Variation on 'showGR' that produces shorter strings @@ -218,29 +200,27 @@ -- to know the variable that introduced the goal, not the value assigned -- to that variable) shortGR :: QGoalReason -> String - shortGR UserGoal = "user" - shortGR (PDependency (PI nm _)) = showQPN nm - shortGR (FDependency nm _) = showQFN nm - shortGR (SDependency nm) = showQSN nm + shortGR UserGoal = "user" + shortGR (DependencyGoal dr) = showDependencyReason dr -- Show conflict set - goCS :: ConflictSet QPN -> String + goCS :: ConflictSet -> String goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}" #endif -- | Replace all goal reasons with a dummy goal reason in the tree -- -- This is useful for debugging (when experimenting with the impact of GRs) -_removeGR :: Tree d QGoalReason -> Tree d QGoalReason +_removeGR :: Tree d c -> Tree d QGoalReason _removeGR = trav go where - go :: TreeF d QGoalReason (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason) - go (PChoiceF qpn _ psq) = PChoiceF qpn dummy psq - go (FChoiceF qfn _ a b psq) = FChoiceF qfn dummy a b psq - go (SChoiceF qsn _ a psq) = SChoiceF qsn dummy a psq - go (GoalChoiceF psq) = GoalChoiceF (goG psq) - go (DoneF rdm s) = DoneF rdm s - go (FailF cs reason) = FailF cs reason + go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason) + go (PChoiceF qpn rdm _ psq) = PChoiceF qpn rdm dummy psq + go (FChoiceF qfn rdm _ a b d psq) = FChoiceF qfn rdm dummy a b d psq + go (SChoiceF qsn rdm _ a psq) = SChoiceF qsn rdm dummy a psq + go (GoalChoiceF rdm psq) = GoalChoiceF rdm (goG psq) + go (DoneF rdm s) = DoneF rdm s + go (FailF cs reason) = FailF cs reason goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason) goG = PSQ.fromList @@ -248,6 +228,8 @@ . PSQ.toList dummy :: QGoalReason - dummy = PDependency - $ PI (Q (PackagePath DefaultNamespace Unqualified) (mkPackageName "$")) - (I (mkVersion [1]) InRepo) + dummy = + DependencyGoal $ + DependencyReason + (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) + [] [] diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Tree.hs b/cabal/cabal-install/Distribution/Solver/Modular/Tree.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Tree.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Tree.hs @@ -1,13 +1,13 @@ {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module Distribution.Solver.Modular.Tree - ( FailReason(..) - , POption(..) + ( POption(..) , Tree(..) , TreeF(..) , Weight + , FailReason(..) + , ConflictingDep(..) , ana , cata - , dchoices , inn , innM , para @@ -20,7 +20,6 @@ import Data.Traversable import Prelude hiding (foldr, mapM, sequence) -import Distribution.Solver.Modular.Degree import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package @@ -29,7 +28,10 @@ import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ) import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Flag import Distribution.Solver.Types.PackagePath +import Distribution.Types.UnqualComponentName +import Language.Haskell.Extension (Extension, Language) type Weight = Double @@ -45,15 +47,15 @@ -- giving too much weight to preferences that are applied later. data Tree d c = -- | Choose a version for a package (or choose to link) - PChoice QPN c (WeightedPSQ [Weight] POption (Tree d c)) + PChoice QPN RevDepMap c (WeightedPSQ [Weight] POption (Tree d c)) -- | Choose a value for a flag -- - -- The Bool indicates whether it's manual. - | FChoice QFN c WeakOrTrivial Bool (WeightedPSQ [Weight] Bool (Tree d c)) + -- The Bool is the default value. + | FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c)) -- | Choose whether or not to enable a stanza - | SChoice QSN c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) + | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) -- | Choose which choice to make next -- @@ -66,14 +68,13 @@ -- invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice' -- or 'SChoice' directly below a 'GoalChoice' node must equal the reason -- recorded on that 'GoalChoice' node. - | GoalChoice (PSQ (Goal QPN) (Tree d c)) + | GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c)) -- | We're done -- we found a solution! | Done RevDepMap d -- | We failed to find a solution in this path through the tree - | Fail (ConflictSet QPN) FailReason - deriving (Eq, Show) + | Fail ConflictSet FailReason -- | A package option is a package instance with an optional linking annotation -- @@ -94,8 +95,13 @@ data POption = POption I (Maybe PackagePath) deriving (Eq, Show) -data FailReason = InconsistentInitialConstraints - | Conflicting [Dep QPN] +data FailReason = UnsupportedExtension Extension + | UnsupportedLanguage Language + | MissingPkgconfigPackage PkgconfigName VR + | NewPackageDoesNotMatchExistingConstraint ConflictingDep + | ConflictingConstraints ConflictingDep ConflictingDep + | NewPackageIsMissingRequiredExe UnqualComponentName (DependencyReason QPN) + | PackageRequiresMissingExe QPN UnqualComponentName | CannotInstall | CannotReinstall | Shadowed @@ -112,42 +118,47 @@ | MultipleInstances | DependenciesNotLinked String | CyclicDependencies + | UnsupportedSpecVer Ver deriving (Eq, Show) +-- | Information about a dependency involved in a conflict, for error messages. +data ConflictingDep = ConflictingDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI + deriving (Eq, Show) + -- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' -- have the same meaning as in 'Tree'. data TreeF d c a = - PChoiceF QPN c (WeightedPSQ [Weight] POption a) - | FChoiceF QFN c WeakOrTrivial Bool (WeightedPSQ [Weight] Bool a) - | SChoiceF QSN c WeakOrTrivial (WeightedPSQ [Weight] Bool a) - | GoalChoiceF (PSQ (Goal QPN) a) - | DoneF RevDepMap d - | FailF (ConflictSet QPN) FailReason + PChoiceF QPN RevDepMap c (WeightedPSQ [Weight] POption a) + | FChoiceF QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool a) + | SChoiceF QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool a) + | GoalChoiceF RevDepMap (PSQ (Goal QPN) a) + | DoneF RevDepMap d + | FailF ConflictSet FailReason deriving (Functor, Foldable, Traversable) out :: Tree d c -> TreeF d c (Tree d c) -out (PChoice p i ts) = PChoiceF p i ts -out (FChoice p i b m ts) = FChoiceF p i b m ts -out (SChoice p i b ts) = SChoiceF p i b ts -out (GoalChoice ts) = GoalChoiceF ts -out (Done x s ) = DoneF x s -out (Fail c x ) = FailF c x +out (PChoice p s i ts) = PChoiceF p s i ts +out (FChoice p s i b m d ts) = FChoiceF p s i b m d ts +out (SChoice p s i b ts) = SChoiceF p s i b ts +out (GoalChoice s ts) = GoalChoiceF s ts +out (Done x s ) = DoneF x s +out (Fail c x ) = FailF c x inn :: TreeF d c (Tree d c) -> Tree d c -inn (PChoiceF p i ts) = PChoice p i ts -inn (FChoiceF p i b m ts) = FChoice p i b m ts -inn (SChoiceF p i b ts) = SChoice p i b ts -inn (GoalChoiceF ts) = GoalChoice ts -inn (DoneF x s ) = Done x s -inn (FailF c x ) = Fail c x +inn (PChoiceF p s i ts) = PChoice p s i ts +inn (FChoiceF p s i b m d ts) = FChoice p s i b m d ts +inn (SChoiceF p s i b ts) = SChoice p s i b ts +inn (GoalChoiceF s ts) = GoalChoice s ts +inn (DoneF x s ) = Done x s +inn (FailF c x ) = Fail c x innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c) -innM (PChoiceF p i ts) = liftM (PChoice p i ) (sequence ts) -innM (FChoiceF p i b m ts) = liftM (FChoice p i b m) (sequence ts) -innM (SChoiceF p i b ts) = liftM (SChoice p i b ) (sequence ts) -innM (GoalChoiceF ts) = liftM (GoalChoice ) (sequence ts) -innM (DoneF x s ) = return $ Done x s -innM (FailF c x ) = return $ Fail c x +innM (PChoiceF p s i ts) = liftM (PChoice p s i ) (sequence ts) +innM (FChoiceF p s i b m d ts) = liftM (FChoice p s i b m d) (sequence ts) +innM (SChoiceF p s i b ts) = liftM (SChoice p s i b ) (sequence ts) +innM (GoalChoiceF s ts) = liftM (GoalChoice s ) (sequence ts) +innM (DoneF x s ) = return $ Done x s +innM (FailF c x ) = return $ Fail c x -- | Determines whether a tree is active, i.e., isn't a failure node. active :: Tree d c -> Bool @@ -156,22 +167,13 @@ -- | Approximates the number of active choices that are available in a node. -- Note that we count goal choices as having one choice, always. -dchoices :: Tree d c -> Degree -dchoices (PChoice _ _ ts) = W.degree (W.filter active ts) -dchoices (FChoice _ _ _ _ ts) = W.degree (W.filter active ts) -dchoices (SChoice _ _ _ ts) = W.degree (W.filter active ts) -dchoices (GoalChoice _ ) = ZeroOrOne -dchoices (Done _ _ ) = ZeroOrOne -dchoices (Fail _ _ ) = ZeroOrOne - --- | Variant of 'dchoices' that traverses fewer children. zeroOrOneChoices :: Tree d c -> Bool -zeroOrOneChoices (PChoice _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (FChoice _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (SChoice _ _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (GoalChoice _ ) = True -zeroOrOneChoices (Done _ _ ) = True -zeroOrOneChoices (Fail _ _ ) = True +zeroOrOneChoices (PChoice _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (FChoice _ _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (SChoice _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (GoalChoice _ _ ) = True +zeroOrOneChoices (Done _ _ ) = True +zeroOrOneChoices (Fail _ _ ) = True -- | Catamorphism on trees. cata :: (TreeF d c a -> a) -> Tree d c -> a diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Validate.hs b/cabal/cabal-install/Distribution/Solver/Modular/Validate.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Validate.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Validate.hs @@ -1,5 +1,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +#ifdef DEBUG_CONFLICT_SETS +{-# LANGUAGE ImplicitParams #-} +#endif module Distribution.Solver.Modular.Validate (validateTree) where -- Validation of the tree. @@ -10,30 +14,35 @@ import Control.Applicative import Control.Monad.Reader hiding (sequence) +import Data.Function (on) import Data.List as L -import Data.Map as M import Data.Set as S import Data.Traversable import Prelude hiding (sequence) import Language.Haskell.Extension (Extension, Language) +import Distribution.Compat.Map.Strict as M import Distribution.Compiler (CompilerInfo(..)) import Distribution.Solver.Modular.Assignment +import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree -import Distribution.Solver.Modular.Version (VR) +import Distribution.Solver.Modular.Version import qualified Distribution.Solver.Modular.WeightedPSQ as W -import Distribution.Solver.Types.ComponentDeps (Component) - import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) +import Distribution.Types.UnqualComponentName +#ifdef DEBUG_CONFLICT_SETS +import GHC.Stack (CallStack) +#endif + -- In practice, most constraints are implication constraints (IF we have made -- a number of choices, THEN we also have to ensure that). We call constraints -- that for which the preconditions are fulfilled ACTIVE. We maintain a set @@ -90,8 +99,23 @@ supportedLang :: Language -> Bool, presentPkgs :: PkgconfigName -> VR -> Bool, index :: Index, - saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies + + -- Saved, scoped, dependencies. Every time 'validate' makes a package choice, + -- it qualifies the package's dependencies and saves them in this map. Then + -- the qualified dependencies are available for subsequent flag and stanza + -- choices for the same package. + saved :: Map QPN (FlaggedDeps QPN), + pa :: PreAssignment, + + -- Map from package name to the executables that are provided by the chosen + -- instance of that package. + availableExes :: Map QPN [UnqualComponentName], + + -- Map from package name to the executables that are required from that + -- package. + requiredExes :: Map QPN ExeDeps, + qualifyOptions :: QualifyOptions } @@ -101,13 +125,47 @@ runValidate :: Validate a -> ValidateState -> a runValidate (Validate r) = runReader r +-- | A preassignment comprises knowledge about variables, but not +-- necessarily fixed values. +data PreAssignment = PA PPreAssignment FAssignment SAssignment + +-- | A (partial) package preassignment. Qualified package names +-- are associated with MergedPkgDeps. +type PPreAssignment = Map QPN MergedPkgDep + +-- | A dependency on a package, including its DependencyReason. +data PkgDep = PkgDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI + +-- | Map from executable name to one of the reasons that the executable is +-- required. +type ExeDeps = Map UnqualComponentName (DependencyReason QPN) + +-- | MergedPkgDep records constraints about the instances that can still be +-- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a +-- list of version ranges paired with the goals / variables that introduced +-- them. It also records whether a package is a build-tool dependency, for each +-- reason that it was introduced. +-- +-- It is important to store the executable name with the version constraint, for +-- error messages, because whether something is a build-tool dependency affects +-- its qualifier, which affects which constraint is applied. +data MergedPkgDep = + MergedDepFixed (Maybe UnqualComponentName) (DependencyReason QPN) I + | MergedDepConstrained [VROrigin] + +-- | Version ranges paired with origins. +type VROrigin = (VR, Maybe UnqualComponentName, DependencyReason QPN) + +-- | The information needed to create a 'Fail' node. +type Conflict = (ConflictSet, FailReason) + validate :: Tree d c -> Validate (Tree d c) validate = cata go where go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c) - go (PChoiceF qpn gr ts) = PChoice qpn gr <$> sequence (W.mapWithKey (goP qpn) ts) - go (FChoiceF qfn gr b m ts) = + go (PChoiceF qpn rdm gr ts) = PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) ts) + go (FChoiceF qfn rdm gr b m d ts) = do -- Flag choices may occur repeatedly (because they can introduce new constraints -- in various places). However, subsequent choices must be consistent. We thereby @@ -119,8 +177,8 @@ Just t -> goF qfn rb t Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn) Nothing -> -- flag choice is new, follow both branches - FChoice qfn gr b m <$> sequence (W.mapWithKey (goF qfn) ts) - go (SChoiceF qsn gr b ts) = + FChoice qfn rdm gr b m d <$> sequence (W.mapWithKey (goF qfn) ts) + go (SChoiceF qsn rdm gr b ts) = do -- Optional stanza choices are very similar to flag choices. PA _ _ psa <- asks pa -- obtain current stanza-preassignment @@ -130,12 +188,12 @@ Just t -> goS qsn rb t Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn) Nothing -> -- stanza choice is new, follow both branches - SChoice qsn gr b <$> sequence (W.mapWithKey (goS qsn) ts) + SChoice qsn rdm gr b <$> sequence (W.mapWithKey (goS qsn) ts) -- We don't need to do anything for goal choices or failure nodes. - go (GoalChoiceF ts) = GoalChoice <$> sequence ts - go (DoneF rdm s ) = pure (Done rdm s) - go (FailF c fr ) = pure (Fail c fr) + go (GoalChoiceF rdm ts) = GoalChoice rdm <$> sequence ts + go (DoneF rdm s ) = pure (Done rdm s) + go (FailF c fr ) = pure (Fail c fr) -- What to do for package nodes ... goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) @@ -146,36 +204,51 @@ pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs idx <- asks index -- obtain the index svd <- asks saved -- obtain saved dependencies + aExes <- asks availableExes + rExes <- asks requiredExes qo <- asks qualifyOptions -- obtain dependencies and index-dictated exclusions introduced by the choice - let (PInfo deps _ mfr) = idx ! pn ! i + let (PInfo deps exes _ mfr) = idx ! pn ! i -- qualify the deps in the current scope let qdeps = qualifyDeps qo qpn deps -- the new active constraints are given by the instance we have chosen, -- plus the dependency information we have for that instance - -- TODO: is the False here right? - let newactives = Dep False {- not exe -} qpn (Fixed i (P qpn)) : L.map (resetVar (P qpn)) (extractDeps pfa psa qdeps) + let newactives = extractAllDeps pfa psa qdeps -- We now try to extend the partial assignment with the new active constraints. - let mnppa = extend extSupported langSupported pkgPresent (P qpn) ppa newactives + let mnppa = extend extSupported langSupported pkgPresent newactives + =<< extendWithPackageChoice (PI qpn i) ppa -- In case we continue, we save the scoped dependencies let nsvd = M.insert qpn qdeps svd case mfr of Just fr -> -- The index marks this as an invalid choice. We can stop. return (Fail (varToConflictSet (P qpn)) fr) - _ -> case mnppa of - Left (c, d) -> -- We have an inconsistency. We can stop. - return (Fail c (Conflicting d)) - Right nppa -> -- We have an updated partial assignment for the recursive validation. - local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r + Nothing -> + let newDeps :: Either Conflict (PPreAssignment, Map QPN ExeDeps) + newDeps = do + nppa <- mnppa + rExes' <- extendRequiredExes aExes rExes newactives + checkExesInNewPackage rExes qpn exes + return (nppa, rExes') + in case newDeps of + Left (c, fr) -> -- We have an inconsistency. We can stop. + return (Fail c fr) + Right (nppa, rExes') -> -- We have an updated partial assignment for the recursive validation. + local (\ s -> s { pa = PA nppa pfa psa + , saved = nsvd + , availableExes = M.insert qpn exes aExes + , requiredExes = rExes' + }) r -- What to do for flag nodes ... goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goF qfn@(FN (PI qpn _i) _f) b r = do + goF qfn@(FN qpn _f) b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - svd <- asks saved -- obtain saved dependencies + svd <- asks saved -- obtain saved dependencies + aExes <- asks availableExes + rExes <- asks requiredExes -- Note that there should be saved dependencies for the package in question, -- because while building, we do not choose flags before we see the packages -- that define them. @@ -188,19 +261,24 @@ -- We now try to get the new active dependencies we might learn about because -- we have chosen a new flag. let newactives = extractNewDeps (F qfn) b npfa psa qdeps + mNewRequiredExes = extendRequiredExes aExes rExes newactives -- As in the package case, we try to extend the partial assignment. - case extend extSupported langSupported pkgPresent (F qfn) ppa newactives of - Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found - Right nppa -> local (\ s -> s { pa = PA nppa npfa psa }) r + let mnppa = extend extSupported langSupported pkgPresent newactives ppa + case liftM2 (,) mnppa mNewRequiredExes of + Left (c, fr) -> return (Fail c fr) -- inconsistency found + Right (nppa, rExes') -> + local (\ s -> s { pa = PA nppa npfa psa, requiredExes = rExes' }) r -- What to do for stanza nodes (similar to flag nodes) ... goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goS qsn@(SN (PI qpn _i) _f) b r = do + goS qsn@(SN qpn _f) b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - svd <- asks saved -- obtain saved dependencies + svd <- asks saved -- obtain saved dependencies + aExes <- asks availableExes + rExes <- asks requiredExes -- Note that there should be saved dependencies for the package in question, -- because while building, we do not choose flags before we see the packages -- that define them. @@ -213,54 +291,197 @@ -- We now try to get the new active dependencies we might learn about because -- we have chosen a new flag. let newactives = extractNewDeps (S qsn) b pfa npsa qdeps + mNewRequiredExes = extendRequiredExes aExes rExes newactives -- As in the package case, we try to extend the partial assignment. - case extend extSupported langSupported pkgPresent (S qsn) ppa newactives of - Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found - Right nppa -> local (\ s -> s { pa = PA nppa pfa npsa }) r + let mnppa = extend extSupported langSupported pkgPresent newactives ppa + case liftM2 (,) mnppa mNewRequiredExes of + Left (c, fr) -> return (Fail c fr) -- inconsistency found + Right (nppa, rExes') -> + local (\ s -> s { pa = PA nppa pfa npsa, requiredExes = rExes' }) r +-- | Check that a newly chosen package instance contains all executables that +-- are required from that package so far. +checkExesInNewPackage :: Map QPN ExeDeps + -> QPN + -> [UnqualComponentName] + -> Either Conflict () +checkExesInNewPackage required qpn providedExes = + case M.toList $ deleteKeys providedExes (M.findWithDefault M.empty qpn required) of + (missingExe, dr) : _ -> let cs = CS.insert (P qpn) $ dependencyReasonToCS dr + in Left (cs, NewPackageIsMissingRequiredExe missingExe dr) + [] -> Right () + where + deleteKeys :: Ord k => [k] -> Map k v -> Map k v + deleteKeys ks m = L.foldr M.delete m ks + -- | We try to extract as many concrete dependencies from the given flagged -- dependencies as possible. We make use of all the flag knowledge we have -- already acquired. -extractDeps :: FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN] -extractDeps fa sa deps = do +extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] +extractAllDeps fa sa deps = do d <- deps case d of Simple sd _ -> return sd Flagged qfn _ td fd -> case M.lookup qfn fa of Nothing -> mzero - Just True -> extractDeps fa sa td - Just False -> extractDeps fa sa fd + Just True -> extractAllDeps fa sa td + Just False -> extractAllDeps fa sa fd Stanza qsn td -> case M.lookup qsn sa of Nothing -> mzero - Just True -> extractDeps fa sa td + Just True -> extractAllDeps fa sa td Just False -> [] -- | We try to find new dependencies that become available due to the given -- flag or stanza choice. We therefore look for the choice in question, and then call --- 'extractDeps' for everything underneath. -extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN] +-- 'extractAllDeps' for everything underneath. +extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] extractNewDeps v b fa sa = go where - go :: FlaggedDeps comp QPN -> [Dep QPN] -- Type annotation necessary (polymorphic recursion) + go :: FlaggedDeps QPN -> [LDep QPN] go deps = do d <- deps case d of Simple _ _ -> mzero Flagged qfn' _ td fd - | v == F qfn' -> L.map (resetVar v) $ - if b then extractDeps fa sa td else extractDeps fa sa fd + | v == F qfn' -> if b then extractAllDeps fa sa td else extractAllDeps fa sa fd | otherwise -> case M.lookup qfn' fa of Nothing -> mzero Just True -> go td Just False -> go fd Stanza qsn' td - | v == S qsn' -> L.map (resetVar v) $ - if b then extractDeps fa sa td else [] + | v == S qsn' -> if b then extractAllDeps fa sa td else [] | otherwise -> case M.lookup qsn' sa of Nothing -> mzero Just True -> go td Just False -> [] +-- | Extend a package preassignment. +-- +-- Takes the variable that causes the new constraints, a current preassignment +-- and a set of new dependency constraints. +-- +-- We're trying to extend the preassignment with each dependency one by one. +-- Each dependency is for a particular variable. We check if we already have +-- constraints for that variable in the current preassignment. If so, we're +-- trying to merge the constraints. +-- +-- Either returns a witness of the conflict that would arise during the merge, +-- or the successfully extended assignment. +extend :: (Extension -> Bool) -- ^ is a given extension supported + -> (Language -> Bool) -- ^ is a given language supported + -> (PkgconfigName -> VR -> Bool) -- ^ is a given pkg-config requirement satisfiable + -> [LDep QPN] + -> PPreAssignment + -> Either Conflict PPreAssignment +extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle ppa newactives + where + + extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment + extendSingle a (LDep dr (Ext ext )) = + if extSupported ext then Right a + else Left (dependencyReasonToCS dr, UnsupportedExtension ext) + extendSingle a (LDep dr (Lang lang)) = + if langSupported lang then Right a + else Left (dependencyReasonToCS dr, UnsupportedLanguage lang) + extendSingle a (LDep dr (Pkg pn vr)) = + if pkgPresent pn vr then Right a + else Left (dependencyReasonToCS dr, MissingPkgconfigPackage pn vr) + extendSingle a (LDep dr (Dep mExe qpn ci)) = + let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a + in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr mExe qpn ci) of + Left (c, (d, d')) -> Left (c, ConflictingConstraints d d') + Right x -> Right x + +-- | Extend a package preassignment with a package choice. For example, when +-- the solver chooses foo-2.0, it tries to add the constraint foo==2.0. +extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment +extendWithPackageChoice (PI qpn i) ppa = + let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa + newChoice = PkgDep (DependencyReason qpn [] []) Nothing qpn (Fixed i) + in case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of + Left (c, (d, _d')) -> -- Don't include the package choice in the + -- FailReason, because it is redundant. + Left (c, NewPackageDoesNotMatchExistingConstraint d) + Right x -> Right x + +-- | Merge constrained instances. We currently adopt a lazy strategy for +-- merging, i.e., we only perform actual checking if one of the two choices +-- is fixed. If the merge fails, we return a conflict set indicating the +-- variables responsible for the failure, as well as the two conflicting +-- fragments. +-- +-- Note that while there may be more than one conflicting pair of version +-- ranges, we only return the first we find. +-- +-- The ConflictingDeps are returned in order, i.e., the first describes the +-- conflicting part of the MergedPkgDep, and the second describes the PkgDep. +-- +-- TODO: Different pairs might have different conflict sets. We're +-- obviously interested to return a conflict that has a "better" conflict +-- set in the sense the it contains variables that allow us to backjump +-- further. We might apply some heuristics here, such as to change the +-- order in which we check the constraints. +merge :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep +merge (MergedDepFixed mExe1 vs1 i1) (PkgDep vs2 mExe2 p ci@(Fixed i2)) + | i1 == i2 = Right $ MergedDepFixed mExe1 vs1 i1 + | otherwise = + Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 + , ( ConflictingDep vs1 mExe1 p (Fixed i1) + , ConflictingDep vs2 mExe2 p ci ) ) + +merge (MergedDepFixed mExe1 vs1 i@(I v _)) (PkgDep vs2 mExe2 p ci@(Constrained vr)) + | checkVR vr v = Right $ MergedDepFixed mExe1 vs1 i + | otherwise = + Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 + , ( ConflictingDep vs1 mExe1 p (Fixed i) + , ConflictingDep vs2 mExe2 p ci ) ) + +merge (MergedDepConstrained vrOrigins) (PkgDep vs2 mExe2 p ci@(Fixed i@(I v _))) = + go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ... + where + go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep + go [] = Right (MergedDepFixed mExe2 vs2 i) + go ((vr, mExe1, vs1) : vros) + | checkVR vr v = go vros + | otherwise = + Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 + , ( ConflictingDep vs1 mExe1 p (Constrained vr) + , ConflictingDep vs2 mExe2 p ci ) ) + +merge (MergedDepConstrained vrOrigins) (PkgDep vs2 mExe2 _ (Constrained vr)) = + Right (MergedDepConstrained $ + + -- TODO: This line appends the new version range, to preserve the order used + -- before a refactoring. Consider prepending the version range, if there is + -- no negative performance impact. + vrOrigins ++ [(vr, mExe2, vs2)]) + +-- | Takes a list of new dependencies and uses it to try to update the map of +-- known executable dependencies. It returns a failure when a new dependency +-- requires an executable that is missing from one of the previously chosen +-- packages. +extendRequiredExes :: Map QPN [UnqualComponentName] + -> Map QPN ExeDeps + -> [LDep QPN] + -> Either Conflict (Map QPN ExeDeps) +extendRequiredExes available = foldM extendSingle + where + extendSingle :: Map QPN ExeDeps -> LDep QPN -> Either Conflict (Map QPN ExeDeps) + extendSingle required (LDep dr (Dep (Just exe) qpn _)) = + let exeDeps = M.findWithDefault M.empty qpn required + in -- Only check for the existence of the exe if its package has already + -- been chosen. + case M.lookup qpn available of + Just exes + | L.notElem exe exes -> let cs = CS.insert (P qpn) (dependencyReasonToCS dr) + in Left (cs, PackageRequiresMissingExe qpn exe) + _ -> Right $ M.insertWith M.union qpn (M.insert exe dr exeDeps) required + extendSingle required _ = Right required + -- | Interface. validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { @@ -274,5 +495,7 @@ , index = idx , saved = M.empty , pa = PA M.empty M.empty M.empty + , availableExes = M.empty + , requiredExes = M.empty , qualifyOptions = defaultQualifyOptions idx } diff --git a/cabal/cabal-install/Distribution/Solver/Modular/Var.hs b/cabal/cabal-install/Distribution/Solver/Modular/Var.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/Var.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/Var.hs @@ -1,15 +1,13 @@ {-# LANGUAGE DeriveFunctor #-} module Distribution.Solver.Modular.Var ( Var(..) - , simplifyVar , showVar - , varPI + , varPN ) where import Prelude hiding (pi) import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package import Distribution.Solver.Types.PackagePath {------------------------------------------------------------------------------- @@ -24,23 +22,13 @@ data Var qpn = P qpn | F (FN qpn) | S (SN qpn) deriving (Eq, Ord, Show, Functor) --- | For computing conflict sets, we map flag choice vars to a --- single flag choice. This means that all flag choices are treated --- as interdependent. So if one flag of a package ends up in a --- conflict set, then all flags are being treated as being part of --- the conflict set. -simplifyVar :: Var qpn -> Var qpn -simplifyVar (P qpn) = P qpn -simplifyVar (F (FN pi _)) = F (FN pi (mkFlag "flag")) -simplifyVar (S qsn) = S qsn - showVar :: Var QPN -> String showVar (P qpn) = showQPN qpn showVar (F qfn) = showQFN qfn showVar (S qsn) = showQSN qsn --- | Extract the package instance from a Var -varPI :: Var QPN -> (QPN, Maybe I) -varPI (P qpn) = (qpn, Nothing) -varPI (F (FN (PI qpn i) _)) = (qpn, Just i) -varPI (S (SN (PI qpn i) _)) = (qpn, Just i) +-- | Extract the package name from a Var +varPN :: Var qpn -> qpn +varPN (P qpn) = qpn +varPN (F (FN qpn _)) = qpn +varPN (S (SN qpn _)) = qpn diff --git a/cabal/cabal-install/Distribution/Solver/Modular/WeightedPSQ.hs b/cabal/cabal-install/Distribution/Solver/Modular/WeightedPSQ.hs --- a/cabal/cabal-install/Distribution/Solver/Modular/WeightedPSQ.hs +++ b/cabal/cabal-install/Distribution/Solver/Modular/WeightedPSQ.hs @@ -5,7 +5,6 @@ , toList , keys , weights - , degree , isZeroOrOne , filter , lookup @@ -20,8 +19,6 @@ import qualified Data.Traversable as T import Prelude hiding (filter, lookup) -import Distribution.Solver.Modular.Degree - -- | An association list that is sorted by weight. -- -- Each element has a key ('k'), value ('v'), and weight ('w'). All operations @@ -32,14 +29,6 @@ -- | /O(N)/. filter :: (v -> Bool) -> WeightedPSQ k w v -> WeightedPSQ k w v filter p (WeightedPSQ xs) = WeightedPSQ (L.filter (p . triple_3) xs) - --- | /O(1)/. Return the length as a 'Degree' after traversing as few elements --- as possible. -degree :: WeightedPSQ w k v -> Degree -degree (WeightedPSQ []) = ZeroOrOne -degree (WeightedPSQ [_]) = ZeroOrOne -degree (WeightedPSQ [_, _]) = Two -degree (WeightedPSQ _) = Other -- | /O(1)/. Return @True@ if the @WeightedPSQ@ contains zero or one elements. isZeroOrOne :: WeightedPSQ w k v -> Bool 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 @@ -37,8 +37,8 @@ ) where import Prelude () -import Distribution.Package (UnqualComponentName) -import Distribution.Client.Compat.Prelude hiding (empty,zip) +import Distribution.Types.UnqualComponentName +import Distribution.Solver.Compat.Prelude hiding (empty,zip) import qualified Data.Map as Map import Data.Foldable (fold) diff --git a/cabal/cabal-install/Distribution/Solver/Types/ConstraintSource.hs b/cabal/cabal-install/Distribution/Solver/Types/ConstraintSource.hs --- a/cabal/cabal-install/Distribution/Solver/Types/ConstraintSource.hs +++ b/cabal/cabal-install/Distribution/Solver/Types/ConstraintSource.hs @@ -46,8 +46,9 @@ -- | The source of the constraint is not specified. | ConstraintSourceUnknown - -- | Custom setup requires a minimum lower bound on Cabal - | ConstraintNewBuildCustomSetupLowerBoundCabal + -- | An internal constraint due to compatibility issues with the Setup.hs + -- command line interface requires a minimum lower bound on Cabal + | ConstraintSetupCabalMinVersion deriving (Eq, Show, Generic) instance Binary ConstraintSource @@ -71,4 +72,5 @@ showConstraintSource ConstraintSourceConfigFlagOrTarget = "config file, command line flag, or user target" showConstraintSource ConstraintSourceUnknown = "unknown source" -showConstraintSource ConstraintNewBuildCustomSetupLowerBoundCabal = "new-build's support of Custom Setup (issue #3932)" +showConstraintSource ConstraintSetupCabalMinVersion = + "minimum version of Cabal used by Setup.hs" diff --git a/cabal/cabal-install/Distribution/Solver/Types/Flag.hs b/cabal/cabal-install/Distribution/Solver/Types/Flag.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Solver/Types/Flag.hs @@ -0,0 +1,6 @@ +module Distribution.Solver.Types.Flag + ( FlagType(..) + ) where + +data FlagType = Manual | Automatic + deriving (Eq, Show) diff --git a/cabal/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs b/cabal/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs --- a/cabal/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs +++ b/cabal/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs @@ -4,9 +4,13 @@ ) where import Distribution.Compat.Binary (Binary(..)) -import Distribution.Package ( Package(..), HasUnitId(..) ) +import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) import Distribution.Solver.Types.SolverId +import Distribution.Types.MungedPackageId +import Distribution.Types.PackageId +import Distribution.Types.PackageName +import Distribution.Types.MungedPackageName import Distribution.InstalledPackageInfo (InstalledPackageInfo) import GHC.Generics (Generic) @@ -22,7 +26,13 @@ instance Binary InstSolverPackage instance Package InstSolverPackage where - packageId = packageId . instSolverPkgIPI + packageId i = + -- HACK! See Note [Index conversion with internal libraries] + let MungedPackageId mpn v = mungedId i + in PackageIdentifier (mkPackageName (unMungedPackageName mpn)) v + +instance HasMungedPackageId InstSolverPackage where + mungedId = mungedId . instSolverPkgIPI instance HasUnitId InstSolverPackage where installedUnitId = installedUnitId . instSolverPkgIPI diff --git a/cabal/cabal-install/Distribution/Solver/Types/OptionalStanza.hs b/cabal/cabal-install/Distribution/Solver/Types/OptionalStanza.hs --- a/cabal/cabal-install/Distribution/Solver/Types/OptionalStanza.hs +++ b/cabal/cabal-install/Distribution/Solver/Types/OptionalStanza.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} module Distribution.Solver.Types.OptionalStanza ( OptionalStanza(..) + , showStanza , enableStanzas ) where @@ -16,6 +17,11 @@ = TestStanzas | BenchStanzas deriving (Eq, Ord, Enum, Bounded, Show, Generic, Typeable) + +-- | String representation of an OptionalStanza. +showStanza :: OptionalStanza -> String +showStanza TestStanzas = "test" +showStanza BenchStanzas = "bench" -- | Convert a list of 'OptionalStanza' into the corresponding -- 'ComponentRequestedSpec' which records what components are enabled. diff --git a/cabal/cabal-install/Distribution/Solver/Types/PackageConstraint.hs b/cabal/cabal-install/Distribution/Solver/Types/PackageConstraint.hs --- a/cabal/cabal-install/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal/cabal-install/Distribution/Solver/Types/PackageConstraint.hs @@ -1,49 +1,149 @@ {-# LANGUAGE DeriveGeneric #-} + +-- | Per-package constraints. Package constraints must be respected by the +-- solver. Multiple constraints for each package can be given, though obviously +-- it is possible to construct conflicting constraints (eg impossible version +-- range or inconsistent flag assignment). +-- module Distribution.Solver.Types.PackageConstraint ( + ConstraintScope(..), + scopeToplevel, + scopeToPackageName, + constraintScopeMatches, + PackageProperty(..), + dispPackageProperty, PackageConstraint(..), + dispPackageConstraint, showPackageConstraint, + packageConstraintToDependency ) where -import Distribution.Compat.Binary (Binary(..)) -import Distribution.PackageDescription (FlagAssignment, unFlagName) -import Distribution.Package (PackageName) +import Distribution.Compat.Binary (Binary(..)) +import Distribution.Package (PackageName) +import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) +import Distribution.Types.Dependency (Dependency(..)) +import Distribution.Version (VersionRange, simplifyVersionRange) + +import Distribution.Solver.Compat.Prelude ((<<>>)) import Distribution.Solver.Types.OptionalStanza -import Distribution.Text (display) -import Distribution.Version (VersionRange, simplifyVersionRange) -import GHC.Generics (Generic) +import Distribution.Solver.Types.PackagePath --- | Per-package constraints. Package constraints must be respected by the --- solver. Multiple constraints for each package can be given, though obviously --- it is possible to construct conflicting constraints (eg impossible version --- range or inconsistent flag assignment). --- -data PackageConstraint - = PackageConstraintVersion PackageName VersionRange - | PackageConstraintInstalled PackageName - | PackageConstraintSource PackageName - | PackageConstraintFlags PackageName FlagAssignment - | PackageConstraintStanzas PackageName [OptionalStanza] +import Distribution.Text (disp, flatStyle) +import GHC.Generics (Generic) +import Text.PrettyPrint ((<+>)) +import qualified Text.PrettyPrint as Disp + + +-- | Determines to what packages and in what contexts a +-- constraint applies. +data ConstraintScope + -- | A scope that applies when the given package is used as a build target. + -- In other words, the scope applies iff a goal has a top-level qualifier + -- and its namespace matches the given package name. A namespace is + -- considered to match a package name when it is either the default + -- namespace (for --no-independent-goals) or it is an independent namespace + -- with the given package name (for --independent-goals). + + -- TODO: Try to generalize the ConstraintScopes once component-based + -- solving is implemented, and remove this special case for targets. + = ScopeTarget PackageName + -- | The package with the specified name and qualifier. + | ScopeQualified Qualifier PackageName + -- | The package with the specified name when it has a + -- setup qualifier. + | ScopeAnySetupQualifier PackageName + -- | The package with the specified name regardless of + -- qualifier. + | ScopeAnyQualifier PackageName + deriving (Eq, Show) + +-- | Constructor for a common use case: the constraint applies to +-- the package with the specified name when that package is a +-- top-level dependency in the default namespace. +scopeToplevel :: PackageName -> ConstraintScope +scopeToplevel = ScopeQualified QualToplevel + +-- | Returns the package name associated with a constraint scope. +scopeToPackageName :: ConstraintScope -> PackageName +scopeToPackageName (ScopeTarget pn) = pn +scopeToPackageName (ScopeQualified _ pn) = pn +scopeToPackageName (ScopeAnySetupQualifier pn) = pn +scopeToPackageName (ScopeAnyQualifier pn) = pn + +constraintScopeMatches :: ConstraintScope -> QPN -> Bool +constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') = + let namespaceMatches DefaultNamespace = True + namespaceMatches (Independent namespacePn) = pn == namespacePn + in namespaceMatches ns && q == QualToplevel && pn == pn' +constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') = + q == q' && pn == pn' +constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = + let setup (PackagePath _ (QualSetup _)) = True + setup _ = False + in setup pp && pn == pn' +constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' + +-- | Pretty-prints a constraint scope. +dispConstraintScope :: ConstraintScope -> Disp.Doc +dispConstraintScope (ScopeTarget pn) = disp pn <<>> Disp.text "." <<>> disp pn +dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> disp pn +dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> disp pn +dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> disp pn + +-- | A package property is a logical predicate on packages. +data PackageProperty + = PackagePropertyVersion VersionRange + | PackagePropertyInstalled + | PackagePropertySource + | PackagePropertyFlags FlagAssignment + | PackagePropertyStanzas [OptionalStanza] deriving (Eq, Show, Generic) -instance Binary PackageConstraint +instance Binary PackageProperty --- | Provide a textual representation of a package constraint --- for debugging purposes. +-- | Pretty-prints a package property. +dispPackageProperty :: PackageProperty -> Disp.Doc +dispPackageProperty (PackagePropertyVersion verrange) = disp verrange +dispPackageProperty PackagePropertyInstalled = Disp.text "installed" +dispPackageProperty PackagePropertySource = Disp.text "source" +dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags +dispPackageProperty (PackagePropertyStanzas stanzas) = + Disp.hsep $ map (Disp.text . showStanza) stanzas + +-- | A package constraint consists of a scope plus a property +-- that must hold for all packages within that scope. +data PackageConstraint = PackageConstraint ConstraintScope PackageProperty + deriving (Eq, Show) + +-- | Pretty-prints a package constraint. +dispPackageConstraint :: PackageConstraint -> Disp.Doc +dispPackageConstraint (PackageConstraint scope prop) = + dispConstraintScope scope <+> dispPackageProperty prop + +-- | Alternative textual representation of a package constraint +-- for debugging purposes (slightly more verbose than that +-- produced by 'dispPackageConstraint'). -- showPackageConstraint :: PackageConstraint -> String -showPackageConstraint (PackageConstraintVersion pn vr) = - display pn ++ " " ++ display (simplifyVersionRange vr) -showPackageConstraint (PackageConstraintInstalled pn) = - display pn ++ " installed" -showPackageConstraint (PackageConstraintSource pn) = - display pn ++ " source" -showPackageConstraint (PackageConstraintFlags pn fs) = - "flags " ++ display pn ++ " " ++ unwords (map (uncurry showFlag) fs) +showPackageConstraint pc@(PackageConstraint scope prop) = + Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 where - showFlag f True = "+" ++ unFlagName f - showFlag f False = "-" ++ unFlagName f -showPackageConstraint (PackageConstraintStanzas pn ss) = - "stanzas " ++ display pn ++ " " ++ unwords (map showStanza ss) + pc2 = case prop of + PackagePropertyVersion vr -> + PackageConstraint scope $ PackagePropertyVersion (simplifyVersionRange vr) + _ -> pc + postprocess = case prop of + PackagePropertyFlags _ -> (Disp.text "flags" <+>) + PackagePropertyStanzas _ -> (Disp.text "stanzas" <+>) + _ -> id + +-- | Lossily convert a 'PackageConstraint' to a 'Dependency'. +packageConstraintToDependency :: PackageConstraint -> Maybe Dependency +packageConstraintToDependency (PackageConstraint scope prop) = toDep prop where - showStanza TestStanzas = "test" - showStanza BenchStanzas = "bench" + toDep (PackagePropertyVersion vr) = + Just $ Dependency (scopeToPackageName scope) vr + toDep (PackagePropertyInstalled) = Nothing + toDep (PackagePropertySource) = Nothing + toDep (PackagePropertyFlags _) = Nothing + toDep (PackagePropertyStanzas _) = Nothing 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 @@ -46,7 +46,7 @@ ) where import Prelude () -import Distribution.Client.Compat.Prelude hiding (lookup) +import Distribution.Solver.Compat.Prelude hiding (lookup) import Control.Exception (assert) import qualified Data.Map as Map @@ -54,8 +54,8 @@ import Distribution.Package ( PackageName, unPackageName, PackageIdentifier(..) - , Package(..), packageName, packageVersion - , Dependency(Dependency) ) + , Package(..), packageName, packageVersion ) +import Distribution.Types.Dependency import Distribution.Version ( withinRange ) import Distribution.Simple.Utils @@ -185,7 +185,8 @@ -- | Internal delete helper. -- -delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg +delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg + -> PackageIndex pkg delete name p (PackageIndex index) = mkPackageIndex $ Map.update filterBucket name index where @@ -196,19 +197,22 @@ -- | Removes a single package from the index. -- -deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg +deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg + -> PackageIndex pkg deletePackageId pkgid = delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) -- | Removes all packages with this (case-sensitive) name from the index. -- -deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg +deletePackageName :: Package pkg => PackageName -> PackageIndex pkg + -> PackageIndex pkg deletePackageName name = delete name (\pkg -> packageName pkg == name) -- | Removes all packages satisfying this dependency from the index. -- -deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg +deleteDependency :: Package pkg => Dependency -> PackageIndex pkg + -> PackageIndex pkg deleteDependency (Dependency name verstionRange) = delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) @@ -244,7 +248,8 @@ -- Since multiple package DBs mask each other case-sensitively by package name, -- then we get back at most one package. -- -lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg +lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier + -> Maybe pkg lookupPackageId index pkgid = case [ pkg | pkg <- lookup index (packageName pkgid) , packageId pkg == pkgid ] of diff --git a/cabal/cabal-install/Distribution/Solver/Types/PackagePath.hs b/cabal/cabal-install/Distribution/Solver/Types/PackagePath.hs --- a/cabal/cabal-install/Distribution/Solver/Types/PackagePath.hs +++ b/cabal/cabal-install/Distribution/Solver/Types/PackagePath.hs @@ -2,13 +2,17 @@ ( PackagePath(..) , Namespace(..) , Qualifier(..) - , QPN + , dispQualifier , Qualified(..) + , QPN + , dispQPN , showQPN ) where import Distribution.Package import Distribution.Text +import qualified Text.PrettyPrint as Disp +import Distribution.Solver.Compat.Prelude ((<<>>)) -- | A package path consists of a namespace and a package path inside that -- namespace. @@ -23,21 +27,25 @@ -- | The default namespace DefaultNamespace - -- | Independent namespace - -- - -- For now we just number these (rather than giving them more structure). - | Independent Int + -- | A namespace for a specific build target + | Independent PackageName deriving (Eq, Ord, Show) +-- | Pretty-prints a namespace. The result is either empty or +-- ends in a period, so it can be prepended onto a qualifier. +dispNamespace :: Namespace -> Disp.Doc +dispNamespace DefaultNamespace = Disp.empty +dispNamespace (Independent i) = disp i <<>> Disp.text "." + -- | Qualifier of a package within a namespace (see 'PackagePath') data Qualifier = -- | Top-level dependency in this namespace - Unqualified + QualToplevel -- | Any dependency on base is considered independent -- -- This makes it possible to have base shims. - | Base PackageName + | QualBase PackageName -- | Setup dependency -- @@ -46,7 +54,7 @@ -- are independent from everything else. However, this very quickly leads to -- infinite search trees in the solver. Therefore we limit ourselves to -- a single qualifier (within a given namespace). - | Setup PackageName + | QualSetup PackageName -- | If we depend on an executable from a package (via -- @build-tools@), we should solve for the dependencies of that @@ -58,42 +66,36 @@ -- of the depended upon executables from a package; if we -- tracked only @pn2@, that would require us to pick only one -- version of an executable over the entire install plan.) - | Exe PackageName PackageName + | QualExe PackageName PackageName deriving (Eq, Ord, Show) --- | String representation of a package path. +-- | Pretty-prints a qualifier. The result is either empty or +-- ends in a period, so it can be prepended onto a package name. -- --- NOTE: The result of 'showPP' is either empty or results in a period, so that --- it can be prepended to a package name. -showPP :: PackagePath -> String -showPP (PackagePath ns q) = - case ns of - DefaultNamespace -> go q - Independent i -> show i ++ "." ++ go q - where - -- Print the qualifier - -- - -- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is - -- there to make sure different dependencies on base are all independent. - -- So we want to print something like @"A.base"@, where the @"A."@ part - -- is the qualifier and @"base"@ is the actual dependency (which, for the - -- 'Base' qualifier, will always be @base@). - go Unqualified = "" - go (Setup pn) = display pn ++ "-setup." - go (Exe pn pn2) = display pn ++ "-" ++ display pn2 ++ "-exe." - go (Base pn) = display pn ++ "." +-- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is +-- there to make sure different dependencies on base are all independent. +-- So we want to print something like @"A.base"@, where the @"A."@ part +-- is the qualifier and @"base"@ is the actual dependency (which, for the +-- 'Base' qualifier, will always be @base@). +dispQualifier :: Qualifier -> Disp.Doc +dispQualifier QualToplevel = Disp.empty +dispQualifier (QualSetup pn) = disp pn <<>> Disp.text ":setup." +dispQualifier (QualExe pn pn2) = disp pn <<>> Disp.text ":" <<>> + disp pn2 <<>> Disp.text ":exe." +dispQualifier (QualBase pn) = disp pn <<>> Disp.text "." -- | A qualified entity. Pairs a package path with the entity. data Qualified a = Q PackagePath a deriving (Eq, Ord, Show) --- | Standard string representation of a qualified entity. -showQ :: (a -> String) -> (Qualified a -> String) -showQ showa (Q pp x) = showPP pp ++ showa x - -- | Qualified package name. type QPN = Qualified PackageName --- | String representation of a qualified package path. +-- | Pretty-prints a qualified package name. +dispQPN :: QPN -> Disp.Doc +dispQPN (Q (PackagePath ns qual) pn) = + dispNamespace ns <<>> dispQualifier qual <<>> disp pn + +-- | String representation of a qualified package name. showQPN :: QPN -> String -showQPN = showQ display +showQPN = Disp.renderStyle flatStyle . dispQPN 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 @@ -21,7 +21,7 @@ ) where import Prelude () -import Distribution.Client.Compat.Prelude +import Distribution.Solver.Compat.Prelude import Control.Exception (IOException, handle) import qualified Data.Map as M diff --git a/cabal/cabal-install/Distribution/Solver/Types/Progress.hs b/cabal/cabal-install/Distribution/Solver/Types/Progress.hs --- a/cabal/cabal-install/Distribution/Solver/Types/Progress.hs +++ b/cabal/cabal-install/Distribution/Solver/Types/Progress.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE DeriveFunctor #-} module Distribution.Solver.Types.Progress ( Progress(..) , foldProgress ) where import Prelude () -import Distribution.Client.Compat.Prelude hiding (fail) +import Distribution.Solver.Compat.Prelude hiding (fail) -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final @@ -14,7 +13,14 @@ data Progress step fail done = Step step (Progress step fail done) | Fail fail | Done done - deriving (Functor) + +-- This Functor instance works around a bug in GHC 7.6.3. +-- See https://ghc.haskell.org/trac/ghc/ticket/7436#comment:6. +-- The derived functor instance caused a space leak in the solver. +instance Functor (Progress step fail) where + fmap f (Step s p) = Step s (fmap f p) + fmap _ (Fail x) = Fail x + fmap f (Done r) = Done (f r) -- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two -- base cases, one for a final result and one for failure. diff --git a/cabal/cabal-install/Distribution/Solver/Types/Settings.hs b/cabal/cabal-install/Distribution/Solver/Types/Settings.hs --- a/cabal/cabal-install/Distribution/Solver/Types/Settings.hs +++ b/cabal/cabal-install/Distribution/Solver/Types/Settings.hs @@ -6,6 +6,7 @@ , AvoidReinstalls(..) , ShadowPkgs(..) , StrongFlags(..) + , AllowBootLibInstalls(..) , EnableBackjumping(..) , CountConflicts(..) , SolveExecutables(..) @@ -33,6 +34,9 @@ newtype StrongFlags = StrongFlags Bool deriving (BooleanFlag, Eq, Generic, Show) +newtype AllowBootLibInstalls = AllowBootLibInstalls Bool + deriving (BooleanFlag, Eq, Generic, Show) + newtype EnableBackjumping = EnableBackjumping Bool deriving (BooleanFlag, Eq, Generic, Show) @@ -45,4 +49,5 @@ instance Binary AvoidReinstalls instance Binary ShadowPkgs instance Binary StrongFlags +instance Binary AllowBootLibInstalls instance Binary SolveExecutables diff --git a/cabal/cabal-install/Distribution/Solver/Types/Variable.hs b/cabal/cabal-install/Distribution/Solver/Types/Variable.hs --- a/cabal/cabal-install/Distribution/Solver/Types/Variable.hs +++ b/cabal/cabal-install/Distribution/Solver/Types/Variable.hs @@ -11,4 +11,4 @@ PackageVar qpn | FlagVar qpn FlagName | StanzaVar qpn OptionalStanza - deriving Eq + deriving (Eq, Show) diff --git a/cabal/cabal-install/LICENSE b/cabal/cabal-install/LICENSE --- a/cabal/cabal-install/LICENSE +++ b/cabal/cabal-install/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2016, Cabal Development Team. +Copyright (c) 2003-2017, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. All rights reserved. diff --git a/cabal/cabal-install/Main.hs b/cabal/cabal-install/Main.hs deleted file mode 100644 --- a/cabal/cabal-install/Main.hs +++ /dev/null @@ -1,1149 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Main --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- Entry point to the default cabal-install front-end. ------------------------------------------------------------------------------ - -module Main (main) where - -import Distribution.Client.Setup - ( GlobalFlags(..), globalCommand, withRepoContext - , ConfigFlags(..) - , ConfigExFlags(..), defaultConfigExFlags, configureExCommand - , reconfigureCommand - , configCompilerAux', configPackageDB' - , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) - , buildCommand, replCommand, testCommand, benchmarkCommand - , InstallFlags(..), defaultInstallFlags - , installCommand, upgradeCommand, uninstallCommand - , FetchFlags(..), fetchCommand - , FreezeFlags(..), freezeCommand - , genBoundsCommand - , GetFlags(..), getCommand, unpackCommand - , checkCommand - , formatCommand - , updateCommand - , ListFlags(..), listCommand - , InfoFlags(..), infoCommand - , UploadFlags(..), uploadCommand - , ReportFlags(..), reportCommand - , runCommand - , InitFlags(initVerbosity), initCommand - , SDistFlags(..), SDistExFlags(..), sdistCommand - , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand - , ActAsSetupFlags(..), actAsSetupCommand - , SandboxFlags(..), sandboxCommand - , ExecFlags(..), execCommand - , UserConfigFlags(..), userConfigCommand - , reportCommand - , manpageCommand - ) -import Distribution.Simple.Setup - ( HaddockTarget(..) - , HaddockFlags(..), haddockCommand, defaultHaddockFlags - , HscolourFlags(..), hscolourCommand - , ReplFlags(..) - , CopyFlags(..), copyCommand - , RegisterFlags(..), registerCommand - , CleanFlags(..), cleanCommand - , TestFlags(..), BenchmarkFlags(..) - , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag - , configAbsolutePaths - ) - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (get) - -import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) -import Distribution.Client.Config - ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff - , userConfigUpdate, createDefaultConfigFile, getConfigFilePath ) -import Distribution.Client.Targets - ( readUserTargets ) -import qualified Distribution.Client.List as List - ( list, info ) - -import qualified Distribution.Client.CmdConfigure as CmdConfigure -import qualified Distribution.Client.CmdBuild as CmdBuild -import qualified Distribution.Client.CmdRepl as CmdRepl -import qualified Distribution.Client.CmdFreeze as CmdFreeze -import qualified Distribution.Client.CmdHaddock as CmdHaddock - -import Distribution.Client.Install (install) -import Distribution.Client.Configure (configure, writeConfigFlags) -import Distribution.Client.Update (update) -import Distribution.Client.Exec (exec) -import Distribution.Client.Fetch (fetch) -import Distribution.Client.Freeze (freeze) -import Distribution.Client.GenBounds (genBounds) -import Distribution.Client.Check as Check (check) ---import Distribution.Client.Clean (clean) -import qualified Distribution.Client.Upload as Upload -import Distribution.Client.Run (run, splitRunArgs) -import Distribution.Client.SrcDist (sdist) -import Distribution.Client.Get (get) -import Distribution.Client.Reconfigure (Check(..), reconfigure) -import Distribution.Client.Sandbox (sandboxInit - ,sandboxAddSource - ,sandboxDelete - ,sandboxDeleteSource - ,sandboxListSources - ,sandboxHcPkg - ,dumpPackageEnvironment - - ,loadConfigOrSandboxConfig - ,findSavedDistPref - ,initPackageDBIfNeeded - ,maybeWithSandboxDirOnSearchPath - ,maybeWithSandboxPackageInfo - ,tryGetIndexFilePath - ,sandboxBuildDir - ,updateSandboxConfigFileFlag - ,updateInstallDirs - - ,getPersistOrConfigCompiler) -import Distribution.Client.Sandbox.PackageEnvironment (setPackageDB) -import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord) -import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox) -import Distribution.Client.Tar (createTarGzFile) -import Distribution.Client.Types (Password (..)) -import Distribution.Client.Init (initCabal) -import Distribution.Client.Manpage (manpage) -import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade -import Distribution.Client.Utils (determineNumJobs -#if defined(mingw32_HOST_OS) - ,relaxEncodingErrors -#endif - ) - -import Distribution.Package (packageId) -import Distribution.PackageDescription - ( BuildType(..), Executable(..), buildable ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.PackageDescription.PrettyPrint - ( writeGenericPackageDescription ) -import qualified Distribution.Simple as Simple -import qualified Distribution.Make as Make -import Distribution.Simple.Build - ( startInterpreter ) -import Distribution.Simple.Command - ( CommandParse(..), CommandUI(..), Command, CommandSpec(..) - , CommandType(..), commandsRun, commandAddAction, hiddenCommand - , commandFromSpec, commandShowOptions ) -import Distribution.Simple.Compiler (Compiler(..), PackageDBStack) -import Distribution.Simple.Configure - ( configCompilerAuxEx, ConfigStateFileError(..) - , getPersistBuildConfig, interpretPackageDbFlags - , tryGetPersistBuildConfig ) -import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.Program (defaultProgramDb - ,configureAllKnownPrograms - ,simpleProgramInvocation - ,getProgramInvocationOutput) -import Distribution.Simple.Program.Db (reconfigurePrograms) -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Utils - ( cabalVersion, die, info, notice, topHandler - , findPackageDesc, tryFindPackageDesc ) -import Distribution.Text - ( display ) -import Distribution.Verbosity as Verbosity - ( Verbosity, normal ) -import Distribution.Version - ( Version, mkVersion, orLaterVersion ) -import qualified Paths_cabal_install (version) - -import System.Environment (getArgs, getProgName) -import System.Exit (exitFailure, exitSuccess) -import System.FilePath ( dropExtension, splitExtension - , takeExtension, (), (<.>)) -import System.IO ( BufferMode(LineBuffering), hSetBuffering -#ifdef mingw32_HOST_OS - , stderr -#endif - , stdout ) -import System.Directory (doesFileExist, getCurrentDirectory) -import Data.Monoid (Any(..)) -import Control.Exception (SomeException(..), try) -import Control.Monad (mapM_) - --- | Entry point --- -main :: IO () -main = do - -- Enable line buffering so that we can get fast feedback even when piped. - -- This is especially important for CI and build systems. - hSetBuffering stdout LineBuffering - -- The default locale encoding for Windows CLI is not UTF-8 and printing - -- Unicode characters to it will fail unless we relax the handling of encoding - -- errors when writing to stderr and stdout. -#ifdef mingw32_HOST_OS - relaxEncodingErrors stdout - relaxEncodingErrors stderr -#endif - getArgs >>= mainWorker - -mainWorker :: [String] -> IO () -mainWorker args = topHandler $ - case commandsRun (globalCommand commands) commands args of - CommandHelp help -> printGlobalHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (globalFlags, commandParse) -> - case commandParse of - _ | fromFlagOrDefault False (globalVersion globalFlags) - -> printVersion - | fromFlagOrDefault False (globalNumericVersion globalFlags) - -> printNumericVersion - CommandHelp help -> printCommandHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> do - globalFlags' <- updateSandboxConfigFileFlag globalFlags - action globalFlags' - - where - printCommandHelp help = do - pname <- getProgName - putStr (help pname) - printGlobalHelp help = do - pname <- getProgName - configFile <- defaultConfigFile - putStr (help pname) - putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" - ++ " " ++ configFile ++ "\n" - exists <- doesFileExist configFile - when (not exists) $ - putStrLn $ "This file will be generated with sensible " - ++ "defaults if you run 'cabal update'." - printOptionsList = putStr . unlines - printErrors errs = die $ intercalate "\n" errs - printNumericVersion = putStrLn $ display Paths_cabal_install.version - printVersion = putStrLn $ "cabal-install version " - ++ display Paths_cabal_install.version - ++ "\ncompiled using version " - ++ display cabalVersion - ++ " of the Cabal library " - - commands = map commandFromSpec commandSpecs - commandSpecs = - [ regularCmd installCommand installAction - , regularCmd updateCommand updateAction - , regularCmd listCommand listAction - , regularCmd infoCommand infoAction - , regularCmd fetchCommand fetchAction - , regularCmd freezeCommand freezeAction - , regularCmd getCommand getAction - , hiddenCmd unpackCommand unpackAction - , regularCmd checkCommand checkAction - , regularCmd sdistCommand sdistAction - , regularCmd uploadCommand uploadAction - , regularCmd reportCommand reportAction - , regularCmd runCommand runAction - , regularCmd initCommand initAction - , regularCmd configureExCommand configureAction - , regularCmd reconfigureCommand reconfigureAction - , regularCmd buildCommand buildAction - , regularCmd replCommand replAction - , regularCmd sandboxCommand sandboxAction - , regularCmd haddockCommand haddockAction - , regularCmd execCommand execAction - , regularCmd userConfigCommand userConfigAction - , regularCmd cleanCommand cleanAction - , regularCmd genBoundsCommand genBoundsAction - , wrapperCmd copyCommand copyVerbosity copyDistPref - , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref - , wrapperCmd registerCommand regVerbosity regDistPref - , regularCmd testCommand testAction - , regularCmd benchmarkCommand benchmarkAction - , hiddenCmd uninstallCommand uninstallAction - , hiddenCmd formatCommand formatAction - , hiddenCmd upgradeCommand upgradeAction - , hiddenCmd win32SelfUpgradeCommand win32SelfUpgradeAction - , hiddenCmd actAsSetupCommand actAsSetupAction - , hiddenCmd manpageCommand (manpageAction commandSpecs) - - , regularCmd CmdConfigure.configureCommand CmdConfigure.configureAction - , regularCmd CmdBuild.buildCommand CmdBuild.buildAction - , regularCmd CmdRepl.replCommand CmdRepl.replAction - , regularCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction - , regularCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction - ] - -type Action = GlobalFlags -> IO () - -regularCmd :: CommandUI flags -> (flags -> [String] -> action) - -> CommandSpec action -regularCmd ui action = - CommandSpec ui ((flip commandAddAction) action) NormalCommand - -hiddenCmd :: CommandUI flags -> (flags -> [String] -> action) - -> CommandSpec action -hiddenCmd ui action = - CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action)) - HiddenCommand - -wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) - -> (flags -> Flag String) -> CommandSpec Action -wrapperCmd ui verbosity distPref = - CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand - -wrapperAction :: Monoid flags - => CommandUI flags - -> (flags -> Flag Verbosity) - -> (flags -> Flag String) - -> Command Action -wrapperAction command verbosityFlag distPrefFlag = - commandAddAction command - { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do - let verbosity = fromFlagOrDefault normal (verbosityFlag flags) - load <- try (loadConfigOrSandboxConfig verbosity globalFlags) - let config = either (\(SomeException _) -> mempty) snd load - distPref <- findSavedDistPref config (distPrefFlag flags) - let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } - setupWrapper verbosity setupScriptOptions Nothing - command (const flags) extraArgs - -configureAction :: (ConfigFlags, ConfigExFlags) - -> [String] -> Action -configureAction (configFlags, configExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - - (useSandbox, config) <- fmap - (updateInstallDirs (configUserInstall configFlags)) - (loadConfigOrSandboxConfig verbosity globalFlags) - distPref <- findSavedDistPref config (configDistPref configFlags) - let configFlags' = savedConfigureFlags config `mappend` configFlags - configExFlags' = savedConfigureExFlags config `mappend` configExFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAuxEx configFlags' - - -- If we're working inside a sandbox and the user has set the -w option, we - -- may need to create a sandbox-local package DB for this compiler and add a - -- timestamp record for this compiler to the timestamp file. - let configFlags'' = case useSandbox of - NoSandbox -> configFlags' - (UseSandbox sandboxDir) -> setPackageDB sandboxDir - comp platform configFlags' - - writeConfigFlags verbosity distPref (configFlags'', configExFlags') - - -- What package database(s) to use - let packageDBs :: PackageDBStack - packageDBs - = interpretPackageDbFlags - (fromFlag (configUserInstall configFlags'')) - (configPackageDBs configFlags'') - - whenUsingSandbox useSandbox $ \sandboxDir -> do - initPackageDBIfNeeded verbosity configFlags'' comp progdb - -- NOTE: We do not write the new sandbox package DB location to - -- 'cabal.sandbox.config' here because 'configure -w' must not affect - -- subsequent 'install' (for UI compatibility with non-sandboxed mode). - - indexFile <- tryGetIndexFilePath config - maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile - (compilerId comp) platform - - maybeWithSandboxDirOnSearchPath useSandbox $ - withRepoContext verbosity globalFlags' $ \repoContext -> - configure verbosity packageDBs repoContext - comp platform progdb configFlags'' configExFlags' extraArgs - -reconfigureAction :: (ConfigFlags, ConfigExFlags) - -> [String] -> Action -reconfigureAction flags _ globalFlags = do - let (configFlags, _) = flags - verbosity = fromFlag (configVerbosity configFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - dist <- findSavedDistPref config (configDistPref configFlags) - let checkFlags = Check $ \_ saved -> do - let flags' = saved <> flags - unless (saved == flags') $ info verbosity message - pure (Any True, flags') - where - -- This message is correct, but not very specific: it will list all - -- of the new flags, even if some have not actually changed. The - -- *minimal* set of changes is more difficult to determine. - message = - "flags changed: " - ++ unwords (commandShowOptions configureExCommand flags) - _ <- - reconfigure configureAction - verbosity dist useSandbox DontSkipAddSourceDepsCheck NoFlag - checkFlags [] globalFlags config - pure () - -buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action -buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) - noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (buildDistPref buildFlags) - - -- Calls 'configureAction' to do the real work, so nothing special has to be - -- done to support sandboxes. - config' <- - reconfigure configureAction - verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags) - mempty [] globalFlags config - - - maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config' distPref buildFlags extraArgs - - --- | Actually do the work of building the package. This is separate from --- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke --- 'reconfigure' twice. -build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO () -build verbosity config distPref buildFlags extraArgs = - setupWrapper verbosity setupOptions Nothing - (Cabal.buildCommand progDb) mkBuildFlags extraArgs - where - progDb = defaultProgramDb - setupOptions = defaultSetupScriptOptions { useDistPref = distPref } - - mkBuildFlags version = filterBuildFlags version config buildFlags' - buildFlags' = buildFlags - { buildVerbosity = toFlag verbosity - , buildDistPref = toFlag distPref - } - --- | Make sure that we don't pass new flags to setup scripts compiled against --- old versions of Cabal. -filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags -filterBuildFlags version config buildFlags - | version >= mkVersion [1,19,1] = buildFlags_latest - -- Cabal < 1.19.1 doesn't support 'build -j'. - | otherwise = buildFlags_pre_1_19_1 - where - buildFlags_pre_1_19_1 = buildFlags { - buildNumJobs = NoFlag - } - buildFlags_latest = buildFlags { - -- Take the 'jobs' setting '~/.cabal/config' into account. - buildNumJobs = Flag . Just . determineNumJobs $ - (numJobsConfigFlag `mappend` numJobsCmdLineFlag) - } - numJobsConfigFlag = installNumJobs . savedInstallFlags $ config - numJobsCmdLineFlag = buildNumJobs buildFlags - - -replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action -replAction (replFlags, buildExFlags) extraArgs globalFlags = do - cwd <- getCurrentDirectory - pkgDesc <- findPackageDesc cwd - either (const onNoPkgDesc) (const onPkgDesc) pkgDesc - where - verbosity = fromFlagOrDefault normal (replVerbosity replFlags) - - -- There is a .cabal file in the current directory: start a REPL and load - -- the project's modules. - onPkgDesc = do - let noAddSource = case replReload replFlags of - Flag True -> SkipAddSourceDepsCheck - _ -> fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (replDistPref replFlags) - - -- Calls 'configureAction' to do the real work, so nothing special has to - -- be done to support sandboxes. - _ <- - reconfigure configureAction - verbosity distPref useSandbox noAddSource NoFlag - mempty [] globalFlags config - let progDb = defaultProgramDb - setupOptions = defaultSetupScriptOptions - { useCabalVersion = orLaterVersion $ mkVersion [1,18,0] - , useDistPref = distPref - } - replFlags' = replFlags - { replVerbosity = toFlag verbosity - , replDistPref = toFlag distPref - } - - maybeWithSandboxDirOnSearchPath useSandbox $ - setupWrapper verbosity setupOptions Nothing - (Cabal.replCommand progDb) (const replFlags') extraArgs - - -- No .cabal file in the current directory: just start the REPL (possibly - -- using the sandbox package DB). - onNoPkgDesc = do - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - let configFlags = savedConfigureFlags config - (comp, platform, programDb) <- configCompilerAux' configFlags - programDb' <- reconfigurePrograms verbosity - (replProgramPaths replFlags) - (replProgramArgs replFlags) - programDb - startInterpreter verbosity programDb' comp platform - (configPackageDB' configFlags) - -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) - -> [String] -> Action -installAction (configFlags, _, installFlags, _) _ globalFlags - | fromFlagOrDefault False (installOnly installFlags) = do - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - load <- try (loadConfigOrSandboxConfig verbosity globalFlags) - let config = either (\(SomeException _) -> mempty) snd load - distPref <- findSavedDistPref config (configDistPref configFlags) - let setupOpts = defaultSetupScriptOptions { useDistPref = distPref } - setupWrapper verbosity setupOpts Nothing installCommand (const mempty) [] - -installAction (configFlags, configExFlags, installFlags, haddockFlags) - extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - (useSandbox, config) <- fmap - (updateInstallDirs (configUserInstall configFlags)) - (loadConfigOrSandboxConfig verbosity globalFlags) - targets <- readUserTargets verbosity extraArgs - - -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to - -- 'configure' when run inside a sandbox. Right now, running - -- - -- $ cabal sandbox init && cabal configure -w /path/to/ghc - -- && cabal build && cabal install - -- - -- performs the compilation twice unless you also pass -w to 'install'. - -- However, this is the same behaviour that 'cabal install' has in the normal - -- mode of operation, so we stick to it for consistency. - - let sandboxDistPref = case useSandbox of - NoSandbox -> NoFlag - UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir - distPref <- findSavedDistPref config - (configDistPref configFlags `mappend` sandboxDistPref) - - let configFlags' = maybeForceTests installFlags' $ - savedConfigureFlags config `mappend` - configFlags { configDistPref = toFlag distPref } - configExFlags' = defaultConfigExFlags `mappend` - savedConfigureExFlags config `mappend` configExFlags - installFlags' = defaultInstallFlags `mappend` - savedInstallFlags config `mappend` installFlags - haddockFlags' = defaultHaddockFlags `mappend` - savedHaddockFlags config `mappend` - haddockFlags { haddockDistPref = toFlag distPref } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAux' configFlags' - -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the - -- future. - progdb' <- configureAllKnownPrograms verbosity progdb - - -- If we're working inside a sandbox and the user has set the -w option, we - -- may need to create a sandbox-local package DB for this compiler and add a - -- timestamp record for this compiler to the timestamp file. - configFlags'' <- case useSandbox of - NoSandbox -> configAbsolutePaths $ configFlags' - (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform - configFlags' - - whenUsingSandbox useSandbox $ \sandboxDir -> do - initPackageDBIfNeeded verbosity configFlags'' comp progdb' - - indexFile <- tryGetIndexFilePath config - maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile - (compilerId comp) platform - - -- TODO: Passing 'SandboxPackageInfo' to install unconditionally here means - -- that 'cabal install some-package' inside a sandbox will sometimes reinstall - -- modified add-source deps, even if they are not among the dependencies of - -- 'some-package'. This can also prevent packages that depend on older - -- versions of add-source'd packages from building (see #1362). - maybeWithSandboxPackageInfo verbosity configFlags'' globalFlags' - comp platform progdb useSandbox $ \mSandboxPkgInfo -> - maybeWithSandboxDirOnSearchPath useSandbox $ - withRepoContext verbosity globalFlags' $ \repoContext -> - install verbosity - (configPackageDB' configFlags'') - repoContext - comp platform progdb' - useSandbox mSandboxPkgInfo - globalFlags' configFlags'' configExFlags' - installFlags' haddockFlags' - targets - - where - -- '--run-tests' implies '--enable-tests'. - maybeForceTests installFlags' configFlags' = - if fromFlagOrDefault False (installRunTests installFlags') - then configFlags' { configTests = toFlag True } - else configFlags' - -testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags - -> IO () -testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (testVerbosity testFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (testDistPref testFlags) - let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - buildFlags' = buildFlags - { buildVerbosity = testVerbosity testFlags } - checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> - if fromFlagOrDefault False (configTests configFlags) - then pure (mempty, flags) - else do - info verbosity "reconfiguring to enable tests" - let flags' = ( configFlags { configTests = toFlag True } - , configExFlags - ) - pure (Any True, flags') - - -- reconfigure also checks if we're in a sandbox and reinstalls add-source - -- deps if needed. - _ <- - reconfigure configureAction - verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags') - checkFlags [] globalFlags config - - let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } - testFlags' = testFlags { testDistPref = toFlag distPref } - - -- The package was just configured, so the LBI must be available. - names <- componentNamesFromLBI verbosity distPref "test suites" - (\c -> case c of { LBI.CTest{} -> True; _ -> False }) - let extraArgs' - | null extraArgs = case names of - ComponentNamesUnknown -> [] - ComponentNames names' -> [ Make.unUnqualComponentName name - | LBI.CTestName name <- names' ] - | otherwise = extraArgs - - maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config distPref buildFlags' extraArgs' - - maybeWithSandboxDirOnSearchPath useSandbox $ - setupWrapper verbosity setupOptions Nothing - Cabal.testCommand (const testFlags') extraArgs' - -data ComponentNames = ComponentNamesUnknown - | ComponentNames [LBI.ComponentName] - --- | Return the names of all buildable components matching a given predicate. -componentNamesFromLBI :: Verbosity -> FilePath -> String - -> (LBI.Component -> Bool) - -> IO ComponentNames -componentNamesFromLBI verbosity distPref targetsDescr compPred = do - eLBI <- tryGetPersistBuildConfig distPref - case eLBI of - Left err -> case err of - -- Note: the build config could have been generated by a custom setup - -- script built against a different Cabal version, so it's crucial that - -- we ignore the bad version error here. - ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown - _ -> die (show err) - Right lbi -> do - let pkgDescr = LBI.localPkgDescr lbi - names = map LBI.componentName - . filter (buildable . LBI.componentBuildInfo) - . filter compPred $ - LBI.pkgComponents pkgDescr - if null names - then do notice verbosity $ "Package has no buildable " - ++ targetsDescr ++ "." - exitSuccess -- See #3215. - - else return $! (ComponentNames names) - -benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags) - -> [String] -> GlobalFlags - -> IO () -benchmarkAction (benchmarkFlags, buildFlags, buildExFlags) - extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal - (benchmarkVerbosity benchmarkFlags) - - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags) - - let buildFlags' = buildFlags - { buildVerbosity = benchmarkVerbosity benchmarkFlags } - noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - - let checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> - if fromFlagOrDefault False (configBenchmarks configFlags) - then pure (mempty, flags) - else do - info verbosity "reconfiguring to enable benchmarks" - let flags' = ( configFlags { configBenchmarks = toFlag True } - , configExFlags - ) - pure (Any True, flags') - - - -- reconfigure also checks if we're in a sandbox and reinstalls add-source - -- deps if needed. - config' <- - reconfigure configureAction - verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags') - checkFlags [] globalFlags config - - let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } - benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref } - - -- The package was just configured, so the LBI must be available. - names <- componentNamesFromLBI verbosity distPref "benchmarks" - (\c -> case c of { LBI.CBench{} -> True; _ -> False; }) - let extraArgs' - | null extraArgs = case names of - ComponentNamesUnknown -> [] - ComponentNames names' -> [ Make.unUnqualComponentName name - | LBI.CBenchName name <- names'] - | otherwise = extraArgs - - maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config' distPref buildFlags' extraArgs' - - maybeWithSandboxDirOnSearchPath useSandbox $ - setupWrapper verbosity setupOptions Nothing - Cabal.benchmarkCommand (const benchmarkFlags') extraArgs' - -haddockAction :: HaddockFlags -> [String] -> Action -haddockAction haddockFlags extraArgs globalFlags = do - let verbosity = fromFlag (haddockVerbosity haddockFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (haddockDistPref haddockFlags) - config' <- - reconfigure configureAction - verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag - mempty [] globalFlags config - let haddockFlags' = defaultHaddockFlags `mappend` - savedHaddockFlags config' `mappend` - haddockFlags { haddockDistPref = toFlag distPref } - setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } - setupWrapper verbosity setupScriptOptions Nothing - haddockCommand (const haddockFlags') extraArgs - when (haddockForHackage haddockFlags == Flag ForHackage) $ do - pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) - let dest = distPref name <.> "tar.gz" - name = display (packageId pkg) ++ "-docs" - docDir = distPref "doc" "html" - createTarGzFile dest docDir name - notice verbosity $ "Documentation tarball created: " ++ dest - -cleanAction :: CleanFlags -> [String] -> Action -cleanAction cleanFlags extraArgs globalFlags = do - load <- try (loadConfigOrSandboxConfig verbosity globalFlags) - let config = either (\(SomeException _) -> mempty) snd load - distPref <- findSavedDistPref config (cleanDistPref cleanFlags) - let setupScriptOptions = defaultSetupScriptOptions - { useDistPref = distPref - , useWin32CleanHack = True - } - cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref } - setupWrapper verbosity setupScriptOptions Nothing - cleanCommand (const cleanFlags') extraArgs - where - verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) - -listAction :: ListFlags -> [String] -> Action -listAction listFlags extraArgs globalFlags = do - let verbosity = fromFlag (listVerbosity listFlags) - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let configFlags' = savedConfigureFlags config - configFlags = configFlags' { - configPackageDBs = configPackageDBs configFlags' - `mappend` listPackageDBs listFlags - } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, _, progdb) <- configCompilerAux' configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - List.list verbosity - (configPackageDB' configFlags) - repoContext - comp - progdb - listFlags - extraArgs - -infoAction :: InfoFlags -> [String] -> Action -infoAction infoFlags extraArgs globalFlags = do - let verbosity = fromFlag (infoVerbosity infoFlags) - targets <- readUserTargets verbosity extraArgs - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let configFlags' = savedConfigureFlags config - configFlags = configFlags' { - configPackageDBs = configPackageDBs configFlags' - `mappend` infoPackageDBs infoFlags - } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, _, progdb) <- configCompilerAuxEx configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - List.info verbosity - (configPackageDB' configFlags) - repoContext - comp - progdb - globalFlags' - infoFlags - targets - -updateAction :: Flag Verbosity -> [String] -> Action -updateAction verbosityFlag extraArgs globalFlags = do - unless (null extraArgs) $ - die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs - let verbosity = fromFlag verbosityFlag - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - update verbosity repoContext - -upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) - -> [String] -> Action -upgradeAction _ _ _ = die $ - "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 " - ++ "confusing and it often led to broken packages.\n" - ++ "If you want the old upgrade behaviour then use the install command " - ++ "with the --upgrade-dependencies flag (but check first with --dry-run " - ++ "to see what would happen). This will try to pick the latest versions " - ++ "of all dependencies, rather than the usual behaviour of trying to pick " - ++ "installed versions of all dependencies. If you do use " - ++ "--upgrade-dependencies, it is recommended that you do not upgrade core " - ++ "packages (e.g. by using appropriate --constraint= flags)." - -fetchAction :: FetchFlags -> [String] -> Action -fetchAction fetchFlags extraArgs globalFlags = do - let verbosity = fromFlag (fetchVerbosity fetchFlags) - targets <- readUserTargets verbosity extraArgs - config <- loadConfig verbosity (globalConfigFile globalFlags) - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAux' configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - fetch verbosity - (configPackageDB' configFlags) - repoContext - comp platform progdb globalFlags' fetchFlags - targets - -freezeAction :: FreezeFlags -> [String] -> Action -freezeAction freezeFlags _extraArgs globalFlags = do - let verbosity = fromFlag (freezeVerbosity freezeFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAux' configFlags - - maybeWithSandboxPackageInfo verbosity configFlags globalFlags' - comp platform progdb useSandbox $ \mSandboxPkgInfo -> - maybeWithSandboxDirOnSearchPath useSandbox $ - withRepoContext verbosity globalFlags' $ \repoContext -> - freeze verbosity - (configPackageDB' configFlags) - repoContext - comp platform progdb - mSandboxPkgInfo - globalFlags' freezeFlags - -genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () -genBoundsAction freezeFlags _extraArgs globalFlags = do - let verbosity = fromFlag (freezeVerbosity freezeFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAux' configFlags - - maybeWithSandboxPackageInfo verbosity configFlags globalFlags' - comp platform progdb useSandbox $ \mSandboxPkgInfo -> - maybeWithSandboxDirOnSearchPath useSandbox $ - withRepoContext verbosity globalFlags' $ \repoContext -> - genBounds verbosity - (configPackageDB' configFlags) - repoContext - comp platform progdb - mSandboxPkgInfo - globalFlags' freezeFlags - -uploadAction :: UploadFlags -> [String] -> Action -uploadAction uploadFlags extraArgs globalFlags = do - config <- loadConfig verbosity (globalConfigFile globalFlags) - let uploadFlags' = savedUploadFlags config `mappend` uploadFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags - tarfiles = extraArgs - when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $ - die "the 'upload' command expects at least one .tar.gz archive." - checkTarFiles extraArgs - maybe_password <- - case uploadPasswordCmd uploadFlags' - of Flag (xs:xss) -> Just . Password <$> - getProgramInvocationOutput verbosity - (simpleProgramInvocation xs xss) - _ -> pure $ flagToMaybe $ uploadPassword uploadFlags' - withRepoContext verbosity globalFlags' $ \repoContext -> do - if fromFlag (uploadDoc uploadFlags') - then do - when (length tarfiles > 1) $ - die $ "the 'upload' command can only upload documentation " - ++ "for one package at a time." - tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles - Upload.uploadDoc verbosity - repoContext - (flagToMaybe $ uploadUsername uploadFlags') - maybe_password - (fromFlag (uploadCandidate uploadFlags')) - tarfile - else do - Upload.upload verbosity - repoContext - (flagToMaybe $ uploadUsername uploadFlags') - maybe_password - (fromFlag (uploadCandidate uploadFlags')) - tarfiles - where - verbosity = fromFlag (uploadVerbosity uploadFlags) - checkTarFiles tarfiles - | not (null otherFiles) - = die $ "the 'upload' command expects only .tar.gz archives: " - ++ intercalate ", " otherFiles - | otherwise = sequence_ - [ do exists <- doesFileExist tarfile - unless exists $ die $ "file not found: " ++ tarfile - | tarfile <- tarfiles ] - - where otherFiles = filter (not . isTarGzFile) tarfiles - isTarGzFile file = case splitExtension file of - (file', ".gz") -> takeExtension file' == ".tar" - _ -> False - generateDocTarball config = do - notice verbosity $ - "No documentation tarball specified. " - ++ "Building a documentation tarball with default settings...\n" - ++ "If you need to customise Haddock options, " - ++ "run 'haddock --for-hackage' first " - ++ "to generate a documentation tarball." - haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage }) - [] globalFlags - distPref <- findSavedDistPref config NoFlag - pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) - return $ distPref display (packageId pkg) ++ "-docs" <.> "tar.gz" - -checkAction :: Flag Verbosity -> [String] -> Action -checkAction verbosityFlag extraArgs _globalFlags = do - unless (null extraArgs) $ - die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs - allOk <- Check.check (fromFlag verbosityFlag) - unless allOk exitFailure - -formatAction :: Flag Verbosity -> [String] -> Action -formatAction verbosityFlag extraArgs _globalFlags = do - let verbosity = fromFlag verbosityFlag - path <- case extraArgs of - [] -> do cwd <- getCurrentDirectory - tryFindPackageDesc cwd - (p:_) -> return p - pkgDesc <- readPackageDescription verbosity path - -- Uses 'writeFileAtomic' under the hood. - writeGenericPackageDescription path pkgDesc - -uninstallAction :: Flag Verbosity -> [String] -> Action -uninstallAction _verbosityFlag extraArgs _globalFlags = do - let package = case extraArgs of - p:_ -> p - _ -> "PACKAGE_NAME" - die $ "This version of 'cabal-install' does not support the 'uninstall' " - ++ "operation. " - ++ "It will likely be implemented at some point in the future; " - ++ "in the meantime you're advised to use either 'ghc-pkg unregister " - ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'." - - -sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action -sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do - unless (null extraArgs) $ - die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs - let verbosity = fromFlag (sDistVerbosity sdistFlags) - load <- try (loadConfigOrSandboxConfig verbosity globalFlags) - let config = either (\(SomeException _) -> mempty) snd load - distPref <- findSavedDistPref config (sDistDistPref sdistFlags) - let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref } - sdist sdistFlags' sdistExFlags - -reportAction :: ReportFlags -> [String] -> Action -reportAction reportFlags extraArgs globalFlags = do - unless (null extraArgs) $ - die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs - - let verbosity = fromFlag (reportVerbosity reportFlags) - config <- loadConfig verbosity (globalConfigFile globalFlags) - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - reportFlags' = savedReportFlags config `mappend` reportFlags - - withRepoContext verbosity globalFlags' $ \repoContext -> - Upload.report verbosity repoContext - (flagToMaybe $ reportUsername reportFlags') - (flagToMaybe $ reportPassword reportFlags') - -runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action -runAction (buildFlags, buildExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (buildDistPref buildFlags) - let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - - -- reconfigure also checks if we're in a sandbox and reinstalls add-source - -- deps if needed. - config' <- - reconfigure configureAction - verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags) - mempty [] globalFlags config - - lbi <- getPersistBuildConfig distPref - (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs - - maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)] - - maybeWithSandboxDirOnSearchPath useSandbox $ - run verbosity lbi exe exeArgs - -getAction :: GetFlags -> [String] -> Action -getAction getFlags extraArgs globalFlags = do - let verbosity = fromFlag (getVerbosity getFlags) - targets <- readUserTargets verbosity extraArgs - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - withRepoContext verbosity (savedGlobalFlags config) $ \repoContext -> - get verbosity - repoContext - globalFlags' - getFlags - targets - -unpackAction :: GetFlags -> [String] -> Action -unpackAction getFlags extraArgs globalFlags = do - getAction getFlags extraArgs globalFlags - -initAction :: InitFlags -> [String] -> Action -initAction initFlags extraArgs globalFlags = do - when (extraArgs /= []) $ - die $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs - let verbosity = fromFlag (initVerbosity initFlags) - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let configFlags = savedConfigureFlags config - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, _, progdb) <- configCompilerAux' configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - initCabal verbosity - (configPackageDB' configFlags) - repoContext - comp - progdb - initFlags - -sandboxAction :: SandboxFlags -> [String] -> Action -sandboxAction sandboxFlags extraArgs globalFlags = do - let verbosity = fromFlag (sandboxVerbosity sandboxFlags) - case extraArgs of - -- Basic sandbox commands. - ["init"] -> sandboxInit verbosity sandboxFlags globalFlags - ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags - ("add-source":extra) -> do - when (noExtraArgs extra) $ - die "The 'sandbox add-source' command expects at least one argument" - sandboxAddSource verbosity extra sandboxFlags globalFlags - ("delete-source":extra) -> do - when (noExtraArgs extra) $ - die ("The 'sandbox delete-source' command expects " ++ - "at least one argument") - sandboxDeleteSource verbosity extra sandboxFlags globalFlags - ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags - - -- More advanced commands. - ("hc-pkg":extra) -> do - when (noExtraArgs extra) $ - die $ "The 'sandbox hc-pkg' command expects at least one argument" - sandboxHcPkg verbosity sandboxFlags globalFlags extra - ["buildopts"] -> die "Not implemented!" - - -- Hidden commands. - ["dump-pkgenv"] -> dumpPackageEnvironment verbosity sandboxFlags globalFlags - - -- Error handling. - [] -> die $ "Please specify a subcommand (see 'help sandbox')" - _ -> die $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs - - where - noExtraArgs = (<1) . length - -execAction :: ExecFlags -> [String] -> Action -execAction execFlags extraArgs globalFlags = do - let verbosity = fromFlag (execVerbosity execFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - let configFlags = savedConfigureFlags config - (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags - exec verbosity useSandbox comp platform progdb extraArgs - -userConfigAction :: UserConfigFlags -> [String] -> Action -userConfigAction ucflags extraArgs globalFlags = do - let verbosity = fromFlag (userConfigVerbosity ucflags) - force = fromFlag (userConfigForce ucflags) - case extraArgs of - ("init":_) -> do - path <- configFile - fileExists <- doesFileExist path - if (not fileExists || (fileExists && force)) - then void $ createDefaultConfigFile verbosity path - else die $ path ++ " already exists." - ("diff":_) -> mapM_ putStrLn =<< userConfigDiff globalFlags - ("update":_) -> userConfigUpdate verbosity globalFlags - -- Error handling. - [] -> die $ "Please specify a subcommand (see 'help user-config')" - _ -> die $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs - where configFile = getConfigFilePath (globalConfigFile globalFlags) - --- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. --- -win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action -win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do - let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags) - Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path -- TODO: eradicateNoParse -win32SelfUpgradeAction _ _ _ = return () - --- | Used as an entry point when cabal-install needs to invoke itself --- as a setup script. This can happen e.g. when doing parallel builds. --- -actAsSetupAction :: ActAsSetupFlags -> [String] -> Action -actAsSetupAction actAsSetupFlags args _globalFlags = - let bt = fromFlag (actAsSetupBuildType actAsSetupFlags) - in case bt of - Simple -> Simple.defaultMainArgs args - Configure -> Simple.defaultMainWithHooksArgs - Simple.autoconfUserHooks args - Make -> Make.defaultMainArgs args - Custom -> error "actAsSetupAction Custom" - (UnknownBuildType _) -> error "actAsSetupAction UnknownBuildType" - -manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action -manpageAction commands _ extraArgs _ = do - unless (null extraArgs) $ - die $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs - pname <- getProgName - let cabalCmd = if takeExtension pname == ".exe" - then dropExtension pname - else pname - putStrLn $ manpage cabalCmd commands 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 @@ -69,12 +69,14 @@ If a C compiler is installed make sure it is on your PATH, or set $CC.' # Find the correct linker/linker-wrapper. +# +# See https://github.com/haskell/cabal/pull/4187#issuecomment-269074153. LINK="$(for link in collect2 ld; do if [ $($CC -print-prog-name=$link) = $link ] then continue else - $CC -print-prog-name=$link + $CC -print-prog-name=$link && break fi done)" @@ -164,9 +166,9 @@ esac done -# Do not try to use -j with GHC older than 7.8 +# Do not try to use -j with GHC 7.8 or older case $GHC_VER in - 7.4*|7.6*) + 7.4*|7.6*|7.8*) JOBS="" ;; *) @@ -225,29 +227,29 @@ esac -TEXT_VER="1.2.2.1"; TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))" +TEXT_VER="1.2.2.2"; TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))" # >= 0.2 && < 1.3 -NETWORK_VER="2.6.2.1"; NETWORK_VER_REGEXP="2\.[0-6]\." +NETWORK_VER="2.6.3.2"; NETWORK_VER_REGEXP="2\.[0-6]\." # >= 2.0 && < 2.7 NETWORK_URI_VER="2.6.1.0"; NETWORK_URI_VER_REGEXP="2\.6\." # >= 2.6 && < 2.7 -CABAL_VER="1.25.0.0"; CABAL_VER_REGEXP="1\.25\.[0-9]" - # >= 1.25 && < 1.26 -TRANS_VER="0.5.2.0"; TRANS_VER_REGEXP="0\.[45]\." +CABAL_VER="2.1.0.0"; CABAL_VER_REGEXP="2\.1\.[0-9]" + # >= 2.1 && < 2.2 +TRANS_VER="0.5.5.0"; TRANS_VER_REGEXP="0\.[45]\." # >= 0.2.* && < 0.6 MTL_VER="2.2.1"; MTL_VER_REGEXP="[2]\." # >= 2.0 && < 3 -HTTP_VER="4000.3.3"; HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)" +HTTP_VER="4000.3.8"; HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)" # >= 4000.2.5 < 4000.4 -ZLIB_VER="0.6.1.1"; ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)" +ZLIB_VER="0.6.1.2"; ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)" # >= 0.5.3 && <= 0.7 -TIME_VER="1.6" TIME_VER_REGEXP="1\.[1-6]\.?" - # >= 1.1 && < 1.7 +TIME_VER="1.8.0.3" TIME_VER_REGEXP="1\.[1-8]\.?" + # >= 1.1 && < 1.9 RANDOM_VER="1.1" RANDOM_VER_REGEXP="1\.[01]\.?" # >= 1 && < 1.2 STM_VER="2.4.4.1"; STM_VER_REGEXP="2\." # == 2.* -ASYNC_VER="2.1.0"; ASYNC_VER_REGEXP="2\." +ASYNC_VER="2.1.1.1"; ASYNC_VER_REGEXP="2\." # 2.* OLD_TIME_VER="1.1.0.3"; OLD_TIME_VER_REGEXP="1\.[01]\.?" # >=1.0.0.0 && <1.2 @@ -257,8 +259,14 @@ # 0.1.* BASE64_BYTESTRING_VER="1.0.0.1"; BASE64_BYTESTRING_VER_REGEXP="1\." # >=1.0 -CRYPTOHASH_SHA256_VER="0.11.7.1"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?" +CRYPTOHASH_SHA256_VER="0.11.101.0"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?" # 0.11.* +RESOLV_VER="0.1.1.1"; RESOLV_VER_REGEXP="0\.1\.[1-9]" + # >= 0.1.1 && < 0.2 +MINTTY_VER="0.1.1"; MINTTY_VER_REGEXP="0\.1\.?" + # 0.1.* +ECHO_VER="0.1.3"; ECHO_VER_REGEXP="0\.1\.[3-9]" + # >= 0.1.3 && < 0.2 EDIT_DISTANCE_VER="0.2.2.1"; EDIT_DISTANCE_VER_REGEXP="0\.2\.2\.?" # 0.2.2.* ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?" @@ -268,7 +276,7 @@ BYTESTRING_BUILDER_VER="0.10.8.1.0"; BYTESTRING_BUILDER_VER_REGEXP="0\.10\.?" TAR_VER="0.5.0.3"; TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.?" # >= 0.5.0.3 && < 0.6 -HASHABLE_VER="1.2.4.0"; HASHABLE_VER_REGEXP="1\." +HASHABLE_VER="1.2.6.1"; HASHABLE_VER_REGEXP="1\." # 1.* HACKAGE_URL="https://hackage.haskell.org/package" @@ -422,7 +430,7 @@ echo "Cabal-${CABAL_VER} will be installed from the local Git clone." (cd ../Cabal && install_pkg ${CABAL_VER} ${CABAL_VER_REGEXP}) else - echo "Cabal-${CABAL_VER} is already installed and the version is ok." + echo "Cabal is already installed and the version is ok." fi else info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} @@ -485,6 +493,9 @@ ${BASE64_BYTESTRING_VER_REGEXP} info_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \ ${CRYPTOHASH_SHA256_VER_REGEXP} +info_pkg "resolv" ${RESOLV_VER} ${RESOLV_VER_REGEXP} +info_pkg "mintty" ${MINTTY_VER} ${MINTTY_VER_REGEXP} +info_pkg "echo" ${ECHO_VER} ${ECHO_VER_REGEXP} info_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} info_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} info_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP} @@ -496,13 +507,15 @@ do_pkg "binary" ${BINARY_VER} ${BINARY_VER_REGEXP} do_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} -# Install the Cabal library from the local Git clone if possible. -do_Cabal_pkg - +# Cabal might depend on these do_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP} do_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} do_pkg "text" ${TEXT_VER} ${TEXT_VER_REGEXP} do_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} + +# Install the Cabal library from the local Git clone if possible. +do_Cabal_pkg + do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} # We conditionally install network-uri, depending on the network version. @@ -521,6 +534,9 @@ ${BASE64_BYTESTRING_VER_REGEXP} do_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \ ${CRYPTOHASH_SHA256_VER_REGEXP} +do_pkg "resolv" ${RESOLV_VER} ${RESOLV_VER_REGEXP} +do_pkg "mintty" ${MINTTY_VER} ${MINTTY_VER_REGEXP} +do_pkg "echo" ${ECHO_VER} ${ECHO_VER_REGEXP} do_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} do_pkg "ed25519" ${ED25519_VER} ${ED25519_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 @@ -1,17 +1,20 @@ Name: cabal-install -Version: 1.25.0.0 +Version: 2.1.0.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing Haskell software by automating the fetching, configuration, compilation and installation of Haskell libraries and programs. + . + This package only provides an executable and cannot be used as a + library (ignore the module listing below.) homepage: http://www.haskell.org/cabal/ bug-reports: https://github.com/haskell/cabal/issues License: BSD3 License-File: LICENSE Author: Cabal Development Team (see AUTHORS file) Maintainer: Cabal Development Team -Copyright: 2003-2016, Cabal Development Team +Copyright: 2003-2017, Cabal Development Team Category: Distribution Build-type: Custom Cabal-Version: >= 1.10 @@ -22,187 +25,6 @@ -- Generated with '../Cabal/misc/gen-extra-source-files.sh' -- Do NOT edit this section manually; instead, run the script. -- BEGIN gen-extra-source-files - tests/IntegrationTests/backpack/includes2-external.sh - tests/IntegrationTests/backpack/includes2-internal.sh - tests/IntegrationTests/backpack/includes2/Includes2.cabal - tests/IntegrationTests/backpack/includes2/exe/Main.hs - tests/IntegrationTests/backpack/includes2/exe/exe.cabal - tests/IntegrationTests/backpack/includes2/mylib/Mine.hs - tests/IntegrationTests/backpack/includes2/mylib/mylib.cabal - tests/IntegrationTests/backpack/includes2/mysql/Database/MySQL.hs - tests/IntegrationTests/backpack/includes2/mysql/mysql.cabal - tests/IntegrationTests/backpack/includes2/postgresql/Database/PostgreSQL.hs - tests/IntegrationTests/backpack/includes2/postgresql/postgresql.cabal - tests/IntegrationTests/backpack/includes2/src/App.hs - tests/IntegrationTests/backpack/includes2/src/src.cabal - tests/IntegrationTests/backpack/includes3-external.sh - tests/IntegrationTests/backpack/includes3-internal.sh - tests/IntegrationTests/backpack/includes3/Includes3.cabal - tests/IntegrationTests/backpack/includes3/exe/Main.hs - tests/IntegrationTests/backpack/includes3/exe/Setup.hs - tests/IntegrationTests/backpack/includes3/exe/exe.cabal - tests/IntegrationTests/backpack/includes3/indef/Foo.hs - tests/IntegrationTests/backpack/includes3/indef/Setup.hs - tests/IntegrationTests/backpack/includes3/indef/indef.cabal - tests/IntegrationTests/backpack/includes3/sigs/Setup.hs - tests/IntegrationTests/backpack/includes3/sigs/sigs.cabal - tests/IntegrationTests/common.sh - tests/IntegrationTests/custom-setup/Cabal-99998/Cabal.cabal - tests/IntegrationTests/custom-setup/Cabal-99998/CabalMessage.hs - tests/IntegrationTests/custom-setup/Cabal-99999/Cabal.cabal - tests/IntegrationTests/custom-setup/Cabal-99999/CabalMessage.hs - tests/IntegrationTests/custom-setup/custom-setup-old-cabal/Setup.hs - tests/IntegrationTests/custom-setup/custom-setup-old-cabal/custom-setup-old-cabal.cabal - tests/IntegrationTests/custom-setup/custom-setup-without-cabal-defaultMain/Setup.hs - tests/IntegrationTests/custom-setup/custom-setup-without-cabal-defaultMain/custom-setup-without-cabal-defaultMain.cabal - tests/IntegrationTests/custom-setup/custom-setup-without-cabal/Setup.hs - tests/IntegrationTests/custom-setup/custom-setup-without-cabal/custom-setup-without-cabal.cabal - tests/IntegrationTests/custom-setup/custom-setup/Setup.hs - tests/IntegrationTests/custom-setup/custom-setup/custom-setup.cabal - tests/IntegrationTests/custom-setup/custom_setup_without_Cabal_doesnt_allow_Cabal_import.sh - tests/IntegrationTests/custom-setup/custom_setup_without_Cabal_doesnt_require_Cabal.sh - tests/IntegrationTests/custom-setup/installs_Cabal_as_setup_dep.sh - tests/IntegrationTests/custom-setup/new_build_requires_Cabal_1_20.sh - tests/IntegrationTests/custom/custom_dep.sh - tests/IntegrationTests/custom/custom_dep/client/B.hs - tests/IntegrationTests/custom/custom_dep/client/Setup.hs - tests/IntegrationTests/custom/custom_dep/client/client.cabal - tests/IntegrationTests/custom/custom_dep/custom/A.hs - tests/IntegrationTests/custom/custom_dep/custom/Setup.hs - tests/IntegrationTests/custom/custom_dep/custom/custom.cabal - tests/IntegrationTests/custom/plain.sh - tests/IntegrationTests/custom/plain/A.hs - tests/IntegrationTests/custom/plain/Setup.hs - tests/IntegrationTests/custom/plain/plain.cabal - tests/IntegrationTests/custom/segfault.sh - tests/IntegrationTests/custom/segfault/Setup.hs - tests/IntegrationTests/custom/segfault/cabal.project - tests/IntegrationTests/custom/segfault/plain.cabal - tests/IntegrationTests/exec/Foo.hs - tests/IntegrationTests/exec/My.hs - tests/IntegrationTests/exec/adds_sandbox_bin_directory_to_path.out - tests/IntegrationTests/exec/adds_sandbox_bin_directory_to_path.sh - tests/IntegrationTests/exec/auto_configures_on_exec.out - tests/IntegrationTests/exec/auto_configures_on_exec.sh - tests/IntegrationTests/exec/can_run_executables_installed_in_sandbox.out - tests/IntegrationTests/exec/can_run_executables_installed_in_sandbox.sh - tests/IntegrationTests/exec/configures_cabal_to_use_sandbox.sh - tests/IntegrationTests/exec/configures_ghc_to_use_sandbox.sh - tests/IntegrationTests/exec/exit_with_failure_without_args.err - tests/IntegrationTests/exec/exit_with_failure_without_args.sh - tests/IntegrationTests/exec/my.cabal - tests/IntegrationTests/exec/runs_given_command.out - tests/IntegrationTests/exec/runs_given_command.sh - tests/IntegrationTests/freeze/disable_benchmarks_freezes_bench_deps.sh - tests/IntegrationTests/freeze/disable_tests_freezes_test_deps.sh - tests/IntegrationTests/freeze/does_not_freeze_nondeps.sh - tests/IntegrationTests/freeze/does_not_freeze_self.sh - tests/IntegrationTests/freeze/dry_run_does_not_create_config.sh - tests/IntegrationTests/freeze/enable_benchmarks_freezes_bench_deps.sh - tests/IntegrationTests/freeze/enable_tests_freezes_test_deps.sh - tests/IntegrationTests/freeze/freezes_direct_dependencies.sh - tests/IntegrationTests/freeze/freezes_transitive_dependencies.sh - tests/IntegrationTests/freeze/my.cabal - tests/IntegrationTests/freeze/runs_without_error.sh - tests/IntegrationTests/internal-libs/cabal.project - tests/IntegrationTests/internal-libs/internal_lib_basic.sh - tests/IntegrationTests/internal-libs/internal_lib_shadow.sh - tests/IntegrationTests/internal-libs/new_build.sh - tests/IntegrationTests/internal-libs/p/Foo.hs - tests/IntegrationTests/internal-libs/p/p.cabal - tests/IntegrationTests/internal-libs/p/p/P.hs - tests/IntegrationTests/internal-libs/p/q/Q.hs - tests/IntegrationTests/internal-libs/q/Q.hs - tests/IntegrationTests/internal-libs/q/q.cabal - tests/IntegrationTests/manpage/outputs_manpage.sh - tests/IntegrationTests/multiple-source/finds_second_source_of_multiple_source.sh - tests/IntegrationTests/multiple-source/p/Setup.hs - tests/IntegrationTests/multiple-source/p/p.cabal - tests/IntegrationTests/multiple-source/q/Setup.hs - tests/IntegrationTests/multiple-source/q/q.cabal - tests/IntegrationTests/new-build/BuildToolsPath.sh - tests/IntegrationTests/new-build/BuildToolsPath/A.hs - tests/IntegrationTests/new-build/BuildToolsPath/MyCustomPreprocessor.hs - tests/IntegrationTests/new-build/BuildToolsPath/build-tools-path.cabal - tests/IntegrationTests/new-build/BuildToolsPath/cabal.project - tests/IntegrationTests/new-build/BuildToolsPath/hello/Hello.hs - tests/IntegrationTests/new-build/T3460.sh - tests/IntegrationTests/new-build/T3460/C.hs - tests/IntegrationTests/new-build/T3460/Setup.hs - tests/IntegrationTests/new-build/T3460/T3460.cabal - tests/IntegrationTests/new-build/T3460/cabal.project - tests/IntegrationTests/new-build/T3460/sub-package-A/A.hs - tests/IntegrationTests/new-build/T3460/sub-package-A/Setup.hs - tests/IntegrationTests/new-build/T3460/sub-package-A/sub-package-A.cabal - tests/IntegrationTests/new-build/T3460/sub-package-B/B.hs - tests/IntegrationTests/new-build/T3460/sub-package-B/Setup.hs - tests/IntegrationTests/new-build/T3460/sub-package-B/sub-package-B.cabal - tests/IntegrationTests/new-build/T3978.err - tests/IntegrationTests/new-build/T3978.sh - tests/IntegrationTests/new-build/T3978/cabal.project - tests/IntegrationTests/new-build/T3978/p/p.cabal - tests/IntegrationTests/new-build/T3978/q/q.cabal - tests/IntegrationTests/new-build/T4017.sh - tests/IntegrationTests/new-build/T4017/cabal.project - tests/IntegrationTests/new-build/T4017/p/p.cabal - tests/IntegrationTests/new-build/T4017/q/q.cabal - tests/IntegrationTests/new-build/executable/Main.hs - tests/IntegrationTests/new-build/executable/Setup.hs - tests/IntegrationTests/new-build/executable/Test.hs - tests/IntegrationTests/new-build/executable/a.cabal - tests/IntegrationTests/new-build/executable/cabal.project - tests/IntegrationTests/new-build/external_build_tools.sh - tests/IntegrationTests/new-build/external_build_tools/cabal.project - tests/IntegrationTests/new-build/external_build_tools/client/Hello.hs - tests/IntegrationTests/new-build/external_build_tools/client/client.cabal - tests/IntegrationTests/new-build/external_build_tools/happy/MyCustomPreprocessor.hs - tests/IntegrationTests/new-build/external_build_tools/happy/happy.cabal - tests/IntegrationTests/new-build/monitor_cabal_files.sh - tests/IntegrationTests/new-build/monitor_cabal_files/cabal.project - tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs - tests/IntegrationTests/new-build/monitor_cabal_files/p/Setup.hs - tests/IntegrationTests/new-build/monitor_cabal_files/p/p.cabal - tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs - tests/IntegrationTests/new-build/monitor_cabal_files/q/Setup.hs - tests/IntegrationTests/new-build/monitor_cabal_files/q/q-broken.cabal.in - tests/IntegrationTests/new-build/monitor_cabal_files/q/q-fixed.cabal.in - tests/IntegrationTests/regression/t2755.sh - tests/IntegrationTests/regression/t2755/A.hs - tests/IntegrationTests/regression/t2755/Setup.hs - tests/IntegrationTests/regression/t2755/test-t2755.cabal - tests/IntegrationTests/regression/t3199.sh - tests/IntegrationTests/regression/t3199/Main.hs - tests/IntegrationTests/regression/t3199/Setup.hs - tests/IntegrationTests/regression/t3199/test-3199.cabal - tests/IntegrationTests/regression/t3827.sh - tests/IntegrationTests/regression/t3827/cabal.project - tests/IntegrationTests/regression/t3827/p/P.hs - tests/IntegrationTests/regression/t3827/p/p.cabal - tests/IntegrationTests/regression/t3827/q/Main.hs - tests/IntegrationTests/regression/t3827/q/q.cabal - tests/IntegrationTests/sandbox-reinstalls/p/Main.hs - tests/IntegrationTests/sandbox-reinstalls/p/p.cabal - tests/IntegrationTests/sandbox-reinstalls/q/Q.hs - tests/IntegrationTests/sandbox-reinstalls/q/q.cabal - tests/IntegrationTests/sandbox-reinstalls/reinstall-modified-source.sh - tests/IntegrationTests/sandbox-sources/fail_removing_source_thats_not_registered.err - tests/IntegrationTests/sandbox-sources/fail_removing_source_thats_not_registered.sh - tests/IntegrationTests/sandbox-sources/p/Setup.hs - tests/IntegrationTests/sandbox-sources/p/p.cabal - tests/IntegrationTests/sandbox-sources/q/Setup.hs - tests/IntegrationTests/sandbox-sources/q/q.cabal - tests/IntegrationTests/sandbox-sources/remove_nonexistent_source.sh - tests/IntegrationTests/sandbox-sources/report_success_removing_source.out - tests/IntegrationTests/sandbox-sources/report_success_removing_source.sh - tests/IntegrationTests/user-config/common.sh - tests/IntegrationTests/user-config/doesnt_overwrite_without_f.err - tests/IntegrationTests/user-config/doesnt_overwrite_without_f.sh - tests/IntegrationTests/user-config/overwrites_with_f.out - tests/IntegrationTests/user-config/overwrites_with_f.sh - tests/IntegrationTests/user-config/runs_without_error.out - tests/IntegrationTests/user-config/runs_without_error.sh - tests/IntegrationTests/user-config/uses_CABAL_CONFIG.out - tests/IntegrationTests/user-config/uses_CABAL_CONFIG.sh tests/IntegrationTests2/build/keep-going/cabal.project tests/IntegrationTests2/build/keep-going/p/P.hs tests/IntegrationTests2/build/keep-going/p/p.cabal @@ -228,6 +50,42 @@ tests/IntegrationTests2/regression/3324/p/p.cabal tests/IntegrationTests2/regression/3324/q/Q.hs tests/IntegrationTests2/regression/3324/q/q.cabal + tests/IntegrationTests2/targets/all-disabled/cabal.project + tests/IntegrationTests2/targets/all-disabled/p.cabal + tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project + tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal + tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal + tests/IntegrationTests2/targets/complex/cabal.project + tests/IntegrationTests2/targets/complex/q/Q.hs + tests/IntegrationTests2/targets/complex/q/q.cabal + tests/IntegrationTests2/targets/empty-pkg/cabal.project + tests/IntegrationTests2/targets/empty-pkg/p.cabal + tests/IntegrationTests2/targets/empty/cabal.project + tests/IntegrationTests2/targets/empty/foo.hs + tests/IntegrationTests2/targets/exes-disabled/cabal.project + tests/IntegrationTests2/targets/exes-disabled/p/p.cabal + tests/IntegrationTests2/targets/exes-disabled/q/q.cabal + tests/IntegrationTests2/targets/libs-disabled/cabal.project + tests/IntegrationTests2/targets/libs-disabled/p/p.cabal + tests/IntegrationTests2/targets/libs-disabled/q/q.cabal + tests/IntegrationTests2/targets/multiple-exes/cabal.project + tests/IntegrationTests2/targets/multiple-exes/p.cabal + tests/IntegrationTests2/targets/multiple-libs/cabal.project + tests/IntegrationTests2/targets/multiple-libs/p/p.cabal + tests/IntegrationTests2/targets/multiple-libs/q/q.cabal + tests/IntegrationTests2/targets/multiple-tests/cabal.project + tests/IntegrationTests2/targets/multiple-tests/p.cabal + tests/IntegrationTests2/targets/simple/P.hs + tests/IntegrationTests2/targets/simple/cabal.project + tests/IntegrationTests2/targets/simple/p.cabal + tests/IntegrationTests2/targets/simple/q/QQ.hs + tests/IntegrationTests2/targets/simple/q/q.cabal + tests/IntegrationTests2/targets/test-only/p.cabal + tests/IntegrationTests2/targets/tests-disabled/cabal.project + tests/IntegrationTests2/targets/tests-disabled/p.cabal + tests/IntegrationTests2/targets/tests-disabled/q/q.cabal + tests/IntegrationTests2/targets/variety/cabal.project + tests/IntegrationTests2/targets/variety/p.cabal -- END gen-extra-source-files source-repository head @@ -247,34 +105,75 @@ description: Get Network.URI from the network-uri package default: True +Flag native-dns + description: Enable use of the [resolv](https://hackage.haskell.org/package/resolv) & [windns](https://hackage.haskell.org/package/windns) packages for performing DNS lookups + default: True + manual: True + +Flag debug-expensive-assertions + description: Enable expensive assertions for testing or debugging + default: False + manual: True + Flag debug-conflict-sets description: Add additional information to ConflictSets default: False + manual: True Flag debug-tracetree description: Compile in support for tracetree (used to debug the solver) default: False + manual: True -executable cabal - main-is: Main.hs - ghc-options: -Wall -fwarn-tabs -rtsopts +flag lib + description: Build cabal-install as a library. Please only use this if you are a cabal-install developer. + Default: False + manual: True + +-- Build everything (including the test binaries) as a single static binary +-- instead of 5 discrete binaries. +-- This is useful for CI where we build our binaries on one machine, and then +-- ship them to another machine for testing. Since the test binaries are +-- statically linked (making deployment easier), if we build five executables, +-- that means we need to ship ALL 5 binaries (with 5 versions of all the +-- statically linked libraries) to the test machines. This reduces that to one +-- binary and one set of linked libraries. +flag monolithic + description: Build cabal-install also with all of its test and support code. Used by our continuous integration. + default: False + manual: True + +library + ghc-options: -Wall -fwarn-tabs if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances - other-modules: - Distribution.Client.BuildTarget + exposed-modules: Distribution.Client.BuildReports.Anonymous Distribution.Client.BuildReports.Storage Distribution.Client.BuildReports.Types Distribution.Client.BuildReports.Upload Distribution.Client.Check + Distribution.Client.CmdBench Distribution.Client.CmdBuild Distribution.Client.CmdConfigure + Distribution.Client.CmdUpdate + Distribution.Client.CmdErrorMessages + Distribution.Client.CmdExec Distribution.Client.CmdFreeze Distribution.Client.CmdHaddock + Distribution.Client.CmdInstall Distribution.Client.CmdRepl + Distribution.Client.CmdRun + Distribution.Client.CmdTest + Distribution.Client.Compat.ExecutablePath + Distribution.Client.Compat.FileLock + Distribution.Client.Compat.FilePerms + Distribution.Client.Compat.Prelude + Distribution.Client.Compat.Process + Distribution.Client.Compat.Semaphore Distribution.Client.Config Distribution.Client.Configure Distribution.Client.Dependency @@ -285,11 +184,11 @@ Distribution.Client.FetchUtils Distribution.Client.FileMonitor Distribution.Client.Freeze + Distribution.Client.GZipUtils Distribution.Client.GenBounds Distribution.Client.Get Distribution.Client.Glob Distribution.Client.GlobalFlags - Distribution.Client.GZipUtils Distribution.Client.Haddock Distribution.Client.HttpUtils Distribution.Client.IndexUtils @@ -304,18 +203,20 @@ Distribution.Client.JobControl Distribution.Client.List Distribution.Client.Manpage + Distribution.Client.Nix + Distribution.Client.Outdated Distribution.Client.PackageHash Distribution.Client.PackageUtils Distribution.Client.ParseUtils Distribution.Client.ProjectBuilding Distribution.Client.ProjectBuilding.Types Distribution.Client.ProjectConfig - Distribution.Client.ProjectConfig.Types Distribution.Client.ProjectConfig.Legacy + Distribution.Client.ProjectConfig.Types Distribution.Client.ProjectOrchestration + Distribution.Client.ProjectPlanOutput Distribution.Client.ProjectPlanning Distribution.Client.ProjectPlanning.Types - Distribution.Client.ProjectPlanOutput Distribution.Client.RebuildMonad Distribution.Client.Reconfigure Distribution.Client.Run @@ -329,44 +230,22 @@ Distribution.Client.Security.HTTP Distribution.Client.Setup Distribution.Client.SetupWrapper - Distribution.Client.SrcDist Distribution.Client.SolverInstallPlan - Distribution.Client.SolverPlanIndex Distribution.Client.SourceFiles + Distribution.Client.SrcDist + Distribution.Client.Store Distribution.Client.Tar + Distribution.Client.TargetSelector Distribution.Client.Targets Distribution.Client.Types Distribution.Client.Update Distribution.Client.Upload Distribution.Client.Utils + Distribution.Client.Utils.Assertion Distribution.Client.Utils.Json - Distribution.Client.World Distribution.Client.Win32SelfUpgrade - Distribution.Client.Compat.ExecutablePath - Distribution.Client.Compat.FilePerms - Distribution.Client.Compat.Prelude - Distribution.Client.Compat.Process - Distribution.Client.Compat.Semaphore - Distribution.Solver.Types.ComponentDeps - Distribution.Solver.Types.ConstraintSource - Distribution.Solver.Types.DependencyResolver - Distribution.Solver.Types.InstalledPreference - 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.PackagePreferences - Distribution.Solver.Types.PkgConfigDb - Distribution.Solver.Types.Progress - Distribution.Solver.Types.ResolverPackage - Distribution.Solver.Types.Settings - Distribution.Solver.Types.SolverId - Distribution.Solver.Types.SolverPackage - Distribution.Solver.Types.SourcePackage - Distribution.Solver.Types.Variable + Distribution.Client.World + Distribution.Solver.Compat.Prelude Distribution.Solver.Modular Distribution.Solver.Modular.Assignment Distribution.Solver.Modular.Builder @@ -374,19 +253,18 @@ Distribution.Solver.Modular.ConfiguredConversion Distribution.Solver.Modular.ConflictSet Distribution.Solver.Modular.Cycles - Distribution.Solver.Modular.Degree Distribution.Solver.Modular.Dependency Distribution.Solver.Modular.Explore Distribution.Solver.Modular.Flag Distribution.Solver.Modular.Index Distribution.Solver.Modular.IndexConversion - Distribution.Solver.Modular.Linking Distribution.Solver.Modular.LabeledGraph + Distribution.Solver.Modular.Linking Distribution.Solver.Modular.Log Distribution.Solver.Modular.Message + Distribution.Solver.Modular.PSQ Distribution.Solver.Modular.Package Distribution.Solver.Modular.Preference - Distribution.Solver.Modular.PSQ Distribution.Solver.Modular.RetryLog Distribution.Solver.Modular.Solver Distribution.Solver.Modular.Tree @@ -394,6 +272,27 @@ Distribution.Solver.Modular.Var Distribution.Solver.Modular.Version Distribution.Solver.Modular.WeightedPSQ + Distribution.Solver.Types.ComponentDeps + Distribution.Solver.Types.ConstraintSource + Distribution.Solver.Types.DependencyResolver + Distribution.Solver.Types.Flag + Distribution.Solver.Types.InstSolverPackage + Distribution.Solver.Types.InstalledPreference + 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.PackagePreferences + Distribution.Solver.Types.PkgConfigDb + Distribution.Solver.Types.Progress + Distribution.Solver.Types.ResolverPackage + Distribution.Solver.Types.Settings + Distribution.Solver.Types.SolverId + Distribution.Solver.Types.SolverPackage + Distribution.Solver.Types.SourcePackage + Distribution.Solver.Types.Variable Paths_cabal_install -- NOTE: when updating build-depends, don't forget to update version regexps @@ -405,10 +304,11 @@ base16-bytestring >= 0.1.1 && < 0.2, binary >= 0.5 && < 0.9, bytestring >= 0.9 && < 1, - Cabal >= 1.25 && < 1.26, + Cabal >= 2.1 && < 2.2, containers >= 0.4 && < 0.6, cryptohash-sha256 >= 0.11 && < 0.12, deepseq >= 1.3 && < 1.5, + echo >= 0.1.3 && < 0.2, edit-distance >= 0.2.2 && < 0.3, filepath >= 1.3 && < 1.5, hashable >= 1.0 && < 2, @@ -418,7 +318,7 @@ random >= 1 && < 1.2, stm >= 2.0 && < 3, tar >= 0.5.0.3 && < 0.6, - time >= 1.4 && < 1.7, + time >= 1.4 && < 1.9, zlib >= 0.5.3 && < 0.7, hackage-security >= 0.5.2.2 && < 0.6 @@ -431,8 +331,8 @@ build-depends: directory >= 1.1 && < 1.2, old-time >= 1 && < 1.2, process >= 1.0.1.1 && < 1.1.0.2 else - build-depends: directory >= 1.2 && < 1.3, - process >= 1.1.0.2 && < 1.5 + build-depends: directory >= 1.2 && < 1.4, + process >= 1.1.0.2 && < 1.7 -- NOTE: you MUST include the network dependency even when network-uri -- is pulled in, otherwise the constraint solver doesn't have enough @@ -442,6 +342,12 @@ else build-depends: network >= 2.4 && < 2.6 + if flag(native-dns) + if os(windows) + build-depends: windns >= 0.1.0 && < 0.2 + else + build-depends: resolv >= 0.1.1 && < 0.2 + -- Needed for GHC.Generics before GHC 7.6 if impl(ghc < 7.6) build-depends: ghc-prim >= 0.2 && < 0.3 @@ -451,8 +357,8 @@ else build-depends: unix >= 2.5 && < 2.8 - if !(arch(arm) && impl(ghc < 7.6)) - ghc-options: -threaded + if flag(debug-expensive-assertions) + cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS if flag(debug-conflict-sets) cpp-options: -DDEBUG_CONFLICT_SETS @@ -462,14 +368,320 @@ cpp-options: -DDEBUG_TRACETREE build-depends: tracetree >= 0.1 && < 0.2 + if !flag(lib) + buildable: False + default-language: Haskell2010 +executable cabal + main-is: Main.hs + hs-source-dirs: main + + ghc-options: -Wall -fwarn-tabs -rtsopts + if impl(ghc >= 8.0) + ghc-options: -Wcompat + -Wnoncanonical-monad-instances + -Wnoncanonical-monadfail-instances + + other-modules: Paths_cabal_install + + if flag(lib) + build-depends: + cabal-install, + Cabal >= 2.1 && < 2.2, + base, + directory, + filepath + else + hs-source-dirs: . + build-depends: + async >= 2.0 && < 3, + array >= 0.4 && < 0.6, + base >= 4.5 && < 5, + base16-bytestring >= 0.1.1 && < 0.2, + binary >= 0.5 && < 0.9, + bytestring >= 0.9 && < 1, + Cabal >= 2.1 && < 2.2, + containers >= 0.4 && < 0.6, + cryptohash-sha256 >= 0.11 && < 0.12, + deepseq >= 1.3 && < 1.5, + echo >= 0.1.3 && < 0.2, + edit-distance >= 0.2.2 && < 0.3, + filepath >= 1.3 && < 1.5, + hashable >= 1.0 && < 2, + HTTP >= 4000.1.5 && < 4000.4, + mtl >= 2.0 && < 3, + pretty >= 1.1 && < 1.2, + random >= 1 && < 1.2, + stm >= 2.0 && < 3, + tar >= 0.5.0.3 && < 0.6, + time >= 1.4 && < 1.9, + zlib >= 0.5.3 && < 0.7, + hackage-security >= 0.5.2.2 && < 0.6 + + other-modules: + Distribution.Client.BuildReports.Anonymous + Distribution.Client.BuildReports.Storage + Distribution.Client.BuildReports.Types + Distribution.Client.BuildReports.Upload + Distribution.Client.Check + Distribution.Client.CmdBench + Distribution.Client.CmdBuild + Distribution.Client.CmdConfigure + Distribution.Client.CmdUpdate + Distribution.Client.CmdErrorMessages + Distribution.Client.CmdExec + Distribution.Client.CmdFreeze + Distribution.Client.CmdHaddock + Distribution.Client.CmdInstall + Distribution.Client.CmdRepl + Distribution.Client.CmdRun + Distribution.Client.CmdTest + Distribution.Client.Compat.ExecutablePath + Distribution.Client.Compat.FileLock + Distribution.Client.Compat.FilePerms + Distribution.Client.Compat.Prelude + Distribution.Client.Compat.Process + Distribution.Client.Compat.Semaphore + Distribution.Client.Config + Distribution.Client.Configure + Distribution.Client.Dependency + Distribution.Client.Dependency.Types + Distribution.Client.DistDirLayout + Distribution.Client.Exec + Distribution.Client.Fetch + Distribution.Client.FetchUtils + Distribution.Client.FileMonitor + Distribution.Client.Freeze + Distribution.Client.GZipUtils + Distribution.Client.GenBounds + Distribution.Client.Get + Distribution.Client.Glob + Distribution.Client.GlobalFlags + Distribution.Client.Haddock + Distribution.Client.HttpUtils + Distribution.Client.IndexUtils + Distribution.Client.IndexUtils.Timestamp + Distribution.Client.Init + Distribution.Client.Init.Heuristics + Distribution.Client.Init.Licenses + Distribution.Client.Init.Types + Distribution.Client.Install + Distribution.Client.InstallPlan + Distribution.Client.InstallSymlink + Distribution.Client.JobControl + Distribution.Client.List + Distribution.Client.Manpage + Distribution.Client.Nix + Distribution.Client.Outdated + Distribution.Client.PackageHash + Distribution.Client.PackageUtils + Distribution.Client.ParseUtils + Distribution.Client.ProjectBuilding + Distribution.Client.ProjectBuilding.Types + Distribution.Client.ProjectConfig + Distribution.Client.ProjectConfig.Legacy + Distribution.Client.ProjectConfig.Types + Distribution.Client.ProjectOrchestration + Distribution.Client.ProjectPlanOutput + Distribution.Client.ProjectPlanning + Distribution.Client.ProjectPlanning.Types + Distribution.Client.RebuildMonad + Distribution.Client.Reconfigure + Distribution.Client.Run + Distribution.Client.Sandbox + Distribution.Client.Sandbox.Index + Distribution.Client.Sandbox.PackageEnvironment + Distribution.Client.Sandbox.Timestamp + Distribution.Client.Sandbox.Types + Distribution.Client.SavedFlags + Distribution.Client.Security.DNS + Distribution.Client.Security.HTTP + Distribution.Client.Setup + Distribution.Client.SetupWrapper + Distribution.Client.SolverInstallPlan + Distribution.Client.SourceFiles + Distribution.Client.SrcDist + Distribution.Client.Store + Distribution.Client.Tar + Distribution.Client.TargetSelector + Distribution.Client.Targets + Distribution.Client.Types + Distribution.Client.Update + Distribution.Client.Upload + Distribution.Client.Utils + Distribution.Client.Utils.Assertion + Distribution.Client.Utils.Json + Distribution.Client.Win32SelfUpgrade + Distribution.Client.World + Distribution.Solver.Compat.Prelude + Distribution.Solver.Modular + Distribution.Solver.Modular.Assignment + Distribution.Solver.Modular.Builder + Distribution.Solver.Modular.Configured + Distribution.Solver.Modular.ConfiguredConversion + Distribution.Solver.Modular.ConflictSet + Distribution.Solver.Modular.Cycles + Distribution.Solver.Modular.Dependency + Distribution.Solver.Modular.Explore + Distribution.Solver.Modular.Flag + Distribution.Solver.Modular.Index + Distribution.Solver.Modular.IndexConversion + Distribution.Solver.Modular.LabeledGraph + Distribution.Solver.Modular.Linking + Distribution.Solver.Modular.Log + Distribution.Solver.Modular.Message + Distribution.Solver.Modular.PSQ + Distribution.Solver.Modular.Package + Distribution.Solver.Modular.Preference + Distribution.Solver.Modular.RetryLog + Distribution.Solver.Modular.Solver + Distribution.Solver.Modular.Tree + Distribution.Solver.Modular.Validate + Distribution.Solver.Modular.Var + Distribution.Solver.Modular.Version + Distribution.Solver.Modular.WeightedPSQ + Distribution.Solver.Types.ComponentDeps + Distribution.Solver.Types.ConstraintSource + Distribution.Solver.Types.DependencyResolver + Distribution.Solver.Types.Flag + Distribution.Solver.Types.InstSolverPackage + Distribution.Solver.Types.InstalledPreference + 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.PackagePreferences + Distribution.Solver.Types.PkgConfigDb + Distribution.Solver.Types.Progress + Distribution.Solver.Types.ResolverPackage + Distribution.Solver.Types.Settings + Distribution.Solver.Types.SolverId + Distribution.Solver.Types.SolverPackage + Distribution.Solver.Types.SourcePackage + Distribution.Solver.Types.Variable + + if flag(old-bytestring) + build-depends: bytestring < 0.10.2, bytestring-builder >= 0.10 && < 1 + else + build-depends: bytestring >= 0.10.2 + + if flag(old-directory) + build-depends: directory >= 1.1 && < 1.2, old-time >= 1 && < 1.2, + process >= 1.0.1.1 && < 1.1.0.2 + else + build-depends: directory >= 1.2 && < 1.4, + process >= 1.1.0.2 && < 1.7 + + -- NOTE: you MUST include the network dependency even when network-uri + -- is pulled in, otherwise the constraint solver doesn't have enough + -- information + if flag(network-uri) + build-depends: network-uri >= 2.6 && < 2.7, network >= 2.6 && < 2.7 + else + build-depends: network >= 2.4 && < 2.6 + + if flag(native-dns) + if os(windows) + build-depends: windns >= 0.1.0 && < 0.2 + else + build-depends: resolv >= 0.1.1 && < 0.2 + + -- Needed for GHC.Generics before GHC 7.6 + if impl(ghc < 7.6) + build-depends: ghc-prim >= 0.2 && < 0.3 + + if os(windows) + build-depends: Win32 >= 2 && < 3 + else + build-depends: unix >= 2.5 && < 2.8 + + if flag(debug-expensive-assertions) + cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS + + if flag(debug-conflict-sets) + cpp-options: -DDEBUG_CONFLICT_SETS + build-depends: base >= 4.8 + + if flag(debug-tracetree) + cpp-options: -DDEBUG_TRACETREE + build-depends: tracetree >= 0.1 && < 0.2 + + if flag(monolithic) + hs-source-dirs: tests + other-modules: + UnitTests + MemoryUsageTests + SolverQuickCheck + IntegrationTests2 + + UnitTests.Distribution.Client.ArbitraryInstances + UnitTests.Distribution.Client.FileMonitor + UnitTests.Distribution.Client.GZipUtils + UnitTests.Distribution.Client.Glob + UnitTests.Distribution.Client.IndexUtils.Timestamp + UnitTests.Distribution.Client.InstallPlan + UnitTests.Distribution.Client.JobControl + UnitTests.Distribution.Client.ProjectConfig + UnitTests.Distribution.Client.Sandbox + UnitTests.Distribution.Client.Sandbox.Timestamp + UnitTests.Distribution.Client.Store + UnitTests.Distribution.Client.Tar + UnitTests.Distribution.Client.Targets + UnitTests.Distribution.Client.UserConfig + UnitTests.Distribution.Solver.Modular.Builder + UnitTests.Distribution.Solver.Modular.DSL + UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils + UnitTests.Distribution.Solver.Modular.MemoryUsage + UnitTests.Distribution.Solver.Modular.QuickCheck + UnitTests.Distribution.Solver.Modular.RetryLog + UnitTests.Distribution.Solver.Modular.Solver + UnitTests.Distribution.Solver.Modular.WeightedPSQ + UnitTests.Options + + cpp-options: -DMONOLITHIC + build-depends: + Cabal >= 2.1 && < 2.2, + QuickCheck >= 2.8.2, + array, + async, + bytestring, + containers, + deepseq, + directory, + edit-distance, + filepath, + hashable, + mtl, + network, + network-uri, + pretty-show, + random, + tagged, + tar, + tasty >= 0.12, + tasty-hunit >= 0.10, + tasty-quickcheck, + time, + zlib + + if !(arch(arm) && impl(ghc < 7.6)) + ghc-options: -threaded + + -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a + if os(aix) + extra-libraries: bsd + + default-language: Haskell2010 + -- Small, fast running tests. Test-Suite unit-tests type: exitcode-stdio-1.0 main-is: UnitTests.hs - hs-source-dirs: tests, . - ghc-options: -Wall -fwarn-tabs + hs-source-dirs: tests + ghc-options: -Wall -fwarn-tabs -main-is UnitTests other-modules: UnitTests.Distribution.Client.ArbitraryInstances UnitTests.Distribution.Client.Targets @@ -478,74 +690,79 @@ UnitTests.Distribution.Client.GZipUtils UnitTests.Distribution.Client.Sandbox UnitTests.Distribution.Client.Sandbox.Timestamp + UnitTests.Distribution.Client.Store UnitTests.Distribution.Client.Tar UnitTests.Distribution.Client.UserConfig UnitTests.Distribution.Client.ProjectConfig UnitTests.Distribution.Client.JobControl UnitTests.Distribution.Client.IndexUtils.Timestamp UnitTests.Distribution.Client.InstallPlan - UnitTests.Distribution.Solver.Modular.PSQ + UnitTests.Distribution.Solver.Modular.Builder UnitTests.Distribution.Solver.Modular.RetryLog UnitTests.Distribution.Solver.Modular.Solver UnitTests.Distribution.Solver.Modular.DSL + UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils UnitTests.Distribution.Solver.Modular.WeightedPSQ UnitTests.Options build-depends: + array, base, async, - array, bytestring, + cabal-install, Cabal, containers, deepseq, mtl, - pretty, - process, + random, directory, filepath, - hashable, - stm, tar, time, - HTTP, zlib, - binary, - random, - hackage-security, - tasty, - tasty-hunit, + network-uri, + network, + tasty >= 0.12, + tasty-hunit >= 0.10, tasty-quickcheck, tagged, QuickCheck >= 2.8.2 - if flag(old-directory) - build-depends: old-time - - if flag(network-uri) - build-depends: network-uri >= 2.6, network >= 2.6 - else - build-depends: network-uri < 2.6, network < 2.6 + if !(arch(arm) && impl(ghc < 7.6)) + ghc-options: -threaded - if impl(ghc < 7.6) - build-depends: ghc-prim >= 0.2 && < 0.3 + if !flag(lib) + buildable: False - if os(windows) - build-depends: Win32 - else - build-depends: unix + default-language: Haskell2010 - ghc-options: -fno-ignore-asserts +-- Tests to run with a limited stack and heap size +Test-Suite memory-usage-tests + type: exitcode-stdio-1.0 + main-is: MemoryUsageTests.hs + hs-source-dirs: tests + ghc-options: -Wall -fwarn-tabs "-with-rtsopts=-M4M -K1K" -main-is MemoryUsageTests + other-modules: + UnitTests.Distribution.Solver.Modular.DSL + UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils + UnitTests.Distribution.Solver.Modular.MemoryUsage + UnitTests.Options + build-depends: + base, + async, + Cabal, + cabal-install, + containers, + deepseq, + tagged, + tasty >= 0.12, + tasty-hunit >= 0.10 if !(arch(arm) && impl(ghc < 7.6)) ghc-options: -threaded - if flag(debug-conflict-sets) - cpp-options: -DDEBUG_CONFLICT_SETS - build-depends: base >= 4.8 - - if flag(debug-tracetree) - cpp-options: -DDEBUG_TRACETREE - build-depends: tracetree >= 0.1 && < 0.2 + if !flag(lib) + buildable: False default-language: Haskell2010 @@ -553,155 +770,62 @@ Test-Suite solver-quickcheck type: exitcode-stdio-1.0 main-is: SolverQuickCheck.hs - hs-source-dirs: tests, . - ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts + hs-source-dirs: tests + ghc-options: -Wall -fwarn-tabs -main-is SolverQuickCheck other-modules: UnitTests.Distribution.Solver.Modular.DSL UnitTests.Distribution.Solver.Modular.QuickCheck build-depends: base, async, - array, - bytestring, Cabal, + cabal-install, containers, deepseq >= 1.2, - mtl, - pretty, - process, - directory, - filepath, hashable, - stm, - tar, - time, - HTTP, - zlib, - binary, - random, - hackage-security, - tasty, + tasty >= 0.12, tasty-quickcheck, QuickCheck >= 2.8.2, pretty-show - if flag(old-directory) - build-depends: old-time - - if flag(network-uri) - build-depends: network-uri >= 2.6, network >= 2.6 - else - build-depends: network-uri < 2.6, network < 2.6 - - if impl(ghc < 7.6) - build-depends: ghc-prim >= 0.2 && < 0.3 - - if os(windows) - build-depends: Win32 - else - build-depends: unix - if !(arch(arm) && impl(ghc < 7.6)) ghc-options: -threaded - if flag(debug-conflict-sets) - cpp-options: -DDEBUG_CONFLICT_SETS - build-depends: base >= 4.8 - - if flag(debug-tracetree) - cpp-options: -DDEBUG_TRACETREE - build-depends: tracetree >= 0.1 && < 0.2 + if !flag(lib) + buildable: False default-language: Haskell2010 --- Integration tests that call the cabal executable externally -test-suite integration-tests - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: IntegrationTests.hs - build-depends: - Cabal, - async, - base, - bytestring, - directory, - filepath, - process, - regex-posix, - tasty, - tasty-hunit - - if os(windows) - build-depends: Win32 >= 2 && < 3 - else - build-depends: unix >= 2.5 && < 2.8 - - if !(arch(arm) && impl(ghc < 7.6)) - ghc-options: -threaded - - ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts - default-language: Haskell2010 - -- Integration tests that use the cabal-install code directly -- but still build whole projects test-suite integration-tests2 type: exitcode-stdio-1.0 main-is: IntegrationTests2.hs - hs-source-dirs: tests, . - ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts + hs-source-dirs: tests + ghc-options: -Wall -fwarn-tabs -main-is IntegrationTests2 other-modules: build-depends: - async, - array, base, - base16-bytestring, - binary, - bytestring, Cabal, + cabal-install, containers, - cryptohash-sha256, deepseq, directory, + edit-distance, filepath, - hackage-security, - hashable, - HTTP, - mtl, - network, - network-uri, - pretty, - process, - random, - stm, - tar, - time, - zlib, - tasty, - tasty-hunit, + tasty >= 0.12, + tasty-hunit >= 0.10, tagged - if flag(old-bytestring) - build-depends: bytestring-builder - - if flag(old-directory) - build-depends: old-time - - if impl(ghc < 7.6) - build-depends: ghc-prim >= 0.2 && < 0.3 - - if os(windows) - build-depends: Win32 - else - build-depends: unix + if !flag(lib) + buildable: False - if arch(arm) - cc-options: -DCABAL_NO_THREADED - else + if !(arch(arm) && impl(ghc < 7.6)) ghc-options: -threaded default-language: Haskell2010 custom-setup - setup-depends: Cabal >= 1.25, + setup-depends: Cabal >= 2.1, base, - process >= 1.1.0.1 && < 1.5, + process >= 1.1.0.1 && < 1.7, filepath >= 1.3 && < 1.5 diff --git a/cabal/cabal-install/changelog b/cabal/cabal-install/changelog --- a/cabal/cabal-install/changelog +++ b/cabal/cabal-install/changelog @@ -1,6 +1,60 @@ -*-change-log-*- -1.25.x.x (current development version) +2.2.0.0 (current development version) + * Completed the 'new-update' command (#4809), which respects nix-style + cabal.project(.local) files and allows to update from + multiple repositories when using overlays. + * New config file field: 'cxx-options' to specify which options to be + passed to the compiler when compiling C++ sources specified by the + 'cxx-sources' field. (#3700) + * New config file field: 'cxx-sources' to specify C++ files to be + compiled separately from C source files. Useful in conjunction with the + 'cxx-options' flag to pass different compiler options to C and C++ + source files. (#3700) + * 'cabal configure' now supports '--enable-static' which can be + used to build static libaries with GHC via GHC's `-staticlib` flag. + * Don't automatically/silently case-correct mispelled package-names + on CLI (#4778) + * 'cabal update' now supports '--index-state' which can be used to + roll back the index to an earlier state. + * 'cabal new-configure' now backs up the old 'cabal.project.local' + file if it exists (#4460). + * Completed the 'new-run' command (#4477). The functionality is the + same of the old 'run' command but using nix-style builds. + Additionally, it can run executables across packages in a project. + * Completed the 'new-bench' command (#3638). Same as above. + * Completed the 'new-exec' command (#3638). Same as above. + * Added a preliminary 'new-install' command (#4558, nonlocal exes + part) which allows to quickly install executables from hackage. + * '--allow-{newer,older}' syntax has been enhanced. Dependency + relaxation can be now limited to a specific release of a package, + plus there's a new syntax for relaxing only caret-style (i.e. '^>=') + dependencies (#4575, #4669). + * On macOS, `new-build` will now place dynamic libraries into + `store/lib` and aggressively shorten their names in an effort to + stay within the load command size limits of macOSs mach-o linker. + * Use [lfxtb] letters to differentiate component kind instead of + opaque "c" in dist-dir layout. + * 'new-build' now checks for the existence of executables for + build-tools and build-tool-depends dependencies in the solver + (#4884). + +2.0.0.1 Mikhail Glushenkov December 2017 + * Support for GHC's numeric -g debug levels (#4673). + * Demoted 'scope' field version check to a warning (#4714). + * Fixed verbosity flags getting removed before being passed to + 'printPlan' (#4724). + * Added a '--store-dir' option that can be used to configure the + location of the build global build store (#4623). + * Turned `allow-{newer,older}` in `cabal.project` files into an + accumulating field to match CLI flag semantics (#4679). + * Improve success message when `cabal upload`ing documentation + (#4777). + * Documentation fixes. + +2.0.0.0 Mikhail Glushenkov August 2017 + * See http://coldwa.st/e/blog/2017-09-09-Cabal-2-0.html + for more detailed release notes. * Removed the '--root-cmd' parameter of the 'install' command (#3356). * Deprecated 'cabal install --global' (#3356). @@ -24,10 +78,52 @@ '.../$pkgid.log' to '.../$compiler/$libname.log' (#3807). * Added a new command, 'cabal reconfigure', which re-runs 'configure' with the most recently used flags (#2214). + * Added the '--index-state' flag for requesting a specific + version of the package index (#3893, #4115). * Support for building Backpack packages. See https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst for more details. + * Support the Nix package manager (#3651). + * Made the 'template-haskell' package non-upgradable again (#4185). + * Fixed password echoing on MinTTY (#4128). + * Added a new solver flag, '--allow-boot-library-installs', that allows + any package to be installed or upgraded (#4209). + * New 'cabal-install' command: 'outdated', for listing outdated + version bounds in a .cabal file or a freeze file (#4207). + * Added qualified constraints for setup dependencies. For example, + --constraint="setup.bar == 1.0" constrains all setup dependencies on + bar, and --constraint="foo:setup.bar == 1.0" constrains foo's setup + dependency on bar (part of #3502). + * Non-qualified constraints, such as --constraint="bar == 1.0", now + only apply to top-level dependencies. They don't constrain setup or + build-tool dependencies. The new syntax --constraint="any.bar == 1.0" + constrains all uses of bar. + * Added a technical preview version of the 'cabal doctest' command + (#4480). +1.24.0.2 Mikhail Glushenkov December 2016 + * Adapted to the revert of a PVP-noncompliant API change in + Cabal 1.24.2.0 (#4123). + * Bumped the directory upper bound to < 1.4 (#4158). + +1.24.0.1 Ryan Thomas October 2016 + * Fixed issue with passing '--enable-profiling' when invoking + Setup scripts built with older versions of Cabal (#3873). + * Fixed various behaviour differences between network transports + (#3429). + * Updated to depend on the latest hackage-security that fixes + various issues on Windows. + * Fixed 'new-build' to exit with a non-zero exit code on failure + (#3506). + * Store secure repo index data as 01-index.* (#3862). + * Added new hackage-security root keys for distribution with + cabal-install. + * Fix an issue where 'cabal install' sometimes had to be run twice + for packages with build-type: Custom and a custom-setup stanza + (#3723). + * 'cabal sdist' no longer ignores '--builddir' when the package's + build-type is Custom (#3794). + 1.24.0.0 Ryan Thomas March 2016 * If there are multiple remote repos, 'cabal update' now updates them in parallel (#2503). @@ -88,6 +184,39 @@ * Tech preview of new nix-style isolated project-based builds. Currently provides the commands (new-)build/repl/configure. +1.22.9.0 Ryan Thomas March 2016 + * Include Cabal-1.22.8.0 + +1.22.8.0 Ryan Thomas February 2016 + * Only Custom setup scripts should be compiled with '-i -i.'. + * installedCabalVersion: Don't special-case Cabal anymore. + * Bump the HTTP upper bound. See #3069. + +1.22.7.0 Ryan Thomas December 2015 + * Remove GZipUtils tests + * maybeDecompress: bail on all errors at the beginning of the stream with zlib < 0.6 + * Correct maybeDecompress + +1.22.6.0 Ryan Thomas June 2015 + * A fix for @ezyang's fix for #2502. (Mikhail Glushenkov) + +1.22.5.0 Ryan Thomas June 2015 + * Reduce temporary directory name length, fixes #2502. (Edward Z. Yang) + +1.22.4.0 Ryan Thomas May 2015 + * Force cabal upload to always use digest auth and never basic auth. + * Add dependency-graph information to `printPlan` output + * bootstrap.sh: fixes linker matching to avoid cases where tested linker names appear unexpectedly in compiler output (fixes #2542) + +1.22.3.0 Ryan Thomas April 2015 + * Fix bash completion for sandbox subcommands - Fixes #2513 (Mikhail Glushenkov) + * filterConfigureFlags: filter more flags (Mikhail Glushenkov) + +1.22.2.0 Ryan Thomas March 2015 + * Don't pass '--{en,dis}able-profiling' to old setup exes. + * -Wall police + * Allow filepath 1.4 + 1.22.0.0 Johan Tibell January 2015 * New command: user-config (#2159). * Implement 'cabal repl --only' (#2016). @@ -102,6 +231,19 @@ * Install profiling and shared libs by default in 'bootstrap.sh' (#2009). +1.20.2.0 Ryan Thomas February 2016 + * Only Custom setup scripts should be compiled with '-i -i.'. + * installedCabalVersion: Don't special-case Cabal anymore. + +1.20.1.0 Ryan Thomas May 2015 + * Force cabal upload to always use digest auth and never basic auth. + * bootstrap.sh: install network-uri before HTTP + +1.20.0.5 Johan Tibell December 2014 + * Support random 1.1. + * Fix bootstrap script after network package split. + * Support network-2.6 in test suite. + 1.20.0.3 Johan Tibell June 2014 * Don't attempt to rename dist if it is already named correctly * Treat all flags of a package as interdependent. @@ -130,6 +272,28 @@ * Add haddock section to config file * Add --main-is flag to init +1.18.2.0 Ryan Thomas February 2016 + * Only Custom setup scripts should be compiled with '-i -i.'. + * installedCabalVersion: Don't special-case Cabal anymore. + +1.18.1.0 Ryan Thomas May 2015 + * Force cabal upload to always use digest auth and never basic auth. + * Merge pull request #2367 from juhp/patch-2 + * Fix bootstrap.sh by bumping HTTP to 4000.2.16.1 + +1.18.0.7 Johan Tibell December 2014 + * Support random 1.1. + * Fix bootstrap script after network package split. + * Support network-2.6 in test suite. + +1.18.0.5 Johan Tibell July 2014 + * Make solver flag resolution more conservative. + +1.18.0.4 Johan Tibell May 2014 + * Increase max-backjumps to 2000. + * Fix solver bug which led to missed install plans. + * Tweak solver heuristics to avoid reinstalls. + 0.14.0 Andres Loeh April 2012 * Works with ghc-7.4 * Completely new modular dependency solver (default in most cases) @@ -193,7 +357,7 @@ * HTTP-4000 package required, should fix bugs with http proxies * Now works with authenticated proxies. * On Windows can now override the proxy setting using an env var - * Fix compatability with config files generated by older versions + * Fix compatibility with config files generated by older versions * Warn if the hackage package list is very old * More helpful --help output, mention config file and examples * Better documentation in ~/.cabal/config file @@ -250,7 +414,7 @@ 0.4 Duncan Coutts Oct 2007 * Renamed executable from 'cabal-install' to 'cabal' - * Partial Windows compatability + * Partial Windows compatibility * Do per-user installs by default * cabal install now installs the package in the current directory * Allow multiple remote servers diff --git a/cabal/cabal-install/main/Main.hs b/cabal/cabal-install/main/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/main/Main.hs @@ -0,0 +1,1229 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Entry point to the default cabal-install front-end. +----------------------------------------------------------------------------- + +module Main (main) where + +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand, withRepoContext + , ConfigFlags(..) + , ConfigExFlags(..), defaultConfigExFlags, configureExCommand + , reconfigureCommand + , configCompilerAux', configPackageDB' + , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) + , buildCommand, replCommand, testCommand, benchmarkCommand + , InstallFlags(..), defaultInstallFlags + , installCommand, upgradeCommand, uninstallCommand + , FetchFlags(..), fetchCommand + , FreezeFlags(..), freezeCommand + , genBoundsCommand + , OutdatedFlags(..), outdatedCommand + , GetFlags(..), getCommand, unpackCommand + , checkCommand + , formatCommand + , UpdateFlags(..), updateCommand + , ListFlags(..), listCommand + , InfoFlags(..), infoCommand + , UploadFlags(..), uploadCommand + , ReportFlags(..), reportCommand + , runCommand + , InitFlags(initVerbosity), initCommand + , SDistFlags(..), SDistExFlags(..), sdistCommand + , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand + , ActAsSetupFlags(..), actAsSetupCommand + , SandboxFlags(..), sandboxCommand + , ExecFlags(..), execCommand + , UserConfigFlags(..), userConfigCommand + , reportCommand + , manpageCommand + ) +import Distribution.Simple.Setup + ( HaddockTarget(..) + , DoctestFlags(..), doctestCommand + , HaddockFlags(..), haddockCommand, defaultHaddockFlags + , HscolourFlags(..), hscolourCommand + , ReplFlags(..) + , CopyFlags(..), copyCommand + , RegisterFlags(..), registerCommand + , CleanFlags(..), cleanCommand + , TestFlags(..), BenchmarkFlags(..) + , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag + , configAbsolutePaths + ) + +import Prelude () +import Distribution.Solver.Compat.Prelude hiding (get) + +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Client.Config + ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff + , userConfigUpdate, createDefaultConfigFile, getConfigFilePath ) +import Distribution.Client.Targets + ( readUserTargets ) +import qualified Distribution.Client.List as List + ( list, info ) + + +import qualified Distribution.Client.CmdConfigure as CmdConfigure +import qualified Distribution.Client.CmdUpdate as CmdUpdate +import qualified Distribution.Client.CmdBuild as CmdBuild +import qualified Distribution.Client.CmdRepl as CmdRepl +import qualified Distribution.Client.CmdFreeze as CmdFreeze +import qualified Distribution.Client.CmdHaddock as CmdHaddock +import qualified Distribution.Client.CmdInstall as CmdInstall +import qualified Distribution.Client.CmdRun as CmdRun +import qualified Distribution.Client.CmdTest as CmdTest +import qualified Distribution.Client.CmdBench as CmdBench +import qualified Distribution.Client.CmdExec as CmdExec + +import Distribution.Client.Install (install) +import Distribution.Client.Configure (configure, writeConfigFlags) +import Distribution.Client.Update (update) +import Distribution.Client.Exec (exec) +import Distribution.Client.Fetch (fetch) +import Distribution.Client.Freeze (freeze) +import Distribution.Client.GenBounds (genBounds) +import Distribution.Client.Outdated (outdated) +import Distribution.Client.Check as Check (check) +--import Distribution.Client.Clean (clean) +import qualified Distribution.Client.Upload as Upload +import Distribution.Client.Run (run, splitRunArgs) +import Distribution.Client.SrcDist (sdist) +import Distribution.Client.Get (get) +import Distribution.Client.Reconfigure (Check(..), reconfigure) +import Distribution.Client.Nix (nixInstantiate + ,nixShell + ,nixShellIfSandboxed) +import Distribution.Client.Sandbox (sandboxInit + ,sandboxAddSource + ,sandboxDelete + ,sandboxDeleteSource + ,sandboxListSources + ,sandboxHcPkg + ,dumpPackageEnvironment + + ,loadConfigOrSandboxConfig + ,findSavedDistPref + ,initPackageDBIfNeeded + ,maybeWithSandboxDirOnSearchPath + ,maybeWithSandboxPackageInfo + ,tryGetIndexFilePath + ,sandboxBuildDir + ,updateSandboxConfigFileFlag + ,updateInstallDirs + + ,getPersistOrConfigCompiler) +import Distribution.Client.Sandbox.PackageEnvironment (setPackageDB) +import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord) +import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox) +import Distribution.Client.Tar (createTarGzFile) +import Distribution.Client.Types (Password (..)) +import Distribution.Client.Init (initCabal) +import Distribution.Client.Manpage (manpage) +import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade +import Distribution.Client.Utils (determineNumJobs +#if defined(mingw32_HOST_OS) + ,relaxEncodingErrors +#endif + ) + +import Distribution.Package (packageId) +import Distribution.PackageDescription + ( BuildType(..), Executable(..), buildable ) +import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) + +import Distribution.PackageDescription.PrettyPrint + ( writeGenericPackageDescription ) +import qualified Distribution.Simple as Simple +import qualified Distribution.Make as Make +import qualified Distribution.Types.UnqualComponentName as Make +import Distribution.Simple.Build + ( startInterpreter ) +import Distribution.Simple.Command + ( CommandParse(..), CommandUI(..), Command, CommandSpec(..) + , CommandType(..), commandsRun, commandAddAction, hiddenCommand + , commandFromSpec, commandShowOptions ) +import Distribution.Simple.Compiler (Compiler(..), PackageDBStack) +import Distribution.Simple.Configure + ( configCompilerAuxEx, ConfigStateFileError(..) + , getPersistBuildConfig, interpretPackageDbFlags + , tryGetPersistBuildConfig ) +import qualified Distribution.Simple.LocalBuildInfo as LBI +import Distribution.Simple.Program (defaultProgramDb + ,configureAllKnownPrograms + ,simpleProgramInvocation + ,getProgramInvocationOutput) +import Distribution.Simple.Program.Db (reconfigurePrograms) +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Utils + ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler + , findPackageDesc, tryFindPackageDesc ) +import Distribution.Text + ( display ) +import Distribution.Verbosity as Verbosity + ( Verbosity, normal ) +import Distribution.Version + ( Version, mkVersion, orLaterVersion ) +import qualified Paths_cabal_install (version) + +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.FilePath ( dropExtension, splitExtension + , takeExtension, (), (<.>)) +import System.IO ( BufferMode(LineBuffering), hSetBuffering +#ifdef mingw32_HOST_OS + , stderr +#endif + , stdout ) +import System.Directory (doesFileExist, getCurrentDirectory) +import Data.Monoid (Any(..)) +import Control.Exception (SomeException(..), try) +import Control.Monad (mapM_) + +#ifdef MONOLITHIC +import qualified UnitTests +import qualified MemoryUsageTests +import qualified SolverQuickCheck +import qualified IntegrationTests2 +import qualified System.Environment as Monolithic +#endif + +-- | Entry point +-- +main :: IO () +#ifdef MONOLITHIC +main = do + mb_exec <- Monolithic.lookupEnv "CABAL_INSTALL_MONOLITHIC_MODE" + case mb_exec of + Just "UnitTests" -> UnitTests.main + Just "MemoryUsageTests" -> MemoryUsageTests.main + Just "SolverQuickCheck" -> SolverQuickCheck.main + Just "IntegrationTests2" -> IntegrationTests2.main + Just s -> error $ "Unrecognized mode '" ++ show s ++ "' in CABAL_INSTALL_MONOLITHIC_MODE" + Nothing -> main' +#else +main = main' +#endif + +main' :: IO () +main' = do + -- Enable line buffering so that we can get fast feedback even when piped. + -- This is especially important for CI and build systems. + hSetBuffering stdout LineBuffering + -- The default locale encoding for Windows CLI is not UTF-8 and printing + -- Unicode characters to it will fail unless we relax the handling of encoding + -- errors when writing to stderr and stdout. +#ifdef mingw32_HOST_OS + relaxEncodingErrors stdout + relaxEncodingErrors stderr +#endif + getArgs >>= mainWorker + +mainWorker :: [String] -> IO () +mainWorker args = topHandler $ + case commandsRun (globalCommand commands) commands args of + CommandHelp help -> printGlobalHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalFlags, commandParse) -> + case commandParse of + _ | fromFlagOrDefault False (globalVersion globalFlags) + -> printVersion + | fromFlagOrDefault False (globalNumericVersion globalFlags) + -> printNumericVersion + CommandHelp help -> printCommandHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> do + globalFlags' <- updateSandboxConfigFileFlag globalFlags + action globalFlags' + + where + printCommandHelp help = do + pname <- getProgName + putStr (help pname) + printGlobalHelp help = do + pname <- getProgName + configFile <- defaultConfigFile + putStr (help pname) + putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" + ++ " " ++ configFile ++ "\n" + exists <- doesFileExist configFile + unless exists $ + putStrLn $ "This file will be generated with sensible " + ++ "defaults if you run 'cabal update'." + printOptionsList = putStr . unlines + printErrors errs = dieNoVerbosity $ intercalate "\n" errs + printNumericVersion = putStrLn $ display Paths_cabal_install.version + printVersion = putStrLn $ "cabal-install version " + ++ display Paths_cabal_install.version + ++ "\ncompiled using version " + ++ display cabalVersion + ++ " of the Cabal library " + + commands = map commandFromSpec commandSpecs + commandSpecs = + [ regularCmd installCommand installAction + , regularCmd updateCommand updateAction + , regularCmd listCommand listAction + , regularCmd infoCommand infoAction + , regularCmd fetchCommand fetchAction + , regularCmd freezeCommand freezeAction + , regularCmd getCommand getAction + , hiddenCmd unpackCommand unpackAction + , regularCmd checkCommand checkAction + , regularCmd sdistCommand sdistAction + , regularCmd uploadCommand uploadAction + , regularCmd reportCommand reportAction + , regularCmd runCommand runAction + , regularCmd initCommand initAction + , regularCmd configureExCommand configureAction + , regularCmd reconfigureCommand reconfigureAction + , regularCmd buildCommand buildAction + , regularCmd replCommand replAction + , regularCmd sandboxCommand sandboxAction + , regularCmd doctestCommand doctestAction + , regularCmd haddockCommand haddockAction + , regularCmd execCommand execAction + , regularCmd userConfigCommand userConfigAction + , regularCmd cleanCommand cleanAction + , regularCmd genBoundsCommand genBoundsAction + , regularCmd outdatedCommand outdatedAction + , wrapperCmd copyCommand copyVerbosity copyDistPref + , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref + , wrapperCmd registerCommand regVerbosity regDistPref + , regularCmd testCommand testAction + , regularCmd benchmarkCommand benchmarkAction + , hiddenCmd uninstallCommand uninstallAction + , hiddenCmd formatCommand formatAction + , hiddenCmd upgradeCommand upgradeAction + , hiddenCmd win32SelfUpgradeCommand win32SelfUpgradeAction + , hiddenCmd actAsSetupCommand actAsSetupAction + , hiddenCmd manpageCommand (manpageAction commandSpecs) + + , regularCmd CmdConfigure.configureCommand CmdConfigure.configureAction + , regularCmd CmdUpdate.updateCommand CmdUpdate.updateAction + , regularCmd CmdBuild.buildCommand CmdBuild.buildAction + , regularCmd CmdRepl.replCommand CmdRepl.replAction + , regularCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction + , regularCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction + , regularCmd CmdInstall.installCommand CmdInstall.installAction + , regularCmd CmdRun.runCommand CmdRun.runAction + , regularCmd CmdTest.testCommand CmdTest.testAction + , regularCmd CmdBench.benchCommand CmdBench.benchAction + , regularCmd CmdExec.execCommand CmdExec.execAction + ] + +type Action = GlobalFlags -> IO () + +regularCmd :: CommandUI flags -> (flags -> [String] -> action) + -> CommandSpec action +regularCmd ui action = + CommandSpec ui ((flip commandAddAction) action) NormalCommand + +hiddenCmd :: CommandUI flags -> (flags -> [String] -> action) + -> CommandSpec action +hiddenCmd ui action = + CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action)) + HiddenCommand + +wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) + -> (flags -> Flag String) -> CommandSpec Action +wrapperCmd ui verbosity distPref = + CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand + +wrapperAction :: Monoid flags + => CommandUI flags + -> (flags -> Flag Verbosity) + -> (flags -> Flag String) + -> Command Action +wrapperAction command verbosityFlag distPrefFlag = + commandAddAction command + { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do + let verbosity = fromFlagOrDefault normal (verbosityFlag flags) + load <- try (loadConfigOrSandboxConfig verbosity globalFlags) + let config = either (\(SomeException _) -> mempty) snd load + distPref <- findSavedDistPref config (distPrefFlag flags) + let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } + setupWrapper verbosity setupScriptOptions Nothing + command (const flags) extraArgs + +configureAction :: (ConfigFlags, ConfigExFlags) + -> [String] -> Action +configureAction (configFlags, configExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (configDistPref configFlags) + nixInstantiate verbosity distPref True globalFlags config + nixShell verbosity distPref globalFlags config $ do + let configFlags' = savedConfigureFlags config `mappend` configFlags + configExFlags' = savedConfigureExFlags config `mappend` configExFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAuxEx configFlags' + + -- If we're working inside a sandbox and the user has set the -w option, we + -- may need to create a sandbox-local package DB for this compiler and add a + -- timestamp record for this compiler to the timestamp file. + let configFlags'' = case useSandbox of + NoSandbox -> configFlags' + (UseSandbox sandboxDir) -> setPackageDB sandboxDir + comp platform configFlags' + + writeConfigFlags verbosity distPref (configFlags'', configExFlags') + + -- What package database(s) to use + let packageDBs :: PackageDBStack + packageDBs + = interpretPackageDbFlags + (fromFlag (configUserInstall configFlags'')) + (configPackageDBs configFlags'') + + whenUsingSandbox useSandbox $ \sandboxDir -> do + initPackageDBIfNeeded verbosity configFlags'' comp progdb + -- NOTE: We do not write the new sandbox package DB location to + -- 'cabal.sandbox.config' here because 'configure -w' must not affect + -- subsequent 'install' (for UI compatibility with non-sandboxed mode). + + indexFile <- tryGetIndexFilePath verbosity config + maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile + (compilerId comp) platform + + maybeWithSandboxDirOnSearchPath useSandbox $ + withRepoContext verbosity globalFlags' $ \repoContext -> + configure verbosity packageDBs repoContext + comp platform progdb configFlags'' configExFlags' extraArgs + +reconfigureAction :: (ConfigFlags, ConfigExFlags) + -> [String] -> Action +reconfigureAction flags@(configFlags, _) _ globalFlags = do + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (configDistPref configFlags) + let checkFlags = Check $ \_ saved -> do + let flags' = saved <> flags + unless (saved == flags') $ info verbosity message + pure (Any True, flags') + where + -- This message is correct, but not very specific: it will list all + -- of the new flags, even if some have not actually changed. The + -- *minimal* set of changes is more difficult to determine. + message = + "flags changed: " + ++ unwords (commandShowOptions configureExCommand flags) + nixInstantiate verbosity distPref True globalFlags config + _ <- + reconfigure configureAction + verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag + checkFlags [] globalFlags config + pure () + +buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action +buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (buildDistPref buildFlags) + -- Calls 'configureAction' to do the real work, so nothing special has to be + -- done to support sandboxes. + config' <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags) + mempty [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity config' distPref buildFlags extraArgs + + +-- | Actually do the work of building the package. This is separate from +-- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke +-- 'reconfigure' twice. +build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO () +build verbosity config distPref buildFlags extraArgs = + setupWrapper verbosity setupOptions Nothing + (Cabal.buildCommand progDb) mkBuildFlags extraArgs + where + progDb = defaultProgramDb + setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + + mkBuildFlags version = filterBuildFlags version config buildFlags' + buildFlags' = buildFlags + { buildVerbosity = toFlag verbosity + , buildDistPref = toFlag distPref + } + +-- | Make sure that we don't pass new flags to setup scripts compiled against +-- old versions of Cabal. +filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags +filterBuildFlags version config buildFlags + | version >= mkVersion [1,19,1] = buildFlags_latest + -- Cabal < 1.19.1 doesn't support 'build -j'. + | otherwise = buildFlags_pre_1_19_1 + where + buildFlags_pre_1_19_1 = buildFlags { + buildNumJobs = NoFlag + } + buildFlags_latest = buildFlags { + -- Take the 'jobs' setting '~/.cabal/config' into account. + buildNumJobs = Flag . Just . determineNumJobs $ + (numJobsConfigFlag `mappend` numJobsCmdLineFlag) + } + numJobsConfigFlag = installNumJobs . savedInstallFlags $ config + numJobsCmdLineFlag = buildNumJobs buildFlags + + +replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action +replAction (replFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (replVerbosity replFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (replDistPref replFlags) + cwd <- getCurrentDirectory + pkgDesc <- findPackageDesc cwd + let + -- There is a .cabal file in the current directory: start a REPL and load + -- the project's modules. + onPkgDesc = do + let noAddSource = case replReload replFlags of + Flag True -> SkipAddSourceDepsCheck + _ -> fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + + -- Calls 'configureAction' to do the real work, so nothing special has to + -- be done to support sandboxes. + _ <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource NoFlag + mempty [] globalFlags config + let progDb = defaultProgramDb + setupOptions = defaultSetupScriptOptions + { useCabalVersion = orLaterVersion $ mkVersion [1,18,0] + , useDistPref = distPref + } + replFlags' = replFlags + { replVerbosity = toFlag verbosity + , replDistPref = toFlag distPref + } + + nixShell verbosity distPref globalFlags config $ do + maybeWithSandboxDirOnSearchPath useSandbox $ + setupWrapper verbosity setupOptions Nothing + (Cabal.replCommand progDb) (const replFlags') extraArgs + + -- No .cabal file in the current directory: just start the REPL (possibly + -- using the sandbox package DB). + onNoPkgDesc = do + let configFlags = savedConfigureFlags config + (comp, platform, programDb) <- configCompilerAux' configFlags + programDb' <- reconfigurePrograms verbosity + (replProgramPaths replFlags) + (replProgramArgs replFlags) + programDb + nixShell verbosity distPref globalFlags config $ do + startInterpreter verbosity programDb' comp platform + (configPackageDB' configFlags) + + either (const onNoPkgDesc) (const onPkgDesc) pkgDesc + +installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> Action +installAction (configFlags, _, installFlags, _) _ globalFlags + | fromFlagOrDefault False (installOnly installFlags) = do + let verb = fromFlagOrDefault normal (configVerbosity configFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verb globalFlags + dist <- findSavedDistPref config (configDistPref configFlags) + let setupOpts = defaultSetupScriptOptions { useDistPref = dist } + nixShellIfSandboxed verb dist globalFlags config useSandbox $ + setupWrapper + verb setupOpts Nothing + installCommand (const mempty) [] + +installAction + (configFlags, configExFlags, installFlags, haddockFlags) + extraArgs globalFlags = do + let verb = fromFlagOrDefault normal (configVerbosity configFlags) + (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verb globalFlags + + let sandboxDist = + case useSandbox of + NoSandbox -> NoFlag + UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir + dist <- findSavedDistPref config + (configDistPref configFlags `mappend` sandboxDist) + + nixShellIfSandboxed verb dist globalFlags config useSandbox $ do + targets <- readUserTargets verb extraArgs + + -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to + -- 'configure' when run inside a sandbox. Right now, running + -- + -- $ cabal sandbox init && cabal configure -w /path/to/ghc + -- && cabal build && cabal install + -- + -- performs the compilation twice unless you also pass -w to 'install'. + -- However, this is the same behaviour that 'cabal install' has in the normal + -- mode of operation, so we stick to it for consistency. + + let configFlags' = maybeForceTests installFlags' $ + savedConfigureFlags config `mappend` + configFlags { configDistPref = toFlag dist } + configExFlags' = defaultConfigExFlags `mappend` + savedConfigureExFlags config `mappend` configExFlags + installFlags' = defaultInstallFlags `mappend` + savedInstallFlags config `mappend` installFlags + haddockFlags' = defaultHaddockFlags `mappend` + savedHaddockFlags config `mappend` + haddockFlags { haddockDistPref = toFlag dist } + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags' + -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the + -- future. + progdb' <- configureAllKnownPrograms verb progdb + + -- If we're working inside a sandbox and the user has set the -w option, we + -- may need to create a sandbox-local package DB for this compiler and add a + -- timestamp record for this compiler to the timestamp file. + configFlags'' <- case useSandbox of + NoSandbox -> configAbsolutePaths $ configFlags' + (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform + configFlags' + + whenUsingSandbox useSandbox $ \sandboxDir -> do + initPackageDBIfNeeded verb configFlags'' comp progdb' + + indexFile <- tryGetIndexFilePath verb config + maybeAddCompilerTimestampRecord verb sandboxDir indexFile + (compilerId comp) platform + + -- TODO: Passing 'SandboxPackageInfo' to install unconditionally here means + -- that 'cabal install some-package' inside a sandbox will sometimes reinstall + -- modified add-source deps, even if they are not among the dependencies of + -- 'some-package'. This can also prevent packages that depend on older + -- versions of add-source'd packages from building (see #1362). + maybeWithSandboxPackageInfo verb configFlags'' globalFlags' + comp platform progdb useSandbox $ \mSandboxPkgInfo -> + maybeWithSandboxDirOnSearchPath useSandbox $ + withRepoContext verb globalFlags' $ \repoContext -> + install verb + (configPackageDB' configFlags'') + repoContext + comp platform progdb' + useSandbox mSandboxPkgInfo + globalFlags' configFlags'' configExFlags' + installFlags' haddockFlags' + targets + + where + -- '--run-tests' implies '--enable-tests'. + maybeForceTests installFlags' configFlags' = + if fromFlagOrDefault False (installRunTests installFlags') + then configFlags' { configTests = toFlag True } + else configFlags' + +testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags + -> IO () +testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (testVerbosity testFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (testDistPref testFlags) + let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + buildFlags' = buildFlags + { buildVerbosity = testVerbosity testFlags } + checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> + if fromFlagOrDefault False (configTests configFlags) + then pure (mempty, flags) + else do + info verbosity "reconfiguring to enable tests" + let flags' = ( configFlags { configTests = toFlag True } + , configExFlags + ) + pure (Any True, flags') + + -- reconfigure also checks if we're in a sandbox and reinstalls add-source + -- deps if needed. + _ <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags') + checkFlags [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + testFlags' = testFlags { testDistPref = toFlag distPref } + + -- The package was just configured, so the LBI must be available. + names <- componentNamesFromLBI verbosity distPref "test suites" + (\c -> case c of { LBI.CTest{} -> True; _ -> False }) + let extraArgs' + | null extraArgs = case names of + ComponentNamesUnknown -> [] + ComponentNames names' -> [ Make.unUnqualComponentName name + | LBI.CTestName name <- names' ] + | otherwise = extraArgs + + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity config distPref buildFlags' extraArgs' + + maybeWithSandboxDirOnSearchPath useSandbox $ + setupWrapper verbosity setupOptions Nothing + Cabal.testCommand (const testFlags') extraArgs' + +data ComponentNames = ComponentNamesUnknown + | ComponentNames [LBI.ComponentName] + +-- | Return the names of all buildable components matching a given predicate. +componentNamesFromLBI :: Verbosity -> FilePath -> String + -> (LBI.Component -> Bool) + -> IO ComponentNames +componentNamesFromLBI verbosity distPref targetsDescr compPred = do + eLBI <- tryGetPersistBuildConfig distPref + case eLBI of + Left err -> case err of + -- Note: the build config could have been generated by a custom setup + -- script built against a different Cabal version, so it's crucial that + -- we ignore the bad version error here. + ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown + _ -> die' verbosity (show err) + Right lbi -> do + let pkgDescr = LBI.localPkgDescr lbi + names = map LBI.componentName + . filter (buildable . LBI.componentBuildInfo) + . filter compPred $ + LBI.pkgComponents pkgDescr + if null names + then do notice verbosity $ "Package has no buildable " + ++ targetsDescr ++ "." + exitSuccess -- See #3215. + + else return $! (ComponentNames names) + +benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags) + -> [String] -> GlobalFlags + -> IO () +benchmarkAction + (benchmarkFlags, buildFlags, buildExFlags) + extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal + (benchmarkVerbosity benchmarkFlags) + + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags) + let buildFlags' = buildFlags + { buildVerbosity = benchmarkVerbosity benchmarkFlags } + noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + + let checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> + if fromFlagOrDefault False (configBenchmarks configFlags) + then pure (mempty, flags) + else do + info verbosity "reconfiguring to enable benchmarks" + let flags' = ( configFlags { configBenchmarks = toFlag True } + , configExFlags + ) + pure (Any True, flags') + + + -- reconfigure also checks if we're in a sandbox and reinstalls add-source + -- deps if needed. + config' <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags') + checkFlags [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref } + + -- The package was just configured, so the LBI must be available. + names <- componentNamesFromLBI verbosity distPref "benchmarks" + (\c -> case c of { LBI.CBench{} -> True; _ -> False; }) + let extraArgs' + | null extraArgs = case names of + ComponentNamesUnknown -> [] + ComponentNames names' -> [ Make.unUnqualComponentName name + | LBI.CBenchName name <- names'] + | otherwise = extraArgs + + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity config' distPref buildFlags' extraArgs' + + maybeWithSandboxDirOnSearchPath useSandbox $ + setupWrapper verbosity setupOptions Nothing + Cabal.benchmarkCommand (const benchmarkFlags') extraArgs' + +haddockAction :: HaddockFlags -> [String] -> Action +haddockAction haddockFlags extraArgs globalFlags = do + let verbosity = fromFlag (haddockVerbosity haddockFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (haddockDistPref haddockFlags) + config' <- + reconfigure configureAction + verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag + mempty [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + let haddockFlags' = defaultHaddockFlags `mappend` + savedHaddockFlags config' `mappend` + haddockFlags { haddockDistPref = toFlag distPref } + setupScriptOptions = defaultSetupScriptOptions + { useDistPref = distPref } + setupWrapper verbosity setupScriptOptions Nothing + haddockCommand (const haddockFlags') extraArgs + when (haddockForHackage haddockFlags == Flag ForHackage) $ do + pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) + let dest = distPref name <.> "tar.gz" + name = display (packageId pkg) ++ "-docs" + docDir = distPref "doc" "html" + createTarGzFile dest docDir name + notice verbosity $ "Documentation tarball created: " ++ dest + +doctestAction :: DoctestFlags -> [String] -> Action +doctestAction doctestFlags extraArgs _globalFlags = do + let verbosity = fromFlag (doctestVerbosity doctestFlags) + + setupWrapper verbosity defaultSetupScriptOptions Nothing + doctestCommand (const doctestFlags) extraArgs + +cleanAction :: CleanFlags -> [String] -> Action +cleanAction cleanFlags extraArgs globalFlags = do + load <- try (loadConfigOrSandboxConfig verbosity globalFlags) + let config = either (\(SomeException _) -> mempty) snd load + distPref <- findSavedDistPref config (cleanDistPref cleanFlags) + let setupScriptOptions = defaultSetupScriptOptions + { useDistPref = distPref + , useWin32CleanHack = True + } + cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref } + setupWrapper verbosity setupScriptOptions Nothing + cleanCommand (const cleanFlags') extraArgs + where + verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) + +listAction :: ListFlags -> [String] -> Action +listAction listFlags extraArgs globalFlags = do + let verbosity = fromFlag (listVerbosity listFlags) + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let configFlags' = savedConfigureFlags config + configFlags = configFlags' { + configPackageDBs = configPackageDBs configFlags' + `mappend` listPackageDBs listFlags + } + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, _, progdb) <- configCompilerAux' configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + List.list verbosity + (configPackageDB' configFlags) + repoContext + comp + progdb + listFlags + extraArgs + +infoAction :: InfoFlags -> [String] -> Action +infoAction infoFlags extraArgs globalFlags = do + let verbosity = fromFlag (infoVerbosity infoFlags) + targets <- readUserTargets verbosity extraArgs + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let configFlags' = savedConfigureFlags config + configFlags = configFlags' { + configPackageDBs = configPackageDBs configFlags' + `mappend` infoPackageDBs infoFlags + } + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, _, progdb) <- configCompilerAuxEx configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + List.info verbosity + (configPackageDB' configFlags) + repoContext + comp + progdb + globalFlags' + infoFlags + targets + +updateAction :: UpdateFlags -> [String] -> Action +updateAction updateFlags extraArgs globalFlags = do + let verbosity = fromFlag (updateVerbosity updateFlags) + unless (null extraArgs) $ + die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + update verbosity updateFlags repoContext + +upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> Action +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 " + ++ "confusing and it often led to broken packages.\n" + ++ "If you want the old upgrade behaviour then use the install command " + ++ "with the --upgrade-dependencies flag (but check first with --dry-run " + ++ "to see what would happen). This will try to pick the latest versions " + ++ "of all dependencies, rather than the usual behaviour of trying to pick " + ++ "installed versions of all dependencies. If you do use " + ++ "--upgrade-dependencies, it is recommended that you do not upgrade core " + ++ "packages (e.g. by using appropriate --constraint= flags)." + where + verbosity = fromFlag (configVerbosity configFlags) + +fetchAction :: FetchFlags -> [String] -> Action +fetchAction fetchFlags extraArgs globalFlags = do + let verbosity = fromFlag (fetchVerbosity fetchFlags) + targets <- readUserTargets verbosity extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + fetch verbosity + (configPackageDB' configFlags) + repoContext + comp platform progdb globalFlags' fetchFlags + targets + +freezeAction :: FreezeFlags -> [String] -> Action +freezeAction freezeFlags _extraArgs globalFlags = do + let verbosity = fromFlag (freezeVerbosity freezeFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config NoFlag + nixShell verbosity distPref globalFlags config $ do + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags + + maybeWithSandboxPackageInfo + verbosity configFlags globalFlags' + comp platform progdb useSandbox $ \mSandboxPkgInfo -> + maybeWithSandboxDirOnSearchPath useSandbox $ + withRepoContext verbosity globalFlags' $ \repoContext -> + freeze verbosity + (configPackageDB' configFlags) + repoContext + comp platform progdb + mSandboxPkgInfo + globalFlags' freezeFlags + +genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () +genBoundsAction freezeFlags _extraArgs globalFlags = do + let verbosity = fromFlag (freezeVerbosity freezeFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config NoFlag + nixShell verbosity distPref globalFlags config $ do + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags + + maybeWithSandboxPackageInfo + verbosity configFlags globalFlags' + comp platform progdb useSandbox $ \mSandboxPkgInfo -> + maybeWithSandboxDirOnSearchPath useSandbox $ + withRepoContext verbosity globalFlags' $ \repoContext -> + genBounds verbosity + (configPackageDB' configFlags) + repoContext + comp platform progdb + mSandboxPkgInfo + globalFlags' freezeFlags + +outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO () +outdatedAction outdatedFlags _extraArgs globalFlags = do + let verbosity = fromFlag (outdatedVerbosity outdatedFlags) + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, _progdb) <- configCompilerAux' configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + outdated verbosity outdatedFlags repoContext + comp platform + +uploadAction :: UploadFlags -> [String] -> Action +uploadAction uploadFlags extraArgs globalFlags = do + config <- loadConfig verbosity (globalConfigFile globalFlags) + let uploadFlags' = savedUploadFlags config `mappend` uploadFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + tarfiles = extraArgs + when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $ + die' verbosity "the 'upload' command expects at least one .tar.gz archive." + checkTarFiles extraArgs + maybe_password <- + case uploadPasswordCmd uploadFlags' + of Flag (xs:xss) -> Just . Password <$> + getProgramInvocationOutput verbosity + (simpleProgramInvocation xs xss) + _ -> pure $ flagToMaybe $ uploadPassword uploadFlags' + withRepoContext verbosity globalFlags' $ \repoContext -> do + if fromFlag (uploadDoc uploadFlags') + then do + when (length tarfiles > 1) $ + die' verbosity $ "the 'upload' command can only upload documentation " + ++ "for one package at a time." + tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles + Upload.uploadDoc verbosity + repoContext + (flagToMaybe $ uploadUsername uploadFlags') + maybe_password + (fromFlag (uploadCandidate uploadFlags')) + tarfile + else do + Upload.upload verbosity + repoContext + (flagToMaybe $ uploadUsername uploadFlags') + maybe_password + (fromFlag (uploadCandidate uploadFlags')) + tarfiles + where + verbosity = fromFlag (uploadVerbosity uploadFlags) + checkTarFiles tarfiles + | not (null otherFiles) + = die' verbosity $ "the 'upload' command expects only .tar.gz archives: " + ++ intercalate ", " otherFiles + | otherwise = sequence_ + [ do exists <- doesFileExist tarfile + unless exists $ die' verbosity $ "file not found: " ++ tarfile + | tarfile <- tarfiles ] + + where otherFiles = filter (not . isTarGzFile) tarfiles + isTarGzFile file = case splitExtension file of + (file', ".gz") -> takeExtension file' == ".tar" + _ -> False + generateDocTarball config = do + notice verbosity $ + "No documentation tarball specified. " + ++ "Building a documentation tarball with default settings...\n" + ++ "If you need to customise Haddock options, " + ++ "run 'haddock --for-hackage' first " + ++ "to generate a documentation tarball." + haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage }) + [] globalFlags + distPref <- findSavedDistPref config NoFlag + pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) + return $ distPref display (packageId pkg) ++ "-docs" <.> "tar.gz" + +checkAction :: Flag Verbosity -> [String] -> Action +checkAction verbosityFlag extraArgs _globalFlags = do + let verbosity = fromFlag verbosityFlag + unless (null extraArgs) $ + die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs + allOk <- Check.check (fromFlag verbosityFlag) + unless allOk exitFailure + +formatAction :: Flag Verbosity -> [String] -> Action +formatAction verbosityFlag extraArgs _globalFlags = do + let verbosity = fromFlag verbosityFlag + path <- case extraArgs of + [] -> do cwd <- getCurrentDirectory + tryFindPackageDesc cwd + (p:_) -> return p + pkgDesc <- readGenericPackageDescription verbosity path + -- Uses 'writeFileAtomic' under the hood. + writeGenericPackageDescription path pkgDesc + +uninstallAction :: Flag Verbosity -> [String] -> Action +uninstallAction verbosityFlag extraArgs _globalFlags = do + let verbosity = fromFlag verbosityFlag + package = case extraArgs of + p:_ -> p + _ -> "PACKAGE_NAME" + die' verbosity $ "This version of 'cabal-install' does not support the 'uninstall' " + ++ "operation. " + ++ "It will likely be implemented at some point in the future; " + ++ "in the meantime you're advised to use either 'ghc-pkg unregister " + ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'." + + +sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action +sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do + let verbosity = fromFlag (sDistVerbosity sdistFlags) + unless (null extraArgs) $ + die' verbosity $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs + load <- try (loadConfigOrSandboxConfig verbosity globalFlags) + let config = either (\(SomeException _) -> mempty) snd load + distPref <- findSavedDistPref config (sDistDistPref sdistFlags) + let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref } + sdist sdistFlags' sdistExFlags + +reportAction :: ReportFlags -> [String] -> Action +reportAction reportFlags extraArgs globalFlags = do + let verbosity = fromFlag (reportVerbosity reportFlags) + unless (null extraArgs) $ + die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + reportFlags' = savedReportFlags config `mappend` reportFlags + + withRepoContext verbosity globalFlags' $ \repoContext -> + Upload.report verbosity repoContext + (flagToMaybe $ reportUsername reportFlags') + (flagToMaybe $ reportPassword reportFlags') + +runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action +runAction (buildFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (buildDistPref buildFlags) + let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + -- reconfigure also checks if we're in a sandbox and reinstalls add-source + -- deps if needed. + config' <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags) + mempty [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + lbi <- getPersistBuildConfig distPref + (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs + + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)] + + maybeWithSandboxDirOnSearchPath useSandbox $ + run verbosity lbi exe exeArgs + +getAction :: GetFlags -> [String] -> Action +getAction getFlags extraArgs globalFlags = do + let verbosity = fromFlag (getVerbosity getFlags) + targets <- readUserTargets verbosity extraArgs + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + withRepoContext verbosity (savedGlobalFlags config) $ \repoContext -> + get verbosity + repoContext + globalFlags' + getFlags + targets + +unpackAction :: GetFlags -> [String] -> Action +unpackAction getFlags extraArgs globalFlags = do + getAction getFlags extraArgs globalFlags + +initAction :: InitFlags -> [String] -> Action +initAction initFlags extraArgs globalFlags = do + let verbosity = fromFlag (initVerbosity initFlags) + when (extraArgs /= []) $ + die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let configFlags = savedConfigureFlags config + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, _, progdb) <- configCompilerAux' configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + initCabal verbosity + (configPackageDB' configFlags) + repoContext + comp + progdb + initFlags + +sandboxAction :: SandboxFlags -> [String] -> Action +sandboxAction sandboxFlags extraArgs globalFlags = do + let verbosity = fromFlag (sandboxVerbosity sandboxFlags) + case extraArgs of + -- Basic sandbox commands. + ["init"] -> sandboxInit verbosity sandboxFlags globalFlags + ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags + ("add-source":extra) -> do + when (noExtraArgs extra) $ + die' verbosity "The 'sandbox add-source' command expects at least one argument" + sandboxAddSource verbosity extra sandboxFlags globalFlags + ("delete-source":extra) -> do + when (noExtraArgs extra) $ + die' verbosity ("The 'sandbox delete-source' command expects " ++ + "at least one argument") + sandboxDeleteSource verbosity extra sandboxFlags globalFlags + ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags + + -- More advanced commands. + ("hc-pkg":extra) -> do + when (noExtraArgs extra) $ + die' verbosity $ "The 'sandbox hc-pkg' command expects at least one argument" + sandboxHcPkg verbosity sandboxFlags globalFlags extra + ["buildopts"] -> die' verbosity "Not implemented!" + + -- Hidden commands. + ["dump-pkgenv"] -> dumpPackageEnvironment verbosity sandboxFlags globalFlags + + -- Error handling. + [] -> die' verbosity $ "Please specify a subcommand (see 'help sandbox')" + _ -> die' verbosity $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs + + where + noExtraArgs = (<1) . length + +execAction :: ExecFlags -> [String] -> Action +execAction execFlags extraArgs globalFlags = do + let verbosity = fromFlag (execVerbosity execFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (execDistPref execFlags) + let configFlags = savedConfigureFlags config + configFlags' = configFlags { configDistPref = Flag distPref } + (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags' + exec verbosity useSandbox comp platform progdb extraArgs + +userConfigAction :: UserConfigFlags -> [String] -> Action +userConfigAction ucflags extraArgs globalFlags = do + let verbosity = fromFlag (userConfigVerbosity ucflags) + force = fromFlag (userConfigForce ucflags) + case extraArgs of + ("init":_) -> do + path <- configFile + fileExists <- doesFileExist path + if (not fileExists || (fileExists && force)) + then void $ createDefaultConfigFile verbosity path + else die' verbosity $ path ++ " already exists." + ("diff":_) -> mapM_ putStrLn =<< userConfigDiff globalFlags + ("update":_) -> userConfigUpdate verbosity globalFlags + -- Error handling. + [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')" + _ -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs + where configFile = getConfigFilePath (globalConfigFile globalFlags) + +-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. +-- +win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action +win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do + let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags) + Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path -- TODO: eradicateNoParse +win32SelfUpgradeAction _ _ _ = return () + +-- | Used as an entry point when cabal-install needs to invoke itself +-- as a setup script. This can happen e.g. when doing parallel builds. +-- +actAsSetupAction :: ActAsSetupFlags -> [String] -> Action +actAsSetupAction actAsSetupFlags args _globalFlags = + let bt = fromFlag (actAsSetupBuildType actAsSetupFlags) + in case bt of + Simple -> Simple.defaultMainArgs args + Configure -> Simple.defaultMainWithHooksArgs + Simple.autoconfUserHooks args + Make -> Make.defaultMainArgs args + Custom -> error "actAsSetupAction Custom" + (UnknownBuildType _) -> error "actAsSetupAction UnknownBuildType" + +manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action +manpageAction commands flagVerbosity extraArgs _ = do + let verbosity = fromFlag flagVerbosity + unless (null extraArgs) $ + die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs + pname <- getProgName + let cabalCmd = if takeExtension pname == ".exe" + then dropExtension pname + else pname + putStrLn $ manpage cabalCmd commands diff --git a/cabal/cabal-install/tests/IntegrationTests.hs b/cabal/cabal-install/tests/IntegrationTests.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests.hs +++ /dev/null @@ -1,325 +0,0 @@ -{-# LANGUAGE CPP #-} --- | Groups black-box tests of cabal-install and configures them to test --- the correct binary. --- --- This file should do nothing but import tests from other modules and run --- them with the path to the correct cabal-install binary. -module Main - where - --- Modules from Cabal. -import Distribution.Compat.CreatePipe (createPipe) -import Distribution.Compat.Environment (setEnv, getEnvironment) -import Distribution.Compat.Internal.TempFile (createTempDirectory) -import Distribution.Simple.Configure (findDistPrefOrDefault) -import Distribution.Simple.Program.Builtin (ghcPkgProgram) -import Distribution.Simple.Program.Db - (defaultProgramDb, requireProgram, setProgramSearchPath) -import Distribution.Simple.Program.Find - (ProgramSearchPathEntry(ProgramSearchPathDir), defaultProgramSearchPath) -import Distribution.Simple.Program.Types - ( Program(..), simpleProgram, programPath) -import Distribution.Simple.Setup ( Flag(..) ) -import Distribution.Simple.Utils ( findProgramVersion, copyDirectoryRecursive, installOrdinaryFile ) -import Distribution.Verbosity (normal) - --- Third party modules. -import Control.Concurrent.Async (withAsync, wait) -import Control.Exception (bracket) -import Data.Maybe (fromMaybe) -import System.Directory - ( canonicalizePath - , findExecutable - , getDirectoryContents - , getTemporaryDirectory - , doesDirectoryExist - , removeDirectoryRecursive - , doesFileExist ) -import System.FilePath -import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.HUnit (testCase, Assertion, assertFailure) -import Control.Monad ( filterM, forM, unless, when ) -import Data.List (isPrefixOf, isSuffixOf, sort) -import Data.IORef (newIORef, writeIORef, readIORef) -import System.Exit (ExitCode(..)) -import System.IO (withBinaryFile, IOMode(ReadMode)) -import System.Process (runProcess, waitForProcess) -import Text.Regex.Posix ((=~)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C8 -import Data.ByteString (ByteString) - -#if MIN_VERSION_base(4,6,0) -import System.Environment ( getExecutablePath ) -#endif - --- | Test case. -data TestCase = TestCase - { tcName :: String -- ^ Name of the shell script - , tcBaseDirectory :: FilePath -- ^ The base directory where tests are found - -- e.g., cabal-install/tests/IntegrationTests - , tcCategory :: String -- ^ Category of test; e.g., custom, exec, freeze, ... - , tcStdOutPath :: Maybe FilePath -- ^ File path of expected standard output - , tcStdErrPath :: Maybe FilePath -- ^ File path of expected standard error - } - --- | Test result. -data TestResult = TestResult - { trExitCode :: ExitCode -- ^ Exit code of test script - , trStdOut :: ByteString -- ^ Actual standard output - , trStdErr :: ByteString -- ^ Actual standard error - , trWorkingDirectory :: FilePath -- ^ Temporary working directory test was - -- executed in. - } - --- | Cabal executable -cabalProgram :: Program -cabalProgram = (simpleProgram "cabal") { - programFindVersion = findProgramVersion "--numeric-version" id - } - --- | Convert test result to user-friendly string message. -testResultToString :: TestResult -> String -testResultToString testResult = - exitStatus ++ "\n" ++ workingDirectory ++ "\n\n" ++ stdOut ++ "\n\n" ++ stdErr - where - exitStatus = "Exit status: " ++ show (trExitCode testResult) - workingDirectory = "Working directory: " ++ (trWorkingDirectory testResult) - stdOut = " was:\n" ++ C8.unpack (trStdOut testResult) - stdErr = " was:\n" ++ C8.unpack (trStdErr testResult) - --- | Returns the command that was issued, the return code, and the output text -run :: FilePath -> String -> [String] -> IO TestResult -run cwd path args = do - -- path is relative to the current directory; canonicalizePath makes it - -- absolute, so that runProcess will find it even when changing directory. - path' <- canonicalizePath path - - (pid, hReadStdOut, hReadStdErr) <- do - -- Create pipes for StdOut and StdErr - (hReadStdOut, hWriteStdOut) <- createPipe - (hReadStdErr, hWriteStdErr) <- createPipe - -- Run the process - env0 <- getEnvironment - -- CABAL_BUILDDIR can interfere with test running, so - -- be sure to clear it out. - let env = filter ((/= "CABAL_BUILDDIR") . fst) env0 - pid <- runProcess path' args (Just cwd) (Just env) Nothing (Just hWriteStdOut) (Just hWriteStdErr) - -- Return the pid and read ends of the pipes - return (pid, hReadStdOut, hReadStdErr) - -- Read subprocess output using asynchronous threads; we need to - -- do this aynchronously to avoid deadlocks due to buffers filling - -- up. - withAsync (B.hGetContents hReadStdOut) $ \stdOutAsync -> do - withAsync (B.hGetContents hReadStdErr) $ \stdErrAsync -> do - -- Wait for the subprocess to terminate - exitcode <- waitForProcess pid - -- We can now be sure that no further output is going to arrive, - -- so we wait for the results of the asynchronous reads. - stdOut <- wait stdOutAsync - stdErr <- wait stdErrAsync - -- Done - return $ TestResult exitcode stdOut stdErr cwd - --- | Get a list of all names in a directory, excluding all hidden or --- system files/directories such as '.', '..' or any files/directories --- starting with a '.'. -listDirectory :: FilePath -> IO [String] -listDirectory directory = do - fmap (filter notHidden) $ getDirectoryContents directory - where - notHidden = not . isHidden - isHidden name = "." `isPrefixOf` name - --- | List a directory as per 'listDirectory', but return an empty list --- in case the directory does not exist. -listDirectoryLax :: FilePath -> IO [String] -listDirectoryLax directory = do - d <- doesDirectoryExist directory - if d then - listDirectory directory - else - return [ ] - --- | @pathIfExists p == return (Just p)@ if @p@ exists, and --- @return Nothing@ otherwise. -pathIfExists :: FilePath -> IO (Maybe FilePath) -pathIfExists p = do - e <- doesFileExist p - if e then - return $ Just p - else - return Nothing - --- | Checks if file @p@ matches a 'ByteString' @s@, subject --- to line-break normalization. Lines in the file which are --- prefixed with @RE:@ are treated specially as a regular expression. -fileMatchesString :: FilePath -> ByteString -> IO Bool -fileMatchesString p s = do - withBinaryFile p ReadMode $ \h -> do - expected <- (C8.lines . normalizeLinebreaks) `fmap` B.hGetContents h -- Strict - let actual = C8.lines $ normalizeLinebreaks s - return $ length expected == length actual && - and (zipWith matches expected actual) - where - matches :: ByteString -> ByteString -> Bool - matches pattern line - | C8.pack "RE:" `B.isPrefixOf` pattern = line =~ C8.drop 3 pattern - | otherwise = line == pattern - - -- This is a bit of a hack, but since we're comparing - -- *text* output, we should be OK. - normalizeLinebreaks = B.filter (not . ((==) 13)) -- carriage return - --- | Check if the @actual@ 'ByteString' matches the contents of --- @expected@ (always succeeds if the expectation is 'Nothing'). --- Also takes the 'TestResult' and a label @handleName@ describing --- what text the string values correspond to. -mustMatch :: TestResult -> String -> ByteString -> Maybe FilePath -> Assertion -mustMatch _ _ _ Nothing = return () -mustMatch testResult handleName actual (Just expected) = do - m <- fileMatchesString expected actual - unless m $ assertFailure $ - "<" ++ handleName ++ "> did not match file '" - ++ expected ++ "'.\n" ++ testResultToString testResult - --- | Given a @directory@, return its subdirectories. This is --- run on @cabal-install/tests/IntegrationTests@ to get the --- list of test categories which can be run. -discoverTestCategories :: FilePath -> IO [String] -discoverTestCategories directory = do - names <- listDirectory directory - fmap sort $ filterM (\name -> doesDirectoryExist $ directory name) names - --- | Find all shell scripts in @baseDirectory category@. -discoverTestCases :: FilePath -> String -> IO [TestCase] -discoverTestCases baseDirectory category = do - -- Find the names of the shell scripts - names <- fmap (filter isTestCase) $ listDirectoryLax directory - -- Fill in TestCase for each script - forM (sort names) $ \name -> do - stdOutPath <- pathIfExists $ directory name `replaceExtension` ".out" - stdErrPath <- pathIfExists $ directory name `replaceExtension` ".err" - return $ TestCase { tcName = name - , tcBaseDirectory = baseDirectory - , tcCategory = category - , tcStdOutPath = stdOutPath - , tcStdErrPath = stdErrPath - } - where - directory = baseDirectory category - isTestCase name = ".sh" `isSuffixOf` name - --- | Given a list of 'TestCase's (describing a shell script for a --- single test case), run @mk@ on each of them to form a runnable --- 'TestTree'. -createTestCases :: [TestCase] -> (TestCase -> Assertion) -> IO [TestTree] -createTestCases testCases mk = - return $ (flip map) testCases $ \tc -> testCase (tcName tc ++ suffix tc) $ mk tc - where - suffix tc = case (tcStdOutPath tc, tcStdErrPath tc) of - (Nothing, Nothing) -> " (ignoring stdout+stderr)" - (Just _ , Nothing) -> " (ignoring stderr)" - (Nothing, Just _ ) -> " (ignoring stdout)" - (Just _ , Just _ ) -> "" - --- | Given a 'TestCase', run it. --- --- A test case of the form @category/testname.sh@ is --- run in the following way --- --- 1. We make a full copy all of @category@ into a temporary --- directory. --- 2. In the temporary directory, run @testname.sh@. --- 3. Test that the exit code is zero, and that stdout/stderr --- match the expected results. --- -runTestCase :: TestCase -> IO () -runTestCase tc = do - doRemove <- newIORef False - bracket createWorkDirectory (removeWorkDirectory doRemove) $ \workDirectory -> do - -- Run - let scriptDirectory = workDirectory - sh <- fmap (fromMaybe $ error "Cannot find 'sh' executable") $ findExecutable "sh" - testResult <- run scriptDirectory sh [ "-e", tcName tc] - -- Assert that we got what we expected - case trExitCode testResult of - ExitSuccess -> - return () -- We're good - ExitFailure _ -> - assertFailure $ "Unexpected exit status.\n\n" ++ testResultToString testResult - mustMatch testResult "stdout" (trStdOut testResult) (tcStdOutPath tc) - mustMatch testResult "stderr" (trStdErr testResult) (tcStdErrPath tc) - -- Only remove working directory if test succeeded - writeIORef doRemove True - where - createWorkDirectory = do - -- Create the temporary directory - tempDirectory <- getTemporaryDirectory - workDirectory <- createTempDirectory tempDirectory "cabal-install-test" - -- Copy all the files from the category into the working directory. - copyDirectoryRecursive normal - (tcBaseDirectory tc tcCategory tc) - workDirectory - -- Copy in the common.sh stub - let commonDest = workDirectory "common.sh" - e <- doesFileExist commonDest - unless e $ - installOrdinaryFile normal (tcBaseDirectory tc "common.sh") commonDest - -- Done - return workDirectory - removeWorkDirectory doRemove workDirectory = do - remove <- readIORef doRemove - when remove $ removeDirectoryRecursive workDirectory - -discoverCategoryTests :: FilePath -> String -> IO [TestTree] -discoverCategoryTests baseDirectory category = do - testCases <- discoverTestCases baseDirectory category - createTestCases testCases runTestCase - -main :: IO () -main = do - -- Find executables and build directories, etc. - distPref <- guessDistDir - buildDir <- canonicalizePath (distPref "build/cabal") - let programSearchPath = ProgramSearchPathDir buildDir : defaultProgramSearchPath - (cabal, _) <- requireProgram normal cabalProgram (setProgramSearchPath programSearchPath defaultProgramDb) - (ghcPkg, _) <- requireProgram normal ghcPkgProgram defaultProgramDb - baseDirectory <- canonicalizePath $ "tests" "IntegrationTests" - -- Set up environment variables for test scripts - setEnv "GHC_PKG" $ programPath ghcPkg - setEnv "CABAL" $ programPath cabal - -- Define default arguments - setEnv "CABAL_ARGS" $ "--config-file=config-file" - setEnv "CABAL_ARGS_NO_CONFIG_FILE" " " - -- Don't get Unicode output from GHC - setEnv "LC_ALL" "C" - -- Discover all the test categories - categories <- discoverTestCategories baseDirectory - -- Discover tests in each category - tests <- forM categories $ \category -> do - categoryTests <- discoverCategoryTests baseDirectory category - return (category, categoryTests) - -- Map into a test tree - let testTree = map (\(category, categoryTests) -> testGroup category categoryTests) tests - -- Run the tests - defaultMain $ testGroup "Integration Tests" $ testTree - --- See this function in Cabal's PackageTests. If you update this, --- update its copy in cabal-install. (Why a copy here? I wanted --- to try moving this into the Cabal library, but to do this properly --- I'd have to BC'ify getExecutablePath, and then it got hairy, so --- I aborted and did something simple.) -guessDistDir :: IO FilePath -guessDistDir = do -#if MIN_VERSION_base(4,6,0) - exe_path <- canonicalizePath =<< getExecutablePath - let dist0 = dropFileName exe_path ".." ".." - b <- doesFileExist (dist0 "setup-config") -#else - let dist0 = error "no path" - b = False -#endif - -- Method (2) - if b then canonicalizePath dist0 - else findDistPrefOrDefault NoFlag >>= canonicalizePath diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2-external.sh b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2-external.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2-external.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh -. ./common.sh - -require_ghc_ge 801 - -cd includes2 -mv cabal.project.external cabal.project -cabal new-build exe -dist-newstyle/build/*/*/exe-*/c/exe/build/exe/exe | fgrep "minemysql minepostgresql" diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2-internal.sh b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2-internal.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2-internal.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh -. ./common.sh - -require_ghc_ge 801 - -cd includes2 -mv cabal.project.internal cabal.project -cabal new-build exe -dist-newstyle/build/*/*/Includes2-*/c/exe/build/exe/exe | fgrep "minemysql minepostgresql" diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/Includes2.cabal b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/Includes2.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/Includes2.cabal +++ /dev/null @@ -1,41 +0,0 @@ -name: Includes2 -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.25 - -library mylib - build-depends: base - signatures: Database - exposed-modules: Mine - hs-source-dirs: mylib - default-language: Haskell2010 - -library mysql - build-depends: base - exposed-modules: Database.MySQL - hs-source-dirs: mysql - default-language: Haskell2010 - -library postgresql - build-depends: base - exposed-modules: Database.PostgreSQL - hs-source-dirs: postgresql - default-language: Haskell2010 - -library - build-depends: base, mysql, postgresql, mylib - mixins: - mylib (Mine as Mine.MySQL) requires (Database as Database.MySQL), - mylib (Mine as Mine.PostgreSQL) requires (Database as Database.PostgreSQL) - exposed-modules: App - hs-source-dirs: src - default-language: Haskell2010 - -executable exe - build-depends: base, Includes2 - main-is: Main.hs - hs-source-dirs: exe - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.external b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.external deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.external +++ /dev/null @@ -1,1 +0,0 @@ -packages: mylib mysql src exe postgresql diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.internal b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.internal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/cabal.project.internal +++ /dev/null @@ -1,1 +0,0 @@ -packages: . diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/exe/Main.hs b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/exe/Main.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/exe/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ -import App - -main = print app diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/exe/exe.cabal b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/exe/exe.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/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, src - main-is: Main.hs - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Database.hsig b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Database.hsig deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Database.hsig +++ /dev/null @@ -1,3 +0,0 @@ -signature Database where -data Database -databaseName :: String diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Mine.hs b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Mine.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/Mine.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Mine where -import Database -data Mine = Mine Database -mine = "mine" ++ databaseName diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/mylib.cabal b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/mylib.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mylib/mylib.cabal +++ /dev/null @@ -1,13 +0,0 @@ -name: mylib -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: Database - exposed-modules: Mine - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mysql/Database/MySQL.hs b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mysql/Database/MySQL.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mysql/Database/MySQL.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Database.MySQL where -data Database = Database Int -databaseName = "mysql" diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mysql/mysql.cabal b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mysql/mysql.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/mysql/mysql.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: mysql -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 - exposed-modules: Database.MySQL - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/Database/PostgreSQL.hs b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/Database/PostgreSQL.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/Database/PostgreSQL.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Database.PostgreSQL where -data Database = Database Bool -databaseName = "postgresql" diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/postgresql.cabal b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/postgresql.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/postgresql/postgresql.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: postgresql -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 - exposed-modules: Database.PostgreSQL - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/src/App.hs b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/src/App.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/src/App.hs +++ /dev/null @@ -1,7 +0,0 @@ -module App where -import Database.MySQL -import Database.PostgreSQL -import qualified Mine.MySQL -import qualified Mine.PostgreSQL - -app = Mine.MySQL.mine ++ " " ++ Mine.PostgreSQL.mine diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/src/src.cabal b/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/src/src.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes2/src/src.cabal +++ /dev/null @@ -1,15 +0,0 @@ -name: src -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, mysql, postgresql, mylib - mixins: - mylib (Mine as Mine.MySQL) requires (Database as Database.MySQL), - mylib (Mine as Mine.PostgreSQL) requires (Database as Database.PostgreSQL) - exposed-modules: App - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3-external.sh b/cabal/cabal-install/tests/IntegrationTests/backpack/includes3-external.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3-external.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh -. ./common.sh - -require_ghc_ge 801 - -cd includes3 -mv cabal.project.external cabal.project -cabal new-build exe -dist-newstyle/build/*/*/exe-*/c/exe/build/exe/exe | fgrep "fromList [(0,2),(2,4)]" diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3-internal.sh b/cabal/cabal-install/tests/IntegrationTests/backpack/includes3-internal.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3-internal.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh -. ./common.sh - -require_ghc_ge 801 - -cd includes3 -mv cabal.project.internal cabal.project -cabal new-build exe -dist-newstyle/build/*/*/Includes3-*/c/exe/build/exe/exe | fgrep "fromList [(0,2),(2,4)]" diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/Includes3.cabal b/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/Includes3.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/Includes3.cabal +++ /dev/null @@ -1,23 +0,0 @@ -name: Includes3 -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.25 - -library sigs - build-depends: base - signatures: Data.Map - hs-source-dirs: sigs - -library indef - build-depends: base, sigs - exposed-modules: Foo - hs-source-dirs: indef - -executable exe - build-depends: base, containers, indef - main-is: Main.hs - hs-source-dirs: exe - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.external b/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.external deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.external +++ /dev/null @@ -1,1 +0,0 @@ -packages: exe indef sigs diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.internal b/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.internal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/cabal.project.internal +++ /dev/null @@ -1,1 +0,0 @@ -packages: . diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/exe/Main.hs b/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/exe/Main.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/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-install/tests/IntegrationTests/backpack/includes3/exe/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/exe/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/exe/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/exe/exe.cabal b/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/exe/exe.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/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-install/tests/IntegrationTests/backpack/includes3/indef/Foo.hs b/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/indef/Foo.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/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-install/tests/IntegrationTests/backpack/includes3/indef/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/indef/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/indef/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/indef/indef.cabal b/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/indef/indef.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/indef/indef.cabal +++ /dev/null @@ -1,11 +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 diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/Data/Map.hsig b/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/Data/Map.hsig deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/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-install/tests/IntegrationTests/backpack/includes3/sigs/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/sigs.cabal b/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/sigs.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/backpack/includes3/sigs/sigs.cabal +++ /dev/null @@ -1,11 +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 diff --git a/cabal/cabal-install/tests/IntegrationTests/common.sh b/cabal/cabal-install/tests/IntegrationTests/common.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/common.sh +++ /dev/null @@ -1,28 +0,0 @@ -# A globally available set of useful utilities. Test -# scripts can include this by saying ". ./common.sh" - -# Helper to run Cabal -cabal() { - "$CABAL" $CABAL_ARGS "$@" -} - -die() { - echo "die: $@" - exit 1 -} - -require_ghc_le() { - GHCVER="$(echo main = print __GLASGOW_HASKELL__ | runghc -XCPP)" - if [ "$GHCVER" -gt "$1" ]; then - echo "Skipping test that needs GHC <= $1 (actual version $GHCVER)" - exit 0 - fi -} - -require_ghc_ge() { - GHCVER="$(echo main = print __GLASGOW_HASKELL__ | runghc -XCPP)" - if [ "$GHCVER" -lt "$1" ]; then - echo "Skipping test that needs GHC >= $1 (actual version $GHCVER)" - exit 0 - fi -} diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99998/Cabal.cabal b/cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99998/Cabal.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99998/Cabal.cabal +++ /dev/null @@ -1,8 +0,0 @@ -name: Cabal -version: 99998 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base - exposed-modules: CabalMessage diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99998/CabalMessage.hs b/cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99998/CabalMessage.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99998/CabalMessage.hs +++ /dev/null @@ -1,3 +0,0 @@ -module CabalMessage where - -message = "This is Cabal-99998" diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99999/Cabal.cabal b/cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99999/Cabal.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99999/Cabal.cabal +++ /dev/null @@ -1,8 +0,0 @@ -name: Cabal -version: 99999 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base - exposed-modules: CabalMessage diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99999/CabalMessage.hs b/cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99999/CabalMessage.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/Cabal-99999/CabalMessage.hs +++ /dev/null @@ -1,3 +0,0 @@ -module CabalMessage where - -message = "This is Cabal-99999" diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-old-cabal/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-old-cabal/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-old-cabal/Setup.hs +++ /dev/null @@ -1,5 +0,0 @@ -import CabalMessage (message) -import System.Exit -import System.IO - -main = hPutStrLn stderr message >> exitFailure diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-old-cabal/custom-setup-old-cabal.cabal b/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-old-cabal/custom-setup-old-cabal.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-old-cabal/custom-setup-old-cabal.cabal +++ /dev/null @@ -1,8 +0,0 @@ -name: custom-setup -version: 1.0 -build-type: Custom - -custom-setup - setup-depends: base, Cabal < 1.20 - -library diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal-defaultMain/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal-defaultMain/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal-defaultMain/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple - -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal-defaultMain/custom-setup-without-cabal-defaultMain.cabal b/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal-defaultMain/custom-setup-without-cabal-defaultMain.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal-defaultMain/custom-setup-without-cabal-defaultMain.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: custom-setup-without-cabal-defaultMain -version: 1.0 -build-type: Custom -cabal-version: >= 1.2 - -custom-setup - setup-depends: base - -library diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal/Setup.hs +++ /dev/null @@ -1,4 +0,0 @@ -import System.Exit -import System.IO - -main = hPutStrLn stderr "My custom Setup" >> exitFailure diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal/custom-setup-without-cabal.cabal b/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal/custom-setup-without-cabal.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup-without-cabal/custom-setup-without-cabal.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: custom-setup-without-cabal -version: 1.0 -build-type: Custom -cabal-version: >= 99999 - -custom-setup - setup-depends: base - -library diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup/Setup.hs +++ /dev/null @@ -1,5 +0,0 @@ -import CabalMessage (message) -import System.Exit -import System.IO - -main = hPutStrLn stderr message >> exitFailure diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup/custom-setup.cabal b/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup/custom-setup.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom-setup/custom-setup.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: custom-setup -version: 1.0 -build-type: Custom -cabal-version: >= 99999 - -custom-setup - setup-depends: base, Cabal >= 99999 - -library diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom_setup_without_Cabal_doesnt_allow_Cabal_import.sh b/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom_setup_without_Cabal_doesnt_allow_Cabal_import.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom_setup_without_Cabal_doesnt_allow_Cabal_import.sh +++ /dev/null @@ -1,12 +0,0 @@ -. ./common.sh -cd custom-setup-without-cabal-defaultMain - -# This package has explicit setup dependencies that do not include Cabal. -# Compilation should fail because Setup.hs imports Distribution.Simple. -! cabal new-build custom-setup-without-cabal-defaultMain > output 2>&1 -cat output -grep -q "\(Could not find module\|Failed to load interface for\).*Distribution\\.Simple" output \ - || die "Should not have been able to import Cabal" - -grep -q "It is a member of the hidden package .*Cabal-" output \ - || die "Cabal should be available" diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom_setup_without_Cabal_doesnt_require_Cabal.sh b/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom_setup_without_Cabal_doesnt_require_Cabal.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/custom_setup_without_Cabal_doesnt_require_Cabal.sh +++ /dev/null @@ -1,11 +0,0 @@ -. ./common.sh -cd custom-setup-without-cabal - -# This package has explicit setup dependencies that do not include Cabal. -# new-build should try to build it, even though the cabal-version cannot be -# satisfied by an installed version of Cabal (cabal-version: >= 99999). However, -# configure should fail because Setup.hs just prints an error message and exits. -! cabal new-build custom-setup-without-cabal > output 2>&1 -cat output -grep -q "My custom Setup" output \ - || die "Expected output from custom Setup" diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/installs_Cabal_as_setup_dep.sh b/cabal/cabal-install/tests/IntegrationTests/custom-setup/installs_Cabal_as_setup_dep.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/installs_Cabal_as_setup_dep.sh +++ /dev/null @@ -1,15 +0,0 @@ -# Regression test for issue #3436 - -. ./common.sh -cabal sandbox init -cabal install ./Cabal-99998 -cabal sandbox add-source Cabal-99999 - -# Install custom-setup, which has a setup dependency on Cabal-99999. -# cabal should build the setup script with Cabal-99999, but then -# configure should fail because Setup just prints an error message -# imported from Cabal and exits. -! cabal install custom-setup/ > output 2>&1 - -cat output -grep -q "This is Cabal-99999" output || die "Expected output from Cabal-99999" diff --git a/cabal/cabal-install/tests/IntegrationTests/custom-setup/new_build_requires_Cabal_1_20.sh b/cabal/cabal-install/tests/IntegrationTests/custom-setup/new_build_requires_Cabal_1_20.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom-setup/new_build_requires_Cabal_1_20.sh +++ /dev/null @@ -1,9 +0,0 @@ -# Regression test for issue #3932 - -. ./common.sh - -cd custom-setup-old-cabal -! cabal new-build > output 2>&1 - -cat output -grep -q "(issue #3932) requires >=1.20" output || die "Expect constraint failure" diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep.sh b/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep.sh +++ /dev/null @@ -1,22 +0,0 @@ -. ./common.sh - -# On Travis OSX, Cabal shipped with GHC 7.8 does not work -# with error "setup: /usr/bin/ar: permission denied"; see -# also https://github.com/haskell/cabal/issues/3938 -# This is a hack to make the test not run in this case. -if [ "$TRAVIS_OS_NAME" = "osx" ]; then - require_ghc_ge 710 -fi - -cd custom_dep -cabal sandbox init -cabal sandbox add-source custom -cabal sandbox add-source client -# Some care must be taken here: we want the Setup script -# to build against GHC's bundled Cabal, but passing -# --package-db=clear --package-db=global to cabal is -# insufficient, as these flags are NOT respected when -# building Setup scripts. Changing HOME to a location -# which definitely does not have a local .cabal -# directory works, the environment variable propagates to GHC. -HOME=`pwd` cabal install client diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/client/B.hs b/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/client/B.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/client/B.hs +++ /dev/null @@ -1,2 +0,0 @@ -module B where -import A diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/client/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/client/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/client/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/client/client.cabal b/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/client/client.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/client/client.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: client -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: B - build-depends: base, custom - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/custom/A.hs b/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/custom/A.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/custom/A.hs +++ /dev/null @@ -1,1 +0,0 @@ -module A where diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/custom/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/custom/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/custom/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/custom/custom.cabal b/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/custom/custom.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/custom_dep/custom/custom.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: custom -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Custom -cabal-version: >=1.10 - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/plain.sh b/cabal/cabal-install/tests/IntegrationTests/custom/plain.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/plain.sh +++ /dev/null @@ -1,15 +0,0 @@ -. ./common.sh - -# On Travis OSX, Cabal shipped with GHC 7.8 does not work -# with error "setup: /usr/bin/ar: permission denied"; see -# also https://github.com/haskell/cabal/issues/3938 -# This is a hack to make the test not run in this case. -if [ "$TRAVIS_OS_NAME" = "osx" ]; then - require_ghc_ge 710 -fi - -cd plain -cabal configure 2> log -grep Custom log -cabal build 2> log -grep Custom log diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/plain/A.hs b/cabal/cabal-install/tests/IntegrationTests/custom/plain/A.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/plain/A.hs +++ /dev/null @@ -1,1 +0,0 @@ -module A where diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/plain/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/custom/plain/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/plain/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -import System.IO -main = hPutStrLn stderr "Custom" >> defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/plain/plain.cabal b/cabal/cabal-install/tests/IntegrationTests/custom/plain/plain.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/plain/plain.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: plain -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Custom -cabal-version: >=1.10 - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/segfault.sh b/cabal/cabal-install/tests/IntegrationTests/custom/segfault.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/segfault.sh +++ /dev/null @@ -1,10 +0,0 @@ -. ./common.sh -if [ "x$(uname)" != "xLinux" ]; then - exit -fi -# Older GHCs don't report exit via signal adequately -require_ghc_ge 708 -cd segfault -! cabal new-build 2> log -cat log -grep SIGSEGV log diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/segfault/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/custom/segfault/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/segfault/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import System.Posix.Signals - -main = putStrLn "Quitting..." >> raiseSignal sigSEGV diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/segfault/cabal.project b/cabal/cabal-install/tests/IntegrationTests/custom/segfault/cabal.project deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/segfault/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: . diff --git a/cabal/cabal-install/tests/IntegrationTests/custom/segfault/plain.cabal b/cabal/cabal-install/tests/IntegrationTests/custom/segfault/plain.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/custom/segfault/plain.cabal +++ /dev/null @@ -1,14 +0,0 @@ -name: plain -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Custom -cabal-version: >=1.10 - -library - build-depends: base - default-language: Haskell2010 - -custom-setup - setup-depends: base, unix diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/Foo.hs b/cabal/cabal-install/tests/IntegrationTests/exec/Foo.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/Foo.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Foo where - -foo :: String -foo = "foo" diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/My.hs b/cabal/cabal-install/tests/IntegrationTests/exec/My.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/My.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main where - -main :: IO () -main = do - putStrLn "This is my-executable" diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/adds_sandbox_bin_directory_to_path.out b/cabal/cabal-install/tests/IntegrationTests/exec/adds_sandbox_bin_directory_to_path.out deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/adds_sandbox_bin_directory_to_path.out +++ /dev/null @@ -1,1 +0,0 @@ -This is my-executable diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/adds_sandbox_bin_directory_to_path.sh b/cabal/cabal-install/tests/IntegrationTests/exec/adds_sandbox_bin_directory_to_path.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/adds_sandbox_bin_directory_to_path.sh +++ /dev/null @@ -1,10 +0,0 @@ -. ./common.sh - -cabal sandbox delete > /dev/null -cabal exec my-executable && die "Unexpectedly found executable" - -cabal sandbox init > /dev/null -cabal install > /dev/null - -# Execute indirectly via bash to ensure that we go through $PATH -cabal exec sh -- -c my-executable || die "Did not find executable" diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/auto_configures_on_exec.out b/cabal/cabal-install/tests/IntegrationTests/exec/auto_configures_on_exec.out deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/auto_configures_on_exec.out +++ /dev/null @@ -1,4 +0,0 @@ -Config file path source is commandline option. -Config file config-file not found. -Writing default configuration to config-file -find_me_in_output diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/auto_configures_on_exec.sh b/cabal/cabal-install/tests/IntegrationTests/exec/auto_configures_on_exec.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/auto_configures_on_exec.sh +++ /dev/null @@ -1,2 +0,0 @@ -. ./common.sh -cabal exec echo find_me_in_output diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/can_run_executables_installed_in_sandbox.out b/cabal/cabal-install/tests/IntegrationTests/exec/can_run_executables_installed_in_sandbox.out deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/can_run_executables_installed_in_sandbox.out +++ /dev/null @@ -1,1 +0,0 @@ -This is my-executable diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/can_run_executables_installed_in_sandbox.sh b/cabal/cabal-install/tests/IntegrationTests/exec/can_run_executables_installed_in_sandbox.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/can_run_executables_installed_in_sandbox.sh +++ /dev/null @@ -1,9 +0,0 @@ -. ./common.sh - -cabal sandbox delete > /dev/null -cabal exec my-executable && die "Unexpectedly found executable" - -cabal sandbox init > /dev/null -cabal install > /dev/null - -cabal exec my-executable || die "Did not find executable" diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/configures_cabal_to_use_sandbox.sh b/cabal/cabal-install/tests/IntegrationTests/exec/configures_cabal_to_use_sandbox.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/configures_cabal_to_use_sandbox.sh +++ /dev/null @@ -1,14 +0,0 @@ -. ./common.sh - -cabal sandbox delete > /dev/null -cabal exec my-executable && die "Unexpectedly found executable" - -cabal sandbox init > /dev/null -cabal install > /dev/null - -# The library should not be available outside the sandbox -"$GHC_PKG" list | grep -v "my-0.1" - -# When run inside 'cabal-exec' the 'sandbox hc-pkg list' sub-command -# should find the library. -cabal exec sh -- -c 'cd subdir && "$CABAL" sandbox hc-pkg list' | grep "my-0.1" diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/configures_ghc_to_use_sandbox.sh b/cabal/cabal-install/tests/IntegrationTests/exec/configures_ghc_to_use_sandbox.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/configures_ghc_to_use_sandbox.sh +++ /dev/null @@ -1,13 +0,0 @@ -. ./common.sh - -cabal sandbox delete > /dev/null -cabal exec my-executable && die "Unexpectedly found executable" - -cabal sandbox init > /dev/null -cabal install > /dev/null - -# The library should not be available outside the sandbox -"$GHC_PKG" list | grep -v "my-0.1" - -# Execute ghc-pkg inside the sandbox; it should find my-0.1 -cabal exec ghc-pkg list | grep "my-0.1" diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/exit_with_failure_without_args.err b/cabal/cabal-install/tests/IntegrationTests/exec/exit_with_failure_without_args.err deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/exit_with_failure_without_args.err +++ /dev/null @@ -1,1 +0,0 @@ -RE:^cabal(\.exe)?: Please specify an executable to run$ diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/exit_with_failure_without_args.sh b/cabal/cabal-install/tests/IntegrationTests/exec/exit_with_failure_without_args.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/exit_with_failure_without_args.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh - -! cabal exec diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/my.cabal b/cabal/cabal-install/tests/IntegrationTests/exec/my.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/my.cabal +++ /dev/null @@ -1,14 +0,0 @@ -name: my -version: 0.1 -license: BSD3 -cabal-version: >= 1.2 -build-type: Simple - -library - exposed-modules: Foo - build-depends: base - - -executable my-executable - main-is: My.hs - build-depends: base diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/runs_given_command.out b/cabal/cabal-install/tests/IntegrationTests/exec/runs_given_command.out deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/runs_given_command.out +++ /dev/null @@ -1,1 +0,0 @@ -this string diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/runs_given_command.sh b/cabal/cabal-install/tests/IntegrationTests/exec/runs_given_command.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/runs_given_command.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh -cabal configure > /dev/null -cabal exec echo this string diff --git a/cabal/cabal-install/tests/IntegrationTests/exec/subdir/.gitkeep b/cabal/cabal-install/tests/IntegrationTests/exec/subdir/.gitkeep deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/exec/subdir/.gitkeep +++ /dev/null diff --git a/cabal/cabal-install/tests/IntegrationTests/freeze/disable_benchmarks_freezes_bench_deps.sh b/cabal/cabal-install/tests/IntegrationTests/freeze/disable_benchmarks_freezes_bench_deps.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/freeze/disable_benchmarks_freezes_bench_deps.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh -cabal freeze --disable-benchmarks -grep -v " criterion ==" cabal.config || die "should NOT have frozen criterion" diff --git a/cabal/cabal-install/tests/IntegrationTests/freeze/disable_tests_freezes_test_deps.sh b/cabal/cabal-install/tests/IntegrationTests/freeze/disable_tests_freezes_test_deps.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/freeze/disable_tests_freezes_test_deps.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh -cabal freeze --disable-tests -grep -v " test-framework ==" cabal.config || die "should NOT have frozen test-framework" diff --git a/cabal/cabal-install/tests/IntegrationTests/freeze/does_not_freeze_nondeps.sh b/cabal/cabal-install/tests/IntegrationTests/freeze/does_not_freeze_nondeps.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/freeze/does_not_freeze_nondeps.sh +++ /dev/null @@ -1,5 +0,0 @@ -. ./common.sh -# TODO: Test this against a package installed in the sandbox but not -# depended upon. -cabal freeze -grep -v "exceptions ==" cabal.config || die "should not have frozen exceptions" diff --git a/cabal/cabal-install/tests/IntegrationTests/freeze/does_not_freeze_self.sh b/cabal/cabal-install/tests/IntegrationTests/freeze/does_not_freeze_self.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/freeze/does_not_freeze_self.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh -cabal freeze -grep -v " my ==" cabal.config || die "should not have frozen self" diff --git a/cabal/cabal-install/tests/IntegrationTests/freeze/dry_run_does_not_create_config.sh b/cabal/cabal-install/tests/IntegrationTests/freeze/dry_run_does_not_create_config.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/freeze/dry_run_does_not_create_config.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh -cabal freeze --dry-run -[ ! -e cabal.config ] || die "cabal.config file should not have been created" diff --git a/cabal/cabal-install/tests/IntegrationTests/freeze/enable_benchmarks_freezes_bench_deps.sh b/cabal/cabal-install/tests/IntegrationTests/freeze/enable_benchmarks_freezes_bench_deps.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/freeze/enable_benchmarks_freezes_bench_deps.sh +++ /dev/null @@ -1,4 +0,0 @@ -. ./common.sh -# TODO: solver should find solution without extra flags too -cabal freeze --enable-benchmarks --reorder-goals --max-backjumps=-1 -grep " criterion ==" cabal.config || die "should have frozen criterion" diff --git a/cabal/cabal-install/tests/IntegrationTests/freeze/enable_tests_freezes_test_deps.sh b/cabal/cabal-install/tests/IntegrationTests/freeze/enable_tests_freezes_test_deps.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/freeze/enable_tests_freezes_test_deps.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh -cabal freeze --enable-tests -grep " test-framework ==" cabal.config || die "should have frozen test-framework" diff --git a/cabal/cabal-install/tests/IntegrationTests/freeze/freezes_direct_dependencies.sh b/cabal/cabal-install/tests/IntegrationTests/freeze/freezes_direct_dependencies.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/freeze/freezes_direct_dependencies.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh -cabal freeze -grep " base ==" cabal.config || die "'base' should have been frozen" diff --git a/cabal/cabal-install/tests/IntegrationTests/freeze/freezes_transitive_dependencies.sh b/cabal/cabal-install/tests/IntegrationTests/freeze/freezes_transitive_dependencies.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/freeze/freezes_transitive_dependencies.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh -cabal freeze -grep " ghc-prim ==" cabal.config || die "'ghc-prim' should have been frozen" diff --git a/cabal/cabal-install/tests/IntegrationTests/freeze/my.cabal b/cabal/cabal-install/tests/IntegrationTests/freeze/my.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/freeze/my.cabal +++ /dev/null @@ -1,21 +0,0 @@ -name: my -version: 0.1 -license: BSD3 -cabal-version: >= 1.20.0 -build-type: Simple - -library - exposed-modules: Foo - build-depends: base - -test-suite test-Foo - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: test-Foo.hs - build-depends: base, my, test-framework - -benchmark bench-Foo - type: exitcode-stdio-1.0 - hs-source-dirs: benchmarks - main-is: benchmark-Foo.hs - build-depends: base, my, criterion diff --git a/cabal/cabal-install/tests/IntegrationTests/freeze/runs_without_error.sh b/cabal/cabal-install/tests/IntegrationTests/freeze/runs_without_error.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/freeze/runs_without_error.sh +++ /dev/null @@ -1,2 +0,0 @@ -. ./common.sh -cabal freeze diff --git a/cabal/cabal-install/tests/IntegrationTests/internal-libs/cabal.project b/cabal/cabal-install/tests/IntegrationTests/internal-libs/cabal.project deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/internal-libs/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: p q diff --git a/cabal/cabal-install/tests/IntegrationTests/internal-libs/internal_lib_basic.sh b/cabal/cabal-install/tests/IntegrationTests/internal-libs/internal_lib_basic.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/internal-libs/internal_lib_basic.sh +++ /dev/null @@ -1,5 +0,0 @@ -. ./common.sh - -cabal sandbox init -cabal sandbox add-source p -cabal install p diff --git a/cabal/cabal-install/tests/IntegrationTests/internal-libs/internal_lib_shadow.sh b/cabal/cabal-install/tests/IntegrationTests/internal-libs/internal_lib_shadow.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/internal-libs/internal_lib_shadow.sh +++ /dev/null @@ -1,6 +0,0 @@ -. ./common.sh - -cabal sandbox init -cabal sandbox add-source p -cabal sandbox add-source q -cabal install p diff --git a/cabal/cabal-install/tests/IntegrationTests/internal-libs/new_build.sh b/cabal/cabal-install/tests/IntegrationTests/internal-libs/new_build.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/internal-libs/new_build.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh - -cabal new-build p diff --git a/cabal/cabal-install/tests/IntegrationTests/internal-libs/p/Foo.hs b/cabal/cabal-install/tests/IntegrationTests/internal-libs/p/Foo.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/internal-libs/p/Foo.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Q -main = putStrLn q diff --git a/cabal/cabal-install/tests/IntegrationTests/internal-libs/p/p.cabal b/cabal/cabal-install/tests/IntegrationTests/internal-libs/p/p.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/internal-libs/p/p.cabal +++ /dev/null @@ -1,23 +0,0 @@ -name: p -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.23 - -library q - build-depends: base - exposed-modules: Q - hs-source-dirs: q - default-language: Haskell2010 - -library - build-depends: base, q - exposed-modules: P - hs-source-dirs: p - default-language: Haskell2010 - -executable foo - build-depends: base, q - main-is: Foo.hs diff --git a/cabal/cabal-install/tests/IntegrationTests/internal-libs/p/p/P.hs b/cabal/cabal-install/tests/IntegrationTests/internal-libs/p/p/P.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/internal-libs/p/p/P.hs +++ /dev/null @@ -1,2 +0,0 @@ -module P where -import Q diff --git a/cabal/cabal-install/tests/IntegrationTests/internal-libs/p/q/Q.hs b/cabal/cabal-install/tests/IntegrationTests/internal-libs/p/q/Q.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/internal-libs/p/q/Q.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Q where -q = "I AM THE ONE" diff --git a/cabal/cabal-install/tests/IntegrationTests/internal-libs/q/Q.hs b/cabal/cabal-install/tests/IntegrationTests/internal-libs/q/Q.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/internal-libs/q/Q.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Q where -q = "DO NOT SEE ME" diff --git a/cabal/cabal-install/tests/IntegrationTests/internal-libs/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests/internal-libs/q/q.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/internal-libs/q/q.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: q -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: Q - build-depends: base - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/manpage/outputs_manpage.sh b/cabal/cabal-install/tests/IntegrationTests/manpage/outputs_manpage.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/manpage/outputs_manpage.sh +++ /dev/null @@ -1,11 +0,0 @@ -. ./common.sh - -OUTPUT=`cabal manpage` - -# contains visible command descriptions -echo $OUTPUT | grep -q '\.B cabal install' || die "visible command description line not found in:\n----$OUTPUT\n----" - -# does not contain hidden command descriptions -echo $OUTPUT | grep -q '\.B cabal manpage' && die "hidden command description line found in:\n----$OUTPUT\n----" - -exit 0 diff --git a/cabal/cabal-install/tests/IntegrationTests/multiple-source/finds_second_source_of_multiple_source.sh b/cabal/cabal-install/tests/IntegrationTests/multiple-source/finds_second_source_of_multiple_source.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/multiple-source/finds_second_source_of_multiple_source.sh +++ /dev/null @@ -1,11 +0,0 @@ -. ./common.sh - -# Create the sandbox -cabal sandbox init - -# Add the sources -cabal sandbox add-source p -cabal sandbox add-source q - -# Install the second package -cabal install q diff --git a/cabal/cabal-install/tests/IntegrationTests/multiple-source/p/LICENSE b/cabal/cabal-install/tests/IntegrationTests/multiple-source/p/LICENSE deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/multiple-source/p/LICENSE +++ /dev/null diff --git a/cabal/cabal-install/tests/IntegrationTests/multiple-source/p/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/multiple-source/p/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/multiple-source/p/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/multiple-source/p/p.cabal b/cabal/cabal-install/tests/IntegrationTests/multiple-source/p/p.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/multiple-source/p/p.cabal +++ /dev/null @@ -1,11 +0,0 @@ -name: p -version: 0.1.0.0 -license-file: LICENSE -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -library - build-depends: base - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/multiple-source/q/LICENSE b/cabal/cabal-install/tests/IntegrationTests/multiple-source/q/LICENSE deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/multiple-source/q/LICENSE +++ /dev/null diff --git a/cabal/cabal-install/tests/IntegrationTests/multiple-source/q/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/multiple-source/q/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/multiple-source/q/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/multiple-source/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests/multiple-source/q/q.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/multiple-source/q/q.cabal +++ /dev/null @@ -1,11 +0,0 @@ -name: q -version: 0.1.0.0 -license-file: LICENSE -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -library - build-depends: base - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath.sh b/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh -cd BuildToolsPath -cabal new-build build-tools-path hello-world diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/A.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/A.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/A.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF my-custom-preprocessor #-} -module A where - -a :: String -a = "0000" diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/MyCustomPreprocessor.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/MyCustomPreprocessor.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/MyCustomPreprocessor.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Main where - -import System.Environment -import System.IO - -main :: IO () -main = do - (_:source:target:_) <- getArgs - let f '0' = '1' - f c = c - writeFile target . map f =<< readFile source diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/build-tools-path.cabal b/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/build-tools-path.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/build-tools-path.cabal +++ /dev/null @@ -1,25 +0,0 @@ -name: build-tools-path -version: 0.1.0.0 -synopsis: Checks build-tools are put in PATH -license: BSD3 -category: Testing -build-type: Simple -cabal-version: >=1.10 - -executable my-custom-preprocessor - main-is: MyCustomPreprocessor.hs - build-depends: base, directory - default-language: Haskell2010 - -library - exposed-modules: A - build-depends: base - build-tools: my-custom-preprocessor - -- ^ Note the internal dependency. - default-language: Haskell2010 - -executable hello-world - main-is: Hello.hs - build-depends: base, build-tools-path - default-language: Haskell2010 - hs-source-dirs: hello diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/cabal.project b/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/cabal.project deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: . diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/hello/Hello.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/hello/Hello.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/hello/Hello.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import A - -main :: IO () -main = putStrLn a diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460.sh b/cabal/cabal-install/tests/IntegrationTests/new-build/T3460.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh -cd T3460 -cabal new-build -j T3460 diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/C.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/C.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/C.hs +++ /dev/null @@ -1,3 +0,0 @@ -module C where -import A -import B diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/T3460.cabal b/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/T3460.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/T3460.cabal +++ /dev/null @@ -1,22 +0,0 @@ --- Initial T3460.cabal generated by cabal init. For further documentation, --- see http://haskell.org/cabal/users-guide/ - -name: T3460 -version: 0.1.0.0 --- synopsis: --- description: -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu --- copyright: --- category: -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: C - -- other-modules: - -- other-extensions: - build-depends: base, sub-package-A, sub-package-B - -- hs-source-dirs: - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/cabal.project b/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/cabal.project deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/cabal.project +++ /dev/null @@ -1,3 +0,0 @@ -packages: ./T3460.cabal - , ./sub-package-A - , ./sub-package-B diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-A/A.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-A/A.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-A/A.hs +++ /dev/null @@ -1,1 +0,0 @@ -module A where diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-A/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-A/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-A/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-A/sub-package-A.cabal b/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-A/sub-package-A.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-A/sub-package-A.cabal +++ /dev/null @@ -1,22 +0,0 @@ --- Initial sub-package-A.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: sub-package-A -version: 0.1.0.0 --- synopsis: --- description: -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu --- copyright: --- category: -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: A - -- other-modules: - -- other-extensions: - build-depends: base - -- hs-source-dirs: - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-B/B.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-B/B.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-B/B.hs +++ /dev/null @@ -1,1 +0,0 @@ -module B where diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-B/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-B/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-B/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-B/sub-package-B.cabal b/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-B/sub-package-B.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3460/sub-package-B/sub-package-B.cabal +++ /dev/null @@ -1,22 +0,0 @@ --- Initial sub-package-B.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: sub-package-B -version: 0.1.0.0 --- synopsis: --- description: -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu --- copyright: --- category: -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: B - -- other-modules: - -- other-extensions: - build-depends: base - -- hs-source-dirs: - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3978.err b/cabal/cabal-install/tests/IntegrationTests/new-build/T3978.err deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3978.err +++ /dev/null @@ -1,1 +0,0 @@ -RE:^cabal(\.exe)?: The package q-1.0 depends on unbuildable libraries: p-1.0 diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3978.sh b/cabal/cabal-install/tests/IntegrationTests/new-build/T3978.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3978.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh -cd T3978 -! cabal new-build q diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3978/cabal.project b/cabal/cabal-install/tests/IntegrationTests/new-build/T3978/cabal.project deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3978/cabal.project +++ /dev/null @@ -1,2 +0,0 @@ -packages: p q -allow-older: p:base diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3978/p/p.cabal b/cabal/cabal-install/tests/IntegrationTests/new-build/T3978/p/p.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3978/p/p.cabal +++ /dev/null @@ -1,7 +0,0 @@ -name: p -version: 1.0 -build-type: Simple -cabal-version: >= 1.10 - -library - buildable: False diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T3978/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests/new-build/T3978/q/q.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T3978/q/q.cabal +++ /dev/null @@ -1,7 +0,0 @@ -name: q -version: 1.0 -build-type: Simple -cabal-version: >= 1.10 - -library - build-depends: p diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T4017.sh b/cabal/cabal-install/tests/IntegrationTests/new-build/T4017.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T4017.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh -cd T4017 -cabal new-build q diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T4017/cabal.project b/cabal/cabal-install/tests/IntegrationTests/new-build/T4017/cabal.project deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T4017/cabal.project +++ /dev/null @@ -1,2 +0,0 @@ -packages: p q -allow-older: p:base diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T4017/p/p.cabal b/cabal/cabal-install/tests/IntegrationTests/new-build/T4017/p/p.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T4017/p/p.cabal +++ /dev/null @@ -1,7 +0,0 @@ -name: p -version: 1.0 -build-type: Simple -cabal-version: >= 1.10 - -library - build-depends: base >= 99999 diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/T4017/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests/new-build/T4017/q/q.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/T4017/q/q.cabal +++ /dev/null @@ -1,7 +0,0 @@ -name: q -version: 1.0 -build-type: Simple -cabal-version: >= 1.10 - -library - build-depends: p diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/executable/Main.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/executable/Main.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/executable/Main.hs +++ /dev/null @@ -1,1 +0,0 @@ -main = return () diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/executable/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/executable/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/executable/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/executable/Test.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/executable/Test.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/executable/Test.hs +++ /dev/null @@ -1,1 +0,0 @@ -main = return () diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/executable/a.cabal b/cabal/cabal-install/tests/IntegrationTests/new-build/executable/a.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/executable/a.cabal +++ /dev/null @@ -1,15 +0,0 @@ -name: a -version: 0.1 -cabal-version: >= 1.10 -build-type: Simple - -executable aexe - main-is: Main.hs - build-depends: base - default-language: Haskell2010 - -test-suite atest - type: exitcode-stdio-1.0 - main-is: Test.hs - build-depends: base - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/executable/cabal.project b/cabal/cabal-install/tests/IntegrationTests/new-build/executable/cabal.project deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/executable/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: . diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools.sh b/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools.sh +++ /dev/null @@ -1,3 +0,0 @@ -. ./common.sh -cd external_build_tools -cabal new-build client diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/cabal.project b/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/cabal.project deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: client, happy diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/client/Hello.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/client/Hello.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/client/Hello.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF happy #-} -module Main where - -a :: String -a = "0000" - -main :: IO () -main = putStrLn a diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/client/client.cabal b/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/client/client.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/client/client.cabal +++ /dev/null @@ -1,13 +0,0 @@ -name: client -version: 0.1.0.0 -synopsis: Checks build-tools are put in PATH -license: BSD3 -category: Testing -build-type: Simple -cabal-version: >=1.10 - -executable hello-world - main-is: Hello.hs - build-depends: base - build-tools: happy - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/happy/MyCustomPreprocessor.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/happy/MyCustomPreprocessor.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/happy/MyCustomPreprocessor.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Main where - -import System.Environment -import System.IO - -main :: IO () -main = do - (_:source:target:_) <- getArgs - let f '0' = '1' - f c = c - writeFile target . map f =<< readFile source diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/happy/happy.cabal b/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/happy/happy.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/external_build_tools/happy/happy.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: happy -version: 999.999.999 -synopsis: Checks build-tools on legacy package name are put in PATH -license: BSD3 -category: Testing -build-type: Simple -cabal-version: >=1.10 - -executable happy - main-is: MyCustomPreprocessor.hs - build-depends: base, directory - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files.sh b/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files.sh +++ /dev/null @@ -1,8 +0,0 @@ -. ./common.sh -cd monitor_cabal_files -cp q/q-broken.cabal.in q/q.cabal -echo "Run 1" | awk '{print;print > "/dev/stderr"}' -! cabal new-build q -cp q/q-fixed.cabal.in q/q.cabal -echo "Run 2" | awk '{print;print > "/dev/stderr"}' -cabal new-build q diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/.gitignore b/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/.gitignore deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/.gitignore +++ /dev/null @@ -1,1 +0,0 @@ -q/q.cabal diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/cabal.project b/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/cabal.project deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/cabal.project +++ /dev/null @@ -1,4 +0,0 @@ -packages: p/p.cabal q/ - --- use both matching a .cabal file, and a dir --- since these are slightly different code paths diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs +++ /dev/null @@ -1,1 +0,0 @@ -module P where diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/p/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/p/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/p/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/p/p.cabal b/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/p/p.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/p/p.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: p -version: 1.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: P - build-depends: base - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where -import P -main :: IO () -main = return () diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-broken.cabal.in b/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-broken.cabal.in deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-broken.cabal.in +++ /dev/null @@ -1,12 +0,0 @@ -name: q -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -executable q - main-is: Main.hs - build-depends: base - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-fixed.cabal.in b/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-fixed.cabal.in deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/new-build/monitor_cabal_files/q/q-fixed.cabal.in +++ /dev/null @@ -1,12 +0,0 @@ -name: q -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -executable q - main-is: Main.hs - build-depends: base, p - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/regression/t2755.sh b/cabal/cabal-install/tests/IntegrationTests/regression/t2755.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/regression/t2755.sh +++ /dev/null @@ -1,6 +0,0 @@ -. ./common.sh - -cd t2755 -cabal configure --enable-tests -(cabal test || true) | tee result.log -! grep "Re-configuring" result.log > /dev/null diff --git a/cabal/cabal-install/tests/IntegrationTests/regression/t2755/A.hs b/cabal/cabal-install/tests/IntegrationTests/regression/t2755/A.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/regression/t2755/A.hs +++ /dev/null @@ -1,1 +0,0 @@ -module A where diff --git a/cabal/cabal-install/tests/IntegrationTests/regression/t2755/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/regression/t2755/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/regression/t2755/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/regression/t2755/test-t2755.cabal b/cabal/cabal-install/tests/IntegrationTests/regression/t2755/test-t2755.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/regression/t2755/test-t2755.cabal +++ /dev/null @@ -1,13 +0,0 @@ -name: test-t2755 -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -category: Test -build-type: Simple -cabal-version: >=1.10 - -library - exposed-modules: A - build-depends: base - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/regression/t3199.sh b/cabal/cabal-install/tests/IntegrationTests/regression/t3199.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/regression/t3199.sh +++ /dev/null @@ -1,12 +0,0 @@ -. ./common.sh - -if [[ `ghc --numeric-version` =~ "7\\." ]]; then - cd t3199 - tmpfile=$(mktemp /tmp/cabal-t3199.XXXXXX) - cabal sandbox init - cabal sandbox add-source ../../../../../Cabal - cabal install --package-db=clear --package-db=global --only-dep --dry-run > $tmpfile - grep -q "the following would be installed" $tmpfile || die "Should've installed Cabal" - grep -q Cabal $tmpfile || die "Should've installed Cabal" - rm $tmpfile -fi diff --git a/cabal/cabal-install/tests/IntegrationTests/regression/t3199/Main.hs b/cabal/cabal-install/tests/IntegrationTests/regression/t3199/Main.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/regression/t3199/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = putStrLn "Hello, Haskell!" diff --git a/cabal/cabal-install/tests/IntegrationTests/regression/t3199/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/regression/t3199/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/regression/t3199/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/regression/t3199/test-3199.cabal b/cabal/cabal-install/tests/IntegrationTests/regression/t3199/test-3199.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/regression/t3199/test-3199.cabal +++ /dev/null @@ -1,27 +0,0 @@ -name: test-t3199 -version: 0.1.0.0 -license: BSD3 -author: Mikhail Glushenkov -maintainer: mikhail.glushenkov@gmail.com -category: Test -build-type: Custom -cabal-version: >=1.10 - -flag exe_2 - description: Build second exe - default: False - -executable test-3199-1 - main-is: Main.hs - build-depends: base - default-language: Haskell2010 - -executable test-3199-2 - main-is: Main.hs - build-depends: base, ansi-terminal - default-language: Haskell2010 - - if flag(exe_2) - buildable: True - else - buildable: False diff --git a/cabal/cabal-install/tests/IntegrationTests/regression/t3827.sh b/cabal/cabal-install/tests/IntegrationTests/regression/t3827.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/regression/t3827.sh +++ /dev/null @@ -1,4 +0,0 @@ -. ./common.sh - -cd t3827 -cabal new-build exe:q diff --git a/cabal/cabal-install/tests/IntegrationTests/regression/t3827/cabal.project b/cabal/cabal-install/tests/IntegrationTests/regression/t3827/cabal.project deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/regression/t3827/cabal.project +++ /dev/null @@ -1,4 +0,0 @@ -packages: p q -profiling-detail: all-functions -package q - profiling: True diff --git a/cabal/cabal-install/tests/IntegrationTests/regression/t3827/p/P.hs b/cabal/cabal-install/tests/IntegrationTests/regression/t3827/p/P.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/regression/t3827/p/P.hs +++ /dev/null @@ -1,2 +0,0 @@ -module P where -p = True diff --git a/cabal/cabal-install/tests/IntegrationTests/regression/t3827/p/p.cabal b/cabal/cabal-install/tests/IntegrationTests/regression/t3827/p/p.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/regression/t3827/p/p.cabal +++ /dev/null @@ -1,8 +0,0 @@ -name: p -version: 1.0 -build-type: Simple -cabal-version: >= 1.10 - -library - build-depends: base - exposed-modules: P diff --git a/cabal/cabal-install/tests/IntegrationTests/regression/t3827/q/Main.hs b/cabal/cabal-install/tests/IntegrationTests/regression/t3827/q/Main.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/regression/t3827/q/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Main where -import P -main = print p diff --git a/cabal/cabal-install/tests/IntegrationTests/regression/t3827/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests/regression/t3827/q/q.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/regression/t3827/q/q.cabal +++ /dev/null @@ -1,8 +0,0 @@ -name: q -version: 1.0 -build-type: Simple -cabal-version: >= 1.10 - -executable q - build-depends: base, p - main-is: Main.hs diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/p/Main.hs b/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/p/Main.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/p/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Q (message) - -main :: IO () -main = putStrLn message diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/p/p.cabal b/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/p/p.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/p/p.cabal +++ /dev/null @@ -1,8 +0,0 @@ -name: p -version: 1.0 -build-type: Simple -cabal-version: >= 1.2 - -executable p - main-is: Main.hs - build-depends: q, base diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/q/Q.hs b/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/q/Q.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/q/Q.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Q where - -message :: String -message = "message" diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/q/q.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/q/q.cabal +++ /dev/null @@ -1,8 +0,0 @@ -name: q -version: 1.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base - exposed-modules: Q diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/reinstall-modified-source.sh b/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/reinstall-modified-source.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-reinstalls/reinstall-modified-source.sh +++ /dev/null @@ -1,16 +0,0 @@ -. ./common.sh - -cd p -cabal sandbox init -cabal sandbox add-source ../q - -cabal install --only-dependencies -cabal run p -v0 | grep -q '^message$' \ - || die "Expected \"message\" in p's output." - -sleep 1 -# Append to the string that p imports from q and prints: -echo ' ++ " updated"' >> ../q/Q.hs - -cabal run p -v0 | grep -q '^message updated$' \ - || die "Expected \"message updated\" in p's output." diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/fail_removing_source_thats_not_registered.err b/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/fail_removing_source_thats_not_registered.err deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/fail_removing_source_thats_not_registered.err +++ /dev/null @@ -1,3 +0,0 @@ -Warning: Sources not registered: "q" - -RE:^cabal(\.exe)?: The sources with the above errors were skipped\. \("q"\)$ diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/fail_removing_source_thats_not_registered.sh b/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/fail_removing_source_thats_not_registered.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/fail_removing_source_thats_not_registered.sh +++ /dev/null @@ -1,10 +0,0 @@ -. ./common.sh - -# Create the sandbox -cabal sandbox init > /dev/null - -# Add one source -cabal sandbox add-source p > /dev/null - -# Remove a source that exists on disk, but is not registered -! cabal sandbox delete-source q diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/p/LICENSE b/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/p/LICENSE deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/p/LICENSE +++ /dev/null diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/p/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/p/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/p/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/p/p.cabal b/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/p/p.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/p/p.cabal +++ /dev/null @@ -1,11 +0,0 @@ -name: p -version: 0.1.0.0 -license-file: LICENSE -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -library - build-depends: base - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/q/LICENSE b/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/q/LICENSE deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/q/LICENSE +++ /dev/null diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/q/Setup.hs b/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/q/Setup.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/q/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/q/q.cabal deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/q/q.cabal +++ /dev/null @@ -1,11 +0,0 @@ -name: q -version: 0.1.0.0 -license-file: LICENSE -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.10 - -library - build-depends: base - default-language: Haskell2010 diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/remove_nonexistent_source.sh b/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/remove_nonexistent_source.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/remove_nonexistent_source.sh +++ /dev/null @@ -1,22 +0,0 @@ -. ./common.sh - -# Create the sandbox -cabal sandbox init - -# Add the sources -cabal sandbox add-source p -cabal sandbox add-source q - -# delete the directory on disk -rm -R p - -# Remove the registered source which is no longer on disk. cabal's handling of -# non-existent sources depends on the behavior of the directory package. -if OUTPUT=`cabal sandbox delete-source p 2>&1`; then - # 'canonicalizePath' should always succeed with directory >= 1.2.3.0 - echo $OUTPUT | grep 'Success deleting sources: "p"' \ - || die "Incorrect success message: $OUTPUT" -else - echo $OUTPUT | grep 'Warning: Source directory not found for paths: "p"' \ - || die "Incorrect failure message: $OUTPUT" -fi diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/report_success_removing_source.out b/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/report_success_removing_source.out deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/report_success_removing_source.out +++ /dev/null @@ -1,6 +0,0 @@ -Success deleting sources: "p" "q" - -Note: 'sandbox delete-source' only unregisters the source dependency, but does -not remove the package from the sandbox package DB. - -Use 'sandbox hc-pkg -- unregister' to do that. diff --git a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/report_success_removing_source.sh b/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/report_success_removing_source.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/sandbox-sources/report_success_removing_source.sh +++ /dev/null @@ -1,11 +0,0 @@ -. ./common.sh - -# Create the sandbox -cabal sandbox init > /dev/null - -# Add the sources -cabal sandbox add-source p > /dev/null -cabal sandbox add-source q > /dev/null - -# Remove one of the sources -cabal sandbox delete-source p q diff --git a/cabal/cabal-install/tests/IntegrationTests/user-config/cabal-config b/cabal/cabal-install/tests/IntegrationTests/user-config/cabal-config deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/user-config/cabal-config +++ /dev/null @@ -1,182 +0,0 @@ --- This is the configuration file for the 'cabal' command line tool. - --- The available configuration options are listed below. --- Some of them have default values listed. - --- Lines (like this one) beginning with '--' are comments. --- Be careful with spaces and indentation because they are --- used to indicate layout for nested sections. - - -repository hackage.haskell.org - url: http://hackage.haskell.org/ - --- default-user-config: --- require-sandbox: False --- ignore-sandbox: False --- ignore-expiry: False --- http-transport: -remote-repo-cache: /home/gman/.cabal/packages --- local-repo: --- logs-dir: -world-file: /home/gman/.cabal/world --- verbose: 1 --- compiler: ghc --- with-compiler: --- with-hc-pkg: --- program-prefix: --- program-suffix: --- library-vanilla: True --- library-profiling: --- shared: --- executable-dynamic: False --- profiling: --- executable-profiling: --- profiling-detail: --- library-profiling-detail: --- optimization: True --- debug-info: False --- library-for-ghci: --- split-objs: False --- executable-stripping: True --- library-stripping: True --- configure-option: --- user-install: True --- package-db: --- flags: --- extra-include-dirs: --- extra-lib-dirs: -extra-prog-path: /home/gman/.cabal/bin --- tests: False --- coverage: False --- library-coverage: --- exact-configuration: False --- benchmarks: False --- relocatable: False --- cabal-lib-version: --- constraint: --- preference: --- solver: choose --- allow-newer: False --- documentation: False --- doc-index-file: $datadir/doc/$arch-$os-$compiler/index.html --- max-backjumps: 2000 --- reorder-goals: False --- shadow-installed-packages: False --- strong-flags: False --- reinstall: False --- avoid-reinstalls: False --- force-reinstalls: False --- upgrade-dependencies: False --- root-cmd: --- symlink-bindir: -build-summary: /home/gman/.cabal/logs/build.log --- build-log: -remote-build-reporting: anonymous --- report-planning-failure: False --- one-shot: False --- run-tests: -jobs: $ncpus --- offline: False --- username: --- password: --- password-command: --- builddir: - -haddock - -- keep-temp-files: False - -- hoogle: False - -- html: False - -- html-location: - -- for-hackage: False - -- executables: False - -- tests: False - -- benchmarks: False - -- all: - -- internal: False - -- css: - -- hyperlink-source: False - -- hscolour-css: - -- contents-location: - -install-dirs user - -- prefix: /home/gman/.cabal - -- bindir: $prefix/bin - -- libdir: $prefix/lib - -- libsubdir: $abi/$libname - -- libexecdir: $prefix/libexec - -- datadir: $prefix/share - -- datasubdir: $abi/$pkgid - -- docdir: $datadir/doc/$abi/$pkgid - -- htmldir: $docdir/html - -- haddockdir: $htmldir - -- sysconfdir: $prefix/etc - -install-dirs global - -- prefix: /usr/local - -- bindir: $prefix/bin - -- libdir: $prefix/lib - -- libsubdir: $abi/$libname - -- libexecdir: $prefix/libexec - -- datadir: $prefix/share - -- datasubdir: $abi/$pkgid - -- docdir: $datadir/doc/$abi/$pkgid - -- htmldir: $docdir/html - -- haddockdir: $htmldir - -- sysconfdir: $prefix/etc - -program-locations - -- alex-location: - -- ar-location: - -- c2hs-location: - -- cpphs-location: - -- gcc-location: - -- ghc-location: - -- ghc-pkg-location: - -- ghcjs-location: - -- ghcjs-pkg-location: - -- greencard-location: - -- haddock-location: - -- happy-location: - -- haskell-suite-location: - -- haskell-suite-pkg-location: - -- hmake-location: - -- hpc-location: - -- hsc2hs-location: - -- hscolour-location: - -- jhc-location: - -- ld-location: - -- lhc-location: - -- lhc-pkg-location: - -- pkg-config-location: - -- strip-location: - -- tar-location: - -- uhc-location: - -program-default-options - -- alex-options: - -- ar-options: - -- c2hs-options: - -- cpphs-options: - -- gcc-options: - -- ghc-options: - -- ghc-pkg-options: - -- ghcjs-options: - -- ghcjs-pkg-options: - -- greencard-options: - -- haddock-options: - -- happy-options: - -- haskell-suite-options: - -- haskell-suite-pkg-options: - -- hmake-options: - -- hpc-options: - -- hsc2hs-options: - -- hscolour-options: - -- jhc-options: - -- ld-options: - -- lhc-options: - -- lhc-pkg-options: - -- pkg-config-options: - -- strip-options: - -- tar-options: - -- uhc-options: diff --git a/cabal/cabal-install/tests/IntegrationTests/user-config/common.sh b/cabal/cabal-install/tests/IntegrationTests/user-config/common.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/user-config/common.sh +++ /dev/null @@ -1,9 +0,0 @@ -# Helper to run Cabal -cabal() { - "$CABAL" $CABAL_ARGS_NO_CONFIG_FILE "$@" -} - -die() { - echo "die: $@" - exit 1 -} diff --git a/cabal/cabal-install/tests/IntegrationTests/user-config/doesnt_overwrite_without_f.err b/cabal/cabal-install/tests/IntegrationTests/user-config/doesnt_overwrite_without_f.err deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/user-config/doesnt_overwrite_without_f.err +++ /dev/null @@ -1,1 +0,0 @@ -RE:^cabal(\.exe)?: \./cabal-config already exists\.$ diff --git a/cabal/cabal-install/tests/IntegrationTests/user-config/doesnt_overwrite_without_f.sh b/cabal/cabal-install/tests/IntegrationTests/user-config/doesnt_overwrite_without_f.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/user-config/doesnt_overwrite_without_f.sh +++ /dev/null @@ -1,5 +0,0 @@ -. ./common.sh - -rm -f ./cabal-config -cabal --config-file=./cabal-config user-config init > /dev/null -! cabal --config-file=./cabal-config user-config init diff --git a/cabal/cabal-install/tests/IntegrationTests/user-config/overwrites_with_f.out b/cabal/cabal-install/tests/IntegrationTests/user-config/overwrites_with_f.out deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/user-config/overwrites_with_f.out +++ /dev/null @@ -1,2 +0,0 @@ -Writing default configuration to ./cabal-config -Writing default configuration to ./cabal-config diff --git a/cabal/cabal-install/tests/IntegrationTests/user-config/overwrites_with_f.sh b/cabal/cabal-install/tests/IntegrationTests/user-config/overwrites_with_f.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/user-config/overwrites_with_f.sh +++ /dev/null @@ -1,9 +0,0 @@ -. ./common.sh - -rm -f ./cabal-config -cabal --config-file=./cabal-config user-config init \ - || die "Couldn't create config file" -cabal --config-file=./cabal-config user-config -f init \ - || die "Couldn't create config file" -test -e ./cabal-config || die "Config file doesn't exist" -rm -f ./cabal-config diff --git a/cabal/cabal-install/tests/IntegrationTests/user-config/runs_without_error.out b/cabal/cabal-install/tests/IntegrationTests/user-config/runs_without_error.out deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/user-config/runs_without_error.out +++ /dev/null @@ -1,1 +0,0 @@ -Writing default configuration to ./cabal-config diff --git a/cabal/cabal-install/tests/IntegrationTests/user-config/runs_without_error.sh b/cabal/cabal-install/tests/IntegrationTests/user-config/runs_without_error.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/user-config/runs_without_error.sh +++ /dev/null @@ -1,7 +0,0 @@ -. ./common.sh - -rm -f ./cabal-config -cabal --config-file=./cabal-config user-config init \ - || die "Couldn't create config file" -test -e ./cabal-config || die "Config file doesn't exist" -rm -f ./cabal-config diff --git a/cabal/cabal-install/tests/IntegrationTests/user-config/uses_CABAL_CONFIG.out b/cabal/cabal-install/tests/IntegrationTests/user-config/uses_CABAL_CONFIG.out deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/user-config/uses_CABAL_CONFIG.out +++ /dev/null @@ -1,1 +0,0 @@ -Writing default configuration to ./my-config diff --git a/cabal/cabal-install/tests/IntegrationTests/user-config/uses_CABAL_CONFIG.sh b/cabal/cabal-install/tests/IntegrationTests/user-config/uses_CABAL_CONFIG.sh deleted file mode 100644 --- a/cabal/cabal-install/tests/IntegrationTests/user-config/uses_CABAL_CONFIG.sh +++ /dev/null @@ -1,5 +0,0 @@ -. ./common.sh - -export CABAL_CONFIG=./my-config -cabal user-config init || die "Couldn't create config file" -test -e ./my-config || die "Config file doesn't exist" 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 @@ -1,435 +1,1709 @@ {-# LANGUAGE DeriveDataTypeable #-} - -module Main where - -import Distribution.Client.DistDirLayout -import Distribution.Client.ProjectConfig -import Distribution.Client.Config (defaultCabalDir) -import Distribution.Client.ProjectPlanning -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.ProjectBuilding -import qualified Distribution.Client.InstallPlan as InstallPlan - -import Distribution.Package -import Distribution.PackageDescription -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Simple.Setup (toFlag) -import Distribution.Simple.Compiler -import Distribution.System -import Distribution.Version -import Distribution.Verbosity -import Distribution.Text - -import Data.Monoid -import qualified Data.Map as Map -import Control.Monad -import Control.Exception -import System.FilePath -import System.Directory - -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.Options -import Data.Tagged (Tagged(..)) -import Data.Proxy (Proxy(..)) -import Data.Typeable (Typeable) - - -main :: IO () -main = - defaultMainWithIngredients - (defaultIngredients ++ [includingOptions projectConfigOptionDescriptions]) - (withProjectConfig $ \config -> - testGroup "Integration tests (internal)" - (tests config)) - -tests :: ProjectConfig -> [TestTree] -tests config = - --TODO: tests for: - -- * normal success - -- * dry-run tests with changes - [ testGroup "Exceptions during discovey and planning" $ - [ testCase "no package" (testExceptionInFindingPackage config) - , testCase "no package2" (testExceptionInFindingPackage2 config) - , testCase "proj conf1" (testExceptionInProjectConfig config) - ] - , testGroup "Exceptions during building (local inplace)" $ - [ testCase "configure" (testExceptionInConfigureStep config) - , testCase "build" (testExceptionInBuildStep config) --- , testCase "register" testExceptionInRegisterStep - ] - --TODO: need to repeat for packages for the store - - , testGroup "Successful builds" $ - [ testCaseSteps "Setup script styles" (testSetupScriptStyles config) - , testCase "keep-going" (testBuildKeepGoing config) - ] - - , testGroup "Regression tests" $ - [ testCase "issue #3324" (testRegressionIssue3324 config) - ] - ] - -testExceptionInFindingPackage :: ProjectConfig -> Assertion -testExceptionInFindingPackage config = do - BadPackageLocations _ locs <- expectException "BadPackageLocations" $ - void $ planProject testdir config - case locs of - [BadLocGlobEmptyMatch "./*.cabal"] -> return () - _ -> assertFailure "expected BadLocGlobEmptyMatch" - cleanProject testdir - where - testdir = "exception/no-pkg" - - -testExceptionInFindingPackage2 :: ProjectConfig -> Assertion -testExceptionInFindingPackage2 config = do - BadPackageLocations _ locs <- expectException "BadPackageLocations" $ - void $ planProject testdir config - case locs of - [BadPackageLocationFile (BadLocDirNoCabalFile ".")] -> return () - _ -> assertFailure $ "expected BadLocDirNoCabalFile, got " ++ show locs - cleanProject testdir - where - testdir = "exception/no-pkg2" - - -testExceptionInProjectConfig :: ProjectConfig -> Assertion -testExceptionInProjectConfig config = do - BadPerPackageCompilerPaths ps <- expectException "BadPerPackageCompilerPaths" $ - void $ planProject testdir config - case ps of - [(pn,"ghc")] | mkPackageName "foo" == pn -> return () - _ -> assertFailure $ "expected (PackageName \"foo\",\"ghc\"), got " - ++ show ps - cleanProject testdir - where - testdir = "exception/bad-config" - - -testExceptionInConfigureStep :: ProjectConfig -> Assertion -testExceptionInConfigureStep config = do - (plan, res) <- executePlan =<< planProject testdir config - (_pkga1, failure) <- expectPackageFailed plan res pkgidA1 - case buildFailureReason failure of - ConfigureFailed _ -> return () - _ -> assertFailure $ "expected ConfigureFailed, got " ++ show failure - cleanProject testdir - where - testdir = "exception/configure" - pkgidA1 = PackageIdentifier (mkPackageName "a") (mkVersion [1]) - - -testExceptionInBuildStep :: ProjectConfig -> Assertion -testExceptionInBuildStep config = do - (plan, res) <- executePlan =<< planProject testdir config - (_pkga1, failure) <- expectPackageFailed plan res pkgidA1 - expectBuildFailed failure - where - testdir = "exception/build" - pkgidA1 = PackageIdentifier (mkPackageName "a") (mkVersion [1]) - -testSetupScriptStyles :: ProjectConfig -> (String -> IO ()) -> Assertion -testSetupScriptStyles config reportSubCase = do - - reportSubCase (show SetupCustomExplicitDeps) - - plan0@(_,_,sharedConfig,_,_) <- planProject testdir1 config - - let isOSX (Platform _ OSX) = True - isOSX _ = False - -- Skip the Custom tests when the shipped Cabal library is buggy - unless (isOSX (pkgConfigPlatform sharedConfig) - && compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [7,10]) $ do - - (plan1, res1) <- executePlan plan0 - (pkg1, _) <- expectPackageInstalled plan1 res1 pkgidA - elabSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps - hasDefaultSetupDeps pkg1 @?= Just False - marker1 <- readFile (basedir testdir1 "marker") - marker1 @?= "ok" - removeFile (basedir testdir1 "marker") - - reportSubCase (show SetupCustomImplicitDeps) - (plan2, res2) <- executePlan =<< planProject testdir2 config - (pkg2, _) <- expectPackageInstalled plan2 res2 pkgidA - elabSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps - hasDefaultSetupDeps pkg2 @?= Just True - marker2 <- readFile (basedir testdir2 "marker") - marker2 @?= "ok" - removeFile (basedir testdir2 "marker") - - reportSubCase (show SetupNonCustomInternalLib) - (plan3, res3) <- executePlan =<< planProject testdir3 config - (pkg3, _) <- expectPackageInstalled plan3 res3 pkgidA - elabSetupScriptStyle pkg3 @?= SetupNonCustomInternalLib -{- - --TODO: the SetupNonCustomExternalLib case is hard to test since it - -- requires a version of Cabal that's later than the one we're testing - -- e.g. needs a .cabal file that specifies cabal-version: >= 2.0 - -- and a corresponding Cabal package that we can use to try and build a - -- default Setup.hs. - reportSubCase (show SetupNonCustomExternalLib) - (plan4, res4) <- executePlan =<< planProject testdir4 config - (pkg4, _) <- expectPackageInstalled plan4 res4 pkgidA - pkgSetupScriptStyle pkg4 @?= SetupNonCustomExternalLib --} - where - testdir1 = "build/setup-custom1" - testdir2 = "build/setup-custom2" - testdir3 = "build/setup-simple" - pkgidA = PackageIdentifier (mkPackageName "a") (mkVersion [0,1]) - -- The solver fills in default setup deps explicitly, but marks them as such - hasDefaultSetupDeps = fmap defaultSetupDepends - . setupBuildInfo . elabPkgDescription - --- | Test the behaviour with and without @--keep-going@ --- -testBuildKeepGoing :: ProjectConfig -> Assertion -testBuildKeepGoing config = do - -- P is expected to fail, Q does not depend on P but without - -- parallel build and without keep-going then we don't build Q yet. - (plan1, res1) <- executePlan =<< planProject testdir (config <> keepGoing False) - (_, failure1) <- expectPackageFailed plan1 res1 pkgidP - expectBuildFailed failure1 - _ <- expectPackageConfigured plan1 res1 pkgidQ - - -- With keep-going then we should go on to sucessfully build Q - (plan2, res2) <- executePlan - =<< planProject testdir (config <> keepGoing True) - (_, failure2) <- expectPackageFailed plan2 res2 pkgidP - expectBuildFailed failure2 - _ <- expectPackageInstalled plan2 res2 pkgidQ - return () - where - testdir = "build/keep-going" - pkgidP = PackageIdentifier (mkPackageName "p") (mkVersion [0,1]) - pkgidQ = PackageIdentifier (mkPackageName "q") (mkVersion [0,1]) - keepGoing kg = - mempty { - projectConfigBuildOnly = mempty { - projectConfigKeepGoing = toFlag kg - } - } - --- | See --- -testRegressionIssue3324 :: ProjectConfig -> Assertion -testRegressionIssue3324 config = do - -- expected failure first time due to missing dep - (plan1, res1) <- executePlan =<< planProject testdir config - (_pkgq, failure) <- expectPackageFailed plan1 res1 pkgidQ - expectBuildFailed failure - - -- add the missing dep, now it should work - let qcabal = basedir testdir "q" "q.cabal" - withFileFinallyRestore qcabal $ do - appendFile qcabal (" build-depends: p\n") - (plan2, res2) <- executePlan =<< planProject testdir config - _ <- expectPackageInstalled plan2 res2 pkgidP - _ <- expectPackageInstalled plan2 res2 pkgidQ - return () - where - testdir = "regression/3324" - pkgidP = PackageIdentifier (mkPackageName "p") (mkVersion [0,1]) - pkgidQ = PackageIdentifier (mkPackageName "q") (mkVersion [0,1]) - - ---------------------------------- --- Test utils to plan and build --- - -basedir :: FilePath -basedir = "tests" "IntegrationTests2" - -planProject :: FilePath -> ProjectConfig -> IO PlanDetails -planProject testdir cliConfig = do - cabalDir <- defaultCabalDir - let cabalDirLayout = defaultCabalDirLayout cabalDir - - projectRootDir <- canonicalizePath ("tests" "IntegrationTests2" - testdir) - let distDirLayout = defaultDistDirLayout projectRootDir - - -- Clear state between test runs. The state remains if the previous run - -- ended in an exception (as we leave the files to help with debugging). - cleanProject testdir - - (elaboratedPlan, _, elaboratedShared, projectConfig) <- - rebuildInstallPlan verbosity - projectRootDir distDirLayout cabalDirLayout - cliConfig - - let targets = - Map.fromList - [ (installedUnitId elab, [BuildDefaultComponents]) - | InstallPlan.Configured elab <- InstallPlan.toList elaboratedPlan - , elabBuildStyle elab == BuildInplaceOnly ] - elaboratedPlan' = pruneInstallPlanToTargets targets elaboratedPlan - - pkgsBuildStatus <- - rebuildTargetsDryRun distDirLayout elaboratedShared - elaboratedPlan' - - let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages - pkgsBuildStatus elaboratedPlan' - - let buildSettings = resolveBuildTimeSettings - verbosity cabalDirLayout - (projectConfigShared projectConfig) - (projectConfigBuildOnly projectConfig) - (projectConfigBuildOnly cliConfig) - - return (distDirLayout, - elaboratedPlan'', - elaboratedShared, - pkgsBuildStatus, - buildSettings) - -type PlanDetails = (DistDirLayout, - ElaboratedInstallPlan, - ElaboratedSharedConfig, - BuildStatusMap, - BuildTimeSettings) - -executePlan :: PlanDetails -> IO (ElaboratedInstallPlan, BuildOutcomes) -executePlan (distDirLayout, - elaboratedPlan, - elaboratedShared, - pkgsBuildStatus, - buildSettings) = - fmap ((,) elaboratedPlan) $ - rebuildTargets verbosity - distDirLayout - elaboratedPlan - elaboratedShared - pkgsBuildStatus - -- Avoid trying to use act-as-setup mode: - buildSettings { buildSettingNumJobs = 1 } - -cleanProject :: FilePath -> IO () -cleanProject testdir = do - alreadyExists <- doesDirectoryExist distDir - when alreadyExists $ removeDirectoryRecursive distDir - where - projectRootDir = "tests" "IntegrationTests2" testdir - distDirLayout = defaultDistDirLayout projectRootDir - distDir = distDirectory distDirLayout - - -verbosity :: Verbosity -verbosity = minBound --normal --verbose --maxBound --minBound - - - -------------------------------------------- --- Tasty integration to adjust the config --- - -withProjectConfig :: (ProjectConfig -> TestTree) -> TestTree -withProjectConfig testtree = - askOption $ \ghcPath -> - testtree (mkProjectConfig ghcPath) - -mkProjectConfig :: GhcPath -> ProjectConfig -mkProjectConfig (GhcPath ghcPath) = - mempty { - projectConfigShared = mempty { - projectConfigHcPath = maybeToFlag ghcPath - }, - projectConfigBuildOnly = mempty { - projectConfigNumJobs = toFlag (Just 1) - } - } - where - maybeToFlag = maybe mempty toFlag - - -data GhcPath = GhcPath (Maybe FilePath) - deriving Typeable - -instance IsOption GhcPath where - defaultValue = GhcPath Nothing - optionName = Tagged "with-ghc" - optionHelp = Tagged "The ghc compiler to use" - parseValue = Just . GhcPath . Just - -projectConfigOptionDescriptions :: [OptionDescription] -projectConfigOptionDescriptions = [Option (Proxy :: Proxy GhcPath)] - - ---------------------------------------- --- HUint style utils for this context --- - -expectException :: Exception e => String -> IO a -> IO e -expectException expected action = do - res <- try action - case res of - Left e -> return e - Right _ -> throwIO $ HUnitFailure $ "expected an exception " ++ expected - -expectPackagePreExisting :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId - -> IO InstalledPackageInfo -expectPackagePreExisting plan buildOutcomes pkgid = do - planpkg <- expectPlanPackage plan pkgid - case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of - (InstallPlan.PreExisting pkg, Nothing) - -> return pkg - (_, buildResult) -> unexpectedBuildResult "PreExisting" planpkg buildResult - -expectPackageConfigured :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId - -> IO ElaboratedConfiguredPackage -expectPackageConfigured plan buildOutcomes pkgid = do - planpkg <- expectPlanPackage plan pkgid - case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of - (InstallPlan.Configured pkg, Nothing) - -> return pkg - (_, buildResult) -> unexpectedBuildResult "Configured" planpkg buildResult - -expectPackageInstalled :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId - -> IO (ElaboratedConfiguredPackage, BuildResult) -expectPackageInstalled plan buildOutcomes pkgid = do - planpkg <- expectPlanPackage plan pkgid - case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of - (InstallPlan.Configured pkg, Just (Right result)) - -> return (pkg, result) - (_, buildResult) -> unexpectedBuildResult "Installed" planpkg buildResult - -expectPackageFailed :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId - -> IO (ElaboratedConfiguredPackage, BuildFailure) -expectPackageFailed plan buildOutcomes pkgid = do - planpkg <- expectPlanPackage plan pkgid - case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of - (InstallPlan.Configured pkg, Just (Left failure)) - -> return (pkg, failure) - (_, buildResult) -> unexpectedBuildResult "Failed" planpkg buildResult - -unexpectedBuildResult :: String -> ElaboratedPlanPackage - -> Maybe (Either BuildFailure BuildResult) -> IO a -unexpectedBuildResult expected planpkg buildResult = - throwIO $ HUnitFailure $ - "expected to find " ++ display (packageId planpkg) ++ " in the " - ++ expected ++ " state, but it is actually in the " ++ actual ++ " state." - where - actual = case (buildResult, planpkg) of - (Nothing, InstallPlan.PreExisting{}) -> "PreExisting" - (Nothing, InstallPlan.Configured{}) -> "Configured" - (Just (Right _), InstallPlan.Configured{}) -> "Installed" - (Just (Left _), InstallPlan.Configured{}) -> "Failed" - _ -> "Impossible!" - -expectPlanPackage :: ElaboratedInstallPlan -> PackageId - -> IO ElaboratedPlanPackage -expectPlanPackage plan pkgid = - case [ pkg - | pkg <- InstallPlan.toList plan - , packageId pkg == pkgid ] of - [pkg] -> return pkg - [] -> throwIO $ HUnitFailure $ - "expected to find " ++ display pkgid - ++ " in the install plan but it's not there" - _ -> throwIO $ HUnitFailure $ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} + +-- For the handy instance IsString PackageIdentifier +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module IntegrationTests2 where + +import Distribution.Client.DistDirLayout +import Distribution.Client.ProjectConfig +import Distribution.Client.Config (defaultCabalDir) +import Distribution.Client.TargetSelector hiding (DirActions(..)) +import qualified Distribution.Client.TargetSelector as TS (DirActions(..)) +import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.ProjectBuilding +import Distribution.Client.ProjectOrchestration + ( resolveTargets, TargetProblemCommon(..), distinctTargetComponents ) +import Distribution.Client.Types + ( PackageLocation(..), UnresolvedSourcePackage + , PackageSpecifier(..) ) +import Distribution.Client.Targets + ( UserConstraint(..), UserConstraintScope(UserAnyQualifier) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Solver.Types.SourcePackage as SP +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource(ConstraintSourceUnknown) ) +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty(PackagePropertySource) ) + +import qualified Distribution.Client.CmdBuild as CmdBuild +import qualified Distribution.Client.CmdRepl as CmdRepl +import qualified Distribution.Client.CmdRun as CmdRun +import qualified Distribution.Client.CmdTest as CmdTest +import qualified Distribution.Client.CmdBench as CmdBench +import qualified Distribution.Client.CmdHaddock as CmdHaddock + +import Distribution.Package +import Distribution.PackageDescription +import qualified Distribution.Types.GenericPackageDescription as GPG +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Simple.Setup (toFlag, HaddockFlags(..), defaultHaddockFlags) +import Distribution.Simple.Compiler +import Distribution.System +import Distribution.Version +import Distribution.ModuleName (ModuleName) +import Distribution.Verbosity +import Distribution.Text + +import Data.Monoid +import Data.List (sort) +import Data.String (IsString(..)) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Monad +import Control.Exception hiding (assert) +import System.FilePath +import System.Directory + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Options +import Data.Tagged (Tagged(..)) +import Data.Proxy (Proxy(..)) +import Data.Typeable (Typeable) + + +main :: IO () +main = + defaultMainWithIngredients + (defaultIngredients ++ [includingOptions projectConfigOptionDescriptions]) + (withProjectConfig $ \config -> + testGroup "Integration tests (internal)" + (tests config)) + + +tests :: ProjectConfig -> [TestTree] +tests config = + --TODO: tests for: + -- * normal success + -- * dry-run tests with changes + [ testGroup "Discovery and planning" $ + [ testCase "find root" testFindProjectRoot + , testCase "find root fail" testExceptionFindProjectRoot + , testCase "no package" (testExceptionInFindingPackage config) + , testCase "no package2" (testExceptionInFindingPackage2 config) + , testCase "proj conf1" (testExceptionInProjectConfig config) + ] + , testGroup "Target selectors" $ + [ testCaseSteps "valid" testTargetSelectors + , testCase "bad syntax" testTargetSelectorBadSyntax + , testCaseSteps "ambiguous syntax" testTargetSelectorAmbiguous + , testCase "no current pkg" testTargetSelectorNoCurrentPackage + , testCase "no targets" testTargetSelectorNoTargets + , testCase "project empty" testTargetSelectorProjectEmpty + , testCase "problems (common)" (testTargetProblemsCommon config) + , testCaseSteps "problems (build)" (testTargetProblemsBuild config) + , testCaseSteps "problems (repl)" (testTargetProblemsRepl config) + , testCaseSteps "problems (run)" (testTargetProblemsRun config) + , testCaseSteps "problems (test)" (testTargetProblemsTest config) + , testCaseSteps "problems (bench)" (testTargetProblemsBench config) + , testCaseSteps "problems (haddock)" (testTargetProblemsHaddock config) + ] + , testGroup "Exceptions during building (local inplace)" $ + [ testCase "configure" (testExceptionInConfigureStep config) + , testCase "build" (testExceptionInBuildStep config) +-- , testCase "register" testExceptionInRegisterStep + ] + --TODO: need to repeat for packages for the store + --TODO: need to check we can build sub-libs, foreign libs and exes + -- components for non-local packages / packages in the store. + + , testGroup "Successful builds" $ + [ testCaseSteps "Setup script styles" (testSetupScriptStyles config) + , testCase "keep-going" (testBuildKeepGoing config) + ] + + , testGroup "Regression tests" $ + [ testCase "issue #3324" (testRegressionIssue3324 config) + ] + ] + + +testFindProjectRoot :: Assertion +testFindProjectRoot = do + Left (BadProjectRootExplicitFile file) <- findProjectRoot (Just testdir) + (Just testfile) + file @?= testfile + where + testdir = basedir "exception" "no-pkg2" + testfile = "bklNI8O1OpOUuDu3F4Ij4nv3oAqN" + + +testExceptionFindProjectRoot :: Assertion +testExceptionFindProjectRoot = do + Right (ProjectRootExplicit dir _) <- findProjectRoot (Just testdir) Nothing + cwd <- getCurrentDirectory + dir @?= cwd testdir + where + testdir = basedir "exception" "no-pkg2" + + +testTargetSelectors :: (String -> IO ()) -> Assertion +testTargetSelectors reportSubCase = do + (_, _, _, localPackages, _) <- configureProject testdir config + let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir) + localPackages + + reportSubCase "cwd" + do Right ts <- readTargetSelectors' [] + ts @?= [TargetPackage TargetImplicitCwd "p-0.1" Nothing] + + reportSubCase "all" + do Right ts <- readTargetSelectors' + ["all", ":all"] + ts @?= replicate 2 (TargetAllPackages Nothing) + + reportSubCase "filter" + do Right ts <- readTargetSelectors' + [ "libs", ":cwd:libs" + , "flibs", ":cwd:flibs" + , "exes", ":cwd:exes" + , "tests", ":cwd:tests" + , "benchmarks", ":cwd:benchmarks"] + zipWithM_ (@?=) ts + [ TargetPackage TargetImplicitCwd "p-0.1" (Just kind) + | kind <- concatMap (replicate 2) [LibKind .. ] + ] + + reportSubCase "all:filter" + do Right ts <- readTargetSelectors' + [ "all:libs", ":all:libs" + , "all:flibs", ":all:flibs" + , "all:exes", ":all:exes" + , "all:tests", ":all:tests" + , "all:benchmarks", ":all:benchmarks"] + zipWithM_ (@?=) ts + [ TargetAllPackages (Just kind) + | kind <- concatMap (replicate 2) [LibKind .. ] + ] + + reportSubCase "pkg" + do Right ts <- readTargetSelectors' + [ ":pkg:p", ".", "./", "p.cabal" + , "q", ":pkg:q", "q/", "./q/", "q/q.cabal"] + ts @?= replicate 4 (mkTargetPackage "p-0.1") + ++ replicate 5 (mkTargetPackage "q-0.1") + + reportSubCase "pkg:filter" + do Right ts <- readTargetSelectors' + [ "p:libs", ".:libs", ":pkg:p:libs" + , "p:flibs", ".:flibs", ":pkg:p:flibs" + , "p:exes", ".:exes", ":pkg:p:exes" + , "p:tests", ".:tests", ":pkg:p:tests" + , "p:benchmarks", ".:benchmarks", ":pkg:p:benchmarks" + , "q:libs", "q/:libs", ":pkg:q:libs" + , "q:flibs", "q/:flibs", ":pkg:q:flibs" + , "q:exes", "q/:exes", ":pkg:q:exes" + , "q:tests", "q/:tests", ":pkg:q:tests" + , "q:benchmarks", "q/:benchmarks", ":pkg:q:benchmarks"] + zipWithM_ (@?=) ts $ + [ TargetPackage TargetExplicitNamed "p-0.1" (Just kind) + | kind <- concatMap (replicate 3) [LibKind .. ] + ] ++ + [ TargetPackage TargetExplicitNamed "q-0.1" (Just kind) + | kind <- concatMap (replicate 3) [LibKind .. ] + ] + + reportSubCase "component" + do Right ts <- readTargetSelectors' + [ "p", "lib:p", "p:lib:p", ":pkg:p:lib:p" + , "lib:q", "q:lib:q", ":pkg:q:lib:q" ] + ts @?= replicate 4 (TargetComponent "p-0.1" CLibName WholeComponent) + ++ replicate 3 (TargetComponent "q-0.1" CLibName WholeComponent) + + reportSubCase "module" + do Right ts <- readTargetSelectors' + [ "P", "lib:p:P", "p:p:P", ":pkg:p:lib:p:module:P" + , "QQ", "lib:q:QQ", "q:q:QQ", ":pkg:q:lib:q:module:QQ" + , "pexe:PMain" -- p:P or q:QQ would be ambiguous here + , "qexe:QMain" -- package p vs component p + ] + ts @?= replicate 4 (TargetComponent "p-0.1" CLibName (ModuleTarget "P")) + ++ replicate 4 (TargetComponent "q-0.1" CLibName (ModuleTarget "QQ")) + ++ [ TargetComponent "p-0.1" (CExeName "pexe") (ModuleTarget "PMain") + , TargetComponent "q-0.1" (CExeName "qexe") (ModuleTarget "QMain") + ] + + reportSubCase "file" + do Right ts <- readTargetSelectors' + [ "./P.hs", "p:P.lhs", "lib:p:P.hsc", "p:p:P.hsc", + ":pkg:p:lib:p:file:P.y" + , "q/QQ.hs", "q:QQ.lhs", "lib:q:QQ.hsc", "q:q:QQ.hsc", + ":pkg:q:lib:q:file:QQ.y" + ] + ts @?= replicate 5 (TargetComponent "p-0.1" CLibName (FileTarget "P")) + ++ replicate 5 (TargetComponent "q-0.1" CLibName (FileTarget "QQ")) + -- Note there's a bit of an inconsistency here: for the single-part + -- syntax the target has to point to a file that exists, whereas for + -- all the other forms we don't require that. + + cleanProject testdir + where + testdir = "targets/simple" + config = mempty + + +testTargetSelectorBadSyntax :: Assertion +testTargetSelectorBadSyntax = do + (_, _, _, localPackages, _) <- configureProject testdir config + let targets = [ "foo bar", " foo" + , "foo:", "foo::bar" + , "foo: ", "foo: :bar" + , "a:b:c:d:e:f", "a:b:c:d:e:f:g:h" ] + Left errs <- readTargetSelectors localPackages targets + zipWithM_ (@?=) errs (map TargetSelectorUnrecognised targets) + cleanProject testdir + where + testdir = "targets/empty" + config = mempty + + +testTargetSelectorAmbiguous :: (String -> IO ()) -> Assertion +testTargetSelectorAmbiguous reportSubCase = do + + -- 'all' is ambiguous with packages and cwd components + reportSubCase "ambiguous: all vs pkg" + assertAmbiguous "all" + [mkTargetPackage "all", mkTargetAllPackages] + [mkpkg "all" []] + + reportSubCase "ambiguous: all vs cwd component" + assertAmbiguous "all" + [mkTargetComponent "other" (CExeName "all"), mkTargetAllPackages] + [mkpkg "other" [mkexe "all"]] + + -- but 'all' is not ambiguous with non-cwd components, modules or files + reportSubCase "unambiguous: all vs non-cwd comp, mod, file" + assertUnambiguous "All" + mkTargetAllPackages + [ mkpkgAt "foo" [mkexe "All"] "foo" + , mkpkg "bar" [ mkexe "bar" `withModules` ["All"] + , mkexe "baz" `withCFiles` ["All"] ] + ] + + -- filters 'libs', 'exes' etc are ambiguous with packages and + -- local components + reportSubCase "ambiguous: cwd-pkg filter vs pkg" + assertAmbiguous "libs" + [ mkTargetPackage "libs" + , TargetPackage TargetImplicitCwd "dummyPackageInfo" (Just LibKind) ] + [mkpkg "libs" []] + + reportSubCase "ambiguous: filter vs cwd component" + assertAmbiguous "exes" + [ mkTargetComponent "other" (CExeName "exes") + , TargetPackage TargetImplicitCwd "dummyPackageInfo" (Just ExeKind) ] + [mkpkg "other" [mkexe "exes"]] + + -- but filters are not ambiguous with non-cwd components, modules or files + reportSubCase "unambiguous: filter vs non-cwd comp, mod, file" + assertUnambiguous "Libs" + (TargetPackage TargetImplicitCwd "bar" (Just LibKind)) + [ mkpkgAt "foo" [mkexe "Libs"] "foo" + , mkpkg "bar" [ mkexe "bar" `withModules` ["Libs"] + , mkexe "baz" `withCFiles` ["Libs"] ] + ] + + -- local components shadow packages and other components + reportSubCase "unambiguous: cwd comp vs pkg, non-cwd comp" + assertUnambiguous "foo" + (mkTargetComponent "other" (CExeName "foo")) + [ mkpkg "other" [mkexe "foo"] + , mkpkgAt "other2" [mkexe "foo"] "other2" -- shadows non-local foo + , mkpkg "foo" [] ] -- shadows package foo + + -- local components shadow modules and files + reportSubCase "unambiguous: cwd comp vs module, file" + assertUnambiguous "Foo" + (mkTargetComponent "bar" (CExeName "Foo")) + [ mkpkg "bar" [mkexe "Foo"] + , mkpkg "other" [ mkexe "other" `withModules` ["Foo"] + , mkexe "other2" `withCFiles` ["Foo"] ] + ] + + -- packages shadow non-local components + reportSubCase "unambiguous: pkg vs non-cwd comp" + assertUnambiguous "foo" + (mkTargetPackage "foo") + [ mkpkg "foo" [] + , mkpkgAt "other" [mkexe "foo"] "other" -- shadows non-local foo + ] + + -- packages shadow modules and files + reportSubCase "unambiguous: pkg vs module, file" + assertUnambiguous "Foo" + (mkTargetPackage "Foo") + [ mkpkgAt "Foo" [] "foo" + , mkpkg "other" [ mkexe "other" `withModules` ["Foo"] + , mkexe "other2" `withCFiles` ["Foo"] ] + ] + + -- non-exact case packages and components are ambiguous + reportSubCase "ambiguous: non-exact-case pkg names" + assertAmbiguous "Foo" + [ mkTargetPackage "foo", mkTargetPackage "FOO" ] + [ mkpkg "foo" [], mkpkg "FOO" [] ] + reportSubCase "ambiguous: non-exact-case comp names" + assertAmbiguous "Foo" + [ mkTargetComponent "bar" (CExeName "foo") + , mkTargetComponent "bar" (CExeName "FOO") ] + [ mkpkg "bar" [mkexe "foo", mkexe "FOO"] ] + + -- exact-case Module or File over non-exact case package or component + reportSubCase "unambiguous: module vs non-exact-case pkg, comp" + assertUnambiguous "Baz" + (mkTargetModule "other" (CExeName "other") "Baz") + [ mkpkg "baz" [mkexe "BAZ"] + , mkpkg "other" [ mkexe "other" `withModules` ["Baz"] ] + ] + reportSubCase "unambiguous: file vs non-exact-case pkg, comp" + assertUnambiguous "Baz" + (mkTargetFile "other" (CExeName "other") "Baz") + [ mkpkg "baz" [mkexe "BAZ"] + , mkpkg "other" [ mkexe "other" `withCFiles` ["Baz"] ] + ] + where + assertAmbiguous :: String + -> [TargetSelector PackageId] + -> [SourcePackage (PackageLocation a)] + -> Assertion + assertAmbiguous str tss pkgs = do + res <- readTargetSelectorsWith + fakeDirActions + (map SpecificSourcePackage pkgs) + [str] + case res of + Left [TargetSelectorAmbiguous _ tss'] -> + sort (map snd tss') @?= sort tss + _ -> assertFailure $ "expected Left [TargetSelectorAmbiguous _ _], " + ++ "got " ++ show res + + assertUnambiguous :: String + -> TargetSelector PackageId + -> [SourcePackage (PackageLocation a)] + -> Assertion + assertUnambiguous str ts pkgs = do + res <- readTargetSelectorsWith + fakeDirActions + (map SpecificSourcePackage pkgs) + [str] + case res of + Right [ts'] -> ts' @?= ts + _ -> assertFailure $ "expected Right [Target...], " + ++ "got " ++ show res + + fakeDirActions = TS.DirActions { + TS.doesFileExist = \_p -> return True, + TS.doesDirectoryExist = \_p -> return True, + TS.canonicalizePath = \p -> return ("/" p), -- FilePath.Unix. ? + TS.getCurrentDirectory = return "/" + } + + mkpkg :: String -> [Executable] -> SourcePackage (PackageLocation a) + mkpkg pkgidstr exes = mkpkgAt pkgidstr exes "" + + mkpkgAt :: String -> [Executable] -> FilePath + -> SourcePackage (PackageLocation a) + mkpkgAt pkgidstr exes loc = + SourcePackage { + packageInfoId = pkgid, + packageSource = LocalUnpackedPackage loc, + packageDescrOverride = Nothing, + SP.packageDescription = GenericPackageDescription { + GPG.packageDescription = emptyPackageDescription { package = pkgid }, + genPackageFlags = [], + condLibrary = Nothing, + condSubLibraries = [], + condForeignLibs = [], + condExecutables = [ ( exeName exe, CondNode exe [] [] ) + | exe <- exes ], + condTestSuites = [], + condBenchmarks = [] + } + } + where + Just pkgid = simpleParse pkgidstr + + mkexe :: String -> Executable + mkexe name = mempty { exeName = fromString name } + + withModules :: Executable -> [String] -> Executable + withModules exe mods = + exe { buildInfo = (buildInfo exe) { otherModules = map fromString mods } } + + withCFiles :: Executable -> [FilePath] -> Executable + withCFiles exe files = + exe { buildInfo = (buildInfo exe) { cSources = files } } + + +mkTargetPackage :: PackageId -> TargetSelector PackageId +mkTargetPackage pkgid = + TargetPackage TargetExplicitNamed pkgid Nothing + +mkTargetComponent :: PackageId -> ComponentName -> TargetSelector PackageId +mkTargetComponent pkgid cname = + TargetComponent pkgid cname WholeComponent + +mkTargetModule :: PackageId -> ComponentName -> ModuleName -> TargetSelector PackageId +mkTargetModule pkgid cname mname = + TargetComponent pkgid cname (ModuleTarget mname) + +mkTargetFile :: PackageId -> ComponentName -> String -> TargetSelector PackageId +mkTargetFile pkgid cname fname = + TargetComponent pkgid cname (FileTarget fname) + +mkTargetAllPackages :: TargetSelector PackageId +mkTargetAllPackages = TargetAllPackages Nothing + +instance IsString PackageIdentifier where + fromString pkgidstr = pkgid + where Just pkgid = simpleParse pkgidstr + + +testTargetSelectorNoCurrentPackage :: Assertion +testTargetSelectorNoCurrentPackage = do + (_, _, _, localPackages, _) <- configureProject testdir config + let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir) + localPackages + targets = [ "libs", ":cwd:libs" + , "flibs", ":cwd:flibs" + , "exes", ":cwd:exes" + , "tests", ":cwd:tests" + , "benchmarks", ":cwd:benchmarks"] + Left errs <- readTargetSelectors' targets + zipWithM_ (@?=) errs + [ TargetSelectorNoCurrentPackage ts + | target <- targets + , let Just ts = parseTargetString target + ] + cleanProject testdir + where + testdir = "targets/complex" + config = mempty + + +testTargetSelectorNoTargets :: Assertion +testTargetSelectorNoTargets = do + (_, _, _, localPackages, _) <- configureProject testdir config + Left errs <- readTargetSelectors localPackages [] + errs @?= [TargetSelectorNoTargetsInCwd] + cleanProject testdir + where + testdir = "targets/complex" + config = mempty + + +testTargetSelectorProjectEmpty :: Assertion +testTargetSelectorProjectEmpty = do + (_, _, _, localPackages, _) <- configureProject testdir config + Left errs <- readTargetSelectors localPackages [] + errs @?= [TargetSelectorNoTargetsInProject] + cleanProject testdir + where + testdir = "targets/empty" + config = mempty + + +testTargetProblemsCommon :: ProjectConfig -> Assertion +testTargetProblemsCommon config0 = do + (_,elaboratedPlan,_) <- planProject testdir config + + let pkgIdMap :: Map.Map PackageName PackageId + pkgIdMap = Map.fromList + [ (packageName p, packageId p) + | p <- InstallPlan.toList elaboratedPlan ] + + cases :: [( TargetSelector PackageId -> CmdBuild.TargetProblem + , TargetSelector PackageId + )] + cases = + [ -- Cannot resolve packages outside of the project + ( \_ -> CmdBuild.TargetProblemCommon $ + TargetProblemNoSuchPackage "foobar" + , mkTargetPackage "foobar" ) + + -- We cannot currently build components like testsuites or + -- benchmarks from packages that are not local to the project + , ( \_ -> CmdBuild.TargetProblemCommon $ + TargetComponentNotProjectLocal + (pkgIdMap Map.! "filepath") (CTestName "filepath-tests") + WholeComponent + , mkTargetComponent (pkgIdMap Map.! "filepath") + (CTestName "filepath-tests") ) + + -- Components can be explicitly @buildable: False@ + , ( \_ -> CmdBuild.TargetProblemCommon $ + TargetComponentNotBuildable "q-0.1" (CExeName "buildable-false") WholeComponent + , mkTargetComponent "q-0.1" (CExeName "buildable-false") ) + + -- Testsuites and benchmarks can be disabled by the solver if it + -- cannot satisfy deps + , ( \_ -> CmdBuild.TargetProblemCommon $ + TargetOptionalStanzaDisabledBySolver "q-0.1" (CTestName "solver-disabled") WholeComponent + , mkTargetComponent "q-0.1" (CTestName "solver-disabled") ) + + -- Testsuites and benchmarks can be disabled explicitly by the + -- user via config + , ( \_ -> CmdBuild.TargetProblemCommon $ + TargetOptionalStanzaDisabledByUser + "q-0.1" (CBenchName "user-disabled") WholeComponent + , mkTargetComponent "q-0.1" (CBenchName "user-disabled") ) + + -- An unknown package. The target selector resolution should only + -- produce known packages, so this should not happen with the + -- output from 'readTargetSelectors'. + , ( \_ -> CmdBuild.TargetProblemCommon $ + TargetProblemNoSuchPackage "foobar" + , mkTargetPackage "foobar" ) + + -- An unknown component of a known package. The target selector + -- resolution should only produce known packages, so this should + -- not happen with the output from 'readTargetSelectors'. + , ( \_ -> CmdBuild.TargetProblemCommon $ + TargetProblemNoSuchComponent "q-0.1" (CExeName "no-such") + , mkTargetComponent "q-0.1" (CExeName "no-such") ) + ] + assertTargetProblems + elaboratedPlan + CmdBuild.selectPackageTargets + CmdBuild.selectComponentTarget + CmdBuild.TargetProblemCommon + cases + where + testdir = "targets/complex" + config = config0 { + projectConfigLocalPackages = (projectConfigLocalPackages config0) { + packageConfigBenchmarks = toFlag False + } + , projectConfigShared = (projectConfigShared config0) { + projectConfigConstraints = + [( UserConstraint (UserAnyQualifier "filepath") PackagePropertySource + , ConstraintSourceUnknown )] + } + } + + +testTargetProblemsBuild :: ProjectConfig -> (String -> IO ()) -> Assertion +testTargetProblemsBuild config reportSubCase = do + + reportSubCase "empty-pkg" + assertProjectTargetProblems + "targets/empty-pkg" config + CmdBuild.selectPackageTargets + CmdBuild.selectComponentTarget + CmdBuild.TargetProblemCommon + [ ( CmdBuild.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "all-disabled" + assertProjectTargetProblems + "targets/all-disabled" + config { + projectConfigLocalPackages = (projectConfigLocalPackages config) { + packageConfigBenchmarks = toFlag False + } + } + CmdBuild.selectPackageTargets + CmdBuild.selectComponentTarget + CmdBuild.TargetProblemCommon + [ ( flip CmdBuild.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CBenchName "user-disabled") + TargetDisabledByUser True + , AvailableTarget "p-0.1" (CTestName "solver-disabled") + TargetDisabledBySolver True + , AvailableTarget "p-0.1" (CExeName "buildable-false") + TargetNotBuildable True + , AvailableTarget "p-0.1" CLibName + TargetNotBuildable True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "enabled component kinds" + -- When we explicitly enable all the component kinds then selecting the + -- whole package selects those component kinds too + do (_,elaboratedPlan,_) <- planProject "targets/variety" config { + projectConfigLocalPackages = (projectConfigLocalPackages config) { + packageConfigTests = toFlag True, + packageConfigBenchmarks = toFlag True + } + } + assertProjectDistinctTargets + elaboratedPlan + CmdBuild.selectPackageTargets + CmdBuild.selectComponentTarget + CmdBuild.TargetProblemCommon + [ mkTargetPackage "p-0.1" ] + [ ("p-0.1-inplace", CLibName) + , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , ("p-0.1-inplace-an-exe", CExeName "an-exe") + , ("p-0.1-inplace-libp", CFLibName "libp") + ] + + reportSubCase "disabled component kinds" + -- When we explicitly disable all the component kinds then selecting the + -- whole package only selects the library, foreign lib and exes + do (_,elaboratedPlan,_) <- planProject "targets/variety" config { + projectConfigLocalPackages = (projectConfigLocalPackages config) { + packageConfigTests = toFlag False, + packageConfigBenchmarks = toFlag False + } + } + assertProjectDistinctTargets + elaboratedPlan + CmdBuild.selectPackageTargets + CmdBuild.selectComponentTarget + CmdBuild.TargetProblemCommon + [ mkTargetPackage "p-0.1" ] + [ ("p-0.1-inplace", CLibName) + , ("p-0.1-inplace-an-exe", CExeName "an-exe") + , ("p-0.1-inplace-libp", CFLibName "libp") + ] + + reportSubCase "requested component kinds" + -- When we selecting the package with an explicit filter then we get those + -- components even though we did not explicitly enable tests/benchmarks + do (_,elaboratedPlan,_) <- planProject "targets/variety" config + assertProjectDistinctTargets + elaboratedPlan + CmdBuild.selectPackageTargets + CmdBuild.selectComponentTarget + CmdBuild.TargetProblemCommon + [ TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) + , TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind) + ] + [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + ] + + +testTargetProblemsRepl :: ProjectConfig -> (String -> IO ()) -> Assertion +testTargetProblemsRepl config reportSubCase = do + + reportSubCase "multiple-libs" + assertProjectTargetProblems + "targets/multiple-libs" config + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ ( flip CmdRepl.TargetProblemMatchesMultiple + [ AvailableTarget "p-0.1" CLibName + (TargetBuildable () TargetRequestedByDefault) True + , AvailableTarget "q-0.1" CLibName + (TargetBuildable () TargetRequestedByDefault) True + ] + , mkTargetAllPackages ) + ] + + reportSubCase "multiple-exes" + assertProjectTargetProblems + "targets/multiple-exes" config + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ ( flip CmdRepl.TargetProblemMatchesMultiple + [ AvailableTarget "p-0.1" (CExeName "p2") + (TargetBuildable () TargetRequestedByDefault) True + , AvailableTarget "p-0.1" (CExeName "p1") + (TargetBuildable () TargetRequestedByDefault) True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "multiple-tests" + assertProjectTargetProblems + "targets/multiple-tests" config + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ ( flip CmdRepl.TargetProblemMatchesMultiple + [ AvailableTarget "p-0.1" (CTestName "p2") + (TargetBuildable () TargetNotRequestedByDefault) True + , AvailableTarget "p-0.1" (CTestName "p1") + (TargetBuildable () TargetNotRequestedByDefault) True + ] + , TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) ) + ] + + reportSubCase "multiple targets" + do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config + assertProjectDistinctTargets + elaboratedPlan + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ mkTargetComponent "p-0.1" (CExeName "p1") + , mkTargetComponent "p-0.1" (CExeName "p2") + ] + [ ("p-0.1-inplace-p1", CExeName "p1") + , ("p-0.1-inplace-p2", CExeName "p2") + ] + + reportSubCase "libs-disabled" + assertProjectTargetProblems + "targets/libs-disabled" config + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ ( flip CmdRepl.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" CLibName TargetNotBuildable True ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "exes-disabled" + assertProjectTargetProblems + "targets/exes-disabled" config + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ ( flip CmdRepl.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "test-only" + assertProjectTargetProblems + "targets/test-only" config + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ ( flip CmdRepl.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CTestName "pexe") + (TargetBuildable () TargetNotRequestedByDefault) True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "empty-pkg" + assertProjectTargetProblems + "targets/empty-pkg" config + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ ( CmdRepl.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "requested component kinds" + do (_,elaboratedPlan,_) <- planProject "targets/variety" config + -- by default we only get the lib + assertProjectDistinctTargets + elaboratedPlan + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ TargetPackage TargetExplicitNamed "p-0.1" Nothing ] + [ ("p-0.1-inplace", CLibName) ] + -- When we select the package with an explicit filter then we get those + -- components even though we did not explicitly enable tests/benchmarks + assertProjectDistinctTargets + elaboratedPlan + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) ] + [ ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") ] + assertProjectDistinctTargets + elaboratedPlan + CmdRepl.selectPackageTargets + CmdRepl.selectComponentTarget + CmdRepl.TargetProblemCommon + [ TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind) ] + [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") ] + + +testTargetProblemsRun :: ProjectConfig -> (String -> IO ()) -> Assertion +testTargetProblemsRun config reportSubCase = do + + reportSubCase "multiple-exes" + assertProjectTargetProblems + "targets/multiple-exes" config + CmdRun.selectPackageTargets + CmdRun.selectComponentTarget + CmdRun.TargetProblemCommon + [ ( flip CmdRun.TargetProblemMatchesMultiple + [ AvailableTarget "p-0.1" (CExeName "p2") + (TargetBuildable () TargetRequestedByDefault) True + , AvailableTarget "p-0.1" (CExeName "p1") + (TargetBuildable () TargetRequestedByDefault) True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "multiple targets" + do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config + assertProjectDistinctTargets + elaboratedPlan + CmdRun.selectPackageTargets + CmdRun.selectComponentTarget + CmdRun.TargetProblemCommon + [ mkTargetComponent "p-0.1" (CExeName "p1") + , mkTargetComponent "p-0.1" (CExeName "p2") + ] + [ ("p-0.1-inplace-p1", CExeName "p1") + , ("p-0.1-inplace-p2", CExeName "p2") + ] + + reportSubCase "exes-disabled" + assertProjectTargetProblems + "targets/exes-disabled" config + CmdRun.selectPackageTargets + CmdRun.selectComponentTarget + CmdRun.TargetProblemCommon + [ ( flip CmdRun.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "empty-pkg" + assertProjectTargetProblems + "targets/empty-pkg" config + CmdRun.selectPackageTargets + CmdRun.selectComponentTarget + CmdRun.TargetProblemCommon + [ ( CmdRun.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "test-only" + assertProjectTargetProblems + "targets/test-only" config + CmdRun.selectPackageTargets + CmdRun.selectComponentTarget + CmdRun.TargetProblemCommon + [ ( CmdRun.TargetProblemNoExes, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "variety" + assertProjectTargetProblems + "targets/variety" config + CmdRun.selectPackageTargets + CmdRun.selectComponentTarget + CmdRun.TargetProblemCommon $ + [ ( const (CmdRun.TargetProblemComponentNotExe "p-0.1" cname) + , mkTargetComponent "p-0.1" cname ) + | cname <- [ CLibName, CFLibName "libp", + CTestName "a-testsuite", CBenchName "a-benchmark" ] + ] ++ + [ ( const (CmdRun.TargetProblemIsSubComponent + "p-0.1" cname (ModuleTarget modname)) + , mkTargetModule "p-0.1" cname modname ) + | (cname, modname) <- [ (CTestName "a-testsuite", "TestModule") + , (CBenchName "a-benchmark", "BenchModule") + , (CExeName "an-exe", "ExeModule") + , (CLibName, "P") + ] + ] ++ + [ ( const (CmdRun.TargetProblemIsSubComponent + "p-0.1" cname (FileTarget fname)) + , mkTargetFile "p-0.1" cname fname) + | (cname, fname) <- [ (CTestName "a-testsuite", "Test.hs") + , (CBenchName "a-benchmark", "Bench.hs") + , (CExeName "an-exe", "Main.hs") + ] + ] + + +testTargetProblemsTest :: ProjectConfig -> (String -> IO ()) -> Assertion +testTargetProblemsTest config reportSubCase = do + + reportSubCase "disabled by config" + assertProjectTargetProblems + "targets/tests-disabled" + config { + projectConfigLocalPackages = (projectConfigLocalPackages config) { + packageConfigTests = toFlag False + } + } + CmdTest.selectPackageTargets + CmdTest.selectComponentTarget + CmdTest.TargetProblemCommon + [ ( flip CmdTest.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CTestName "user-disabled") + TargetDisabledByUser True + , AvailableTarget "p-0.1" (CTestName "solver-disabled") + TargetDisabledByUser True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "disabled by solver & buildable false" + assertProjectTargetProblems + "targets/tests-disabled" + config + CmdTest.selectPackageTargets + CmdTest.selectComponentTarget + CmdTest.TargetProblemCommon + [ ( flip CmdTest.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CTestName "user-disabled") + TargetDisabledBySolver True + , AvailableTarget "p-0.1" (CTestName "solver-disabled") + TargetDisabledBySolver True + ] + , mkTargetPackage "p-0.1" ) + + , ( flip CmdTest.TargetProblemNoneEnabled + [ AvailableTarget "q-0.1" (CTestName "buildable-false") + TargetNotBuildable True + ] + , mkTargetPackage "q-0.1" ) + ] + + reportSubCase "empty-pkg" + assertProjectTargetProblems + "targets/empty-pkg" config + CmdTest.selectPackageTargets + CmdTest.selectComponentTarget + CmdTest.TargetProblemCommon + [ ( CmdTest.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "no tests" + assertProjectTargetProblems + "targets/simple" + config + CmdTest.selectPackageTargets + CmdTest.selectComponentTarget + CmdTest.TargetProblemCommon + [ ( CmdTest.TargetProblemNoTests, mkTargetPackage "p-0.1" ) + , ( CmdTest.TargetProblemNoTests, mkTargetPackage "q-0.1" ) + ] + + reportSubCase "not a test" + assertProjectTargetProblems + "targets/variety" + config + CmdTest.selectPackageTargets + CmdTest.selectComponentTarget + CmdTest.TargetProblemCommon $ + [ ( const (CmdTest.TargetProblemComponentNotTest + "p-0.1" CLibName) + , mkTargetComponent "p-0.1" CLibName ) + + , ( const (CmdTest.TargetProblemComponentNotTest + "p-0.1" (CExeName "an-exe")) + , mkTargetComponent "p-0.1" (CExeName "an-exe") ) + + , ( const (CmdTest.TargetProblemComponentNotTest + "p-0.1" (CFLibName "libp")) + , mkTargetComponent "p-0.1" (CFLibName "libp") ) + + , ( const (CmdTest.TargetProblemComponentNotTest + "p-0.1" (CBenchName "a-benchmark")) + , mkTargetComponent "p-0.1" (CBenchName "a-benchmark") ) + ] ++ + [ ( const (CmdTest.TargetProblemIsSubComponent + "p-0.1" cname (ModuleTarget modname)) + , mkTargetModule "p-0.1" cname modname ) + | (cname, modname) <- [ (CTestName "a-testsuite", "TestModule") + , (CBenchName "a-benchmark", "BenchModule") + , (CExeName "an-exe", "ExeModule") + , (CLibName, "P") + ] + ] ++ + [ ( const (CmdTest.TargetProblemIsSubComponent + "p-0.1" cname (FileTarget fname)) + , mkTargetFile "p-0.1" cname fname) + | (cname, fname) <- [ (CTestName "a-testsuite", "Test.hs") + , (CBenchName "a-benchmark", "Bench.hs") + , (CExeName "an-exe", "Main.hs") + ] + ] + + +testTargetProblemsBench :: ProjectConfig -> (String -> IO ()) -> Assertion +testTargetProblemsBench config reportSubCase = do + + reportSubCase "disabled by config" + assertProjectTargetProblems + "targets/benchmarks-disabled" + config { + projectConfigLocalPackages = (projectConfigLocalPackages config) { + packageConfigBenchmarks = toFlag False + } + } + CmdBench.selectPackageTargets + CmdBench.selectComponentTarget + CmdBench.TargetProblemCommon + [ ( flip CmdBench.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CBenchName "user-disabled") + TargetDisabledByUser True + , AvailableTarget "p-0.1" (CBenchName "solver-disabled") + TargetDisabledByUser True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "disabled by solver & buildable false" + assertProjectTargetProblems + "targets/benchmarks-disabled" + config + CmdBench.selectPackageTargets + CmdBench.selectComponentTarget + CmdBench.TargetProblemCommon + [ ( flip CmdBench.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CBenchName "user-disabled") + TargetDisabledBySolver True + , AvailableTarget "p-0.1" (CBenchName "solver-disabled") + TargetDisabledBySolver True + ] + , mkTargetPackage "p-0.1" ) + + , ( flip CmdBench.TargetProblemNoneEnabled + [ AvailableTarget "q-0.1" (CBenchName "buildable-false") + TargetNotBuildable True + ] + , mkTargetPackage "q-0.1" ) + ] + + reportSubCase "empty-pkg" + assertProjectTargetProblems + "targets/empty-pkg" config + CmdBench.selectPackageTargets + CmdBench.selectComponentTarget + CmdBench.TargetProblemCommon + [ ( CmdBench.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "no benchmarks" + assertProjectTargetProblems + "targets/simple" + config + CmdBench.selectPackageTargets + CmdBench.selectComponentTarget + CmdBench.TargetProblemCommon + [ ( CmdBench.TargetProblemNoBenchmarks, mkTargetPackage "p-0.1" ) + , ( CmdBench.TargetProblemNoBenchmarks, mkTargetPackage "q-0.1" ) + ] + + reportSubCase "not a benchmark" + assertProjectTargetProblems + "targets/variety" + config + CmdBench.selectPackageTargets + CmdBench.selectComponentTarget + CmdBench.TargetProblemCommon $ + [ ( const (CmdBench.TargetProblemComponentNotBenchmark + "p-0.1" CLibName) + , mkTargetComponent "p-0.1" CLibName ) + + , ( const (CmdBench.TargetProblemComponentNotBenchmark + "p-0.1" (CExeName "an-exe")) + , mkTargetComponent "p-0.1" (CExeName "an-exe") ) + + , ( const (CmdBench.TargetProblemComponentNotBenchmark + "p-0.1" (CFLibName "libp")) + , mkTargetComponent "p-0.1" (CFLibName "libp") ) + + , ( const (CmdBench.TargetProblemComponentNotBenchmark + "p-0.1" (CTestName "a-testsuite")) + , mkTargetComponent "p-0.1" (CTestName "a-testsuite") ) + ] ++ + [ ( const (CmdBench.TargetProblemIsSubComponent + "p-0.1" cname (ModuleTarget modname)) + , mkTargetModule "p-0.1" cname modname ) + | (cname, modname) <- [ (CTestName "a-testsuite", "TestModule") + , (CBenchName "a-benchmark", "BenchModule") + , (CExeName "an-exe", "ExeModule") + , (CLibName, "P") + ] + ] ++ + [ ( const (CmdBench.TargetProblemIsSubComponent + "p-0.1" cname (FileTarget fname)) + , mkTargetFile "p-0.1" cname fname) + | (cname, fname) <- [ (CTestName "a-testsuite", "Test.hs") + , (CBenchName "a-benchmark", "Bench.hs") + , (CExeName "an-exe", "Main.hs") + ] + ] + + +testTargetProblemsHaddock :: ProjectConfig -> (String -> IO ()) -> Assertion +testTargetProblemsHaddock config reportSubCase = do + + reportSubCase "all-disabled" + assertProjectTargetProblems + "targets/all-disabled" + config + (let haddockFlags = mkHaddockFlags False True True False + in CmdHaddock.selectPackageTargets haddockFlags) + CmdHaddock.selectComponentTarget + CmdHaddock.TargetProblemCommon + [ ( flip CmdHaddock.TargetProblemNoneEnabled + [ AvailableTarget "p-0.1" (CBenchName "user-disabled") + TargetDisabledByUser True + , AvailableTarget "p-0.1" (CTestName "solver-disabled") + TargetDisabledBySolver True + , AvailableTarget "p-0.1" (CExeName "buildable-false") + TargetNotBuildable True + , AvailableTarget "p-0.1" CLibName + TargetNotBuildable True + ] + , mkTargetPackage "p-0.1" ) + ] + + reportSubCase "empty-pkg" + assertProjectTargetProblems + "targets/empty-pkg" config + (let haddockFlags = mkHaddockFlags False False False False + in CmdHaddock.selectPackageTargets haddockFlags) + CmdHaddock.selectComponentTarget + CmdHaddock.TargetProblemCommon + [ ( CmdHaddock.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) + ] + + reportSubCase "enabled component kinds" + -- When we explicitly enable all the component kinds then selecting the + -- whole package selects those component kinds too + (_,elaboratedPlan,_) <- planProject "targets/variety" config + let haddockFlags = mkHaddockFlags True True True True + in assertProjectDistinctTargets + elaboratedPlan + (CmdHaddock.selectPackageTargets haddockFlags) + CmdHaddock.selectComponentTarget + CmdHaddock.TargetProblemCommon + [ mkTargetPackage "p-0.1" ] + [ ("p-0.1-inplace", CLibName) + , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , ("p-0.1-inplace-an-exe", CExeName "an-exe") + , ("p-0.1-inplace-libp", CFLibName "libp") + ] + + reportSubCase "disabled component kinds" + -- When we explicitly disable all the component kinds then selecting the + -- whole package only selects the library + let haddockFlags = mkHaddockFlags False False False False + in assertProjectDistinctTargets + elaboratedPlan + (CmdHaddock.selectPackageTargets haddockFlags) + CmdHaddock.selectComponentTarget + CmdHaddock.TargetProblemCommon + [ mkTargetPackage "p-0.1" ] + [ ("p-0.1-inplace", CLibName) ] + + reportSubCase "requested component kinds" + -- When we selecting the package with an explicit filter then it does not + -- matter if the config was to disable all the component kinds + let haddockFlags = mkHaddockFlags False False False False + in assertProjectDistinctTargets + elaboratedPlan + (CmdHaddock.selectPackageTargets haddockFlags) + CmdHaddock.selectComponentTarget + CmdHaddock.TargetProblemCommon + [ TargetPackage TargetExplicitNamed "p-0.1" (Just FLibKind) + , TargetPackage TargetExplicitNamed "p-0.1" (Just ExeKind) + , TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) + , TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind) + ] + [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , ("p-0.1-inplace-an-exe", CExeName "an-exe") + , ("p-0.1-inplace-libp", CFLibName "libp") + ] + where + mkHaddockFlags flib exe test bench = + defaultHaddockFlags { + haddockForeignLibs = toFlag flib, + haddockExecutables = toFlag exe, + haddockTestSuites = toFlag test, + haddockBenchmarks = toFlag bench + } + +assertProjectDistinctTargets + :: forall err. (Eq err, Show err) => + ElaboratedInstallPlan + -> (forall k. TargetSelector PackageId -> [AvailableTarget k] -> Either err [k]) + -> (forall k. PackageId -> ComponentName -> SubComponentTarget -> AvailableTarget k -> Either err k ) + -> (TargetProblemCommon -> err) + -> [TargetSelector PackageId] + -> [(UnitId, ComponentName)] + -> Assertion +assertProjectDistinctTargets elaboratedPlan + selectPackageTargets + selectComponentTarget + liftProblem + targetSelectors + expectedTargets + | Right targets <- results + = distinctTargetComponents targets @?= Set.fromList expectedTargets + + | otherwise + = assertFailure $ "assertProjectDistinctTargets: expected " + ++ "(Right targets) but got " ++ show results + where + results = resolveTargets + selectPackageTargets + selectComponentTarget + liftProblem + elaboratedPlan + targetSelectors + + +assertProjectTargetProblems + :: forall err. (Eq err, Show err) => + FilePath -> ProjectConfig + -> (forall k. TargetSelector PackageId + -> [AvailableTarget k] + -> Either err [k]) + -> (forall k. PackageId -> ComponentName -> SubComponentTarget + -> AvailableTarget k + -> Either err k ) + -> (TargetProblemCommon -> err) + -> [(TargetSelector PackageId -> err, TargetSelector PackageId)] + -> Assertion +assertProjectTargetProblems testdir config + selectPackageTargets + selectComponentTarget + liftProblem + cases = do + (_,elaboratedPlan,_) <- planProject testdir config + assertTargetProblems + elaboratedPlan + selectPackageTargets + selectComponentTarget + liftProblem + cases + + +assertTargetProblems + :: forall err. (Eq err, Show err) => + ElaboratedInstallPlan + -> (forall k. TargetSelector PackageId -> [AvailableTarget k] -> Either err [k]) + -> (forall k. PackageId -> ComponentName -> SubComponentTarget -> AvailableTarget k -> Either err k ) + -> (TargetProblemCommon -> err) + -> [(TargetSelector PackageId -> err, TargetSelector PackageId)] + -> Assertion +assertTargetProblems elaboratedPlan + selectPackageTargets + selectComponentTarget + liftProblem = + mapM_ (uncurry assertTargetProblem) + where + assertTargetProblem expected targetSelector = + let res = resolveTargets selectPackageTargets selectComponentTarget + liftProblem elaboratedPlan [targetSelector] in + case res of + Left [problem] -> + problem @?= expected targetSelector + + unexpected -> + assertFailure $ "expected resolveTargets result: (Left [problem]) " + ++ "but got: " ++ show unexpected + + +testExceptionInFindingPackage :: ProjectConfig -> Assertion +testExceptionInFindingPackage config = do + BadPackageLocations _ locs <- expectException "BadPackageLocations" $ + void $ planProject testdir config + case locs of + [BadLocGlobEmptyMatch "./*.cabal"] -> return () + _ -> assertFailure "expected BadLocGlobEmptyMatch" + cleanProject testdir + where + testdir = "exception/no-pkg" + + +testExceptionInFindingPackage2 :: ProjectConfig -> Assertion +testExceptionInFindingPackage2 config = do + BadPackageLocations _ locs <- expectException "BadPackageLocations" $ + void $ planProject testdir config + case locs of + [BadPackageLocationFile (BadLocDirNoCabalFile ".")] -> return () + _ -> assertFailure $ "expected BadLocDirNoCabalFile, got " ++ show locs + cleanProject testdir + where + testdir = "exception/no-pkg2" + + +testExceptionInProjectConfig :: ProjectConfig -> Assertion +testExceptionInProjectConfig config = do + BadPerPackageCompilerPaths ps <- expectException "BadPerPackageCompilerPaths" $ + void $ planProject testdir config + case ps of + [(pn,"ghc")] | "foo" == pn -> return () + _ -> assertFailure $ "expected (PackageName \"foo\",\"ghc\"), got " + ++ show ps + cleanProject testdir + where + testdir = "exception/bad-config" + + +testExceptionInConfigureStep :: ProjectConfig -> Assertion +testExceptionInConfigureStep config = do + (plan, res) <- executePlan =<< planProject testdir config + (_pkga1, failure) <- expectPackageFailed plan res pkgidA1 + case buildFailureReason failure of + ConfigureFailed _ -> return () + _ -> assertFailure $ "expected ConfigureFailed, got " ++ show failure + cleanProject testdir + where + testdir = "exception/configure" + pkgidA1 = PackageIdentifier "a" (mkVersion [1]) + + +testExceptionInBuildStep :: ProjectConfig -> Assertion +testExceptionInBuildStep config = do + (plan, res) <- executePlan =<< planProject testdir config + (_pkga1, failure) <- expectPackageFailed plan res pkgidA1 + expectBuildFailed failure + where + testdir = "exception/build" + pkgidA1 = PackageIdentifier "a" (mkVersion [1]) + +testSetupScriptStyles :: ProjectConfig -> (String -> IO ()) -> Assertion +testSetupScriptStyles config reportSubCase = do + + reportSubCase (show SetupCustomExplicitDeps) + + plan0@(_,_,sharedConfig) <- planProject testdir1 config + + let isOSX (Platform _ OSX) = True + isOSX _ = False + -- Skip the Custom tests when the shipped Cabal library is buggy + unless (isOSX (pkgConfigPlatform sharedConfig) + && compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [7,10]) $ do + + (plan1, res1) <- executePlan plan0 + (pkg1, _) <- expectPackageInstalled plan1 res1 pkgidA + elabSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps + hasDefaultSetupDeps pkg1 @?= Just False + marker1 <- readFile (basedir testdir1 "marker") + marker1 @?= "ok" + removeFile (basedir testdir1 "marker") + + reportSubCase (show SetupCustomImplicitDeps) + (plan2, res2) <- executePlan =<< planProject testdir2 config + (pkg2, _) <- expectPackageInstalled plan2 res2 pkgidA + elabSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps + hasDefaultSetupDeps pkg2 @?= Just True + marker2 <- readFile (basedir testdir2 "marker") + marker2 @?= "ok" + removeFile (basedir testdir2 "marker") + + reportSubCase (show SetupNonCustomInternalLib) + (plan3, res3) <- executePlan =<< planProject testdir3 config + (pkg3, _) <- expectPackageInstalled plan3 res3 pkgidA + elabSetupScriptStyle pkg3 @?= SetupNonCustomInternalLib +{- + --TODO: the SetupNonCustomExternalLib case is hard to test since it + -- requires a version of Cabal that's later than the one we're testing + -- e.g. needs a .cabal file that specifies cabal-version: >= 2.0 + -- and a corresponding Cabal package that we can use to try and build a + -- default Setup.hs. + reportSubCase (show SetupNonCustomExternalLib) + (plan4, res4) <- executePlan =<< planProject testdir4 config + (pkg4, _) <- expectPackageInstalled plan4 res4 pkgidA + pkgSetupScriptStyle pkg4 @?= SetupNonCustomExternalLib +-} + where + testdir1 = "build/setup-custom1" + testdir2 = "build/setup-custom2" + testdir3 = "build/setup-simple" + pkgidA = PackageIdentifier "a" (mkVersion [0,1]) + -- The solver fills in default setup deps explicitly, but marks them as such + hasDefaultSetupDeps = fmap defaultSetupDepends + . setupBuildInfo . elabPkgDescription + +-- | Test the behaviour with and without @--keep-going@ +-- +testBuildKeepGoing :: ProjectConfig -> Assertion +testBuildKeepGoing config = do + -- P is expected to fail, Q does not depend on P but without + -- parallel build and without keep-going then we don't build Q yet. + (plan1, res1) <- executePlan =<< planProject testdir (config <> keepGoing False) + (_, failure1) <- expectPackageFailed plan1 res1 "p-0.1" + expectBuildFailed failure1 + _ <- expectPackageConfigured plan1 res1 "q-0.1" + + -- With keep-going then we should go on to sucessfully build Q + (plan2, res2) <- executePlan + =<< planProject testdir (config <> keepGoing True) + (_, failure2) <- expectPackageFailed plan2 res2 "p-0.1" + expectBuildFailed failure2 + _ <- expectPackageInstalled plan2 res2 "q-0.1" + return () + where + testdir = "build/keep-going" + keepGoing kg = + mempty { + projectConfigBuildOnly = mempty { + projectConfigKeepGoing = toFlag kg + } + } + +-- | See +-- +testRegressionIssue3324 :: ProjectConfig -> Assertion +testRegressionIssue3324 config = do + -- expected failure first time due to missing dep + (plan1, res1) <- executePlan =<< planProject testdir config + (_pkgq, failure) <- expectPackageFailed plan1 res1 "q-0.1" + expectBuildFailed failure + + -- add the missing dep, now it should work + let qcabal = basedir testdir "q" "q.cabal" + withFileFinallyRestore qcabal $ do + appendFile qcabal (" build-depends: p\n") + (plan2, res2) <- executePlan =<< planProject testdir config + _ <- expectPackageInstalled plan2 res2 "p-0.1" + _ <- expectPackageInstalled plan2 res2 "q-0.1" + return () + where + testdir = "regression/3324" + + +--------------------------------- +-- Test utils to plan and build +-- + +basedir :: FilePath +basedir = "tests" "IntegrationTests2" + +dirActions :: FilePath -> TS.DirActions IO +dirActions testdir = + defaultDirActions { + TS.doesFileExist = \p -> + TS.doesFileExist defaultDirActions (virtcwd p), + + TS.doesDirectoryExist = \p -> + TS.doesDirectoryExist defaultDirActions (virtcwd p), + + TS.canonicalizePath = \p -> + TS.canonicalizePath defaultDirActions (virtcwd p), + + TS.getCurrentDirectory = + TS.canonicalizePath defaultDirActions virtcwd + } + where + virtcwd = basedir testdir + +type ProjDetails = (DistDirLayout, + CabalDirLayout, + ProjectConfig, + [PackageSpecifier UnresolvedSourcePackage], + BuildTimeSettings) + +configureProject :: FilePath -> ProjectConfig -> IO ProjDetails +configureProject testdir cliConfig = do + cabalDir <- defaultCabalDir + let cabalDirLayout = defaultCabalDirLayout cabalDir + + projectRootDir <- canonicalizePath (basedir testdir) + isexplict <- doesFileExist (projectRootDir "cabal.project") + let projectRoot + | isexplict = ProjectRootExplicit projectRootDir + (projectRootDir "cabal.project") + | otherwise = ProjectRootImplicit projectRootDir + distDirLayout = defaultDistDirLayout projectRoot Nothing + + -- Clear state between test runs. The state remains if the previous run + -- ended in an exception (as we leave the files to help with debugging). + cleanProject testdir + + (projectConfig, localPackages) <- + rebuildProjectConfig verbosity + distDirLayout + cliConfig + + let buildSettings = resolveBuildTimeSettings + verbosity cabalDirLayout + projectConfig + + return (distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + buildSettings) + +type PlanDetails = (ProjDetails, + ElaboratedInstallPlan, + ElaboratedSharedConfig) + +planProject :: FilePath -> ProjectConfig -> IO PlanDetails +planProject testdir cliConfig = do + + projDetails@ + (distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + _buildSettings) <- configureProject testdir cliConfig + + (elaboratedPlan, _, elaboratedShared) <- + rebuildInstallPlan verbosity + distDirLayout cabalDirLayout + projectConfig + localPackages + + return (projDetails, + elaboratedPlan, + elaboratedShared) + +executePlan :: PlanDetails -> IO (ElaboratedInstallPlan, BuildOutcomes) +executePlan ((distDirLayout, cabalDirLayout, _, _, buildSettings), + elaboratedPlan, + elaboratedShared) = do + + let targets :: Map.Map UnitId [ComponentTarget] + targets = + Map.fromList + [ (unitid, [ComponentTarget cname WholeComponent]) + | ts <- Map.elems (availableTargets elaboratedPlan) + , AvailableTarget { + availableTargetStatus = TargetBuildable (unitid, cname) _ + } <- ts + ] + elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuild targets + elaboratedPlan + + pkgsBuildStatus <- + rebuildTargetsDryRun distDirLayout elaboratedShared + elaboratedPlan' + + let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages + pkgsBuildStatus elaboratedPlan' + + buildOutcomes <- + rebuildTargets verbosity + distDirLayout + (cabalStoreDirLayout cabalDirLayout) + elaboratedPlan'' + elaboratedShared + pkgsBuildStatus + -- Avoid trying to use act-as-setup mode: + buildSettings { buildSettingNumJobs = 1 } + + return (elaboratedPlan'', buildOutcomes) + +cleanProject :: FilePath -> IO () +cleanProject testdir = do + alreadyExists <- doesDirectoryExist distDir + when alreadyExists $ removeDirectoryRecursive distDir + where + projectRoot = ProjectRootImplicit (basedir testdir) + distDirLayout = defaultDistDirLayout projectRoot Nothing + distDir = distDirectory distDirLayout + + +verbosity :: Verbosity +verbosity = minBound --normal --verbose --maxBound --minBound + + + +------------------------------------------- +-- Tasty integration to adjust the config +-- + +withProjectConfig :: (ProjectConfig -> TestTree) -> TestTree +withProjectConfig testtree = + askOption $ \ghcPath -> + testtree (mkProjectConfig ghcPath) + +mkProjectConfig :: GhcPath -> ProjectConfig +mkProjectConfig (GhcPath ghcPath) = + mempty { + projectConfigShared = mempty { + projectConfigHcPath = maybeToFlag ghcPath + }, + projectConfigBuildOnly = mempty { + projectConfigNumJobs = toFlag (Just 1) + } + } + where + maybeToFlag = maybe mempty toFlag + + +data GhcPath = GhcPath (Maybe FilePath) + deriving Typeable + +instance IsOption GhcPath where + defaultValue = GhcPath Nothing + optionName = Tagged "with-ghc" + optionHelp = Tagged "The ghc compiler to use" + parseValue = Just . GhcPath . Just + +projectConfigOptionDescriptions :: [OptionDescription] +projectConfigOptionDescriptions = [Option (Proxy :: Proxy GhcPath)] + + +--------------------------------------- +-- HUint style utils for this context +-- + +expectException :: Exception e => String -> IO a -> IO e +expectException expected action = do + res <- try action + case res of + Left e -> return e + Right _ -> throwIO $ HUnitFailure Nothing $ "expected an exception " ++ expected + +expectPackagePreExisting :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId + -> IO InstalledPackageInfo +expectPackagePreExisting plan buildOutcomes pkgid = do + planpkg <- expectPlanPackage plan pkgid + case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of + (InstallPlan.PreExisting pkg, Nothing) + -> return pkg + (_, buildResult) -> unexpectedBuildResult "PreExisting" planpkg buildResult + +expectPackageConfigured :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId + -> IO ElaboratedConfiguredPackage +expectPackageConfigured plan buildOutcomes pkgid = do + planpkg <- expectPlanPackage plan pkgid + case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of + (InstallPlan.Configured pkg, Nothing) + -> return pkg + (_, buildResult) -> unexpectedBuildResult "Configured" planpkg buildResult + +expectPackageInstalled :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId + -> IO (ElaboratedConfiguredPackage, BuildResult) +expectPackageInstalled plan buildOutcomes pkgid = do + planpkg <- expectPlanPackage plan pkgid + case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of + (InstallPlan.Configured pkg, Just (Right result)) + -> return (pkg, result) + (_, buildResult) -> unexpectedBuildResult "Installed" planpkg buildResult + +expectPackageFailed :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId + -> IO (ElaboratedConfiguredPackage, BuildFailure) +expectPackageFailed plan buildOutcomes pkgid = do + planpkg <- expectPlanPackage plan pkgid + case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of + (InstallPlan.Configured pkg, Just (Left failure)) + -> return (pkg, failure) + (_, buildResult) -> unexpectedBuildResult "Failed" planpkg buildResult + +unexpectedBuildResult :: String -> ElaboratedPlanPackage + -> Maybe (Either BuildFailure BuildResult) -> IO a +unexpectedBuildResult expected planpkg buildResult = + throwIO $ HUnitFailure Nothing $ + "expected to find " ++ display (packageId planpkg) ++ " in the " + ++ expected ++ " state, but it is actually in the " ++ actual ++ " state." + where + actual = case (buildResult, planpkg) of + (Nothing, InstallPlan.PreExisting{}) -> "PreExisting" + (Nothing, InstallPlan.Configured{}) -> "Configured" + (Just (Right _), InstallPlan.Configured{}) -> "Installed" + (Just (Left _), InstallPlan.Configured{}) -> "Failed" + _ -> "Impossible!" + +expectPlanPackage :: ElaboratedInstallPlan -> PackageId + -> IO ElaboratedPlanPackage +expectPlanPackage plan pkgid = + case [ pkg + | pkg <- InstallPlan.toList plan + , packageId pkg == pkgid ] of + [pkg] -> return pkg + [] -> throwIO $ HUnitFailure Nothing $ + "expected to find " ++ display pkgid + ++ " in the install plan but it's not there" + _ -> throwIO $ HUnitFailure Nothing $ "expected to find only one instance of " ++ display pkgid ++ " in the install plan but there's several" diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/all-disabled/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/targets/all-disabled/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/all-disabled/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/all-disabled/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/all-disabled/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/all-disabled/p.cabal @@ -0,0 +1,23 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Q + build-depends: base, filepath + buildable: False + +executable buildable-false + main-is: Main.hs + buildable: False + +test-suite solver-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: a-package-that-does-not-exist + +benchmark user-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project @@ -0,0 +1,1 @@ +packages: ./ ./q/ diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal @@ -0,0 +1,15 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +benchmark solver-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: a-package-that-does-not-exist + +benchmark user-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: base + diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal @@ -0,0 +1,10 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +benchmark buildable-false + type: exitcode-stdio-1.0 + main-is: Main.hs + buildable: False + diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/complex/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/targets/complex/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/complex/cabal.project @@ -0,0 +1,1 @@ +packages: q/ diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/complex/q/Q.hs b/cabal/cabal-install/tests/IntegrationTests2/targets/complex/q/Q.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/complex/q/Q.hs diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/complex/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/complex/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/complex/q/q.cabal @@ -0,0 +1,22 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Q + build-depends: base, filepath + +executable buildable-false + main-is: Main.hs + buildable: False + +test-suite solver-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: a-package-that-does-not-exist + +benchmark user-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/empty-pkg/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/targets/empty-pkg/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/empty-pkg/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/empty-pkg/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/empty-pkg/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/empty-pkg/p.cabal @@ -0,0 +1,5 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/empty/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/targets/empty/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/empty/cabal.project @@ -0,0 +1,1 @@ +packages: diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/empty/foo.hs b/cabal/cabal-install/tests/IntegrationTests2/targets/empty/foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/empty/foo.hs diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/exes-disabled/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/targets/exes-disabled/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/exes-disabled/cabal.project @@ -0,0 +1,1 @@ +packages: p/ q/ diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/exes-disabled/p/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/exes-disabled/p/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/exes-disabled/p/p.cabal @@ -0,0 +1,9 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +executable p + main-is: P.hs + build-depends: base + buildable: False diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/exes-disabled/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/exes-disabled/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/exes-disabled/q/q.cabal @@ -0,0 +1,9 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +executable q + main-is: Q.hs + build-depends: base + buildable: False diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/libs-disabled/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/targets/libs-disabled/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/libs-disabled/cabal.project @@ -0,0 +1,1 @@ +packages: p/ q/ diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/libs-disabled/p/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/libs-disabled/p/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/libs-disabled/p/p.cabal @@ -0,0 +1,9 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: P + build-depends: base + buildable: False diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/libs-disabled/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/libs-disabled/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/libs-disabled/q/q.cabal @@ -0,0 +1,9 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Q + build-depends: base + buildable: False diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-exes/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-exes/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-exes/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-exes/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-exes/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-exes/p.cabal @@ -0,0 +1,12 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +executable p1 + main-is: P1.hs + build-depends: base + +executable p2 + main-is: P2.hs + build-depends: base diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-libs/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-libs/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-libs/cabal.project @@ -0,0 +1,1 @@ +packages: p/ q/ diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-libs/p/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-libs/p/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-libs/p/p.cabal @@ -0,0 +1,8 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: P + build-depends: base diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-libs/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-libs/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-libs/q/q.cabal @@ -0,0 +1,8 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Q + build-depends: base diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-tests/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-tests/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-tests/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-tests/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-tests/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/multiple-tests/p.cabal @@ -0,0 +1,14 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +test-suite p1 + type: exitcode-stdio-1.0 + main-is: P1.hs + build-depends: base + +test-suite p2 + type: exitcode-stdio-1.0 + main-is: P2.hs + build-depends: base diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/simple/P.hs b/cabal/cabal-install/tests/IntegrationTests2/targets/simple/P.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/simple/P.hs diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/simple/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/targets/simple/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/simple/cabal.project @@ -0,0 +1,1 @@ +packages: ./ q/ diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/simple/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/simple/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/simple/p.cabal @@ -0,0 +1,12 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: P + build-depends: base + +executable pexe + main-is: Main.hs + other-modules: PMain diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/simple/q/QQ.hs b/cabal/cabal-install/tests/IntegrationTests2/targets/simple/q/QQ.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/simple/q/QQ.hs diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/simple/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/simple/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/simple/q/q.cabal @@ -0,0 +1,12 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: QQ + build-depends: base + +executable qexe + main-is: Main.hs + other-modules: QMain diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/test-only/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/test-only/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/test-only/p.cabal @@ -0,0 +1,9 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +test-suite pexe + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: PMain diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/tests-disabled/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/targets/tests-disabled/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/tests-disabled/cabal.project @@ -0,0 +1,1 @@ +packages: ./ ./q/ diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/tests-disabled/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/tests-disabled/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/tests-disabled/p.cabal @@ -0,0 +1,15 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +test-suite solver-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: a-package-that-does-not-exist + +test-suite user-disabled + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: base + diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/tests-disabled/q/q.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/tests-disabled/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/tests-disabled/q/q.cabal @@ -0,0 +1,10 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +test-suite buildable-false + type: exitcode-stdio-1.0 + main-is: Main.hs + buildable: False + diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/variety/cabal.project b/cabal/cabal-install/tests/IntegrationTests2/targets/variety/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/variety/cabal.project @@ -0,0 +1,1 @@ +packages: ./ diff --git a/cabal/cabal-install/tests/IntegrationTests2/targets/variety/p.cabal b/cabal/cabal-install/tests/IntegrationTests2/targets/variety/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/IntegrationTests2/targets/variety/p.cabal @@ -0,0 +1,27 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: P + build-depends: base + +foreign-library libp + type: native-shared + other-modules: FLib + +executable an-exe + main-is: Main.hs + other-modules: AModule + +test-suite a-testsuite + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: AModule + +benchmark a-benchmark + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: AModule + diff --git a/cabal/cabal-install/tests/MemoryUsageTests.hs b/cabal/cabal-install/tests/MemoryUsageTests.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/MemoryUsageTests.hs @@ -0,0 +1,15 @@ +module MemoryUsageTests where + +import Test.Tasty + +import qualified UnitTests.Distribution.Solver.Modular.MemoryUsage + +tests :: TestTree +tests = + testGroup "Memory Usage" + [ testGroup "UnitTests.Distribution.Solver.Modular.MemoryUsage" + UnitTests.Distribution.Solver.Modular.MemoryUsage.tests + ] + +main :: IO () +main = defaultMain tests diff --git a/cabal/cabal-install/tests/SolverQuickCheck.hs b/cabal/cabal-install/tests/SolverQuickCheck.hs --- a/cabal/cabal-install/tests/SolverQuickCheck.hs +++ b/cabal/cabal-install/tests/SolverQuickCheck.hs @@ -1,4 +1,4 @@ -module Main where +module SolverQuickCheck where import Test.Tasty diff --git a/cabal/cabal-install/tests/UnitTests.hs b/cabal/cabal-install/tests/UnitTests.hs --- a/cabal/cabal-install/tests/UnitTests.hs +++ b/cabal/cabal-install/tests/UnitTests.hs @@ -1,7 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Main - where +module UnitTests where import Test.Tasty @@ -10,7 +9,7 @@ import Distribution.Compat.Time -import qualified UnitTests.Distribution.Solver.Modular.PSQ +import qualified UnitTests.Distribution.Solver.Modular.Builder import qualified UnitTests.Distribution.Solver.Modular.WeightedPSQ import qualified UnitTests.Distribution.Solver.Modular.Solver import qualified UnitTests.Distribution.Solver.Modular.RetryLog @@ -19,6 +18,7 @@ import qualified UnitTests.Distribution.Client.GZipUtils import qualified UnitTests.Distribution.Client.Sandbox import qualified UnitTests.Distribution.Client.Sandbox.Timestamp +import qualified UnitTests.Distribution.Client.Store import qualified UnitTests.Distribution.Client.Tar import qualified UnitTests.Distribution.Client.Targets import qualified UnitTests.Distribution.Client.UserConfig @@ -38,8 +38,8 @@ else mtimeChangeCalibrated in testGroup "Unit Tests" - [ testGroup "UnitTests.Distribution.Solver.Modular.PSQ" - UnitTests.Distribution.Solver.Modular.PSQ.tests + [ testGroup "UnitTests.Distribution.Solver.Modular.Builder" + UnitTests.Distribution.Solver.Modular.Builder.tests , testGroup "UnitTests.Distribution.Solver.Modular.WeightedPSQ" UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests , testGroup "UnitTests.Distribution.Solver.Modular.Solver" @@ -56,6 +56,8 @@ UnitTests.Distribution.Client.Sandbox.tests , testGroup "Distribution.Client.Sandbox.Timestamp" UnitTests.Distribution.Client.Sandbox.Timestamp.tests + , testGroup "Distribution.Client.Store" + UnitTests.Distribution.Client.Store.tests , testGroup "Distribution.Client.Tar" UnitTests.Distribution.Client.Tar.tests , testGroup "Distribution.Client.Targets" diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -21,6 +21,7 @@ import Control.Monad import Distribution.Version +import Distribution.Types.Dependency import Distribution.Package import Distribution.System import Distribution.Verbosity diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs @@ -1,6 +1,5 @@ module UnitTests.Distribution.Client.FileMonitor (tests) where -import Data.Typeable import Control.Monad import Control.Exception import Control.Concurrent (threadDelay) @@ -812,37 +811,37 @@ | otherwise = error $ "Failed to parse " ++ globstr -expectMonitorChanged :: (Binary a, Binary b, Typeable a, Typeable b) +expectMonitorChanged :: (Binary a, Binary b) => RootPath -> FileMonitor a b -> a -> IO (MonitorChangedReason a) expectMonitorChanged root monitor key = do res <- checkChanged root monitor key case res of MonitorChanged reason -> return reason - MonitorUnchanged _ _ -> throwIO $ HUnitFailure "expected change" + MonitorUnchanged _ _ -> throwIO $ HUnitFailure Nothing "expected change" -expectMonitorUnchanged :: (Binary a, Binary b, Typeable a, Typeable b) +expectMonitorUnchanged :: (Binary a, Binary b) => RootPath -> FileMonitor a b -> a -> IO (b, [MonitorFilePath]) expectMonitorUnchanged root monitor key = do res <- checkChanged root monitor key case res of - MonitorChanged _reason -> throwIO $ HUnitFailure "expected no change" + MonitorChanged _reason -> throwIO $ HUnitFailure Nothing "expected no change" MonitorUnchanged b files -> return (b, files) -checkChanged :: (Binary a, Binary b, Typeable a, Typeable b) +checkChanged :: (Binary a, Binary b) => RootPath -> FileMonitor a b -> a -> IO (MonitorChanged a b) checkChanged (RootPath root) monitor key = checkFileMonitorChanged monitor root key -updateMonitor :: (Binary a, Binary b, Typeable a, Typeable b) +updateMonitor :: (Binary a, Binary b) => RootPath -> FileMonitor a b -> [MonitorFilePath] -> a -> b -> IO () updateMonitor (RootPath root) monitor files key result = updateFileMonitor monitor root Nothing files key result -updateMonitorWithTimestamp :: (Binary a, Binary b, Typeable a, Typeable b) +updateMonitorWithTimestamp :: (Binary a, Binary b) => RootPath -> FileMonitor a b -> MonitorTimestamp -> [MonitorFilePath] -> a -> b -> IO () updateMonitorWithTimestamp (RootPath root) monitor timestamp files key result = diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs @@ -103,12 +103,12 @@ testparse s = case simpleParse s of Just p -> return p - Nothing -> throwIO $ HUnitFailure ("expected parse of: " ++ s) + Nothing -> throwIO $ HUnitFailure Nothing ("expected parse of: " ++ s) parseFail :: String -> Assertion parseFail s = case simpleParse s :: Maybe FilePathGlob of - Just _ -> throwIO $ HUnitFailure ("expected no parse of: " ++ s) + Just _ -> throwIO $ HUnitFailure Nothing ("expected no parse of: " ++ s) Nothing -> return () instance Arbitrary FilePathGlob where diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -233,8 +233,9 @@ | pkgv <- srcpkgvs , let depvs = graph ! pkgv ] - let index = Graph.fromList (map InstallPlan.PreExisting ipkgs - ++ map InstallPlan.Configured srcpkgs) + let index = Graph.fromDistinctList + (map InstallPlan.PreExisting ipkgs + ++ map InstallPlan.Configured srcpkgs) return $ InstallPlan.new (IndependentGoals False) index 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 @@ -16,6 +16,7 @@ import Distribution.Compiler import Distribution.Version import Distribution.ParseUtils +import Distribution.Text as Text import Distribution.Simple.Compiler import Distribution.Simple.Setup import Distribution.Simple.InstallDirs @@ -31,6 +32,7 @@ import Distribution.Utils.NubList import Network.URI +import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.Settings @@ -62,6 +64,9 @@ , testGroup "individual parser tests" [ testProperty "package location" prop_parsePackageLocationTokenQ + , testProperty "RelaxedDep" prop_roundtrip_printparse_RelaxedDep + , testProperty "RelaxDeps" prop_roundtrip_printparse_RelaxDeps + , testProperty "RelaxDeps'" prop_roundtrip_printparse_RelaxDeps' ] , testGroup "ProjectConfig printing/parsing round trip" @@ -198,11 +203,13 @@ hackProjectConfigShared :: ProjectConfigShared -> ProjectConfigShared hackProjectConfigShared config = config { + projectConfigProjectFile = mempty, -- not present within project files + projectConfigConfigFile = mempty, -- dito projectConfigConstraints = --TODO: [required eventually] parse ambiguity in constraint -- "pkgname -any" as either any version or disabled flag "any". - let ambiguous ((UserConstraintFlags _pkg flags), _) = - (not . null) [ () | (name, False) <- flags + let ambiguous (UserConstraint _ (PackagePropertyFlags flags), _) = + (not . null) [ () | (name, False) <- unFlagAssignment flags , "any" `isPrefixOf` unFlagName name ] ambiguous _ = False in filter (not . ambiguous) (projectConfigConstraints config) @@ -226,17 +233,42 @@ ---------------------------- --- Individual Parser tests +-- Individual Parser tests -- +-- | Helper to parse a given string +-- +-- Succeeds only if there is a unique complete parse +runReadP :: Parse.ReadP a a -> String -> Maybe a +runReadP parser s = case [ x | (x,"") <- Parse.readP_to_S parser s ] of + [x'] -> Just x' + _ -> Nothing + prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool prop_parsePackageLocationTokenQ (PackageLocationString str) = - case [ x | (x,"") <- Parse.readP_to_S parsePackageLocationTokenQ - (renderPackageLocationToken str) ] of - [str'] -> str' == str - _ -> False + runReadP parsePackageLocationTokenQ (renderPackageLocationToken str) == Just str +prop_roundtrip_printparse_RelaxedDep :: RelaxedDep -> Bool +prop_roundtrip_printparse_RelaxedDep rdep = + runReadP Text.parse (Text.display rdep) == Just rdep +prop_roundtrip_printparse_RelaxDeps :: RelaxDeps -> Bool +prop_roundtrip_printparse_RelaxDeps rdep = + runReadP Text.parse (Text.display rdep) == Just rdep + +prop_roundtrip_printparse_RelaxDeps' :: RelaxDeps -> Bool +prop_roundtrip_printparse_RelaxDeps' rdep = + runReadP Text.parse (go $ Text.display rdep) == Just rdep + where + -- replace 'all' tokens by '*' + go :: String -> String + go [] = [] + go "all" = "*" + go ('a':'l':'l':c:rest) | c `elem` ":," = '*' : go (c:rest) + go rest = let (x,y) = break (`elem` ":,") rest + (x',y') = span (`elem` ":,^") y + in x++x'++go y' + ------------------------ -- Arbitrary instances -- @@ -257,12 +289,28 @@ -- package entries with no content are equivalent to -- the entry not existing at all, so exclude empty - shrink (ProjectConfig x0 x1 x2 x3 x4 x5 x6 x7 x8) = - [ ProjectConfig x0' x1' x2' x3' - x4' x5' x6' x7' (MapMappend (fmap getNonMEmpty x8')) + shrink ProjectConfig { projectPackages = x0 + , projectPackagesOptional = x1 + , projectPackagesRepo = x2 + , projectPackagesNamed = x3 + , projectConfigBuildOnly = x4 + , projectConfigShared = x5 + , projectConfigProvenance = x6 + , projectConfigLocalPackages = x7 + , projectConfigSpecificPackage = x8 } = + [ ProjectConfig { projectPackages = x0' + , projectPackagesOptional = x1' + , projectPackagesRepo = x2' + , projectPackagesNamed = x3' + , projectConfigBuildOnly = x4' + , projectConfigShared = x5' + , projectConfigProvenance = x6' + , projectConfigLocalPackages = x7' + , projectConfigSpecificPackage = (MapMappend + (fmap getNonMEmpty x8')) } | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8')) <- shrink ((x0, x1, x2, x3), - (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8))) + (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8))) ] newtype PackageLocationString @@ -311,18 +359,46 @@ <*> arbitrary <*> (fmap getShortToken <$> arbitrary) <*> (fmap getShortToken <$> arbitrary) + <*> (fmap getShortToken <$> arbitrary) where arbitraryNumJobs = fmap (fmap getPositive) <$> arbitrary - shrink (ProjectConfigBuildOnly - x00 x01 x02 x03 x04 x05 x06 x07 - x08 x09 x10 x11 x12 x13 x14 x15 - x16) = - [ ProjectConfigBuildOnly - x00' x01' x02' x03' x04' - x05' x06' x07' x08' (postShrink_NumJobs x09') - x10' x11' x12' x13 x14' - x15 x16 + shrink ProjectConfigBuildOnly { projectConfigVerbosity = x00 + , projectConfigDryRun = x01 + , projectConfigOnlyDeps = x02 + , projectConfigSummaryFile = x03 + , projectConfigLogFile = x04 + , projectConfigBuildReports = x05 + , projectConfigReportPlanningFailure = x06 + , projectConfigSymlinkBinDir = x07 + , projectConfigOneShot = x08 + , projectConfigNumJobs = x09 + , projectConfigKeepGoing = x10 + , projectConfigOfflineMode = x11 + , projectConfigKeepTempFiles = x12 + , projectConfigHttpTransport = x13 + , projectConfigIgnoreExpiry = x14 + , projectConfigCacheDir = x15 + , projectConfigLogsDir = x16 + , projectConfigStoreDir = x17 } = + [ ProjectConfigBuildOnly { projectConfigVerbosity = x00' + , projectConfigDryRun = x01' + , projectConfigOnlyDeps = x02' + , projectConfigSummaryFile = x03' + , projectConfigLogFile = x04' + , projectConfigBuildReports = x05' + , projectConfigReportPlanningFailure = x06' + , projectConfigSymlinkBinDir = x07' + , projectConfigOneShot = x08' + , projectConfigNumJobs = postShrink_NumJobs x09' + , projectConfigKeepGoing = x10' + , projectConfigOfflineMode = x11' + , projectConfigKeepTempFiles = x12' + , projectConfigHttpTransport = x13 + , projectConfigIgnoreExpiry = x14' + , projectConfigCacheDir = x15 + , projectConfigLogsDir = x16 + , projectConfigStoreDir = x17} | ((x00', x01', x02', x03', x04'), (x05', x06', x07', x08', x09'), (x10', x11', x12', x14')) @@ -338,11 +414,14 @@ instance Arbitrary ProjectConfigShared where arbitrary = ProjectConfigShared - <$> arbitrary -- 4 + <$> arbitraryFlag arbitraryShortToken <*> arbitraryFlag arbitraryShortToken <*> arbitraryFlag arbitraryShortToken <*> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitraryFlag arbitraryShortToken <*> arbitrary + <*> arbitrary <*> (toNubList <$> listOf arbitraryShortToken) <*> arbitrary <*> arbitraryConstraints @@ -351,41 +430,86 @@ <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary where arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)] arbitraryConstraints = - map (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary + fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary - shrink (ProjectConfigShared - x00 x01 x02 x03 x04 - x05 x06 x07 x08 x09 - x10 x11 x12 x13 x14 - x15 x16) = - [ ProjectConfigShared - x00' (fmap getNonEmpty x01') (fmap getNonEmpty x02') x03' x04' - x05' x06' (postShrink_Constraints x07') x08' x09' - x10' x11' x12' x13' x14' x15' x16' + shrink ProjectConfigShared { projectConfigDistDir = x00 + , projectConfigProjectFile = x01 + , projectConfigHcFlavor = x02 + , projectConfigHcPath = x03 + , projectConfigHcPkg = x04 + , projectConfigHaddockIndex = x05 + , projectConfigRemoteRepos = x06 + , projectConfigLocalRepos = x07 + , projectConfigIndexState = x08 + , projectConfigConstraints = x09 + , projectConfigPreferences = x10 + , projectConfigCabalVersion = x11 + , projectConfigSolver = x12 + , projectConfigAllowOlder = x13 + , projectConfigAllowNewer = x14 + , projectConfigMaxBackjumps = x15 + , projectConfigReorderGoals = x16 + , projectConfigCountConflicts = x17 + , projectConfigStrongFlags = x18 + , projectConfigAllowBootLibInstalls = x19 + , projectConfigPerComponent = x20 + , projectConfigIndependentGoals = x21 + , projectConfigConfigFile = x22 } = + [ ProjectConfigShared { projectConfigDistDir = x00' + , projectConfigProjectFile = x01' + , projectConfigHcFlavor = x02' + , projectConfigHcPath = fmap getNonEmpty x03' + , projectConfigHcPkg = fmap getNonEmpty x04' + , projectConfigHaddockIndex = x05' + , projectConfigRemoteRepos = x06' + , projectConfigLocalRepos = x07' + , projectConfigIndexState = x08' + , projectConfigConstraints = postShrink_Constraints x09' + , projectConfigPreferences = x10' + , projectConfigCabalVersion = x11' + , projectConfigSolver = x12' + , projectConfigAllowOlder = x13' + , projectConfigAllowNewer = x14' + , projectConfigMaxBackjumps = x15' + , projectConfigReorderGoals = x16' + , projectConfigCountConflicts = x17' + , projectConfigStrongFlags = x18' + , projectConfigAllowBootLibInstalls = x19' + , projectConfigPerComponent = x20' + , projectConfigIndependentGoals = x21' + , projectConfigConfigFile = x22' } | ((x00', x01', x02', x03', x04'), (x05', x06', x07', x08', x09'), (x10', x11', x12', x13', x14'), - (x15', x16')) + (x15', x16', x17', x18', x19'), + x20', x21', x22') <- shrink - ((x00, fmap NonEmpty x01, fmap NonEmpty x02, x03, x04), - (x05, x06, preShrink_Constraints x07, x08, x09), + ((x00, x01, x02, fmap NonEmpty x03, fmap NonEmpty x04), + (x05, x06, x07, x08, preShrink_Constraints x09), (x10, x11, x12, x13, x14), - (x15, x16)) + (x15, x16, x17, x18, x19), + x20, x21, x22) ] where preShrink_Constraints = map fst postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource)) projectConfigConstraintSource :: ConstraintSource -projectConfigConstraintSource = +projectConfigConstraintSource = ConstraintSourceProjectConfig "TODO" instance Arbitrary ProjectConfigProvenance where arbitrary = elements [Implicit, Explicit "cabal.project"] +instance Arbitrary FlagAssignment where + arbitrary = mkFlagAssignment <$> arbitrary + instance Arbitrary PackageConfig where arbitrary = PackageConfig @@ -397,7 +521,7 @@ <*> listOf arbitraryShortToken)) <*> (toNubList <$> listOf arbitraryShortToken) <*> arbitrary - <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary @@ -407,13 +531,13 @@ <*> shortListOf 5 arbitraryShortToken <*> shortListOf 5 arbitraryShortToken <*> shortListOf 5 arbitraryShortToken - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitraryFlag arbitraryShortToken <*> arbitrary <*> arbitrary @@ -423,59 +547,125 @@ <*> arbitrary <*> arbitraryFlag arbitraryShortToken <*> arbitrary + <*> arbitrary where arbitraryProgramName :: Gen String arbitraryProgramName = elements [ programName prog | (prog, _) <- knownPrograms (defaultProgramDb) ] - shrink (PackageConfig - x00 x01 x02 x03 x04 - x05 x06 x07 x08 x09 - x10 x11 x12 x13 x14 - x15 x16 x17 x18 x19 - x20 x21 x22 x23 x24 - x25 x26 x27 x28 x29 - x30 x31 x32 x33 x33_1 x34 - x35 x36 x37 x38 x39 - x40) = - [ PackageConfig - (postShrink_Paths x00') - (postShrink_Args x01') x02' x03' x04' - x05' x06' x07' x08' x09' - x10' x11' (map getNonEmpty x12') x13' x14' - x15' (map getNonEmpty x16') - (map getNonEmpty x17') - (map getNonEmpty x18') - x19' - x20' x21' x22' x23' x24' - x25' x26' x27' x28' x29' - x30' x31' x32' x33' x33_1' x34' - x35' x36' (fmap getNonEmpty x37') x38' - (fmap getNonEmpty x39') - x40' - | (((x00', x01', x02', x03', x04'), - (x05', x06', x07', x08', x09'), + shrink PackageConfig { packageConfigProgramPaths = x00 + , packageConfigProgramArgs = x01 + , packageConfigProgramPathExtra = x02 + , packageConfigFlagAssignment = x03 + , packageConfigVanillaLib = x04 + , packageConfigSharedLib = x05 + , packageConfigStaticLib = x42 + , packageConfigDynExe = x06 + , packageConfigProf = x07 + , packageConfigProfLib = x08 + , packageConfigProfExe = x09 + , packageConfigProfDetail = x10 + , packageConfigProfLibDetail = x11 + , packageConfigConfigureArgs = x12 + , packageConfigOptimization = x13 + , packageConfigProgPrefix = x14 + , packageConfigProgSuffix = x15 + , packageConfigExtraLibDirs = x16 + , packageConfigExtraFrameworkDirs = x17 + , packageConfigExtraIncludeDirs = x18 + , packageConfigGHCiLib = x19 + , packageConfigSplitSections = x20 + , packageConfigSplitObjs = x20_1 + , packageConfigStripExes = x21 + , packageConfigStripLibs = x22 + , packageConfigTests = x23 + , packageConfigBenchmarks = x24 + , packageConfigCoverage = x25 + , packageConfigRelocatable = x26 + , packageConfigDebugInfo = x27 + , packageConfigRunTests = x28 + , packageConfigDocumentation = x29 + , packageConfigHaddockHoogle = x30 + , packageConfigHaddockHtml = x31 + , packageConfigHaddockHtmlLocation = x32 + , packageConfigHaddockForeignLibs = x33 + , packageConfigHaddockExecutables = x33_1 + , packageConfigHaddockTestSuites = x34 + , packageConfigHaddockBenchmarks = x35 + , packageConfigHaddockInternal = x36 + , packageConfigHaddockCss = x37 + , packageConfigHaddockHscolour = x38 + , packageConfigHaddockHscolourCss = x39 + , packageConfigHaddockContents = x40 + , packageConfigHaddockForHackage = x41 } = + [ PackageConfig { packageConfigProgramPaths = postShrink_Paths x00' + , packageConfigProgramArgs = postShrink_Args x01' + , packageConfigProgramPathExtra = x02' + , packageConfigFlagAssignment = x03' + , packageConfigVanillaLib = x04' + , packageConfigSharedLib = x05' + , packageConfigStaticLib = x42' + , packageConfigDynExe = x06' + , packageConfigProf = x07' + , packageConfigProfLib = x08' + , packageConfigProfExe = x09' + , packageConfigProfDetail = x10' + , packageConfigProfLibDetail = x11' + , packageConfigConfigureArgs = map getNonEmpty x12' + , packageConfigOptimization = x13' + , packageConfigProgPrefix = x14' + , packageConfigProgSuffix = x15' + , packageConfigExtraLibDirs = map getNonEmpty x16' + , packageConfigExtraFrameworkDirs = map getNonEmpty x17' + , packageConfigExtraIncludeDirs = map getNonEmpty x18' + , packageConfigGHCiLib = x19' + , packageConfigSplitSections = x20' + , packageConfigSplitObjs = x20_1' + , packageConfigStripExes = x21' + , packageConfigStripLibs = x22' + , packageConfigTests = x23' + , packageConfigBenchmarks = x24' + , packageConfigCoverage = x25' + , packageConfigRelocatable = x26' + , packageConfigDebugInfo = x27' + , packageConfigRunTests = x28' + , packageConfigDocumentation = x29' + , packageConfigHaddockHoogle = x30' + , packageConfigHaddockHtml = x31' + , packageConfigHaddockHtmlLocation = x32' + , packageConfigHaddockForeignLibs = x33' + , packageConfigHaddockExecutables = x33_1' + , packageConfigHaddockTestSuites = x34' + , packageConfigHaddockBenchmarks = x35' + , packageConfigHaddockInternal = x36' + , packageConfigHaddockCss = fmap getNonEmpty x37' + , packageConfigHaddockHscolour = x38' + , packageConfigHaddockHscolourCss = fmap getNonEmpty x39' + , packageConfigHaddockContents = x40' + , packageConfigHaddockForHackage = x41' } + | (((x00', x01', x02', x03', x04'), + (x05', x42', x06', x07', x08', x09'), (x10', x11', x12', x13', x14'), (x15', x16', x17', x18', x19')), - ((x20', x21', x22', x23', x24'), + ((x20', x20_1', x21', x22', x23', x24'), (x25', x26', x27', x28', x29'), (x30', x31', x32', (x33', x33_1'), x34'), (x35', x36', x37', x38', x39'), - (x40'))) + (x40', x41'))) <- shrink - (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04), - (x05, x06, x07, x08, x09), - (x10, x11, map NonEmpty x12, x13, x14), - (x15, map NonEmpty x16, - map NonEmpty x17, - map NonEmpty x18, - x19)), - ((x20, x21, x22, x23, x24), + (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04), + (x05, x42, x06, x07, x08, x09), + (x10, x11, map NonEmpty x12, x13, x14), + (x15, map NonEmpty x16, + map NonEmpty x17, + map NonEmpty x18, + x19)), + ((x20, x20_1, x21, x22, x23, x24), (x25, x26, x27, x28, x29), (x30, x31, x32, (x33, x33_1), x34), (x35, x36, fmap NonEmpty x37, x38, fmap NonEmpty x39), - (x40))) + (x40, x41))) ] where preShrink_Paths = Map.map NonEmpty @@ -491,6 +681,8 @@ . Map.map (map getNonEmpty . getNonEmpty) . Map.mapKeys getNoShrink +instance Arbitrary HaddockTarget where + arbitrary = elements [ForHackage, ForDevelopment] instance Arbitrary SourceRepo where arbitrary = (SourceRepo RepoThis @@ -540,7 +732,7 @@ <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 4 <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 8 <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 12 - <*> arbitrary <*> arbitrary <*> arbitrary -- 15 + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 16 instance Arbitrary PackageDB where arbitrary = oneof [ pure GlobalPackageDB @@ -562,16 +754,31 @@ shortListOf1 5 (oneof [ choose ('0', '9') , choose ('a', 'f') ]) +instance Arbitrary UserConstraintScope where + arbitrary = oneof [ UserQualified <$> arbitrary <*> arbitrary + , UserAnySetupQualifier <$> arbitrary + , UserAnyQualifier <$> arbitrary + ] + +instance Arbitrary UserQualifier where + arbitrary = oneof [ pure UserQualToplevel + , UserQualSetup <$> arbitrary + + -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax. + -- , UserQualExe <$> arbitrary <*> arbitrary + ] + instance Arbitrary UserConstraint where - arbitrary = - oneof - [ UserConstraintVersion <$> arbitrary <*> arbitrary - , UserConstraintInstalled <$> arbitrary - , UserConstraintSource <$> arbitrary - , UserConstraintFlags <$> arbitrary <*> shortListOf1 3 arbitrary - , UserConstraintStanzas <$> arbitrary <*> ((\x->[x]) <$> arbitrary) - ] + arbitrary = UserConstraint <$> arbitrary <*> arbitrary +instance Arbitrary PackageProperty where + arbitrary = oneof [ PackagePropertyVersion <$> arbitrary + , pure PackagePropertyInstalled + , pure PackagePropertySource + , PackagePropertyFlags . mkFlagAssignment <$> shortListOf1 3 arbitrary + , PackagePropertyStanzas . (\x->[x]) <$> arbitrary + ] + instance Arbitrary OptionalStanza where arbitrary = elements [minBound..maxBound] @@ -591,9 +798,15 @@ instance Arbitrary CountConflicts where arbitrary = CountConflicts <$> arbitrary +instance Arbitrary IndependentGoals where + arbitrary = IndependentGoals <$> arbitrary + instance Arbitrary StrongFlags where arbitrary = StrongFlags <$> arbitrary +instance Arbitrary AllowBootLibInstalls where + arbitrary = AllowBootLibInstalls <$> arbitrary + instance Arbitrary AllowNewer where arbitrary = AllowNewer <$> arbitrary @@ -601,16 +814,28 @@ arbitrary = AllowOlder <$> arbitrary instance Arbitrary RelaxDeps where - arbitrary = oneof [ pure RelaxDepsNone + arbitrary = oneof [ pure mempty , RelaxDepsSome <$> shortListOf1 3 arbitrary , pure RelaxDepsAll ] -instance Arbitrary RelaxedDep where - arbitrary = oneof [ RelaxedDep <$> arbitrary - , RelaxedDepScoped <$> arbitrary <*> arbitrary +instance Arbitrary RelaxDepMod where + arbitrary = elements [RelaxDepModNone, RelaxDepModCaret] + +instance Arbitrary RelaxDepScope where + arbitrary = oneof [ pure RelaxDepScopeAll + , RelaxDepScopePackage <$> arbitrary + , RelaxDepScopePackageId <$> (PackageIdentifier <$> arbitrary <*> arbitrary) ] +instance Arbitrary RelaxDepSubject where + arbitrary = oneof [ pure RelaxDepSubjectAll + , RelaxDepSubjectPkg <$> arbitrary + ] + +instance Arbitrary RelaxedDep where + arbitrary = RelaxedDep <$> arbitrary <*> arbitrary <*> arbitrary + instance Arbitrary ProfDetailLevel where arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ] @@ -641,4 +866,3 @@ arbitraryURIPort :: Gen String arbitraryURIPort = oneof [ pure "", (':':) <$> shortListOf1 4 (choose ('0','9')) ] - diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs @@ -44,7 +44,7 @@ withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do let fileName = dir "timestamp-record" writeFile fileName fileContent - tRec <- readTimestampFile fileName + tRec <- readTimestampFile normal fileName assertEqual "expected timestamp records to be equal" expected tRec @@ -58,6 +58,6 @@ withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do let fileName = dir "timestamp-record" writeTimestampFile fileName timestampRecord - tRec <- readTimestampFile fileName + tRec <- readTimestampFile normal fileName assertEqual "expected timestamp records to be equal" timestampRecord tRec diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Store.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Store.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Store.hs @@ -0,0 +1,181 @@ +module UnitTests.Distribution.Client.Store (tests) where + +--import Control.Monad +--import Control.Concurrent (forkIO, threadDelay) +--import Control.Concurrent.MVar +import qualified Data.Set as Set +import System.FilePath +import System.Directory +--import System.Random + +import Distribution.Package (UnitId, mkUnitId) +import Distribution.Compiler (CompilerId(..), CompilerFlavor(..)) +import Distribution.Version (mkVersion) +import Distribution.Verbosity (Verbosity, silent) +import Distribution.Simple.Utils (withTempDirectory) + +import Distribution.Client.Store +import Distribution.Client.RebuildMonad + +import Test.Tasty +import Test.Tasty.HUnit + + +tests :: [TestTree] +tests = + [ testCase "list content empty" testListEmpty + , testCase "install serial" testInstallSerial +--, testCase "install parallel" testInstallParallel + --TODO: figure out some way to do a parallel test, see issue below + ] + + +testListEmpty :: Assertion +testListEmpty = + withTempDirectory verbosity "." "store-" $ \tmp -> do + let storeDirLayout = defaultStoreDirLayout (tmp "store") + + assertStoreEntryExists storeDirLayout compid unitid False + assertStoreContent tmp storeDirLayout compid Set.empty + where + compid = CompilerId GHC (mkVersion [1,0]) + unitid = mkUnitId "foo-1.0-xyz" + + +testInstallSerial :: Assertion +testInstallSerial = + withTempDirectory verbosity "." "store-" $ \tmp -> do + let storeDirLayout = defaultStoreDirLayout (tmp "store") + copyFiles file content dir = do + -- we copy into a prefix inside the tmp dir and return the prefix + let destprefix = dir "prefix" + createDirectory destprefix + writeFile (destprefix file) content + return (destprefix,[]) + + assertNewStoreEntry tmp storeDirLayout compid unitid1 + (copyFiles "file1" "content-foo") (return ()) + UseNewStoreEntry + + assertNewStoreEntry tmp storeDirLayout compid unitid1 + (copyFiles "file1" "content-foo") (return ()) + UseExistingStoreEntry + + assertNewStoreEntry tmp storeDirLayout compid unitid2 + (copyFiles "file2" "content-bar") (return ()) + UseNewStoreEntry + + let pkgDir :: UnitId -> FilePath + pkgDir = storePackageDirectory storeDirLayout compid + assertFileEqual (pkgDir unitid1 "file1") "content-foo" + assertFileEqual (pkgDir unitid2 "file2") "content-bar" + where + compid = CompilerId GHC (mkVersion [1,0]) + unitid1 = mkUnitId "foo-1.0-xyz" + unitid2 = mkUnitId "bar-2.0-xyz" + + +{- +-- unfortunately a parallel test like the one below is thwarted by the normal +-- process-internal file locking. If that locking were not in place then we +-- ought to get the blocking behaviour, but due to the normal Handle locking +-- it just fails instead. + +testInstallParallel :: Assertion +testInstallParallel = + withTempDirectory verbosity "." "store-" $ \tmp -> do + let storeDirLayout = defaultStoreDirLayout (tmp "store") + + sync1 <- newEmptyMVar + sync2 <- newEmptyMVar + outv <- newEmptyMVar + regv <- newMVar (0 :: Int) + + sequence_ + [ do forkIO $ do + let copyFiles dir = do + delay <- randomRIO (1,100000) + writeFile (dir "file") (show n) + putMVar sync1 () + readMVar sync2 + threadDelay delay + register = do + modifyMVar_ regv (return . (+1)) + threadDelay 200000 + o <- newStoreEntry verbosity storeDirLayout + compid unitid + copyFiles register + putMVar outv (n, o) + | n <- [0..9 :: Int] ] + + replicateM_ 10 (takeMVar sync1) + -- all threads are in the copyFiles action concurrently, release them: + putMVar sync2 () + + outcomes <- replicateM 10 (takeMVar outv) + regcount <- readMVar regv + let regcount' = length [ () | (_, UseNewStoreEntry) <- outcomes ] + + assertEqual "num registrations" 1 regcount + assertEqual "num registrations" 1 regcount' + + assertStoreContent tmp storeDirLayout compid (Set.singleton unitid) + + let pkgDir :: UnitId -> FilePath + pkgDir = storePackageDirectory storeDirLayout compid + case [ n | (n, UseNewStoreEntry) <- outcomes ] of + [n] -> assertFileEqual (pkgDir unitid "file") (show n) + _ -> assertFailure "impossible" + + where + compid = CompilerId GHC (mkVersion [1,0]) + unitid = mkUnitId "foo-1.0-xyz" +-} + +------------- +-- Utils + +assertNewStoreEntry :: FilePath -> StoreDirLayout + -> CompilerId -> UnitId + -> (FilePath -> IO (FilePath,[FilePath])) -> IO () + -> NewStoreEntryOutcome + -> Assertion +assertNewStoreEntry tmp storeDirLayout compid unitid + copyFiles register expectedOutcome = do + entries <- runRebuild tmp $ getStoreEntries storeDirLayout compid + outcome <- newStoreEntry verbosity storeDirLayout + compid unitid + copyFiles register + assertEqual "newStoreEntry outcome" expectedOutcome outcome + assertStoreEntryExists storeDirLayout compid unitid True + let expected = Set.insert unitid entries + assertStoreContent tmp storeDirLayout compid expected + + +assertStoreEntryExists :: StoreDirLayout + -> CompilerId -> UnitId -> Bool + -> Assertion +assertStoreEntryExists storeDirLayout compid unitid expected = do + actual <- doesStoreEntryExist storeDirLayout compid unitid + assertEqual "store entry exists" expected actual + + +assertStoreContent :: FilePath -> StoreDirLayout + -> CompilerId -> Set.Set UnitId + -> Assertion +assertStoreContent tmp storeDirLayout compid expected = do + actual <- runRebuild tmp $ getStoreEntries storeDirLayout compid + assertEqual "store content" actual expected + + +assertFileEqual :: FilePath -> String -> Assertion +assertFileEqual path expected = do + exists <- doesFileExist path + assertBool ("file does not exist:\n" ++ path) exists + actual <- readFile path + assertEqual ("file content for:\n" ++ path) expected actual + + +verbosity :: Verbosity +verbosity = silent + diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs @@ -32,7 +32,7 @@ e2 = getFileEntry "file2" "y" p = (\e -> let (NormalFile dta _) = entryContent e str = BS.Char8.unpack dta - in not . (=="y") $ str) + in str /= "y") assertEqual "Unexpected result for filter" "xz" $ entriesToString $ filterEntries p $ Next e1 $ Next e2 Done assertEqual "Unexpected result for filter" "z" $ @@ -46,7 +46,7 @@ e2 = getFileEntry "file2" "y" p = (\e -> let (NormalFile dta _) = entryContent e str = BS.Char8.unpack dta - in tell "t" >> return (not . (=="y") $ str)) + in tell "t" >> return (str /= "y")) (r, w) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 Done assertEqual "Unexpected result for filterM" "xz" $ entriesToString r diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs @@ -2,57 +2,106 @@ tests ) where -import Distribution.Client.Targets (UserConstraint (..), readUserConstraint) -import Distribution.Compat.ReadP (ReadP, readP_to_S) +import Distribution.Client.Targets (UserQualifier(..) + ,UserConstraintScope(..) + ,UserConstraint(..), readUserConstraint) +import Distribution.Compat.ReadP (readP_to_S) import Distribution.Package (mkPackageName) +import Distribution.PackageDescription (mkFlagName, mkFlagAssignment) +import Distribution.Version (anyVersion, thisVersion, mkVersion) import Distribution.ParseUtils (parseCommaList) import Distribution.Text (parse) +import Distribution.Solver.Types.PackageConstraint (PackageProperty(..)) +import Distribution.Solver.Types.OptionalStanza (OptionalStanza(..)) + import Test.Tasty import Test.Tasty.HUnit import Data.Char (isSpace) +import Data.List (intercalate) -tests :: [TestTree] -tests = [ testCase "readUserConstraint" readUserConstraintTest - , testCase "parseUserConstraint" parseUserConstraintTest - , testCase "readUserConstraints" readUserConstraintsTest - ] +-- Helper function: makes a test group by mapping each element +-- of a list to a test case. +makeGroup :: String -> (a -> Assertion) -> [a] -> TestTree +makeGroup name f xs = testGroup name $ + zipWith testCase (map show [0 :: Integer ..]) (map f xs) -readUserConstraintTest :: Assertion -readUserConstraintTest = - assertEqual ("Couldn't read constraint: '" ++ constr ++ "'") expected actual +tests :: [TestTree] +tests = + [ makeGroup "readUserConstraint" (uncurry readUserConstraintTest) + exampleConstraints + + , makeGroup "parseUserConstraint" (uncurry parseUserConstraintTest) + exampleConstraints + + , makeGroup "readUserConstraints" (uncurry readUserConstraintsTest) + [-- First example only. + (head exampleStrs, take 1 exampleUcs), + -- All examples separated by commas. + (intercalate ", " exampleStrs, exampleUcs)] + ] where - pkgName = "template-haskell" - constr = pkgName ++ " installed" + (exampleStrs, exampleUcs) = unzip exampleConstraints - expected = UserConstraintInstalled (mkPackageName pkgName) - actual = let (Right r) = readUserConstraint constr in r +exampleConstraints :: [(String, UserConstraint)] +exampleConstraints = + [ ("template-haskell installed", + UserConstraint (UserQualified UserQualToplevel (pn "template-haskell")) + PackagePropertyInstalled) + + , ("bytestring -any", + UserConstraint (UserQualified UserQualToplevel (pn "bytestring")) + (PackagePropertyVersion anyVersion)) -parseUserConstraintTest :: Assertion -parseUserConstraintTest = - assertEqual ("Couldn't parse constraint: '" ++ constr ++ "'") expected actual - where - pkgName = "template-haskell" - constr = pkgName ++ " installed" + , ("any.directory test", + UserConstraint (UserAnyQualifier (pn "directory")) + (PackagePropertyStanzas [TestStanzas])) - expected = [UserConstraintInstalled (mkPackageName pkgName)] - actual = [ x | (x, ys) <- readP_to_S parseUserConstraint constr - , all isSpace ys] + , ("setup.Cabal installed", + UserConstraint (UserAnySetupQualifier (pn "Cabal")) + PackagePropertyInstalled) - parseUserConstraint :: ReadP r UserConstraint - parseUserConstraint = parse + , ("process:setup.bytestring ==5.2", + UserConstraint (UserQualified (UserQualSetup (pn "process")) (pn "bytestring")) + (PackagePropertyVersion (thisVersion (mkVersion [5, 2])))) + + , ("network:setup.containers +foo -bar baz", + UserConstraint (UserQualified (UserQualSetup (pn "network")) (pn "containers")) + (PackagePropertyFlags (mkFlagAssignment + [(fn "foo", True), + (fn "bar", False), + (fn "baz", True)]))) + + -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax. + -- + -- , ("foo:happy:exe.template-haskell test", + -- UserConstraint (UserQualified (UserQualExe (pn "foo") (pn "happy")) (pn "template-haskell")) + -- (PackagePropertyStanzas [TestStanzas])) + ] + where + pn = mkPackageName + fn = mkFlagName -readUserConstraintsTest :: Assertion -readUserConstraintsTest = - assertEqual ("Couldn't read constraints: '" ++ constr ++ "'") expected actual +readUserConstraintTest :: String -> UserConstraint -> Assertion +readUserConstraintTest str uc = + assertEqual ("Couldn't read constraint: '" ++ str ++ "'") expected actual where - pkgName = "template-haskell" - constr = pkgName ++ " installed" + expected = uc + actual = let Right r = readUserConstraint str in r - expected = [[UserConstraintInstalled (mkPackageName pkgName)]] - actual = [ x | (x, ys) <- readP_to_S parseUserConstraints constr +parseUserConstraintTest :: String -> UserConstraint -> Assertion +parseUserConstraintTest str uc = + assertEqual ("Couldn't parse constraint: '" ++ str ++ "'") expected actual + where + expected = [uc] + actual = [ x | (x, ys) <- readP_to_S parse str , all isSpace ys] - parseUserConstraints :: ReadP r [UserConstraint] - parseUserConstraints = parseCommaList parse +readUserConstraintsTest :: String -> [UserConstraint] -> Assertion +readUserConstraintsTest str ucs = + assertEqual ("Couldn't read constraints: '" ++ str ++ "'") expected actual + where + expected = [ucs] + actual = [ x | (x, ys) <- readP_to_S (parseCommaList parse) str + , all isSpace ys] diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Builder.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Builder.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Builder.hs @@ -0,0 +1,20 @@ +module UnitTests.Distribution.Solver.Modular.Builder ( + tests + ) where + +import Distribution.Solver.Modular.Builder + +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: [TestTree] +tests = [ testProperty "splitsAltImplementation" splitsTest + ] + +-- | Simpler splits implementation +splits' :: [a] -> [(a, [a])] +splits' [] = [] +splits' (x : xs) = (x, xs) : map (\ (y, ys) -> (y, x : ys)) (splits' xs) + +splitsTest :: [Int] -> Property +splitsTest xs = splits' xs === splits xs diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs --- a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -7,11 +7,14 @@ , Dependencies(..) , ExTest(..) , ExExe(..) + , ExConstraint(..) , ExPreference(..) , ExampleDb , ExampleVersionRange , ExamplePkgVersion , ExamplePkgName + , ExampleFlagName + , ExFlag(..) , ExampleAvailable(..) , ExampleInstalled(..) , ExampleQualifier(..) @@ -19,40 +22,46 @@ , EnableAllTests(..) , exAv , exInst - , exFlag + , exFlagged , exResolve , extractInstallPlan + , declareFlags , withSetupDeps , withTest , withTests , withExe , withExes , runProgress + , mkSimpleVersion + , mkVersionRange ) where import Prelude () -import Distribution.Client.Compat.Prelude +import Distribution.Solver.Compat.Prelude -- base import Data.Either (partitionEithers) -import Data.List (elemIndex) -import Data.Ord (comparing) import qualified Data.Map as Map -- Cabal -import qualified Distribution.Compiler as C -import qualified Distribution.InstalledPackageInfo as IPI +import qualified Distribution.Compiler as C +import qualified Distribution.InstalledPackageInfo as IPI import Distribution.License (License(..)) -import qualified Distribution.ModuleName as Module -import qualified Distribution.Package as C +import qualified Distribution.ModuleName as Module +import qualified Distribution.Package as C hiding (HasUnitId(..)) -import qualified Distribution.PackageDescription as C -import qualified Distribution.PackageDescription.Check as C -import qualified Distribution.Simple.PackageIndex as C.PackageIndex +import qualified Distribution.Types.ExeDependency as C +import qualified Distribution.Types.LegacyExeDependency as C +import qualified Distribution.Types.PkgconfigDependency as C +import qualified Distribution.Types.UnqualComponentName as C +import qualified Distribution.Types.CondTree as C +import qualified Distribution.PackageDescription as C +import qualified Distribution.PackageDescription.Check as C +import qualified Distribution.Simple.PackageIndex as C.PackageIndex import Distribution.Simple.Setup (BooleanFlag(..)) -import qualified Distribution.System as C +import qualified Distribution.System as C import Distribution.Text (display) -import qualified Distribution.Version as C +import qualified Distribution.Version as C import Language.Haskell.Extension (Extension(..), Language(..)) -- cabal-install @@ -64,9 +73,11 @@ import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.Flag import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import qualified Distribution.Solver.Types.PackageIndex as CI.PackageIndex +import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackagePath as P import qualified Distribution.Solver.Types.PkgConfigDb as PC import Distribution.Solver.Types.Settings @@ -134,14 +145,24 @@ -- | Simple dependency on a fixed version | ExFix ExamplePkgName ExamplePkgVersion - -- | Build-tools dependency - | ExBuildToolAny ExamplePkgName + -- | Simple dependency on a range of versions, with an inclusive lower bound + -- and an exclusive upper bound. + | ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion - -- | Build-tools dependency on a fixed version - | ExBuildToolFix ExamplePkgName ExamplePkgVersion + -- | Build-tool-depends dependency + | ExBuildToolAny ExamplePkgName ExampleExeName + -- | Build-tool-depends dependency on a fixed version + | ExBuildToolFix ExamplePkgName ExampleExeName ExamplePkgVersion + + -- | Legacy build-tools dependency + | ExLegacyBuildToolAny ExamplePkgName + + -- | Legacy build-tools dependency on a fixed version + | ExLegacyBuildToolFix ExamplePkgName ExamplePkgVersion + -- | Dependencies indexed by a flag - | ExFlag ExampleFlagName Dependencies Dependencies + | ExFlagged ExampleFlagName Dependencies Dependencies -- | Dependency on a language extension | ExExt Extension @@ -153,22 +174,41 @@ | ExPkg (ExamplePkgName, ExamplePkgVersion) deriving Show +-- | Simplified version of D.Types.GenericPackageDescription.Flag for use in +-- example source packages. +data ExFlag = ExFlag { + exFlagName :: ExampleFlagName + , exFlagDefault :: Bool + , exFlagType :: FlagType + } deriving Show + data ExTest = ExTest ExampleTestName [ExampleDependency] data ExExe = ExExe ExampleExeName [ExampleDependency] -exFlag :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency] - -> ExampleDependency -exFlag n t e = ExFlag n (Buildable t) (Buildable e) +exFlagged :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency] + -> ExampleDependency +exFlagged n t e = ExFlagged n (Buildable t) (Buildable e) +data ExConstraint = + ExVersionConstraint ConstraintScope ExampleVersionRange + | ExFlagConstraint ConstraintScope ExampleFlagName Bool + | ExStanzaConstraint ConstraintScope [OptionalStanza] + deriving Show + data ExPreference = ExPkgPref ExamplePkgName ExampleVersionRange | ExStanzaPref ExamplePkgName [OptionalStanza] + deriving Show data ExampleAvailable = ExAv { exAvName :: ExamplePkgName , exAvVersion :: ExamplePkgVersion , exAvDeps :: ComponentDeps [ExampleDependency] + + -- Setting flags here is only necessary to override the default values of + -- the fields in C.Flag. + , exAvFlags :: [ExFlag] } deriving Show data ExampleVar = @@ -177,11 +217,18 @@ | S ExampleQualifier ExamplePkgName OptionalStanza data ExampleQualifier = - None - | Indep Int - | Setup ExamplePkgName - | IndepSetup Int ExamplePkgName + QualNone + | QualIndep ExamplePkgName + | QualSetup ExamplePkgName + -- The two package names are the build target and the package containing the + -- setup script. + | QualIndepSetup ExamplePkgName ExamplePkgName + + -- The two package names are the package depending on the exe and the + -- package containing the exe. + | QualExe ExamplePkgName ExamplePkgName + -- | Whether to enable tests in all packages in a test case. newtype EnableAllTests = EnableAllTests Bool deriving BooleanFlag @@ -198,8 +245,15 @@ exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency] -> ExampleAvailable exAv n v ds = ExAv { exAvName = n, exAvVersion = v - , exAvDeps = CD.fromLibraryDeps ds } + , exAvDeps = CD.fromLibraryDeps ds, exAvFlags = [] } +-- | Override the default settings (e.g., manual vs. automatic) for a subset of +-- a package's flags. +declareFlags :: [ExFlag] -> ExampleAvailable -> ExampleAvailable +declareFlags flags ex = ex { + exAvFlags = flags + } + withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable withSetupDeps ex setupDeps = ex { exAvDeps = exAvDeps ex <> CD.fromSetupDeps setupDeps @@ -252,9 +306,7 @@ type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a -type DependencyComponent a = ( C.Condition C.ConfVar - , DependencyTree a - , Maybe (DependencyTree a)) +type DependencyComponent a = C.CondBranch C.ConfVar [C.Dependency] a exDbPkgs :: ExampleDb -> [ExamplePkgName] exDbPkgs = map (either exInstName exAvName) @@ -262,6 +314,25 @@ exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage exAvSrcPkg ex = let pkgId = exAvPkgId ex + + flags :: [C.Flag] + flags = + let declaredFlags :: Map ExampleFlagName C.Flag + declaredFlags = + Map.fromListWith + (\f1 f2 -> error $ "duplicate flag declarations: " ++ show [f1, f2]) + [(exFlagName flag, mkFlag flag) | flag <- exAvFlags ex] + + usedFlags :: Map ExampleFlagName C.Flag + usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names] + where + names = concatMap extractFlags $ + CD.libraryDeps (exAvDeps ex) + ++ concatMap snd testSuites + ++ concatMap snd executables + in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings: + Map.elems $ declaredFlags `Map.union` usedFlags + testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)] executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)] setup = case CD.setupDeps (exAvDeps ex) of @@ -289,10 +360,7 @@ , C.licenseFiles = ["LICENSE"] , C.specVersionRaw = Left $ C.mkVersion [1,12] } - , C.genPackageFlags = nub $ concatMap extractFlags $ - CD.libraryDeps (exAvDeps ex) - ++ concatMap snd testSuites - ++ concatMap snd executables + , C.genPackageFlags = flags , C.condLibrary = let mkLib bi = mempty { C.libBuildInfo = bi } in Just $ mkCondTree defaultLib mkLib $ mkBuildInfoTree $ @@ -343,43 +411,48 @@ , [Extension] , Maybe Language , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config - , [(ExamplePkgName, Maybe Int)] -- build tools + , [(ExamplePkgName, ExampleExeName, C.VersionRange)] -- build tools + , [(ExamplePkgName, C.VersionRange)] -- legacy build tools ) splitTopLevel [] = - ([], [], Nothing, [], []) - splitTopLevel (ExBuildToolAny p:deps) = - let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, (p, Nothing):exes) - splitTopLevel (ExBuildToolFix p v:deps) = - let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, (p, Just v):exes) + ([], [], Nothing, [], [], []) + splitTopLevel (ExBuildToolAny p e:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, (p, e, C.anyVersion):exes, legacyExes) + splitTopLevel (ExBuildToolFix p e v:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, (p, e, C.thisVersion (mkSimpleVersion v)):exes, legacyExes) + splitTopLevel (ExLegacyBuildToolAny p:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, exes, (p, C.anyVersion):legacyExes) + splitTopLevel (ExLegacyBuildToolFix p v:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, exes, (p, C.thisVersion (mkSimpleVersion v)):legacyExes) splitTopLevel (ExExt ext:deps) = - let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps - in (other, ext:exts, lang, pcpkgs, exes) + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, ext:exts, lang, pcpkgs, exes, legacyExes) splitTopLevel (ExLang lang:deps) = case splitTopLevel deps of - (other, exts, Nothing, pcpkgs, exes) -> (other, exts, Just lang, pcpkgs, exes) + (other, exts, Nothing, pcpkgs, exes, legacyExes) -> (other, exts, Just lang, pcpkgs, exes, legacyExes) _ -> error "Only 1 Language dependency is supported" splitTopLevel (ExPkg pkg:deps) = - let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps - in (other, exts, lang, pkg:pcpkgs, exes) + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pkg:pcpkgs, exes, legacyExes) splitTopLevel (dep:deps) = - let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps - in (dep:other, exts, lang, pcpkgs, exes) + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (dep:other, exts, lang, pcpkgs, exes, legacyExes) -- Extract the total set of flags used - extractFlags :: ExampleDependency -> [C.Flag] - extractFlags (ExAny _) = [] - extractFlags (ExFix _ _) = [] - extractFlags (ExBuildToolAny _) = [] - extractFlags (ExBuildToolFix _ _) = [] - extractFlags (ExFlag f a b) = C.MkFlag { - C.flagName = C.mkFlagName f - , C.flagDescription = "" - , C.flagDefault = True - , C.flagManual = False - } - : concatMap extractFlags (deps a ++ deps b) + extractFlags :: ExampleDependency -> [ExampleFlagName] + extractFlags (ExAny _) = [] + extractFlags (ExFix _ _) = [] + extractFlags (ExRange _ _ _) = [] + extractFlags (ExBuildToolAny _ _) = [] + extractFlags (ExBuildToolFix _ _ _) = [] + extractFlags (ExLegacyBuildToolAny _) = [] + extractFlags (ExLegacyBuildToolFix _ _) = [] + extractFlags (ExFlagged f a b) = + f : concatMap extractFlags (deps a ++ deps b) where deps :: Dependencies -> [ExampleDependency] deps NotBuildable = [] @@ -409,7 +482,7 @@ goComponents :: [DependencyComponent C.BuildInfo] -> [DependencyComponent a] - goComponents comps = [(cond, go t, go <$> me) | (cond, t, me) <- comps] + goComponents comps = [C.CondBranch cond (go t) (go <$> me) | C.CondBranch cond t me <- comps] mkBuildInfoTree :: Dependencies -> DependencyTree C.BuildInfo mkBuildInfoTree NotBuildable = @@ -419,17 +492,19 @@ , C.condTreeComponents = [] } mkBuildInfoTree (Buildable deps) = - let (libraryDeps, exts, mlang, pcpkgs, buildTools) = splitTopLevel deps + let (libraryDeps, exts, mlang, pcpkgs, buildTools, legacyBuildTools) = splitTopLevel deps (directDeps, flaggedDeps) = splitDeps libraryDeps bi = mempty { C.otherExtensions = exts , C.defaultLanguage = mlang - , C.buildTools = [ C.LegacyExeDependency n $ mkVersion v - | (n,v) <- buildTools ] + , C.buildToolDepends = [ C.ExeDependency (C.mkPackageName p) (C.mkUnqualComponentName e) vr + | (p, e, vr) <- buildTools] + , C.buildTools = [ C.LegacyExeDependency n vr + | (n,vr) <- legacyBuildTools] , C.pkgconfigDepends = [ C.PkgconfigDependency n' v' | (n,v) <- pcpkgs , let n' = C.mkPkgconfigName n - , let v' = mkVersion $ Just v ] + , let v' = C.thisVersion (mkSimpleVersion v) ] } in C.CondNode { C.condTreeData = bi -- Necessary for language extensions @@ -440,43 +515,38 @@ , C.condTreeComponents = map mkFlagged flaggedDeps } - mkVersion :: Maybe ExamplePkgVersion -> C.VersionRange - mkVersion Nothing = C.anyVersion - mkVersion (Just n) = C.thisVersion v - where - v = C.mkVersion [n, 0, 0] - - mkDirect :: (ExamplePkgName, Maybe ExamplePkgVersion) -> C.Dependency - mkDirect (dep, v) = C.Dependency (C.mkPackageName dep) $ mkVersion $v + mkDirect :: (ExamplePkgName, C.VersionRange) -> C.Dependency + mkDirect (dep, vr) = C.Dependency (C.mkPackageName dep) vr mkFlagged :: (ExampleFlagName, Dependencies, Dependencies) - -> ( C.Condition C.ConfVar - , DependencyTree C.BuildInfo - , Maybe (DependencyTree C.BuildInfo)) - mkFlagged (f, a, b) = ( C.Var (C.Flag (C.mkFlagName f)) - , mkBuildInfoTree a - , Just (mkBuildInfoTree b) - ) + -> DependencyComponent C.BuildInfo + mkFlagged (f, a, b) = + C.CondBranch (C.Var (C.Flag (C.mkFlagName f))) + (mkBuildInfoTree a) + (Just (mkBuildInfoTree b)) -- Split a set of dependencies into direct dependencies and flagged -- dependencies. A direct dependency is a tuple of the name of package and - -- maybe its version (no version means any version) meant to be converted - -- to a 'C.Dependency' with 'mkDirect' for example. A flagged dependency is - -- the set of dependencies guarded by a flag. + -- its version range meant to be converted to a 'C.Dependency' with + -- 'mkDirect' for example. A flagged dependency is the set of dependencies + -- guarded by a flag. splitDeps :: [ExampleDependency] - -> ( [(ExamplePkgName, Maybe Int)] + -> ( [(ExamplePkgName, C.VersionRange)] , [(ExampleFlagName, Dependencies, Dependencies)] ) splitDeps [] = ([], []) splitDeps (ExAny p:deps) = let (directDeps, flaggedDeps) = splitDeps deps - in ((p, Nothing):directDeps, flaggedDeps) + in ((p, C.anyVersion):directDeps, flaggedDeps) splitDeps (ExFix p v:deps) = let (directDeps, flaggedDeps) = splitDeps deps - in ((p, Just v):directDeps, flaggedDeps) - splitDeps (ExFlag f a b:deps) = + in ((p, C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps) + splitDeps (ExRange p v1 v2:deps) = let (directDeps, flaggedDeps) = splitDeps deps + in ((p, mkVersionRange v1 v2):directDeps, flaggedDeps) + splitDeps (ExFlagged f a b:deps) = + let (directDeps, flaggedDeps) = splitDeps deps in (directDeps, (f, a, b):flaggedDeps) splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep @@ -485,6 +555,33 @@ mkSetupDeps deps = let (directDeps, []) = splitDeps deps in map mkDirect directDeps +mkSimpleVersion :: ExamplePkgVersion -> C.Version +mkSimpleVersion n = C.mkVersion [n, 0, 0] + +mkVersionRange :: ExamplePkgVersion -> ExamplePkgVersion -> C.VersionRange +mkVersionRange v1 v2 = + C.intersectVersionRanges (C.orLaterVersion $ mkSimpleVersion v1) + (C.earlierVersion $ mkSimpleVersion v2) + +mkFlag :: ExFlag -> C.Flag +mkFlag flag = C.MkFlag { + C.flagName = C.mkFlagName $ exFlagName flag + , C.flagDescription = "" + , C.flagDefault = exFlagDefault flag + , C.flagManual = + case exFlagType flag of + Manual -> True + Automatic -> False + } + +mkDefaultFlag :: ExampleFlagName -> C.Flag +mkDefaultFlag flag = C.MkFlag { + C.flagName = C.mkFlagName flag + , C.flagDescription = "" + , C.flagDefault = True + , C.flagManual = False + } + exAvPkgId :: ExampleAvailable -> C.PackageIdentifier exAvPkgId ex = C.PackageIdentifier { pkgName = C.mkPackageName (exAvName ex) @@ -517,18 +614,22 @@ -> Maybe [Language] -> PC.PkgConfigDb -> [ExamplePkgName] - -> Solver -> Maybe Int + -> CountConflicts -> IndependentGoals -> ReorderGoals + -> AllowBootLibInstalls -> EnableBackjumping - -> Maybe [ExampleVar] + -> SolveExecutables + -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering) + -> [ExConstraint] -> [ExPreference] -> EnableAllTests -> Progress String String CI.SolverInstallPlan.SolverInstallPlan -exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder - enableBj vars prefs enableAllTests - = resolveDependencies C.buildPlatform compiler pkgConfigDb solver params +exResolve db exts langs pkgConfigDb targets mbj countConflicts indepGoals + reorder allowBootLibInstalls enableBj solveExes goalOrder constraints + prefs enableAllTests + = resolveDependencies C.buildPlatform compiler pkgConfigDb Modular params where defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag compiler = defaultCompiler { C.compilerInfoExtensions = exts @@ -541,46 +642,35 @@ , packagePreferences = Map.empty } enableTests - | asBool enableAllTests = fmap (\p -> PackageConstraintStanzas - (C.mkPackageName p) [TestStanzas]) + | asBool enableAllTests = fmap (\p -> PackageConstraint + (scopeToplevel (C.mkPackageName p)) + (PackagePropertyStanzas [TestStanzas])) (exDbPkgs db) | otherwise = [] targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets - params = addPreferences (fmap toPref prefs) + params = addConstraints (fmap toConstraint constraints) $ addConstraints (fmap toLpc enableTests) + $ addPreferences (fmap toPref prefs) + $ setCountConflicts countConflicts $ setIndependentGoals indepGoals $ setReorderGoals reorder $ setMaxBackjumps mbj + $ setAllowBootLibInstalls allowBootLibInstalls $ setEnableBackjumping enableBj + $ setSolveExecutables solveExes $ setGoalOrder goalOrder $ standardInstallPolicy instIdx avaiIdx targets' toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown + toConstraint (ExVersionConstraint scope v) = + toLpc $ PackageConstraint scope (PackagePropertyVersion v) + toConstraint (ExFlagConstraint scope fn b) = + toLpc $ PackageConstraint scope (PackagePropertyFlags (C.mkFlagAssignment [(C.mkFlagName fn, b)])) + toConstraint (ExStanzaConstraint scope stanzas) = + toLpc $ PackageConstraint scope (PackagePropertyStanzas stanzas) + toPref (ExPkgPref n v) = PackageVersionPreference (C.mkPackageName n) v toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas - - goalOrder :: Maybe (Variable P.QPN -> Variable P.QPN -> Ordering) - goalOrder = (orderFromList . map toVariable) `fmap` vars - - -- Sort elements in the list ahead of elements not in the list. Otherwise, - -- follow the order in the list. - orderFromList :: Eq a => [a] -> a -> a -> Ordering - orderFromList xs = - comparing $ \x -> let i = elemIndex x xs in (isNothing i, i) - - toVariable :: ExampleVar -> Variable P.QPN - toVariable (P q pn) = PackageVar (toQPN q pn) - toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.mkFlagName fn) - toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza - - toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN - toQPN q pn = P.Q pp (C.mkPackageName pn) - where - pp = case q of - None -> P.PackagePath P.DefaultNamespace P.Unqualified - Indep x -> P.PackagePath (P.Independent x) P.Unqualified - Setup p -> P.PackagePath P.DefaultNamespace (P.Setup (C.mkPackageName p)) - IndepSetup x p -> P.PackagePath (P.Independent x) (P.Setup (C.mkPackageName p)) extractInstallPlan :: CI.SolverInstallPlan.SolverInstallPlan -> [(ExamplePkgName, ExamplePkgVersion)] diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE RecordWildCards #-} +-- | Utilities for creating HUnit test cases with the solver DSL. +module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils ( + SolverTest + , SolverResult(..) + , independentGoals + , allowBootLibInstalls + , disableBackjumping + , disableSolveExecutables + , goalOrder + , constraints + , preferences + , enableAllTests + , solverSuccess + , solverFailure + , anySolverFailure + , mkTest + , mkTestExts + , mkTestLangs + , mkTestPCDepends + , mkTestExtLangPC + , runTest + ) where + +import Prelude () +import Distribution.Solver.Compat.Prelude + +import Data.List (elemIndex) +import Data.Ord (comparing) + +-- test-framework +import Test.Tasty as TF +import Test.Tasty.HUnit (testCase, assertEqual, assertBool) + +-- Cabal +import qualified Distribution.PackageDescription as C +import qualified Distribution.Types.PackageName as C +import Language.Haskell.Extension (Extension(..), Language(..)) + +-- cabal-install +import qualified Distribution.Solver.Types.PackagePath as P +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList) +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Variable +import Distribution.Client.Dependency (foldProgress) +import UnitTests.Distribution.Solver.Modular.DSL +import UnitTests.Options + +-- | Combinator to turn on --independent-goals behavior, i.e. solve +-- for the goals as if we were solving for each goal independently. +independentGoals :: SolverTest -> SolverTest +independentGoals test = test { testIndepGoals = IndependentGoals True } + +allowBootLibInstalls :: SolverTest -> SolverTest +allowBootLibInstalls test = + test { testAllowBootLibInstalls = AllowBootLibInstalls True } + +disableBackjumping :: SolverTest -> SolverTest +disableBackjumping test = + test { testEnableBackjumping = EnableBackjumping False } + +disableSolveExecutables :: SolverTest -> SolverTest +disableSolveExecutables test = + test { testSolveExecutables = SolveExecutables False } + +goalOrder :: [ExampleVar] -> SolverTest -> SolverTest +goalOrder order test = test { testGoalOrder = Just order } + +constraints :: [ExConstraint] -> SolverTest -> SolverTest +constraints cs test = test { testConstraints = cs } + +preferences :: [ExPreference] -> SolverTest -> SolverTest +preferences prefs test = test { testSoftConstraints = prefs } + +enableAllTests :: SolverTest -> SolverTest +enableAllTests test = test { testEnableAllTests = EnableAllTests True } + +{------------------------------------------------------------------------------- + Solver tests +-------------------------------------------------------------------------------} + +data SolverTest = SolverTest { + testLabel :: String + , testTargets :: [String] + , testResult :: SolverResult + , testIndepGoals :: IndependentGoals + , testAllowBootLibInstalls :: AllowBootLibInstalls + , testEnableBackjumping :: EnableBackjumping + , testSolveExecutables :: SolveExecutables + , testGoalOrder :: Maybe [ExampleVar] + , testConstraints :: [ExConstraint] + , testSoftConstraints :: [ExPreference] + , testDb :: ExampleDb + , testSupportedExts :: Maybe [Extension] + , testSupportedLangs :: Maybe [Language] + , testPkgConfigDb :: PkgConfigDb + , testEnableAllTests :: EnableAllTests + } + +-- | Expected result of a solver test. +data SolverResult = SolverResult { + -- | The solver's log should satisfy this predicate. Note that we also print + -- the log, so evaluating a large log here can cause a space leak. + resultLogPredicate :: [String] -> Bool, + + -- | Fails with an error message satisfying the predicate, or succeeds with + -- the given plan. + resultErrorMsgPredicateOrPlan :: Either (String -> Bool) [(String, Int)] + } + +solverSuccess :: [(String, Int)] -> SolverResult +solverSuccess = SolverResult (const True) . Right + +solverFailure :: (String -> Bool) -> SolverResult +solverFailure = SolverResult (const True) . Left + +-- | Can be used for test cases where we just want to verify that +-- they fail, but do not care about the error message. +anySolverFailure :: SolverResult +anySolverFailure = solverFailure (const True) + +-- | Makes a solver test case, consisting of the following components: +-- +-- 1. An 'ExampleDb', representing the package database (both +-- installed and remote) we are doing dependency solving over, +-- 2. A 'String' name for the test, +-- 3. A list '[String]' of package names to solve for +-- 4. The expected result, either 'Nothing' if there is no +-- satisfying solution, or a list '[(String, Int)]' of +-- packages to install, at which versions. +-- +-- See 'UnitTests.Distribution.Solver.Modular.DSL' for how +-- to construct an 'ExampleDb', as well as definitions of 'db1' etc. +-- in this file. +mkTest :: ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest +mkTest = mkTestExtLangPC Nothing Nothing [] + +mkTestExts :: [Extension] + -> ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest +mkTestExts exts = mkTestExtLangPC (Just exts) Nothing [] + +mkTestLangs :: [Language] + -> ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest +mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) [] + +mkTestPCDepends :: [(String, String)] + -> ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest +mkTestPCDepends pkgConfigDb = mkTestExtLangPC Nothing Nothing pkgConfigDb + +mkTestExtLangPC :: Maybe [Extension] + -> Maybe [Language] + -> [(String, String)] + -> ExampleDb + -> String + -> [String] + -> SolverResult + -> SolverTest +mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest { + testLabel = label + , testTargets = targets + , testResult = result + , testIndepGoals = IndependentGoals False + , testAllowBootLibInstalls = AllowBootLibInstalls False + , testEnableBackjumping = EnableBackjumping True + , testSolveExecutables = SolveExecutables True + , testGoalOrder = Nothing + , testConstraints = [] + , testSoftConstraints = [] + , testDb = db + , testSupportedExts = exts + , testSupportedLangs = langs + , testPkgConfigDb = pkgConfigDbFromList pkgConfigDb + , testEnableAllTests = EnableAllTests False + } + +runTest :: SolverTest -> TF.TestTree +runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> + testCase testLabel $ do + let progress = exResolve testDb testSupportedExts + testSupportedLangs testPkgConfigDb testTargets + Nothing (CountConflicts True) testIndepGoals + (ReorderGoals False) testAllowBootLibInstalls + testEnableBackjumping testSolveExecutables + (sortGoals <$> testGoalOrder) testConstraints + testSoftConstraints testEnableAllTests + printMsg msg = when showSolverLog $ putStrLn msg + msgs = foldProgress (:) (const []) (const []) progress + assertBool ("Unexpected solver log:\n" ++ unlines msgs) $ + resultLogPredicate testResult $ concatMap lines msgs + result <- foldProgress ((>>) . printMsg) (return . Left) (return . Right) progress + case result of + Left err -> assertBool ("Unexpected error:\n" ++ err) + (checkErrorMsg testResult err) + Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan)) + where + toMaybe :: SolverResult -> Maybe [(String, Int)] + toMaybe = either (const Nothing) Just . resultErrorMsgPredicateOrPlan + + checkErrorMsg :: SolverResult -> String -> Bool + checkErrorMsg result msg = + case resultErrorMsgPredicateOrPlan result of + Left f -> f msg + Right _ -> False + + sortGoals :: [ExampleVar] + -> Variable P.QPN -> Variable P.QPN -> Ordering + sortGoals = orderFromList . map toVariable + + -- Sort elements in the list ahead of elements not in the list. Otherwise, + -- follow the order in the list. + orderFromList :: Eq a => [a] -> a -> a -> Ordering + orderFromList xs = + comparing $ \x -> let i = elemIndex x xs in (isNothing i, i) + + toVariable :: ExampleVar -> Variable P.QPN + toVariable (P q pn) = PackageVar (toQPN q pn) + toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.mkFlagName fn) + toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza + + toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN + toQPN q pn = P.Q pp (C.mkPackageName pn) + where + pp = case q of + QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel + QualIndep p -> P.PackagePath (P.Independent $ C.mkPackageName p) + P.QualToplevel + QualSetup s -> P.PackagePath P.DefaultNamespace + (P.QualSetup (C.mkPackageName s)) + QualIndepSetup p s -> P.PackagePath (P.Independent $ C.mkPackageName p) + (P.QualSetup (C.mkPackageName s)) + QualExe p1 p2 -> P.PackagePath P.DefaultNamespace + (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2)) diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs @@ -0,0 +1,97 @@ +-- | Tests for detecting space leaks in the dependency solver. +module UnitTests.Distribution.Solver.Modular.MemoryUsage (tests) where + +import Test.Tasty (TestTree) + +import UnitTests.Distribution.Solver.Modular.DSL +import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils + +tests :: [TestTree] +tests = [ + runTest $ basicTest "basic space leak test" + , runTest $ flagsTest "package with many flags" + , runTest $ issue2899 "issue #2899" + ] + +-- | This test solves for n packages that each have two versions. There is no +-- solution, because the nth package depends on another package that doesn't fit +-- its version constraint. Backjumping is disabled, so the solver must explore a +-- search tree of size 2^n. It should fail if memory usage is proportional to +-- the size of the tree. +basicTest :: String -> SolverTest +basicTest name = + disableBackjumping $ mkTest pkgs name ["target"] anySolverFailure + where + n :: Int + n = 18 + + pkgs :: ExampleDb + pkgs = map Right $ + [ exAv "target" 1 [ExAny $ pkgName 1]] + ++ [ exAv (pkgName i) v [ExRange (pkgName $ i + 1) 2 4] + | i <- [1..n], v <- [2, 3]] + ++ [exAv (pkgName $ n + 1) 1 []] + + pkgName :: Int -> ExamplePkgName + pkgName x = "pkg-" ++ show x + +-- | This test is similar to 'basicTest', except that it has one package with n +-- flags, flag-1 through flag-n. The solver assigns flags in order, so it +-- doesn't discover the unknown dependencies under flag-n until it has assigned +-- all of the flags. It has to explore the whole search tree. +flagsTest :: String -> SolverTest +flagsTest name = + disableBackjumping $ + goalOrder orderedFlags $ mkTest pkgs name ["pkg"] anySolverFailure + where + n :: Int + n = 16 + + pkgs :: ExampleDb + pkgs = [Right $ exAv "pkg" 1 $ + [exFlagged (flagName n) [ExAny "unknown1"] [ExAny "unknown2"]] + + -- The remaining flags have no effect: + ++ [exFlagged (flagName i) [] [] | i <- [1..n - 1]] + ] + + flagName :: Int -> ExampleFlagName + flagName x = "flag-" ++ show x + + orderedFlags :: [ExampleVar] + orderedFlags = [F QualNone "pkg" (flagName i) | i <- [1..n]] + +-- | Test for a space leak caused by sharing of search trees under packages with +-- link choices (issue #2899). +-- +-- The goal order is fixed so that the solver chooses setup-dep and then +-- target-setup.setup-dep at the top of the search tree. target-setup.setup-dep +-- has two choices: link to setup-dep, and don't link to setup-dep. setup-dep +-- has a long chain of dependencies (pkg-1 through pkg-n). However, pkg-n +-- depends on pkg-n+1, which doesn't exist, so there is no solution. Since each +-- dependency has two versions, the solver must try 2^n combinations when +-- backjumping is disabled. These combinations create large search trees under +-- each of the two choices for target-setup.setup-dep. Although the choice to +-- not link is disallowed by the Single Instance Restriction, the solver doesn't +-- know that until it has explored (and evaluated) the whole tree under the +-- choice to link. If the two trees are shared, memory usage spikes. +issue2899 :: String -> SolverTest +issue2899 name = + disableBackjumping $ + goalOrder goals $ mkTest pkgs name ["target"] anySolverFailure + where + n :: Int + n = 16 + + pkgs :: ExampleDb + pkgs = map Right $ + [ exAv "target" 1 [ExAny "setup-dep"] `withSetupDeps` [ExAny "setup-dep"] + , exAv "setup-dep" 1 [ExAny $ pkgName 1]] + ++ [ exAv (pkgName i) v [ExAny $ pkgName (i + 1)] + | i <- [1..n], v <- [1, 2]] + + pkgName :: Int -> ExamplePkgName + pkgName x = "pkg-" ++ show x + + goals :: [ExampleVar] + goals = [P QualNone "setup-dep", P (QualSetup "target") "setup-dep"] diff --git a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/PSQ.hs b/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/PSQ.hs deleted file mode 100644 --- a/cabal/cabal-install/tests/UnitTests/Distribution/Solver/Modular/PSQ.hs +++ /dev/null @@ -1,22 +0,0 @@ -module UnitTests.Distribution.Solver.Modular.PSQ ( - tests - ) where - -import Distribution.Solver.Modular.PSQ - -import Test.Tasty -import Test.Tasty.QuickCheck - -tests :: [TestTree] -tests = [ testProperty "splitsAltImplementation" splitsTest - ] - --- | Original splits implementation -splits' :: PSQ k a -> PSQ k (a, PSQ k a) -splits' xs = - casePSQ xs - (PSQ []) - (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits' ys))) - -splitsTest :: [(Int, Int)] -> Bool -splitsTest psq = splits' (PSQ psq) == splits (PSQ psq) 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 @@ -1,39 +1,45 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module UnitTests.Distribution.Solver.Modular.QuickCheck (tests) where -import Control.DeepSeq (NFData, force) -import Control.Monad (foldM) +import Prelude () +import Distribution.Client.Compat.Prelude + +import Control.Arrow ((&&&)) +import Control.DeepSeq (force) import Data.Either (lefts) import Data.Function (on) -import Data.List (groupBy, isInfixOf, nub, nubBy, sort) -import Data.Maybe (isJust) -import GHC.Generics (Generic) - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<*>)) -import Data.Monoid (Monoid) -#endif +import Data.Hashable (Hashable(..)) +import Data.List (groupBy, isInfixOf) +import Data.Ord (comparing) import Text.Show.Pretty (parseValue, valToStr) import Test.Tasty (TestTree) import Test.Tasty.QuickCheck -import Distribution.Client.Dependency.Types - ( Solver(..) ) +import Distribution.Types.GenericPackageDescription (FlagName) +import Distribution.Utils.ShortText (ShortText) + import Distribution.Client.Setup (defaultMaxBackjumps) -import Distribution.Package (UnqualComponentName, mkUnqualComponentName) +import Distribution.Types.PackageName +import Distribution.Types.UnqualComponentName import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ComponentDeps ( Component(..), ComponentDep, ComponentDeps ) +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import qualified Distribution.Solver.Types.PackagePath as P import Distribution.Solver.Types.PkgConfigDb (pkgConfigDbFromList) import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Variable +import Distribution.Version import UnitTests.Distribution.Solver.Modular.DSL @@ -43,12 +49,15 @@ -- existence of a solution. It runs the solver twice, and only sets those -- parameters on the second run. The test also applies parameters that -- can affect the existence of a solution to both runs. - testProperty "target order and --reorder-goals do not affect solvability" $ - \(SolverTest db targets) targetOrder reorderGoals indepGoals solver -> - let r1 = solve' (ReorderGoals False) targets db - r2 = solve' reorderGoals targets2 db - solve' reorder = solve (EnableBackjumping True) reorder - indepGoals solver + testProperty "target and goal order do not affect solvability" $ + \test targetOrder mGoalOrder1 mGoalOrder2 indepGoals -> + let r1 = solve' mGoalOrder1 test + r2 = solve' mGoalOrder2 test { testTargets = targets2 } + solve' goalOrder = + solve (EnableBackjumping True) (ReorderGoals False) + (CountConflicts True) indepGoals + (getBlind <$> goalOrder) + targets = testTargets test targets2 = case targetOrder of SameOrder -> targets ReverseOrder -> reverse targets @@ -58,23 +67,42 @@ , testProperty "solvable without --independent-goals => solvable with --independent-goals" $ - \(SolverTest db targets) reorderGoals solver -> - let r1 = solve' (IndependentGoals False) targets db - r2 = solve' (IndependentGoals True) targets db - solve' indep = solve (EnableBackjumping True) - reorderGoals indep solver + \test reorderGoals -> + let r1 = solve' (IndependentGoals False) test + r2 = solve' (IndependentGoals True) test + solve' indep = solve (EnableBackjumping True) reorderGoals + (CountConflicts True) indep Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) `implies` isRight (resultPlan r2) , testProperty "backjumping does not affect solvability" $ - \(SolverTest db targets) reorderGoals indepGoals -> - let r1 = solve' (EnableBackjumping True) targets db - r2 = solve' (EnableBackjumping False) targets db - solve' enableBj = solve enableBj reorderGoals indepGoals Modular + \test reorderGoals indepGoals -> + let r1 = solve' (EnableBackjumping True) test + r2 = solve' (EnableBackjumping False) test + solve' enableBj = solve enableBj reorderGoals + (CountConflicts True) indepGoals Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) === isRight (resultPlan r2) + + -- This test uses --no-count-conflicts, because the goal order used with + -- --count-conflicts depends on the total set of conflicts seen by the + -- solver. The solver explores more of the tree and encounters more + -- conflicts when it doesn't backjump. The different goal orders can lead to + -- different solutions and cause the test to fail. + -- TODO: Find a faster way to randomly sort goals, and then use a random + -- goal order in this test. + , testProperty + "backjumping does not affect the result (with static goal order)" $ + \test reorderGoals indepGoals -> + let r1 = solve' (EnableBackjumping True) test + r2 = solve' (EnableBackjumping False) test + solve' enableBj = solve enableBj reorderGoals + (CountConflicts False) indepGoals Nothing + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> + resultPlan r1 === resultPlan r2 ] where noneReachedBackjumpLimit :: [Result] -> Bool @@ -97,18 +125,25 @@ isRight (Right _) = True isRight _ = False -solve :: EnableBackjumping -> ReorderGoals -> IndependentGoals - -> Solver -> [PN] -> TestDb -> Result -solve enableBj reorder indep solver targets (TestDb db) = +newtype VarOrdering = VarOrdering { + unVarOrdering :: Variable P.QPN -> Variable P.QPN -> Ordering + } + +solve :: EnableBackjumping -> ReorderGoals -> CountConflicts -> IndependentGoals + -> Maybe VarOrdering + -> SolverTest -> Result +solve enableBj reorder countConflicts indep goalOrder test = let (lg, result) = - runProgress $ exResolve db Nothing Nothing + runProgress $ exResolve (unTestDb (testDb test)) Nothing Nothing (pkgConfigDbFromList []) - (map unPN targets) - solver + (map unPN (testTargets test)) -- The backjump limit prevents individual tests from using -- too much time and memory. (Just defaultMaxBackjumps) - indep reorder enableBj Nothing [] (EnableAllTests True) + countConflicts indep reorder (AllowBootLibInstalls False) + enableBj (SolveExecutables True) (unVarOrdering <$> goalOrder) + (testConstraints test) (testPreferences test) + (EnableAllTests False) failure :: String -> Failure failure msg @@ -167,26 +202,36 @@ data SolverTest = SolverTest { testDb :: TestDb , testTargets :: [PN] + , testConstraints :: [ExConstraint] + , testPreferences :: [ExPreference] } -- | Pretty-print the test when quickcheck calls 'show'. instance Show SolverTest where show test = let str = "SolverTest {testDb = " ++ show (testDb test) - ++ ", testTargets = " ++ show (testTargets test) ++ "}" + ++ ", testTargets = " ++ show (testTargets test) + ++ ", testConstraints = " ++ show (testConstraints test) + ++ ", testPreferences = " ++ show (testPreferences test) + ++ "}" in maybe str valToStr $ parseValue str instance Arbitrary SolverTest where arbitrary = do db <- arbitrary - let pkgs = nub $ map getName (unTestDb db) + let pkgVersions = nub $ map (getName &&& getVersion) (unTestDb db) + pkgs = nub $ map fst pkgVersions Positive n <- arbitrary targets <- randomSubset n pkgs - return (SolverTest db targets) + constraints <- boundedListOf 1 $ arbitraryConstraint pkgVersions + prefs <- boundedListOf 3 $ arbitraryPreference pkgVersions + return (SolverTest db targets constraints prefs) shrink test = [test { testDb = db } | db <- shrink (testDb test)] ++ [test { testTargets = targets } | targets <- shrink (testTargets test)] + ++ [test { testConstraints = cs } | cs <- shrink (testConstraints test)] + ++ [test { testPreferences = prefs } | prefs <- shrink (testPreferences test)] -- | Collection of source and installed packages. newtype TestDb = TestDb { unTestDb :: ExampleDb } @@ -202,7 +247,7 @@ TestDb <$> shuffle (unTestDb db) where nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb - nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> mapM (nextPkg db) pkgs + nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> traverse (nextPkg db) pkgs nextPkg :: TestDb -> (PN, PV) -> Gen TestPackage nextPkg db (pn, v) = do @@ -215,14 +260,14 @@ arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable arbitraryExAv pn v db = - ExAv (unPN pn) (unPV v) <$> arbitraryComponentDeps db + (\cds -> ExAv (unPN pn) (unPV v) cds []) <$> arbitraryComponentDeps db arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled arbitraryExInst pn v pkgs = do - hash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] + pkgHash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] numDeps <- min 3 <$> arbitrary deps <- randomSubset numDeps pkgs - return $ ExInst (unPN pn) (unPV v) hash (map exInstHash deps) + return $ ExInst (unPN pn) (unPV v) pkgHash (map exInstHash deps) arbitraryComponentDeps :: TestDb -> Gen (ComponentDeps [ExampleDependency]) arbitraryComponentDeps (TestDb []) = return $ CD.fromList [] @@ -258,9 +303,9 @@ arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency arbitraryExDep db@(TestDb pkgs) level = - let flag = ExFlag <$> arbitraryFlagName - <*> arbitraryDeps db - <*> arbitraryDeps db + let flag = ExFlagged <$> arbitraryFlagName + <*> arbitraryDeps db + <*> arbitraryDeps db other = -- Package checks require dependencies on "base" to have bounds. let notBase = filter ((/= PN "base") . getName) pkgs @@ -287,6 +332,34 @@ arbitraryFlagName :: Gen String arbitraryFlagName = (:[]) <$> elements ['A'..'E'] +arbitraryConstraint :: [(PN, PV)] -> Gen ExConstraint +arbitraryConstraint pkgs = do + (PN pn, v) <- elements pkgs + let anyQualifier = ScopeAnyQualifier (mkPackageName pn) + oneof [ + ExVersionConstraint anyQualifier <$> arbitraryVersionRange v + , ExStanzaConstraint anyQualifier <$> sublistOf [TestStanzas, BenchStanzas] + ] + +arbitraryPreference :: [(PN, PV)] -> Gen ExPreference +arbitraryPreference pkgs = do + (PN pn, v) <- elements pkgs + oneof [ + ExStanzaPref pn <$> sublistOf [TestStanzas, BenchStanzas] + , ExPkgPref pn <$> arbitraryVersionRange v + ] + +arbitraryVersionRange :: PV -> Gen VersionRange +arbitraryVersionRange (PV v) = + let version = mkSimpleVersion v + in elements [ + thisVersion version + , notThisVersion version + , earlierVersion version + , orLaterVersion version + , noVersion + ] + instance Arbitrary ReorderGoals where arbitrary = ReorderGoals <$> arbitrary @@ -297,11 +370,6 @@ shrink (IndependentGoals indep) = [IndependentGoals False | indep] -instance Arbitrary Solver where - arbitrary = return Modular - - shrink Modular = [] - instance Arbitrary UnqualComponentName where arbitrary = mkUnqualComponentName <$> (:[]) <$> elements "ABC" @@ -309,6 +377,7 @@ arbitrary = oneof [ return ComponentLib , ComponentSubLib <$> arbitrary , ComponentExe <$> arbitrary + , ComponentFLib <$> arbitrary , ComponentTest <$> arbitrary , ComponentBench <$> arbitrary , return ComponentSetup @@ -339,10 +408,10 @@ shrink (ExAny _) = [] shrink (ExFix "base" _) = [] -- preserve bounds on base shrink (ExFix pn _) = [ExAny pn] - shrink (ExFlag flag th el) = + shrink (ExFlagged flag th el) = deps th ++ deps el - ++ [ExFlag flag th' el | th' <- shrink th] - ++ [ExFlag flag th el' | el' <- shrink el] + ++ [ExFlagged flag th' el | th' <- shrink th] + ++ [ExFlagged flag th el' | el' <- shrink el] where deps NotBuildable = [] deps (Buildable ds) = ds @@ -353,6 +422,56 @@ shrink NotBuildable = [Buildable []] shrink (Buildable deps) = map Buildable (shrink deps) + +instance Arbitrary ExConstraint where + arbitrary = error "arbitrary not implemented: ExConstraint" + + shrink (ExStanzaConstraint scope stanzas) = + [ExStanzaConstraint scope stanzas' | stanzas' <- shrink stanzas] + shrink (ExVersionConstraint scope vr) = + [ExVersionConstraint scope vr' | vr' <- shrink vr] + shrink _ = [] + +instance Arbitrary ExPreference where + arbitrary = error "arbitrary not implemented: ExPreference" + + shrink (ExStanzaPref pn stanzas) = + [ExStanzaPref pn stanzas' | stanzas' <- shrink stanzas] + shrink (ExPkgPref pn vr) = [ExPkgPref pn vr' | vr' <- shrink vr] + +instance Arbitrary OptionalStanza where + arbitrary = error "arbitrary not implemented: OptionalStanza" + + shrink BenchStanzas = [TestStanzas] + shrink TestStanzas = [] + +instance Arbitrary VersionRange where + arbitrary = error "arbitrary not implemented: VersionRange" + + shrink vr = [noVersion | vr /= noVersion] + +-- Randomly sorts solver variables using 'hash'. +-- TODO: Sorting goals with this function is very slow. +instance Arbitrary VarOrdering where + arbitrary = do + f <- arbitrary :: Gen (Int -> Int) + return $ VarOrdering (comparing (f . hash)) + +instance Hashable pn => Hashable (Variable pn) +instance Hashable a => Hashable (P.Qualified a) +instance Hashable P.PackagePath +instance Hashable P.Qualifier +instance Hashable P.Namespace +instance Hashable OptionalStanza +instance Hashable FlagName +instance Hashable PackageName +instance Hashable ShortText + +deriving instance Generic (Variable pn) +deriving instance Generic (P.Qualified a) +deriving instance Generic P.PackagePath +deriving instance Generic P.Namespace +deriving instance Generic P.Qualifier randomSubset :: Int -> [a] -> Gen [a] randomSubset n xs = take n <$> shuffle xs 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} -- | This is a set of unit tests for the dependency solver, -- which uses the solver DSL ("UnitTests.Distribution.Solver.Modular.DSL") -- to more conveniently create package databases to run the solver tests on. @@ -12,21 +12,18 @@ -- test-framework import Test.Tasty as TF -import Test.Tasty.HUnit (testCase, assertEqual, assertBool) -- Cabal import Language.Haskell.Extension ( Extension(..) , KnownExtension(..), Language(..)) -- cabal-install +import Distribution.Solver.Types.Flag import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList) -import Distribution.Solver.Types.Settings -import Distribution.Client.Dependency (foldProgress) -import Distribution.Client.Dependency.Types - ( Solver(Modular) ) +import Distribution.Solver.Types.PackageConstraint +import qualified Distribution.Solver.Types.PackagePath as P import UnitTests.Distribution.Solver.Modular.DSL -import UnitTests.Options +import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils tests :: [TF.TestTree] tests = [ @@ -44,8 +41,8 @@ , runTest $ mkTest db1 "buildDepAgainstNew" ["G"] (solverSuccess [("B", 2), ("E", 1), ("G", 1)]) , runTest $ indep $ mkTest db1 "multipleInstances" ["F", "G"] anySolverFailure , runTest $ mkTest db21 "unknownPackage1" ["A"] (solverSuccess [("A", 1), ("B", 1)]) - , runTest $ mkTest db22 "unknownPackage2" ["A"] (solverFaiure (isInfixOf "unknown package: C")) - , runTest $ mkTest db23 "unknownPackage3" ["A"] (solverFaiure (isInfixOf "unknown package: B")) + , runTest $ mkTest db22 "unknownPackage2" ["A"] (solverFailure (isInfixOf "unknown package: C")) + , runTest $ mkTest db23 "unknownPackage3" ["A"] (solverFailure (isInfixOf "unknown package: B")) ] , testGroup "Flagged dependencies" [ runTest $ mkTest db3 "forceFlagOn" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) @@ -54,6 +51,63 @@ , runTest $ indep $ mkTest db4 "linkFlags2" ["C", "D"] anySolverFailure , runTest $ indep $ mkTest db18 "linkFlags3" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)]) ] + , testGroup "Manual flags" [ + runTest $ mkTest dbManualFlags "Use default value for manual flag" ["pkg"] $ + solverSuccess [("pkg", 1), ("true-dep", 1)] + + , let checkFullLog = + any $ isInfixOf "rejecting: pkg:-flag (manual flag can only be changed explicitly)" + in runTest $ constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $ + mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $ + -- TODO: We should check the summarized log instead of the full log + -- for the manual flags error message, but it currently only + -- appears in the full log. + SolverResult checkFullLog (Left $ const True) + + , let cs = [ExFlagConstraint (ScopeAnyQualifier "pkg") "flag" False] + in runTest $ constraints cs $ + mkTest dbManualFlags "Toggle manual flag with flag constraint" ["pkg"] $ + solverSuccess [("false-dep", 1), ("pkg", 1)] + ] + , testGroup "Qualified manual flag constraints" [ + let name = "Top-level flag constraint does not constrain setup dep's flag" + cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] + in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ + solverSuccess [ ("A", 1), ("B", 1), ("B", 2) + , ("b-1-false-dep", 1), ("b-2-true-dep", 1) ] + + , let name = "Solver can toggle setup dep's flag to match top-level constraint" + cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False + , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion ] + in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ + solverSuccess [ ("A", 1), ("B", 1), ("B", 2) + , ("b-1-false-dep", 1), ("b-2-false-dep", 1) ] + + , let name = "User can constrain flags separately with qualified constraints" + cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True + , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ] + in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ + solverSuccess [ ("A", 1), ("B", 1), ("B", 2) + , ("b-1-true-dep", 1), ("b-2-false-dep", 1) ] + + -- Regression test for #4299 + , let name = "Solver can link deps when only one has constrained manual flag" + cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] + in runTest $ constraints cs $ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ + solverSuccess [ ("A", 1), ("B", 1), ("b-1-false-dep", 1) ] + + , let name = "Solver cannot link deps that have conflicting manual flag constraints" + cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True + , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ] + failureReason = "(constraint from unknown source requires opposite flag selection)" + checkFullLog lns = + all (\msg -> any (msg `isInfixOf`) lns) + [ "rejecting: B:-flag " ++ failureReason + , "rejecting: A:setup.B:+flag " ++ failureReason ] + in runTest $ constraints cs $ + mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ + SolverResult checkFullLog (Left $ const True) + ] , testGroup "Stanzas" [ runTest $ enableAllTests $ mkTest db5 "simpleTest1" ["C"] (solverSuccess [("A", 2), ("C", 1)]) , runTest $ enableAllTests $ mkTest db5 "simpleTest2" ["D"] anySolverFailure @@ -64,6 +118,7 @@ , runTest $ indep $ enableAllTests $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)]) , runTest $ enableAllTests $ mkTest db6 "depsWithTests1" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) , runTest $ indep $ enableAllTests $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]) + , runTest $ testTestSuiteWithFlag "test suite with flag" ] , testGroup "Setup dependencies" [ runTest $ mkTest db7 "setupDeps1" ["B"] (solverSuccess [("A", 2), ("B", 1)]) @@ -84,6 +139,12 @@ , runTest $ mkTest db12 "baseShim5" ["D"] anySolverFailure , runTest $ mkTest db12 "baseShim6" ["E"] (solverSuccess [("E", 1), ("syb", 2)]) ] + , testGroup "Base" [ + runTest $ mkTest dbBase "Refuse to install base without --allow-boot-library-installs" ["base"] $ + solverFailure (isInfixOf "only already installed instances can be used") + , runTest $ allowBootLibInstalls $ mkTest dbBase "Install base with --allow-boot-library-installs" ["base"] $ + solverSuccess [("base", 1), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)] + ] , testGroup "Cycles" [ runTest $ mkTest db14 "simpleCycle1" ["A"] anySolverFailure , runTest $ mkTest db14 "simpleCycle2" ["A", "B"] anySolverFailure @@ -93,6 +154,7 @@ , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"] (solverSuccess [("C", 2), ("D", 1)]) , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"] (solverSuccess [("D", 1)]) , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"] (solverSuccess [("C", 2), ("D", 1), ("E", 1)]) + , runTest $ testCyclicDependencyErrorMessages "cyclic dependency error messages" ] , testGroup "Extensions" [ runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] anySolverFailure @@ -109,7 +171,27 @@ , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] anySolverFailure , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (solverSuccess [("A",1),("B",1),("C",1)]) ] + , testGroup "Qualified Package Constraints" [ + runTest $ mkTest dbConstraints "install latest versions without constraints" ["A", "B", "C"] $ + solverSuccess [("A", 7), ("B", 8), ("C", 9), ("D", 7), ("D", 8), ("D", 9)] + , let cs = [ ExVersionConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4 ] + in runTest $ constraints cs $ + mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $ + solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)] + + , let cs = [ ExVersionConstraint (ScopeQualified P.QualToplevel "D") $ mkVersionRange 1 4 + , ExVersionConstraint (ScopeQualified (P.QualSetup "B") "D") $ mkVersionRange 4 7 + ] + in runTest $ constraints cs $ + mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $ + solverSuccess [("A", 1), ("B", 5), ("C", 9), ("D", 1), ("D", 5), ("D", 9)] + + , let cs = [ ExVersionConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4 ] + in runTest $ constraints cs $ + mkTest dbConstraints "constrain package across setup scripts" ["A", "B", "C"] $ + solverSuccess [("A", 7), ("B", 2), ("C", 3), ("D", 2), ("D", 3), ("D", 7)] + ] , testGroup "Package Preferences" [ runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1] $ mkTest db13 "selectPreferredVersionSimple" ["A"] (solverSuccess [("A", 1)]) , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (solverSuccess [("A", 2)]) @@ -134,6 +216,8 @@ , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $ mkTest dbStanzaPreferences2 "disable testing when it's not possible" ["pkg"] $ solverSuccess [("pkg", 1)] + + , testStanzaPreference "test stanza preference" ] , testGroup "Buildable Field" [ testBuildable "avoid building component with unknown dependency" (ExAny "unknown") @@ -164,188 +248,107 @@ , runTest $ mkTest dbBJ1b "bj1b" ["A"] (solverSuccess [("A", 1), ("B", 1)]) , runTest $ mkTest dbBJ1c "bj1c" ["A"] (solverSuccess [("A", 1), ("B", 1)]) , runTest $ mkTest dbBJ2 "bj2" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTest dbBJ3 "bj3 " ["A"] (solverSuccess [("A", 1), ("Ba", 1), ("C", 1)]) + , runTest $ mkTest dbBJ3 "bj3" ["A"] (solverSuccess [("A", 1), ("Ba", 1), ("C", 1)]) , runTest $ mkTest dbBJ4 "bj4" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) , runTest $ mkTest dbBJ5 "bj5" ["A"] (solverSuccess [("A", 1), ("B", 1), ("D", 1)]) , runTest $ mkTest dbBJ6 "bj6" ["A"] (solverSuccess [("A", 1), ("B", 1)]) , runTest $ mkTest dbBJ7 "bj7" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) , runTest $ indep $ mkTest dbBJ8 "bj8" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) ] - -- Build-tools dependencies - , testGroup "build-tools" [ - runTest $ mkTest dbBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)]) - , runTest $ mkTest dbBuildTools2 "bt2" ["A"] (solverSuccess [("A", 1)]) - , runTest $ mkTest dbBuildTools3 "bt3" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)]) - , runTest $ mkTest dbBuildTools4 "bt4" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)]) - , runTest $ mkTest dbBuildTools5 "bt5" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)]) - , runTest $ mkTest dbBuildTools6 "bt6" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)]) - ] - -- Tests for the contents of the solver's log - , testGroup "Solver log" [ - -- See issue #3203. The solver should only choose a version for A once. - runTest $ - let db = [Right $ exAv "A" 1 []] - p lg = elem "targets: A" lg - && length (filter ("trying: A" `isInfixOf`) lg) == 1 - in mkTest db "deduplicate targets" ["A", "A"] $ - SolverResult p $ Right [("A", 1)] - ] - ] - where - mkvrThis = V.thisVersion . makeV - mkvrOrEarlier = V.orEarlierVersion . makeV - makeV v = V.mkVersion [v,0,0] + -- build-tool-depends dependencies + , testGroup "build-tool-depends" [ + runTest $ mkTest dbBuildTools "simple exe dependency" ["A"] (solverSuccess [("A", 1), ("bt-pkg", 2)]) --- | Combinator to turn on --independent-goals behavior, i.e. solve --- for the goals as if we were solving for each goal independently. -indep :: SolverTest -> SolverTest -indep test = test { testIndepGoals = IndependentGoals True } + , runTest $ disableSolveExecutables $ + mkTest dbBuildTools "don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)]) -goalOrder :: [ExampleVar] -> SolverTest -> SolverTest -goalOrder order test = test { testGoalOrder = Just order } + , runTest $ mkTest dbBuildTools "flagged exe dependency" ["B"] (solverSuccess [("B", 1), ("bt-pkg", 2)]) -preferences :: [ExPreference] -> SolverTest -> SolverTest -preferences prefs test = test { testSoftConstraints = prefs } + , runTest $ enableAllTests $ + mkTest dbBuildTools "test suite exe dependency" ["C"] (solverSuccess [("C", 1), ("bt-pkg", 2)]) -enableAllTests :: SolverTest -> SolverTest -enableAllTests test = test { testEnableAllTests = EnableAllTests True } + , runTest $ mkTest dbBuildTools "unknown exe" ["D"] $ + solverFailure (isInfixOf "does not contain executable unknown-exe, which is required by D") -data GoalOrder = FixedGoalOrder | DefaultGoalOrder + , runTest $ disableSolveExecutables $ + mkTest dbBuildTools "don't check for build tool executables in legacy mode" ["D"] $ solverSuccess [("D", 1)] -{------------------------------------------------------------------------------- - Solver tests --------------------------------------------------------------------------------} + , runTest $ mkTest dbBuildTools "unknown build tools package error mentions package, not exe" ["E"] $ + solverFailure (isInfixOf "unknown package: E:unknown-pkg:exe.unknown-pkg (dependency of E)") -data SolverTest = SolverTest { - testLabel :: String - , testTargets :: [String] - , testResult :: SolverResult - , testIndepGoals :: IndependentGoals - , testGoalOrder :: Maybe [ExampleVar] - , testSoftConstraints :: [ExPreference] - , testDb :: ExampleDb - , testSupportedExts :: Maybe [Extension] - , testSupportedLangs :: Maybe [Language] - , testPkgConfigDb :: PkgConfigDb - , testEnableAllTests :: EnableAllTests - } + , runTest $ mkTest dbBuildTools "unknown flagged exe" ["F"] $ + solverFailure (isInfixOf "does not contain executable unknown-exe, which is required by F +flagF") --- | Expected result of a solver test. -data SolverResult = SolverResult { - -- | The solver's log should satisfy this predicate. Note that we also print - -- the log, so evaluating a large log here can cause a space leak. - resultLogPredicate :: [String] -> Bool, + , runTest $ enableAllTests $ mkTest dbBuildTools "unknown test suite exe" ["G"] $ + solverFailure (isInfixOf "does not contain executable unknown-exe, which is required by G *test") - -- | Fails with an error message satisfying the predicate, or succeeds with - -- the given plan. - resultErrorMsgPredicateOrPlan :: Either (String -> Bool) [(String, Int)] - } + , runTest $ mkTest dbBuildTools "wrong exe for build tool package version" ["H"] $ + solverFailure $ isInfixOf $ + -- The solver reports the version conflict when a version conflict + -- and an executable conflict apply to the same package version. + "rejecting: H:bt-pkg:exe.bt-pkg-4.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)\n" + ++ "rejecting: H:bt-pkg:exe.bt-pkg-3.0.0 (does not contain executable exe1, which is required by H)\n" + ++ "rejecting: H:bt-pkg:exe.bt-pkg-2.0.0, H:bt-pkg:exe.bt-pkg-1.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)" -solverSuccess :: [(String, Int)] -> SolverResult -solverSuccess = SolverResult (const True) . Right + , runTest $ chooseExeAfterBuildToolsPackage True "choose exe after choosing its package - success" -solverFaiure :: (String -> Bool) -> SolverResult -solverFaiure = SolverResult (const True) . Left + , runTest $ chooseExeAfterBuildToolsPackage False "choose exe after choosing its package - failure" --- | Can be used for test cases where we just want to verify that --- they fail, but do not care about the error message. -anySolverFailure :: SolverResult -anySolverFailure = solverFaiure (const True) + , runTest $ rejectInstalledBuildToolPackage "reject installed package for build-tool dependency" --- | Makes a solver test case, consisting of the following components: --- --- 1. An 'ExampleDb', representing the package database (both --- installed and remote) we are doing dependency solving over, --- 2. A 'String' name for the test, --- 3. A list '[String]' of package names to solve for --- 4. The expected result, either 'Nothing' if there is no --- satisfying solution, or a list '[(String, Int)]' of --- packages to install, at which versions. --- --- See 'UnitTests.Distribution.Solver.Modular.DSL' for how --- to construct an 'ExampleDb', as well as definitions of 'db1' etc. --- in this file. -mkTest :: ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTest = mkTestExtLangPC Nothing Nothing [] + , runTest $ requireConsistentBuildToolVersions "build tool versions must be consistent within one package" + ] + -- build-tools dependencies + , testGroup "legacy build-tools" [ + runTest $ mkTest dbLegacyBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)]) -mkTestExts :: [Extension] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTestExts exts = mkTestExtLangPC (Just exts) Nothing [] + , runTest $ disableSolveExecutables $ + mkTest dbLegacyBuildTools1 "bt1 - don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)]) -mkTestLangs :: [Language] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) [] + , runTest $ mkTest dbLegacyBuildTools2 "bt2" ["A"] $ + solverFailure (isInfixOf "does not contain executable alex, which is required by A") -mkTestPCDepends :: [(String, String)] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTestPCDepends pkgConfigDb = mkTestExtLangPC Nothing Nothing pkgConfigDb + , runTest $ disableSolveExecutables $ + mkTest dbLegacyBuildTools2 "bt2 - don't check for build tool executables in legacy mode" ["A"] (solverSuccess [("A", 1)]) -mkTestExtLangPC :: Maybe [Extension] - -> Maybe [Language] - -> [(String, String)] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest { - testLabel = label - , testTargets = targets - , testResult = result - , testIndepGoals = IndependentGoals False - , testGoalOrder = Nothing - , testSoftConstraints = [] - , testDb = db - , testSupportedExts = exts - , testSupportedLangs = langs - , testPkgConfigDb = pkgConfigDbFromList pkgConfigDb - , testEnableAllTests = EnableAllTests False - } + , runTest $ mkTest dbLegacyBuildTools3 "bt3" ["A"] (solverSuccess [("A", 1)]) -runTest :: SolverTest -> TF.TestTree -runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> - testCase testLabel $ do - let progress = exResolve testDb testSupportedExts - testSupportedLangs testPkgConfigDb testTargets - Modular Nothing testIndepGoals (ReorderGoals False) - (EnableBackjumping True) testGoalOrder testSoftConstraints - testEnableAllTests - printMsg msg = if showSolverLog - then putStrLn msg - else return () - msgs = foldProgress (:) (const []) (const []) progress - assertBool ("Unexpected solver log:\n" ++ unlines msgs) $ - resultLogPredicate testResult $ concatMap lines msgs - result <- foldProgress ((>>) . printMsg) (return . Left) (return . Right) progress - case result of - Left err -> assertBool ("Unexpected error:\n" ++ err) - (checkErrorMsg testResult err) - Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan)) + , runTest $ mkTest dbLegacyBuildTools4 "bt4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)]) + + , runTest $ mkTest dbLegacyBuildTools5 "bt5" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)]) + + , runTest $ mkTest dbLegacyBuildTools6 "bt6" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)]) + ] + -- internal dependencies + , testGroup "internal dependencies" [ + runTest $ mkTest dbIssue3775 "issue #3775" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)]) + ] + -- Tests for the contents of the solver's log + , testGroup "Solver log" [ + -- See issue #3203. The solver should only choose a version for A once. + runTest $ + let db = [Right $ exAv "A" 1 []] + + p :: [String] -> Bool + p lg = elem "targets: A" lg + && length (filter ("trying: A" `isInfixOf`) lg) == 1 + in mkTest db "deduplicate targets" ["A", "A"] $ + SolverResult p $ Right [("A", 1)] + , runTest $ + let db = [Right $ exAv "A" 1 [ExAny "B"]] + msg = "After searching the rest of the dependency tree exhaustively, " + ++ "these were the goals I've had most trouble fulfilling: A, B" + in mkTest db "exhaustive search failure message" ["A"] $ + solverFailure (isInfixOf msg) + ] + ] where - toMaybe :: SolverResult -> Maybe [(String, Int)] - toMaybe = either (const Nothing) Just . resultErrorMsgPredicateOrPlan + indep = independentGoals + mkvrThis = V.thisVersion . makeV + mkvrOrEarlier = V.orEarlierVersion . makeV + makeV v = V.mkVersion [v,0,0] - checkErrorMsg :: SolverResult -> String -> Bool - checkErrorMsg result msg = - case resultErrorMsgPredicateOrPlan result of - Left f -> f msg - Right _ -> False +data GoalOrder = FixedGoalOrder | DefaultGoalOrder {------------------------------------------------------------------------------- Specific example database for the tests @@ -381,7 +384,7 @@ db3 = [ Right $ exAv "A" 1 [] , Right $ exAv "A" 2 [] - , Right $ exAv "B" 1 [exFlag "flagB" [ExFix "A" 1] [ExFix "A" 2]] + , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "A" 1] [ExFix "A" 2]] , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"] , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"] ] @@ -424,11 +427,53 @@ , Right $ exAv "Ax" 2 [] , Right $ exAv "Ay" 1 [] , Right $ exAv "Ay" 2 [] - , Right $ exAv "B" 1 [exFlag "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]] + , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]] , Right $ exAv "C" 1 [ExFix "Ax" 2, ExAny "B"] , Right $ exAv "D" 1 [ExFix "Ay" 2, ExAny "B"] ] +-- | Simple database containing one package with a manual flag. +dbManualFlags :: ExampleDb +dbManualFlags = [ + Right $ declareFlags [ExFlag "flag" True Manual] $ + exAv "pkg" 1 [exFlagged "flag" [ExAny "true-dep"] [ExAny "false-dep"]] + , Right $ exAv "true-dep" 1 [] + , Right $ exAv "false-dep" 1 [] + ] + +-- | Database containing a setup dependency with a manual flag. A's library and +-- setup script depend on two different versions of B. B's manual flag can be +-- set to different values in the two places where it is used. +dbSetupDepWithManualFlag :: ExampleDb +dbSetupDepWithManualFlag = + let bFlags = [ExFlag "flag" True Manual] + in [ + Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 2] + , Right $ declareFlags bFlags $ + exAv "B" 1 [exFlagged "flag" [ExAny "b-1-true-dep"] + [ExAny "b-1-false-dep"]] + , Right $ declareFlags bFlags $ + exAv "B" 2 [exFlagged "flag" [ExAny "b-2-true-dep"] + [ExAny "b-2-false-dep"]] + , Right $ exAv "b-1-true-dep" 1 [] + , Right $ exAv "b-1-false-dep" 1 [] + , Right $ exAv "b-2-true-dep" 1 [] + , Right $ exAv "b-2-false-dep" 1 [] + ] + +-- | A database similar to 'dbSetupDepWithManualFlag', except that the library +-- and setup script both depend on B-1. B must be linked because of the Single +-- Instance Restriction, and its flag can only have one value. +dbLinkedSetupDepWithManualFlag :: ExampleDb +dbLinkedSetupDepWithManualFlag = [ + Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 1] + , Right $ declareFlags [ExFlag "flag" True Manual] $ + exAv "B" 1 [exFlagged "flag" [ExAny "b-1-true-dep"] + [ExAny "b-1-false-dep"]] + , Right $ exAv "b-1-true-dep" 1 [] + , Right $ exAv "b-1-false-dep" 1 [] + ] + -- | Some tests involving testsuites -- -- Note that in this test framework test suites are always enabled; if you @@ -473,6 +518,35 @@ , Right $ exAv "D" 1 [ExAny "B"] ] +-- | This test checks that the solver can backjump to disable a flag, even if +-- the problematic dependency is also under a test suite. (issue #4390) +-- +-- The goal order forces the solver to choose the flag before enabling testing. +-- Previously, the solver couldn't handle this case, because it only tried to +-- disable testing, and when that failed, it backjumped past the flag choice. +-- The solver should also try to set the flag to false, because that avoids the +-- dependency on B. +testTestSuiteWithFlag :: String -> SolverTest +testTestSuiteWithFlag name = + goalOrder goals $ enableAllTests $ mkTest db name ["A", "B"] $ + solverSuccess [("A", 1), ("B", 1)] + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [] + `withTest` + ExTest "test" [exFlagged "flag" [ExFix "B" 2] []] + , Right $ exAv "B" 1 [] + ] + + goals :: [ExampleVar] + goals = [ + P QualNone "B" + , P QualNone "A" + , F QualNone "A" "flag" + , S QualNone "A" TestStanzas + ] + -- Packages with setup dependencies -- -- Install.. @@ -600,6 +674,15 @@ , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2] ] +dbBase :: ExampleDb +dbBase = [ + Right $ exAv "base" 1 + [ExAny "ghc-prim", ExAny "integer-simple", ExAny "integer-gmp"] + , Right $ exAv "ghc-prim" 1 [] + , Right $ exAv "integer-simple" 1 [] + , Right $ exAv "integer-gmp" 1 [] + ] + db13 :: ExampleDb db13 = [ Right $ exAv "A" 1 [] @@ -607,6 +690,20 @@ , Right $ exAv "A" 3 [] ] +-- | A, B, and C have three different dependencies on D that can be set to +-- different versions with qualified constraints. Each version of D can only +-- be depended upon by one version of A, B, or C, so that the versions of A, B, +-- and C in the install plan indicate which version of D was chosen for each +-- dependency. The one-to-one correspondence between versions of A, B, and C and +-- versions of D also prevents linking, which would complicate the solver's +-- behavior. +dbConstraints :: ExampleDb +dbConstraints = + [Right $ exAv "A" v [ExFix "D" v] | v <- [1, 4, 7]] + ++ [Right $ exAv "B" v [] `withSetupDeps` [ExFix "D" v] | v <- [2, 5, 8]] + ++ [Right $ exAv "C" v [] `withSetupDeps` [ExFix "D" v] | v <- [3, 6, 9]] + ++ [Right $ exAv "D" v [] | v <- [1..9]] + dbStanzaPreferences1 :: ExampleDb dbStanzaPreferences1 = [ Right $ exAv "pkg" 1 [] `withTest` ExTest "test" [ExAny "test-dep"] @@ -618,6 +715,32 @@ Right $ exAv "pkg" 1 [] `withTest` ExTest "test" [ExAny "unknown"] ] +-- | This is a test case for a bug in stanza preferences (#3930). The solver +-- should be able to install 'A' by enabling 'flag' and disabling testing. When +-- it tries goals in the specified order and prefers testing, it encounters +-- 'unknown-pkg2'. 'unknown-pkg2' is only introduced by testing and 'flag', so +-- the conflict set should contain both of those variables. Before the fix, it +-- only contained 'flag'. The solver backjumped past the choice to disable +-- testing and failed to find the solution. +testStanzaPreference :: String -> TestTree +testStanzaPreference name = + let pkg = exAv "A" 1 [exFlagged "flag" + [] + [ExAny "unknown-pkg1"]] + `withTest` + ExTest "test" [exFlagged "flag" + [ExAny "unknown-pkg2"] + []] + goals = [ + P QualNone "A" + , F QualNone "A" "flag" + , S QualNone "A" TestStanzas + ] + in runTest $ goalOrder goals $ + preferences [ ExStanzaPref "A" [TestStanzas]] $ + mkTest [Right pkg] name ["A"] $ + solverSuccess [("A", 1)] + -- | Database with some cycles -- -- * Simplest non-trivial cycle: A -> B and B -> A @@ -627,7 +750,7 @@ db14 = [ Right $ exAv "A" 1 [ExAny "B"] , Right $ exAv "B" 1 [ExAny "A"] - , Right $ exAv "C" 1 [exFlag "flagC" [ExAny "D"] [ExAny "E"]] + , Right $ exAv "C" 1 [exFlagged "flagC" [ExAny "D"] [ExAny "E"]] , Right $ exAv "D" 1 [ExAny "C"] , Right $ exAv "E" 1 [] ] @@ -655,6 +778,39 @@ , Right $ exAv "E" 1 [ExFix "C" 2] ] +-- | Packages pkg-A, pkg-B, and pkg-C form a cycle. The solver should backtrack +-- as soon as it chooses the last package in the cycle, to avoid searching parts +-- of the tree that have no solution. Since there is no way to break the cycle, +-- it should fail with an error message describing the cycle. +testCyclicDependencyErrorMessages :: String -> SolverTest +testCyclicDependencyErrorMessages name = + goalOrder goals $ + mkTest db name ["pkg-A"] $ + SolverResult checkFullLog $ Left checkSummarizedLog + where + db :: ExampleDb + db = [ + Right $ exAv "pkg-A" 1 [ExAny "pkg-B"] + , Right $ exAv "pkg-B" 1 [ExAny "pkg-C"] + , Right $ exAv "pkg-C" 1 [ExAny "pkg-A", ExAny "pkg-D"] + , Right $ exAv "pkg-D" 1 [ExAny "pkg-E"] + , Right $ exAv "pkg-E" 1 [] + ] + + -- The solver should backtrack as soon as pkg-A, pkg-B, and pkg-C form a + -- cycle. It shouldn't try pkg-D or pkg-E. + checkFullLog :: [String] -> Bool + checkFullLog = + not . any (\l -> "pkg-D" `isInfixOf` l || "pkg-E" `isInfixOf` l) + + checkSummarizedLog :: String -> Bool + checkSummarizedLog = + isInfixOf "rejecting: pkg-C-1.0.0 (cyclic dependencies; conflict set: pkg-A, pkg-B, pkg-C)" + + -- Solve for pkg-D and pkg-E last. + goals :: [ExampleVar] + goals = [P QualNone ("pkg-" ++ [c]) | c <- ['A'..'E']] + -- | Check that the solver can backtrack after encountering the SIR (issue #2843) -- -- When A and B are installed as independent goals, the single instance @@ -676,9 +832,9 @@ db16 = [ Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1] , Right $ exAv "B" 1 [ ExFix "D" 2 - , exFlag "flagA" + , exFlagged "flagA" [ExAny "C"] - [exFlag "flagB" + [exFlagged "flagB" [ExAny "E"] [ExAny "C"]]] , Right $ exAv "C" 1 [ExAny "D"] @@ -698,7 +854,7 @@ -- solver must backtrack to try D-1 for both 0.D and 1.D. testIndepGoals2 :: String -> SolverTest testIndepGoals2 name = - goalOrder goals $ indep $ + goalOrder goals $ independentGoals $ enableAllTests $ mkTest db name ["A", "B"] $ solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)] where @@ -713,14 +869,14 @@ goals :: [ExampleVar] goals = [ - P (Indep 0) "A" - , P (Indep 0) "C" - , P (Indep 0) "D" - , P (Indep 1) "B" - , P (Indep 1) "C" - , P (Indep 1) "D" - , S (Indep 1) "B" TestStanzas - , S (Indep 0) "A" TestStanzas + P (QualIndep "A") "A" + , P (QualIndep "A") "C" + , P (QualIndep "A") "D" + , P (QualIndep "B") "B" + , P (QualIndep "B") "C" + , P (QualIndep "B") "D" + , S (QualIndep "B") "B" TestStanzas + , S (QualIndep "A") "A" TestStanzas ] -- | Issue #2834 @@ -743,9 +899,9 @@ db18 = [ Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1] , Right $ exAv "B" 1 [ExAny "C", ExFix "D" 2] - , Right $ exAv "C" 1 [exFlag "flagA" + , Right $ exAv "C" 1 [exFlagged "flagA" [ExFix "D" 1, ExAny "E"] - [exFlag "flagB" + [exFlagged "flagB" [ExAny "F"] [ExFix "D" 2, ExAny "G"]]] , Right $ exAv "D" 1 [] @@ -781,7 +937,7 @@ -- > D F E testIndepGoals3 :: String -> SolverTest testIndepGoals3 name = - goalOrder goals $ indep $ + goalOrder goals $ independentGoals $ mkTest db name ["D", "E", "F"] anySolverFailure where db :: ExampleDb @@ -797,16 +953,16 @@ goals :: [ExampleVar] goals = [ - P (Indep 0) "D" - , P (Indep 0) "C" - , P (Indep 0) "A" - , P (Indep 1) "E" - , P (Indep 1) "C" - , P (Indep 1) "B" - , P (Indep 2) "F" - , P (Indep 2) "B" - , P (Indep 2) "C" - , P (Indep 2) "A" + P (QualIndep "D") "D" + , P (QualIndep "D") "C" + , P (QualIndep "D") "A" + , P (QualIndep "E") "E" + , P (QualIndep "E") "C" + , P (QualIndep "E") "B" + , P (QualIndep "F") "F" + , P (QualIndep "F") "B" + , P (QualIndep "F") "C" + , P (QualIndep "F") "A" ] -- | This test checks that the solver correctly backjumps when dependencies @@ -823,7 +979,7 @@ -- changed. testIndepGoals4 :: String -> SolverTest testIndepGoals4 name = - goalOrder goals $ indep $ + goalOrder goals $ independentGoals $ enableAllTests $ mkTest db name ["A", "B", "C"] $ solverSuccess [("A",1), ("B",1), ("C",1), ("D",1), ("E",1), ("E",2)] where @@ -839,15 +995,15 @@ goals :: [ExampleVar] goals = [ - P (Indep 0) "A" - , P (Indep 0) "E" - , P (Indep 1) "B" - , P (Indep 1) "D" - , P (Indep 1) "E" - , P (Indep 2) "C" - , P (Indep 2) "D" - , P (Indep 2) "E" - , S (Indep 2) "C" TestStanzas + P (QualIndep "A") "A" + , P (QualIndep "A") "E" + , P (QualIndep "B") "B" + , P (QualIndep "B") "D" + , P (QualIndep "B") "E" + , P (QualIndep "C") "C" + , P (QualIndep "C") "D" + , P (QualIndep "C") "E" + , S (QualIndep "C") "C" TestStanzas ] -- | Test the trace messages that we get when a package refers to an unknown pkg @@ -899,7 +1055,7 @@ DefaultGoalOrder -> test where test :: SolverTest - test = indep $ mkTest db name ["X", "Y"] $ + test = independentGoals $ mkTest db name ["X", "Y"] $ solverSuccess [("A", 1), ("A", 2), ("B", 1), ("C", 1), ("C", 2), ("X", 1), ("Y", 1)] @@ -916,14 +1072,14 @@ goals :: [ExampleVar] goals = [ - P (Indep 0) "X" - , P (Indep 0) "A" - , P (Indep 0) "B" - , P (Indep 0) "C" - , P (Indep 1) "Y" - , P (Indep 1) "A" - , P (Indep 1) "B" - , P (Indep 1) "C" + P (QualIndep "X") "X" + , P (QualIndep "X") "A" + , P (QualIndep "X") "B" + , P (QualIndep "X") "C" + , P (QualIndep "Y") "Y" + , P (QualIndep "Y") "A" + , P (QualIndep "Y") "B" + , P (QualIndep "Y") "C" ] -- | A simplified version of 'testIndepGoals5'. @@ -934,7 +1090,7 @@ DefaultGoalOrder -> test where test :: SolverTest - test = indep $ mkTest db name ["X", "Y"] $ + test = independentGoals $ mkTest db name ["X", "Y"] $ solverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("X", 1), ("Y", 1)] @@ -950,12 +1106,12 @@ goals :: [ExampleVar] goals = [ - P (Indep 0) "X" - , P (Indep 0) "A" - , P (Indep 0) "B" - , P (Indep 1) "Y" - , P (Indep 1) "A" - , P (Indep 1) "B" + P (QualIndep "X") "X" + , P (QualIndep "X") "A" + , P (QualIndep "X") "B" + , P (QualIndep "Y") "Y" + , P (QualIndep "Y") "A" + , P (QualIndep "Y") "B" ] dbExts1 :: ExampleDb @@ -984,12 +1140,12 @@ where expected = solverSuccess [("false-dep", 1), ("pkg", 1)] db = [ - Right $ exAv "pkg" 1 [exFlag "enable-exe" + Right $ exAv "pkg" 1 [exFlagged "enable-exe" [ExAny "true-dep"] [ExAny "false-dep"]] `withExe` ExExe "exe" [ unavailableDep - , ExFlag "enable-exe" (Buildable []) NotBuildable ] + , ExFlagged "enable-exe" (Buildable []) NotBuildable ] , Right $ exAv "true-dep" 1 [] , Right $ exAv "false-dep" 1 [] ] @@ -999,18 +1155,18 @@ dbBuildable1 :: ExampleDb dbBuildable1 = [ Right $ exAv "pkg" 1 - [ exFlag "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"] - , exFlag "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]] + [ exFlagged "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"] + , exFlagged "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]] `withExes` [ ExExe "exe1" [ ExAny "unknown" - , ExFlag "flag1" (Buildable []) NotBuildable - , ExFlag "flag2" (Buildable []) NotBuildable] + , ExFlagged "flag1" (Buildable []) NotBuildable + , ExFlagged "flag2" (Buildable []) NotBuildable] , ExExe "exe2" [ ExAny "unknown" - , ExFlag "flag1" + , ExFlagged "flag1" (Buildable []) - (Buildable [ExFlag "flag2" NotBuildable (Buildable [])])] + (Buildable [ExFlagged "flag2" NotBuildable (Buildable [])])] ] , Right $ exAv "flag1-true" 1 [] , Right $ exAv "flag1-false" 1 [] @@ -1027,7 +1183,7 @@ `withExe` ExExe "exe" [ ExAny "unknown" - , ExFlag "disable-exe" NotBuildable (Buildable []) + , ExFlagged "disable-exe" NotBuildable (Buildable []) ] , Right $ exAv "B" 3 [ExAny "unknown"] ] @@ -1105,7 +1261,7 @@ -- bug report (#3409) dbBJ5 :: ExampleDb dbBJ5 = [ - Right $ exAv "A" 1 [exFlag "flagA" [ExFix "B" 1] [ExFix "C" 1]] + Right $ exAv "A" 1 [exFlagged "flagA" [ExFix "B" 1] [ExFix "C" 1]] , Right $ exAv "B" 1 [ExFix "D" 1] , Right $ exAv "C" 1 [ExFix "D" 2] , Right $ exAv "D" 1 [] @@ -1138,52 +1294,155 @@ ] {------------------------------------------------------------------------------- - Databases for build-tools + Databases for build-tool-depends -------------------------------------------------------------------------------} -dbBuildTools1 :: ExampleDb -dbBuildTools1 = [ - Right $ exAv "alex" 1 [], - Right $ exAv "A" 1 [ExBuildToolAny "alex"] + +-- | Multiple packages depending on exes from 'bt-pkg'. +dbBuildTools :: ExampleDb +dbBuildTools = [ + Right $ exAv "A" 1 [ExBuildToolAny "bt-pkg" "exe1"] + , Right $ exAv "B" 1 [exFlagged "flagB" [ExAny "unknown"] + [ExBuildToolAny "bt-pkg" "exe1"]] + , Right $ exAv "C" 1 [] `withTest` ExTest "testC" [ExBuildToolAny "bt-pkg" "exe1"] + , Right $ exAv "D" 1 [ExBuildToolAny "bt-pkg" "unknown-exe"] + , Right $ exAv "E" 1 [ExBuildToolAny "unknown-pkg" "exe1"] + , Right $ exAv "F" 1 [exFlagged "flagF" [ExBuildToolAny "bt-pkg" "unknown-exe"] + [ExAny "unknown"]] + , Right $ exAv "G" 1 [] `withTest` ExTest "testG" [ExBuildToolAny "bt-pkg" "unknown-exe"] + , Right $ exAv "H" 1 [ExBuildToolFix "bt-pkg" "exe1" 3] + + , Right $ exAv "bt-pkg" 4 [] + , Right $ exAv "bt-pkg" 3 [] `withExe` ExExe "exe2" [] + , Right $ exAv "bt-pkg" 2 [] `withExe` ExExe "exe1" [] + , Right $ exAv "bt-pkg" 1 [] ] +-- The solver should never choose an installed package for a build tool +-- dependency. +rejectInstalledBuildToolPackage :: String -> SolverTest +rejectInstalledBuildToolPackage name = + mkTest db name ["A"] $ solverFailure $ isInfixOf $ + "rejecting: A:B:exe.B-1.0.0/installed-1 " + ++ "(does not contain executable exe, which is required by A)" + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [ExBuildToolAny "B" "exe"] + , Left $ exInst "B" 1 "B-1" [] + ] + +-- | This test forces the solver to choose B as a build-tool dependency before +-- it sees the dependency on executable exe2 from B. The solver needs to check +-- that the version that it already chose for B contains the necessary +-- executable. This order causes a different "missing executable" error message +-- than when the solver checks for the executable in the same step that it +-- chooses the build-tool package. +-- +-- This case may become impossible if we ever add the executable name to the +-- build-tool goal qualifier. Then this test would involve two qualified goals +-- for B, one for exe1 and another for exe2. +chooseExeAfterBuildToolsPackage :: Bool -> String -> SolverTest +chooseExeAfterBuildToolsPackage shouldSucceed name = + goalOrder goals $ mkTest db name ["A"] $ + if shouldSucceed + then solverSuccess [("A", 1), ("B", 1)] + else solverFailure $ isInfixOf $ + "rejecting: A:+flagA (requires executable exe2 from A:B:exe.B, " + ++ "but the executable does not exist)" + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [ ExBuildToolAny "B" "exe1" + , exFlagged "flagA" [ExBuildToolAny "B" "exe2"] + [ExAny "unknown"]] + , Right $ exAv "B" 1 [] + `withExes` + [ExExe exe [] | exe <- if shouldSucceed then ["exe1", "exe2"] else ["exe1"]] + ] + + goals :: [ExampleVar] + goals = [ + P QualNone "A" + , P (QualExe "A" "B") "B" + , F QualNone "A" "flag" + ] + +-- | Test that when one package depends on two executables from another package, +-- both executables must come from the same instance of that package. We could +-- lift this restriction in the future by adding the executable name to the goal +-- qualifier. +requireConsistentBuildToolVersions :: String -> SolverTest +requireConsistentBuildToolVersions name = + mkTest db name ["A"] $ solverFailure $ isInfixOf $ + "rejecting: A:B:exe.B-2.0.0 (conflict: A => A:B:exe.B (exe exe1)==1.0.0)\n" + ++ "rejecting: A:B:exe.B-1.0.0 (conflict: A => A:B:exe.B (exe exe2)==2.0.0)" + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [ ExBuildToolFix "B" "exe1" 1 + , ExBuildToolFix "B" "exe2" 2 ] + , Right $ exAv "B" 2 [] `withExes` exes + , Right $ exAv "B" 1 [] `withExes` exes + ] + + exes = [ExExe "exe1" [], ExExe "exe2" []] + +{------------------------------------------------------------------------------- + Databases for legacy build-tools +-------------------------------------------------------------------------------} +dbLegacyBuildTools1 :: ExampleDb +dbLegacyBuildTools1 = [ + Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [], + Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"] + ] + +-- Test that a recognized build tool dependency specifies the name of both the +-- package and the executable. This db has no solution. +dbLegacyBuildTools2 :: ExampleDb +dbLegacyBuildTools2 = [ + Right $ exAv "alex" 1 [] `withExe` ExExe "other-exe" [], + Right $ exAv "other-package" 1 [] `withExe` ExExe "alex" [], + Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"] + ] + -- Test that build-tools on a random thing doesn't matter (only -- the ones we recognize need to be in db) -dbBuildTools2 :: ExampleDb -dbBuildTools2 = [ - Right $ exAv "A" 1 [ExBuildToolAny "otherdude"] +dbLegacyBuildTools3 :: ExampleDb +dbLegacyBuildTools3 = [ + Right $ exAv "A" 1 [ExLegacyBuildToolAny "otherdude"] ] -- Test that we can solve for different versions of executables -dbBuildTools3 :: ExampleDb -dbBuildTools3 = [ - Right $ exAv "alex" 1 [], - Right $ exAv "alex" 2 [], - Right $ exAv "A" 1 [ExBuildToolFix "alex" 1], - Right $ exAv "B" 1 [ExBuildToolFix "alex" 2], +dbLegacyBuildTools4 :: ExampleDb +dbLegacyBuildTools4 = [ + Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [], + Right $ exAv "alex" 2 [] `withExe` ExExe "alex" [], + Right $ exAv "A" 1 [ExLegacyBuildToolFix "alex" 1], + Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 2], Right $ exAv "C" 1 [ExAny "A", ExAny "B"] ] -- Test that exe is not related to library choices -dbBuildTools4 :: ExampleDb -dbBuildTools4 = [ - Right $ exAv "alex" 1 [ExFix "A" 1], +dbLegacyBuildTools5 :: ExampleDb +dbLegacyBuildTools5 = [ + Right $ exAv "alex" 1 [ExFix "A" 1] `withExe` ExExe "alex" [], Right $ exAv "A" 1 [], Right $ exAv "A" 2 [], - Right $ exAv "B" 1 [ExBuildToolFix "alex" 1, ExFix "A" 2] + Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 1, ExFix "A" 2] ] -- Test that build-tools on build-tools works -dbBuildTools5 :: ExampleDb -dbBuildTools5 = [ - Right $ exAv "alex" 1 [], - Right $ exAv "happy" 1 [ExBuildToolAny "alex"], - Right $ exAv "A" 1 [ExBuildToolAny "happy"] +dbLegacyBuildTools6 :: ExampleDb +dbLegacyBuildTools6 = [ + Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [], + Right $ exAv "happy" 1 [ExLegacyBuildToolAny "alex"] `withExe` ExExe "happy" [], + Right $ exAv "A" 1 [ExLegacyBuildToolAny "happy"] ] -- Test that build-depends on library/executable package works. -- Extracted from https://github.com/haskell/cabal/issues/3775 -dbBuildTools6 :: ExampleDb -dbBuildTools6 = [ +dbIssue3775 :: ExampleDb +dbIssue3775 = [ Right $ exAv "warp" 1 [], -- NB: the warp build-depends refers to the package, not the internal -- executable! diff --git a/cabal/cabal-testsuite/.gitignore b/cabal/cabal-testsuite/.gitignore new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/.gitignore @@ -0,0 +1,2 @@ +*.dist +Setup diff --git a/cabal/cabal-testsuite/LICENSE b/cabal/cabal-testsuite/LICENSE --- a/cabal/cabal-testsuite/LICENSE +++ b/cabal/cabal-testsuite/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2016, Cabal Development Team. +Copyright (c) 2003-2017, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. All rights reserved. diff --git a/cabal/cabal-testsuite/PackageTests.hs b/cabal/cabal-testsuite/PackageTests.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests.hs +++ /dev/null @@ -1,329 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PatternGuards #-} - --- This is the runner for the package-tests suite. The actual --- tests are in in PackageTests.Tests - -module Main where - -import PackageTests.Options -import PackageTests.PackageTester -import PackageTests.Tests - -import Distribution.Simple.Configure - ( ConfigStateFileError(..), findDistPrefOrDefault, getConfigStateFile - , interpretPackageDbFlags, configCompilerEx ) -import Distribution.Simple.Compiler (PackageDB(..), PackageDBStack - ,CompilerFlavor(GHC)) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) -import Distribution.Simple.Program (defaultProgramDb) -import Distribution.Simple.Setup (Flag(..), readPackageDbList, showPackageDbList) -import Distribution.Simple.Utils (cabalVersion) -import Distribution.Text (display) -import Distribution.Verbosity (normal, flagToVerbosity, lessVerbose) -import Distribution.ReadE (readEOrFail) -import Distribution.Compat.Time (calibrateMtimeChangeDelay) - -import Control.Exception -import Data.Proxy ( Proxy(..) ) -import Distribution.Compat.Environment ( lookupEnv ) -import System.Directory -import Test.Tasty -import Test.Tasty.Options -import Test.Tasty.Ingredients - -#if MIN_VERSION_base(4,6,0) -import System.Environment ( getExecutablePath ) -#endif - -main :: IO () -main = do - -- In abstract, the Cabal test suite makes calls to the "Setup" - -- executable and tests the output of Cabal. However, we have to - -- responsible for building this executable in the first place, - -- since (1) Cabal doesn't support a test-suite depending on an - -- executable, so we can't put a "Setup" executable in the Cabal - -- file and then depend on it, (2) we don't want to call the Cabal - -- functions *directly* because we need to capture and save the - -- stdout and stderr, and (3) even if we could do all that, we will - -- want to test some Custom setup scripts, which will be specific to - -- the test at hand and need to be compiled against Cabal. - -- - -- To be able to build the executable, there is some information - -- we need: - -- - -- 1. We need to know what ghc to use, - -- - -- 2. We need to know what package databases (plural!) contain - -- all of the necessary dependencies to make our Cabal package - -- well-formed. - -- - -- We could have the user pass these all in as arguments, but - -- there's a more convenient way to get this information: the *build - -- configuration* that was used to build the Cabal library (and this - -- test suite) in the first place. To do this, we need to find the - -- 'dist' directory that was set as the build directory for Cabal. - - -- First, figure out the dist directory associated with this Cabal. - dist_dir :: FilePath <- guessDistDir - - -- Next, attempt to read out the LBI. This may not work, in which - -- case we'll try to guess the correct parameters. This is ignored - -- if values are explicitly passed into the test suite. - mb_lbi <- getPersistBuildConfig_ (dist_dir "setup-config") - - -- You need to run the test suite in the right directory, sorry. - -- This variable is modestly misnamed: this refers to the base - -- directory of Cabal (so, CHECKOUT_DIR/Cabal, not - -- CHECKOUT_DIR/Cabal/test). - cabal_dir <- getCurrentDirectory - - -- TODO: make this controllable by a flag. We do have a flag - -- parser but it's not called early enough for this verbosity... - verbosity <- maybe normal (readEOrFail flagToVerbosity) - `fmap` lookupEnv "VERBOSE" - - ------------------------------------------------------------------- - -- SETTING UP GHC AND GHC-PKG - ------------------------------------------------------------------- - - -- NOTE: There are TWO configurations of GHC we have to manage - -- when running the test suite. - -- - -- 1. The primary GHC is the one that was used to build the - -- copy of Cabal that we are testing. This configuration - -- can be pulled out of the LBI. - -- - -- 2. The "with" GHC is the version of GHC we ask the Cabal - -- we are testing to use (i.e., using --with-compiler). Notice - -- that this does NOT have to match the version we compiled - -- the library with! (Not all tests will work in this situation, - -- however, since some need to link against the Cabal library.) - -- By default we use the same configuration as the one from the - -- LBI, but a user can override it to test against a different - -- version of GHC. - mb_ghc_path <- lookupEnv "CABAL_PACKAGETESTS_GHC" - mb_ghc_pkg_path <- lookupEnv "CABAL_PACKAGETESTS_GHC_PKG" - boot_programs <- - case (mb_ghc_path, mb_ghc_pkg_path) of - (Nothing, Nothing) | Just lbi <- mb_lbi -> do - putStrLn "Using configuration from LBI" - return (withPrograms lbi) - _ -> do - putStrLn "(Re)configuring test suite (ignoring LBI)" - (_comp, _compPlatform, programDb) - <- configCompilerEx - (Just GHC) mb_ghc_path mb_ghc_pkg_path - -- NB: if we accept full ConfigFlags parser then - -- should use (mkProgramDb cfg (configPrograms cfg)) - -- instead. - defaultProgramDb - (lessVerbose verbosity) - return programDb - - mb_with_ghc_path <- lookupEnv "CABAL_PACKAGETESTS_WITH_GHC" - mb_with_ghc_pkg_path <- lookupEnv "CABAL_PACKAGETESTS_WITH_GHC_PKG" - with_programs <- - case (mb_with_ghc_path, mb_with_ghc_path) of - (Nothing, Nothing) -> return boot_programs - _ -> do - putStrLn "Configuring test suite for --with-compiler" - (_comp, _compPlatform, with_programs) - <- configCompilerEx - (Just GHC) mb_with_ghc_path mb_with_ghc_pkg_path - defaultProgramDb - (lessVerbose verbosity) - return with_programs - - -- TODO: maybe have to configure gcc? - - ------------------------------------------------------------------- - -- SETTING UP THE DATABASE STACK - ------------------------------------------------------------------- - - -- Figure out what database stack to use. (This is the tricky bit, - -- because we need to have enough databases to make the just-built - -- Cabal package well-formed). - db_stack_env <- lookupEnv "CABAL_PACKAGETESTS_DB_STACK" - let packageDBStack0 = case db_stack_env of - Just str -> interpretPackageDbFlags True -- user install? why not. - (concatMap readPackageDbList - (splitSearchPath str)) - Nothing -> - case mb_lbi of - Just lbi -> withPackageDB lbi - -- A wild guess! - Nothing -> interpretPackageDbFlags True [] - - -- Package DBs are not guaranteed to be absolute, so make them so in - -- case a subprocess using the package DB needs a different CWD. - packageDBStack1 <- mapM canonicalizePackageDB packageDBStack0 - - -- The LBI's database stack does *not* contain the inplace installed - -- Cabal package. So we need to add that to the stack. - let package_db_stack - = packageDBStack1 ++ - [SpecificPackageDB - (dist_dir "package.conf.inplace")] - - -- NB: It's possible that our database stack is broken (e.g., - -- it's got a database for the wrong version of GHC, or it - -- doesn't have enough to let us build Cabal.) We'll notice - -- when we attempt to compile setup. - - -- There is also is a parameter for the stack for --with-compiler, - -- since if GHC is a different version we need a different set of - -- databases. The default should actually be quite reasonable - -- as, unlike in the case of the GHC used to build Cabal, we don't - -- expect htere to be a Cabal available. - with_ghc_db_stack_env :: Maybe String - <- lookupEnv "CABAL_PACKAGETESTS_WITH_DB_STACK" - let withGhcDBStack0 :: PackageDBStack - withGhcDBStack0 = - interpretPackageDbFlags True - $ case with_ghc_db_stack_env of - Nothing -> [] - Just str -> concatMap readPackageDbList (splitSearchPath str) - with_ghc_db_stack :: PackageDBStack - <- mapM canonicalizePackageDB withGhcDBStack0 - - -- THIS ISN'T EVEN MY FINAL FORM. The package database stack - -- controls where we install a package; specifically, the package is - -- installed to the top-most package on the stack (this makes the - -- most sense, since it could depend on any of the packages below - -- it.) If the test wants to register anything (as opposed to just - -- working in place), then we need to have another temporary - -- database we can install into (and not accidentally clobber any of - -- the other stacks.) This is done on a per-test basis. - -- - -- ONE MORE THING. On the subject of installing the package (with - -- copy/register) it is EXTREMELY important that we also overload - -- the install directories, so we don't clobber anything in the - -- default install paths. VERY IMPORTANT. - - -- Figure out how long we need to delay for recompilation tests - (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay - - let suite = SuiteConfig - { cabalDistPref = dist_dir - , bootProgramDb = boot_programs - , withProgramDb = with_programs - , packageDBStack = package_db_stack - , withGhcDBStack = with_ghc_db_stack - , suiteVerbosity = verbosity - , absoluteCWD = cabal_dir - , mtimeChangeDelay = mtimeChange' - } - - let toMillis :: Int -> Double - toMillis x = fromIntegral x / 1000.0 - - putStrLn $ "Cabal test suite - testing cabal version " - ++ display cabalVersion - putStrLn $ "Cabal build directory: " ++ dist_dir - putStrLn $ "Cabal source directory: " ++ cabal_dir - putStrLn $ "File modtime calibration: " ++ show (toMillis mtimeChange') - ++ " (maximum observed: " ++ show (toMillis mtimeChange) ++ ")" - -- TODO: it might be useful to factor this out so that ./Setup - -- configure dumps this file, so we can read it without in a version - -- stable way. - putStrLn $ "Environment:" - putStrLn $ "CABAL_PACKAGETESTS_GHC=" ++ show (ghcPath suite) ++ " \\" - putStrLn $ "CABAL_PACKAGETESTS_GHC_PKG=" ++ show (ghcPkgPath suite) ++ " \\" - putStrLn $ "CABAL_PACKAGETESTS_WITH_GHC=" ++ show (withGhcPath suite) ++ " \\" - putStrLn $ "CABAL_PACKAGETESTS_WITH_GHC_PKG=" ++ show (withGhcPkgPath suite) ++ " \\" - -- For brevity, we use the pre-canonicalized values - let showDBStack = show - . intercalate [searchPathSeparator] - . showPackageDbList - . uninterpretPackageDBFlags - putStrLn $ "CABAL_PACKAGETESTS_DB_STACK=" ++ showDBStack packageDBStack0 - putStrLn $ "CABAL_PACKAGETESTS_WITH_DB_STACK=" ++ showDBStack withGhcDBStack0 - - -- Create a shared Setup executable to speed up Simple tests - putStrLn $ "Building shared ./Setup executable" - rawCompileSetup verbosity suite [] "." - - defaultMainWithIngredients options $ - runTestTree "Package Tests" (tests suite) - --- Reverse of 'interpretPackageDbFlags'. --- prop_idem stk b --- = interpretPackageDbFlags b (uninterpretPackageDBFlags stk) == stk -uninterpretPackageDBFlags :: PackageDBStack -> [Maybe PackageDB] -uninterpretPackageDBFlags stk = Nothing : map (\x -> Just x) stk - --- | Guess what the 'dist' directory Cabal was installed in is. There's --- no 100% reliable way to find this, but there are a few good shots: --- --- 1. Test programs are ~always built in-place, in a directory --- that looks like dist/build/package-tests/package-tests; --- thus the directory can be determined by looking at $0. --- This method is robust against sandboxes, Nix local --- builds, and Stack, but doesn't work if you're running --- in an interpreter. --- --- 2. We can use the normal input methods (as per Cabal), --- checking for the CABAL_BUILDDIR environment variable as --- well as the default location in the current working directory. --- --- NB: If you update this, also update its copy in cabal-install's --- IntegrationTests -guessDistDir :: IO FilePath -guessDistDir = do -#if MIN_VERSION_base(4,6,0) - -- Method (1) - -- TODO: this needs to be BC'ified, probably. - exe_path <- canonicalizePath =<< getExecutablePath - -- exe_path is something like /path/to/dist/build/package-tests/package-tests - let dist0 = dropFileName exe_path ".." ".." - b <- doesFileExist (dist0 "setup-config") -#else - let dist0 = error "no path" - b = False -#endif - -- Method (2) - if b then canonicalizePath dist0 - else findDistPrefOrDefault NoFlag >>= canonicalizePath - -canonicalizePackageDB :: PackageDB -> IO PackageDB -canonicalizePackageDB (SpecificPackageDB path) - = SpecificPackageDB `fmap` canonicalizePath path -canonicalizePackageDB x = return x - --- | Like Distribution.Simple.Configure.getPersistBuildConfig but --- doesn't check that the Cabal version matches, which it doesn't when --- we run Cabal's own test suite, due to bootstrapping issues. --- Here's the situation: --- --- 1. There's some system Cabal-1.0 installed. We use this --- to build Setup.hs --- 2. We run ./Setup configure, which uses Cabal-1.0 to --- write out the LocalBuildInfo --- 3. We build the Cabal library, whose version is Cabal-2.0 --- 4. We build the package-tests executable, which LINKS AGAINST --- Cabal-2.0 --- 5. We try to read the LocalBuildInfo that ./Setup configure --- wrote out, but it's Cabal-1.0 format! --- --- It's a bit skeevy that we're trying to read Cabal-1.0 LocalBuildInfo --- using Cabal-2.0's parser, but this seems to work OK in practice --- because LocalBuildInfo is a slow-moving data structure. If --- we ever make a major change, this won't work, and we'll have to --- take a different approach (either setting "build-type: Custom" --- so we bootstrap with the most recent Cabal, or by writing the --- information we need in another format.) -getPersistBuildConfig_ :: FilePath -> IO (Maybe LocalBuildInfo) -getPersistBuildConfig_ filename = do - eLBI <- try $ getConfigStateFile filename - case eLBI of - -- If the version doesn't match but we still got a successful - -- parse, don't complain and just use it! - Left (ConfigStateFileBadVersion _ _ (Right lbi)) -> return (Just lbi) - Left _ -> return Nothing - Right lbi -> return (Just lbi) - -options :: [Ingredient] -options = includingOptions - [Option (Proxy :: Proxy OptionEnableAllTests)] : - defaultIngredients diff --git a/cabal/cabal-testsuite/PackageTests/.gitignore b/cabal/cabal-testsuite/PackageTests/.gitignore deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -test-log.txt -Setup -/TestSuiteExeV10/dist-* -tmp.package.conf diff --git a/cabal/cabal-testsuite/PackageTests/AllowNewer/AllowNewer.cabal b/cabal/cabal-testsuite/PackageTests/AllowNewer/AllowNewer.cabal --- a/cabal/cabal-testsuite/PackageTests/AllowNewer/AllowNewer.cabal +++ b/cabal/cabal-testsuite/PackageTests/AllowNewer/AllowNewer.cabal @@ -17,9 +17,11 @@ main-is: Test.hs hs-source-dirs: tests build-depends: base < 1 + default-language: Haskell2010 benchmark foo-bench type: exitcode-stdio-1.0 main-is: Bench.hs hs-source-dirs: benchmarks build-depends: base < 1 + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/AllowNewer/Setup.hs b/cabal/cabal-testsuite/PackageTests/AllowNewer/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/AllowNewer/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/AllowNewer/cabal.project b/cabal/cabal-testsuite/PackageTests/AllowNewer/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/AllowNewer/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/AllowNewer/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/AllowNewer/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/AllowNewer/cabal.test.hs @@ -0,0 +1,28 @@ +import Test.Cabal.Prelude hiding (cabal) +import qualified Test.Cabal.Prelude as P +-- See #4332, dep solving output is not deterministic +main = cabalTest . recordMode DoNotRecord $ do + fails $ cabal "new-build" [] + cabal "new-build" ["--allow-newer"] + fails $ cabal "new-build" ["--allow-newer=baz,quux"] + cabal "new-build" ["--allow-newer=base", "--allow-newer=baz,quux"] + cabal "new-build" ["--allow-newer=bar", "--allow-newer=base,baz" + ,"--allow-newer=quux"] + fails $ cabal "new-build" ["--enable-tests"] + cabal "new-build" ["--enable-tests", "--allow-newer"] + fails $ cabal "new-build" ["--enable-benchmarks"] + cabal "new-build" ["--enable-benchmarks", "--allow-newer"] + fails $ cabal "new-build" ["--enable-benchmarks", "--enable-tests"] + cabal "new-build" ["--enable-benchmarks", "--enable-tests" + ,"--allow-newer"] + fails $ cabal "new-build" ["--allow-newer=Foo:base"] + fails $ cabal "new-build" ["--allow-newer=Foo:base" + ,"--enable-tests", "--enable-benchmarks"] + cabal "new-build" ["--allow-newer=AllowNewer:base"] + cabal "new-build" ["--allow-newer=AllowNewer:base" + ,"--allow-newer=Foo:base"] + cabal "new-build" ["--allow-newer=AllowNewer:base" + ,"--allow-newer=Foo:base" + ,"--enable-tests", "--enable-benchmarks"] + where + cabal cmd args = P.cabal cmd ("--dry-run" : args) diff --git a/cabal/cabal-testsuite/PackageTests/AllowNewer/src/Foo.hs b/cabal/cabal-testsuite/PackageTests/AllowNewer/src/Foo.hs --- a/cabal/cabal-testsuite/PackageTests/AllowNewer/src/Foo.hs +++ b/cabal/cabal-testsuite/PackageTests/AllowNewer/src/Foo.hs @@ -1,4 +1,1 @@ -module Main where - -main :: IO () -main = return () +module Foo where diff --git a/cabal/cabal-testsuite/PackageTests/AllowOlder/AllowOlder.cabal b/cabal/cabal-testsuite/PackageTests/AllowOlder/AllowOlder.cabal --- a/cabal/cabal-testsuite/PackageTests/AllowOlder/AllowOlder.cabal +++ b/cabal/cabal-testsuite/PackageTests/AllowOlder/AllowOlder.cabal @@ -17,9 +17,11 @@ main-is: Test.hs hs-source-dirs: tests build-depends: base > 42 + default-language: Haskell2010 benchmark foo-bench type: exitcode-stdio-1.0 main-is: Bench.hs hs-source-dirs: benchmarks build-depends: base > 42 + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/AllowOlder/Setup.hs b/cabal/cabal-testsuite/PackageTests/AllowOlder/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/AllowOlder/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/AllowOlder/cabal.project b/cabal/cabal-testsuite/PackageTests/AllowOlder/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/AllowOlder/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/AllowOlder/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/AllowOlder/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/AllowOlder/cabal.test.hs @@ -0,0 +1,28 @@ +import Test.Cabal.Prelude hiding (cabal) +import qualified Test.Cabal.Prelude as P +-- See #4332, dep solving output is not deterministic +main = cabalTest . recordMode DoNotRecord $ do + fails $ cabal "new-build" [] + cabal "new-build" ["--allow-older"] + fails $ cabal "new-build" ["--allow-older=baz,quux"] + cabal "new-build" ["--allow-older=base", "--allow-older=baz,quux"] + cabal "new-build" ["--allow-older=bar", "--allow-older=base,baz" + ,"--allow-older=quux"] + fails $ cabal "new-build" ["--enable-tests"] + cabal "new-build" ["--enable-tests", "--allow-older"] + fails $ cabal "new-build" ["--enable-benchmarks"] + cabal "new-build" ["--enable-benchmarks", "--allow-older"] + fails $ cabal "new-build" ["--enable-benchmarks", "--enable-tests"] + cabal "new-build" ["--enable-benchmarks", "--enable-tests" + ,"--allow-older"] + fails $ cabal "new-build" ["--allow-older=Foo:base"] + fails $ cabal "new-build" ["--allow-older=Foo:base" + ,"--enable-tests", "--enable-benchmarks"] + cabal "new-build" ["--allow-older=AllowOlder:base"] + cabal "new-build" ["--allow-older=AllowOlder:base" + ,"--allow-older=Foo:base"] + cabal "new-build" ["--allow-older=AllowOlder:base" + ,"--allow-older=Foo:base" + ,"--enable-tests", "--enable-benchmarks"] + where + cabal cmd args = P.cabal cmd ("--dry-run" : args) diff --git a/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-package-import.cabal.out b/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-package-import.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-package-import.cabal.out @@ -0,0 +1,28 @@ +# Setup configure +Resolving dependencies... +Configuring p-0.1.0.0... +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for p-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring q-0.1.0.0... +# Setup build +Preprocessing library for q-0.1.0.0.. +Building library for q-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for q-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring package-import-0.1.0.0... +# Setup build +Preprocessing executable 'package-import' for package-import-0.1.0.0.. +Building executable 'package-import' for package-import-0.1.0.0.. +# package-import +p q diff --git a/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-package-import.out b/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-package-import.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-package-import.out @@ -0,0 +1,25 @@ +# Setup configure +Configuring p-0.1.0.0... +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for p-0.1.0.0.. +# Setup configure +Configuring q-0.1.0.0... +# Setup build +Preprocessing library for q-0.1.0.0.. +Building library for q-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for q-0.1.0.0.. +# Setup configure +Configuring package-import-0.1.0.0... +# Setup build +Preprocessing executable 'package-import' for package-import-0.1.0.0.. +Building executable 'package-import' for package-import-0.1.0.0.. +# package-import +p q diff --git a/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-package-import.test.hs b/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-package-import.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-package-import.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude +-- Test that module name ambiguity can be resolved using package +-- qualified imports. (Paper Backpack doesn't natively support +-- this but we must!) +main = setupAndCabalTest $ do + withPackageDb $ do + withDirectory "p" $ setup_install [] + withDirectory "q" $ setup_install [] + withDirectory "package-import" $ do + setup_build [] + runExe' "package-import" [] >>= assertOutputContains "p q" diff --git a/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.cabal.out b/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.cabal.out @@ -0,0 +1,38 @@ +# Setup configure +Resolving dependencies... +Configuring p-0.1.0.0... +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for p-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring q-0.1.0.0... +# Setup build +Preprocessing library for q-0.1.0.0.. +Building library for q-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for q-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring reexport-0.1.0.0... +# Setup build +Preprocessing library for reexport-0.1.0.0.. +Building library for reexport-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for reexport-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring reexport-test-0.1.0.0... +# Setup build +Preprocessing executable 'reexport-test' for reexport-test-0.1.0.0.. +Building executable 'reexport-test' for reexport-test-0.1.0.0.. +# reexport-test +p q diff --git a/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.out b/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.out @@ -0,0 +1,34 @@ +# Setup configure +Configuring p-0.1.0.0... +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for p-0.1.0.0.. +# Setup configure +Configuring q-0.1.0.0... +# Setup build +Preprocessing library for q-0.1.0.0.. +Building library for q-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for q-0.1.0.0.. +# Setup configure +Configuring reexport-0.1.0.0... +# Setup build +Preprocessing library for reexport-0.1.0.0.. +Building library for reexport-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for reexport-0.1.0.0.. +# Setup configure +Configuring reexport-test-0.1.0.0... +# Setup build +Preprocessing executable 'reexport-test' for reexport-test-0.1.0.0.. +Building executable 'reexport-test' for reexport-test-0.1.0.0.. +# reexport-test +p q diff --git a/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.test.hs b/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Ambiguity/setup-reexport.test.hs @@ -0,0 +1,12 @@ +import Test.Cabal.Prelude +-- Test that we can resolve a module name ambiguity when reexporting +-- by explicitly specifying what package we want. +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [7,9]) + withPackageDb $ do + withDirectory "p" $ setup_install [] + withDirectory "q" $ setup_install [] + withDirectory "reexport" $ setup_install [] + withDirectory "reexport-test" $ do + setup_build [] + runExe' "reexport-test" [] >>= assertOutputContains "p q" diff --git a/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/Check.hs b/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/Check.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/Check.hs +++ /dev/null @@ -1,51 +0,0 @@ -module PackageTests.AutogenModules.Package.Check where - -import PackageTests.PackageTester - -suite :: TestM () -suite = do - - configureResult <- shouldFail $ cabal' "configure" [] - sdistResult <- shouldFail $ cabal' "sdist" [] - - -- Package check messages. - let libAutogenMsg = - "An 'autogen-module' is neither on 'exposed-modules' or " - ++ "'other-modules'" - let exeAutogenMsg = - "On executable 'Exe' an 'autogen-module' is not on " - ++ "'other-modules'" - let testAutogenMsg = - "On test suite 'Test' an 'autogen-module' is not on " - ++ "'other-modules'" - let benchAutogenMsg = - "On benchmark 'Bench' an 'autogen-module' is not on " - ++ "'other-modules'" - let pathsAutogenMsg = - "Packages using 'cabal-version: >= 1.25' and the autogenerated" - - -- Asserts for the desired check messages after configure. - assertOutputContains libAutogenMsg configureResult - assertOutputContains exeAutogenMsg configureResult - assertOutputContains testAutogenMsg configureResult - assertOutputContains benchAutogenMsg configureResult - - -- Asserts for the desired check messages after sdist. - assertOutputContains "Distribution quality errors:" sdistResult - assertOutputContains libAutogenMsg sdistResult - assertOutputContains exeAutogenMsg sdistResult - assertOutputContains testAutogenMsg sdistResult - assertOutputContains benchAutogenMsg sdistResult - assertOutputContains pathsAutogenMsg sdistResult - -- Asserts for the undesired check messages after sdist. - assertOutputDoesNotContain "Distribution quality warnings:" sdistResult - - -- Asserts for the error messages of the modules not found. - assertOutputContains - "Error: Could not find module: MyLibHelperModule with any suffix" - sdistResult - assertOutputContains - "module is autogenerated it should be added to 'autogen-modules'" - sdistResult - - return () diff --git a/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.cabal.out @@ -0,0 +1,22 @@ +# Setup configure +Resolving dependencies... +Configuring AutogenModules-0.1... +cabal: An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'. + +On executable 'Exe' an 'autogen-module' is not on 'other-modules' + +On test suite 'Test' an 'autogen-module' is not on 'other-modules' + +On benchmark 'Bench' an 'autogen-module' is not on 'other-modules' +# Setup sdist +Distribution quality errors: +An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'. +On executable 'Exe' an 'autogen-module' is not on 'other-modules' +On test suite 'Test' an 'autogen-module' is not on 'other-modules' +On benchmark 'Bench' an 'autogen-module' is not on 'other-modules' +Packages using 'cabal-version: >= 1.25' and the autogenerated module Paths_* must include it also on the 'autogen-modules' field besides 'exposed-modules' and 'other-modules'. This specifies that the module does not come with the package and is generated on setup. Modules built with a custom Setup.hs script also go here to ensure that commands like sdist don't fail. +The filename ./my.cabal does not match package name (expected: AutogenModules.cabal) +Note: the public hackage server would reject this package. +Warning: Cannot run preprocessors. Run 'configure' command first. +Building source dist for AutogenModules-0.1... +cabal: Error: Could not find module: MyLibHelperModule with any suffix: ["gc","chs","hsc","x","y","ly","cpphs","hs","lhs","hsig","lhsig"]. If the module is autogenerated it should be added to 'autogen-modules'. diff --git a/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.out b/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.out @@ -0,0 +1,21 @@ +# Setup configure +Configuring AutogenModules-0.1... +setup: An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'. + +On executable 'Exe' an 'autogen-module' is not on 'other-modules' + +On test suite 'Test' an 'autogen-module' is not on 'other-modules' + +On benchmark 'Bench' an 'autogen-module' is not on 'other-modules' +# Setup sdist +Distribution quality errors: +An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'. +On executable 'Exe' an 'autogen-module' is not on 'other-modules' +On test suite 'Test' an 'autogen-module' is not on 'other-modules' +On benchmark 'Bench' an 'autogen-module' is not on 'other-modules' +Packages using 'cabal-version: >= 1.25' and the autogenerated module Paths_* must include it also on the 'autogen-modules' field besides 'exposed-modules' and 'other-modules'. This specifies that the module does not come with the package and is generated on setup. Modules built with a custom Setup.hs script also go here to ensure that commands like sdist don't fail. +The filename ./my.cabal does not match package name (expected: AutogenModules.cabal) +Note: the public hackage server would reject this package. +Warning: Cannot run preprocessors. Run 'configure' command first. +Building source dist for AutogenModules-0.1... +setup: Error: Could not find module: MyLibHelperModule with any suffix: ["gc","chs","hsc","x","y","ly","cpphs","hs","lhs","hsig","lhsig"]. If the module is autogenerated it should be added to 'autogen-modules'. diff --git a/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.test.hs b/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/AutogenModules/Package/setup.test.hs @@ -0,0 +1,49 @@ +import Test.Cabal.Prelude + +-- Test that setup shows all the 'autogen-modules' warnings. +main = setupAndCabalTest $ do + + configureResult <- fails $ setup' "configure" [] + sdistResult <- fails $ setup' "sdist" [] + + -- Package check messages. + let libAutogenMsg = + "An 'autogen-module' is neither on 'exposed-modules' or " + ++ "'other-modules'" + let exeAutogenMsg = + "On executable 'Exe' an 'autogen-module' is not on " + ++ "'other-modules'" + let testAutogenMsg = + "On test suite 'Test' an 'autogen-module' is not on " + ++ "'other-modules'" + let benchAutogenMsg = + "On benchmark 'Bench' an 'autogen-module' is not on " + ++ "'other-modules'" + let pathsAutogenMsg = + "Packages using 'cabal-version: >= 1.25' and the autogenerated" + + -- Asserts for the desired check messages after configure. + assertOutputContains libAutogenMsg configureResult + assertOutputContains exeAutogenMsg configureResult + assertOutputContains testAutogenMsg configureResult + assertOutputContains benchAutogenMsg configureResult + + -- Asserts for the desired check messages after sdist. + assertOutputContains "Distribution quality errors:" sdistResult + assertOutputContains libAutogenMsg sdistResult + assertOutputContains exeAutogenMsg sdistResult + assertOutputContains testAutogenMsg sdistResult + assertOutputContains benchAutogenMsg sdistResult + assertOutputContains pathsAutogenMsg sdistResult + -- Asserts for the undesired check messages after sdist. + assertOutputDoesNotContain "Distribution quality warnings:" sdistResult + + -- Asserts for the error messages of the modules not found. + assertOutputContains + "Error: Could not find module: MyLibHelperModule with any suffix" + sdistResult + assertOutputContains + "module is autogenerated it should be added to 'autogen-modules'" + sdistResult + + return () diff --git a/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/AutogenModules.cabal b/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/AutogenModules.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/AutogenModules.cabal @@ -0,0 +1,60 @@ +name: AutogenModules +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Federico Mastellone +maintainer: Federico Mastellone +synopsis: AutogenModules +category: PackageTests +build-type: Simple +cabal-version: >= 1.24 + +description: + Check that Cabal recognizes the autogen-modules fields below. + +Library + default-language: Haskell2010 + build-depends: base + exposed-modules: + MyLibrary + Paths_AutogenModules + MyLibHelperModule + other-modules: + MyLibModule + autogen-modules: + MyLibHelperModule + +Executable Exe + default-language: Haskell2010 + main-is: Dummy.hs + build-depends: base + other-modules: + MyExeModule + Paths_AutogenModules + MyExeHelperModule + autogen-modules: + MyExeHelperModule + +Test-Suite Test + default-language: Haskell2010 + main-is: Dummy.hs + type: exitcode-stdio-1.0 + build-depends: base + other-modules: + MyTestModule + Paths_AutogenModules + MyTestHelperModule + autogen-modules: + MyTestHelperModule + +Benchmark Bench + default-language: Haskell2010 + main-is: Dummy.hs + type: exitcode-stdio-1.0 + build-depends: base + other-modules: + MyBenchModule + Paths_AutogenModules + MyBenchHelperModule + autogen-modules: + MyBenchHelperModule diff --git a/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/Check.hs b/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/Check.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/Check.hs +++ /dev/null @@ -1,104 +0,0 @@ -module PackageTests.AutogenModules.SrcDist.Check where - -import Distribution.ModuleName -import Distribution.Simple.LocalBuildInfo -import Distribution.PackageDescription -import PackageTests.PackageTester - -suite :: TestM () -suite = do - - dist_dir <- distDir - - -- Calling sdist without running configure first makes test fail with: - -- "Exception: Run the 'configure' command first." - -- This is becuase we are calling getPersistBuildConfig - - configureResult <- cabal' "configure" [] - sdistResult <- cabal' "sdist" [] - - -- Now check that all the correct modules were parsed. - lbi <- liftIO $ getPersistBuildConfig dist_dir - let (Just gotLibrary) = library (localPkgDescr lbi) - let gotExecutable = head $ executables (localPkgDescr lbi) - let gotTestSuite = head $ testSuites (localPkgDescr lbi) - let gotBenchmark = head $ benchmarks (localPkgDescr lbi) - assertEqual "library 'autogen-modules' field does not match expected" - [fromString "MyLibHelperModule"] - (libModulesAutogen gotLibrary) - assertEqual "executable 'autogen-modules' field does not match expected" - [fromString "MyExeHelperModule"] - (exeModulesAutogen gotExecutable) - assertEqual "test-suite 'autogen-modules' field does not match expected" - [fromString "MyTestHelperModule"] - (testModulesAutogen gotTestSuite) - assertEqual "benchmark 'autogen-modules' field does not match expected" - [fromString "MyBenchHelperModule"] - (benchmarkModulesAutogen gotBenchmark) - - -- Package check messages. - let libAutogenMsg = - "An 'autogen-module' is neither on 'exposed-modules' or " - ++ "'other-modules'" - let exeAutogenMsg = - "On executable 'Exe' an 'autogen-module' is not on " - ++ "'other-modules'" - let testAutogenMsg = - "On test suite 'Test' an 'autogen-module' is not on " - ++ "'other-modules'" - let benchAutogenMsg = - "On benchmark 'Bench' an 'autogen-module' is not on " - ++ "'other-modules'" - let pathsAutogenMsg = - "Packages using 'cabal-version: >= 1.25' and the autogenerated" - - -- Asserts for the undesired check messages after configure. - assertOutputDoesNotContain libAutogenMsg configureResult - assertOutputDoesNotContain exeAutogenMsg configureResult - assertOutputDoesNotContain testAutogenMsg configureResult - assertOutputDoesNotContain benchAutogenMsg configureResult - assertOutputDoesNotContain pathsAutogenMsg configureResult - - -- Asserts for the undesired check messages after sdist. - assertOutputDoesNotContain "Distribution quality errors:" sdistResult - assertOutputDoesNotContain libAutogenMsg sdistResult - assertOutputDoesNotContain exeAutogenMsg sdistResult - assertOutputDoesNotContain testAutogenMsg sdistResult - assertOutputDoesNotContain benchAutogenMsg sdistResult - assertOutputDoesNotContain "Distribution quality warnings:" sdistResult - assertOutputDoesNotContain pathsAutogenMsg sdistResult - - -- Assert sdist --list-sources output. - -- If called before configure fails, dist directory is not created. - let listSourcesFileGot = dist_dir ++ "/" ++ "list-sources.txt" - cabal "sdist" ["--list-sources=" ++ listSourcesFileGot] - let listSourcesStrExpected = -#if defined(mingw32_HOST_OS) - ".\\MyLibrary.hs\n" - ++ ".\\MyLibModule.hs\n" - ++ ".\\Dummy.hs\n" - ++ ".\\MyExeModule.hs\n" - ++ ".\\Dummy.hs\n" - ++ ".\\MyTestModule.hs\n" - ++ ".\\Dummy.hs\n" - ++ ".\\MyBenchModule.hs\n" - ++ "LICENSE\n" - ++ ".\\my.cabal\n" -#else - "./MyLibrary.hs\n" - ++ "./MyLibModule.hs\n" - ++ "./Dummy.hs\n" - ++ "./MyExeModule.hs\n" - ++ "./Dummy.hs\n" - ++ "./MyTestModule.hs\n" - ++ "./Dummy.hs\n" - ++ "./MyBenchModule.hs\n" - ++ "LICENSE\n" - ++ "./my.cabal\n" -#endif - listSourcesStrGot <- liftIO $ readFile listSourcesFileGot - assertEqual "sdist --list-sources does not match the expected files" - listSourcesStrExpected - listSourcesStrGot - - return () diff --git a/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/my.cabal b/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/my.cabal deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/my.cabal +++ /dev/null @@ -1,60 +0,0 @@ -name: AutogenModules -version: 0.1 -license: BSD3 -license-file: LICENSE -author: Federico Mastellone -maintainer: Federico Mastellone -synopsis: AutogenModules -category: PackageTests -build-type: Simple -cabal-version: >= 1.24 - -description: - Check that Cabal recognizes the autogen-modules fields below. - -Library - default-language: Haskell2010 - build-depends: base - exposed-modules: - MyLibrary - Paths_AutogenModules - MyLibHelperModule - other-modules: - MyLibModule - autogen-modules: - MyLibHelperModule - -Executable Exe - default-language: Haskell2010 - main-is: Dummy.hs - build-depends: base - other-modules: - MyExeModule - Paths_AutogenModules - MyExeHelperModule - autogen-modules: - MyExeHelperModule - -Test-Suite Test - default-language: Haskell2010 - main-is: Dummy.hs - type: exitcode-stdio-1.0 - build-depends: base - other-modules: - MyTestModule - Paths_AutogenModules - MyTestHelperModule - autogen-modules: - MyTestHelperModule - -Benchmark Bench - default-language: Haskell2010 - main-is: Dummy.hs - type: exitcode-stdio-1.0 - build-depends: base - other-modules: - MyBenchModule - Paths_AutogenModules - MyBenchHelperModule - autogen-modules: - MyBenchHelperModule diff --git a/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.cabal.out @@ -0,0 +1,11 @@ +# Setup configure +Resolving dependencies... +Configuring AutogenModules-0.1... +# Setup sdist +Building source dist for AutogenModules-0.1... +Preprocessing executable 'Exe' for AutogenModules-0.1.. +Preprocessing library for AutogenModules-0.1.. +Source tarball created: setup.cabal.dist/work/dist/AutogenModules-0.1.tar.gz +# Setup sdist +List of package sources written to file '/setup.cabal.dist/work/./dist/list-sources.txt' +List of package sources written to file '/setup.cabal.dist/work/./dist/list-sources.txt' diff --git a/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.out b/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.out @@ -0,0 +1,9 @@ +# Setup configure +Configuring AutogenModules-0.1... +# Setup sdist +Building source dist for AutogenModules-0.1... +Preprocessing executable 'Exe' for AutogenModules-0.1.. +Preprocessing library for AutogenModules-0.1.. +Source tarball created: setup.dist/work/dist/AutogenModules-0.1.tar.gz +# Setup sdist +List of package sources written to file '/setup.dist/work/./dist/list-sources.txt' diff --git a/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.test.hs b/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/AutogenModules/SrcDist/setup.test.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE CPP #-} +import Test.Cabal.Prelude + +import Control.Monad.IO.Class +import Distribution.ModuleName hiding (main) +import Distribution.Simple.LocalBuildInfo +import Distribution.PackageDescription + +-- Test that setup parses and uses 'autogen-modules' fields correctly +main = setupAndCabalTest $ do + + dist_dir <- fmap testDistDir getTestEnv + + -- Calling sdist without running configure first makes test fail with: + -- "Exception: Run the 'configure' command first." + -- This is becuase we are calling getPersistBuildConfig + + configureResult <- setup' "configure" [] + sdistResult <- setup' "sdist" [] + + -- Now check that all the correct modules were parsed. + lbi <- getLocalBuildInfoM + let Just gotLibrary = library (localPkgDescr lbi) + let gotExecutable = head $ executables (localPkgDescr lbi) + let gotTestSuite = head $ testSuites (localPkgDescr lbi) + let gotBenchmark = head $ benchmarks (localPkgDescr lbi) + assertEqual "library 'autogen-modules' field does not match expected" + [fromString "MyLibHelperModule"] + (libModulesAutogen gotLibrary) + assertEqual "executable 'autogen-modules' field does not match expected" + [fromString "MyExeHelperModule"] + (exeModulesAutogen gotExecutable) + assertEqual "test-suite 'autogen-modules' field does not match expected" + [fromString "MyTestHelperModule"] + (testModulesAutogen gotTestSuite) + assertEqual "benchmark 'autogen-modules' field does not match expected" + [fromString "MyBenchHelperModule"] + (benchmarkModulesAutogen gotBenchmark) + + -- Package check messages. + let libAutogenMsg = + "An 'autogen-module' is neither on 'exposed-modules' or " + ++ "'other-modules'" + let exeAutogenMsg = + "On executable 'Exe' an 'autogen-module' is not on " + ++ "'other-modules'" + let testAutogenMsg = + "On test suite 'Test' an 'autogen-module' is not on " + ++ "'other-modules'" + let benchAutogenMsg = + "On benchmark 'Bench' an 'autogen-module' is not on " + ++ "'other-modules'" + let pathsAutogenMsg = + "Packages using 'cabal-version: >= 1.25' and the autogenerated" + + -- Asserts for the undesired check messages after configure. + assertOutputDoesNotContain libAutogenMsg configureResult + assertOutputDoesNotContain exeAutogenMsg configureResult + assertOutputDoesNotContain testAutogenMsg configureResult + assertOutputDoesNotContain benchAutogenMsg configureResult + assertOutputDoesNotContain pathsAutogenMsg configureResult + + -- Asserts for the undesired check messages after sdist. + assertOutputDoesNotContain "Distribution quality errors:" sdistResult + assertOutputDoesNotContain libAutogenMsg sdistResult + assertOutputDoesNotContain exeAutogenMsg sdistResult + assertOutputDoesNotContain testAutogenMsg sdistResult + assertOutputDoesNotContain benchAutogenMsg sdistResult + assertOutputDoesNotContain "Distribution quality warnings:" sdistResult + assertOutputDoesNotContain pathsAutogenMsg sdistResult + + -- Assert sdist --list-sources output. + -- If called before configure fails, dist directory is not created. + let listSourcesFileGot = dist_dir ++ "/" ++ "list-sources.txt" + setup "sdist" ["--list-sources=" ++ listSourcesFileGot] + let listSourcesStrExpected = +#if defined(mingw32_HOST_OS) + ".\\MyLibrary.hs\n" + ++ ".\\MyLibModule.hs\n" + ++ ".\\Dummy.hs\n" + ++ ".\\MyExeModule.hs\n" + ++ ".\\Dummy.hs\n" + ++ ".\\MyTestModule.hs\n" + ++ ".\\Dummy.hs\n" + ++ ".\\MyBenchModule.hs\n" + ++ "LICENSE\n" + ++ ".\\AutogenModules.cabal\n" +#else + "./MyLibrary.hs\n" + ++ "./MyLibModule.hs\n" + ++ "./Dummy.hs\n" + ++ "./MyExeModule.hs\n" + ++ "./Dummy.hs\n" + ++ "./MyTestModule.hs\n" + ++ "./Dummy.hs\n" + ++ "./MyBenchModule.hs\n" + ++ "LICENSE\n" + ++ "./AutogenModules.cabal\n" +#endif + listSourcesStrGot <- liftIO $ readFile listSourcesFileGot + assertEqual "sdist --list-sources does not match the expected files" + listSourcesStrExpected + listSourcesStrGot + + return () diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/Fail1.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/Fail1.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/Fail1.cabal @@ -0,0 +1,17 @@ +name: Fail1 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library sig + signatures: A + build-depends: base + default-language: Haskell2010 + +library + build-depends: sig + mixins: sig requires (MissingReq as A) + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Resolving dependencies... +Configuring Fail1-0.1.0.0... +Error: + The library 'sig' from package 'Fail1-0.1.0.0' does not require: + MissingReq + In mixins: Fail1:sig requires (MissingReq as A) + In the stanza library diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/setup.out b/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring Fail1-0.1.0.0... +Error: + The library 'sig' from package 'Fail1-0.1.0.0' does not require: + MissingReq + In mixins: Fail1:sig requires (MissingReq as A) + In the stanza library diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail1/setup.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + r <- fails $ setup' "configure" [] + assertOutputContains "MissingReq" r + return () diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/Fail2.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/Fail2.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/Fail2.cabal @@ -0,0 +1,11 @@ +name: Fail2 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + mixins: non-existent + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/setup.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring Fail2-0.1.0.0... +Error: + Mix-in refers to non-existent package 'non-existent' + (did you forget to add the package to build-depends?) diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/setup.out b/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring Fail2-0.1.0.0... +Error: + Mix-in refers to non-existent package 'non-existent' + (did you forget to add the package to build-depends?) diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail2/setup.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + r <- fails $ setup' "configure" [] + assertOutputContains "non-existent" r + return () diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/Fail3.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/Fail3.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/Fail3.cabal @@ -0,0 +1,17 @@ +name: Fail1 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library + signatures: UnfilledSig + build-depends: base + default-language: Haskell2010 + +executable foo + build-depends: Fail1 + main-is: Main.hs + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/Main.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/Main.hs @@ -0,0 +1,1 @@ +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/UnfilledSig.hsig b/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/UnfilledSig.hsig new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/UnfilledSig.hsig @@ -0,0 +1,1 @@ +signature UnfilledSig where diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/setup.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring Fail1-0.1.0.0... +Error: + Non-library component has unfilled requirements: UnfilledSig + In the stanza executable foo diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/setup.out b/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring Fail1-0.1.0.0... +Error: + Non-library component has unfilled requirements: UnfilledSig + In the stanza executable foo diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Fail3/setup.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + r <- fails $ setup' "configure" [] + assertOutputContains "UnfilledSig" r + return () diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes1/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes1/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes1/setup.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring Includes1-0.1.0.0... +# Setup build +Preprocessing library for Includes1-0.1.0.0.. +Building library for Includes1-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes1/setup.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes1/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes1/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring Includes1-0.1.0.0... +# Setup build +Preprocessing library for Includes1-0.1.0.0.. +Building library for Includes1-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes1/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes1/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes1/setup.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + setup "configure" [] + r <- fails $ setup' "build" [] + assertRegex "error should be in B.hs" "^B.hs:" r + assertRegex "error should be \"Could not find module Data.Set\"" + "(Could not find module|Failed to load interface).*Data.Set" r diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/Includes2.cabal.fail b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/Includes2.cabal.fail new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/Includes2.cabal.fail @@ -0,0 +1,35 @@ +name: fail +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library mylib + build-depends: base + signatures: Database + exposed-modules: Mine + hs-source-dirs: mylib + default-language: Haskell2010 + +library mysql + build-depends: base + exposed-modules: Database.MySQL + hs-source-dirs: mysql + default-language: Haskell2010 + +library postgresql + build-depends: base + exposed-modules: Database.PostgreSQL + hs-source-dirs: postgresql + default-language: Haskell2010 + +library + build-depends: base, mysql, postgresql, mylib + mixins: + mysql (Database.MySQL as Database), + postgresql (Database.PostgreSQL as Database) + exposed-modules: App + hs-source-dirs: src + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external-target.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external-target.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external-target.out @@ -0,0 +1,9 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - mylib-0.1.0.0 (lib) (first run) +Configuring library for mylib-0.1.0.0.. +Preprocessing library for mylib-0.1.0.0.. +Building library instantiated with Database = +for mylib-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external-target.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external-target.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external-target.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + withProjectFile "cabal.external.project" $ do + cabal "new-build" ["mylib"] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.out @@ -0,0 +1,43 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - mylib-0.1.0.0 (lib) (first run) + - mysql-0.1.0.0 (lib) (first run) + - postgresql-0.1.0.0 (lib) (first run) + - mylib-0.1.0.0 (lib with Database=mysql-0.1.0.0-inplace:Database.MySQL) (first run) + - mylib-0.1.0.0 (lib with Database=postgresql-0.1.0.0-inplace:Database.PostgreSQL) (first run) + - src-0.1.0.0 (lib) (first run) + - exe-0.1.0.0 (exe:exe) (first run) +Configuring library for mylib-0.1.0.0.. +Preprocessing library for mylib-0.1.0.0.. +Building library instantiated with Database = +for mylib-0.1.0.0.. +Configuring library for mysql-0.1.0.0.. +Preprocessing library for mysql-0.1.0.0.. +Building library for mysql-0.1.0.0.. +Configuring library for postgresql-0.1.0.0.. +Preprocessing library for postgresql-0.1.0.0.. +Building library for postgresql-0.1.0.0.. +Configuring library instantiated with + Database = mysql-0.1.0.0-inplace:Database.MySQL +for mylib-0.1.0.0.. +Preprocessing library for mylib-0.1.0.0.. +Building library instantiated with + Database = mysql-0.1.0.0-inplace:Database.MySQL +for mylib-0.1.0.0.. +Configuring library instantiated with + Database = postgresql-0.1.0.0-inplace:Database.PostgreSQL +for mylib-0.1.0.0.. +Preprocessing library for mylib-0.1.0.0.. +Building library instantiated with + Database = postgresql-0.1.0.0-inplace:Database.PostgreSQL +for mylib-0.1.0.0.. +Configuring library for src-0.1.0.0.. +Preprocessing library for src-0.1.0.0.. +Building library for src-0.1.0.0.. +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.. +# exe exe +"minemysql minepostgresql" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-external.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + withProjectFile "cabal.external.project" $ do + cabal "new-build" ["exe"] + withPlan $ do + r <- runPlanExe' "exe" "exe" [] + assertOutputContains "minemysql minepostgresql" r diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal-target.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal-target.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal-target.out @@ -0,0 +1,9 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - Includes2-0.1.0.0 (lib:mylib) (first run) +Configuring library 'mylib' for Includes2-0.1.0.0.. +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Building library 'mylib' instantiated with Database = +for Includes2-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal-target.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal-target.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal-target.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + withProjectFile "cabal.internal.project" $ do + cabal "new-build" ["mylib"] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.out @@ -0,0 +1,43 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - Includes2-0.1.0.0 (lib:mylib) (first run) + - Includes2-0.1.0.0 (lib:mysql) (first run) + - Includes2-0.1.0.0 (lib:postgresql) (first run) + - Includes2-0.1.0.0 (lib:mylib with Database=Includes2-0.1.0.0-inplace-mysql:Database.MySQL) (first run) + - Includes2-0.1.0.0 (lib:mylib with Database=Includes2-0.1.0.0-inplace-postgresql:Database.PostgreSQL) (first run) + - Includes2-0.1.0.0 (lib) (first run) + - Includes2-0.1.0.0 (exe:exe) (first run) +Configuring library 'mylib' for Includes2-0.1.0.0.. +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Building library 'mylib' instantiated with Database = +for Includes2-0.1.0.0.. +Configuring library 'mysql' for Includes2-0.1.0.0.. +Preprocessing library 'mysql' for Includes2-0.1.0.0.. +Building library 'mysql' for Includes2-0.1.0.0.. +Configuring library 'postgresql' for Includes2-0.1.0.0.. +Preprocessing library 'postgresql' for Includes2-0.1.0.0.. +Building library 'postgresql' for Includes2-0.1.0.0.. +Configuring library 'mylib' instantiated with + Database = Includes2-0.1.0.0-inplace-mysql:Database.MySQL +for Includes2-0.1.0.0.. +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Building library 'mylib' instantiated with + Database = Includes2-0.1.0.0-inplace-mysql:Database.MySQL +for Includes2-0.1.0.0.. +Configuring library 'mylib' instantiated with + Database = Includes2-0.1.0.0-inplace-postgresql:Database.PostgreSQL +for Includes2-0.1.0.0.. +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Building library 'mylib' instantiated with + Database = Includes2-0.1.0.0-inplace-postgresql:Database.PostgreSQL +for Includes2-0.1.0.0.. +Configuring library for Includes2-0.1.0.0.. +Preprocessing library for Includes2-0.1.0.0.. +Building library for Includes2-0.1.0.0.. +Configuring executable 'exe' for Includes2-0.1.0.0.. +Preprocessing executable 'exe' for Includes2-0.1.0.0.. +Building executable 'exe' for Includes2-0.1.0.0.. +# Includes2 exe +"minemysql minepostgresql" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + withProjectFile "cabal.internal.project" $ do + cabal "new-build" ["exe"] + withPlan $ do + r <- runPlanExe' "Includes2" "exe" [] + assertOutputContains "minemysql minepostgresql" r diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal.external.project b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal.external.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal.external.project @@ -0,0 +1,1 @@ +packages: mylib mysql src exe postgresql diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal.internal.project b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal.internal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/cabal.internal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/fail.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/fail.cabal deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/fail.cabal +++ /dev/null @@ -1,35 +0,0 @@ -name: fail -version: 0.1.0.0 -license: BSD3 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.25 - -library mylib - build-depends: base - signatures: Database - exposed-modules: Mine - hs-source-dirs: mylib - default-language: Haskell2010 - -library mysql - build-depends: base - exposed-modules: Database.MySQL - hs-source-dirs: mysql - default-language: Haskell2010 - -library postgresql - build-depends: base - exposed-modules: Database.PostgreSQL - hs-source-dirs: postgresql - default-language: Haskell2010 - -library - build-depends: base, mysql, postgresql, mylib - mixins: - mysql (Database.MySQL as Database), - postgresql (Database.PostgreSQL as Database) - exposed-modules: App - hs-source-dirs: src - default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.cabal.out @@ -0,0 +1,120 @@ +# Setup configure +Resolving dependencies... +Configuring mylib-0.1.0.0... +# Setup build +Preprocessing library for mylib-0.1.0.0.. +Building library instantiated with Database = +for mylib-0.1.0.0.. +# Setup haddock +Preprocessing library for mylib-0.1.0.0.. +Running Haddock on library instantiated with Database = +for mylib-0.1.0.0.. +Documentation created: ../setup-external.cabal.dist/work/mylib/dist/doc/html/mylib/index.html +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Database = +for mylib-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring mysql-0.1.0.0... +# Setup build +Preprocessing library for mysql-0.1.0.0.. +Building library for mysql-0.1.0.0.. +# Setup haddock +Preprocessing library for mysql-0.1.0.0.. +Running Haddock on library for mysql-0.1.0.0.. +Documentation created: ../setup-external.cabal.dist/work/mysql/dist/doc/html/mysql/index.html +# Setup copy +Installing library in +# Setup register +Registering library for mysql-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring postgresql-0.1.0.0... +# Setup build +Preprocessing library for postgresql-0.1.0.0.. +Building library for postgresql-0.1.0.0.. +# Setup haddock +Preprocessing library for postgresql-0.1.0.0.. +Running Haddock on library for postgresql-0.1.0.0.. +Documentation created: ../setup-external.cabal.dist/work/postgresql/dist/doc/html/postgresql/index.html +# Setup copy +Installing library in +# Setup register +Registering library for postgresql-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring mylib-0.1.0.0... +# Setup build +Preprocessing library for mylib-0.1.0.0.. +Building library instantiated with Database = mysql-0.1.0.0:Database.MySQL +for mylib-0.1.0.0.. +# Setup haddock +Preprocessing library for mylib-0.1.0.0.. +Running Haddock on library instantiated with + Database = mysql-0.1.0.0:Database.MySQL +for mylib-0.1.0.0.. +Documentation created: ../setup-external.cabal.dist/work/mylib/dist/doc/html/mylib/index.html +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Database = mysql-0.1.0.0:Database.MySQL +for mylib-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring mylib-0.1.0.0... +# Setup build +Preprocessing library for mylib-0.1.0.0.. +Building library instantiated with + Database = postgresql-0.1.0.0:Database.PostgreSQL +for mylib-0.1.0.0.. +# Setup haddock +Preprocessing library for mylib-0.1.0.0.. +Running Haddock on library instantiated with + Database = postgresql-0.1.0.0:Database.PostgreSQL +for mylib-0.1.0.0.. +Documentation created: ../setup-external.cabal.dist/work/mylib/dist/doc/html/mylib/index.html +# Setup copy +Installing library in +# Setup register +Registering library instantiated with + Database = postgresql-0.1.0.0:Database.PostgreSQL +for mylib-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring src-0.1.0.0... +# Setup build +Preprocessing library for src-0.1.0.0.. +Building library for src-0.1.0.0.. +# Setup haddock +Preprocessing library for src-0.1.0.0.. +Running Haddock on library for src-0.1.0.0.. +Documentation created: ../setup-external.cabal.dist/work/src/dist/doc/html/src/index.html +# Setup copy +Installing library in +# Setup register +Registering library for src-0.1.0.0.. +# Setup configure +Resolving dependencies... +Warning: solver failed to find a solution: +Could not resolve dependencies: +trying: exe-0.1.0.0 (user goal) +next goal: src (dependency of exe) +rejecting: src-/installed-... (conflict: src => mylib==0.1.0.0/installed-0.1..., src => mylib==0.1.0.0/installed-0.1...) +fail (backjumping, conflict set: exe, src) +After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: exe (2), src (2) +Trying configure anyway. +Configuring exe-0.1.0.0... +# Setup build +Preprocessing executable 'exe' for exe-0.1.0.0.. +Building executable 'exe' for exe-0.1.0.0.. +# Setup haddock +Warning: No documentation was generated as this package does not contain a library. Perhaps you want to use the --executables, --tests, --benchmarks or --foreign-libraries flags. +# Setup copy +Installing executable exe in +Warning: The directory /setup-external.cabal.dist/usr/bin is not in the system search path. +# Setup register +Package contains no library to register: exe-0.1.0.0... +# exe +"minemysql minepostgresql" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.out @@ -0,0 +1,105 @@ +# Setup configure +Configuring mylib-0.1.0.0... +# Setup build +Preprocessing library for mylib-0.1.0.0.. +Building library instantiated with Database = +for mylib-0.1.0.0.. +# Setup haddock +Preprocessing library for mylib-0.1.0.0.. +Running Haddock on library instantiated with Database = +for mylib-0.1.0.0.. +Documentation created: ../setup-external.dist/work/mylib/dist/doc/html/mylib/index.html +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Database = +for mylib-0.1.0.0.. +# Setup configure +Configuring mysql-0.1.0.0... +# Setup build +Preprocessing library for mysql-0.1.0.0.. +Building library for mysql-0.1.0.0.. +# Setup haddock +Preprocessing library for mysql-0.1.0.0.. +Running Haddock on library for mysql-0.1.0.0.. +Documentation created: ../setup-external.dist/work/mysql/dist/doc/html/mysql/index.html +# Setup copy +Installing library in +# Setup register +Registering library for mysql-0.1.0.0.. +# Setup configure +Configuring postgresql-0.1.0.0... +# Setup build +Preprocessing library for postgresql-0.1.0.0.. +Building library for postgresql-0.1.0.0.. +# Setup haddock +Preprocessing library for postgresql-0.1.0.0.. +Running Haddock on library for postgresql-0.1.0.0.. +Documentation created: ../setup-external.dist/work/postgresql/dist/doc/html/postgresql/index.html +# Setup copy +Installing library in +# Setup register +Registering library for postgresql-0.1.0.0.. +# Setup configure +Configuring mylib-0.1.0.0... +# Setup build +Preprocessing library for mylib-0.1.0.0.. +Building library instantiated with Database = mysql-0.1.0.0:Database.MySQL +for mylib-0.1.0.0.. +# Setup haddock +Preprocessing library for mylib-0.1.0.0.. +Running Haddock on library instantiated with + Database = mysql-0.1.0.0:Database.MySQL +for mylib-0.1.0.0.. +Documentation created: ../setup-external.dist/work/mylib/dist/doc/html/mylib/index.html +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Database = mysql-0.1.0.0:Database.MySQL +for mylib-0.1.0.0.. +# Setup configure +Configuring mylib-0.1.0.0... +# Setup build +Preprocessing library for mylib-0.1.0.0.. +Building library instantiated with + Database = postgresql-0.1.0.0:Database.PostgreSQL +for mylib-0.1.0.0.. +# Setup haddock +Preprocessing library for mylib-0.1.0.0.. +Running Haddock on library instantiated with + Database = postgresql-0.1.0.0:Database.PostgreSQL +for mylib-0.1.0.0.. +Documentation created: ../setup-external.dist/work/mylib/dist/doc/html/mylib/index.html +# Setup copy +Installing library in +# Setup register +Registering library instantiated with + Database = postgresql-0.1.0.0:Database.PostgreSQL +for mylib-0.1.0.0.. +# Setup configure +Configuring src-0.1.0.0... +# Setup build +Preprocessing library for src-0.1.0.0.. +Building library for src-0.1.0.0.. +# Setup haddock +Preprocessing library for src-0.1.0.0.. +Running Haddock on library for src-0.1.0.0.. +Documentation created: ../setup-external.dist/work/src/dist/doc/html/src/index.html +# Setup copy +Installing library in +# Setup register +Registering library for src-0.1.0.0.. +# Setup configure +Configuring exe-0.1.0.0... +# Setup build +Preprocessing executable 'exe' for exe-0.1.0.0.. +Building executable 'exe' for exe-0.1.0.0.. +# Setup haddock +Warning: No documentation was generated as this package does not contain a library. Perhaps you want to use the --executables, --tests, --benchmarks or --foreign-libraries flags. +# Setup copy +Installing executable exe in +Warning: The directory /setup-external.dist/usr/bin is not in the system search path. +# Setup register +Package contains no library to register: exe-0.1.0.0... +# exe +"minemysql minepostgresql" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-external.test.hs @@ -0,0 +1,17 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + withPackageDb $ do + withDirectory "mylib" $ setup_install_with_docs ["--ipid", "mylib-0.1.0.0"] + withDirectory "mysql" $ setup_install_with_docs ["--ipid", "mysql-0.1.0.0"] + withDirectory "postgresql" $ setup_install_with_docs ["--ipid", "postgresql-0.1.0.0"] + withDirectory "mylib" $ + setup_install_with_docs ["--ipid", "mylib-0.1.0.0", + "--instantiate-with", "Database=mysql-0.1.0.0:Database.MySQL"] + withDirectory "mylib" $ + setup_install_with_docs ["--ipid", "mylib-0.1.0.0", + "--instantiate-with", "Database=postgresql-0.1.0.0:Database.PostgreSQL"] + withDirectory "src" $ setup_install_with_docs [] + withDirectory "exe" $ do + setup_install_with_docs [] + runExe' "exe" [] >>= assertOutputContains "minemysql minepostgresql" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.cabal.out @@ -0,0 +1,16 @@ +# Setup configure +Resolving dependencies... +Configuring fail-0.1.0.0... +Error: + - Cannot match module names + Database.MySQL + and Database.PostgreSQL + While filling requirement 'Database' + + - Ambiguous module 'Database' + It could refer to 'fail-0.1.0.0-mysql:Database.MySQL' + brought into scope by mixins: fail:mysql (Database.MySQL as Database) + or 'fail-0.1.0.0-postgresql:Database.PostgreSQL' + brought into scope by mixins: fail:postgresql (Database.PostgreSQL as Database) + While filling requirements of build-depends: fail:mylib + In the stanza library diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.out @@ -0,0 +1,15 @@ +# Setup configure +Configuring fail-0.1.0.0... +Error: + - Cannot match module names + Database.MySQL + and Database.PostgreSQL + While filling requirement 'Database' + + - Ambiguous module 'Database' + It could refer to 'fail-0.1.0.0-mysql:Database.MySQL' + brought into scope by mixins: fail:mysql (Database.MySQL as Database) + or 'fail-0.1.0.0-postgresql:Database.PostgreSQL' + brought into scope by mixins: fail:postgresql (Database.PostgreSQL as Database) + While filling requirements of build-depends: fail:mylib + In the stanza library diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal-fail.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + r <- fails $ setup' "configure" ["--cabal-file", "Includes2.cabal.fail"] + assertOutputContains "mysql" r diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.cabal.out @@ -0,0 +1,46 @@ +# Setup configure +Resolving dependencies... +Configuring Includes2-0.1.0.0... +# Setup build +Preprocessing library 'postgresql' for Includes2-0.1.0.0.. +Building library 'postgresql' for Includes2-0.1.0.0.. +Preprocessing library 'mysql' for Includes2-0.1.0.0.. +Building library 'mysql' for Includes2-0.1.0.0.. +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Building library 'mylib' instantiated with Database = +for Includes2-0.1.0.0.. +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Building library 'mylib' instantiated with + Database = Includes2-0.1.0.0-mysql:Database.MySQL +for Includes2-0.1.0.0.. +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Building library 'mylib' instantiated with + Database = Includes2-0.1.0.0-postgresql:Database.PostgreSQL +for Includes2-0.1.0.0.. +Preprocessing library for Includes2-0.1.0.0.. +Building library for Includes2-0.1.0.0.. +Preprocessing executable 'exe' for Includes2-0.1.0.0.. +Building executable 'exe' for Includes2-0.1.0.0.. +# Setup copy +Installing internal library postgresql in +Installing internal library mysql in +Installing internal library mylib in +Installing internal library mylib in +Installing internal library mylib in +Installing library in +Installing executable exe in +Warning: The directory /setup-internal.cabal.dist/usr/bin is not in the system search path. +# Setup register +Registering library 'postgresql' for Includes2-0.1.0.0.. +Registering library 'mysql' for Includes2-0.1.0.0.. +Registering library 'mylib' instantiated with Database = +for Includes2-0.1.0.0.. +Registering library 'mylib' instantiated with + Database = Includes2-0.1.0.0-mysql:Database.MySQL +for Includes2-0.1.0.0.. +Registering library 'mylib' instantiated with + Database = Includes2-0.1.0.0-postgresql:Database.PostgreSQL +for Includes2-0.1.0.0.. +Registering library for Includes2-0.1.0.0.. +# exe +"minemysql minepostgresql" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.out @@ -0,0 +1,45 @@ +# Setup configure +Configuring Includes2-0.1.0.0... +# Setup build +Preprocessing library 'postgresql' for Includes2-0.1.0.0.. +Building library 'postgresql' for Includes2-0.1.0.0.. +Preprocessing library 'mysql' for Includes2-0.1.0.0.. +Building library 'mysql' for Includes2-0.1.0.0.. +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Building library 'mylib' instantiated with Database = +for Includes2-0.1.0.0.. +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Building library 'mylib' instantiated with + Database = Includes2-0.1.0.0-mysql:Database.MySQL +for Includes2-0.1.0.0.. +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Building library 'mylib' instantiated with + Database = Includes2-0.1.0.0-postgresql:Database.PostgreSQL +for Includes2-0.1.0.0.. +Preprocessing library for Includes2-0.1.0.0.. +Building library for Includes2-0.1.0.0.. +Preprocessing executable 'exe' for Includes2-0.1.0.0.. +Building executable 'exe' for Includes2-0.1.0.0.. +# Setup copy +Installing internal library postgresql in +Installing internal library mysql in +Installing internal library mylib in +Installing internal library mylib in +Installing internal library mylib in +Installing library in +Installing executable exe in +Warning: The directory /setup-internal.dist/usr/bin is not in the system search path. +# Setup register +Registering library 'postgresql' for Includes2-0.1.0.0.. +Registering library 'mysql' for Includes2-0.1.0.0.. +Registering library 'mylib' instantiated with Database = +for Includes2-0.1.0.0.. +Registering library 'mylib' instantiated with + Database = Includes2-0.1.0.0-mysql:Database.MySQL +for Includes2-0.1.0.0.. +Registering library 'mylib' instantiated with + Database = Includes2-0.1.0.0-postgresql:Database.PostgreSQL +for Includes2-0.1.0.0.. +Registering library for Includes2-0.1.0.0.. +# exe +"minemysql minepostgresql" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-internal.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + withPackageDb $ do + setup_install ["--cabal-file", "Includes2.cabal"] + -- TODO: haddock for internal method doesn't work + runExe "exe" [] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-per-component.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-per-component.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-per-component.out @@ -0,0 +1,110 @@ +# Setup configure +Configuring library 'mylib' for Includes2-0.1.0.0.. +# Setup build +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Building library 'mylib' instantiated with Database = +for Includes2-0.1.0.0.. +# Setup haddock +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Running Haddock on library 'mylib' instantiated with Database = +for Includes2-0.1.0.0.. +Documentation created: setup-per-component.dist/work/dist/doc/html/Includes2/index.html +# Setup copy +Installing internal library mylib in +# Setup register +Registering library 'mylib' instantiated with Database = +for Includes2-0.1.0.0.. +# Setup configure +Configuring library 'mysql' for Includes2-0.1.0.0.. +# Setup build +Preprocessing library 'mysql' for Includes2-0.1.0.0.. +Building library 'mysql' for Includes2-0.1.0.0.. +# Setup haddock +Preprocessing library 'mysql' for Includes2-0.1.0.0.. +Running Haddock on library 'mysql' for Includes2-0.1.0.0.. +Documentation created: setup-per-component.dist/work/dist/doc/html/Includes2/index.html +# Setup copy +Installing internal library mysql in +# Setup register +Registering library 'mysql' for Includes2-0.1.0.0.. +# Setup configure +Configuring library 'postgresql' for Includes2-0.1.0.0.. +# Setup build +Preprocessing library 'postgresql' for Includes2-0.1.0.0.. +Building library 'postgresql' for Includes2-0.1.0.0.. +# Setup haddock +Preprocessing library 'postgresql' for Includes2-0.1.0.0.. +Running Haddock on library 'postgresql' for Includes2-0.1.0.0.. +Documentation created: setup-per-component.dist/work/dist/doc/html/Includes2/index.html +# Setup copy +Installing internal library postgresql in +# Setup register +Registering library 'postgresql' for Includes2-0.1.0.0.. +# Setup configure +Configuring library 'mylib' instantiated with + Database = mysql-0.1.0.0:Database.MySQL +for Includes2-0.1.0.0.. +# Setup build +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Building library 'mylib' instantiated with + Database = mysql-0.1.0.0:Database.MySQL +for Includes2-0.1.0.0.. +# Setup haddock +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Running Haddock on library 'mylib' instantiated with + Database = mysql-0.1.0.0:Database.MySQL +for Includes2-0.1.0.0.. +Documentation created: setup-per-component.dist/work/dist/doc/html/Includes2/index.html +# Setup copy +Installing internal library mylib in +# Setup register +Registering library 'mylib' instantiated with + Database = mysql-0.1.0.0:Database.MySQL +for Includes2-0.1.0.0.. +# Setup configure +Configuring library 'mylib' instantiated with + Database = postgresql-0.1.0.0:Database.PostgreSQL +for Includes2-0.1.0.0.. +# Setup build +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Building library 'mylib' instantiated with + Database = postgresql-0.1.0.0:Database.PostgreSQL +for Includes2-0.1.0.0.. +# Setup haddock +Preprocessing library 'mylib' for Includes2-0.1.0.0.. +Running Haddock on library 'mylib' instantiated with + Database = postgresql-0.1.0.0:Database.PostgreSQL +for Includes2-0.1.0.0.. +Documentation created: setup-per-component.dist/work/dist/doc/html/Includes2/index.html +# Setup copy +Installing internal library mylib in +# Setup register +Registering library 'mylib' instantiated with + Database = postgresql-0.1.0.0:Database.PostgreSQL +for Includes2-0.1.0.0.. +# Setup configure +Configuring library for Includes2-0.1.0.0.. +# Setup build +Preprocessing library for Includes2-0.1.0.0.. +Building library for Includes2-0.1.0.0.. +# Setup haddock +Preprocessing library for Includes2-0.1.0.0.. +Running Haddock on library for Includes2-0.1.0.0.. +Documentation created: setup-per-component.dist/work/dist/doc/html/Includes2/index.html +# Setup copy +Installing library in +# Setup register +Registering library for Includes2-0.1.0.0.. +# Setup configure +Configuring executable 'exe' for Includes2-0.1.0.0.. +# Setup build +Preprocessing executable 'exe' for Includes2-0.1.0.0.. +Building executable 'exe' for Includes2-0.1.0.0.. +# Setup haddock +Preprocessing executable 'exe' for Includes2-0.1.0.0.. +# Setup copy +Installing executable exe in +Warning: The directory /setup-per-component.dist/usr/bin is not in the system search path. +# Setup register +# exe +"minemysql minepostgresql" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-per-component.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-per-component.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes2/setup-per-component.test.hs @@ -0,0 +1,16 @@ +import Test.Cabal.Prelude +main = setupTest $ do + -- No cabal test because per-component is broken with it + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + withPackageDb $ do + let setup_install' args = setup_install_with_docs (["--cabal-file", "Includes2.cabal"] ++ args) + setup_install' ["mylib", "--cid", "mylib-0.1.0.0"] + setup_install' ["mysql", "--cid", "mysql-0.1.0.0"] + setup_install' ["postgresql", "--cid", "postgresql-0.1.0.0"] + setup_install' ["mylib", "--cid", "mylib-0.1.0.0", + "--instantiate-with", "Database=mysql-0.1.0.0:Database.MySQL"] + setup_install' ["mylib", "--cid", "mylib-0.1.0.0", + "--instantiate-with", "Database=postgresql-0.1.0.0:Database.PostgreSQL"] + setup_install' ["Includes2"] + setup_install' ["exe"] + runExe' "exe" [] >>= assertOutputContains "minemysql minepostgresql" 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 @@ -10,11 +10,13 @@ build-depends: base signatures: Data.Map hs-source-dirs: sigs + default-language: Haskell2010 library indef build-depends: base, sigs exposed-modules: Foo hs-source-dirs: indef + default-language: Haskell2010 executable exe build-depends: base, containers, indef diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.out @@ -0,0 +1,26 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - sigs-0.1.0.0 (lib) (first run) + - indef-0.1.0.0 (lib) (first run) + - indef-0.1.0.0 (lib with Data.Map=containers-:Data.Map) (first run) + - 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.. +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.. +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.. +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.. +# exe exe +fromList [(0,2),(2,4)] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + withProjectFile "cabal.external.project" $ do + cabal "new-build" ["exe"] + withPlan $ do + r <- runPlanExe' "exe" "exe" [] + assertOutputContains "fromList [(0,2),(2,4)]" r diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.out @@ -0,0 +1,28 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - Includes3-0.1.0.0 (lib:sigs) (first run) + - Includes3-0.1.0.0 (lib:indef) (first run) + - Includes3-0.1.0.0 (lib:indef with Data.Map=containers-:Data.Map) (first run) + - Includes3-0.1.0.0 (exe:exe) (first run) +Configuring library 'sigs' for Includes3-0.1.0.0.. +Preprocessing library 'sigs' for Includes3-0.1.0.0.. +Building library 'sigs' instantiated with Data.Map = +for Includes3-0.1.0.0.. +Configuring library 'indef' for Includes3-0.1.0.0.. +Preprocessing library 'indef' for Includes3-0.1.0.0.. +Building library 'indef' instantiated with Data.Map = +for Includes3-0.1.0.0.. +Configuring library 'indef' instantiated with + Data.Map = containers-:Data.Map +for Includes3-0.1.0.0.. +Preprocessing library 'indef' for Includes3-0.1.0.0.. +Building library 'indef' instantiated with + Data.Map = containers-:Data.Map +for Includes3-0.1.0.0.. +Configuring executable 'exe' for Includes3-0.1.0.0.. +Preprocessing executable 'exe' for Includes3-0.1.0.0.. +Building executable 'exe' for Includes3-0.1.0.0.. +# Includes3 exe +fromList [(0,2),(2,4)] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + withProjectFile "cabal.internal.project" $ do + cabal "new-build" ["exe"] + withPlan $ do + r <- runPlanExe' "Includes3" "exe" [] + assertOutputContains "fromList [(0,2),(2,4)]" r diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal.external.project b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal.external.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal.external.project @@ -0,0 +1,1 @@ +packages: exe indef sigs diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal.internal.project b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal.internal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/cabal.internal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/indef/indef.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/indef/indef.cabal --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/indef/indef.cabal +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/indef/indef.cabal @@ -9,3 +9,4 @@ library build-depends: base, sigs exposed-modules: Foo + 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 new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.out @@ -0,0 +1,32 @@ +# Setup configure +Configuring library for sigs-0.1.0.0.. +# Setup build +Preprocessing library for sigs-0.1.0.0.. +Building library instantiated with Data.Map = +for sigs-0.1.0.0.. +# Setup haddock +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 +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Data.Map = +for sigs-0.1.0.0.. +# Setup configure +Configuring library for indef-0.1.0.0.. +# Setup build +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with Data.Map = +for indef-0.1.0.0.. +# Setup haddock +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 +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Data.Map = +for indef-0.1.0.0.. 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 new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-explicit.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +-- NB: cabal-install doesn't understand --dependency +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"] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.cabal.out @@ -0,0 +1,24 @@ +# Setup configure +Resolving dependencies... +Configuring sigs-0.1.0.0... +# Setup build +Preprocessing library for sigs-0.1.0.0.. +Building library instantiated with Data.Map = +for sigs-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Data.Map = +for sigs-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring indef-0.1.0.0... +# Setup build +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with Data.Map = +for indef-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Data.Map = +for indef-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.out @@ -0,0 +1,22 @@ +# Setup configure +Configuring sigs-0.1.0.0... +# Setup build +Preprocessing library for sigs-0.1.0.0.. +Building library instantiated with Data.Map = +for sigs-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Data.Map = +for sigs-0.1.0.0.. +# Setup configure +Configuring indef-0.1.0.0... +# Setup build +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with Data.Map = +for indef-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Data.Map = +for indef-0.1.0.0.. 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 new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-fail.test.hs @@ -0,0 +1,13 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + withPackageDb $ do + withDirectory "sigs" $ setup_install [] + withDirectory "indef" $ setup_install [] + -- Forgot to build the instantiated versions! + withDirectory "exe" $ do + -- Missing package message includes a unit identifier, + -- which wobbles when version numbers change + r <- recordMode DoNotRecord . fails $ setup' "configure" [] + assertOutputContains "indef-0.1.0.0" r + return () 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 new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.cabal.out @@ -0,0 +1,83 @@ +# Setup configure +Resolving dependencies... +Configuring sigs-0.1.0.0... +# Setup build +Preprocessing library for sigs-0.1.0.0.. +Building library instantiated with Data.Map = +for sigs-0.1.0.0.. +# Setup haddock +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 +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Data.Map = +for sigs-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring indef-0.1.0.0... +# Setup build +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with Data.Map = +for indef-0.1.0.0.. +# Setup haddock +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 +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Data.Map = +for indef-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring sigs-0.1.0.0... +# Setup build +Preprocessing library for sigs-0.1.0.0.. +Building library instantiated with Data.Map = containers-:Data.Map +for sigs-0.1.0.0.. +# Setup haddock +Preprocessing library for sigs-0.1.0.0.. +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 +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Data.Map = containers-:Data.Map +for sigs-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring indef-0.1.0.0... +# Setup build +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with Data.Map = containers-:Data.Map +for indef-0.1.0.0.. +# Setup haddock +Preprocessing library for indef-0.1.0.0.. +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 +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Data.Map = containers-:Data.Map +for indef-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring exe-0.1.0.0... +# Setup build +Preprocessing executable 'exe' for exe-0.1.0.0.. +Building executable 'exe' for exe-0.1.0.0.. +# Setup copy +Installing executable exe in +Warning: The directory /setup-external-ok.cabal.dist/usr/bin is not in the system search path. +# Setup register +Package contains no library to register: exe-0.1.0.0... +# exe +fromList [(0,2),(2,4)] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.out @@ -0,0 +1,78 @@ +# Setup configure +Configuring sigs-0.1.0.0... +# Setup build +Preprocessing library for sigs-0.1.0.0.. +Building library instantiated with Data.Map = +for sigs-0.1.0.0.. +# Setup haddock +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 +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Data.Map = +for sigs-0.1.0.0.. +# Setup configure +Configuring indef-0.1.0.0... +# Setup build +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with Data.Map = +for indef-0.1.0.0.. +# Setup haddock +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 +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Data.Map = +for indef-0.1.0.0.. +# Setup configure +Configuring sigs-0.1.0.0... +# Setup build +Preprocessing library for sigs-0.1.0.0.. +Building library instantiated with Data.Map = containers-:Data.Map +for sigs-0.1.0.0.. +# Setup haddock +Preprocessing library for sigs-0.1.0.0.. +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 +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Data.Map = containers-:Data.Map +for sigs-0.1.0.0.. +# Setup configure +Configuring indef-0.1.0.0... +# Setup build +Preprocessing library for indef-0.1.0.0.. +Building library instantiated with Data.Map = containers-:Data.Map +for indef-0.1.0.0.. +# Setup haddock +Preprocessing library for indef-0.1.0.0.. +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 +# Setup copy +Installing library in +# Setup register +Registering library instantiated with Data.Map = containers-:Data.Map +for indef-0.1.0.0.. +# Setup configure +Configuring exe-0.1.0.0... +# Setup build +Preprocessing executable 'exe' for exe-0.1.0.0.. +Building executable 'exe' for exe-0.1.0.0.. +# Setup copy +Installing executable exe in +Warning: The directory /setup-external-ok.dist/usr/bin is not in the system search path. +# Setup register +Package contains no library to register: exe-0.1.0.0... +# exe +fromList [(0,2),(2,4)] 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 new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-external-ok.test.hs @@ -0,0 +1,22 @@ +import Test.Cabal.Prelude +import Data.List +import qualified Data.Char as Char +main = setupAndCabalTest $ do + 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 + -- 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 + -- Ditto. + setup_install_with_docs ["--ipid", "indef-0.1.0.0", + "--instantiate-with", "Data.Map=" ++ containers_id ++ ":Data.Map"] + withDirectory "exe" $ do + setup_install [] + runExe' "exe" [] >>= assertOutputContains "fromList [(0,2),(2,4)]" + diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.cabal.out @@ -0,0 +1,45 @@ +# Setup configure +Resolving dependencies... +Configuring Includes3-0.1.0.0... +# Setup build +Preprocessing library 'sigs' for Includes3-0.1.0.0.. +Building library 'sigs' instantiated with Data.Map = +for Includes3-0.1.0.0.. +Preprocessing library 'indef' for Includes3-0.1.0.0.. +Building library 'indef' instantiated with Data.Map = +for Includes3-0.1.0.0.. +Preprocessing library 'indef' for Includes3-0.1.0.0.. +Building library 'indef' instantiated with + Data.Map = containers-:Data.Map +for Includes3-0.1.0.0.. +Preprocessing executable 'exe' for Includes3-0.1.0.0.. +Building executable 'exe' for Includes3-0.1.0.0.. +# Setup copy +Installing internal library sigs in +Installing internal library indef in +Installing internal library indef in +Installing executable exe in +Warning: The directory /setup-internal.cabal.dist/usr/bin is not in the system search path. +# Setup register +Registering library 'sigs' instantiated with Data.Map = +for Includes3-0.1.0.0.. +Registering library 'indef' instantiated with Data.Map = +for Includes3-0.1.0.0.. +Registering library 'indef' instantiated with + Data.Map = containers-:Data.Map +for Includes3-0.1.0.0.. +# Setup build +Preprocessing library 'sigs' for Includes3-0.1.0.0.. +Building library 'sigs' instantiated with Data.Map = +for Includes3-0.1.0.0.. +Preprocessing library 'indef' for Includes3-0.1.0.0.. +Building library 'indef' instantiated with Data.Map = +for Includes3-0.1.0.0.. +Preprocessing library 'indef' for Includes3-0.1.0.0.. +Building library 'indef' instantiated with + Data.Map = containers-:Data.Map +for Includes3-0.1.0.0.. +Preprocessing executable 'exe' for Includes3-0.1.0.0.. +Building executable 'exe' for Includes3-0.1.0.0.. +# exe +fromList [(0,2),(2,4)] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.out @@ -0,0 +1,44 @@ +# Setup configure +Configuring Includes3-0.1.0.0... +# Setup build +Preprocessing library 'sigs' for Includes3-0.1.0.0.. +Building library 'sigs' instantiated with Data.Map = +for Includes3-0.1.0.0.. +Preprocessing library 'indef' for Includes3-0.1.0.0.. +Building library 'indef' instantiated with Data.Map = +for Includes3-0.1.0.0.. +Preprocessing library 'indef' for Includes3-0.1.0.0.. +Building library 'indef' instantiated with + Data.Map = containers-:Data.Map +for Includes3-0.1.0.0.. +Preprocessing executable 'exe' for Includes3-0.1.0.0.. +Building executable 'exe' for Includes3-0.1.0.0.. +# Setup copy +Installing internal library sigs in +Installing internal library indef in +Installing internal library indef in +Installing executable exe in +Warning: The directory /setup-internal.dist/usr/bin is not in the system search path. +# Setup register +Registering library 'sigs' instantiated with Data.Map = +for Includes3-0.1.0.0.. +Registering library 'indef' instantiated with Data.Map = +for Includes3-0.1.0.0.. +Registering library 'indef' instantiated with + Data.Map = containers-:Data.Map +for Includes3-0.1.0.0.. +# Setup build +Preprocessing library 'sigs' for Includes3-0.1.0.0.. +Building library 'sigs' instantiated with Data.Map = +for Includes3-0.1.0.0.. +Preprocessing library 'indef' for Includes3-0.1.0.0.. +Building library 'indef' instantiated with Data.Map = +for Includes3-0.1.0.0.. +Preprocessing library 'indef' for Includes3-0.1.0.0.. +Building library 'indef' instantiated with + Data.Map = containers-:Data.Map +for Includes3-0.1.0.0.. +Preprocessing executable 'exe' for Includes3-0.1.0.0.. +Building executable 'exe' for Includes3-0.1.0.0.. +# exe +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 new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/setup-internal.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + withPackageDb $ do + setup_install [] + _ <- runM "touch" ["indef/Foo.hs"] + setup "build" [] + runExe' "exe" [] >>= assertOutputContains "fromList [(0,2),(2,4)]" + diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/sigs/sigs.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/sigs/sigs.cabal --- a/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/sigs/sigs.cabal +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes3/sigs/sigs.cabal @@ -9,3 +9,4 @@ library build-depends: base signatures: Data.Map + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes4/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes4/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes4/setup.cabal.out @@ -0,0 +1,40 @@ +# Setup configure +Resolving dependencies... +Configuring Includes4-0.1.0.0... +# Setup build +Preprocessing library 'indef' for Includes4-0.1.0.0.. +Building library 'indef' instantiated with + A = + B = + Rec = +for Includes4-0.1.0.0.. +Preprocessing library 'impl' for Includes4-0.1.0.0.. +Building library 'impl' for Includes4-0.1.0.0.. +Preprocessing library 'indef' for Includes4-0.1.0.0.. +Building library 'indef' instantiated with + A = Includes4-0.1.0.0-impl:A + B = Includes4-0.1.0.0-impl:B + Rec = Includes4-0.1.0.0-impl:Rec +for Includes4-0.1.0.0.. +Preprocessing executable 'exe' for Includes4-0.1.0.0.. +Building executable 'exe' for Includes4-0.1.0.0.. +# Setup copy +Installing internal library indef in +Installing internal library impl in +Installing internal library indef in +Installing executable exe in +Warning: The directory /setup.cabal.dist/usr/bin is not in the system search path. +# Setup register +Registering library 'indef' instantiated with + A = + B = + Rec = +for Includes4-0.1.0.0.. +Registering library 'impl' for Includes4-0.1.0.0.. +Registering library 'indef' instantiated with + A = Includes4-0.1.0.0-impl:A + B = Includes4-0.1.0.0-impl:B + Rec = Includes4-0.1.0.0-impl:Rec +for Includes4-0.1.0.0.. +# exe +A (B (A (B diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes4/setup.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes4/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes4/setup.out @@ -0,0 +1,39 @@ +# Setup configure +Configuring Includes4-0.1.0.0... +# Setup build +Preprocessing library 'indef' for Includes4-0.1.0.0.. +Building library 'indef' instantiated with + A = + B = + Rec = +for Includes4-0.1.0.0.. +Preprocessing library 'impl' for Includes4-0.1.0.0.. +Building library 'impl' for Includes4-0.1.0.0.. +Preprocessing library 'indef' for Includes4-0.1.0.0.. +Building library 'indef' instantiated with + A = Includes4-0.1.0.0-impl:A + B = Includes4-0.1.0.0-impl:B + Rec = Includes4-0.1.0.0-impl:Rec +for Includes4-0.1.0.0.. +Preprocessing executable 'exe' for Includes4-0.1.0.0.. +Building executable 'exe' for Includes4-0.1.0.0.. +# Setup copy +Installing internal library indef in +Installing internal library impl in +Installing internal library indef in +Installing executable exe in +Warning: The directory /setup.dist/usr/bin is not in the system search path. +# Setup register +Registering library 'indef' instantiated with + A = + B = + Rec = +for Includes4-0.1.0.0.. +Registering library 'impl' for Includes4-0.1.0.0.. +Registering library 'indef' instantiated with + A = Includes4-0.1.0.0-impl:A + B = Includes4-0.1.0.0-impl:B + Rec = Includes4-0.1.0.0-impl:Rec +for Includes4-0.1.0.0.. +# exe +A (B (A (B diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes4/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes4/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes4/setup.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + withPackageDb $ do + setup_install [] + runExe' "exe" [] >>= assertOutputContains "A (B (A (B" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes5/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes5/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes5/setup.cabal.out @@ -0,0 +1,10 @@ +# Setup configure +Resolving dependencies... +Configuring Includes5-0.1.0.0... +# Setup build +Preprocessing library 'impl' for Includes5-0.1.0.0.. +Building library 'impl' for Includes5-0.1.0.0.. +Preprocessing library 'good' for Includes5-0.1.0.0.. +Building library 'good' for Includes5-0.1.0.0.. +Preprocessing library 'bad' for Includes5-0.1.0.0.. +Building library 'bad' for Includes5-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes5/setup.out b/cabal/cabal-testsuite/PackageTests/Backpack/Includes5/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes5/setup.out @@ -0,0 +1,9 @@ +# Setup configure +Configuring Includes5-0.1.0.0... +# Setup build +Preprocessing library 'impl' for Includes5-0.1.0.0.. +Building library 'impl' for Includes5-0.1.0.0.. +Preprocessing library 'good' for Includes5-0.1.0.0.. +Building library 'good' for Includes5-0.1.0.0.. +Preprocessing library 'bad' for Includes5-0.1.0.0.. +Building library 'bad' for Includes5-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Includes5/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Includes5/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Includes5/setup.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + setup "configure" [] + r <- fails $ setup' "build" [] + assertOutputContains "Foobar" r + assertOutputContains "Could not find" r + return () diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/Indef2.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/Indef2.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/Indef2.cabal @@ -0,0 +1,16 @@ +name: Indef2 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.25 + +library asig1 + signatures: A + build-depends: base + default-language: Haskell2010 + +library + build-depends: asig1 + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/setup.cabal.out @@ -0,0 +1,10 @@ +# Setup configure +Resolving dependencies... +Configuring Indef2-0.1.0.0... +# Setup build +Preprocessing library 'asig1' for Indef2-0.1.0.0.. +Building library 'asig1' instantiated with A = +for Indef2-0.1.0.0.. +Preprocessing library for Indef2-0.1.0.0.. +Building library instantiated with A = +for Indef2-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/setup.out b/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/setup.out @@ -0,0 +1,9 @@ +# Setup configure +Configuring Indef2-0.1.0.0... +# Setup build +Preprocessing library 'asig1' for Indef2-0.1.0.0.. +Building library 'asig1' instantiated with A = +for Indef2-0.1.0.0.. +Preprocessing library for Indef2-0.1.0.0.. +Building library instantiated with A = +for Indef2-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Indef2/setup.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + setup "configure" [] + setup "build" [] + return () diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.cabal.out @@ -0,0 +1,24 @@ +# Setup configure +Resolving dependencies... +Configuring p-0.1.0.0... +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup haddock +Preprocessing library for p-0.1.0.0.. +Running Haddock on library for p-0.1.0.0.. +Documentation created: ../setup.cabal.dist/work/p/dist/doc/html/p/index.html +# Setup copy +Installing library in +# Setup register +Registering library for p-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring q-0.1.0.0... +# Setup build +Preprocessing library for q-0.1.0.0.. +Building library for q-0.1.0.0.. +# Setup haddock +Preprocessing library for q-0.1.0.0.. +Running Haddock on library for q-0.1.0.0.. +Documentation created: ../setup.cabal.dist/work/q/dist/doc/html/q/index.html diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.out b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.out @@ -0,0 +1,22 @@ +# Setup configure +Configuring p-0.1.0.0... +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup haddock +Preprocessing library for p-0.1.0.0.. +Running Haddock on library for p-0.1.0.0.. +Documentation created: ../setup.dist/work/p/dist/doc/html/p/index.html +# Setup copy +Installing library in +# Setup register +Registering library for p-0.1.0.0.. +# Setup configure +Configuring q-0.1.0.0... +# Setup build +Preprocessing library for q-0.1.0.0.. +Building library for q-0.1.0.0.. +# Setup haddock +Preprocessing library for q-0.1.0.0.. +Running Haddock on library for q-0.1.0.0.. +Documentation created: ../setup.dist/work/q/dist/doc/html/q/index.html diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport1/setup.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + withPackageDb $ do + withDirectory "p" $ setup_install_with_docs [] + withDirectory "q" $ do + setup_build [] + setup "haddock" [] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/Asdf.hsig b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/Asdf.hsig new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/Asdf.hsig @@ -0,0 +1,1 @@ +signature Asdf where diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/Reexport2.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/Reexport2.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/Reexport2.cabal @@ -0,0 +1,10 @@ +name: Reexport2 +version: 1.0 +build-type: Simple +cabal-version: >= 1.25 + +library + signatures: Asdf + reexported-modules: Asdf + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/cabal.out @@ -0,0 +1,10 @@ +# cabal new-build +Resolving dependencies... +Error: + Problem with module re-exports: + - The module 'Asdf' + is not exported by any suitable package. + It occurs in neither the 'exposed-modules' of this package, + nor any of its 'build-depends' dependencies. + In the stanza 'library' + In the inplace package 'Reexport2-1.0' diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/cabal.project b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + r <- fails $ cabal' "new-build" [] + assertOutputContains "Asdf" r + assertOutputContains "Reexport2" r diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.cabal.out @@ -0,0 +1,4 @@ +# Setup configure +Resolving dependencies... +Configuring Reexport2-1.0... +cabal: Duplicate modules in library: Asdf diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.out b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.out @@ -0,0 +1,3 @@ +# Setup configure +Configuring Reexport2-1.0... +setup: Duplicate modules in library: Asdf diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/Reexport2/setup.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + fails (setup' "configure" []) + >>= assertRegex "Expect problem with Asdf" "Asdf" diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4447/A.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/A.hs @@ -0,0 +1,1 @@ +module A where diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4447/Main.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/Main.hs @@ -0,0 +1,2 @@ +module Main where +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4447/T4447.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/T4447.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/T4447.cabal @@ -0,0 +1,17 @@ +name: T4447 +version: 1.0 +cabal-version: >= 2.0 +build-type: Simple + +library foo-indef + exposed-modules: B + signatures: A + build-depends: base + hs-source-dirs: foo-indef + default-language: Haskell2010 + +executable foo-exe + build-depends: foo-indef, base + other-modules: A + main-is: Main.hs + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4447/cabal.project b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4447/foo-indef/A.hsig b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/foo-indef/A.hsig new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/foo-indef/A.hsig @@ -0,0 +1,1 @@ +signature A where diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4447/foo-indef/B.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/foo-indef/B.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/foo-indef/B.hs @@ -0,0 +1,1 @@ +module B where diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4447/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/setup.cabal.out @@ -0,0 +1,10 @@ +# Setup configure +Resolving dependencies... +Configuring T4447-1.0... +Error: + Cannot instantiate requirement 'A' brought into scope by build-depends: T4447:foo-indef + with locally defined module brought into scope by other-modules: A + as this would create a cyclic dependency, which GHC does not support. + Try moving this module to a separate library, e.g., + create a new stanza: library 'sublib'. + In the stanza executable foo-exe diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4447/setup.out b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/setup.out @@ -0,0 +1,9 @@ +# Setup configure +Configuring T4447-1.0... +Error: + Cannot instantiate requirement 'A' brought into scope by build-depends: T4447:foo-indef + with locally defined module brought into scope by other-modules: A + as this would create a cyclic dependency, which GHC does not support. + Try moving this module to a separate library, e.g., + create a new stanza: library 'sublib'. + In the stanza executable foo-exe diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4447/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4447/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + fails $ setup "configure" [] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4754/P.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/P.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/P.hs @@ -0,0 +1,3 @@ +module P where +import Sig + diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4754/Sig.hsig b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/Sig.hsig new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/Sig.hsig @@ -0,0 +1,1 @@ +signature Sig where diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4754/p.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/p.cabal @@ -0,0 +1,15 @@ +name: p +version: 0.1 +cabal-version: >= 2.0 +build-type: Simple + +library + exposed-modules: P + signatures: Sig + build-depends: base + +executable pexe + build-depends: p, base + mixins: base, base (Prelude as Sig) + main-is: PExe.hs + hs-source-dirs: pexe diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4754/pexe/PExe.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/pexe/PExe.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/pexe/PExe.hs @@ -0,0 +1,2 @@ +import P +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4754/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/setup.cabal.out @@ -0,0 +1,13 @@ +# Setup configure +Resolving dependencies... +Configuring p-0.1... +Warning: Packages using 'cabal-version: >= 1.10' must specify the 'default-language' field for each component (e.g. Haskell98 or Haskell2010). If a component uses different languages in different modules then list the other ones in the 'other-languages' field. +# Setup build +Preprocessing library for p-0.1.. +Building library instantiated with Sig = +for p-0.1.. +Preprocessing library for p-0.1.. +Building library instantiated with Sig = base-:Prelude +for p-0.1.. +Preprocessing executable 'pexe' for p-0.1.. +Building executable 'pexe' for p-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4754/setup.out b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/setup.out @@ -0,0 +1,12 @@ +# Setup configure +Configuring p-0.1... +Warning: Packages using 'cabal-version: >= 1.10' must specify the 'default-language' field for each component (e.g. Haskell98 or Haskell2010). If a component uses different languages in different modules then list the other ones in the 'other-languages' field. +# Setup build +Preprocessing library for p-0.1.. +Building library instantiated with Sig = +for p-0.1.. +Preprocessing library for p-0.1.. +Building library instantiated with Sig = base-:Prelude +for p-0.1.. +Preprocessing executable 'pexe' for p-0.1.. +Building executable 'pexe' for p-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/T4754/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/T4754/setup.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + skipUnless =<< hasProfiledLibraries + setup "configure" ["--enable-profiling"] + setup "build" [] diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/A.hsig b/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/A.hsig new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/A.hsig @@ -0,0 +1,1 @@ +signature A where diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/M.hs b/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/M.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/M.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TemplateHaskell #-} +module M where +$( [d| x = True |] ) diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/bkpth.cabal b/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/bkpth.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/bkpth.cabal @@ -0,0 +1,14 @@ +name: bkpth +version: 1.0 +build-type: Simple +cabal-version: >= 1.25 + +library helper + signatures: A + build-depends: base + default-language: Haskell2010 + +library + exposed-modules: M + build-depends: base, helper + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.cabal.out @@ -0,0 +1,10 @@ +# Setup configure +Resolving dependencies... +Configuring bkpth-1.0... +# Setup build +Preprocessing library 'helper' for bkpth-1.0.. +Building library 'helper' instantiated with A = +for bkpth-1.0.. +Preprocessing library for bkpth-1.0.. +Building library instantiated with A = +for bkpth-1.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.out b/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.out @@ -0,0 +1,9 @@ +# Setup configure +Configuring bkpth-1.0... +# Setup build +Preprocessing library 'helper' for bkpth-1.0.. +Building library 'helper' instantiated with A = +for bkpth-1.0.. +Preprocessing library for bkpth-1.0.. +Building library instantiated with A = +for bkpth-1.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Backpack/TemplateHaskell/setup.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [8,1]) + setup "configure" [] + setup "build" [] diff --git a/cabal/cabal-testsuite/PackageTests/BenchmarkExeV10/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BenchmarkExeV10/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BenchmarkExeV10/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Resolving dependencies... +Configuring my-0.1... +# Setup build +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Preprocessing benchmark 'bench-Foo' for my-0.1.. +Building benchmark 'bench-Foo' for my-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/BenchmarkExeV10/setup.out b/cabal/cabal-testsuite/PackageTests/BenchmarkExeV10/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BenchmarkExeV10/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring my-0.1... +# Setup build +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Preprocessing benchmark 'bench-Foo' for my-0.1.. +Building benchmark 'bench-Foo' for my-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/BenchmarkExeV10/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BenchmarkExeV10/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BenchmarkExeV10/setup.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +-- Test if exitcode-stdio-1.0 benchmark builds correctly +main = setupAndCabalTest $ setup_build ["--enable-benchmarks"] diff --git a/cabal/cabal-testsuite/PackageTests/BenchmarkOptions/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BenchmarkOptions/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BenchmarkOptions/setup.cabal.out @@ -0,0 +1,20 @@ +# Setup configure +Resolving dependencies... +Configuring BenchmarkOptions-0.1... +# Setup build +Preprocessing benchmark 'test-BenchmarkOptions' for BenchmarkOptions-0.1.. +Building benchmark 'test-BenchmarkOptions' for BenchmarkOptions-0.1.. +Preprocessing executable 'dummy' for BenchmarkOptions-0.1.. +Building executable 'dummy' for BenchmarkOptions-0.1.. +# Setup bench +Preprocessing benchmark 'test-BenchmarkOptions' for BenchmarkOptions-0.1.. +Building benchmark 'test-BenchmarkOptions' for BenchmarkOptions-0.1.. +Running 1 benchmarks... +Benchmark test-BenchmarkOptions: RUNNING... +Benchmark test-BenchmarkOptions: FINISH +# Setup bench +Preprocessing benchmark 'test-BenchmarkOptions' for BenchmarkOptions-0.1.. +Building benchmark 'test-BenchmarkOptions' for BenchmarkOptions-0.1.. +Running 1 benchmarks... +Benchmark test-BenchmarkOptions: RUNNING... +Benchmark test-BenchmarkOptions: FINISH diff --git a/cabal/cabal-testsuite/PackageTests/BenchmarkOptions/setup.out b/cabal/cabal-testsuite/PackageTests/BenchmarkOptions/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BenchmarkOptions/setup.out @@ -0,0 +1,15 @@ +# Setup configure +Configuring BenchmarkOptions-0.1... +# Setup build +Preprocessing benchmark 'test-BenchmarkOptions' for BenchmarkOptions-0.1.. +Building benchmark 'test-BenchmarkOptions' for BenchmarkOptions-0.1.. +Preprocessing executable 'dummy' for BenchmarkOptions-0.1.. +Building executable 'dummy' for BenchmarkOptions-0.1.. +# Setup bench +Running 1 benchmarks... +Benchmark test-BenchmarkOptions: RUNNING... +Benchmark test-BenchmarkOptions: FINISH +# Setup bench +Running 1 benchmarks... +Benchmark test-BenchmarkOptions: RUNNING... +Benchmark test-BenchmarkOptions: FINISH diff --git a/cabal/cabal-testsuite/PackageTests/BenchmarkOptions/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BenchmarkOptions/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BenchmarkOptions/setup.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude +-- Test --benchmark-option(s) flags on ./Setup bench +main = setupAndCabalTest $ do + setup_build ["--enable-benchmarks"] + setup "bench" [ "--benchmark-options=1 2 3" ] + setup "bench" [ "--benchmark-option=1" + , "--benchmark-option=2" + , "--benchmark-option=3" + ] diff --git a/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/Check.hs b/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/Check.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/Check.hs +++ /dev/null @@ -1,29 +0,0 @@ -module PackageTests.BenchmarkStanza.Check where - -import PackageTests.PackageTester - -import Distribution.Version -import Distribution.Simple.LocalBuildInfo -import Distribution.Package -import Distribution.PackageDescription - -suite :: TestM () -suite = do - assertOutputDoesNotContain "unknown section type" - =<< cabal' "configure" [] - dist_dir <- distDir - lbi <- liftIO $ getPersistBuildConfig dist_dir - let anticipatedBenchmark = emptyBenchmark - { benchmarkName = mkUnqualComponentName "dummy" - , benchmarkInterface = BenchmarkExeV10 (mkVersion [1,0]) - "dummy.hs" - , benchmarkBuildInfo = emptyBuildInfo - { targetBuildDepends = - [ Dependency (mkPackageName "base") anyVersion ] - , hsSourceDirs = ["."] - } - } - gotBenchmark = head $ benchmarks (localPkgDescr lbi) - assertEqual "parsed benchmark stanza does not match anticipated" - anticipatedBenchmark gotBenchmark - return () diff --git a/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/my.cabal b/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/my.cabal --- a/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/my.cabal +++ b/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/my.cabal @@ -5,6 +5,7 @@ stability: stable category: PackageTests build-type: Simple +cabal-version: >= 1.10 description: Check that Cabal recognizes the benchmark stanza defined below. diff --git a/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/setup.cabal.out @@ -0,0 +1,4 @@ +# Setup configure +Resolving dependencies... +Configuring BenchmarkStanza-0.1... +Warning: Packages using 'cabal-version: >= 1.10' must specify the 'default-language' field for each component (e.g. Haskell98 or Haskell2010). If a component uses different languages in different modules then list the other ones in the 'other-languages' field. diff --git a/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/setup.out b/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/setup.out @@ -0,0 +1,3 @@ +# Setup configure +Configuring BenchmarkStanza-0.1... +Warning: Packages using 'cabal-version: >= 1.10' must specify the 'default-language' field for each component (e.g. Haskell98 or Haskell2010). If a component uses different languages in different modules then list the other ones in the 'other-languages' field. diff --git a/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BenchmarkStanza/setup.test.hs @@ -0,0 +1,27 @@ +import Test.Cabal.Prelude + +import Distribution.Version +import Distribution.Simple.LocalBuildInfo +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Types.UnqualComponentName +import Control.Monad.IO.Class +import Distribution.Simple.Configure + +main = setupAndCabalTest $ do + assertOutputDoesNotContain "unknown section type" + =<< setup' "configure" ["--enable-benchmarks"] + lbi <- getLocalBuildInfoM + let gotBenchmark = head $ benchmarks (localPkgDescr lbi) + assertEqual "benchmarkName" + (mkUnqualComponentName "dummy") + (benchmarkName gotBenchmark) + assertEqual "benchmarkInterface" + (BenchmarkExeV10 (mkVersion [1,0]) "dummy.hs") + (benchmarkInterface gotBenchmark) + -- NB: Not testing targetBuildDepends (benchmarkBuildInfo gotBenchmark), + -- as the dependency varies with cabal-install + assertEqual "benchmarkBuildInfo/hsSourceDirs" + ["."] + (hsSourceDirs (benchmarkBuildInfo gotBenchmark)) + return () diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/DepCycle.cabal b/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/DepCycle.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/DepCycle.cabal @@ -0,0 +1,12 @@ +name: DepCycle +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +library foo + build-depends: bar + default-language: Haskell2010 + +library bar + build-depends: foo + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/cabal.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/cabal.out @@ -0,0 +1,7 @@ +# cabal new-build +Resolving dependencies... +Error: + Dependency cycle between the following components: + library bar + library foo + In the inplace package 'DepCycle-1.0' diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/cabal.project b/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/cabal.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + r <- fails $ cabal' "new-build" [] + assertOutputContains "cycl" r -- match cyclic or cycle + assertOutputContains "bar" r + assertOutputContains "foo" r + assertOutputContains "DepCycle" r diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/setup.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring DepCycle-1.0... +Error: + Components in the package depend on each other in a cyclic way: + 'library 'bar'' depends on 'library 'foo'' depends on 'library 'bar'' diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/setup.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring DepCycle-1.0... +Error: + Components in the package depend on each other in a cyclic way: + 'library 'bar'' depends on 'library 'foo'' depends on 'library 'bar'' diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/DepCycle/setup.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + r <- fails $ setup' "configure" [] + assertOutputContains "cycl" r -- match cyclic or cycle + assertOutputContains "bar" r + assertOutputContains "foo" r diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.cabal.out @@ -0,0 +1,4 @@ +# Setup configure +Resolving dependencies... +Configuring InternalLibrary0-0.1... +cabal: The field 'build-depends: InternalLibrary0' refers to a library which is defined within the same package. To use this feature the package must specify at least 'cabal-version: >= 1.8'. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.out @@ -0,0 +1,3 @@ +# Setup configure +Configuring InternalLibrary0-0.1... +setup: The field 'build-depends: InternalLibrary0' refers to a library which is defined within the same package. To use this feature the package must specify at least 'cabal-version: >= 1.8'. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary0/setup.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude +-- Test attempt to have executable depend on internal +-- library, but setup-version is too old. +main = setupAndCabalTest $ do + r <- fails $ setup' "configure" [] + -- Should tell you how to enable the desired behavior + let sb = "library which is defined within the same package." + assertOutputContains sb r diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.out @@ -0,0 +1,10 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - InternalLibrary1-0.1 (exe:lemon) (first run) +Configuring InternalLibrary1-0.1... +Preprocessing library for InternalLibrary1-0.1.. +Building library for InternalLibrary1-0.1.. +Preprocessing executable 'lemon' for InternalLibrary1-0.1.. +Building executable 'lemon' for InternalLibrary1-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.project b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + cabal "new-build" ["lemon"] diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Resolving dependencies... +Configuring InternalLibrary1-0.1... +# Setup build +Preprocessing library for InternalLibrary1-0.1.. +Building library for InternalLibrary1-0.1.. +Preprocessing executable 'lemon' for InternalLibrary1-0.1.. +Building executable 'lemon' for InternalLibrary1-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/setup.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring InternalLibrary1-0.1... +# Setup build +Preprocessing library for InternalLibrary1-0.1.. +Building library for InternalLibrary1-0.1.. +Preprocessing executable 'lemon' for InternalLibrary1-0.1.. +Building executable 'lemon' for InternalLibrary1-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary1/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +-- Test executable depends on internal library. +main = setupAndCabalTest $ setup_build [] + diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/setup.cabal.out @@ -0,0 +1,22 @@ +# Setup configure +Resolving dependencies... +Configuring InternalLibrary2-0.1... +# Setup build +Preprocessing library for InternalLibrary2-0.1.. +Building library for InternalLibrary2-0.1.. +# Setup copy +Installing library in +# Setup register +Registering library for InternalLibrary2-0.1.. +# Setup configure +Resolving dependencies... +Configuring InternalLibrary2-0.1... +# Setup build +Preprocessing library for InternalLibrary2-0.1.. +Building library for InternalLibrary2-0.1.. +Preprocessing executable 'lemon' for InternalLibrary2-0.1.. +Building executable 'lemon' for InternalLibrary2-0.1.. +# lemon +foo +foo +myLibFunc internal diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/setup.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/setup.out @@ -0,0 +1,20 @@ +# Setup configure +Configuring InternalLibrary2-0.1... +# Setup build +Preprocessing library for InternalLibrary2-0.1.. +Building library for InternalLibrary2-0.1.. +# Setup copy +Installing library in +# Setup register +Registering library for InternalLibrary2-0.1.. +# Setup configure +Configuring InternalLibrary2-0.1... +# Setup build +Preprocessing library for InternalLibrary2-0.1.. +Building library for InternalLibrary2-0.1.. +Preprocessing executable 'lemon' for InternalLibrary2-0.1.. +Building executable 'lemon' for InternalLibrary2-0.1.. +# lemon +foo +foo +myLibFunc internal diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary2/setup.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest . withPackageDb $ do + withDirectory "to-install" $ setup_install [] + setup_build [] + r <- runExe' "lemon" [] + assertEqual + ("executable should have linked with the internal library") + ("foo foo myLibFunc internal") + (concatOutput (resultOutput r)) diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/setup.cabal.out @@ -0,0 +1,22 @@ +# Setup configure +Resolving dependencies... +Configuring InternalLibrary3-0.2... +# Setup build +Preprocessing library for InternalLibrary3-0.2.. +Building library for InternalLibrary3-0.2.. +# Setup copy +Installing library in +# Setup register +Registering library for InternalLibrary3-0.2.. +# Setup configure +Resolving dependencies... +Configuring InternalLibrary3-0.1... +# Setup build +Preprocessing library for InternalLibrary3-0.1.. +Building library for InternalLibrary3-0.1.. +Preprocessing executable 'lemon' for InternalLibrary3-0.1.. +Building executable 'lemon' for InternalLibrary3-0.1.. +# lemon +foo +foo +myLibFunc internal diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/setup.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/setup.out @@ -0,0 +1,20 @@ +# Setup configure +Configuring InternalLibrary3-0.2... +# Setup build +Preprocessing library for InternalLibrary3-0.2.. +Building library for InternalLibrary3-0.2.. +# Setup copy +Installing library in +# Setup register +Registering library for InternalLibrary3-0.2.. +# Setup configure +Configuring InternalLibrary3-0.1... +# Setup build +Preprocessing library for InternalLibrary3-0.1.. +Building library for InternalLibrary3-0.1.. +Preprocessing executable 'lemon' for InternalLibrary3-0.1.. +Building executable 'lemon' for InternalLibrary3-0.1.. +# lemon +foo +foo +myLibFunc internal diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary3/setup.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude +-- Test that internal library is preferred to an installed on +-- with the same name and LATER version +main = setupAndCabalTest . withPackageDb $ do + withDirectory "to-install" $ setup_install [] + setup_build [] + r <- runExe' "lemon" [] + assertEqual + ("executable should have linked with the internal library") + ("foo foo myLibFunc internal") + (concatOutput (resultOutput r)) diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import Text.PrettyPrint - -myLibFunc :: IO () -myLibFunc = do - putStrLn (render (text "foo")) - let text = "myLibFunc internal" - C.putStrLn $ C.pack text diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/my.cabal b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/my.cabal deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/my.cabal +++ /dev/null @@ -1,23 +0,0 @@ -name: InternalLibrary4 -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - This test is to make sure that we can explicitly say we want InternalLibrary4-0.2 - and it will give us the *installed* version 0.2 instead of the internal 0.1. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, pretty - -Executable lemon - main-is: lemon.hs - hs-source-dirs: programs - build-depends: base, bytestring, pretty, InternalLibrary4 >= 0.2 diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs +++ /dev/null @@ -1,6 +0,0 @@ -import Text.PrettyPrint -import MyLibrary - -main = do - putStrLn (render (text "foo")) - myLibFunc diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs +++ /dev/null @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import Text.PrettyPrint - -myLibFunc :: IO () -myLibFunc = do - putStrLn (render (text "foo")) - let text = "myLibFunc installed" - C.putStrLn $ C.pack text diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal b/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal +++ /dev/null @@ -1,18 +0,0 @@ -name: InternalLibrary4 -version: 0.2 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - This test is to make sure that the internal library is preferred by ghc to - an installed one of the same name but a *newer* version. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, pretty diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/setup.cabal.out @@ -0,0 +1,10 @@ +# Setup configure +Resolving dependencies... +Configuring SameDepsAllRound-0.1... +# Setup build +Preprocessing executable 'pineapple' for SameDepsAllRound-0.1.. +Building executable 'pineapple' for SameDepsAllRound-0.1.. +Preprocessing executable 'lemon' for SameDepsAllRound-0.1.. +Building executable 'lemon' for SameDepsAllRound-0.1.. +Preprocessing library for SameDepsAllRound-0.1.. +Building library for SameDepsAllRound-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/setup.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/setup.out @@ -0,0 +1,9 @@ +# Setup configure +Configuring SameDepsAllRound-0.1... +# Setup build +Preprocessing executable 'pineapple' for SameDepsAllRound-0.1.. +Building executable 'pineapple' for SameDepsAllRound-0.1.. +Preprocessing executable 'lemon' for SameDepsAllRound-0.1.. +Building executable 'lemon' for SameDepsAllRound-0.1.. +Preprocessing library for SameDepsAllRound-0.1.. +Building library for SameDepsAllRound-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/SameDepsAllRound/setup.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +-- Test "old build-dep behavior", where we should get the +-- same package dependencies on all targets if setup-version +-- is sufficiently old. +main = setupAndCabalTest $ setup_build [] + diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Resolving dependencies... +Configuring TargetSpecificDeps1-0.1... +# Setup build +Preprocessing executable 'lemon' for TargetSpecificDeps1-0.1.. +Building executable 'lemon' for TargetSpecificDeps1-0.1.. +Preprocessing library for TargetSpecificDeps1-0.1.. +Building library for TargetSpecificDeps1-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/setup.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring TargetSpecificDeps1-0.1... +# Setup build +Preprocessing executable 'lemon' for TargetSpecificDeps1-0.1.. +Building executable 'lemon' for TargetSpecificDeps1-0.1.. +Preprocessing library for TargetSpecificDeps1-0.1.. +Building library for TargetSpecificDeps1-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps1/setup.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude +-- Test "new build-dep behavior", where each target gets +-- separate dependencies. This tests that an executable +-- dep does not leak into the library. +main = setupAndCabalTest $ do + setup "configure" [] + r <- fails $ setup' "build" [] + assertRegex "error should be in MyLibrary.hs" "^MyLibrary.hs:" r + assertRegex + "error should be \"Could not find module `Text\\.PrettyPrint\"" + "(Could not find module|Failed to load interface for).*Text\\.PrettyPrint" r diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Resolving dependencies... +Configuring TargetSpecificDeps1-0.1... +# Setup build +Preprocessing executable 'lemon' for TargetSpecificDeps1-0.1.. +Building executable 'lemon' for TargetSpecificDeps1-0.1.. +Preprocessing library for TargetSpecificDeps1-0.1.. +Building library for TargetSpecificDeps1-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/setup.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring TargetSpecificDeps1-0.1... +# Setup build +Preprocessing executable 'lemon' for TargetSpecificDeps1-0.1.. +Building executable 'lemon' for TargetSpecificDeps1-0.1.. +Preprocessing library for TargetSpecificDeps1-0.1.. +Building library for TargetSpecificDeps1-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps2/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +-- This is a control on ../TargetSpecificDeps1/setup.test.hs; it should +-- succeed. +main = setupAndCabalTest $ setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/setup.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring test-0.1... +# Setup build +Preprocessing executable 'lemon' for test-0.1.. +Building executable 'lemon' for test-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/setup.out b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring test-0.1... +# Setup build +Preprocessing executable 'lemon' for test-0.1.. +Building executable 'lemon' for test-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildDeps/TargetSpecificDeps3/setup.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude +-- Test "new build-dep behavior", where each target gets +-- separate dependencies. This tests that an library +-- dep does not leak into the executable. +main = setupAndCabalTest $ do + setup "configure" [] + r <- fails $ setup' "build" [] + assertRegex "error should be in lemon.hs" "^lemon.hs:" r + assertRegex + "error should be \"Could not find module `Text\\.PrettyPrint\"" + "(Could not find module|Failed to load interface for).*Text\\.PrettyPrint" r diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargetErrors/setup.out b/cabal/cabal-testsuite/PackageTests/BuildTargetErrors/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargetErrors/setup.out @@ -0,0 +1,4 @@ +# Setup configure +Configuring BuildTargetErrors-1.0... +# Setup build +setup: Cannot process the executable 'not-buildable-exe' because the component is marked as disabled in the .cabal file. diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargetErrors/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildTargetErrors/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargetErrors/setup.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude +-- Test error message we report when a non-buildable target is +-- requested to be built +-- TODO: We can give a better error message here, see #3858. +-- NB: Do NOT test on cabal-install, as we fail differently +-- in that case +main = setupTest $ do + setup "configure" [] + assertOutputContains "the component is marked as disabled" + =<< fails (setup' "build" ["not-buildable-exe"]) diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/Main.hs b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/Main.hs @@ -0,0 +1,1 @@ +main = putStrLn "local pkg-1.0" diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/cabal.project b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/pkg.cabal b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/pkg.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/pkg.cabal @@ -0,0 +1,8 @@ +name: pkg +version: 1.0 +build-type: Simple +cabal-version: >= 1.2 + +executable my-exe + main-is: Main.hs + build-depends: base diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/repo/pkg-1.0/pkg.cabal b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/repo/pkg-1.0/pkg.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/repo/pkg-1.0/pkg.cabal @@ -0,0 +1,8 @@ +name: pkg +version: 1.0 +build-type: Simple +cabal-version: >= 1.2 + +executable my-exe + main-is: Main.hs + build-depends: base diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/repo/pkg-2.0/pkg.cabal b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/repo/pkg-2.0/pkg.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/repo/pkg-2.0/pkg.cabal @@ -0,0 +1,8 @@ +name: pkg +version: 2.0 +build-type: Simple +cabal-version: >= 1.2 + +executable my-exe + main-is: Main.hs + build-depends: base diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.out b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.out @@ -0,0 +1,19 @@ +# cabal update +Downloading the latest package list from test-local-repo +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - pkg-1.0 (exe:my-exe) (first run) +Configuring pkg-1.0... +Preprocessing executable 'my-exe' for pkg-1.0.. +Building executable 'my-exe' for pkg-1.0.. +# pkg my-exe +local pkg-1.0 +# cabal new-build +Resolving dependencies... +cabal: Could not resolve dependencies: +next goal: pkg (user goal) +rejecting: pkg-2.0 (constraint from user target requires ==1.0) +rejecting: pkg-1.0 (constraint from command line flag requires ==2.0) +After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: pkg (3) diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.test.hs b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.test.hs @@ -0,0 +1,15 @@ +import Test.Cabal.Prelude + +-- Test that "cabal new-build pkg" builds the local pkg-1.0, which has an exe +-- that prints a unique message. It should not build 1.0 or 2.0 from the +-- repository. +main = cabalTest $ withRepo "repo" $ do + cabal "new-build" ["pkg"] + withPlan $ do + r <- runPlanExe' "pkg" "my-exe" [] + assertOutputContains "local pkg-1.0" r + + -- cabal shouldn't build a package from the repo, even when given a constraint + -- that only matches a non-local package. + r <- fails $ cabal' "new-build" ["pkg", "--constraint=pkg==2.0"] + assertOutputContains "rejecting: pkg-2.0" r diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/cabal.project b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/cabal.project @@ -0,0 +1,1 @@ +packages: */*.cabal diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/pkg/Main.hs b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/pkg/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/pkg/Main.hs @@ -0,0 +1,3 @@ +import Module (message) + +main = putStrLn $ "Main.hs: " ++ message diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/pkg/Setup.hs b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/pkg/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/pkg/Setup.hs @@ -0,0 +1,4 @@ +import Module (message) +import Distribution.Simple + +main = putStrLn ("Setup.hs: " ++ message) >> defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/pkg/pkg.cabal b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/pkg/pkg.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/pkg/pkg.cabal @@ -0,0 +1,12 @@ +name: pkg +version: 1.0 +build-type: Custom +cabal-version: >= 1.20 + +custom-setup + setup-depends: base, Cabal, setup-dep == 2.* + +executable my-exe + main-is: Main.hs + build-depends: base, setup-dep == 1.* + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/repo/setup-dep-1.0/Module.hs b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/repo/setup-dep-1.0/Module.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/repo/setup-dep-1.0/Module.hs @@ -0,0 +1,3 @@ +module Module (message) where + +message = "setup-dep from repo" diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/repo/setup-dep-1.0/setup-dep.cabal b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/repo/setup-dep-1.0/setup-dep.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/repo/setup-dep-1.0/setup-dep.cabal @@ -0,0 +1,9 @@ +name: setup-dep +version: 1.0 +build-type: Simple +cabal-version: >= 1.20 + +library + build-depends: base + exposed-modules: Module + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/setup-dep/Module.hs b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/setup-dep/Module.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/setup-dep/Module.hs @@ -0,0 +1,3 @@ +module Module (message) where + +message = "setup-dep from project" diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/setup-dep/setup-dep.cabal b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/setup-dep/setup-dep.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/setup-dep/setup-dep.cabal @@ -0,0 +1,9 @@ +name: setup-dep +version: 2.0 +build-type: Simple +cabal-version: >= 1.20 + +library + build-depends: base + exposed-modules: Module + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.out b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.out @@ -0,0 +1,13 @@ +# cabal update +Downloading the latest package list from test-local-repo +# cabal new-build +Resolving dependencies... +cabal: Could not resolve dependencies: +trying: pkg-1.0 (user goal) +next goal: setup-dep (user goal) +rejecting: setup-dep-2.0 (conflict: pkg => setup-dep==1.*) +rejecting: setup-dep-1.0 (constraint from user target requires ==2.0) +fail (backjumping, conflict set: pkg, setup-dep) +After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: setup-dep (3), pkg (2) +# pkg my-exe +Main.hs: setup-dep from repo diff --git a/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.test.hs b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.test.hs @@ -0,0 +1,25 @@ +import Test.Cabal.Prelude + +-- This test case is a simplified version of #4295. There is a local package, +-- pkg-1.0, which has a setup dependency on setup-dep==2.*. The repo contains +-- setup-dep-1.0, and the project contains the newer version, setup-dep-2.0. +-- pkg-1.0 also has a non-setup dependency on setup-dep==1.*. +-- +-- The solution to the dependency problem must use the local setup-dep only as a +-- setup dependency for pkg. This means that setup-dep cannot use the same +-- qualifier as pkg, even though they are both build targets of the project. +-- The solution must use --independent-goals to give pkg and setup-dep different +-- qualifiers. +main = cabalTest $ do + skipUnless =<< hasNewBuildCompatBootCabal + withRepo "repo" $ do + fails $ cabal "new-build" ["pkg:my-exe", "--dry-run"] + -- Disabled recording because whether or not we get + -- detailed information for the build of my-exe depends + -- on whether or not the Cabal library version is recent + -- enough + r1 <- recordMode DoNotRecord $ cabal' "new-build" ["pkg:my-exe", "--independent-goals"] + assertOutputContains "Setup.hs: setup-dep from project" r1 + withPlan $ do + r2 <- runPlanExe' "pkg" "my-exe" [] + assertOutputContains "Main.hs: setup-dep from repo" r2 diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolDepends/cabal.project b/cabal/cabal-testsuite/PackageTests/BuildToolDepends/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildToolDepends/cabal.project @@ -0,0 +1,2 @@ +packages: client +optional-packages: pre-proc diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolDepends/client/Hello.hs b/cabal/cabal-testsuite/PackageTests/BuildToolDepends/client/Hello.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildToolDepends/client/Hello.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -F -pgmF zero-to-one #-} +module Main where + +a :: String +a = "0000" + +main :: IO () +main = putStrLn a diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolDepends/client/client.cabal b/cabal/cabal-testsuite/PackageTests/BuildToolDepends/client/client.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildToolDepends/client/client.cabal @@ -0,0 +1,13 @@ +name: client +version: 0.1.0.0 +synopsis: Checks build-tool-depends are put in PATH +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +executable hello-world + main-is: Hello.hs + build-depends: base + build-tool-depends: pre-proc:zero-to-one + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolDepends/pre-proc/MyCustomPreprocessor.hs b/cabal/cabal-testsuite/PackageTests/BuildToolDepends/pre-proc/MyCustomPreprocessor.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildToolDepends/pre-proc/MyCustomPreprocessor.hs @@ -0,0 +1,11 @@ +module Main where + +import System.Environment +import System.IO + +main :: IO () +main = do + (_:source:target:_) <- getArgs + let f '0' = '1' + f c = c + writeFile target . map f =<< readFile source diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolDepends/pre-proc/pre-proc.cabal b/cabal/cabal-testsuite/PackageTests/BuildToolDepends/pre-proc/pre-proc.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildToolDepends/pre-proc/pre-proc.cabal @@ -0,0 +1,17 @@ +name: pre-proc +version: 999.999.999 +synopsis: Checks build-tool-depends are put in PATH +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +executable zero-to-one + main-is: MyCustomPreprocessor.hs + build-depends: base, directory + default-language: Haskell2010 + +executable bad-do-not-build-me + main-is: MyMissingPreprocessor.hs + build-depends: base, directory + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolDepends/setup.out b/cabal/cabal-testsuite/PackageTests/BuildToolDepends/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildToolDepends/setup.out @@ -0,0 +1,12 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - pre-proc-999.999.999 (exe:zero-to-one) (first run) + - client-0.1.0.0 (exe:hello-world) (first run) +Configuring executable 'zero-to-one' for pre-proc-999.999.999.. +Preprocessing executable 'zero-to-one' for pre-proc-999.999.999.. +Building executable 'zero-to-one' for pre-proc-999.999.999.. +Configuring executable 'hello-world' for client-0.1.0.0.. +Preprocessing executable 'hello-world' for client-0.1.0.0.. +Building executable 'hello-world' for client-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolDepends/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildToolDepends/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildToolDepends/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +-- Test build-tool-depends between two packages +main = cabalTest $ do + cabal "new-build" ["client"] diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/Foo.hs b/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/Foo.hs @@ -0,0 +1,1 @@ +module Foo where diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.cabal.out @@ -0,0 +1,4 @@ +# Setup configure +Resolving dependencies... +Configuring build-tool-depends-missing-0.1.0.0... +cabal: The package depends on a missing internal executable: diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.out b/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.out @@ -0,0 +1,3 @@ +# Setup configure +Configuring build-tool-depends-missing-0.1.0.0... +setup: The package depends on a missing internal executable: diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/setup.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +-- Test missing internal build-tool-depends does indeed fail +main = setupAndCabalTest $ do + assertOutputContains "missing internal executable" + =<< fails (setup' "configure" []) diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/tool-depends-missing.cabal b/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/tool-depends-missing.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildToolDependsInternalMissing/tool-depends-missing.cabal @@ -0,0 +1,13 @@ +name: build-tool-depends-missing +version: 0.1.0.0 +synopsis: Checks build-tool-depends errs for bad version +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Foo + build-tool-depends: build-tool-depends-missing:hello-world + -- ^ missing internal dependency + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/External/cabal.out b/cabal/cabal-testsuite/PackageTests/BuildTools/External/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/External/cabal.out @@ -0,0 +1,12 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - happy-999.999.999 (exe:happy) (first run) + - client-0.1.0.0 (exe:hello-world) (first run) +Configuring executable 'happy' for happy-999.999.999.. +Preprocessing executable 'happy' for happy-999.999.999.. +Building executable 'happy' for happy-999.999.999.. +Configuring executable 'hello-world' for client-0.1.0.0.. +Preprocessing executable 'hello-world' for client-0.1.0.0.. +Building executable 'hello-world' for client-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/External/cabal.project b/cabal/cabal-testsuite/PackageTests/BuildTools/External/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/External/cabal.project @@ -0,0 +1,1 @@ +packages: client, happy diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/External/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/BuildTools/External/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/External/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +-- Test legacy `build-tools` dependency on external package +-- We use one of the hard-coded names to accomplish this +main = cabalTest $ do + cabal "new-build" ["client"] diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/External/client/Hello.hs b/cabal/cabal-testsuite/PackageTests/BuildTools/External/client/Hello.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/External/client/Hello.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -F -pgmF happy #-} +module Main where + +a :: String +a = "0000" + +main :: IO () +main = putStrLn a diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/External/client/client.cabal b/cabal/cabal-testsuite/PackageTests/BuildTools/External/client/client.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/External/client/client.cabal @@ -0,0 +1,13 @@ +name: client +version: 0.1.0.0 +synopsis: Checks build-tools are put in PATH +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +executable hello-world + main-is: Hello.hs + build-depends: base + build-tools: happy + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/External/happy/MyCustomPreprocessor.hs b/cabal/cabal-testsuite/PackageTests/BuildTools/External/happy/MyCustomPreprocessor.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/External/happy/MyCustomPreprocessor.hs @@ -0,0 +1,11 @@ +module Main where + +import System.Environment +import System.IO + +main :: IO () +main = do + (_:source:target:_) <- getArgs + let f '0' = '1' + f c = c + writeFile target . map f =<< readFile source diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/External/happy/happy.cabal b/cabal/cabal-testsuite/PackageTests/BuildTools/External/happy/happy.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/External/happy/happy.cabal @@ -0,0 +1,12 @@ +name: happy +version: 999.999.999 +synopsis: Checks build-tools on legacy package name are put in PATH +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +executable happy + main-is: MyCustomPreprocessor.hs + build-depends: base, directory + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/A.hs b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/A.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -F -pgmF my-foreign-preprocessor #-} +module A where + +a :: String +a = "0000" diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/build-tools-path-foreign.cabal b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/build-tools-path-foreign.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/build-tools-path-foreign.cabal @@ -0,0 +1,20 @@ +name: build-tools-path-foreign +version: 0.1.0.0 +synopsis: Checks unknown build-tools are drawn from PATH +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: A + build-depends: base + build-tools: my-foreign-preprocessor + -- ^ Note the unknown dependency. + default-language: Haskell2010 + +executable hello-world + main-is: Hello.hs + build-depends: base, build-tools-path-foreign + default-language: Haskell2010 + hs-source-dirs: hello diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/hello/Hello.hs b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/hello/Hello.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/hello/Hello.hs @@ -0,0 +1,6 @@ +module Main where + +import A + +main :: IO () +main = putStrLn a diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/my-foreign-preprocessor b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/my-foreign-preprocessor new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/my-foreign-preprocessor @@ -0,0 +1,3 @@ +#!/usr/bin/env sh + +sed -e 's/0/1/g' < $2 > $3 diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.cabal.out @@ -0,0 +1,10 @@ +# Setup configure +Resolving dependencies... +Configuring build-tools-path-foreign-0.1.0.0... +# Setup build +Preprocessing library for build-tools-path-foreign-0.1.0.0.. +Building library for build-tools-path-foreign-0.1.0.0.. +Preprocessing executable 'hello-world' for build-tools-path-foreign-0.1.0.0.. +Building executable 'hello-world' for build-tools-path-foreign-0.1.0.0.. +# hello-world +1111 diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.out b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.out @@ -0,0 +1,9 @@ +# Setup configure +Configuring build-tools-path-foreign-0.1.0.0... +# Setup build +Preprocessing library for build-tools-path-foreign-0.1.0.0.. +Building library for build-tools-path-foreign-0.1.0.0.. +Preprocessing executable 'hello-world' for build-tools-path-foreign-0.1.0.0.. +Building executable 'hello-world' for build-tools-path-foreign-0.1.0.0.. +# hello-world +1111 diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Foreign/setup.test.hs @@ -0,0 +1,15 @@ +import Test.Cabal.Prelude + +import Control.Applicative ((<$>)) +import Control.Monad.IO.Class +import System.Environment + +-- Test PATH-munging +-- TODO: Enable this test on Windows +main = setupAndCabalTest $ do + skipIf =<< isWindows + path <- liftIO $ getEnv "PATH" + cwd <- testCurrentDir <$> getTestEnv + r <- withEnv [("PATH", Just $ cwd ++ ":" ++ path)] $ setup_build [] + runExe' "hello-world" [] + >>= assertOutputContains "1111" diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/A.hs b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/A.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -F -pgmF my-cpp #-} +module A where + +a :: String +a = "0000" diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/MyCustomPreprocessor.hs b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/MyCustomPreprocessor.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/MyCustomPreprocessor.hs @@ -0,0 +1,11 @@ +module Main where + +import System.Environment +import System.IO + +main :: IO () +main = do + (_:source:target:_) <- getArgs + let f '0' = '1' + f c = c + writeFile target . map f =<< readFile source diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.out b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.out @@ -0,0 +1,16 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - foo-0.1.0.0 (exe:my-cpp) (first run) + - foo-0.1.0.0 (lib) (first run) + - foo-0.1.0.0 (exe:hello-world) (first run) +Configuring executable 'my-cpp' for foo-0.1.0.0.. +Preprocessing executable 'my-cpp' for foo-0.1.0.0.. +Building executable 'my-cpp' for foo-0.1.0.0.. +Configuring library for foo-0.1.0.0.. +Preprocessing library for foo-0.1.0.0.. +Building library for foo-0.1.0.0.. +Configuring executable 'hello-world' for foo-0.1.0.0.. +Preprocessing executable 'hello-world' for foo-0.1.0.0.. +Building executable 'hello-world' for foo-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.project b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +-- Test leacy `build-tools` dependency on internal library +main = cabalTest $ do + cabal "new-build" ["foo", "hello-world"] diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/foo.cabal b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/foo.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/foo.cabal @@ -0,0 +1,25 @@ +name: foo +version: 0.1.0.0 +synopsis: Checks build-tools are put in PATH +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +executable my-cpp + main-is: MyCustomPreprocessor.hs + build-depends: base, directory + default-language: Haskell2010 + +library + exposed-modules: A + build-depends: base + build-tools: my-cpp + -- ^ Note the internal dependency. + default-language: Haskell2010 + +executable hello-world + main-is: Hello.hs + build-depends: base, foo + default-language: Haskell2010 + hs-source-dirs: hello diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/hello/Hello.hs b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/hello/Hello.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/hello/Hello.hs @@ -0,0 +1,6 @@ +module Main where + +import A + +main :: IO () +main = putStrLn a diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/setup.cabal.out @@ -0,0 +1,12 @@ +# Setup configure +Resolving dependencies... +Configuring foo-0.1.0.0... +# Setup build +Preprocessing executable 'my-cpp' for foo-0.1.0.0.. +Building executable 'my-cpp' for foo-0.1.0.0.. +Preprocessing library for foo-0.1.0.0.. +Building library for foo-0.1.0.0.. +Preprocessing executable 'hello-world' for foo-0.1.0.0.. +Building executable 'hello-world' for foo-0.1.0.0.. +# hello-world +1111 diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/setup.out b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/setup.out @@ -0,0 +1,11 @@ +# Setup configure +Configuring foo-0.1.0.0... +# Setup build +Preprocessing executable 'my-cpp' for foo-0.1.0.0.. +Building executable 'my-cpp' for foo-0.1.0.0.. +Preprocessing library for foo-0.1.0.0.. +Building library for foo-0.1.0.0.. +Preprocessing executable 'hello-world' for foo-0.1.0.0.. +Building executable 'hello-world' for foo-0.1.0.0.. +# hello-world +1111 diff --git a/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildTools/Internal/setup.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +-- Test PATH-munging +main = setupAndCabalTest $ do + setup_build [] + runExe' "hello-world" [] + >>= assertOutputContains "1111" diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolsPath/A.hs b/cabal/cabal-testsuite/PackageTests/BuildToolsPath/A.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/BuildToolsPath/A.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF my-custom-preprocessor #-} -module A where - -a :: String -a = "0000" diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolsPath/MyCustomPreprocessor.hs b/cabal/cabal-testsuite/PackageTests/BuildToolsPath/MyCustomPreprocessor.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/BuildToolsPath/MyCustomPreprocessor.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Main where - -import System.Environment -import System.IO - -main :: IO () -main = do - (_:source:target:_) <- getArgs - let f '0' = '1' - f c = c - writeFile target . map f =<< readFile source diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolsPath/build-tools-path.cabal b/cabal/cabal-testsuite/PackageTests/BuildToolsPath/build-tools-path.cabal deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/BuildToolsPath/build-tools-path.cabal +++ /dev/null @@ -1,25 +0,0 @@ -name: build-tools-path -version: 0.1.0.0 -synopsis: Checks build-tools are put in PATH -license: BSD3 -category: Testing -build-type: Simple -cabal-version: >=1.10 - -executable my-custom-preprocessor - main-is: MyCustomPreprocessor.hs - build-depends: base, directory - default-language: Haskell2010 - -library - exposed-modules: A - build-depends: base - build-tools: my-custom-preprocessor - -- ^ Note the internal dependency. - default-language: Haskell2010 - -executable hello-world - main-is: Hello.hs - build-depends: base, build-tools-path - default-language: Haskell2010 - hs-source-dirs: hello diff --git a/cabal/cabal-testsuite/PackageTests/BuildToolsPath/hello/Hello.hs b/cabal/cabal-testsuite/PackageTests/BuildToolsPath/hello/Hello.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/BuildToolsPath/hello/Hello.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import A - -main :: IO () -main = putStrLn a diff --git a/cabal/cabal-testsuite/PackageTests/BuildableField/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/BuildableField/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildableField/setup.cabal.out @@ -0,0 +1,4 @@ +# Setup configure +# Setup build +Preprocessing library for BuildableField-0.1.0.0.. +Building library for BuildableField-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildableField/setup.out b/cabal/cabal-testsuite/PackageTests/BuildableField/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildableField/setup.out @@ -0,0 +1,4 @@ +# Setup configure +# Setup build +Preprocessing library for BuildableField-0.1.0.0.. +Building library for BuildableField-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/BuildableField/setup.test.hs b/cabal/cabal-testsuite/PackageTests/BuildableField/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/BuildableField/setup.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude +-- Test that setup can choose flags to disable building a component when that +-- component's dependencies are unavailable. The build should succeed without +-- requiring the component's dependencies or imports. +main = setupAndCabalTest $ do + r <- setup' "configure" ["-v"] + assertOutputContains "Flags chosen: build-exe=False" r + setup "build" [] diff --git a/cabal/cabal-testsuite/PackageTests/CMain/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/CMain/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CMain/setup.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring my-0.1... +# Setup build +Preprocessing executable 'foo' for my-0.1.. +Building executable 'foo' for my-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/CMain/setup.out b/cabal/cabal-testsuite/PackageTests/CMain/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CMain/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring my-0.1... +# Setup build +Preprocessing executable 'foo' for my-0.1.. +Building executable 'foo' for my-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/CMain/setup.test.hs b/cabal/cabal-testsuite/PackageTests/CMain/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CMain/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +-- Test building an executable whose main() function is defined in a C +-- file +main = setupAndCabalTest $ setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/COnlyMain/foo.c b/cabal/cabal-testsuite/PackageTests/COnlyMain/foo.c new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/COnlyMain/foo.c @@ -0,0 +1,6 @@ +#include + +int main(int argc, char **argv) { + printf("Hello world!"); + return 0; +} diff --git a/cabal/cabal-testsuite/PackageTests/COnlyMain/my.cabal b/cabal/cabal-testsuite/PackageTests/COnlyMain/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/COnlyMain/my.cabal @@ -0,0 +1,10 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 2.1 +build-type: Simple + +executable foo + -- default-language is required by cabal-version >= 1.10 + default-language: Haskell2010 + main-is: foo.c diff --git a/cabal/cabal-testsuite/PackageTests/COnlyMain/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/COnlyMain/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/COnlyMain/setup.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring my-0.1... +# Setup build +Preprocessing executable 'foo' for my-0.1.. +Building executable 'foo' for my-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/COnlyMain/setup.out b/cabal/cabal-testsuite/PackageTests/COnlyMain/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/COnlyMain/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring my-0.1... +# Setup build +Preprocessing executable 'foo' for my-0.1.. +Building executable 'foo' for my-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/COnlyMain/setup.test.hs b/cabal/cabal-testsuite/PackageTests/COnlyMain/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/COnlyMain/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +-- Test building an executable whose main() function is defined in a C +-- file +main = setupAndCabalTest $ setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/CaretOperator/Check.hs b/cabal/cabal-testsuite/PackageTests/CaretOperator/Check.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/CaretOperator/Check.hs +++ /dev/null @@ -1,34 +0,0 @@ -module PackageTests.CaretOperator.Check where - -import PackageTests.PackageTester - -import Distribution.Version -import Distribution.Simple.LocalBuildInfo -import Distribution.Package -import Distribution.PackageDescription -import Language.Haskell.Extension (Language(..)) - - -suite :: TestM () -suite = do - assertOutputDoesNotContain "Parse of field 'build-depends' failed" - =<< cabal' "configure" [] - dist_dir <- distDir - lbi <- liftIO $ getPersistBuildConfig dist_dir - - let anticipatedLib = emptyLibrary - { libBuildInfo = emptyBuildInfo - { defaultLanguage = Just Haskell2010 - , targetBuildDepends = - [ Dependency (mkPackageName "base") - (withinVersion (mkVersion [4])) - , Dependency (mkPackageName "pretty") - (majorBoundVersion (mkVersion [1,1,1,0])) - ] - , hsSourceDirs = ["."] - } - } - Just gotLib = library (localPkgDescr lbi) - assertEqual "parsed library component does not match anticipated" - anticipatedLib gotLib - return () diff --git a/cabal/cabal-testsuite/PackageTests/CaretOperator/my.cabal b/cabal/cabal-testsuite/PackageTests/CaretOperator/my.cabal --- a/cabal/cabal-testsuite/PackageTests/CaretOperator/my.cabal +++ b/cabal/cabal-testsuite/PackageTests/CaretOperator/my.cabal @@ -9,7 +9,7 @@ description: Check that Cabal recognizes the caret operator -Library +library default-language: Haskell2010 - build-depends: base == 4.* + build-depends: base , pretty ^>= 1.1.1.0 diff --git a/cabal/cabal-testsuite/PackageTests/CaretOperator/setup.out b/cabal/cabal-testsuite/PackageTests/CaretOperator/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CaretOperator/setup.out @@ -0,0 +1,2 @@ +# Setup configure +Configuring CaretOperator-0... diff --git a/cabal/cabal-testsuite/PackageTests/CaretOperator/setup.test.hs b/cabal/cabal-testsuite/PackageTests/CaretOperator/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CaretOperator/setup.test.hs @@ -0,0 +1,30 @@ +import Test.Cabal.Prelude + +import Control.Monad +import Distribution.Version +import Distribution.Simple.LocalBuildInfo +import Distribution.Package +import Distribution.Types.Dependency +import Distribution.PackageDescription +import Language.Haskell.Extension (Language(..)) + +-- Test that setup parses '^>=' operator correctly. +-- Don't bother with the cabal-install test as the build-depends +-- is updated by this point so that we lost the caret parsing. +main = setupTest $ do + -- Don't run this for GHC 7.0/7.2, which doesn't have a recent + -- enough version of pretty. (But this is pretty dumb.) + skipUnless =<< ghcVersionIs (>= mkVersion [7,3]) + assertOutputDoesNotContain "Parse of field 'build-depends' failed" + =<< setup' "configure" [] + lbi <- getLocalBuildInfoM + + let Just gotLib = library (localPkgDescr lbi) + bi = libBuildInfo gotLib + assertEqual "defaultLanguage" (Just Haskell2010) (defaultLanguage bi) + forM_ (targetBuildDepends bi) $ \(Dependency pn vr) -> + when (pn == mkPackageName "pretty") $ + assertEqual "targetBuildDepends/pretty" + vr (majorBoundVersion (mkVersion [1,1,1,0])) + assertEqual "hsSourceDirs" ["."] (hsSourceDirs bi) + return () diff --git a/cabal/cabal-testsuite/PackageTests/Configure/.gitignore b/cabal/cabal-testsuite/PackageTests/Configure/.gitignore --- a/cabal/cabal-testsuite/PackageTests/Configure/.gitignore +++ b/cabal/cabal-testsuite/PackageTests/Configure/.gitignore @@ -1,6 +1,6 @@ -X11.buildinfo +zlib.buildinfo autom4te.cache/ *.log *.status -include/HsX11Config.h configure +include/HsZlibConfig.h diff --git a/cabal/cabal-testsuite/PackageTests/Configure/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Configure/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Configure/setup.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring zlib-1.1... +# Setup build +Preprocessing library for zlib-1.1.. +Building library for zlib-1.1.. diff --git a/cabal/cabal-testsuite/PackageTests/Configure/setup.out b/cabal/cabal-testsuite/PackageTests/Configure/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Configure/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring zlib-1.1... +# Setup build +Preprocessing library for zlib-1.1.. +Building library for zlib-1.1.. diff --git a/cabal/cabal-testsuite/PackageTests/Configure/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Configure/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Configure/setup.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude +-- Test for 'build-type: Configure' example from the setup manual. +-- Disabled on Windows since MingW doesn't ship with autoreconf by +-- default. +main = setupAndCabalTest $ do + skipIf =<< isWindows + _ <- shell "autoreconf" ["-i"] + setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Exe/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Exe/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Exe/setup.cabal.out @@ -0,0 +1,20 @@ +# Setup configure +Resolving dependencies... +Warning: solver failed to find a solution: +Could not resolve dependencies: +trying: Exe-0.1.0.0 (user goal) +unknown package: totally-impossible-dependency-to-fill (dependency of Exe) +fail (backjumping, conflict set: Exe, totally-impossible-dependency-to-fill) +After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: Exe (2), totally-impossible-dependency-to-fill (1) +Trying configure anyway. +Configuring executable 'goodexe' for Exe-0.1.0.0.. +# Setup build +Preprocessing executable 'goodexe' for Exe-0.1.0.0.. +Building executable 'goodexe' for Exe-0.1.0.0.. +# Setup copy +Installing executable goodexe in +Warning: The directory /setup.cabal.dist/usr/bin is not in the system search path. +# Setup register +Package contains no library to register: Exe-0.1.0.0... +# goodexe +OK diff --git a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Exe/setup.out b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Exe/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Exe/setup.out @@ -0,0 +1,12 @@ +# Setup configure +Configuring executable 'goodexe' for Exe-0.1.0.0.. +# Setup build +Preprocessing executable 'goodexe' for Exe-0.1.0.0.. +Building executable 'goodexe' for Exe-0.1.0.0.. +# Setup copy +Installing executable goodexe in +Warning: The directory /setup.dist/usr/bin is not in the system search path. +# Setup register +Package contains no library to register: Exe-0.1.0.0... +# goodexe +OK diff --git a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Exe/setup.test.hs b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Exe/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Exe/setup.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + withPackageDb $ do + setup_install ["goodexe"] + runExe' "goodexe" [] >>= assertOutputContains "OK" diff --git a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit-fail.out b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit-fail.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit-fail.out @@ -0,0 +1,13 @@ +# Setup configure +Configuring library 'sublib' for Lib-0.1.0.0.. +# Setup build +Preprocessing library 'sublib' for Lib-0.1.0.0.. +Building library 'sublib' for Lib-0.1.0.0.. +# Setup copy +Installing internal library sublib in +# Setup register +Registering library 'sublib' for Lib-0.1.0.0.. +# Setup configure +Configuring executable 'exe' for Lib-0.1.0.0.. +setup: Encountered missing dependencies: + sublib -any diff --git a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit-fail.test.hs b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit-fail.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit-fail.test.hs @@ -0,0 +1,11 @@ + +import Test.Cabal.Prelude +-- NB: The --dependency flag is not supported by cabal-install +main = setupTest $ do + withPackageDb $ do + base_id <- getIPID "base" + setup_install ["sublib", "--cid", "sublib-0.1-abc"] + r <- fails $ setup' "configure" + [ "exe", "--exact-configuration" + , "--dependency", "base=" ++ base_id ] + assertOutputContains "sublib" r diff --git a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.out b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.out @@ -0,0 +1,20 @@ +# Setup configure +Configuring library 'sublib' for Lib-0.1.0.0.. +# Setup build +Preprocessing library 'sublib' for Lib-0.1.0.0.. +Building library 'sublib' for Lib-0.1.0.0.. +# Setup copy +Installing internal library sublib in +# Setup register +Registering library 'sublib' for Lib-0.1.0.0.. +# Setup configure +Configuring executable 'exe' for Lib-0.1.0.0.. +# Setup build +Preprocessing executable 'exe' for Lib-0.1.0.0.. +Building executable 'exe' for Lib-0.1.0.0.. +# Setup copy +Installing executable exe in +Warning: The directory /setup-explicit.dist/usr/bin is not in the system search path. +# Setup register +# exe +OK diff --git a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude +-- NB: The --dependency flag is not supported by cabal-install +main = setupTest $ do + withPackageDb $ do + base_id <- getIPID "base" + setup_install ["sublib", "--cid", "sublib-0.1-abc"] + setup_install [ "exe", "--exact-configuration" + , "--dependency", "sublib=sublib-0.1-abc" + , "--dependency", "base=" ++ base_id ] + runExe' "exe" [] >>= assertOutputContains "OK" diff --git a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup.out b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup.out @@ -0,0 +1,20 @@ +# Setup configure +Configuring library 'sublib' for Lib-0.1.0.0.. +# Setup build +Preprocessing library 'sublib' for Lib-0.1.0.0.. +Building library 'sublib' for Lib-0.1.0.0.. +# Setup copy +Installing internal library sublib in +# Setup register +Registering library 'sublib' for Lib-0.1.0.0.. +# Setup configure +Configuring executable 'exe' for Lib-0.1.0.0.. +# Setup build +Preprocessing executable 'exe' for Lib-0.1.0.0.. +Building executable 'exe' for Lib-0.1.0.0.. +# Setup copy +Installing executable exe in +Warning: The directory /setup.dist/usr/bin is not in the system search path. +# Setup register +# exe +OK diff --git a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup.test.hs b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude +-- NB: This currently doesn't work with cabal-install, as the depsolver +-- doesn't know to compute a dependency for sublib in exe, resulting in +-- Setup not being called with enough dependencies. Shout if this is +-- a problem for you; the advised workaround is to use Setup directly +-- if you need per-component builds. +main = setupTest $ do + withPackageDb $ do + setup_install ["sublib"] + setup_install ["exe"] + runExe' "exe" [] >>= assertOutputContains "OK" diff --git a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/Test.cabal b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/Test.cabal --- a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/Test.cabal +++ b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/Test.cabal @@ -16,3 +16,4 @@ type: exitcode-stdio-1.0 main-is: Test.hs hs-source-dirs: tests + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/setup.out b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/setup.out @@ -0,0 +1,29 @@ +# Setup configure +Configuring library for test-for-cabal-0.1.0.0.. +# Setup build +Preprocessing library for test-for-cabal-0.1.0.0.. +Building library for test-for-cabal-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for test-for-cabal-0.1.0.0.. +# Setup configure +Configuring testlib-0.1.0.0... +# Setup build +Preprocessing library for testlib-0.1.0.0.. +Building library for testlib-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for testlib-0.1.0.0.. +# Setup configure +Configuring test suite 'testsuite' for test-for-cabal-0.1.0.0.. +# Setup build +Preprocessing test suite 'testsuite' for test-for-cabal-0.1.0.0.. +Building test suite 'testsuite' for test-for-cabal-0.1.0.0.. +# Setup test +Running 1 test suites... +Test suite testsuite: RUNNING... +Test suite testsuite: PASS +Test suite logged to: setup.dist/work/dist/test/test-for-cabal-0.1.0.0-testsuite.log +1 of 1 test suites (1 of 1 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/setup.test.hs b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ConfigureComponent/Test/setup.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude +-- NB: This doesn't work with cabal-install, because the +-- dependency solver doesn't know how to solve for only +-- a single component of a package. +main = setupTest $ do + withPackageDb $ do + setup_install ["test-for-cabal"] + withDirectory "testlib" $ setup_install [] + setup "configure" ["testsuite"] + setup "build" [] + setup "test" [] diff --git a/cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/myprog.cabal b/cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/myprog.cabal --- a/cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/myprog.cabal +++ b/cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/myprog.cabal @@ -9,7 +9,9 @@ executable myprog main-is: Main.hs build-depends: base + default-language: Haskell2010 executable myprog2 main-is: Main2.hs build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/setup.cabal.out @@ -0,0 +1,9 @@ +# Setup configure +Resolving dependencies... +Configuring myprog-0.1.0.0... +# Setup build +Preprocessing executable 'myprog' for myprog-0.1.0.0.. +Building executable 'myprog' for myprog-0.1.0.0.. +# Setup copy +Installing executable myprog in +Warning: The directory /setup.cabal.dist/usr/bin is not in the system search path. diff --git a/cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/setup.out b/cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/setup.out @@ -0,0 +1,8 @@ +# Setup configure +Configuring myprog-0.1.0.0... +# Setup build +Preprocessing executable 'myprog' for myprog-0.1.0.0.. +Building executable 'myprog' for myprog-0.1.0.0.. +# Setup copy +Installing executable myprog in +Warning: The directory /setup.dist/usr/bin is not in the system search path. diff --git a/cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/setup.test.hs b/cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CopyComponent/Exe/setup.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +-- Test that per-component copy works, when only building one executable +main = setupAndCabalTest $ do + withPackageDb $ do + setup "configure" [] + setup "build" ["myprog"] + setup "copy" ["myprog"] diff --git a/cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/p.cabal b/cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/p.cabal --- a/cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/p.cabal +++ b/cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/p.cabal @@ -15,3 +15,4 @@ executable pprog main-is: Main.hs build-depends: p + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Resolving dependencies... +Configuring p-0.1.0.0... +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing library in diff --git a/cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/setup.out b/cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring p-0.1.0.0... +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing library in diff --git a/cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/setup.test.hs b/cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CopyComponent/Lib/setup.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +-- Test that per-component copy works, when only building library +main = setupAndCabalTest $ do + withPackageDb $ do + setup "configure" [] + setup "build" ["lib:p"] + setup "copy" ["lib:p"] diff --git a/cabal/cabal-testsuite/PackageTests/CustomDep/cabal.project b/cabal/cabal-testsuite/PackageTests/CustomDep/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomDep/cabal.project @@ -0,0 +1,1 @@ +packages: client custom diff --git a/cabal/cabal-testsuite/PackageTests/CustomDep/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/CustomDep/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomDep/cabal.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + -- NB: This variant seems to use the bootstrapped Cabal? + skipUnless =<< hasCabalForGhc + -- This test depends heavily on what packages are in the global + -- database, don't record the output + recordMode DoNotRecord $ do + -- TODO: Hack, delete me + withEnvFilter (/= "HOME") $ do + cabal "new-build" ["all"] diff --git a/cabal/cabal-testsuite/PackageTests/CustomDep/client/B.hs b/cabal/cabal-testsuite/PackageTests/CustomDep/client/B.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomDep/client/B.hs @@ -0,0 +1,2 @@ +module B where +import A diff --git a/cabal/cabal-testsuite/PackageTests/CustomDep/client/Setup.hs b/cabal/cabal-testsuite/PackageTests/CustomDep/client/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomDep/client/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/CustomDep/client/client.cabal b/cabal/cabal-testsuite/PackageTests/CustomDep/client/client.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomDep/client/client.cabal @@ -0,0 +1,12 @@ +name: client +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: B + build-depends: base, custom + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/CustomDep/custom/A.hs b/cabal/cabal-testsuite/PackageTests/CustomDep/custom/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomDep/custom/A.hs @@ -0,0 +1,1 @@ +module A where diff --git a/cabal/cabal-testsuite/PackageTests/CustomDep/custom/Setup.hs b/cabal/cabal-testsuite/PackageTests/CustomDep/custom/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomDep/custom/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/CustomDep/custom/custom.cabal b/cabal/cabal-testsuite/PackageTests/CustomDep/custom/custom.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomDep/custom/custom.cabal @@ -0,0 +1,12 @@ +name: custom +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Custom +cabal-version: >=1.10 + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/CustomDep/sandbox.out b/cabal/cabal-testsuite/PackageTests/CustomDep/sandbox.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomDep/sandbox.out @@ -0,0 +1,5 @@ +# cabal sandbox init +Writing a default package environment file to /sandbox.dist/cabal.sandbox.config +Creating a new sandbox at /sandbox.dist/sandbox +# cabal sandbox add-source +# cabal sandbox add-source diff --git a/cabal/cabal-testsuite/PackageTests/CustomDep/sandbox.test.hs b/cabal/cabal-testsuite/PackageTests/CustomDep/sandbox.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomDep/sandbox.test.hs @@ -0,0 +1,16 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + osx <- isOSX + -- On Travis OSX, Cabal shipped with GHC 7.8 does not work + -- with error "setup: /usr/bin/ar: permission denied"; see + -- also https://github.com/haskell/cabal/issues/3938 + -- This is a hack to make the test not run in this case. + when osx $ skipUnless =<< ghcVersionIs (>= mkVersion [7,10]) + withSandbox $ do + cabal_sandbox "add-source" ["custom"] + cabal_sandbox "add-source" ["client"] + -- NB: This test relies critically on the Setup script being + -- built against GHC's bundled Cabal. This means that the + -- output we see may vary between tests, so we don't record this. + recordMode DoNotRecord $ + cabal "install" ["client"] diff --git a/cabal/cabal-testsuite/PackageTests/CustomPlain/A.hs b/cabal/cabal-testsuite/PackageTests/CustomPlain/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomPlain/A.hs @@ -0,0 +1,1 @@ +module A where diff --git a/cabal/cabal-testsuite/PackageTests/CustomPlain/Setup.hs b/cabal/cabal-testsuite/PackageTests/CustomPlain/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomPlain/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +import System.IO +main = hPutStrLn stderr "ThisIsCustomYeah" >> defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/CustomPlain/cabal.project b/cabal/cabal-testsuite/PackageTests/CustomPlain/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomPlain/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/CustomPlain/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/CustomPlain/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomPlain/cabal.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + -- Regression test for #4393 + recordMode DoNotRecord $ do + -- TODO: Hack; see also CustomDep/cabal.test.hs + withEnvFilter (/= "HOME") $ do + -- On -v2, we don't have vQuiet set, which suppressed + -- the error + cabal "new-build" ["-v1"] diff --git a/cabal/cabal-testsuite/PackageTests/CustomPlain/plain.cabal b/cabal/cabal-testsuite/PackageTests/CustomPlain/plain.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomPlain/plain.cabal @@ -0,0 +1,12 @@ +name: plain +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Custom +cabal-version: >=1.10 + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/CustomPlain/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/CustomPlain/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomPlain/setup.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring plain-0.1.0.0... +# Setup build +Preprocessing library for plain-0.1.0.0.. +Building library for plain-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/CustomPlain/setup.out b/cabal/cabal-testsuite/PackageTests/CustomPlain/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomPlain/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring plain-0.1.0.0... +# Setup build +Preprocessing library for plain-0.1.0.0.. +Building library for plain-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/CustomPlain/setup.test.hs b/cabal/cabal-testsuite/PackageTests/CustomPlain/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomPlain/setup.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< hasCabalForGhc + -- On Travis OSX, Cabal shipped with GHC 7.8 does not work + -- with error "setup: /usr/bin/ar: permission denied"; see + -- also https://github.com/haskell/cabal/issues/3938 + -- This is a hack to make the test not run in this case. + skipIf =<< liftM2 (&&) isOSX (ghcVersionIs (< mkVersion [7,10])) + setup' "configure" [] >>= assertOutputContains "ThisIsCustomYeah" + setup' "build" [] >>= assertOutputContains "ThisIsCustomYeah" diff --git a/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.cabal.out @@ -0,0 +1,12 @@ +# Setup configure +Resolving dependencies... +Configuring internal-preprocessor-test-0.1.0.0... +# Setup build +Preprocessing executable 'my-custom-preprocessor' for internal-preprocessor-test-0.1.0.0.. +Building executable 'my-custom-preprocessor' for internal-preprocessor-test-0.1.0.0.. +Preprocessing library for internal-preprocessor-test-0.1.0.0.. +Building library for internal-preprocessor-test-0.1.0.0.. +Preprocessing executable 'hello-world' for internal-preprocessor-test-0.1.0.0.. +Building executable 'hello-world' for internal-preprocessor-test-0.1.0.0.. +# hello-world +hello from A diff --git a/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.out b/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.out @@ -0,0 +1,11 @@ +# Setup configure +Configuring internal-preprocessor-test-0.1.0.0... +# Setup build +Preprocessing executable 'my-custom-preprocessor' for internal-preprocessor-test-0.1.0.0.. +Building executable 'my-custom-preprocessor' for internal-preprocessor-test-0.1.0.0.. +Preprocessing library for internal-preprocessor-test-0.1.0.0.. +Building library for internal-preprocessor-test-0.1.0.0.. +Preprocessing executable 'hello-world' for internal-preprocessor-test-0.1.0.0.. +Building executable 'hello-world' for internal-preprocessor-test-0.1.0.0.. +# hello-world +hello from A diff --git a/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.test.hs b/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomPreProcess/setup.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +-- Test internal custom preprocessor +main = setupAndCabalTest $ do + skipUnless =<< hasCabalForGhc + setup_build [] + runExe' "hello-world" [] + >>= assertOutputContains "hello from A" diff --git a/cabal/cabal-testsuite/PackageTests/CustomSegfault/.gitignore b/cabal/cabal-testsuite/PackageTests/CustomSegfault/.gitignore new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomSegfault/.gitignore @@ -0,0 +1,1 @@ +core* diff --git a/cabal/cabal-testsuite/PackageTests/CustomSegfault/Setup.hs b/cabal/cabal-testsuite/PackageTests/CustomSegfault/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomSegfault/Setup.hs @@ -0,0 +1,3 @@ +import System.Posix.Signals + +main = putStrLn "Quitting..." >> raiseSignal sigSEGV diff --git a/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.out b/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.out @@ -0,0 +1,6 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - plain-0.1.0.0 (lib:plain) (first run) +cabal: Failed to build plain-0.1.0.0-inplace. The failure occurred during the configure step. The build process segfaulted (i.e. SIGSEGV). diff --git a/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.project b/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomSegfault/cabal.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + -- TODO: this test ought to work on Windows too + skipUnless =<< isLinux + skipUnless =<< ghcVersionIs (>= mkVersion [7,8]) + fails $ cabal' "new-build" [] >>= assertOutputContains "SIGSEGV" diff --git a/cabal/cabal-testsuite/PackageTests/CustomSegfault/plain.cabal b/cabal/cabal-testsuite/PackageTests/CustomSegfault/plain.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomSegfault/plain.cabal @@ -0,0 +1,14 @@ +name: plain +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Custom +cabal-version: >=1.10 + +library + build-depends: base + default-language: Haskell2010 + +custom-setup + setup-depends: base, unix diff --git a/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/Setup.hs b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/Setup.hs @@ -0,0 +1,4 @@ +import System.Exit +import System.IO + +main = hPutStrLn stderr "My custom Setup" >> exitFailure diff --git a/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/cabal.out b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/cabal.out @@ -0,0 +1,5 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - custom-setup-without-cabal-1.0 (lib:custom-setup-without-cabal) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/cabal.project b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/cabal.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + + -- This package has explicit setup dependencies that do not include Cabal. + -- new-build should try to build it, but configure should fail because + -- Setup.hs just prints an error message and exits. + r <- fails $ cabal' "new-build" ["custom-setup-without-cabal"] + assertOutputContains "My custom Setup" r diff --git a/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/custom-setup-without-cabal.cabal b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/custom-setup-without-cabal.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabal/custom-setup-without-cabal.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.0 +name: custom-setup-without-cabal +version: 1.0 +build-type: Custom + +custom-setup + setup-depends: base + +library diff --git a/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/Setup.hs b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/cabal.out b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/cabal.out @@ -0,0 +1,5 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - custom-setup-without-cabal-defaultMain-1.0 (lib:custom-setup-without-cabal-defaultMain) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/cabal.project b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/cabal.test.hs @@ -0,0 +1,16 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + + -- This package has explicit setup dependencies that do not include Cabal. + -- Compilation should fail because Setup.hs imports Distribution.Simple. + r <- fails $ cabal' "new-build" ["custom-setup-without-cabal-defaultMain"] + assertRegex "Should not have been able to import Cabal" + "(Could not find module|Failed to load interface for).*Distribution\\.Simple" r + {- + -- TODO: With GHC 8.2, this no longer is displayed + -- When using --with-ghc, this message is not necessarily output + has_cabal <- hasCabalForGhc + when has_cabal $ + assertRegex "It is a member of the hidden package .*Cabal-" + "It is a member of the hidden package" r + -} diff --git a/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/custom-setup-without-cabal-defaultMain.cabal b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/custom-setup-without-cabal-defaultMain.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/CustomWithoutCabalDefaultMain/custom-setup-without-cabal-defaultMain.cabal @@ -0,0 +1,9 @@ +name: custom-setup-without-cabal-defaultMain +version: 1.0 +build-type: Custom +cabal-version: >= 1.2 + +custom-setup + setup-depends: base + +library diff --git a/cabal/cabal-testsuite/PackageTests/DeterministicAr/Check.hs b/cabal/cabal-testsuite/PackageTests/DeterministicAr/Check.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/DeterministicAr/Check.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - -module PackageTests.DeterministicAr.Check where - -import Control.Monad -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import Data.Char (isSpace) -import PackageTests.PackageTester -import System.IO - -import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) -import Distribution.Package (getHSLibraryName) -import Distribution.Version (mkVersion) -import Distribution.Simple.Compiler (compilerId) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, compiler, localUnitId) - -suite :: TestM () -suite = do - cabal_build [] - dist_dir <- distDir - lbi <- liftIO $ getPersistBuildConfig dist_dir - liftIO $ checkMetadata lbi (dist_dir "build") - --- Almost a copypasta of Distribution.Simple.Program.Ar.wipeMetadata -checkMetadata :: LocalBuildInfo -> FilePath -> IO () -checkMetadata lbi dir = withBinaryFile path ReadMode $ \ h -> do - hFileSize h >>= checkArchive h - where - path = dir "lib" ++ getHSLibraryName (localUnitId lbi) ++ ".a" - - _ghc_7_10 = case compilerId (compiler lbi) of - CompilerId GHC version | version >= mkVersion [7, 10] -> True - _ -> False - - checkError msg = assertFailure ( - "PackageTests.DeterministicAr.checkMetadata: " ++ msg ++ - " in " ++ path) >> undefined - archLF = "!\x0a" -- global magic, 8 bytes - x60LF = "\x60\x0a" -- header magic, 2 bytes - metadata = BS.concat - [ "0 " -- mtime, 12 bytes - , "0 " -- UID, 6 bytes - , "0 " -- GID, 6 bytes - , "0644 " -- mode, 8 bytes - ] - headerSize = 60 - - -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details - checkArchive :: Handle -> Integer -> IO () - checkArchive h archiveSize = do - global <- BS.hGet h (BS.length archLF) - unless (global == archLF) $ checkError "Bad global header" - checkHeader (toInteger $ BS.length archLF) - - where - checkHeader :: Integer -> IO () - checkHeader offset = case compare offset archiveSize of - EQ -> return () - GT -> checkError (atOffset "Archive truncated") - LT -> do - header <- BS.hGet h headerSize - unless (BS.length header == headerSize) $ - checkError (atOffset "Short header") - let magic = BS.drop 58 header - unless (magic == x60LF) . checkError . atOffset $ - "Bad magic " ++ show magic ++ " in header" - - unless (metadata == BS.take 32 (BS.drop 16 header)) - . checkError . atOffset $ "Metadata has changed" - - let size = BS.take 10 $ BS.drop 48 header - objSize <- case reads (BS8.unpack size) of - [(n, s)] | all isSpace s -> return n - _ -> checkError (atOffset "Bad file size in header") - - let nextHeader = offset + toInteger headerSize + - -- Odd objects are padded with an extra '\x0a' - if odd objSize then objSize + 1 else objSize - hSeek h AbsoluteSeek nextHeader - checkHeader nextHeader - - where - atOffset msg = msg ++ " at offset " ++ show offset diff --git a/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.cabal.out b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring DeterministicAr-0... +# Setup build +Preprocessing library for DeterministicAr-0.. +Building library for DeterministicAr-0.. diff --git a/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.out b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring DeterministicAr-0... +# Setup build +Preprocessing library for DeterministicAr-0.. +Building library for DeterministicAr-0.. diff --git a/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.test.hs b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-default-ar.test.hs @@ -0,0 +1,13 @@ + +import Test.Cabal.Prelude + +import Control.Monad.IO.Class + +import Test.Cabal.CheckArMetadata + +-- Test that setup determinstically generates object archives +main = setupAndCabalTest $ do + setup_build [] + dist_dir <- fmap testDistDir getTestEnv + lbi <- getLocalBuildInfoM + liftIO $ checkMetadata lbi (dist_dir "build") diff --git a/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.cabal.out b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring DeterministicAr-0... +# Setup build +Preprocessing library for DeterministicAr-0.. +Building library for DeterministicAr-0.. diff --git a/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.out b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring DeterministicAr-0... +# Setup build +Preprocessing library for DeterministicAr-0.. +Building library for DeterministicAr-0.. diff --git a/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.test.hs b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/DeterministicAr/setup-old-ar-without-at-args.test.hs @@ -0,0 +1,13 @@ + +import Test.Cabal.Prelude + +import Control.Monad.IO.Class + +import Test.Cabal.CheckArMetadata + +-- Test that setup determinstically generates object archives +main = setupAndCabalTest $ do + setup_build ["--disable-response-files"] + dist_dir <- fmap testDistDir getTestEnv + lbi <- getLocalBuildInfoM + liftIO $ checkMetadata lbi (dist_dir "build") diff --git a/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal b/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal --- a/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal +++ b/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal @@ -17,9 +17,11 @@ test-module: Foo hs-source-dirs: tests build-depends: base, Cabal, DuplicateModuleName + default-language: Haskell2010 test-suite foo2 type: detailed-0.9 test-module: Foo hs-source-dirs: tests2 build-depends: base, Cabal, DuplicateModuleName + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/setup.cabal.out @@ -0,0 +1,30 @@ +# Setup configure +Resolving dependencies... +Configuring DuplicateModuleName-0.1.0.0... +# Setup build +Preprocessing library for DuplicateModuleName-0.1.0.0.. +Building library for DuplicateModuleName-0.1.0.0.. +Preprocessing test suite 'foo' for DuplicateModuleName-0.1.0.0.. +Building test suite 'foo' for DuplicateModuleName-0.1.0.0.. +Preprocessing test suite 'foo2' for DuplicateModuleName-0.1.0.0.. +Building test suite 'foo2' for DuplicateModuleName-0.1.0.0.. +# Setup test +Preprocessing library for DuplicateModuleName-0.1.0.0.. +Building library for DuplicateModuleName-0.1.0.0.. +Preprocessing test suite 'foo' for DuplicateModuleName-0.1.0.0.. +Building test suite 'foo' for DuplicateModuleName-0.1.0.0.. +Running 1 test suites... +Test suite foo: RUNNING... +Test suite foo: FAIL +Test suite logged to: setup.cabal.dist/work/dist/test/DuplicateModuleName-0.1.0.0-foo.log +0 of 1 test suites (0 of 2 test cases) passed. +# Setup test +Preprocessing library for DuplicateModuleName-0.1.0.0.. +Building library for DuplicateModuleName-0.1.0.0.. +Preprocessing test suite 'foo2' for DuplicateModuleName-0.1.0.0.. +Building test suite 'foo2' for DuplicateModuleName-0.1.0.0.. +Running 1 test suites... +Test suite foo2: RUNNING... +Test suite foo2: FAIL +Test suite logged to: setup.cabal.dist/work/dist/test/DuplicateModuleName-0.1.0.0-foo2.log +0 of 1 test suites (0 of 2 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/setup.out b/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/setup.out @@ -0,0 +1,21 @@ +# Setup configure +Configuring DuplicateModuleName-0.1.0.0... +# Setup build +Preprocessing library for DuplicateModuleName-0.1.0.0.. +Building library for DuplicateModuleName-0.1.0.0.. +Preprocessing test suite 'foo' for DuplicateModuleName-0.1.0.0.. +Building test suite 'foo' for DuplicateModuleName-0.1.0.0.. +Preprocessing test suite 'foo2' for DuplicateModuleName-0.1.0.0.. +Building test suite 'foo2' for DuplicateModuleName-0.1.0.0.. +# Setup test +Running 1 test suites... +Test suite foo: RUNNING... +Test suite foo: FAIL +Test suite logged to: setup.dist/work/dist/test/DuplicateModuleName-0.1.0.0-foo.log +0 of 1 test suites (0 of 2 test cases) passed. +# Setup test +Running 1 test suites... +Test suite foo2: RUNNING... +Test suite foo2: FAIL +Test suite logged to: setup.dist/work/dist/test/DuplicateModuleName-0.1.0.0-foo2.log +0 of 1 test suites (0 of 2 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/setup.test.hs b/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/DuplicateModuleName/setup.test.hs @@ -0,0 +1,12 @@ +import Test.Cabal.Prelude +-- Test that if two components have the same module name, they do not +-- clobber each other. +main = setupAndCabalTest $ do + skipUnless =<< hasCabalForGhc -- use of library test suite + setup_build ["--enable-tests"] + r1 <- fails $ setup' "test" ["foo"] + assertOutputContains "test B" r1 + assertOutputContains "test A" r1 + r2 <- fails $ setup' "test" ["foo2"] + assertOutputContains "test C" r2 + assertOutputContains "test A" r2 diff --git a/cabal/cabal-testsuite/PackageTests/EmptyLib/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/EmptyLib/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/EmptyLib/setup.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring emptyLib-1.0... +# Setup build +Preprocessing library for emptyLib-1.0.. +Building library for emptyLib-1.0.. diff --git a/cabal/cabal-testsuite/PackageTests/EmptyLib/setup.out b/cabal/cabal-testsuite/PackageTests/EmptyLib/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/EmptyLib/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring emptyLib-1.0... +# Setup build +Preprocessing library for emptyLib-1.0.. +Building library for emptyLib-1.0.. diff --git a/cabal/cabal-testsuite/PackageTests/EmptyLib/setup.test.hs b/cabal/cabal-testsuite/PackageTests/EmptyLib/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/EmptyLib/setup.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +-- Test build when the library is empty, for #1241 +main = setupAndCabalTest $ withDirectory "empty" $ setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/Exec/Foo.hs b/cabal/cabal-testsuite/PackageTests/Exec/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +foo :: String +foo = "foo" diff --git a/cabal/cabal-testsuite/PackageTests/Exec/My.hs b/cabal/cabal-testsuite/PackageTests/Exec/My.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/My.hs @@ -0,0 +1,5 @@ +module Main where + +main :: IO () +main = do + putStrLn "This is my-executable" diff --git a/cabal/cabal-testsuite/PackageTests/Exec/T4049/UseLib.c b/cabal/cabal-testsuite/PackageTests/Exec/T4049/UseLib.c new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/T4049/UseLib.c @@ -0,0 +1,9 @@ +#include + +int main() +{ + myForeignLibInit(); + sayHi(); + myForeignLibExit(); + return 0; +} diff --git a/cabal/cabal-testsuite/PackageTests/Exec/T4049/csrc/MyForeignLibWrapper.c b/cabal/cabal-testsuite/PackageTests/Exec/T4049/csrc/MyForeignLibWrapper.c new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/T4049/csrc/MyForeignLibWrapper.c @@ -0,0 +1,23 @@ +#include +#include "HsFFI.h" + +HsBool myForeignLibInit(void){ + int argc = 2; + char *argv[] = { "+RTS", "-A32m", NULL }; + char **pargv = argv; + + // Initialize Haskell runtime + hs_init(&argc, &pargv); + + // do any other initialization here and + // return false if there was a problem + return HS_BOOL_TRUE; +} + +void myForeignLibExit(void){ + hs_exit(); +} + +int cFoo2() { + return 1234; +} diff --git a/cabal/cabal-testsuite/PackageTests/Exec/T4049/my-foreign-lib.cabal b/cabal/cabal-testsuite/PackageTests/Exec/T4049/my-foreign-lib.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/T4049/my-foreign-lib.cabal @@ -0,0 +1,19 @@ +name: my-foreign-lib +version: 0.1.0.0 +author: Edsko de Vries +maintainer: edsko@well-typed.com +build-type: Simple +cabal-version: >=1.10 + +foreign-library myforeignlib + type: native-shared + + if os(windows) + options: standalone + + other-modules: MyForeignLib.Hello + MyForeignLib.SomeBindings + build-depends: base + hs-source-dirs: src + c-sources: csrc/MyForeignLibWrapper.c + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Exec/T4049/sandbox.out b/cabal/cabal-testsuite/PackageTests/Exec/T4049/sandbox.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/T4049/sandbox.out @@ -0,0 +1,12 @@ +# cabal sandbox init +Writing a default package environment file to /sandbox.dist/cabal.sandbox.config +Creating a new sandbox at /sandbox.dist/sandbox +# cabal install +Resolving dependencies... +Configuring my-foreign-lib-0.1.0.0... +Preprocessing foreign library 'myforeignlib' for my-foreign-lib-0.1.0.0.. +Building foreign library 'myforeignlib' for my-foreign-lib-0.1.0.0.. +Installing foreign library myforeignlib in +Installed my-foreign-lib-0.1.0.0 +# cabal exec +Hi from a foreign library! Foo has value 5678 diff --git a/cabal/cabal-testsuite/PackageTests/Exec/T4049/sandbox.test.hs b/cabal/cabal-testsuite/PackageTests/Exec/T4049/sandbox.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/T4049/sandbox.test.hs @@ -0,0 +1,20 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [7,8]) + withSandbox $ do + cabal "install" ["--enable-shared"] + env <- getTestEnv + is_windows <- isWindows + let sandbox_dir = testSandboxDir env + work_dir = testWorkDir env + lib_dir = + -- This is dumb but it's been this way for a long time. + if is_windows + then sandbox_dir + else sandbox_dir "lib" + gcc [ "UseLib.c" + , "-o", work_dir "UseLib" + , "-l" ++ "myforeignlib" + , "-L" ++ lib_dir ] + recordMode RecordAll $ + cabal "exec" ["-v0", work_dir "UseLib"] diff --git a/cabal/cabal-testsuite/PackageTests/Exec/T4049/src/MyForeignLib/Hello.hs b/cabal/cabal-testsuite/PackageTests/Exec/T4049/src/MyForeignLib/Hello.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/T4049/src/MyForeignLib/Hello.hs @@ -0,0 +1,10 @@ +-- | Module with single foreign export +module MyForeignLib.Hello (sayHi) where + +import MyForeignLib.SomeBindings + +foreign export ccall sayHi :: IO () + +-- | Say hi! +sayHi :: IO () +sayHi = putStrLn $ "Hi from a foreign library! Foo has value " ++ show valueOfFoo diff --git a/cabal/cabal-testsuite/PackageTests/Exec/T4049/src/MyForeignLib/SomeBindings.hsc b/cabal/cabal-testsuite/PackageTests/Exec/T4049/src/MyForeignLib/SomeBindings.hsc new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/T4049/src/MyForeignLib/SomeBindings.hsc @@ -0,0 +1,10 @@ +-- | Module that needs the hsc2hs preprocessor +module MyForeignLib.SomeBindings where + +#define FOO 1 + +#ifdef FOO +-- | Value guarded by a CPP flag +valueOfFoo :: Int +valueOfFoo = 5678 +#endif diff --git a/cabal/cabal-testsuite/PackageTests/Exec/cabal.out b/cabal/cabal-testsuite/PackageTests/Exec/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/cabal.out @@ -0,0 +1,10 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - my-0.1 (exe:my-executable) (first run) +Configuring my-0.1... +Preprocessing executable 'my-executable' for my-0.1.. +Building executable 'my-executable' for my-0.1.. +# my my-executable +This is my-executable diff --git a/cabal/cabal-testsuite/PackageTests/Exec/cabal.project b/cabal/cabal-testsuite/PackageTests/Exec/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/Exec/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Exec/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/cabal.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + -- NB: cabal-version: >= 1.2 in my.cabal means we exercise + -- the non per-component code path + cabal "new-build" ["my-executable"] + withPlan $ runPlanExe "my" "my-executable" [] diff --git a/cabal/cabal-testsuite/PackageTests/Exec/legacy-autoconfigure.out b/cabal/cabal-testsuite/PackageTests/Exec/legacy-autoconfigure.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/legacy-autoconfigure.out @@ -0,0 +1,1 @@ +# cabal exec diff --git a/cabal/cabal-testsuite/PackageTests/Exec/legacy-autoconfigure.test.hs b/cabal/cabal-testsuite/PackageTests/Exec/legacy-autoconfigure.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/legacy-autoconfigure.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + cabal' "exec" ["echo", "find_me_in_output"] + >>= assertOutputContains "find_me_in_output" diff --git a/cabal/cabal-testsuite/PackageTests/Exec/legacy-no-args.out b/cabal/cabal-testsuite/PackageTests/Exec/legacy-no-args.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/legacy-no-args.out @@ -0,0 +1,2 @@ +# cabal exec +cabal: Please specify an executable to run diff --git a/cabal/cabal-testsuite/PackageTests/Exec/legacy-no-args.test.hs b/cabal/cabal-testsuite/PackageTests/Exec/legacy-no-args.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/legacy-no-args.test.hs @@ -0,0 +1,2 @@ +import Test.Cabal.Prelude +main = cabalTest $ fails (cabal' "exec" []) >>= assertOutputContains "Please specify an executable to run" diff --git a/cabal/cabal-testsuite/PackageTests/Exec/legacy.out b/cabal/cabal-testsuite/PackageTests/Exec/legacy.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/legacy.out @@ -0,0 +1,4 @@ +# cabal configure +Resolving dependencies... +Configuring my-0.1... +# cabal exec diff --git a/cabal/cabal-testsuite/PackageTests/Exec/legacy.test.hs b/cabal/cabal-testsuite/PackageTests/Exec/legacy.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/legacy.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + cabal "configure" [] + cabal' "exec" ["echo", "find_me_in_output"] + >>= assertOutputContains "find_me_in_output" diff --git a/cabal/cabal-testsuite/PackageTests/Exec/my.cabal b/cabal/cabal-testsuite/PackageTests/Exec/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/my.cabal @@ -0,0 +1,14 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.2 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base + + +executable my-executable + main-is: My.hs + build-depends: base diff --git a/cabal/cabal-testsuite/PackageTests/Exec/sandbox-ghc-pkg.out b/cabal/cabal-testsuite/PackageTests/Exec/sandbox-ghc-pkg.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/sandbox-ghc-pkg.out @@ -0,0 +1,16 @@ +# cabal sandbox init +Writing a default package environment file to /sandbox-ghc-pkg.dist/cabal.sandbox.config +Creating a new sandbox at /sandbox-ghc-pkg.dist/sandbox +# cabal exec +cabal: The program 'my-executable' is required but it could not be found. +# cabal install +Resolving dependencies... +Configuring my-0.1... +Preprocessing executable 'my-executable' for my-0.1.. +Building executable 'my-executable' for my-0.1.. +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Installing executable my-executable in +Installing library in +Installed my-0.1 +# cabal exec diff --git a/cabal/cabal-testsuite/PackageTests/Exec/sandbox-ghc-pkg.test.hs b/cabal/cabal-testsuite/PackageTests/Exec/sandbox-ghc-pkg.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/sandbox-ghc-pkg.test.hs @@ -0,0 +1,12 @@ +import Test.Cabal.Prelude +import Data.Maybe +main = cabalTest $ do + withPackageDb $ do + withSandbox $ do + fails $ cabal "exec" ["my-executable"] + cabal "install" [] + -- The library should not be available outside the sandbox + ghcPkg' "list" [] >>= assertOutputDoesNotContain "my-0.1" + -- Execute ghc-pkg inside the sandbox; it should find my-0.1 + cabal' "exec" ["ghc-pkg", "list"] + >>= assertOutputContains "my-0.1" diff --git a/cabal/cabal-testsuite/PackageTests/Exec/sandbox-hc-pkg.out b/cabal/cabal-testsuite/PackageTests/Exec/sandbox-hc-pkg.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/sandbox-hc-pkg.out @@ -0,0 +1,16 @@ +# cabal sandbox init +Writing a default package environment file to /sandbox-hc-pkg.dist/cabal.sandbox.config +Creating a new sandbox at /sandbox-hc-pkg.dist/sandbox +# cabal exec +cabal: The program 'my-executable' is required but it could not be found. +# cabal install +Resolving dependencies... +Configuring my-0.1... +Preprocessing executable 'my-executable' for my-0.1.. +Building executable 'my-executable' for my-0.1.. +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Installing executable my-executable in +Installing library in +Installed my-0.1 +# cabal exec diff --git a/cabal/cabal-testsuite/PackageTests/Exec/sandbox-hc-pkg.test.hs b/cabal/cabal-testsuite/PackageTests/Exec/sandbox-hc-pkg.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/sandbox-hc-pkg.test.hs @@ -0,0 +1,25 @@ +import Test.Cabal.Prelude +import Data.Maybe +import System.Directory +import Control.Monad.IO.Class +main = cabalTest $ do + withPackageDb $ do + withSandbox $ do + fails $ cabal "exec" ["my-executable"] + cabal "install" [] + -- The library should not be available outside the sandbox + ghcPkg' "list" [] >>= assertOutputDoesNotContain "my-0.1" + -- When run inside 'cabal-exec' the 'sandbox hc-pkg list' sub-command + -- should find the library. + env <- getTestEnv + -- NB: cabal_path might be relative, so we have to + -- turn it absolute + rel_cabal_path <- programPathM cabalProgram + cabal_path <- liftIO $ makeAbsolute rel_cabal_path + cabal' "exec" ["sh", "--", "-c" + , "cd subdir && " ++ show cabal_path ++ + -- TODO: Ugh. Test abstractions leaking + -- through + " --sandbox-config-file " ++ show (testSandboxConfigFile env) ++ + " sandbox hc-pkg list"] + >>= assertOutputContains "my-0.1" diff --git a/cabal/cabal-testsuite/PackageTests/Exec/sandbox-path.out b/cabal/cabal-testsuite/PackageTests/Exec/sandbox-path.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/sandbox-path.out @@ -0,0 +1,16 @@ +# cabal sandbox init +Writing a default package environment file to /sandbox-path.dist/cabal.sandbox.config +Creating a new sandbox at /sandbox-path.dist/sandbox +# cabal exec +cabal: The program 'my-executable' is required but it could not be found. +# cabal install +Resolving dependencies... +Configuring my-0.1... +Preprocessing executable 'my-executable' for my-0.1.. +Building executable 'my-executable' for my-0.1.. +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Installing executable my-executable in +Installing library in +Installed my-0.1 +# cabal exec diff --git a/cabal/cabal-testsuite/PackageTests/Exec/sandbox-path.test.hs b/cabal/cabal-testsuite/PackageTests/Exec/sandbox-path.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/sandbox-path.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withSandbox $ do + fails $ cabal "exec" ["my-executable"] + cabal "install" [] + -- Execute indirectly via bash to ensure that we go through $PATH + cabal' "exec" ["sh", "--", "-c", "my-executable"] + >>= assertOutputContains "This is my-executable" diff --git a/cabal/cabal-testsuite/PackageTests/Exec/sandbox.out b/cabal/cabal-testsuite/PackageTests/Exec/sandbox.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/sandbox.out @@ -0,0 +1,16 @@ +# cabal sandbox init +Writing a default package environment file to /sandbox.dist/cabal.sandbox.config +Creating a new sandbox at /sandbox.dist/sandbox +# cabal exec +cabal: The program 'my-executable' is required but it could not be found. +# cabal install +Resolving dependencies... +Configuring my-0.1... +Preprocessing executable 'my-executable' for my-0.1.. +Building executable 'my-executable' for my-0.1.. +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Installing executable my-executable in +Installing library in +Installed my-0.1 +# cabal exec diff --git a/cabal/cabal-testsuite/PackageTests/Exec/sandbox.test.hs b/cabal/cabal-testsuite/PackageTests/Exec/sandbox.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/sandbox.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withSandbox $ do + fails $ cabal "exec" ["my-executable"] + cabal "install" [] + cabal' "exec" ["my-executable"] + >>= assertOutputContains "This is my-executable" diff --git a/cabal/cabal-testsuite/PackageTests/Exec/subdir/.gitkeep b/cabal/cabal-testsuite/PackageTests/Exec/subdir/.gitkeep new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Exec/subdir/.gitkeep diff --git a/cabal/cabal-testsuite/PackageTests/ExecModern/Foo.hs b/cabal/cabal-testsuite/PackageTests/ExecModern/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ExecModern/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +foo :: String +foo = "foo" diff --git a/cabal/cabal-testsuite/PackageTests/ExecModern/My.hs b/cabal/cabal-testsuite/PackageTests/ExecModern/My.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ExecModern/My.hs @@ -0,0 +1,5 @@ +module Main where + +main :: IO () +main = do + putStrLn "This is my-executable" diff --git a/cabal/cabal-testsuite/PackageTests/ExecModern/cabal.out b/cabal/cabal-testsuite/PackageTests/ExecModern/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ExecModern/cabal.out @@ -0,0 +1,10 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - my-0.1 (exe:my-executable) (first run) +Configuring executable 'my-executable' for my-0.1.. +Preprocessing executable 'my-executable' for my-0.1.. +Building executable 'my-executable' for my-0.1.. +# my my-executable +This is my-executable diff --git a/cabal/cabal-testsuite/PackageTests/ExecModern/cabal.project b/cabal/cabal-testsuite/PackageTests/ExecModern/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ExecModern/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/ExecModern/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/ExecModern/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ExecModern/cabal.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + -- NB: cabal-version: >= 1.2 in my.cabal means we exercise + -- the non per-component code path + cabal "new-build" ["my-executable"] + withPlan $ runPlanExe "my" "my-executable" [] diff --git a/cabal/cabal-testsuite/PackageTests/ExecModern/my.cabal b/cabal/cabal-testsuite/PackageTests/ExecModern/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ExecModern/my.cabal @@ -0,0 +1,15 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.10 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base + default-language: Haskell2010 + +executable my-executable + main-is: My.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/ForeignLibs/.gitignore b/cabal/cabal-testsuite/PackageTests/ForeignLibs/.gitignore new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ForeignLibs/.gitignore @@ -0,0 +1,1 @@ +uselib diff --git a/cabal/cabal-testsuite/PackageTests/ForeignLibs/Check.hs b/cabal/cabal-testsuite/PackageTests/ForeignLibs/Check.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/ForeignLibs/Check.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module PackageTests.ForeignLibs.Check where - -import Control.Exception -import System.Environment -import System.FilePath -import System.IO.Error - -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program.Db -import Distribution.Simple.Program.Builtin -import Distribution.Simple.Program.Types -import Distribution.System -import Distribution.Verbosity -import Distribution.Version - -import PackageTests.PackageTester - --- Foreign libraries don't work with GHC 7.6 and earlier -suite :: TestM () -suite = whenGhcVersion (>= mkVersion [7,8]) . withPackageDb $ do - cabal_install [] - dist_dir <- distDir - pkg_dir <- packageDir - lbi <- liftIO $ getPersistBuildConfig dist_dir - let installDirs = absoluteInstallDirs (localPkgDescr lbi) lbi NoCopyDest - - -- Link a C program against the library - (gcc, _) <- liftIO $ requireProgram normal gccProgram (withPrograms lbi) - _ <- run (Just pkg_dir) (programPath gcc) [ - "-o", "uselib" - , "UseLib.c" - , "-l", "myforeignlib" - , "-L", flibdir installDirs - ] - - -- Run the C program - let ldPath = case hostPlatform lbi of - Platform _ OSX -> "DYLD_LIBRARY_PATH" - Platform _ Windows -> "PATH" - Platform _ _other -> "LD_LIBRARY_PATH" - oldLdPath <- liftIO $ getEnv' ldPath - withEnv [ (ldPath, Just $ flibdir installDirs ++ [searchPathSeparator] ++ oldLdPath) ] $ do - result <- run (Just pkg_dir) - (pkg_dir "uselib") - [] - assertOutputContains "5678" result - assertOutputContains "189" result - -getEnv' :: String -> IO String -getEnv' = handle handler . getEnv - where - handler e = if isDoesNotExistError e - then return "" - else throw e diff --git a/cabal/cabal-testsuite/PackageTests/ForeignLibs/my-foreign-lib.cabal b/cabal/cabal-testsuite/PackageTests/ForeignLibs/my-foreign-lib.cabal --- a/cabal/cabal-testsuite/PackageTests/ForeignLibs/my-foreign-lib.cabal +++ b/cabal/cabal-testsuite/PackageTests/ForeignLibs/my-foreign-lib.cabal @@ -24,3 +24,17 @@ hs-source-dirs: src c-sources: csrc/MyForeignLibWrapper.c default-language: Haskell2010 + +foreign-library versionedlib + type: native-shared + + if !os(linux) + buildable: False + lib-version-info: 9:3:4 + + other-modules: MyForeignLib.Hello + MyForeignLib.SomeBindings + build-depends: base, my-foreign-lib + hs-source-dirs: src + c-sources: csrc/MyForeignLibWrapper.c + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs b/cabal/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} + +import Control.Exception +import Control.Monad.IO.Class +import System.Environment +import System.FilePath +import System.IO.Error +#ifndef mingw32_HOST_OS +import System.Posix (readSymbolicLink) +#endif /* mingw32_HOST_OS */ + +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Builtin +import Distribution.Simple.Program.Types +import Distribution.System +import Distribution.Verbosity +import Distribution.Version + +import Test.Cabal.Prelude + +-- Test that foreign libraries work +-- Recording is turned off because versionedlib will or will not +-- be installed depending on if we're on Linux or not. +main = setupAndCabalTest . recordMode DoNotRecord $ do + -- Foreign libraries don't work with GHC 7.6 and earlier + skipUnless =<< ghcVersionIs (>= mkVersion [7,8]) + withPackageDb $ do + setup_install [] + setup "copy" [] -- regression test #4156 + dist_dir <- fmap testDistDir getTestEnv + lbi <- getLocalBuildInfoM + let installDirs = absoluteInstallDirs (localPkgDescr lbi) lbi NoCopyDest + + -- Link a C program against the library + _ <- runProgramM gccProgram + [ "-o", "uselib" + , "UseLib.c" + , "-l", "myforeignlib" + , "-L", flibdir installDirs ] + + -- Run the C program + let ldPath = case hostPlatform lbi of + Platform _ OSX -> "DYLD_LIBRARY_PATH" + Platform _ Windows -> "PATH" + Platform _ _other -> "LD_LIBRARY_PATH" + oldLdPath <- liftIO $ getEnv' ldPath + withEnv [ (ldPath, Just $ flibdir installDirs ++ [searchPathSeparator] ++ oldLdPath) ] $ do + cwd <- fmap testCurrentDir getTestEnv + result <- runM (cwd "uselib") [] + assertOutputContains "5678" result + assertOutputContains "189" result + + -- If we're on Linux, we should have built a library with a + -- version. We will now check that it was installed correctly. +#ifndef mingw32_HOST_OS + case hostPlatform lbi of + Platform _ Linux -> do + let libraryName = "libversionedlib.so.5.4.3" + libdir = flibdir installDirs + objdumpProgram = simpleProgram "objdump" + (objdump, _) <- liftIO $ requireProgram normal objdumpProgram (withPrograms lbi) + path1 <- liftIO $ readSymbolicLink $ libdir "libversionedlib.so" + path2 <- liftIO $ readSymbolicLink $ libdir "libversionedlib.so.5" + assertEqual "Symbolic link 'libversionedlib.so' incorrect" + path1 libraryName + assertEqual "Symbolic link 'libversionedlib.so.5' incorrect" + path2 libraryName + objInfo <- runM (programPath objdump) [ + "-x" + , libdir libraryName + ] + assertBool "SONAME of 'libversionedlib.so.5.4.3' incorrect" $ + elem "libversionedlib.so.5" $ words $ resultOutput objInfo + _ -> return () +#endif /* mingw32_HOST_OS */ + +getEnv' :: String -> IO String +getEnv' = handle handler . getEnv + where + handler e = if isDoesNotExistError e + then return "" + else throw e diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/disable-benchmarks.out b/cabal/cabal-testsuite/PackageTests/Freeze/disable-benchmarks.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/disable-benchmarks.out @@ -0,0 +1,4 @@ +# cabal update +Downloading the latest package list from test-local-repo +# cabal freeze +Resolving dependencies... diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/disable-benchmarks.test.hs b/cabal/cabal-testsuite/PackageTests/Freeze/disable-benchmarks.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/disable-benchmarks.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withRepo "repo" . withSourceCopy $ do + cabal "freeze" ["--disable-benchmarks"] + cwd <- fmap testCurrentDir getTestEnv + assertFileDoesNotContain (cwd "cabal.config") "criterion" diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/disable-tests.out b/cabal/cabal-testsuite/PackageTests/Freeze/disable-tests.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/disable-tests.out @@ -0,0 +1,4 @@ +# cabal update +Downloading the latest package list from test-local-repo +# cabal freeze +Resolving dependencies... diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/disable-tests.test.hs b/cabal/cabal-testsuite/PackageTests/Freeze/disable-tests.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/disable-tests.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withRepo "repo" . withSourceCopy $ do + cabal "freeze" ["--disable-tests"] + cwd <- fmap testCurrentDir getTestEnv + assertFileDoesNotContain (cwd "cabal.config") "test-framework" diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/dry-run.out b/cabal/cabal-testsuite/PackageTests/Freeze/dry-run.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/dry-run.out @@ -0,0 +1,2 @@ +# cabal update +Downloading the latest package list from test-local-repo diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/dry-run.test.hs b/cabal/cabal-testsuite/PackageTests/Freeze/dry-run.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/dry-run.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withRepo "repo" . withSourceCopy $ do + recordMode DoNotRecord $ cabal "freeze" ["--dry-run"] + cwd <- fmap testCurrentDir getTestEnv + shouldNotExist (cwd "cabal.config") diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/enable-benchmarks.out b/cabal/cabal-testsuite/PackageTests/Freeze/enable-benchmarks.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/enable-benchmarks.out @@ -0,0 +1,4 @@ +# cabal update +Downloading the latest package list from test-local-repo +# cabal freeze +Resolving dependencies... diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/enable-benchmarks.test.hs b/cabal/cabal-testsuite/PackageTests/Freeze/enable-benchmarks.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/enable-benchmarks.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withRepo "repo" . withSourceCopy $ do + cabal "freeze" ["--enable-benchmarks"] + cwd <- fmap testCurrentDir getTestEnv + assertFileDoesContain (cwd "cabal.config") "criterion" + assertFileDoesContain (cwd "cabal.config") "ghc-prim" diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/enable-tests.out b/cabal/cabal-testsuite/PackageTests/Freeze/enable-tests.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/enable-tests.out @@ -0,0 +1,4 @@ +# cabal update +Downloading the latest package list from test-local-repo +# cabal freeze +Resolving dependencies... diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/enable-tests.test.hs b/cabal/cabal-testsuite/PackageTests/Freeze/enable-tests.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/enable-tests.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withRepo "repo" . withSourceCopy $ do + cabal "freeze" ["--enable-tests"] + cwd <- fmap testCurrentDir getTestEnv + assertFileDoesContain (cwd "cabal.config") "test-framework" diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/freeze.out b/cabal/cabal-testsuite/PackageTests/Freeze/freeze.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/freeze.out @@ -0,0 +1,4 @@ +# cabal update +Downloading the latest package list from test-local-repo +# cabal freeze +Resolving dependencies... diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/freeze.test.hs b/cabal/cabal-testsuite/PackageTests/Freeze/freeze.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/freeze.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withRepo "repo" . withSourceCopy $ do + -- TODO: test this with a sandbox-installed package + -- that is not depended upon + cabal "freeze" [] + cwd <- fmap testCurrentDir getTestEnv + assertFileDoesNotContain (cwd "cabal.config") "exceptions" + assertFileDoesNotContain (cwd "cabal.config") "my" + assertFileDoesContain (cwd "cabal.config") "base" diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/my.cabal b/cabal/cabal-testsuite/PackageTests/Freeze/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/my.cabal @@ -0,0 +1,21 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.20.0 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base + +test-suite test-Foo + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: test-Foo.hs + build-depends: base, my, test-framework + +benchmark bench-Foo + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: benchmark-Foo.hs + build-depends: base, my, criterion diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/repo/criterion-1.1.4.0/criterion.cabal b/cabal/cabal-testsuite/PackageTests/Freeze/repo/criterion-1.1.4.0/criterion.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/repo/criterion-1.1.4.0/criterion.cabal @@ -0,0 +1,8 @@ +name: criterion +version: 1.1.4.0 +build-type: Simple +cabal-version: >= 1.10 + +library + build-depends: base, ghc-prim + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Freeze/repo/test-framework-0.8.1.1/test-framework.cabal b/cabal/cabal-testsuite/PackageTests/Freeze/repo/test-framework-0.8.1.1/test-framework.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Freeze/repo/test-framework-0.8.1.1/test-framework.cabal @@ -0,0 +1,8 @@ +name: test-framework +version: 0.8.1.1 +build-type: Simple +cabal-version: >= 1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.cabal.out @@ -0,0 +1,2 @@ +# Setup configure +cabal: Version mismatch between ghc and ghc-pkg: /./ghc is version /./ghc-pkg is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.out @@ -0,0 +1,3 @@ +# Setup configure +Configuring SameDirectory-0.1.0.0... +setup: Version mismatch between ghc and ghc-pkg: /./ghc is version /./ghc-pkg is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.test.hs b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectory/setup.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude +-- TODO: Enable this test on Windows +main = setupAndCabalTest $ do + skipIf =<< isWindows + env <- getTestEnv + let cwd = testCurrentDir env + ghc_path <- programPathM ghcProgram + r <- withEnv [("WITH_GHC", Just ghc_path)] + . fails $ setup' "configure" ["-w", cwd "ghc"] + assertOutputContains "is version 9999999" r diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.cabal.out @@ -0,0 +1,2 @@ +# Setup configure +cabal: Version mismatch between ghc and ghc-pkg: /./ghc-7.10 is version /./ghc-pkg-ghc-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.out @@ -0,0 +1,3 @@ +# Setup configure +Configuring SameDirectory-0.1.0.0... +setup: Version mismatch between ghc and ghc-pkg: /./ghc-7.10 is version /./ghc-pkg-ghc-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.test.hs b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/setup.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude +-- TODO: Enable this test on Windows +main = setupAndCabalTest $ do + skipIf =<< isWindows + env <- getTestEnv + let cwd = testCurrentDir env + ghc_path <- programPathM ghcProgram + r <- withEnv [("WITH_GHC", Just ghc_path)] + . fails $ setup' "configure" ["-w", cwd "ghc-7.10"] + assertOutputContains "is version 9999999" r diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.cabal.out @@ -0,0 +1,2 @@ +# Setup configure +cabal: Version mismatch between ghc and ghc-pkg: /./ghc-7.10 is version /./ghc-pkg-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.out @@ -0,0 +1,3 @@ +# Setup configure +Configuring SameDirectory-0.1.0.0... +setup: Version mismatch between ghc and ghc-pkg: /./ghc-7.10 is version /./ghc-pkg-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.test.hs b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SameDirectoryVersion/setup.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude +-- TODO: Enable this test on Windows +main = setupAndCabalTest $ do + skipIf =<< isWindows + env <- getTestEnv + let cwd = testCurrentDir env + ghc_path <- programPathM ghcProgram + r <- withEnv [("WITH_GHC", Just ghc_path)] + . fails $ setup' "configure" ["-w", cwd "ghc-7.10"] + assertOutputContains "is version 9999999" r diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.cabal.out @@ -0,0 +1,2 @@ +# Setup configure +cabal: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.out @@ -0,0 +1,3 @@ +# Setup configure +Configuring SameDirectory-0.1.0.0... +setup: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.test.hs b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/Symlink/setup.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude +-- TODO: Enable this test on Windows +main = setupAndCabalTest $ do + skipIf =<< isWindows + withSymlink "bin/ghc" "ghc" $ do + env <- getTestEnv + let cwd = testCurrentDir env + ghc_path <- programPathM ghcProgram + r <- withEnv [("WITH_GHC", Just ghc_path)] + . fails $ setup' "configure" ["-w", cwd "ghc"] + assertOutputContains "is version 9999999" r diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.cabal.out @@ -0,0 +1,2 @@ +# Setup configure +cabal: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.out @@ -0,0 +1,3 @@ +# Setup configure +Configuring SameDirectory-0.1.0.0... +setup: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.test.hs b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkGhcVersion/setup.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude +-- TODO: Enable this test on Windows +main = setupAndCabalTest $ do + skipIf =<< isWindows + withSymlink "bin/ghc-7.10" "ghc" $ do + env <- getTestEnv + let cwd = testCurrentDir env + ghc_path <- programPathM ghcProgram + r <- withEnv [("WITH_GHC", Just ghc_path)] + . fails $ setup' "configure" ["-w", cwd "ghc"] + assertOutputContains "is version 9999999" r diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.cabal.out @@ -0,0 +1,2 @@ +# Setup configure +cabal: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg-ghc-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.out b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.out @@ -0,0 +1,3 @@ +# Setup configure +Configuring SameDirectory-0.1.0.0... +setup: Version mismatch between ghc and ghc-pkg: /./ghc is version /bin/ghc-pkg-ghc-7.10 is version 9999999 diff --git a/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.test.hs b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/GhcPkgGuess/SymlinkVersion/setup.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude +-- TODO: Enable this test on Windows +main = setupAndCabalTest $ do + skipIf =<< isWindows + withSymlink "bin/ghc-7.10" "ghc" $ do + env <- getTestEnv + let cwd = testCurrentDir env + ghc_path <- programPathM ghcProgram + r <- withEnv [("WITH_GHC", Just ghc_path)] + . fails $ setup' "configure" ["-w", cwd "ghc"] + assertOutputContains "is version 9999999" r diff --git a/cabal/cabal-testsuite/PackageTests/Haddock/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Haddock/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Haddock/setup.cabal.out @@ -0,0 +1,7 @@ +# Setup configure +Resolving dependencies... +Configuring Haddock-0.1... +# Setup haddock +Preprocessing library for Haddock-0.1.. +Running Haddock on library for Haddock-0.1.. +Documentation created: setup.cabal.dist/work/dist/doc/html/Haddock/index.html diff --git a/cabal/cabal-testsuite/PackageTests/Haddock/setup.out b/cabal/cabal-testsuite/PackageTests/Haddock/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Haddock/setup.out @@ -0,0 +1,6 @@ +# Setup configure +Configuring Haddock-0.1... +# Setup haddock +Preprocessing library for Haddock-0.1.. +Running Haddock on library for Haddock-0.1.. +Documentation created: setup.dist/work/dist/doc/html/Haddock/index.html diff --git a/cabal/cabal-testsuite/PackageTests/Haddock/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Haddock/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Haddock/setup.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude +-- Test that "./Setup haddock" works correctly +main = setupAndCabalTest $ do + env <- getTestEnv + let haddocksDir = testDistDir env "doc" "html" "Haddock" + setup "configure" [] + setup "haddock" [] + let docFiles + = map (haddocksDir ) + ["CPP.html", "Literate.html", "NoCPP.html", "Simple.html"] + mapM_ (assertFindInFile "For hiding needles.") docFiles diff --git a/cabal/cabal-testsuite/PackageTests/HaddockNewline/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/HaddockNewline/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockNewline/setup.cabal.out @@ -0,0 +1,7 @@ +# Setup configure +Resolving dependencies... +Configuring HaddockNewline-0.1.0.0... +# Setup haddock +Preprocessing library for HaddockNewline-0.1.0.0.. +Running Haddock on library for HaddockNewline-0.1.0.0.. +Documentation created: setup.cabal.dist/work/dist/doc/html/HaddockNewline/index.html diff --git a/cabal/cabal-testsuite/PackageTests/HaddockNewline/setup.out b/cabal/cabal-testsuite/PackageTests/HaddockNewline/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockNewline/setup.out @@ -0,0 +1,6 @@ +# Setup configure +Configuring HaddockNewline-0.1.0.0... +# Setup haddock +Preprocessing library for HaddockNewline-0.1.0.0.. +Running Haddock on library for HaddockNewline-0.1.0.0.. +Documentation created: setup.dist/work/dist/doc/html/HaddockNewline/index.html diff --git a/cabal/cabal-testsuite/PackageTests/HaddockNewline/setup.test.hs b/cabal/cabal-testsuite/PackageTests/HaddockNewline/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/HaddockNewline/setup.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +-- Test that Haddock with a newline in synopsis works correctly, #3004 +main = setupAndCabalTest $ do + setup "configure" [] + setup "haddock" [] diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/foo.cabal b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/foo.cabal --- a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/foo.cabal +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/foo.cabal @@ -16,3 +16,4 @@ main-is: Main.hs build-depends: base, foo-internal hs-source-dirs: exe + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.cabal.out @@ -0,0 +1,36 @@ +# Setup configure +Resolving dependencies... +Configuring foo-0.1.0.0... +# Setup build +Preprocessing library 'foo-internal' for foo-0.1.0.0.. +Building library 'foo-internal' for foo-0.1.0.0.. +Preprocessing executable 'foo' for foo-0.1.0.0.. +Building executable 'foo' for foo-0.1.0.0.. +# Setup copy +Installing internal library foo-internal in +Installing executable foo in +Warning: The directory /setup-static.cabal.dist/usr/bin is not in the system search path. +# Setup register +Registering library 'foo-internal' for foo-0.1.0.0.. +# Setup clean +cleaning... +# foo +46 +# Setup configure +Resolving dependencies... +Configuring foo-0.1.0.0... +# Setup build +Preprocessing library 'foo-internal' for foo-0.1.0.0.. +Building library 'foo-internal' for foo-0.1.0.0.. +Preprocessing executable 'foo' for foo-0.1.0.0.. +Building executable 'foo' for foo-0.1.0.0.. +# Setup copy +Installing internal library foo-internal in +Installing executable foo in +Warning: The directory /setup-static.cabal.dist/usr/bin is not in the system search path. +# Setup register +Registering library 'foo-internal' for foo-0.1.0.0.. +# Setup clean +cleaning... +# foo +46 diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.out @@ -0,0 +1,34 @@ +# Setup configure +Configuring foo-0.1.0.0... +# Setup build +Preprocessing library 'foo-internal' for foo-0.1.0.0.. +Building library 'foo-internal' for foo-0.1.0.0.. +Preprocessing executable 'foo' for foo-0.1.0.0.. +Building executable 'foo' for foo-0.1.0.0.. +# Setup copy +Installing internal library foo-internal in +Installing executable foo in +Warning: The directory /setup-static.dist/usr/bin is not in the system search path. +# Setup register +Registering library 'foo-internal' for foo-0.1.0.0.. +# Setup clean +cleaning... +# foo +46 +# Setup configure +Configuring foo-0.1.0.0... +# Setup build +Preprocessing library 'foo-internal' for foo-0.1.0.0.. +Building library 'foo-internal' for foo-0.1.0.0.. +Preprocessing executable 'foo' for foo-0.1.0.0.. +Building executable 'foo' for foo-0.1.0.0.. +# Setup copy +Installing internal library foo-internal in +Installing executable foo in +Warning: The directory /setup-static.dist/usr/bin is not in the system search path. +# Setup register +Registering library 'foo-internal' for foo-0.1.0.0.. +# Setup clean +cleaning... +# foo +46 diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.test.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Executable/setup-static.test.hs @@ -0,0 +1,53 @@ +import Test.Cabal.Prelude +import Control.Monad.IO.Class +import Control.Monad +import Distribution.Package +import Distribution.Simple.Configure +import Distribution.Simple.BuildPaths +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.InstallDirs +import Distribution.Simple.Compiler +import Distribution.Types.TargetInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.UnqualComponentName +import System.Directory + +-- Internal libraries used by a statically linked executable: +-- no libraries should get installed or registered. (Note, +-- this does build shared libraries just to make sure they +-- don't get installed, so this test doesn't work on Windows.) +main = setupAndCabalTest $ do + skipUnless =<< hasSharedLibraries + withPackageDb $ do + -- MULTI + forM_ [False, True] $ \is_dynamic -> do + setup_install $ [ if is_dynamic then "--enable-executable-dynamic" + else "--disable-executable-dynamic" + , "--enable-shared"] + dist_dir <- fmap testDistDir getTestEnv + lbi <- liftIO $ getPersistBuildConfig dist_dir + let pkg_descr = localPkgDescr lbi + compiler_id = compilerId (compiler lbi) + cname = CSubLibName $ mkUnqualComponentName "foo-internal" + [target] = componentNameTargets' pkg_descr lbi cname + uid = componentUnitId (targetCLBI target) + InstallDirs{libdir=dir,dynlibdir=dyndir} = + absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest + assertBool "interface files should be installed" + =<< liftIO (doesFileExist (dir "Foo.hi")) + assertBool "static library should be installed" + =<< liftIO (doesFileExist (dir mkLibName uid)) + if is_dynamic + then + assertBool "dynamic library MUST be installed" + =<< liftIO (doesFileExist (dyndir mkSharedLibName + compiler_id uid)) + else + assertBool "dynamic library should be installed" + =<< liftIO (doesFileExist (dyndir mkSharedLibName + compiler_id uid)) + fails $ ghcPkg "describe" ["foo"] + -- clean away the dist directory so that we catch accidental + -- dependence on the inplace files + setup "clean" [] + runInstalledExe' "foo" [] >>= assertOutputContains "46" diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Library/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Library/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Library/setup.cabal.out @@ -0,0 +1,23 @@ +# Setup configure +Resolving dependencies... +Configuring foolib-0.1.0.0... +Warning: Packages using 'cabal-version: >= 1.10' must specify the 'default-language' field for each component (e.g. Haskell98 or Haskell2010). If a component uses different languages in different modules then list the other ones in the 'other-languages' field. +# Setup build +Preprocessing library 'foolib-internal' for foolib-0.1.0.0.. +Building library 'foolib-internal' for foolib-0.1.0.0.. +Preprocessing library for foolib-0.1.0.0.. +Building library for foolib-0.1.0.0.. +# Setup copy +Installing internal library foolib-internal in +Installing library in +# Setup register +Registering library 'foolib-internal' for foolib-0.1.0.0.. +Registering library for foolib-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring fooexe-0.1.0.0... +# Setup build +Preprocessing executable 'fooexe' for fooexe-0.1.0.0.. +Building executable 'fooexe' for fooexe-0.1.0.0.. +# fooexe +25 diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Library/setup.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Library/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Library/setup.out @@ -0,0 +1,21 @@ +# Setup configure +Configuring foolib-0.1.0.0... +Warning: Packages using 'cabal-version: >= 1.10' must specify the 'default-language' field for each component (e.g. Haskell98 or Haskell2010). If a component uses different languages in different modules then list the other ones in the 'other-languages' field. +# Setup build +Preprocessing library 'foolib-internal' for foolib-0.1.0.0.. +Building library 'foolib-internal' for foolib-0.1.0.0.. +Preprocessing library for foolib-0.1.0.0.. +Building library for foolib-0.1.0.0.. +# Setup copy +Installing internal library foolib-internal in +Installing library in +# Setup register +Registering library 'foolib-internal' for foolib-0.1.0.0.. +Registering library for foolib-0.1.0.0.. +# Setup configure +Configuring fooexe-0.1.0.0... +# Setup build +Preprocessing executable 'fooexe' for fooexe-0.1.0.0.. +Building executable 'fooexe' for fooexe-0.1.0.0.. +# fooexe +25 diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/Library/setup.test.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Library/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/Library/setup.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude +-- Internal library used by public library; it must be installed and +-- registered. +main = setupAndCabalTest $ + withPackageDb $ do + withDirectory "foolib" $ setup_install [] + withDirectory "fooexe" $ do + setup_build [] + runExe' "fooexe" [] + >>= assertOutputContains "25" diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal-per-package.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal-per-package.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal-per-package.out @@ -0,0 +1,6 @@ +# cabal new-build +Resolving dependencies... +Error: + Internal libraries only supported with per-component builds. + Per-component builds were disabled because you passed --disable-per-component + In the inplace package 'p-0.1.0.0' diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal-per-package.test.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal-per-package.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal-per-package.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + fails $ cabal "new-build" ["--disable-per-component", "p"] diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal.out @@ -0,0 +1,16 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - p-0.1.0.0 (lib:q) (first run) + - p-0.1.0.0 (exe:foo) (first run) + - p-0.1.0.0 (lib) (first run) +Configuring library 'q' for p-0.1.0.0.. +Preprocessing library 'q' for p-0.1.0.0.. +Building library 'q' for p-0.1.0.0.. +Configuring executable 'foo' for p-0.1.0.0.. +Preprocessing executable 'foo' for p-0.1.0.0.. +Building executable 'foo' for p-0.1.0.0.. +Configuring library for p-0.1.0.0.. +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal.project b/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal.project @@ -0,0 +1,1 @@ +packages: p q diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + cabal "new-build" ["p"] diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/p/p.cabal b/cabal/cabal-testsuite/PackageTests/InternalLibraries/p/p.cabal --- a/cabal/cabal-testsuite/PackageTests/InternalLibraries/p/p.cabal +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/p/p.cabal @@ -21,3 +21,4 @@ executable foo build-depends: base, q main-is: Foo.hs + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/sandbox-shadow.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/sandbox-shadow.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/sandbox-shadow.out @@ -0,0 +1,18 @@ +# cabal sandbox init +Writing a default package environment file to /sandbox-shadow.dist/cabal.sandbox.config +Creating a new sandbox at /sandbox-shadow.dist/sandbox +# cabal sandbox add-source +# cabal sandbox add-source +# cabal install +Resolving dependencies... +Configuring p-0.1.0.0... +Preprocessing library 'q' for p-0.1.0.0.. +Building library 'q' for p-0.1.0.0.. +Preprocessing executable 'foo' for p-0.1.0.0.. +Building executable 'foo' for p-0.1.0.0.. +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +Installing internal library q in +Installing executable foo in +Installing library in +Installed p-0.1.0.0 diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/sandbox-shadow.test.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/sandbox-shadow.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/sandbox-shadow.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withSandbox $ do + cabal_sandbox "add-source" ["p"] + cabal_sandbox "add-source" ["q"] + cabal "install" ["p"] diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/sandbox.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/sandbox.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/sandbox.out @@ -0,0 +1,17 @@ +# cabal sandbox init +Writing a default package environment file to /sandbox.dist/cabal.sandbox.config +Creating a new sandbox at /sandbox.dist/sandbox +# cabal sandbox add-source +# cabal install +Resolving dependencies... +Configuring p-0.1.0.0... +Preprocessing library 'q' for p-0.1.0.0.. +Building library 'q' for p-0.1.0.0.. +Preprocessing executable 'foo' for p-0.1.0.0.. +Building executable 'foo' for p-0.1.0.0.. +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +Installing internal library q in +Installing executable foo in +Installing library in +Installed p-0.1.0.0 diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/sandbox.test.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/sandbox.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/sandbox.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withSandbox $ do + cabal_sandbox "add-source" ["p"] + cabal "install" ["p"] diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-pkg-config.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-pkg-config.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-pkg-config.cabal.out @@ -0,0 +1,26 @@ +# Setup configure +Resolving dependencies... +Configuring p-0.1.0.0... +# Setup build +Preprocessing library 'q' for p-0.1.0.0.. +Building library 'q' for p-0.1.0.0.. +Preprocessing executable 'foo' for p-0.1.0.0.. +Building executable 'foo' for p-0.1.0.0.. +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing internal library q in +Installing executable foo in +Warning: The directory /setup-gen-pkg-config.cabal.dist/usr/bin is not in the system search path. +Installing library in +# Setup register +# Setup configure +Resolving dependencies... +Configuring r-0.1.0.0... +# Setup build +Preprocessing library for r-0.1.0.0.. +Building library for r-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for r-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-pkg-config.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-pkg-config.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-pkg-config.out @@ -0,0 +1,24 @@ +# Setup configure +Configuring p-0.1.0.0... +# Setup build +Preprocessing library 'q' for p-0.1.0.0.. +Building library 'q' for p-0.1.0.0.. +Preprocessing executable 'foo' for p-0.1.0.0.. +Building executable 'foo' for p-0.1.0.0.. +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing internal library q in +Installing executable foo in +Warning: The directory /setup-gen-pkg-config.dist/usr/bin is not in the system search path. +Installing library in +# Setup register +# Setup configure +Configuring r-0.1.0.0... +# Setup build +Preprocessing library for r-0.1.0.0.. +Building library for r-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for r-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-pkg-config.test.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-pkg-config.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-pkg-config.test.hs @@ -0,0 +1,24 @@ +import Test.Cabal.Prelude +import Control.Monad +import Control.Monad.IO.Class +import System.Directory +import Data.List +-- Test to see if --gen-pkg-config works. +main = setupAndCabalTest $ do + withPackageDb $ do + withDirectory "p" $ do + setup_build [] + setup "copy" [] + let dir = "pkg-config.bak" + setup "register" ["--gen-pkg-config=" ++ dir] + -- Infelicity! Does not respect CWD. + env <- getTestEnv + let cwd = testCurrentDir env + notHidden = not . isHidden + isHidden name = "." `isPrefixOf` name + confs <- fmap (sort . filter notHidden) + . liftIO $ getDirectoryContents (cwd dir) + forM_ confs $ \conf -> ghcPkg "register" [cwd dir conf] + + -- Make sure we can see p + withDirectory "r" $ setup_install [] diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-script.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-script.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-script.cabal.out @@ -0,0 +1,26 @@ +# Setup configure +Resolving dependencies... +Configuring p-0.1.0.0... +# Setup build +Preprocessing library 'q' for p-0.1.0.0.. +Building library 'q' for p-0.1.0.0.. +Preprocessing executable 'foo' for p-0.1.0.0.. +Building executable 'foo' for p-0.1.0.0.. +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing internal library q in +Installing executable foo in +Warning: The directory /setup-gen-script.cabal.dist/usr/bin is not in the system search path. +Installing library in +# Setup register +# Setup configure +Resolving dependencies... +Configuring r-0.1.0.0... +# Setup build +Preprocessing library for r-0.1.0.0.. +Building library for r-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for r-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-script.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-script.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-script.out @@ -0,0 +1,24 @@ +# Setup configure +Configuring p-0.1.0.0... +# Setup build +Preprocessing library 'q' for p-0.1.0.0.. +Building library 'q' for p-0.1.0.0.. +Preprocessing executable 'foo' for p-0.1.0.0.. +Building executable 'foo' for p-0.1.0.0.. +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing internal library q in +Installing executable foo in +Warning: The directory /setup-gen-script.dist/usr/bin is not in the system search path. +Installing library in +# Setup register +# Setup configure +Configuring r-0.1.0.0... +# Setup build +Preprocessing library for r-0.1.0.0.. +Building library for r-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for r-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-script.test.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-script.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-gen-script.test.hs @@ -0,0 +1,15 @@ +import Test.Cabal.Prelude +-- Test to see if --gen-script +main = setupAndCabalTest $ do + is_windows <- isWindows + withPackageDb $ do + withDirectory "p" $ do + setup_build [] + setup "copy" [] + setup "register" ["--gen-script"] + _ <- if is_windows + then shell "cmd" ["/C", "register.bat"] + else shell "sh" ["register.sh"] + return () + -- Make sure we can see p + withDirectory "r" $ setup_install [] diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-per-component.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-per-component.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-per-component.out @@ -0,0 +1,29 @@ +# Setup configure +Configuring library 'q' for p-0.1.0.0.. +# Setup build +Preprocessing library 'q' for p-0.1.0.0.. +Building library 'q' for p-0.1.0.0.. +# Setup copy +Installing internal library q in +# Setup register +Registering library 'q' for p-0.1.0.0.. +# Setup configure +Configuring library for p-0.1.0.0.. +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for p-0.1.0.0.. +# Setup configure +Configuring executable 'foo' for p-0.1.0.0.. +# Setup build +Preprocessing executable 'foo' for p-0.1.0.0.. +Building executable 'foo' for p-0.1.0.0.. +# Setup copy +Installing executable foo in +Warning: The directory /setup-per-component.dist/usr/bin is not in the system search path. +# Setup register +# foo +I AM THE ONE diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-per-component.test.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-per-component.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup-per-component.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude +-- No cabal test because per-component is broken for it +main = setupTest $ do + withPackageDb $ do + withDirectory "p" $ do + setup_install ["q"] + setup_install ["p"] + setup_install ["foo"] + runInstalledExe "foo" [] + diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup.cabal.out @@ -0,0 +1,32 @@ +# Setup configure +Resolving dependencies... +Configuring q-0.1.0.0... +# Setup build +Preprocessing library for q-0.1.0.0.. +Building library for q-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for q-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring p-0.1.0.0... +# Setup build +Preprocessing library 'q' for p-0.1.0.0.. +Building library 'q' for p-0.1.0.0.. +Preprocessing executable 'foo' for p-0.1.0.0.. +Building executable 'foo' for p-0.1.0.0.. +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing internal library q in +Installing executable foo in +Warning: The directory /setup.cabal.dist/usr/bin is not in the system search path. +Installing library in +# Setup register +Registering library 'q' for p-0.1.0.0.. +Registering library for p-0.1.0.0.. +# Setup clean +cleaning... +# foo +I AM THE ONE diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup.out b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup.out @@ -0,0 +1,30 @@ +# Setup configure +Configuring q-0.1.0.0... +# Setup build +Preprocessing library for q-0.1.0.0.. +Building library for q-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for q-0.1.0.0.. +# Setup configure +Configuring p-0.1.0.0... +# Setup build +Preprocessing library 'q' for p-0.1.0.0.. +Building library 'q' for p-0.1.0.0.. +Preprocessing executable 'foo' for p-0.1.0.0.. +Building executable 'foo' for p-0.1.0.0.. +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing internal library q in +Installing executable foo in +Warning: The directory /setup.dist/usr/bin is not in the system search path. +Installing library in +# Setup register +Registering library 'q' for p-0.1.0.0.. +Registering library for p-0.1.0.0.. +# Setup clean +cleaning... +# foo +I AM THE ONE diff --git a/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup.test.hs b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalLibraries/setup.test.hs @@ -0,0 +1,12 @@ +import Test.Cabal.Prelude +-- Basic test for internal libraries (in p); package q is to make +-- sure that the internal library correctly is used, not the +-- external library. +main = setupAndCabalTest $ do + withPackageDb $ do + withDirectory "q" $ setup_install [] + withDirectory "p" $ do + setup_install [] + setup "clean" [] + r <- runInstalledExe' "foo" [] + assertOutputContains "I AM THE ONE" r diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/Foo.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/Foo.hs @@ -0,0 +1,1 @@ +module Foo where diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/Main.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/build-depends-bad-version.cabal b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/build-depends-bad-version.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/build-depends-bad-version.cabal @@ -0,0 +1,17 @@ +name: build-depends-bad-version +version: 0.1.0.0 +synopsis: Checks build-depends errs for bad version +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Foo + default-language: Haskell2010 + +executable bar + main-is: Main.hs + build-depends: build-depends-bad-version >=2 + -- ^ internal dependency, bad version bounds + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.cabal.out @@ -0,0 +1,10 @@ +# Setup configure +Resolving dependencies... +Warning: solver failed to find a solution: +Could not resolve dependencies: +next goal: build-depends-bad-version (user goal) +rejecting: build-depends-bad-version-0.1.0.0 (conflict: build-depends-bad-version==0.1.0.0, build-depends-bad-version => build-depends-bad-version>=2) +After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: build-depends-bad-version (2) +Trying configure anyway. +Configuring build-depends-bad-version-0.1.0.0... +cabal: The package has an impossible version range for a dependency on an internal library: build-depends-bad-version >=2. This version range does not include the current package, and must be removed as the current package's library will always be used. diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.out @@ -0,0 +1,3 @@ +# Setup configure +Configuring build-depends-bad-version-0.1.0.0... +setup: The package has an impossible version range for a dependency on an internal library: build-depends-bad-version >=2. This version range does not include the current package, and must be removed as the current package's library will always be used. diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.test.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsBad/setup.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +-- Test impossible version bound on internal build-tools deps +main = setupAndCabalTest $ do + assertOutputContains "impossible version range" + =<< fails (setup' "configure" []) diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/Foo.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/Foo.hs @@ -0,0 +1,1 @@ +module Foo where diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/Main.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/build-depends-extra-version.cabal b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/build-depends-extra-version.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/build-depends-extra-version.cabal @@ -0,0 +1,17 @@ +name: build-depends-extra-version +version: 0.1.0.0 +synopsis: Checks build-depends warns for extraneous version +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Foo + default-language: Haskell2010 + +executable bar + main-is: Main.hs + build-depends: build-depends-extra-version >=0.0.0.1 + -- ^ internal dependency, extraneous version + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.cabal.out @@ -0,0 +1,16 @@ +# Setup configure +Resolving dependencies... +Configuring build-depends-extra-version-0.1.0.0... +Warning: The package has an extraneous version range for a dependency on an internal library: build-depends-extra-version >=0.0.0.1. This version range includes the current package but isn't needed as the current package's library will always be used. +# Setup sdist +Distribution quality errors: +The package has an extraneous version range for a dependency on an internal library: build-depends-extra-version >=0.0.0.1. This version range includes the current package but isn't needed as the current package's library will always be used. +Distribution quality warnings: +No 'maintainer' field. +No 'description' field. +A 'license-file' is not specified. +Note: the public hackage server would reject this package. +Building source dist for build-depends-extra-version-0.1.0.0... +Preprocessing library for build-depends-extra-version-0.1.0.0.. +Preprocessing executable 'bar' for build-depends-extra-version-0.1.0.0.. +Source tarball created: setup.cabal.dist/work/dist/build-depends-extra-version-0.1.0.0.tar.gz diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.out @@ -0,0 +1,15 @@ +# Setup configure +Configuring build-depends-extra-version-0.1.0.0... +Warning: The package has an extraneous version range for a dependency on an internal library: build-depends-extra-version >=0.0.0.1. This version range includes the current package but isn't needed as the current package's library will always be used. +# Setup sdist +Distribution quality errors: +The package has an extraneous version range for a dependency on an internal library: build-depends-extra-version >=0.0.0.1. This version range includes the current package but isn't needed as the current package's library will always be used. +Distribution quality warnings: +No 'maintainer' field. +No 'description' field. +A 'license-file' is not specified. +Note: the public hackage server would reject this package. +Building source dist for build-depends-extra-version-0.1.0.0... +Preprocessing library for build-depends-extra-version-0.1.0.0.. +Preprocessing executable 'bar' for build-depends-extra-version-0.1.0.0.. +Source tarball created: setup.dist/work/dist/build-depends-extra-version-0.1.0.0.tar.gz diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.test.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildDependsExtra/setup.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +-- Test unneed version bound on internal build-tools deps +main = setupAndCabalTest $ do + setup' "configure" [] + assertOutputContains "extraneous version range" + =<< setup' "sdist" [] diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/Foo.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/Foo.hs @@ -0,0 +1,1 @@ +module Foo where diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/Main.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/build-tool-depends-bad-version.cabal b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/build-tool-depends-bad-version.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/build-tool-depends-bad-version.cabal @@ -0,0 +1,18 @@ +name: build-tool-depends-bad-version +version: 0.1.0.0 +synopsis: Checks build-tool-depends errs for bad version +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Foo + build-tool-depends: build-tool-depends-bad-version:hello-world >=2 + -- ^ internal dependency, bad version bounds + default-language: Haskell2010 + +executable hello-world + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.cabal.out @@ -0,0 +1,4 @@ +# Setup configure +Resolving dependencies... +Configuring build-tool-depends-bad-version-0.1.0.0... +cabal: The package has an impossible version range for a dependency on an internal executable: build-tool-depends-bad-version:hello-world >=2. This version range does not include the current package, and must be removed as the current package's executable will always be used. diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.out @@ -0,0 +1,3 @@ +# Setup configure +Configuring build-tool-depends-bad-version-0.1.0.0... +setup: The package has an impossible version range for a dependency on an internal executable: build-tool-depends-bad-version:hello-world >=2. This version range does not include the current package, and must be removed as the current package's executable will always be used. diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.test.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsBad/setup.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +-- Test impossible version bound on internal build-tools deps +main = setupAndCabalTest $ do + assertOutputContains "impossible version range" + =<< fails (setup' "configure" []) diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/Foo.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/Foo.hs @@ -0,0 +1,1 @@ +module Foo where diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/Main.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/build-tool-depends-extra-version.cabal b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/build-tool-depends-extra-version.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/build-tool-depends-extra-version.cabal @@ -0,0 +1,18 @@ +name: build-tool-depends-extra-version +version: 0.1.0.0 +synopsis: Checks build-tool-depends warns for extraneous version +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Foo + build-tool-depends: build-tool-depends-extra-version:hello-world >=0.0.0.1 + -- ^ internal dependency, extraneous version + default-language: Haskell2010 + +executable hello-world + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.cabal.out @@ -0,0 +1,16 @@ +# Setup configure +Resolving dependencies... +Configuring build-tool-depends-extra-version-0.1.0.0... +Warning: The package has an extraneous version range for a dependency on an internal executable: build-tool-depends-extra-version:hello-world >=0.0.0.1. This version range includes the current package but isn't needed as the current package's executable will always be used. +# Setup sdist +Distribution quality errors: +The package has an extraneous version range for a dependency on an internal executable: build-tool-depends-extra-version:hello-world >=0.0.0.1. This version range includes the current package but isn't needed as the current package's executable will always be used. +Distribution quality warnings: +No 'maintainer' field. +No 'description' field. +A 'license-file' is not specified. +Note: the public hackage server would reject this package. +Building source dist for build-tool-depends-extra-version-0.1.0.0... +Preprocessing executable 'hello-world' for build-tool-depends-extra-version-0.1.0.0.. +Preprocessing library for build-tool-depends-extra-version-0.1.0.0.. +Source tarball created: setup.cabal.dist/work/dist/build-tool-depends-extra-version-0.1.0.0.tar.gz diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.out @@ -0,0 +1,15 @@ +# Setup configure +Configuring build-tool-depends-extra-version-0.1.0.0... +Warning: The package has an extraneous version range for a dependency on an internal executable: build-tool-depends-extra-version:hello-world >=0.0.0.1. This version range includes the current package but isn't needed as the current package's executable will always be used. +# Setup sdist +Distribution quality errors: +The package has an extraneous version range for a dependency on an internal executable: build-tool-depends-extra-version:hello-world >=0.0.0.1. This version range includes the current package but isn't needed as the current package's executable will always be used. +Distribution quality warnings: +No 'maintainer' field. +No 'description' field. +A 'license-file' is not specified. +Note: the public hackage server would reject this package. +Building source dist for build-tool-depends-extra-version-0.1.0.0... +Preprocessing executable 'hello-world' for build-tool-depends-extra-version-0.1.0.0.. +Preprocessing library for build-tool-depends-extra-version-0.1.0.0.. +Source tarball created: setup.dist/work/dist/build-tool-depends-extra-version-0.1.0.0.tar.gz diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.test.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolDependsExtra/setup.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +-- Test unneed version bound on internal build-tools deps +main = setupAndCabalTest $ do + setup' "configure" [] + assertOutputContains "extraneous version range" + =<< setup' "sdist" [] diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/Foo.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/Foo.hs @@ -0,0 +1,1 @@ +module Foo where diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/Main.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/build-tools-bad-version.cabal b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/build-tools-bad-version.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/build-tools-bad-version.cabal @@ -0,0 +1,18 @@ +name: build-tools-bad-version +version: 0.1.0.0 +synopsis: Checks build-tools errs for bad version +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Foo + build-tools: hello-world >=2 + -- ^ internal dependency, bad version bounds + default-language: Haskell2010 + +executable hello-world + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.cabal.out @@ -0,0 +1,4 @@ +# Setup configure +Resolving dependencies... +Configuring build-tools-bad-version-0.1.0.0... +cabal: The package has an impossible version range for a dependency on an internal executable: build-tools-bad-version:hello-world >=2. This version range does not include the current package, and must be removed as the current package's executable will always be used. diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.out @@ -0,0 +1,3 @@ +# Setup configure +Configuring build-tools-bad-version-0.1.0.0... +setup: The package has an impossible version range for a dependency on an internal executable: build-tools-bad-version:hello-world >=2. This version range does not include the current package, and must be removed as the current package's executable will always be used. diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.test.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsBad/setup.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +-- Test impossible version bound on internal build-tools deps +main = setupAndCabalTest $ do + assertOutputContains "impossible version range" + =<< fails (setup' "configure" []) diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/Foo.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/Foo.hs @@ -0,0 +1,1 @@ +module Foo where diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/Main.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/build-tools-extra-version.cabal b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/build-tools-extra-version.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/build-tools-extra-version.cabal @@ -0,0 +1,18 @@ +name: build-tools-extra-version +version: 0.1.0.0 +synopsis: Checks build-tools warns for extraneous version +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Foo + build-tools: hello-world >=0.0.0.1 + -- ^ internal dependency, extraneous version + default-language: Haskell2010 + +executable hello-world + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.cabal.out @@ -0,0 +1,16 @@ +# Setup configure +Resolving dependencies... +Configuring build-tools-extra-version-0.1.0.0... +Warning: The package has an extraneous version range for a dependency on an internal executable: build-tools-extra-version:hello-world >=0.0.0.1. This version range includes the current package but isn't needed as the current package's executable will always be used. +# Setup sdist +Distribution quality errors: +The package has an extraneous version range for a dependency on an internal executable: build-tools-extra-version:hello-world >=0.0.0.1. This version range includes the current package but isn't needed as the current package's executable will always be used. +Distribution quality warnings: +No 'maintainer' field. +No 'description' field. +A 'license-file' is not specified. +Note: the public hackage server would reject this package. +Building source dist for build-tools-extra-version-0.1.0.0... +Preprocessing executable 'hello-world' for build-tools-extra-version-0.1.0.0.. +Preprocessing library for build-tools-extra-version-0.1.0.0.. +Source tarball created: setup.cabal.dist/work/dist/build-tools-extra-version-0.1.0.0.tar.gz diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.out b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.out @@ -0,0 +1,15 @@ +# Setup configure +Configuring build-tools-extra-version-0.1.0.0... +Warning: The package has an extraneous version range for a dependency on an internal executable: build-tools-extra-version:hello-world >=0.0.0.1. This version range includes the current package but isn't needed as the current package's executable will always be used. +# Setup sdist +Distribution quality errors: +The package has an extraneous version range for a dependency on an internal executable: build-tools-extra-version:hello-world >=0.0.0.1. This version range includes the current package but isn't needed as the current package's executable will always be used. +Distribution quality warnings: +No 'maintainer' field. +No 'description' field. +A 'license-file' is not specified. +Note: the public hackage server would reject this package. +Building source dist for build-tools-extra-version-0.1.0.0... +Preprocessing executable 'hello-world' for build-tools-extra-version-0.1.0.0.. +Preprocessing library for build-tools-extra-version-0.1.0.0.. +Source tarball created: setup.dist/work/dist/build-tools-extra-version-0.1.0.0.tar.gz diff --git a/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.test.hs b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/InternalVersions/BuildToolsExtra/setup.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +-- Test unneed version bound on internal build-tools deps +main = setupAndCabalTest $ do + setup' "configure" [] + assertOutputContains "extraneous version range" + =<< setup' "sdist" [] diff --git a/cabal/cabal-testsuite/PackageTests/Macros/macros.cabal b/cabal/cabal-testsuite/PackageTests/Macros/macros.cabal --- a/cabal/cabal-testsuite/PackageTests/Macros/macros.cabal +++ b/cabal/cabal-testsuite/PackageTests/Macros/macros.cabal @@ -1,7 +1,6 @@ name: macros version: 0.1.0.0 license: BSD3 -license-file: LICENSE author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu build-type: Simple @@ -11,6 +10,7 @@ exposed-modules: C hs-source-dirs: src build-depends: base, filepath + default-language: Haskell2010 executable macros-a main-is: A.hs diff --git a/cabal/cabal-testsuite/PackageTests/Macros/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Macros/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Macros/setup.cabal.out @@ -0,0 +1,14 @@ +# Setup configure +Resolving dependencies... +Configuring macros-0.1.0.0... +# Setup build +Preprocessing library for macros-0.1.0.0.. +Building library for macros-0.1.0.0.. +Preprocessing executable 'macros-a' for macros-0.1.0.0.. +Building executable 'macros-a' for macros-0.1.0.0.. +Preprocessing executable 'macros-b' for macros-0.1.0.0.. +Building executable 'macros-b' for macros-0.1.0.0.. +# macros-a +macros-0.1.0.0-macros-a +# macros-b +macros-0.1.0.0-macros-b diff --git a/cabal/cabal-testsuite/PackageTests/Macros/setup.out b/cabal/cabal-testsuite/PackageTests/Macros/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Macros/setup.out @@ -0,0 +1,13 @@ +# Setup configure +Configuring macros-0.1.0.0... +# Setup build +Preprocessing library for macros-0.1.0.0.. +Building library for macros-0.1.0.0.. +Preprocessing executable 'macros-a' for macros-0.1.0.0.. +Building executable 'macros-a' for macros-0.1.0.0.. +Preprocessing executable 'macros-b' for macros-0.1.0.0.. +Building executable 'macros-b' for macros-0.1.0.0.. +# macros-a +macros-0.1.0.0-macros-a +# macros-b +macros-0.1.0.0-macros-b diff --git a/cabal/cabal-testsuite/PackageTests/Macros/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Macros/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Macros/setup.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +-- Test to ensure that setup_macros.h are computed per-component. +main = setupAndCabalTest $ do + setup_build [] + runExe "macros-a" [] + runExe "macros-b" [] + diff --git a/cabal/cabal-testsuite/PackageTests/Manpage/cabal.out b/cabal/cabal-testsuite/PackageTests/Manpage/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Manpage/cabal.out @@ -0,0 +1,1 @@ +# cabal manpage diff --git a/cabal/cabal-testsuite/PackageTests/Manpage/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Manpage/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Manpage/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + r <- cabal' "manpage" [] + assertOutputContains ".B cabal install" r + assertOutputDoesNotContain ".B cabal manpage" r diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/Bar.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/Bar.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/Bar.hs @@ -0,0 +1,1 @@ +main = putStrLn "Hello Bar" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/Foo.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/Foo.hs @@ -0,0 +1,1 @@ +main = putStrLn "Hello Foo" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/MultipleBenchmarks.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/MultipleBenchmarks.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/MultipleBenchmarks.cabal @@ -0,0 +1,17 @@ +name: MultipleBenchmarks +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +benchmark foo + type: exitcode-stdio-1.0 + main-is: Foo.hs + build-depends: base + default-language: Haskell2010 + +benchmark bar + type: exitcode-stdio-1.0 + main-is: Bar.hs + build-depends: base + default-language: Haskell2010 + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.out @@ -0,0 +1,27 @@ +# cabal new-bench +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - MultipleBenchmarks-1.0 (bench:foo) (first run) +Configuring benchmark 'foo' for MultipleBenchmarks-1.0.. +Preprocessing benchmark 'foo' for MultipleBenchmarks-1.0.. +Building benchmark 'foo' for MultipleBenchmarks-1.0.. +Running 1 benchmarks... +Benchmark foo: RUNNING... +Benchmark foo: FINISH +# cabal new-bench +Build profile: -w ghc- -O1 +In order, the following will be built: + - MultipleBenchmarks-1.0 (bench:bar) (first run) + - MultipleBenchmarks-1.0 (bench:foo) (first run) +Configuring benchmark 'bar' for MultipleBenchmarks-1.0.. +Preprocessing benchmark 'bar' for MultipleBenchmarks-1.0.. +Building benchmark 'bar' for MultipleBenchmarks-1.0.. +Running 1 benchmarks... +Benchmark bar: RUNNING... +Benchmark bar: FINISH +Preprocessing benchmark 'foo' for MultipleBenchmarks-1.0.. +Building benchmark 'foo' for MultipleBenchmarks-1.0.. +Running 1 benchmarks... +Benchmark foo: RUNNING... +Benchmark foo: FINISH diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdBench/MultipleBenchmarks/cabal.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + res1 <- cabal' "new-bench" ["foo"] + assertOutputContains "Hello Foo" res1 + assertOutputDoesNotContain "Hello Bar" res1 + res2 <- cabal' "new-bench" ["all"] + assertOutputContains "Hello Foo" res2 + assertOutputContains "Hello Bar" res2 + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/Main.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/Main.hs @@ -0,0 +1,2 @@ +import InplaceDep +main = f diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/cabal.out @@ -0,0 +1,9 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - inplace-dep-1.0 (lib) (first run) +Configuring library for inplace-dep-1.0.. +Preprocessing library for inplace-dep-1.0.. +Building library for inplace-dep-1.0.. +# cabal new-exec diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/cabal.project @@ -0,0 +1,2 @@ +packages: + inplace-dep diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/cabal.test.hs @@ -0,0 +1,17 @@ +import Test.Cabal.Prelude +import Control.Monad.Trans (liftIO) +import System.Directory-- (getDirectoryContents, removeFile) +main = cabalTest $ do + cabal "new-build" ["inplace-dep"] + env <- getTestEnv + liftIO $ removeEnvFiles $ testSourceDir env -- we don't want existing env files to interfere + cabal "new-exec" ["ghc", "Main.hs"] + -- TODO external (store) deps, once new-install is working + +removeEnvFiles :: FilePath -> IO () +removeEnvFiles dir = (mapM_ (removeFile . (dir )) + . filter + ((".ghc.environment" ==) + . take 16)) + =<< getDirectoryContents dir + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/inplace-dep/InplaceDep.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/inplace-dep/InplaceDep.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/inplace-dep/InplaceDep.hs @@ -0,0 +1,5 @@ +module InplaceDep ( f ) where + +f :: IO () +f = putStrLn "Hello world" + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/inplace-dep/inplace-dep.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/inplace-dep/inplace-dep.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/GhcInvocation/inplace-dep/inplace-dep.cabal @@ -0,0 +1,10 @@ +name: inplace-dep +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: InplaceDep + build-depends: base + default-language: Haskell2010 + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/Main.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/Main.hs @@ -0,0 +1,1 @@ +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/RunExe.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/RunExe.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/RunExe.cabal @@ -0,0 +1,9 @@ +name: RunExe +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +executable foo + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/cabal.out @@ -0,0 +1,9 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - RunExe-1.0 (exe:foo) (first run) +Configuring executable 'foo' for RunExe-1.0.. +Preprocessing executable 'foo' for RunExe-1.0.. +Building executable 'foo' for RunExe-1.0.. +# cabal new-exec diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdExec/RunExe/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + cabal "new-build" [] + cabal' "new-exec" ["foo"] >>= assertOutputContains "Hello World" + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/bar/Main.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/bar/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/bar/Main.hs @@ -0,0 +1,4 @@ +import LibFoo + +main = putStrLn =<< LibFoo.getData + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/bar/bar.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/bar/bar.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/bar/bar.cabal @@ -0,0 +1,9 @@ +name: bar +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +executable bar + main-is: Main.hs + build-depends: base, foo + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/cabal.out @@ -0,0 +1,19 @@ +# cabal new-run +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - foo-1.0 (exe:foo) (first run) +Configuring executable 'foo' for foo-1.0.. +Preprocessing executable 'foo' for foo-1.0.. +Building executable 'foo' for foo-1.0.. +# cabal new-run +Build profile: -w ghc- -O1 +In order, the following will be built: + - foo-1.0 (lib) (first run) + - bar-1.0 (exe:bar) (first run) +Configuring library for foo-1.0.. +Preprocessing library for foo-1.0.. +Building library for foo-1.0.. +Configuring executable 'bar' for bar-1.0.. +Preprocessing executable 'bar' for bar-1.0.. +Building executable 'bar' for bar-1.0.. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/cabal.project @@ -0,0 +1,3 @@ +packages: + foo + bar diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + cabal' "new-run" ["foo"] >>= assertOutputContains "Hello World" + cabal' "new-run" ["bar"] >>= assertOutputContains "Hello World" + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/LibFoo.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/LibFoo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/LibFoo.hs @@ -0,0 +1,4 @@ +module LibFoo where +import Paths_foo +getData = readFile =<< getDataFileName "hello.txt" + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/Main.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/Main.hs @@ -0,0 +1,4 @@ +import Paths_foo + +main = putStrLn =<< readFile =<< getDataFileName "hello.txt" + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/data/hello.txt b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/data/hello.txt new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/data/hello.txt @@ -0,0 +1,1 @@ +Hello World diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/foo.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/foo.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Datafiles/foo/foo.cabal @@ -0,0 +1,19 @@ +name: foo +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 +data-dir: data +data-files: hello.txt + +executable foo + main-is: Main.hs + build-depends: base + default-language: Haskell2010 + +library + exposed-modules: LibFoo + other-modules: Paths_foo + build-depends: base + default-language: Haskell2010 + + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/ExeAndLib.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/ExeAndLib.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/ExeAndLib.cabal @@ -0,0 +1,14 @@ +name: ExeAndLib +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +executable foo + main-is: Main.hs + build-depends: base + default-language: Haskell2010 + +library + exposed-modules: Main + default-language: Haskell2010 + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/Main.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/Main.hs @@ -0,0 +1,1 @@ +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.out @@ -0,0 +1,10 @@ +# cabal new-run +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - ExeAndLib-1.0 (exe:foo) (first run) +Configuring executable 'foo' for ExeAndLib-1.0.. +Preprocessing executable 'foo' for ExeAndLib-1.0.. +Building executable 'foo' for ExeAndLib-1.0.. +# cabal new-run +cabal: The run command is for running executables, but the target 'ExeAndLib' refers to the library in the package ExeAndLib-1.0 from the package ExeAndLib-1.0. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude +import Control.Monad ( (>=>) ) +main = cabalTest $ do + -- the exe + cabal' "new-run" ["foo"] >>= assertOutputContains "Hello World" + -- the lib + fails (cabal' "new-run" ["ExeAndLib"]) >>= assertOutputDoesNotContain "Hello World" + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/ExitCodePropagation.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/ExitCodePropagation.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/ExitCodePropagation.cabal @@ -0,0 +1,9 @@ +name: ExitCodePropagation +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +executable foo + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/Main.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/Main.hs @@ -0,0 +1,4 @@ +import System.Exit (exitWith, ExitCode(ExitFailure)) + +main = exitWith $ ExitFailure 42 + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.out @@ -0,0 +1,8 @@ +# cabal new-run +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - ExitCodePropagation-1.0 (exe:foo) (first run) +Configuring executable 'foo' for ExitCodePropagation-1.0.. +Preprocessing executable 'foo' for ExitCodePropagation-1.0.. +Building executable 'foo' for ExitCodePropagation-1.0.. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExitCodePropagation/cabal.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +import Control.Monad ( (>=>) ) +import System.Exit (ExitCode(ExitFailure)) +main = cabalTest $ + fails (cabal' "new-run" ["foo"]) >>= assertExitCode (ExitFailure 42) + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/Bar.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/Bar.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/Bar.hs @@ -0,0 +1,1 @@ +main = putStrLn "Hello Bar" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/Foo.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/Foo.hs @@ -0,0 +1,1 @@ +main = putStrLn "Hello Foo" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/MultipleExes.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/MultipleExes.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/MultipleExes.cabal @@ -0,0 +1,15 @@ +name: MultipleExes +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +executable foo + main-is: Foo.hs + build-depends: base + default-language: Haskell2010 + +executable bar + main-is: Bar.hs + build-depends: base + default-language: Haskell2010 + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.out @@ -0,0 +1,21 @@ +# cabal new-run +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - MultipleExes-1.0 (exe:foo) (first run) +Configuring executable 'foo' for MultipleExes-1.0.. +Preprocessing executable 'foo' for MultipleExes-1.0.. +Building executable 'foo' for MultipleExes-1.0.. +# cabal new-run +Build profile: -w ghc- -O1 +In order, the following will be built: + - MultipleExes-1.0 (exe:bar) (first run) +Configuring executable 'bar' for MultipleExes-1.0.. +Preprocessing executable 'bar' for MultipleExes-1.0.. +Building executable 'bar' for MultipleExes-1.0.. +# cabal new-run +Up to date +# cabal new-run +cabal: The run command is for running a single executable at once. The target '' refers to the package MultipleExes-1.0 which includes the executables foo and bar. +# cabal new-run +cabal: The run command is for running a single executable at once. The target 'MultipleExes' refers to the package MultipleExes-1.0 which includes the executables foo and bar. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultipleExes/cabal.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + -- some ways of explicitly specifying an exe + cabal' "new-run" ["foo"] >>= assertOutputContains "Hello Foo" + cabal' "new-run" ["exe:bar"] >>= assertOutputContains "Hello Bar" + cabal' "new-run" ["MultipleExes:foo"] >>= assertOutputContains "Hello Foo" + -- there are multiple exes in ... + fails (cabal' "new-run" []) >>= assertOutputDoesNotContain "Hello" -- in the same project + fails (cabal' "new-run" ["MultipleExes"]) >>= assertOutputDoesNotContain "Hello" -- in the same package + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/bar/Main1.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/bar/Main1.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/bar/Main1.hs @@ -0,0 +1,1 @@ +main = putStrLn "Hello bar:foo-exe" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/bar/Main2.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/bar/Main2.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/bar/Main2.hs @@ -0,0 +1,1 @@ +main = putStrLn "Hello bar:bar-exe" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/bar/bar.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/bar/bar.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/bar/bar.cabal @@ -0,0 +1,14 @@ +name: bar +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +executable foo-exe + main-is: Main1.hs + build-depends: base + default-language: Haskell2010 + +executable bar-exe + main-is: Main2.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.out @@ -0,0 +1,37 @@ +# cabal new-run +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - bar-1.0 (exe:bar-exe) (first run) +Configuring executable 'bar-exe' for bar-1.0.. +Preprocessing executable 'bar-exe' for bar-1.0.. +Building executable 'bar-exe' for bar-1.0.. +# cabal new-run +Up to date +# cabal new-run +Build profile: -w ghc- -O1 +In order, the following will be built: + - foo-1.0 (exe:foo-exe) (first run) +Configuring executable 'foo-exe' for foo-1.0.. +Preprocessing executable 'foo-exe' for foo-1.0.. +Building executable 'foo-exe' for foo-1.0.. +# cabal new-run +Build profile: -w ghc- -O1 +In order, the following will be built: + - bar-1.0 (exe:foo-exe) (first run) +Configuring executable 'foo-exe' for bar-1.0.. +Preprocessing executable 'foo-exe' for bar-1.0.. +Building executable 'foo-exe' for bar-1.0.. +# cabal new-run +cabal: No targets given and there is no package in the current directory. Use the target 'all' for all packages in the project or specify packages or components by name or location. See 'cabal build --help' for more details on target options. +# cabal new-run +cabal: The run command is for running a single executable at once. The target 'bar' refers to the package bar-1.0 which includes the executables foo-exe and bar-exe. +# cabal new-run +cabal: Ambiguous target 'foo-exe'. It could be: + bar:foo-exe (component) + foo:foo-exe (component) + +# cabal new-run +cabal: Unknown target 'foo:bar-exe'. +The package foo has no component 'bar-exe'. + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.project @@ -0,0 +1,4 @@ +packages: + foo + bar + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/cabal.test.hs @@ -0,0 +1,15 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + -- some ways of specifying an exe without ambiguities + cabal' "new-run" ["bar-exe"] >>= assertOutputContains "Hello bar:bar-exe" + cabal' "new-run" ["bar:bar-exe"] >>= assertOutputContains "Hello bar:bar-exe" + cabal' "new-run" ["foo:foo-exe"] >>= assertOutputContains "Hello foo:foo-exe" + cabal' "new-run" ["bar:foo-exe"] >>= assertOutputContains "Hello bar:foo-exe" + -- there are multiple exes ... + fails (cabal' "new-run" []) >>= assertOutputDoesNotContain "Hello" -- in the same project + fails (cabal' "new-run" ["bar"]) >>= assertOutputDoesNotContain "Hello" -- in the same package + fails (cabal' "new-run" ["foo-exe"]) >>= assertOutputDoesNotContain "Hello" -- with the same name + -- invalid exes + fails (cabal' "new-run" ["foo:bar-exe"]) >>= assertOutputDoesNotContain "Hello" -- does not exist + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/foo/Main1.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/foo/Main1.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/foo/Main1.hs @@ -0,0 +1,1 @@ +main = putStrLn "Hello foo:foo-exe" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/foo/foo.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/foo/foo.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/MultiplePackages/foo/foo.cabal @@ -0,0 +1,10 @@ +name: foo +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +executable foo-exe + main-is: Main1.hs + build-depends: base + default-language: Haskell2010 + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/Main.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/Main.hs @@ -0,0 +1,1 @@ +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/Single.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/Single.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/Single.cabal @@ -0,0 +1,9 @@ +name: Single +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +executable foo + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.out @@ -0,0 +1,19 @@ +# cabal new-run +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - Single-1.0 (exe:foo) (first run) +Configuring executable 'foo' for Single-1.0.. +Preprocessing executable 'foo' for Single-1.0.. +Building executable 'foo' for Single-1.0.. +# cabal new-run +Up to date +# cabal new-run +Up to date +# cabal new-run +Up to date +# cabal new-run +Up to date +# cabal new-run +cabal: Cannot run the package bar, it is not in this project (either directly or indirectly). If you want to add it to the project then edit the cabal.project file. + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CmdRun/Single/cabal.test.hs @@ -0,0 +1,14 @@ +import Test.Cabal.Prelude +import Control.Monad ( (>=>) ) +main = cabalTest $ do + -- Some different ways of calling an executable that should all work + -- on a single-exe single-package project + mapM_ (cabal' "new-run" >=> assertOutputContains "Hello World") + [ ["foo"] + , ["Single"] + , [] + , ["Single:foo"] + , ["exe:foo"] ] + -- non-existent exe + fails (cabal' "new-run" ["bar"]) >>= assertOutputDoesNotContain "Hello World" + diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/Setup.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/Setup.hs @@ -0,0 +1,4 @@ +import SetupDep (message) +import Distribution.Simple + +main = putStrLn ("pkg Setup.hs: " ++ message) >> defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/build-local-package-with-custom-setup.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/build-local-package-with-custom-setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/build-local-package-with-custom-setup.out @@ -0,0 +1,2 @@ +# cabal update +Downloading the latest package list from test-local-repo diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/build-local-package-with-custom-setup.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/build-local-package-with-custom-setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/build-local-package-with-custom-setup.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude + +-- The one local package, pkg, has a setup dependency on setup-dep-2.0, which is +-- in the repository. +main = cabalTest $ do + skipUnless =<< hasNewBuildCompatBootCabal + withRepo "repo" $ do + r <- recordMode DoNotRecord $ cabal' "new-build" ["pkg"] + -- pkg's setup script should print out a message that it imported from + -- setup-dep: + assertOutputContains "pkg Setup.hs: setup-dep-2.0" r diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/cabal.project @@ -0,0 +1,1 @@ +packages: *.cabal diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/pkg.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/pkg.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/pkg.cabal @@ -0,0 +1,10 @@ +name: pkg +version: 1.0 +build-type: Custom +cabal-version: >= 1.20 + +custom-setup + setup-depends: base, Cabal, setup-dep + +library + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/repo/setup-dep-2.0/SetupDep.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/repo/setup-dep-2.0/SetupDep.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/repo/setup-dep-2.0/SetupDep.hs @@ -0,0 +1,3 @@ +module SetupDep (message) where + +message = "setup-dep-2.0" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/repo/setup-dep-2.0/setup-dep.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/repo/setup-dep-2.0/setup-dep.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/LocalPackageWithCustomSetup/repo/setup-dep-2.0/setup-dep.cabal @@ -0,0 +1,9 @@ +name: setup-dep +version: 2.0 +build-type: Simple +cabal-version: >= 1.20 + +library + build-depends: base + exposed-modules: SetupDep + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/Main.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/Main.hs @@ -0,0 +1,3 @@ +import RemotePkg (message) + +main = putStrLn $ "pkg Main.hs: " ++ message diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.out b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.out @@ -0,0 +1,4 @@ +# cabal update +Downloading the latest package list from test-local-repo +# pkg my-exe +pkg Main.hs: remote-pkg-2.0 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/build-package-from-repo-with-custom-setup.test.hs @@ -0,0 +1,15 @@ +import Test.Cabal.Prelude + +-- The one local package, pkg, has a dependency on remote-pkg-2.0, which has a +-- setup dependency on remote-setup-dep-3.0. +main = cabalTest $ do + skipUnless =<< hasNewBuildCompatBootCabal + withRepo "repo" $ do + r1 <- recordMode DoNotRecord $ cabal' "new-build" ["pkg:my-exe"] + -- remote-pkg's setup script should print out a message that it imported from + -- remote-setup-dep: + assertOutputContains "remote-pkg Setup.hs: remote-setup-dep-3.0" r1 + withPlan $ do + r2 <- runPlanExe' "pkg" "my-exe" [] + -- pkg's executable should print a message that it imported from remote-pkg: + assertOutputContains "pkg Main.hs: remote-pkg-2.0" r2 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/cabal.project @@ -0,0 +1,1 @@ +packages: *.cabal diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/pkg.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/pkg.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/pkg.cabal @@ -0,0 +1,9 @@ +name: pkg +version: 1.0 +build-type: Simple +cabal-version: >= 1.20 + +executable my-exe + main-is: Main.hs + build-depends: base, remote-pkg + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-pkg-2.0/RemotePkg.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-pkg-2.0/RemotePkg.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-pkg-2.0/RemotePkg.hs @@ -0,0 +1,3 @@ +module RemotePkg (message) where + +message = "remote-pkg-2.0" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-pkg-2.0/Setup.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-pkg-2.0/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-pkg-2.0/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple +import RemoteSetupDep (message) + +main = putStrLn ("remote-pkg Setup.hs: " ++ message) >> defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-pkg-2.0/remote-pkg.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-pkg-2.0/remote-pkg.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-pkg-2.0/remote-pkg.cabal @@ -0,0 +1,12 @@ +name: remote-pkg +version: 2.0 +build-type: Custom +cabal-version: >= 1.20 + +custom-setup + setup-depends: base, Cabal, remote-setup-dep + +library + build-depends: base + exposed-modules: RemotePkg + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-setup-dep-3.0/RemoteSetupDep.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-setup-dep-3.0/RemoteSetupDep.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-setup-dep-3.0/RemoteSetupDep.hs @@ -0,0 +1,3 @@ +module RemoteSetupDep (message) where + +message = "remote-setup-dep-3.0" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-setup-dep-3.0/remote-setup-dep.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-setup-dep-3.0/remote-setup-dep.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/CustomSetup/RemotePackageWithCustomSetup/repo/remote-setup-dep-3.0/remote-setup-dep.cabal @@ -0,0 +1,9 @@ +name: remote-setup-dep +version: 3.0 +build-type: Simple +cabal-version: >= 1.20 + +library + build-depends: base + exposed-modules: RemoteSetupDep + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/.gitignore b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/.gitignore new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/.gitignore @@ -0,0 +1,1 @@ +q/q.cabal diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/cabal.out @@ -0,0 +1,20 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - q-0.1.0.0 (exe:q) (first run) +Configuring executable 'q' for q-0.1.0.0.. +Preprocessing executable 'q' for q-0.1.0.0.. +Building executable 'q' for q-0.1.0.0.. +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - p-1.0 (lib) (first run) + - q-0.1.0.0 (exe:q) (configuration changed) +Configuring library for p-1.0.. +Preprocessing library for p-1.0.. +Building library for p-1.0.. +Configuring executable 'q' for q-0.1.0.0.. +Preprocessing executable 'q' for q-0.1.0.0.. +Building executable 'q' for q-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/cabal.project @@ -0,0 +1,4 @@ +packages: p/p.cabal q/ + +-- use both matching a .cabal file, and a dir +-- since these are slightly different code paths diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/cabal.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withSourceCopy . withDelay $ do + copySourceFileTo "q/q-broken.cabal.in" "q/q.cabal" + fails $ cabal "new-build" ["q"] + delay + copySourceFileTo "q/q-fixed.cabal.in" "q/q.cabal" + cabal "new-build" ["q"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/p/P.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/p/P.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/p/P.hs @@ -0,0 +1,1 @@ +module P where diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/p/Setup.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/p/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/p/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/p/p.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/p/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/p/p.cabal @@ -0,0 +1,12 @@ +name: p +version: 1.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: P + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/Main.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/Main.hs @@ -0,0 +1,4 @@ +module Main where +import P +main :: IO () +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/Setup.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/q-broken.cabal.in b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/q-broken.cabal.in new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/q-broken.cabal.in @@ -0,0 +1,12 @@ +name: q +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +executable q + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/q-fixed.cabal.in b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/q-fixed.cabal.in new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/MonitorCabalFiles/q/q-fixed.cabal.in @@ -0,0 +1,12 @@ +name: q +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +executable q + main-is: Main.hs + build-depends: base, p + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/C.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/C.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/C.hs @@ -0,0 +1,3 @@ +module C where +import A +import B diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/Setup.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/T3460.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/T3460.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/T3460.cabal @@ -0,0 +1,22 @@ +-- Initial T3460.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: T3460 +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +-- copyright: +-- category: +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: C + -- other-modules: + -- other-extensions: + build-depends: base, sub-package-A, sub-package-B + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/cabal.out diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/cabal.project @@ -0,0 +1,3 @@ +packages: ./T3460.cabal + , ./sub-package-A + , ./sub-package-B diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + -- Parallel flag means output of this test is nondeterministic + recordMode DoNotRecord $ + cabal "new-build" ["-j", "T3460"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-A/A.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-A/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-A/A.hs @@ -0,0 +1,1 @@ +module A where diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-A/Setup.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-A/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-A/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-A/sub-package-A.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-A/sub-package-A.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-A/sub-package-A.cabal @@ -0,0 +1,22 @@ +-- Initial sub-package-A.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: sub-package-A +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +-- copyright: +-- category: +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: A + -- other-modules: + -- other-extensions: + build-depends: base + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-B/B.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-B/B.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-B/B.hs @@ -0,0 +1,1 @@ +module B where diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-B/Setup.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-B/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-B/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-B/sub-package-B.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-B/sub-package-B.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3460/sub-package-B/sub-package-B.cabal @@ -0,0 +1,22 @@ +-- Initial sub-package-B.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: sub-package-B +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +-- copyright: +-- category: +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: B + -- other-modules: + -- other-extensions: + build-depends: base + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.out @@ -0,0 +1,12 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - p-1.0 (lib) --enable-library-profiling (first run) + - q-1.0 (exe:q) --enable-profiling (first run) +Configuring library for p-1.0.. +Preprocessing library for p-1.0.. +Building library for p-1.0.. +Configuring executable 'q' for q-1.0.. +Preprocessing executable 'q' for q-1.0.. +Building executable 'q' for q-1.0.. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.project @@ -0,0 +1,4 @@ +packages: p q +profiling-detail: all-functions +package q + profiling: True diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + cabal "new-build" ["exe:q"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/p/P.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/p/P.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/p/P.hs @@ -0,0 +1,2 @@ +module P where +p = True diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/p/p.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/p/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/p/p.cabal @@ -0,0 +1,9 @@ +name: p +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +library + build-depends: base + exposed-modules: P + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/q/Main.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/q/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/q/Main.hs @@ -0,0 +1,3 @@ +module Main where +import P +main = print p diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/q/q.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3827/q/q.cabal @@ -0,0 +1,9 @@ +name: q +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +executable q + build-depends: base, p + main-is: Main.hs + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.out @@ -0,0 +1,6 @@ +# cabal new-build +Resolving dependencies... +Error: + Dependency on unbuildable library from p + In the stanza 'library' + In the inplace package 'q-1.0' diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.project @@ -0,0 +1,2 @@ +packages: p q +allow-older: p:base diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + fails $ cabal "new-build" ["q"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/p/p.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/p/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/p/p.cabal @@ -0,0 +1,7 @@ +name: p +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +library + buildable: False diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/q/q.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T3978/q/q.cabal @@ -0,0 +1,7 @@ +name: q +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +library + build-depends: p diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/cabal.out @@ -0,0 +1,12 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - p-1.0 (lib) (first run) + - q-1.0 (lib) (first run) +Configuring library for p-1.0.. +Preprocessing library for p-1.0.. +Building library for p-1.0.. +Configuring library for q-1.0.. +Preprocessing library for q-1.0.. +Building library for q-1.0.. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/cabal.project @@ -0,0 +1,2 @@ +packages: p q +allow-older: p:base diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + cabal "new-build" ["q"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/p/p.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/p/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/p/p.cabal @@ -0,0 +1,8 @@ +name: p +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +library + build-depends: base >= 99999 + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/q/q.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4017/q/q.cabal @@ -0,0 +1,8 @@ +name: q +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +library + build-depends: p + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/A.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/A.hs @@ -0,0 +1,1 @@ +module A where diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/Setup.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/a.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/a.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/a.cabal @@ -0,0 +1,11 @@ +name: a +version: 0.1 +build-type: Custom +cabal-version: >= 1.10 + +-- no explicit setup deps + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.out @@ -0,0 +1,17 @@ +# cabal update +Downloading the latest package list from test-local-repo +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - old-locale-1.0.0.7 (lib) (requires download & build) + - old-time-1.1.0.3 (lib) (requires download & build) + - a-0.1 (lib:a) (first run) +Configuring library for old-locale-1.0.0.7.. +Preprocessing library for old-locale-1.0.0.7.. +Building library for old-locale-1.0.0.7.. +Installing library in +Configuring library for old-time-1.1.0.3.. +Preprocessing library for old-time-1.1.0.3.. +Building library for old-time-1.1.0.3.. +Installing library in diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/cabal.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + -- Don't run this test unless the GHC is sufficiently recent + -- to not ship boot old-time/old-locale + skipUnless =<< ghcVersionIs (>= mkVersion [7,11]) + -- Don't run this test on GHC 8.2, which ships with Cabal 2.0, + -- which is not eligible for old-style Custom setup (if + -- we had the full Hackage index, we'd try it.) + skipUnless =<< ghcVersionIs (< mkVersion [8,1]) + withRepo "repo" $ do + cabal "new-build" ["a"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-locale-1.0.0.7/System/Locale.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-locale-1.0.0.7/System/Locale.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-locale-1.0.0.7/System/Locale.hs @@ -0,0 +1,1 @@ +module System.Locale where diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-locale-1.0.0.7/old-locale.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-locale-1.0.0.7/old-locale.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-locale-1.0.0.7/old-locale.cabal @@ -0,0 +1,9 @@ +name: old-locale +version: 1.0.0.7 +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: System.Locale + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-time-1.1.0.3/System/Time.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-time-1.1.0.3/System/Time.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-time-1.1.0.3/System/Time.hs @@ -0,0 +1,2 @@ +module System.Time where +import System.Locale diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-time-1.1.0.3/old-time.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-time-1.1.0.3/old-time.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4375/repo/old-time-1.1.0.3/old-time.cabal @@ -0,0 +1,9 @@ +name: old-time +version: 1.1.0.3 +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: System.Time + build-depends: base, old-locale == 1.0.* + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/cabal.out @@ -0,0 +1,14 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - p-1.0 (lib) (first run) + - q-1.0 (lib) (first run) +Configuring library for p-1.0.. +Preprocessing library for p-1.0.. +Building library for p-1.0.. +Configuring library for q-1.0.. +Preprocessing library for q-1.0.. +Building library for q-1.0.. +# cabal new-build +Up to date diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/cabal.project @@ -0,0 +1,1 @@ +packages: p q diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + cabal "new-build" ["q"] + cabal "new-build" ["q"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/p/P.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/p/P.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/p/P.hs @@ -0,0 +1,1 @@ +module P where diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/p/PTest.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/p/PTest.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/p/PTest.hs @@ -0,0 +1,1 @@ +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/p/p.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/p/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/p/p.cabal @@ -0,0 +1,15 @@ +name: p +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: P + build-depends: base + default-language: Haskell2010 + +test-suite ptest + main-is: PTest.hs + type: exitcode-stdio-1.0 + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/q/Q.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/q/Q.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/q/Q.hs @@ -0,0 +1,2 @@ +module Q where +import P diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/q/q.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4405/q/q.cabal @@ -0,0 +1,9 @@ +name: q +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +library + build-depends: p, base + exposed-modules: Q + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/A.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/A.hs @@ -0,0 +1,1 @@ +module A where diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/Main.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/Main.hs @@ -0,0 +1,1 @@ +main = return () diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/Setup.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/T4450.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/T4450.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/T4450.cabal @@ -0,0 +1,17 @@ +name: T4450 +version: 1.0 +build-type: Custom +cabal-version: >= 1.10 + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010 + +executable foo + main-is: Main.hs + build-depends: base, T4450 + default-language: Haskell2010 + +custom-setup + setup-depends: base, Cabal diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.out diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.project @@ -0,0 +1,1 @@ +packages: . dep diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/cabal.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + skipUnless =<< hasNewBuildCompatBootCabal + -- Custom Setups inconsistently report output depending + -- on your boot GHC. + recordMode DoNotRecord $ cabal "new-build" ["foo"] + recordMode DoNotRecord $ cabal "new-build" ["dep"] diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/dep/Dep.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/dep/Dep.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/dep/Dep.hs @@ -0,0 +1,1 @@ +module Dep where diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/dep/dep.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/dep/dep.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4450/dep/dep.cabal @@ -0,0 +1,9 @@ +name: dep +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: Dep + build-depends: T4450, base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/Main.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/Main.hs @@ -0,0 +1,1 @@ +main = putStrLn "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/T4477.cabal b/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/T4477.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/T4477.cabal @@ -0,0 +1,9 @@ +name: T4477 +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +executable foo + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/cabal.out b/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/cabal.out @@ -0,0 +1,8 @@ +# cabal new-run +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - T4477-1.0 (exe:foo) (first run) +Configuring executable 'foo' for T4477-1.0.. +Preprocessing executable 'foo' for T4477-1.0.. +Building executable 'foo' for T4477-1.0.. diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/cabal.project b/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewBuild/T4477/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + cabal' "new-run" ["foo"] >>= assertOutputContains "Hello World" diff --git a/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/NewConfigure.cabal b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/NewConfigure.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/NewConfigure.cabal @@ -0,0 +1,11 @@ +name: NewConfigure +version: 0.1.0.0 +author: Foo Bar +maintainer: cabal-dev@haskell.org +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Foo + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/Setup.hs b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.out b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.out @@ -0,0 +1,6 @@ +# cabal new-configure +'cabal.project.local' file already exists. Now overwriting it. +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following would be built: + - NewConfigure-0.1.0.0 (lib) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.project b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.project.local b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.project.local new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.project.local diff --git a/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewConfigure/LocalConfigOverwrite/cabal.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude + +main = cabalTest $ + withSourceCopy $ do + r <- cabal' "new-configure" [] + assertOutputContains "Now overwriting it" r diff --git a/cabal/cabal-testsuite/PackageTests/NewFreeze/cabal.project b/cabal/cabal-testsuite/PackageTests/NewFreeze/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewFreeze/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/NewFreeze/my-local-package.cabal b/cabal/cabal-testsuite/PackageTests/NewFreeze/my-local-package.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewFreeze/my-local-package.cabal @@ -0,0 +1,9 @@ +name: my-local-package +version: 1.0 +cabal-version: >= 1.20 +build-type: Simple + +library + build-depends: base, my-library-dep + build-tool-depends: my-build-tool-dep:my-build-tool >= 2 + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewFreeze/new_freeze.out b/cabal/cabal-testsuite/PackageTests/NewFreeze/new_freeze.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewFreeze/new_freeze.out @@ -0,0 +1,29 @@ +# cabal update +Downloading the latest package list from test-local-repo +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following would be built: + - my-build-tool-dep-1.0 (exe:my-build-tool) (requires download & build) + - my-build-tool-dep-3.0 (exe:my-build-tool) (requires download & build) + - my-library-dep-1.0 (lib) (requires download & build) + - my-local-package-1.0 (lib) (first run) +# cabal new-freeze +Resolving dependencies... +Wrote freeze file: /new_freeze.dist/source/cabal.project.freeze +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following would be built: + - my-build-tool-dep-1.0 (exe:my-build-tool) (requires download & build) + - my-build-tool-dep-2.0 (exe:my-build-tool) (requires download & build) + - my-library-dep-1.0 (lib) (requires download & build) + - my-local-package-1.0 (lib) (first run) +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following would be built: + - my-build-tool-dep-1.0 (exe:my-build-tool) (requires download & build) + - my-build-tool-dep-3.0 (exe:my-build-tool) (requires download & build) + - my-library-dep-1.0 (lib) (requires download & build) + - my-local-package-1.0 (lib) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/NewFreeze/new_freeze.test.hs b/cabal/cabal-testsuite/PackageTests/NewFreeze/new_freeze.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewFreeze/new_freeze.test.hs @@ -0,0 +1,49 @@ +import Test.Cabal.Prelude +import Control.Monad.IO.Class +import System.Directory + +-- Test that 'cabal new-freeze' works with multiple versions of a build tool +-- dependency. +-- +-- The repository contains versions 1.0, 2.0, and 3.0 of the build tool. There +-- is one local package, which requires >= 2, and a library dependency of the +-- local package, which requires < 2, so cabal should pick versions 1.0 and 3.0 +-- of the build tool when there are no constraints. +main = cabalTest $ withSourceCopy $ do + withRepo "repo" $ do + cabal' "new-build" ["--dry-run"] >>= assertUsesLatestBuildTool + + -- Force the project to use versions 1.0 and 2.0 of the build tool. + cabal "new-freeze" ["--constraint=any.my-build-tool-dep < 3"] + + cwd <- fmap testCurrentDir getTestEnv + let freezeFile = cwd "cabal.project.freeze" + + -- The freeze file should specify a version range that includes both + -- versions of the build tool from the install plan. (This constraint will + -- be replaced with two exe qualified constraints once #3502 is fully + -- implemented). + assertFileDoesContain freezeFile "any.my-build-tool-dep ==1.0 || ==2.0" + + -- The library dependency should have a constraint on an exact version. + assertFileDoesContain freezeFile "any.my-library-dep ==1.0" + + -- The local package should be unconstrained. + assertFileDoesNotContain freezeFile "my-local-package" + + -- cabal should be able to find an install plan that fits the constraints + -- from the freeze file. + cabal' "new-build" ["--dry-run"] >>= assertDoesNotUseLatestBuildTool + + -- cabal should choose the latest version again after the freeze file is + -- removed. + liftIO $ removeFile freezeFile + cabal' "new-build" ["--dry-run"] >>= assertUsesLatestBuildTool + where + assertUsesLatestBuildTool out = do + assertOutputContains "my-build-tool-dep-3.0 (exe:my-build-tool)" out + assertOutputDoesNotContain "my-build-tool-dep-2.0" out + + assertDoesNotUseLatestBuildTool out = do + assertOutputContains "my-build-tool-dep-2.0 (exe:my-build-tool)" out + assertOutputDoesNotContain "my-build-tool-dep-3.0" out diff --git a/cabal/cabal-testsuite/PackageTests/NewFreeze/repo/my-build-tool-dep-1.0/my-build-tool-dep.cabal b/cabal/cabal-testsuite/PackageTests/NewFreeze/repo/my-build-tool-dep-1.0/my-build-tool-dep.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewFreeze/repo/my-build-tool-dep-1.0/my-build-tool-dep.cabal @@ -0,0 +1,9 @@ +name: my-build-tool-dep +version: 1.0 +cabal-version: >= 1.20 +build-type: Simple + +executable my-build-tool + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewFreeze/repo/my-build-tool-dep-2.0/my-build-tool-dep.cabal b/cabal/cabal-testsuite/PackageTests/NewFreeze/repo/my-build-tool-dep-2.0/my-build-tool-dep.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewFreeze/repo/my-build-tool-dep-2.0/my-build-tool-dep.cabal @@ -0,0 +1,9 @@ +name: my-build-tool-dep +version: 2.0 +cabal-version: >= 1.20 +build-type: Simple + +executable my-build-tool + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewFreeze/repo/my-build-tool-dep-3.0/my-build-tool-dep.cabal b/cabal/cabal-testsuite/PackageTests/NewFreeze/repo/my-build-tool-dep-3.0/my-build-tool-dep.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewFreeze/repo/my-build-tool-dep-3.0/my-build-tool-dep.cabal @@ -0,0 +1,9 @@ +name: my-build-tool-dep +version: 3.0 +cabal-version: >= 1.20 +build-type: Simple + +executable my-build-tool + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/NewFreeze/repo/my-library-dep-1.0/my-library-dep.cabal b/cabal/cabal-testsuite/PackageTests/NewFreeze/repo/my-library-dep-1.0/my-library-dep.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/NewFreeze/repo/my-library-dep-1.0/my-library-dep.cabal @@ -0,0 +1,9 @@ +name: my-library-dep +version: 1.0 +cabal-version: >= 1.20 +build-type: Simple + +library + build-depends: base + build-tool-depends: my-build-tool-dep:my-build-tool < 2 + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Options.hs b/cabal/cabal-testsuite/PackageTests/Options.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Options.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module PackageTests.Options - ( OptionEnableAllTests(..) - ) where - -import Data.Typeable (Typeable) - -import Test.Tasty.Options (IsOption(..), flagCLParser, safeRead) - -newtype OptionEnableAllTests = OptionEnableAllTests Bool - deriving Typeable - -instance IsOption OptionEnableAllTests where - defaultValue = OptionEnableAllTests False - parseValue = fmap OptionEnableAllTests . safeRead - optionName = return "enable-all-tests" - optionHelp = return "Enable all tests" - optionCLParser = flagCLParser Nothing (OptionEnableAllTests True) diff --git a/cabal/cabal-testsuite/PackageTests/OrderFlags/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/OrderFlags/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/OrderFlags/setup.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring OrderFlags-0.1... +# Setup build +Preprocessing library for OrderFlags-0.1.. +Building library for OrderFlags-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/OrderFlags/setup.out b/cabal/cabal-testsuite/PackageTests/OrderFlags/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/OrderFlags/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring OrderFlags-0.1... +# Setup build +Preprocessing library for OrderFlags-0.1.. +Building library for OrderFlags-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/OrderFlags/setup.test.hs b/cabal/cabal-testsuite/PackageTests/OrderFlags/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/OrderFlags/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +-- Test that setup properly orders GHC flags passed to GHC (when +-- there are multiple ghc-options fields.) +main = setupAndCabalTest $ setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/cabal.config b/cabal/cabal-testsuite/PackageTests/Outdated/cabal.config new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/cabal.config @@ -0,0 +1,1 @@ +constraints: base == 3.0.3.2, template-haskell ==2.3.0.0 diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/cabal.project b/cabal/cabal-testsuite/PackageTests/Outdated/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/cabal.project.freeze b/cabal/cabal-testsuite/PackageTests/Outdated/cabal.project.freeze new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/cabal.project.freeze @@ -0,0 +1,1 @@ +constraints: base == 3.0.3.2, template-haskell ==2.3.0.0 diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/my.cabal b/cabal/cabal-testsuite/PackageTests/Outdated/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/my.cabal @@ -0,0 +1,15 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.20.0 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base >= 3 && < 4 + +test-suite tests-Foo + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: test-Foo.hs + build-depends: base, template-haskell >= 2.3.0.0 && < 2.4 diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/outdated.out b/cabal/cabal-testsuite/PackageTests/Outdated/outdated.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/outdated.out @@ -0,0 +1,16 @@ +# cabal update +Downloading the latest package list from test-local-repo +# cabal outdated +Outdated dependencies: +base ==3.* (latest: 4.0.0.0) +template-haskell >=2.3.0.0 && <2.4 (latest: 2.4.0.0) +# cabal outdated +Outdated dependencies: +template-haskell >=2.3.0.0 && <2.4 (latest: 2.4.0.0) +# cabal outdated +All dependencies are up to date. +# cabal outdated +Outdated dependencies: +template-haskell >=2.3.0.0 && <2.4 (latest: 2.4.0.0) +# cabal outdated +All dependencies are up to date. diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/outdated.test.hs b/cabal/cabal-testsuite/PackageTests/Outdated/outdated.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/outdated.test.hs @@ -0,0 +1,26 @@ +import Test.Cabal.Prelude +main = cabalTest $ withRepo "repo" $ do + cabal' "outdated" [] >>= + (\out -> do + assertOutputContains "base" out + assertOutputContains "template-haskell" out) + + cabal' "outdated" ["--ignore=base"] >>= + (\out -> do + assertOutputDoesNotContain "base" out + assertOutputContains "template-haskell" out) + + cabal' "outdated" ["--ignore=base,template-haskell"] >>= + (\out -> do + assertOutputDoesNotContain "base" out + assertOutputDoesNotContain "template-haskell" out) + + cabal' "outdated" ["--minor=base"] >>= + (\out -> do + assertOutputDoesNotContain "base" out + assertOutputContains "template-haskell" out) + + cabal' "outdated" ["--minor=base,template-haskell"] >>= + (\out -> do + assertOutputDoesNotContain "base" out + assertOutputDoesNotContain "template-haskell" out) diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/outdated_freeze.out b/cabal/cabal-testsuite/PackageTests/Outdated/outdated_freeze.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/outdated_freeze.out @@ -0,0 +1,20 @@ +# cabal update +Downloading the latest package list from test-local-repo +# cabal outdated +Outdated dependencies: +base ==3.0.3.2 (latest: 4.0.0.0) +template-haskell ==2.3.0.0 (latest: 2.4.0.0) +# cabal outdated +All dependencies are up to date. +# cabal outdated +Outdated dependencies: +template-haskell ==2.3.0.0 (latest: 2.3.0.1) +# cabal outdated +Outdated dependencies: +base ==3.0.3.2 (latest: 4.0.0.0) +template-haskell ==2.3.0.0 (latest: 2.4.0.0) +# cabal outdated +All dependencies are up to date. +# cabal outdated +Outdated dependencies: +template-haskell ==2.3.0.0 (latest: 2.3.0.1) diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/outdated_freeze.test.hs b/cabal/cabal-testsuite/PackageTests/Outdated/outdated_freeze.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/outdated_freeze.test.hs @@ -0,0 +1,18 @@ +import Test.Cabal.Prelude +main = cabalTest $ withRepo "repo" + $ forM_ ["--new-freeze-file", "--freeze-file"] $ \arg -> do + + cabal' "outdated" [arg] >>= + (\out -> do + assertOutputContains "base" out + assertOutputContains "template-haskell" out) + + cabal' "outdated" [arg, "--ignore=base,template-haskell"] >>= + (\out -> do + assertOutputDoesNotContain "base" out + assertOutputDoesNotContain "template-haskell" out) + + cabal' "outdated" [arg, "--minor=base,template-haskell"] >>= + (\out -> do + assertOutputDoesNotContain "base" out + assertOutputContains "template-haskell" out) diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/repo/base-3.0.3.1/base.cabal b/cabal/cabal-testsuite/PackageTests/Outdated/repo/base-3.0.3.1/base.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/repo/base-3.0.3.1/base.cabal @@ -0,0 +1,154 @@ +name: base +version: 3.0.3.1 +license: BSD3 +license-file: LICENSE +maintainer: libraries@haskell.org +synopsis: Basic libraries (backwards-compatibility version) +description: + This is a backwards-compatible version of the base package. + It depends on a later version of base, and was probably supplied + with your compiler when it was installed. + +cabal-version: >=1.2 +build-type: Simple + +Library { + build-depends: base >= 4.0 && < 4.2, + syb >= 0.1 && < 0.2 + extensions: PackageImports + + if impl(ghc < 6.9) { + buildable: False + } + + if impl(ghc) { + exposed-modules: + Data.Generics, + Data.Generics.Aliases, + Data.Generics.Basics, + Data.Generics.Instances, + Data.Generics.Schemes, + Data.Generics.Text, + Data.Generics.Twins, + Foreign.Concurrent, + GHC.Arr, + GHC.Base, + GHC.Conc, + GHC.ConsoleHandler, + GHC.Desugar, + GHC.Dotnet, + GHC.Enum, + GHC.Environment, + GHC.Err, + GHC.Exception, + GHC.Exts, + GHC.Float, + GHC.ForeignPtr, + GHC.Handle, + GHC.IO, + GHC.IOBase, + GHC.Int, + GHC.List, + GHC.Num, + GHC.PArr, + GHC.Pack, + GHC.Ptr, + GHC.Read, + GHC.Real, + GHC.ST, + GHC.STRef, + GHC.Show, + GHC.Stable, + GHC.Storable, + GHC.TopHandler, + GHC.Unicode, + GHC.Weak, + GHC.Word, + System.Timeout + } + exposed-modules: + Control.Applicative, + Control.Arrow, + Control.Category, + Control.Concurrent, + Control.Concurrent.Chan, + Control.Concurrent.MVar, + Control.Concurrent.QSem, + Control.Concurrent.QSemN, + Control.Concurrent.SampleVar, + Control.Exception, + Control.Monad, + Control.Monad.Fix, + Control.Monad.Instances, + Control.Monad.ST, + Control.Monad.ST.Lazy, + Control.Monad.ST.Strict, + Data.Bits, + Data.Bool, + Data.Char, + Data.Complex, + Data.Dynamic, + Data.Either, + Data.Eq, + Data.Fixed, + Data.Foldable + Data.Function, + Data.HashTable, + Data.IORef, + Data.Int, + Data.Ix, + Data.List, + Data.Maybe, + Data.Monoid, + Data.Ord, + Data.Ratio, + Data.STRef, + Data.STRef.Lazy, + Data.STRef.Strict, + Data.String, + Data.Traversable + Data.Tuple, + Data.Typeable, + Data.Unique, + Data.Version, + Data.Word, + Debug.Trace, + Foreign, + Foreign.C, + Foreign.C.Error, + Foreign.C.String, + Foreign.C.Types, + Foreign.ForeignPtr, + Foreign.Marshal, + Foreign.Marshal.Alloc, + Foreign.Marshal.Array, + Foreign.Marshal.Error, + Foreign.Marshal.Pool, + Foreign.Marshal.Utils, + Foreign.Ptr, + Foreign.StablePtr, + Foreign.Storable, + Numeric, + Prelude, + System.Console.GetOpt, + System.CPUTime, + System.Environment, + System.Exit, + System.IO, + System.IO.Error, + System.IO.Unsafe, + System.Info, + System.Mem, + System.Mem.StableName, + System.Mem.Weak, + System.Posix.Internals, + System.Posix.Types, + Text.ParserCombinators.ReadP, + Text.ParserCombinators.ReadPrec, + Text.Printf, + Text.Read, + Text.Read.Lex, + Text.Show, + Text.Show.Functions + Unsafe.Coerce +} diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/repo/base-3.0.3.2/base.cabal b/cabal/cabal-testsuite/PackageTests/Outdated/repo/base-3.0.3.2/base.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/repo/base-3.0.3.2/base.cabal @@ -0,0 +1,160 @@ +name: base +version: 3.0.3.2 +license: BSD3 +license-file: LICENSE +maintainer: libraries@haskell.org +bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/base +synopsis: Basic libraries (backwards-compatibility version) +description: + This is a backwards-compatible version of the base package. + It depends on a later version of base, and was probably supplied + with your compiler when it was installed. + +cabal-version: >=1.6 +build-type: Simple + +source-repository head + type: darcs + location: http://darcs.haskell.org/packages/base3-compat + +Library { + build-depends: base >= 4.0 && < 4.3, + syb >= 0.1 && < 0.2 + extensions: PackageImports,CPP + ghc-options: -fno-warn-deprecations + + if impl(ghc < 6.9) { + buildable: False + } + + if impl(ghc) { + exposed-modules: + Data.Generics, + Data.Generics.Aliases, + Data.Generics.Basics, + Data.Generics.Instances, + Data.Generics.Schemes, + Data.Generics.Text, + Data.Generics.Twins, + Foreign.Concurrent, + GHC.Arr, + GHC.Base, + GHC.Conc, + GHC.ConsoleHandler, + GHC.Desugar, + GHC.Dotnet, + GHC.Enum, + GHC.Environment, + GHC.Err, + GHC.Exception, + GHC.Exts, + GHC.Float, + GHC.ForeignPtr, + GHC.Handle, + GHC.IO, + GHC.IOBase, + GHC.Int, + GHC.List, + GHC.Num, + GHC.PArr, + GHC.Pack, + GHC.Ptr, + GHC.Read, + GHC.Real, + GHC.ST, + GHC.STRef, + GHC.Show, + GHC.Stable, + GHC.Storable, + GHC.TopHandler, + GHC.Unicode, + GHC.Weak, + GHC.Word, + System.Timeout + } + exposed-modules: + Control.Applicative, + Control.Arrow, + Control.Category, + Control.Concurrent, + Control.Concurrent.Chan, + Control.Concurrent.MVar, + Control.Concurrent.QSem, + Control.Concurrent.QSemN, + Control.Concurrent.SampleVar, + Control.Exception, + Control.Monad, + Control.Monad.Fix, + Control.Monad.Instances, + Control.Monad.ST, + Control.Monad.ST.Lazy, + Control.Monad.ST.Strict, + Data.Bits, + Data.Bool, + Data.Char, + Data.Complex, + Data.Dynamic, + Data.Either, + Data.Eq, + Data.Fixed, + Data.Foldable + Data.Function, + Data.HashTable, + Data.IORef, + Data.Int, + Data.Ix, + Data.List, + Data.Maybe, + Data.Monoid, + Data.Ord, + Data.Ratio, + Data.STRef, + Data.STRef.Lazy, + Data.STRef.Strict, + Data.String, + Data.Traversable + Data.Tuple, + Data.Typeable, + Data.Unique, + Data.Version, + Data.Word, + Debug.Trace, + Foreign, + Foreign.C, + Foreign.C.Error, + Foreign.C.String, + Foreign.C.Types, + Foreign.ForeignPtr, + Foreign.Marshal, + Foreign.Marshal.Alloc, + Foreign.Marshal.Array, + Foreign.Marshal.Error, + Foreign.Marshal.Pool, + Foreign.Marshal.Utils, + Foreign.Ptr, + Foreign.StablePtr, + Foreign.Storable, + Numeric, + Prelude, + System.Console.GetOpt, + System.CPUTime, + System.Environment, + System.Exit, + System.IO, + System.IO.Error, + System.IO.Unsafe, + System.Info, + System.Mem, + System.Mem.StableName, + System.Mem.Weak, + System.Posix.Internals, + System.Posix.Types, + Text.ParserCombinators.ReadP, + Text.ParserCombinators.ReadPrec, + Text.Printf, + Text.Read, + Text.Read.Lex, + Text.Show, + Text.Show.Functions + Unsafe.Coerce +} diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/repo/base-4.0.0.0/base.cabal b/cabal/cabal-testsuite/PackageTests/Outdated/repo/base-4.0.0.0/base.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/repo/base-4.0.0.0/base.cabal @@ -0,0 +1,174 @@ +name: base +version: 4.0.0.0 +license: BSD3 +license-file: LICENSE +maintainer: libraries@haskell.org +synopsis: Basic libraries +description: + This package contains the Prelude and its support libraries, + and a large collection of useful libraries ranging from data + structures to parsing combinators and debugging utilities. +cabal-version: >= 1.2.3 +build-type: Configure +extra-tmp-files: + config.log config.status autom4te.cache + include/HsBaseConfig.h +extra-source-files: + config.guess config.sub install-sh + aclocal.m4 configure.ac configure + include/CTypes.h + +Library { + if impl(ghc) { + build-depends: rts, ghc-prim, integer + exposed-modules: + Foreign.Concurrent, + GHC.Arr, + GHC.Base, + GHC.Classes, + GHC.Conc, + GHC.ConsoleHandler, + GHC.Desugar, + GHC.Enum, + GHC.Environment, + GHC.Err, + GHC.Exception, + GHC.Exts, + GHC.Float, + GHC.ForeignPtr, + GHC.Handle, + GHC.IO, + GHC.IOBase, + GHC.Int, + GHC.List, + GHC.Num, + GHC.PArr, + GHC.Pack, + GHC.Ptr, + GHC.Read, + GHC.Real, + GHC.ST, + GHC.STRef, + GHC.Show, + GHC.Stable, + GHC.Storable, + GHC.TopHandler, + GHC.Unicode, + GHC.Weak, + GHC.Word, + System.Timeout + extensions: MagicHash, ExistentialQuantification, Rank2Types, + ScopedTypeVariables, UnboxedTuples, + ForeignFunctionInterface, UnliftedFFITypes, + DeriveDataTypeable, GeneralizedNewtypeDeriving, + FlexibleInstances, PatternSignatures, StandaloneDeriving, + PatternGuards, EmptyDataDecls + } + exposed-modules: + Control.Applicative, + Control.Arrow, + Control.Category, + Control.Concurrent, + Control.Concurrent.Chan, + Control.Concurrent.MVar, + Control.Concurrent.QSem, + Control.Concurrent.QSemN, + Control.Concurrent.SampleVar, + Control.Exception, + Control.Exception.Base + Control.OldException, + Control.Monad, + Control.Monad.Fix, + Control.Monad.Instances, + Control.Monad.ST + Control.Monad.ST.Lazy + Control.Monad.ST.Strict + Data.Bits, + Data.Bool, + Data.Char, + Data.Complex, + Data.Dynamic, + Data.Either, + Data.Eq, + Data.Data, + Data.Fixed, + Data.Foldable + Data.Function, + Data.HashTable, + Data.IORef, + Data.Int, + Data.Ix, + Data.List, + Data.Maybe, + Data.Monoid, + Data.Ord, + Data.Ratio, + Data.STRef + Data.STRef.Lazy + Data.STRef.Strict + Data.String, + Data.Traversable + Data.Tuple, + Data.Typeable, + Data.Unique, + Data.Version, + Data.Word, + Debug.Trace, + Foreign, + Foreign.C, + Foreign.C.Error, + Foreign.C.String, + Foreign.C.Types, + Foreign.ForeignPtr, + Foreign.Marshal, + Foreign.Marshal.Alloc, + Foreign.Marshal.Array, + Foreign.Marshal.Error, + Foreign.Marshal.Pool, + Foreign.Marshal.Utils, + Foreign.Ptr, + Foreign.StablePtr, + Foreign.Storable, + Numeric, + Prelude, + System.Console.GetOpt + System.CPUTime, + System.Environment, + System.Exit, + System.IO, + System.IO.Error, + System.IO.Unsafe, + System.Info, + System.Mem, + System.Mem.StableName, + System.Mem.Weak, + System.Posix.Internals, + System.Posix.Types, + Text.ParserCombinators.ReadP, + Text.ParserCombinators.ReadPrec, + Text.Printf, + Text.Read, + Text.Read.Lex, + Text.Show, + Text.Show.Functions + Unsafe.Coerce + c-sources: + cbits/PrelIOUtils.c + cbits/WCsubst.c + cbits/Win32Utils.c + cbits/consUtils.c + cbits/dirUtils.c + cbits/inputReady.c + cbits/selectUtils.c + include-dirs: include + includes: HsBase.h + install-includes: HsBase.h HsBaseConfig.h WCsubst.h dirUtils.h consUtils.h Typeable.h + if os(windows) { + extra-libraries: wsock32, msvcrt, kernel32, user32, shell32 + } + extensions: CPP + -- We need to set the package name to base (without a version number) + -- as it's magic. + ghc-options: -package-name base + nhc98-options: -H4M -K3M +} diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/repo/template-haskell-2.3.0.0/template-haskell.cabal b/cabal/cabal-testsuite/PackageTests/Outdated/repo/template-haskell-2.3.0.0/template-haskell.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/repo/template-haskell-2.3.0.0/template-haskell.cabal @@ -0,0 +1,22 @@ +name: template-haskell +version: 2.3.0.0 +x-revision: 1 +license: BSD3 +license-file: LICENSE +maintainer: libraries@haskell.org +description: + Facilities for manipulating Haskell source code using Template Haskell. +build-type: Simple +build-depends: base<4.3, pretty, packedstring, containers +exposed-modules: + Language.Haskell.TH.Syntax, + Language.Haskell.TH.PprLib, + Language.Haskell.TH.Ppr, + Language.Haskell.TH.Lib, + Language.Haskell.TH.Quote, + Language.Haskell.TH +extensions: MagicHash, PatternGuards, PolymorphicComponents, + DeriveDataTypeable, TypeSynonymInstances +-- We need to set the package name to template-haskell (without a +-- version number) as it's magic. +ghc-options: -package-name template-haskell diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/repo/template-haskell-2.3.0.1/template-haskell.cabal b/cabal/cabal-testsuite/PackageTests/Outdated/repo/template-haskell-2.3.0.1/template-haskell.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/repo/template-haskell-2.3.0.1/template-haskell.cabal @@ -0,0 +1,22 @@ +name: template-haskell +version: 2.3.0.1 +x-revision: 1 +license: BSD3 +license-file: LICENSE +maintainer: libraries@haskell.org +description: + Facilities for manipulating Haskell source code using Template Haskell. +build-type: Simple +build-depends: base <4.3, pretty, packedstring, containers +exposed-modules: + Language.Haskell.TH.Syntax, + Language.Haskell.TH.PprLib, + Language.Haskell.TH.Ppr, + Language.Haskell.TH.Lib, + Language.Haskell.TH.Quote, + Language.Haskell.TH +extensions: MagicHash, PatternGuards, PolymorphicComponents, + DeriveDataTypeable, TypeSynonymInstances +-- We need to set the package name to template-haskell (without a +-- version number) as it's magic. +ghc-options: -package-name template-haskell diff --git a/cabal/cabal-testsuite/PackageTests/Outdated/repo/template-haskell-2.4.0.0/template-haskell.cabal b/cabal/cabal-testsuite/PackageTests/Outdated/repo/template-haskell-2.4.0.0/template-haskell.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Outdated/repo/template-haskell-2.4.0.0/template-haskell.cabal @@ -0,0 +1,32 @@ +name: template-haskell +version: 2.4.0.0 +x-revision: 1 +license: BSD3 +license-file: LICENSE +maintainer: libraries@haskell.org +bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=Template%20Haskell +description: + Facilities for manipulating Haskell source code using Template Haskell. +build-type: Simple +Cabal-Version: >= 1.6 + +Library + build-depends: base >= 3 && < 4.3, + pretty, containers + exposed-modules: + Language.Haskell.TH.Syntax.Internals + Language.Haskell.TH.Syntax + Language.Haskell.TH.PprLib + Language.Haskell.TH.Ppr + Language.Haskell.TH.Lib + Language.Haskell.TH.Quote + Language.Haskell.TH + extensions: MagicHash, PatternGuards, PolymorphicComponents, + DeriveDataTypeable, TypeSynonymInstances + -- We need to set the package name to template-haskell (without a + -- version number) as it's magic. + ghc-options: -package-name template-haskell + +source-repository head + type: darcs + location: http://darcs.haskell.org/packages/template-haskell/ diff --git a/cabal/cabal-testsuite/PackageTests/PackageTester.hs b/cabal/cabal-testsuite/PackageTests/PackageTester.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/PackageTester.hs +++ /dev/null @@ -1,832 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE CPP #-} - -module PackageTests.PackageTester - ( PackageSpec - , SuiteConfig(..) - , TestConfig(..) - , Result(..) - , TestM - , runTestM - - -- * Paths - , ghcPath - , withGhcPath - , ghcPkgPath - , withGhcPkgPath - - , packageDir - , distDir - , relativeDistDir - , sharedDBPath - , getWithGhcPath - , prefixDir - - -- * Running cabal commands - , cabal - , cabal' - , cabal_build - , cabal_install - , cabal_install_with_docs - , ghcPkg - , ghcPkg' - , compileSetup - , shell - , run - , runExe - , runExe' - , runInstalledExe - , runInstalledExe' - , rawRun - , rawCompileSetup - , withPackage - , withEnv - , withPackageDb - - -- * Polymorphic versions of HUnit functions - , assertFailure - , assertEqual - , assertBool - , shouldExist - , shouldNotExist - - -- * Test helpers - , shouldFail - , whenGhcVersion - , assertOutputContains - , assertOutputDoesNotContain - , assertFindInFile - , concatOutput - , ghcFileModDelay - , withSymlink - - -- * Test trees - , TestTreeM - , runTestTree - , testTree - , testTreeSteps - , testTreeSub - , testTreeSubSteps - , testTree' - , groupTests - , mapTestTrees - , testWhen - , testUnless - , unlessWindows - , hasSharedLibraries - , hasCabalForGhc - - , getPersistBuildConfig - - -- Common utilities - , module System.FilePath - , module Data.List - , module Control.Monad.IO.Class - , module Text.Regex.Posix - ) where - -import PackageTests.Options - -import Distribution.Compat.CreatePipe (createPipe) -import Distribution.Simple.Compiler (PackageDBStack, PackageDB(..)) -import Distribution.Simple.Program.Run (getEffectiveEnvironment) -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Db -import Distribution.Simple.Program -import Distribution.System (OS(Windows), buildOS) -import Distribution.Simple.Utils - ( printRawCommandAndArgsAndEnv, withFileContents ) -import Distribution.Simple.Configure - ( getPersistBuildConfig ) -import Distribution.Verbosity (Verbosity) -import Distribution.Version - -import Distribution.Simple.BuildPaths (exeExtension) - -import Distribution.Simple.Utils (cabalVersion) -import Distribution.Text (display) - -import qualified Test.Tasty.HUnit as HUnit -import Text.Regex.Posix - -import qualified Control.Exception as E -import Control.Monad -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Writer -import Control.Monad.IO.Class -import qualified Data.ByteString.Char8 as C -import Data.List -import System.Directory - ( doesFileExist, canonicalizePath, createDirectoryIfMissing - , removeDirectoryRecursive, getPermissions, setPermissions - , setOwnerExecutable ) -import System.Exit -import System.FilePath -import System.IO -import System.IO.Error (isDoesNotExistError) -import System.Process (runProcess, waitForProcess, showCommandForUser) -import Control.Concurrent (threadDelay) -import Test.Tasty (TestTree, askOption, testGroup) - -#ifndef mingw32_HOST_OS -import Control.Monad.Catch ( bracket_ ) -import System.Directory ( removeFile ) -import System.Posix.Files ( createSymbolicLink ) -#endif - --- | Our test monad maintains an environment recording the global test --- suite configuration 'SuiteConfig', and the local per-test --- configuration 'TestConfig'. -type TestM = ReaderT (SuiteConfig, TestConfig) IO - --- | Run a test in the test monad. -runTestM :: SuiteConfig -> FilePath -> Maybe String -> TestM a -> IO () -runTestM suite name subname m = do - let test = TestConfig { - testMainName = name, - testSubName = subname, - testShouldFail = False, - testCurrentPackage = ".", - testPackageDb = False, - -- Try to avoid Unicode output - testEnvironment = [("LC_ALL", Just "C")] - } - void (runReaderT (cleanup >> m) (suite, test)) - where - -- TODO: option not to clean up dist dirs; this should be - -- harmless! - cleanup = do - onlyIfExists . removeDirectoryRecursive =<< topDir - --- | Run an IO action, and suppress a "does not exist" error. -onlyIfExists :: MonadIO m => IO () -> m () -onlyIfExists m = liftIO $ - E.catch m $ \(e :: IOError) -> - if isDoesNotExistError e - then return () - else E.throwIO e - --- cleaning up: --- cabal clean will clean up dist directory, but we also need to zap --- Setup etc. --- --- Suggestion: just copy the files somewhere else! - --- | Global configuration for the entire test suite. -data SuiteConfig = SuiteConfig - -- | The programs used to build the Cabal under test. - -- Invariant: ghc and ghc-pkg are configured. - { bootProgramDb :: ProgramDb - -- | The programs that are requested using @--with-compiler@ - -- and @--with-hc-pkg@ to Cabal the under-test. - -- Invariant: ghc and ghc-pkg are configured. - , withProgramDb :: ProgramDb - -- | The build directory that was used to build Cabal (used - -- to compile Setup scripts.) - , cabalDistPref :: FilePath - -- | The package database stack which makes the *built* - -- Cabal well-formed. In general, this is going to be - -- the package DB stack from the LBI you used to build - -- Cabal, PLUS the inplace database (since you also want Cabal). - -- TODO: I forgot what this comment means: - -- We don't add these by default because then you have to - -- link against Cabal which makes the build go longer. - , packageDBStack :: PackageDBStack - -- | The package database stack for 'withGhcPath'. This - -- is ignored if @'withGhcPath' suite == 'ghcPath' suite@. - -- We don't assume this includes the inplace database (since - -- Cabal would have been built with the wrong version of GHC, - -- so the databases aren't compatible anyway.) - , withGhcDBStack :: PackageDBStack - -- | How verbose should we be - , suiteVerbosity :: Verbosity - -- | The absolute current working directory - , absoluteCWD :: FilePath - -- | How long we should 'threadDelay' to make sure the file timestamp is - -- updated correctly for recompilation tests. - , mtimeChangeDelay :: Int - } - -getProgram :: ProgramDb -> Program -> ConfiguredProgram -getProgram progdb program = prog - where Just prog = lookupProgram program progdb -- invariant! - -getBootProgram :: SuiteConfig -> Program -> ConfiguredProgram -getBootProgram suite = getProgram (bootProgramDb suite) - -getWithProgram :: SuiteConfig -> Program -> ConfiguredProgram -getWithProgram suite = getProgram (withProgramDb suite) - -ghcProg :: SuiteConfig -> ConfiguredProgram -ghcProg suite = getBootProgram suite ghcProgram - -withGhcProg :: SuiteConfig -> ConfiguredProgram -withGhcProg suite = getWithProgram suite ghcProgram - -withGhcPkgProg :: SuiteConfig -> ConfiguredProgram -withGhcPkgProg suite = getWithProgram suite ghcPkgProgram - -programVersion' :: ConfiguredProgram -> Version -programVersion' prog = version - where Just version = programVersion prog -- invariant! - -ghcPath :: SuiteConfig -> FilePath -ghcPath = programPath . ghcProg - --- Basically you should never use these two... - -ghcPkgProg :: SuiteConfig -> ConfiguredProgram -ghcPkgProg suite = getBootProgram suite ghcPkgProgram - -ghcPkgPath :: SuiteConfig -> FilePath -ghcPkgPath = programPath . ghcPkgProg - -ghcVersion :: SuiteConfig -> Version -ghcVersion = programVersion' . ghcProg - -withGhcPath :: SuiteConfig -> FilePath -withGhcPath = programPath . withGhcProg - -withGhcVersion :: SuiteConfig -> Version -withGhcVersion = programVersion' . withGhcProg - --- Ditto... -withGhcPkgPath :: SuiteConfig -> FilePath -withGhcPkgPath = programPath . withGhcPkgProg - --- Selects the correct database stack to pass to the Cabal under --- test as the "database stack" to use for testing. This may be --- something different if the GHC we want Cabal to use is different --- from the GHC Cabal was built with. -testDBStack :: SuiteConfig -> PackageDBStack -testDBStack suite - | withGhcPath suite == ghcPath suite - = packageDBStack suite - | otherwise - = withGhcDBStack suite - -data TestConfig = TestConfig - -- | Test name, MUST be the directory the test packages live in - -- relative to tests/PackageTests - { testMainName :: FilePath - -- | Test sub-name, used to qualify dist/database directory to avoid - -- conflicts. - , testSubName :: Maybe String - -- | This gets modified sometimes - , testShouldFail :: Bool - -- | The "current" package, ala current directory - , testCurrentPackage :: PackageSpec - -- | Says if we've initialized the per-test package DB - , testPackageDb :: Bool - -- | Environment override - , testEnvironment :: [(String, Maybe String)] - } - --- | A package that can be built. -type PackageSpec = FilePath - ------------------------------------------------------------------------- --- * Directories - -simpleSetupPath :: TestM FilePath -simpleSetupPath = do - (suite, _) <- ask - return (absoluteCWD suite "Setup") - --- | The absolute path to the directory containing the files for --- this tests; usually @Check.hs@ and any test packages. -testDir :: TestM FilePath -testDir = do - (suite, test) <- ask - return $ absoluteCWD suite "PackageTests" testMainName test - --- | The absolute path to the root of the package directory; it's --- where the Cabal file lives. This is what you want the CWD of cabal --- calls to be. -packageDir :: TestM FilePath -packageDir = do - (_, test) <- ask - test_dir <- testDir - return $ test_dir testCurrentPackage test - --- | The absolute path to the directory containing all the --- files for ALL tests associated with a test (respecting --- subtests.) To clean, you ONLY need to delete this directory. -topDir :: TestM FilePath -topDir = do - test_dir <- testDir - (_, test) <- ask - return $ test_dir - case testSubName test of - Nothing -> "dist-test" - Just n -> "dist-test." ++ n - -prefixDir :: TestM FilePath -prefixDir = do - top_dir <- topDir - return $ top_dir "usr" - --- | The absolute path to the build directory that should be used --- for the current package in a test. -distDir :: TestM FilePath -distDir = do - top_dir <- topDir - (_, test) <- ask - return $ top_dir testCurrentPackage test "dist" - -definitelyMakeRelative :: FilePath -> FilePath -> FilePath -definitelyMakeRelative base0 path0 = - let go [] path = joinPath path - go base [] = joinPath (replicate (length base) "..") - go (".":xs) ys = go xs ys - go xs (".":ys) = go xs ys - go (x:xs) (y:ys) - | x == y = go xs ys - | otherwise = go (x:xs) [] go [] (y:ys) - in go (splitPath base0) (splitPath path0) - --- hpc is stupid and doesn't understand absolute paths. -relativeDistDir :: TestM FilePath -relativeDistDir = do - dist_dir0 <- distDir - pkg_dir <- packageDir - return $ definitelyMakeRelative pkg_dir dist_dir0 - --- | The absolute path to the shared package database that should --- be used by all packages in this test. -sharedDBPath :: TestM FilePath -sharedDBPath = do - top_dir <- topDir - return $ top_dir "packagedb" - -getWithGhcPath :: TestM FilePath -getWithGhcPath = do - (suite, _) <- ask - return $ withGhcPath suite - ------------------------------------------------------------------------- --- * Running cabal - -cabal :: String -> [String] -> TestM () -cabal cmd extraArgs0 = void (cabal' cmd extraArgs0) - -cabal' :: String -> [String] -> TestM Result -cabal' cmd extraArgs0 = do - (suite, test) <- ask - prefix_dir <- prefixDir - when ((cmd == "register" || cmd == "copy") && not (testPackageDb test)) $ - error "Cannot register/copy without using 'withPackageDb'" - let extraArgs1 = case cmd of - "configure" -> - -- If the package database is empty, setting --global - -- here will make us error loudly if we try to install - -- into a bad place. - [ "--global" - , "--with-ghc", withGhcPath suite - -- This improves precision but it increases the number - -- of flags one has to specify and I don't like that; - -- Cabal is going to configure it and usually figure - -- out the right location in any case. - -- , "--with-ghc-pkg", withGhcPkgPath suite - -- These flags make the test suite run faster - -- Can't do this unless we LD_LIBRARY_PATH correctly - -- , "--enable-executable-dynamic" - , "--disable-optimization" - -- Specify where we want our installed packages to go - , "--prefix=" ++ prefix_dir - ] -- Only add the LBI package stack if the GHC version - -- matches. - ++ packageDBParams (testDBStack suite) - ++ extraArgs0 - _ -> extraArgs0 - -- This is a horrible hack to make hpc work correctly - dist_dir <- relativeDistDir - let extraArgs = ["-v", "--distdir", dist_dir] ++ extraArgs1 - doCabal (cmd:extraArgs) - --- | This abstracts the common pattern of configuring and then building. -cabal_build :: [String] -> TestM () -cabal_build args = do - cabal "configure" args - cabal "build" [] - return () - --- | This abstracts the common pattern of "installing" a package. -cabal_install :: [String] -> TestM () -cabal_install args = do - cabal "configure" args - cabal "build" [] - cabal "copy" [] - cabal "register" [] - return () - --- | This abstracts the common pattern of "installing" a package, --- with haddock documentation. -cabal_install_with_docs :: [String] -> TestM () -cabal_install_with_docs args = do - cabal "configure" args - cabal "build" [] - cabal "haddock" [] - cabal "copy" [] - cabal "register" [] - return () - --- | Determines what Setup executable to run and runs it -doCabal :: [String] -- ^ extra arguments - -> TestM Result -doCabal cabalArgs = do - pkg_dir <- packageDir - customSetup <- liftIO $ doesFileExist (pkg_dir "Setup.hs") - if customSetup - then do - compileSetup - -- TODO make this less racey - let path = pkg_dir "Setup" - run (Just pkg_dir) path cabalArgs - else do - -- Use shared Setup executable (only for Simple build types). - path <- simpleSetupPath - run (Just pkg_dir) path cabalArgs - -packageDBParams :: PackageDBStack -> [String] -packageDBParams dbs = "--package-db=clear" - : map (("--package-db=" ++) . convert) dbs - where - convert :: PackageDB -> String - convert GlobalPackageDB = "global" - convert UserPackageDB = "user" - convert (SpecificPackageDB path) = path - ------------------------------------------------------------------------- --- * Compiling setup scripts - -compileSetup :: TestM () -compileSetup = do - (suite, test) <- ask - pkg_path <- packageDir - liftIO $ rawCompileSetup (suiteVerbosity suite) suite (testEnvironment test) pkg_path - -rawCompileSetup :: Verbosity -> SuiteConfig -> [(String, Maybe String)] -> FilePath -> IO () -rawCompileSetup verbosity suite e path = do - -- NB: Use 'ghcPath', not 'withGhcPath', since we need to be able to - -- link against the Cabal library which was built with 'ghcPath'. - -- Ditto with packageDBStack. - r <- rawRun verbosity (Just path) (ghcPath suite) e $ - [ "--make"] ++ - ghcPackageDBParams (ghcVersion suite) (packageDBStack suite) ++ - [ "-hide-package Cabal" - -- This mostly works, UNLESS you've installed a - -- version of Cabal with the SAME version number. - -- Then old GHCs will incorrectly select the installed - -- version (because it prefers the FIRST package it finds.) - -- It also semi-works to not specify "-hide-all-packages" - -- at all, except if there's a later version of Cabal - -- installed GHC will prefer that. - , "-package Cabal-" ++ display cabalVersion - , "-O0" - , "Setup.hs" ] - unless (resultExitCode r == ExitSuccess) $ - error $ - "could not build shared Setup executable\n" ++ - " ran: " ++ resultCommand r ++ "\n" ++ - " output:\n" ++ resultOutput r ++ "\n\n" - -ghcPackageDBParams :: Version -> PackageDBStack -> [String] -ghcPackageDBParams ghc_version dbs - | ghc_version >= mkVersion [7,6] - = "-clear-package-db" : map convert dbs - | otherwise - = concatMap convertLegacy dbs - where - convert :: PackageDB -> String - convert GlobalPackageDB = "-global-package-db" - convert UserPackageDB = "-user-package-db" - convert (SpecificPackageDB path) = "-package-db=" ++ path - - convertLegacy :: PackageDB -> [String] - convertLegacy (SpecificPackageDB path) = ["-package-conf=" ++ path] - convertLegacy _ = [] - ------------------------------------------------------------------------- --- * Running ghc-pkg - -ghcPkg :: String -> [String] -> TestM () -ghcPkg cmd args = void (ghcPkg' cmd args) - -ghcPkg' :: String -> [String] -> TestM Result -ghcPkg' cmd args = do - (config, test) <- ask - unless (testPackageDb test) $ - error "Must initialize package database using withPackageDb" - -- NB: testDBStack already has the local database - let db_stack = testDBStack config - extraArgs = ghcPkgPackageDBParams (withGhcVersion config) db_stack - run Nothing (withGhcPkgPath config) (cmd : extraArgs ++ args) - -ghcPkgPackageDBParams :: Version -> PackageDBStack -> [String] -ghcPkgPackageDBParams version dbs = concatMap convert dbs where - convert :: PackageDB -> [String] - -- Ignoring global/user is dodgy but there's no way good - -- way to give ghc-pkg the correct flags in this case. - convert GlobalPackageDB = [] - convert UserPackageDB = [] - convert (SpecificPackageDB path) - | version >= mkVersion [7,6] - = ["--package-db=" ++ path] - | otherwise - = ["--package-conf=" ++ path] - ------------------------------------------------------------------------- --- * Running other things - --- | Run an executable that was produced by cabal. The @exe_name@ --- is precisely the name of the executable section in the file. -runExe :: String -> [String] -> TestM () -runExe exe_name args = void (runExe' exe_name args) - -runExe' :: String -> [String] -> TestM Result -runExe' exe_name args = do - dist_dir <- distDir - let exe = dist_dir "build" exe_name exe_name - run Nothing exe args - --- | Run an executable that was installed by cabal. The @exe_name@ --- is precisely the name of the executable. -runInstalledExe :: String -> [String] -> TestM () -runInstalledExe exe_name args = void (runInstalledExe' exe_name args) - -runInstalledExe' :: String -> [String] -> TestM Result -runInstalledExe' exe_name args = do - usr <- prefixDir - let exe = usr "bin" exe_name - run Nothing exe args - -shell :: String -> [String] -> TestM Result -shell exe args = do - pkg_dir <- packageDir - run (Just pkg_dir) exe args - -run :: Maybe FilePath -> String -> [String] -> TestM Result -run mb_cwd path args = do - verbosity <- getVerbosity - (_, test) <- ask - r <- liftIO $ rawRun verbosity mb_cwd path (testEnvironment test) args - record r - requireSuccess r - -rawRun :: Verbosity -> Maybe FilePath -> String -> [(String, Maybe String)] -> [String] -> IO Result -rawRun verbosity mb_cwd path envOverrides args = do - -- path is relative to the current directory; canonicalizePath makes it - -- absolute, so that runProcess will find it even when changing directory. - path' <- do pathExists <- doesFileExist path - exePathExists <- doesFileExist (path <.> exeExtension) - case () of - _ | pathExists -> canonicalizePath path - | exePathExists -> canonicalizePath (path <.> exeExtension) - | otherwise -> return path - menv <- getEffectiveEnvironment envOverrides - - printRawCommandAndArgsAndEnv verbosity path' args menv - (readh, writeh) <- createPipe - pid <- runProcess path' args mb_cwd menv Nothing (Just writeh) (Just writeh) - - out <- hGetContents readh - void $ E.evaluate (length out) -- force the output - hClose readh - - -- wait for the program to terminate - exitcode <- waitForProcess pid - return Result { - resultExitCode = exitcode, - resultDirectory = mb_cwd, - resultCommand = showCommandForUser path' args, - resultOutput = out - } - ------------------------------------------------------------------------- --- * Subprocess run results - -data Result = Result - { resultExitCode :: ExitCode - , resultDirectory :: Maybe FilePath - , resultCommand :: String - , resultOutput :: String - } deriving Show - -requireSuccess :: Result -> TestM Result -requireSuccess r@Result { resultCommand = cmd - , resultExitCode = exitCode - , resultOutput = output } = do - (_, test) <- ask - when (exitCode /= ExitSuccess && not (testShouldFail test)) $ - assertFailure $ "Command " ++ cmd ++ " failed.\n" ++ - "Output:\n" ++ output ++ "\n" - when (exitCode == ExitSuccess && testShouldFail test) $ - assertFailure $ "Command " ++ cmd ++ " succeeded.\n" ++ - "Output:\n" ++ output ++ "\n" - return r - -record :: Result -> TestM () -record res = do - log_dir <- topDir - (suite, _) <- ask - liftIO $ createDirectoryIfMissing True log_dir - liftIO $ C.appendFile (log_dir "test.log") - (C.pack $ "+ " ++ resultCommand res ++ "\n" - ++ resultOutput res ++ "\n\n") - let test_sh = log_dir "test.sh" - b <- liftIO $ doesFileExist test_sh - when (not b) . liftIO $ do - -- This is hella racey but this is not that security important - C.appendFile test_sh - (C.pack $ "#/bin/sh\nset -ev\n" ++ - "cd "++ show (absoluteCWD suite) ++"\n") - perms <- getPermissions test_sh - setPermissions test_sh (setOwnerExecutable True perms) - - liftIO $ C.appendFile test_sh - (C.pack - (case resultDirectory res of - Nothing -> resultCommand res ++ "\n" - Just d -> "(cd " ++ show d ++ " && " ++ resultCommand res ++ ")\n")) - ------------------------------------------------------------------------- --- * Test helpers - -assertFailure :: MonadIO m => String -> m () -assertFailure = liftIO . HUnit.assertFailure - -assertEqual :: (Eq a, Show a, MonadIO m) => String -> a -> a -> m () -assertEqual s x y = liftIO $ HUnit.assertEqual s x y - -assertBool :: MonadIO m => String -> Bool -> m () -assertBool s x = liftIO $ HUnit.assertBool s x - -shouldExist :: MonadIO m => FilePath -> m () -shouldExist path = liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") - -shouldNotExist :: MonadIO m => FilePath -> m () -shouldNotExist path = - liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") . not - -shouldFail :: TestM a -> TestM a -shouldFail = withReaderT (\(suite, test) -> (suite, test { testShouldFail = not (testShouldFail test) })) - -whenGhcVersion :: (Version -> Bool) -> TestM () -> TestM () -whenGhcVersion p m = do - (suite, _) <- ask - when (p (withGhcVersion suite)) m - -withPackage :: FilePath -> TestM a -> TestM a -withPackage f = withReaderT (\(suite, test) -> (suite, test { testCurrentPackage = f })) - --- We append to the environment list, as per 'getEffectiveEnvironment' --- which prefers the latest override. -withEnv :: [(String, Maybe String)] -> TestM a -> TestM a -withEnv e m = do - withReaderT (\(suite, test) -> (suite, test { testEnvironment = testEnvironment test ++ e })) m - -withPackageDb :: TestM a -> TestM a -withPackageDb m = do - (_, test0) <- ask - db_path <- sharedDBPath - if testPackageDb test0 - then m - else withReaderT (\(suite, test) -> - (suite { packageDBStack - = packageDBStack suite - ++ [SpecificPackageDB db_path] - , withGhcDBStack - = withGhcDBStack suite - ++ [SpecificPackageDB db_path]}, - test { testPackageDb = True })) - $ do ghcPkg "init" [db_path] - m - -assertOutputContains :: MonadIO m => String -> Result -> m () -assertOutputContains needle result = - unless (needle `isInfixOf` (concatOutput output)) $ - assertFailure $ - " expected: " ++ needle ++ "\n" ++ - " in output: " ++ output ++ "" - where output = resultOutput result - -assertOutputDoesNotContain :: MonadIO m => String -> Result -> m () -assertOutputDoesNotContain needle result = - when (needle `isInfixOf` (concatOutput output)) $ - assertFailure $ - "unexpected: " ++ needle ++ - " in output: " ++ output - where output = resultOutput result - -assertFindInFile :: MonadIO m => String -> FilePath -> m () -assertFindInFile needle path = - liftIO $ withFileContents path - (\contents -> - unless (needle `isInfixOf` contents) - (assertFailure ("expected: " ++ needle ++ "\n" ++ - " in file: " ++ path))) - --- | Replace line breaks with spaces, correctly handling "\r\n". -concatOutput :: String -> String -concatOutput = unwords . lines . filter ((/=) '\r') - --- | Delay a sufficient period of time to permit file timestamp --- to be updated. -ghcFileModDelay :: TestM () -ghcFileModDelay = do - (suite, _) <- ask - -- For old versions of GHC, we only had second-level precision, - -- so we need to sleep a full second. Newer versions use - -- millisecond level precision, so we only have to wait - -- the granularity of the underlying filesystem. - -- TODO: cite commit when GHC got better precision; this - -- version bound was empirically generated. - let delay | withGhcVersion suite < mkVersion [7,7] - = 1000000 -- 1s - | otherwise - = mtimeChangeDelay suite - liftIO $ threadDelay delay - --- | Create a symlink for the duration of the provided action. If the symlink --- already exists, it is deleted. Does not work on Windows. -withSymlink :: FilePath -> FilePath -> TestM a -> TestM a -#ifdef mingw32_HOST_OS -withSymlink _oldpath _newpath _act = - error "PackageTests.PackageTester.withSymlink: does not work on Windows!" -#else -withSymlink oldpath newpath act = do - symlinkExists <- liftIO $ doesFileExist newpath - when symlinkExists $ liftIO $ removeFile newpath - bracket_ (liftIO $ createSymbolicLink oldpath newpath) - (liftIO $ removeFile newpath) act -#endif - ------------------------------------------------------------------------- --- * Test trees - --- | Monad for creating test trees. The option --enable-all-tests determines --- whether to filter tests with 'testWhen' and 'testUnless'. -type TestTreeM = WriterT [TestTree] (Reader OptionEnableAllTests) - -runTestTree :: String -> TestTreeM () -> TestTree -runTestTree name ts = askOption $ - testGroup name . runReader (execWriterT ts) - -testTree :: SuiteConfig -> String -> TestM a -> TestTreeM () -testTree config name m = - testTree' $ HUnit.testCase name $ runTestM config name Nothing m - -testTreeSteps :: SuiteConfig -> String -> ((String -> TestM ()) -> TestM a) -> TestTreeM () -testTreeSteps config name f = - testTree' . HUnit.testCaseSteps name - $ \step -> runTestM config name Nothing (f (liftIO . step)) - -testTreeSub :: SuiteConfig -> String -> String -> TestM a -> TestTreeM () -testTreeSub config name sub_name m = - testTree' $ HUnit.testCase (name sub_name) $ runTestM config name (Just sub_name) m - -testTreeSubSteps :: SuiteConfig -> String -> String - -> ((String -> TestM ()) -> TestM a) - -> TestTreeM () -testTreeSubSteps config name sub_name f = - testTree' . HUnit.testCaseSteps (name sub_name) - $ \step -> runTestM config name (Just sub_name) (f (liftIO . step)) - -testTree' :: TestTree -> TestTreeM () -testTree' tc = tell [tc] - --- | Create a test group from the output of the given action. -groupTests :: String -> TestTreeM () -> TestTreeM () -groupTests name = censor (\ts -> [testGroup name ts]) - --- | Apply a function to each top-level test tree. -mapTestTrees :: (TestTree -> TestTree) -> TestTreeM a -> TestTreeM a -mapTestTrees = censor . map - -testWhen :: Bool -> TestTreeM () -> TestTreeM () -testWhen c test = do - OptionEnableAllTests enableAll <- lift ask - when (enableAll || c) test - -testUnless :: Bool -> TestTreeM () -> TestTreeM () -testUnless = testWhen . not - -unlessWindows :: TestTreeM () -> TestTreeM () -unlessWindows = testUnless (buildOS == Windows) - -hasSharedLibraries :: SuiteConfig -> Bool -hasSharedLibraries config = - buildOS /= Windows || withGhcVersion config < mkVersion [7,8] - -hasCabalForGhc :: SuiteConfig -> Bool -hasCabalForGhc config = - withGhcPath config == ghcPath config - ------------------------------------------------------------------------- --- Verbosity - -getVerbosity :: TestM Verbosity -getVerbosity = fmap (suiteVerbosity . fst) ask diff --git a/cabal/cabal-testsuite/PackageTests/PathsModule/Executable/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/PathsModule/Executable/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PathsModule/Executable/setup.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring PathsModule-0.1... +# Setup build +Preprocessing executable 'TestPathsModule' for PathsModule-0.1.. +Building executable 'TestPathsModule' for PathsModule-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/PathsModule/Executable/setup.out b/cabal/cabal-testsuite/PackageTests/PathsModule/Executable/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PathsModule/Executable/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring PathsModule-0.1... +# Setup build +Preprocessing executable 'TestPathsModule' for PathsModule-0.1.. +Building executable 'TestPathsModule' for PathsModule-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/PathsModule/Executable/setup.test.hs b/cabal/cabal-testsuite/PackageTests/PathsModule/Executable/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PathsModule/Executable/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +-- Test that Paths module is generated and available for executables. +main = setupAndCabalTest $ setup_build [] + diff --git a/cabal/cabal-testsuite/PackageTests/PathsModule/Library/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/PathsModule/Library/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PathsModule/Library/setup.cabal.out @@ -0,0 +1,6 @@ +# Setup configure +Resolving dependencies... +Configuring PathsModule-0.1... +# Setup build +Preprocessing library for PathsModule-0.1.. +Building library for PathsModule-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/PathsModule/Library/setup.out b/cabal/cabal-testsuite/PackageTests/PathsModule/Library/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PathsModule/Library/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring PathsModule-0.1... +# Setup build +Preprocessing library for PathsModule-0.1.. +Building library for PathsModule-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/PathsModule/Library/setup.test.hs b/cabal/cabal-testsuite/PackageTests/PathsModule/Library/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PathsModule/Library/setup.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +-- Test that Paths module is generated and available for libraries. +main = setupAndCabalTest $ setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/PreProcess/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/setup.cabal.out @@ -0,0 +1,12 @@ +# Setup configure +Resolving dependencies... +Configuring PreProcess-0.1... +# Setup build +Preprocessing test suite 'my-test-suite' for PreProcess-0.1.. +Building test suite 'my-test-suite' for PreProcess-0.1.. +Preprocessing executable 'my-executable' for PreProcess-0.1.. +Building executable 'my-executable' for PreProcess-0.1.. +Preprocessing benchmark 'my-benchmark' for PreProcess-0.1.. +Building benchmark 'my-benchmark' for PreProcess-0.1.. +Preprocessing library for PreProcess-0.1.. +Building library for PreProcess-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/setup.out b/cabal/cabal-testsuite/PackageTests/PreProcess/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/setup.out @@ -0,0 +1,11 @@ +# Setup configure +Configuring PreProcess-0.1... +# Setup build +Preprocessing test suite 'my-test-suite' for PreProcess-0.1.. +Building test suite 'my-test-suite' for PreProcess-0.1.. +Preprocessing executable 'my-executable' for PreProcess-0.1.. +Building executable 'my-executable' for PreProcess-0.1.. +Preprocessing benchmark 'my-benchmark' for PreProcess-0.1.. +Building benchmark 'my-benchmark' for PreProcess-0.1.. +Preprocessing library for PreProcess-0.1.. +Building library for PreProcess-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/PreProcess/setup.test.hs b/cabal/cabal-testsuite/PackageTests/PreProcess/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcess/setup.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +-- Check that preprocessors (hsc2hs) are run +main = setupAndCabalTest $ setup_build ["--enable-tests", "--enable-benchmarks"] diff --git a/cabal/cabal-testsuite/PackageTests/PreProcessExtraSources/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/PreProcessExtraSources/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcessExtraSources/setup.cabal.out @@ -0,0 +1,12 @@ +# Setup configure +Resolving dependencies... +Configuring PreProcessExtraSources-0.1... +# Setup build +Preprocessing test suite 'my-test-suite' for PreProcessExtraSources-0.1.. +Building test suite 'my-test-suite' for PreProcessExtraSources-0.1.. +Preprocessing executable 'my-executable' for PreProcessExtraSources-0.1.. +Building executable 'my-executable' for PreProcessExtraSources-0.1.. +Preprocessing benchmark 'my-benchmark' for PreProcessExtraSources-0.1.. +Building benchmark 'my-benchmark' for PreProcessExtraSources-0.1.. +Preprocessing library for PreProcessExtraSources-0.1.. +Building library for PreProcessExtraSources-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/PreProcessExtraSources/setup.out b/cabal/cabal-testsuite/PackageTests/PreProcessExtraSources/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcessExtraSources/setup.out @@ -0,0 +1,11 @@ +# Setup configure +Configuring PreProcessExtraSources-0.1... +# Setup build +Preprocessing test suite 'my-test-suite' for PreProcessExtraSources-0.1.. +Building test suite 'my-test-suite' for PreProcessExtraSources-0.1.. +Preprocessing executable 'my-executable' for PreProcessExtraSources-0.1.. +Building executable 'my-executable' for PreProcessExtraSources-0.1.. +Preprocessing benchmark 'my-benchmark' for PreProcessExtraSources-0.1.. +Building benchmark 'my-benchmark' for PreProcessExtraSources-0.1.. +Preprocessing library for PreProcessExtraSources-0.1.. +Building library for PreProcessExtraSources-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/PreProcessExtraSources/setup.test.hs b/cabal/cabal-testsuite/PackageTests/PreProcessExtraSources/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/PreProcessExtraSources/setup.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +-- Check that preprocessors that generate extra C sources are handled +main = setupAndCabalTest $ setup_build ["--enable-tests", "--enable-benchmarks"] diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/Exe.hs b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/Exe.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/Exe.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module Main where + +import QQ + +main = putStrLn [myq|hello|] diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/Lib.hs b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/Lib.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/Lib.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module Lib where + +import QQ + +val = [myq|hello|] diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/QQ.hs b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/QQ.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/QQ.hs @@ -0,0 +1,6 @@ +module QQ where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +myq = QuasiQuoter { quoteExp = \s -> litE $ stringL $ s ++ " world"} diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/my.cabal b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/my.cabal @@ -0,0 +1,15 @@ +Name: quasiQuotes +Version: 0.1 +Build-Type: Simple +Cabal-Version: >= 1.2 + +Library + Exposed-Modules: Lib + Other-Modules: QQ + Build-Depends: base, template-haskell + Extensions: QuasiQuotes + +Executable main + Main-is: Exe.hs + Build-Depends: base, template-haskell + Extensions: QuasiQuotes diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Resolving dependencies... +Configuring quasiQuotes-0.1... +# Setup build +Preprocessing executable 'main' for quasiQuotes-0.1.. +Building executable 'main' for quasiQuotes-0.1.. +Preprocessing library for quasiQuotes-0.1.. +Building library for quasiQuotes-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.out b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring quasiQuotes-0.1... +# Setup build +Preprocessing executable 'main' for quasiQuotes-0.1.. +Building executable 'main' for quasiQuotes-0.1.. +Preprocessing library for quasiQuotes-0.1.. +Building library for quasiQuotes-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.test.hs b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/dynamic/setup.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +-- Test building a dynamic library/executable which uses QuasiQuotes +main = setupAndCabalTest $ do + skipUnless =<< hasSharedLibraries + setup_build ["--enable-shared", "--enable-executable-dynamic"] diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/Exe.hs b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/Exe.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/Exe.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module Main where + +import QQ + +main = putStrLn [myq|hello|] diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/Lib.hs b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/Lib.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/Lib.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module Lib where + +import QQ + +val = [myq|hello|] diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/QQ.hs b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/QQ.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/QQ.hs @@ -0,0 +1,6 @@ +module QQ where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +myq = QuasiQuoter { quoteExp = \s -> litE $ stringL $ s ++ " world"} diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/my.cabal b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/my.cabal @@ -0,0 +1,15 @@ +Name: quasiQuotes +Version: 0.1 +Build-Type: Simple +Cabal-Version: >= 1.2 + +Library + Exposed-Modules: Lib + Other-Modules: QQ + Build-Depends: base, template-haskell + Extensions: QuasiQuotes + +Executable main + Main-is: Exe.hs + Build-Depends: base, template-haskell + Extensions: QuasiQuotes diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Resolving dependencies... +Configuring quasiQuotes-0.1... +# Setup build +Preprocessing executable 'main' for quasiQuotes-0.1.. +Building executable 'main' for quasiQuotes-0.1.. +Preprocessing library for quasiQuotes-0.1.. +Building library for quasiQuotes-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.out b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring quasiQuotes-0.1... +# Setup build +Preprocessing executable 'main' for quasiQuotes-0.1.. +Building executable 'main' for quasiQuotes-0.1.. +Preprocessing library for quasiQuotes-0.1.. +Building library for quasiQuotes-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.test.hs b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/profiling/setup.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +-- Test building a profiled library/executable which uses QuasiQuotes +-- (setup has to build the non-profiled version first) +main = setupAndCabalTest $ do + skipUnless =<< hasProfiledLibraries + setup_build ["--enable-library-profiling", + "--enable-profiling"] diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/Exe.hs b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/Exe.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/Exe.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module Main where + +import QQ + +main = putStrLn [myq|hello|] diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/Lib.hs b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/Lib.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/Lib.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module Lib where + +import QQ + +val = [myq|hello|] diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/QQ.hs b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/QQ.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/QQ.hs @@ -0,0 +1,6 @@ +module QQ where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +myq = QuasiQuoter { quoteExp = \s -> litE $ stringL $ s ++ " world"} diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/my.cabal b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/my.cabal @@ -0,0 +1,15 @@ +Name: quasiQuotes +Version: 0.1 +Build-Type: Simple +Cabal-Version: >= 1.2 + +Library + Exposed-Modules: Lib + Other-Modules: QQ + Build-Depends: base, template-haskell + Extensions: QuasiQuotes + +Executable main + Main-is: Exe.hs + Build-Depends: base, template-haskell + Extensions: QuasiQuotes diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Resolving dependencies... +Configuring quasiQuotes-0.1... +# Setup build +Preprocessing executable 'main' for quasiQuotes-0.1.. +Building executable 'main' for quasiQuotes-0.1.. +Preprocessing library for quasiQuotes-0.1.. +Building library for quasiQuotes-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/setup.out b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring quasiQuotes-0.1... +# Setup build +Preprocessing executable 'main' for quasiQuotes-0.1.. +Building executable 'main' for quasiQuotes-0.1.. +Preprocessing library for quasiQuotes-0.1.. +Building library for quasiQuotes-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/setup.test.hs b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/QuasiQuotes/vanilla/setup.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +-- Test building a vanilla library/executable which uses QuasiQuotes +main = setupAndCabalTest $ setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/fail-ambiguous.cabal b/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/fail-ambiguous.cabal deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/fail-ambiguous.cabal +++ /dev/null @@ -1,10 +0,0 @@ -name: p -version: 0.1.0.0 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.21 - -library - build-depends: base, containers, containers-dupe - reexported-modules: Data.Map as Map diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/fail-missing.cabal b/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/fail-missing.cabal deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/fail-missing.cabal +++ /dev/null @@ -1,10 +0,0 @@ -name: p -version: 0.1.0.0 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.21 - -library - build-depends: base - reexported-modules: Missing as Foobar diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/fail-other.cabal b/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/fail-other.cabal deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/fail-other.cabal +++ /dev/null @@ -1,12 +0,0 @@ -name: p -version: 0.1.0.0 -author: Edward Z. Yang -maintainer: ezyang@cs.stanford.edu -build-type: Simple -cabal-version: >=1.21 - -library - exposed-modules: Public - other-modules: Private - build-depends: base - reexported-modules: Private as Reprivate diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/p.cabal b/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/p.cabal --- a/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/p.cabal +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/p.cabal @@ -15,3 +15,4 @@ containers:Data.Tree, Public as Republic -- NB: Private is not reexportable + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/p.cabal.fail-ambiguous b/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/p.cabal.fail-ambiguous new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/p.cabal.fail-ambiguous @@ -0,0 +1,11 @@ +name: p +version: 0.1.0.0 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.21 + +library + build-depends: base, containers, containers-dupe + reexported-modules: Data.Map as Map + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/p.cabal.fail-missing b/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/p.cabal.fail-missing new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/p.cabal.fail-missing @@ -0,0 +1,11 @@ +name: p +version: 0.1.0.0 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.21 + +library + build-depends: base + reexported-modules: Missing as Foobar + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/p.cabal.fail-other b/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/p.cabal.fail-other new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/p/p.cabal.fail-other @@ -0,0 +1,13 @@ +name: p +version: 0.1.0.0 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.21 + +library + exposed-modules: Public + other-modules: Private + build-depends: base + reexported-modules: Private as Reprivate + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.cabal.out b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.cabal.out @@ -0,0 +1,25 @@ +# Setup configure +Resolving dependencies... +Configuring containers-dupe-0.1.0.0... +# Setup build +Preprocessing library for containers-dupe-0.1.0.0.. +Building library for containers-dupe-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for containers-dupe-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring p-0.1.0.0... +Error: + Problem with module re-exports: + - Ambiguous reexport 'Data.Map' + It could refer to either: + 'containers-:Data.Map' + brought into scope by build-depends: containers + or 'containers-dupe-0.1.0.0:Data.Map' + brought into scope by build-depends: containers-dupe + The ambiguity can be resolved by qualifying the + re-export with a package name. + The syntax is 'packagename:ModuleName [as NewName]'. + In the stanza library diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.out b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.out @@ -0,0 +1,23 @@ +# Setup configure +Configuring containers-dupe-0.1.0.0... +# Setup build +Preprocessing library for containers-dupe-0.1.0.0.. +Building library for containers-dupe-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for containers-dupe-0.1.0.0.. +# Setup configure +Configuring p-0.1.0.0... +Error: + Problem with module re-exports: + - Ambiguous reexport 'Data.Map' + It could refer to either: + 'containers-:Data.Map' + brought into scope by build-depends: containers + or 'containers-dupe-0.1.0.0:Data.Map' + brought into scope by build-depends: containers-dupe + The ambiguity can be resolved by qualifying the + re-export with a package name. + The syntax is 'packagename:ModuleName [as NewName]'. + In the stanza library diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.test.hs b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-ambiguous.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [7,9]) + withPackageDb $ do + withDirectory "containers-dupe" $ + setup_install [] + withDirectory "p" $ do + r <- fails $ setup' "configure" ["--cabal-file", "p.cabal.fail-ambiguous"] + assertOutputContains "Data.Map" r diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.cabal.out b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.cabal.out @@ -0,0 +1,10 @@ +# Setup configure +Resolving dependencies... +Configuring p-0.1.0.0... +Error: + Problem with module re-exports: + - The module 'Missing' + is not exported by any suitable package. + It occurs in neither the 'exposed-modules' of this package, + nor any of its 'build-depends' dependencies. + In the stanza library diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.out b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.out @@ -0,0 +1,9 @@ +# Setup configure +Configuring p-0.1.0.0... +Error: + Problem with module re-exports: + - The module 'Missing' + is not exported by any suitable package. + It occurs in neither the 'exposed-modules' of this package, + nor any of its 'build-depends' dependencies. + In the stanza library diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.test.hs b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-missing.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [7,9]) + withDirectory "p" $ do + r <- fails $ setup' "configure" ["--cabal-file", "p.cabal.fail-missing"] + assertOutputContains "Missing" r diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.cabal.out b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.cabal.out @@ -0,0 +1,10 @@ +# Setup configure +Resolving dependencies... +Configuring p-0.1.0.0... +Error: + Problem with module re-exports: + - The module 'Private' + is not exported by any suitable package. + It occurs in neither the 'exposed-modules' of this package, + nor any of its 'build-depends' dependencies. + In the stanza library diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.out b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.out @@ -0,0 +1,9 @@ +# Setup configure +Configuring p-0.1.0.0... +Error: + Problem with module re-exports: + - The module 'Private' + is not exported by any suitable package. + It occurs in neither the 'exposed-modules' of this package, + nor any of its 'build-depends' dependencies. + In the stanza library diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.test.hs b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup-fail-other.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [7,9]) + withDirectory "p" $ do + r <- fails $ setup' "configure" ["--cabal-file", "p.cabal.fail-other"] + assertOutputContains "Private" r diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup.cabal.out @@ -0,0 +1,16 @@ +# Setup configure +Resolving dependencies... +Configuring p-0.1.0.0... +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for p-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring q-0.1.0.0... +# Setup build +Preprocessing library for q-0.1.0.0.. +Building library for q-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup.out b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup.out @@ -0,0 +1,14 @@ +# Setup configure +Configuring p-0.1.0.0... +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for p-0.1.0.0.. +# Setup configure +Configuring q-0.1.0.0... +# Setup build +Preprocessing library for q-0.1.0.0.. +Building library for q-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup.test.hs b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/ReexportedModules/setup.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +-- Test that reexported modules build correctly +main = setupAndCabalTest $ do + skipUnless =<< ghcVersionIs (>= mkVersion [7,9]) + withPackageDb $ do + withDirectory "p" $ setup_install ["--cabal-file", "p.cabal"] + withDirectory "q" $ setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T2755/A.hs b/cabal/cabal-testsuite/PackageTests/Regression/T2755/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T2755/A.hs @@ -0,0 +1,1 @@ +module A where diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T2755/Setup.hs b/cabal/cabal-testsuite/PackageTests/Regression/T2755/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T2755/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T2755/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T2755/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T2755/setup.cabal.out @@ -0,0 +1,5 @@ +# Setup configure +Resolving dependencies... +Configuring test-t2755-0.1.0.0... +# Setup test +Package has no buildable test suites. diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T2755/setup.out b/cabal/cabal-testsuite/PackageTests/Regression/T2755/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T2755/setup.out @@ -0,0 +1,4 @@ +# Setup configure +Configuring test-t2755-0.1.0.0... +# Setup test +Package has no test suites. diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T2755/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T2755/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T2755/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + setup "configure" ["--enable-tests"] + setup "test" [] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T2755/test-t2755.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T2755/test-t2755.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T2755/test-t2755.cabal @@ -0,0 +1,13 @@ +name: test-t2755 +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +category: Test +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: A + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T2971/q/q.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T2971/q/q.cabal --- a/cabal/cabal-testsuite/PackageTests/Regression/T2971/q/q.cabal +++ b/cabal/cabal-testsuite/PackageTests/Regression/T2971/q/q.cabal @@ -2,13 +2,15 @@ version: 0.1.0.0 author: Edward Z. Yang maintainer: ezyang@cs.stanford.edu -build-type: Custom +build-type: Simple cabal-version: >=1.10 executable bar main-is: Bar.hs build-depends: base + default-language: Haskell2010 executable foo main-is: Foo.hs build-depends: base, p + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T2971/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T2971/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T2971/setup.cabal.out @@ -0,0 +1,17 @@ +# Setup configure +Resolving dependencies... +Configuring p-0.1.0.0... +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for p-0.1.0.0.. +# Setup configure +Resolving dependencies... +Configuring q-0.1.0.0... +# Setup build +Preprocessing executable 'foo' for q-0.1.0.0.. +Building executable 'foo' for q-0.1.0.0.. +Preprocessing executable 'bar' for q-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T2971/setup.out b/cabal/cabal-testsuite/PackageTests/Regression/T2971/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T2971/setup.out @@ -0,0 +1,15 @@ +# Setup configure +Configuring p-0.1.0.0... +# Setup build +Preprocessing library for p-0.1.0.0.. +Building library for p-0.1.0.0.. +# Setup copy +Installing library in +# Setup register +Registering library for p-0.1.0.0.. +# Setup configure +Configuring q-0.1.0.0... +# Setup build +Preprocessing executable 'foo' for q-0.1.0.0.. +Building executable 'foo' for q-0.1.0.0.. +Preprocessing executable 'bar' for q-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T2971/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T2971/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T2971/setup.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude +-- Test that we don't pick up include-dirs from libraries +-- we didn't actually depend on. +main = setupAndCabalTest $ do + withPackageDb $ do + withDirectory "p" $ setup_install [] + withDirectory "q" $ do + setup "configure" [] + assertOutputContains "T2971test.h" + =<< fails (setup' "build" []) diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T2971a/T2971a.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T2971a/T2971a.cabal --- a/cabal/cabal-testsuite/PackageTests/Regression/T2971a/T2971a.cabal +++ b/cabal/cabal-testsuite/PackageTests/Regression/T2971a/T2971a.cabal @@ -14,3 +14,4 @@ executable exe main-is: Main.hs build-depends: base, T2971a + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T2971a/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T2971a/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T2971a/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Resolving dependencies... +Configuring T2971a-0.1.0.0... +# Setup build +Preprocessing library for T2971a-0.1.0.0.. +Building library for T2971a-0.1.0.0.. +Preprocessing executable 'exe' for T2971a-0.1.0.0.. +Building executable 'exe' for T2971a-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T2971a/setup.out b/cabal/cabal-testsuite/PackageTests/Regression/T2971a/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T2971a/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring T2971a-0.1.0.0... +# Setup build +Preprocessing library for T2971a-0.1.0.0.. +Building library for T2971a-0.1.0.0.. +Preprocessing executable 'exe' for T2971a-0.1.0.0.. +Building executable 'exe' for T2971a-0.1.0.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T2971a/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T2971a/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T2971a/setup.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +-- Test that we pick up include dirs from internal library +main = setupAndCabalTest $ setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3199/Cabal/Cabal.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T3199/Cabal/Cabal.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3199/Cabal/Cabal.cabal @@ -0,0 +1,8 @@ +name: Cabal +version: 2.0.0.0 +build-type: Simple +cabal-version: >= 1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3199/Main.hs b/cabal/cabal-testsuite/PackageTests/Regression/T3199/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3199/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3199/Setup.hs b/cabal/cabal-testsuite/PackageTests/Regression/T3199/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3199/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3199/sandbox.out b/cabal/cabal-testsuite/PackageTests/Regression/T3199/sandbox.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3199/sandbox.out @@ -0,0 +1,8 @@ +# cabal sandbox init +Writing a default package environment file to /sandbox.dist/cabal.sandbox.config +Creating a new sandbox at /sandbox.dist/sandbox +# cabal sandbox add-source +# cabal install +Resolving dependencies... +In order, the following would be installed: +Cabal-2.0.0.0 (new version) diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3199/sandbox.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T3199/sandbox.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3199/sandbox.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + -- 8.0 and up come with sufficiently recent versions of + -- Cabal which don't have this bug. + skipUnless =<< ghcVersionIs (< mkVersion [8,0]) + withSandbox $ do + cabal_sandbox "add-source" ["Cabal"] + cabal "install" + -- Ignore the Cabal library that is under test + ["--package-db=clear", "--package-db=global" + ,"--only-dep", "--dry-run"] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3199/test-3199.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T3199/test-3199.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3199/test-3199.cabal @@ -0,0 +1,27 @@ +name: test-t3199 +version: 0.1.0.0 +license: BSD3 +author: Mikhail Glushenkov +maintainer: mikhail.glushenkov@gmail.com +category: Test +build-type: Custom +cabal-version: >=1.10 + +flag exe_2 + description: Build second exe + default: False + +executable test-3199-1 + main-is: Main.hs + build-depends: base + default-language: Haskell2010 + +executable test-3199-2 + main-is: Main.hs + build-depends: base, ansi-terminal + default-language: Haskell2010 + + if flag(exe_2) + buildable: True + else + buildable: False diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3294/.gitignore b/cabal/cabal-testsuite/PackageTests/Regression/T3294/.gitignore --- a/cabal/cabal-testsuite/PackageTests/Regression/T3294/.gitignore +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3294/.gitignore @@ -1,1 +1,1 @@ -*.hs +Main.hs diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3294/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T3294/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3294/setup.cabal.out @@ -0,0 +1,13 @@ +# Setup configure +Resolving dependencies... +Configuring T3294-0.1.0.0... +# Setup build +Preprocessing executable 'T3294' for T3294-0.1.0.0.. +Building executable 'T3294' for T3294-0.1.0.0.. +# T3294 +aaa +# Setup build +Preprocessing executable 'T3294' for T3294-0.1.0.0.. +Building executable 'T3294' for T3294-0.1.0.0.. +# T3294 +bbb diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3294/setup.out b/cabal/cabal-testsuite/PackageTests/Regression/T3294/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3294/setup.out @@ -0,0 +1,12 @@ +# Setup configure +Configuring T3294-0.1.0.0... +# Setup build +Preprocessing executable 'T3294' for T3294-0.1.0.0.. +Building executable 'T3294' for T3294-0.1.0.0.. +# T3294 +aaa +# Setup build +Preprocessing executable 'T3294' for T3294-0.1.0.0.. +Building executable 'T3294' for T3294-0.1.0.0.. +# T3294 +bbb diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3294/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T3294/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3294/setup.test.hs @@ -0,0 +1,14 @@ +import Test.Cabal.Prelude +import Control.Monad.IO.Class +-- Test that executable recompilation works +-- https://github.com/haskell/setup/issues/3294 +main = setupAndCabalTest $ do + withSourceCopy . withDelay $ do + writeSourceFile "Main.hs" "main = putStrLn \"aaa\"" + setup "configure" [] + setup "build" [] + runExe' "T3294" [] >>= assertOutputContains "aaa" + delay + writeSourceFile "Main.hs" "main = putStrLn \"bbb\"" + setup "build" [] + runExe' "T3294" [] >>= assertOutputContains "bbb" diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3436/Cabal-1.2/Cabal.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T3436/Cabal-1.2/Cabal.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3436/Cabal-1.2/Cabal.cabal @@ -0,0 +1,8 @@ +name: Cabal +version: 1.2 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base + exposed-modules: CabalMessage diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3436/Cabal-1.2/CabalMessage.hs b/cabal/cabal-testsuite/PackageTests/Regression/T3436/Cabal-1.2/CabalMessage.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3436/Cabal-1.2/CabalMessage.hs @@ -0,0 +1,3 @@ +module CabalMessage where + +message = "This is Cabal-1.2" diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3436/Cabal-2.0/Cabal.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T3436/Cabal-2.0/Cabal.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3436/Cabal-2.0/Cabal.cabal @@ -0,0 +1,8 @@ +name: Cabal +version: 2.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base + exposed-modules: CabalMessage diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3436/Cabal-2.0/CabalMessage.hs b/cabal/cabal-testsuite/PackageTests/Regression/T3436/Cabal-2.0/CabalMessage.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3436/Cabal-2.0/CabalMessage.hs @@ -0,0 +1,3 @@ +module CabalMessage where + +message = "This is Cabal-2.0" diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3436/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T3436/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3436/cabal.out @@ -0,0 +1,9 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - Cabal-2.0 (lib:Cabal) (first run) + - custom-setup-1.0 (lib:custom-setup) (first run) +Configuring Cabal-2.0... +Preprocessing library for Cabal-2.0.. +Building library for Cabal-2.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3436/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T3436/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3436/cabal.project @@ -0,0 +1,1 @@ +packages: custom-setup Cabal-2.0 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3436/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T3436/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3436/cabal.test.hs @@ -0,0 +1,8 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + -- NB: This test doesn't really test #3436, because Cabal-1.2 + -- isn't in the system database and thus we can't see if the + -- depsolver incorrectly chooses it. Worth fixing if we figure + -- out how to simulate the "global" database without root. + r <- fails $ cabal' "new-build" ["custom-setup"] + assertOutputContains "This is Cabal-2.0" r diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3436/custom-setup/Setup.hs b/cabal/cabal-testsuite/PackageTests/Regression/T3436/custom-setup/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3436/custom-setup/Setup.hs @@ -0,0 +1,5 @@ +import CabalMessage (message) +import System.Exit +import System.IO + +main = hPutStrLn stderr message >> exitFailure diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3436/custom-setup/custom-setup.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T3436/custom-setup/custom-setup.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3436/custom-setup/custom-setup.cabal @@ -0,0 +1,9 @@ +cabal-version: 2.0 +name: custom-setup +version: 1.0 +build-type: Custom + +custom-setup + setup-depends: base, Cabal >= 2.0 + +library diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3436/sandbox.out b/cabal/cabal-testsuite/PackageTests/Regression/T3436/sandbox.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3436/sandbox.out @@ -0,0 +1,22 @@ +# cabal sandbox init +Writing a default package environment file to /sandbox.dist/cabal.sandbox.config +Creating a new sandbox at /sandbox.dist/sandbox +# cabal install +Resolving dependencies... +Configuring Cabal-1.2... +Preprocessing library for Cabal-1.2.. +Building library for Cabal-1.2.. +Installing library in +Installed Cabal-1.2 +# cabal sandbox add-source +# cabal install +Resolving dependencies... +Configuring Cabal-2.0... +Preprocessing library for Cabal-2.0.. +Building library for Cabal-2.0.. +Installing library in +Installed Cabal-2.0 +Failed to install custom-setup-1.0 +cabal: Error: some packages failed to install: +custom-setup-1.0-92JpsxIMpiQHysxYdDtEVq failed during the configure step. The exception was: + ExitFailure 1 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3436/sandbox.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T3436/sandbox.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3436/sandbox.test.hs @@ -0,0 +1,21 @@ +import Test.Cabal.Prelude + +-- Regression test for issue #3436 +-- +-- #3436 occurred when a package with a custom setup specified a 'cabal-version' +-- that was newer than the version of the installed Cabal library, even though +-- the solver didn't choose the installed Cabal for the package's setup script. +-- +-- This test installs a fake Cabal-1.2 and then tries to build the package +-- custom-setup, which depends on a fake Cabal-2.0 (through cabal-version and +-- setup-depends). +main = cabalTest $ do + withSandbox $ do + cabal "install" ["./Cabal-1.2"] + cabal_sandbox "add-source" ["Cabal-2.0"] + + -- cabal should build custom-setup's setup script with Cabal-2.0, but + -- then configure should fail because Setup just prints an error message + -- imported from Cabal and exits. + r <- fails $ cabal' "install" ["custom-setup/"] + assertOutputContains "This is Cabal-2.0" r diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3847/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T3847/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3847/setup.cabal.out @@ -0,0 +1,4 @@ +# Setup configure +Resolving dependencies... +Configuring T3847-1.0... +Warning: Unknown extensions: ThisDoesNotExist diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3847/setup.out b/cabal/cabal-testsuite/PackageTests/Regression/T3847/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3847/setup.out @@ -0,0 +1,3 @@ +# Setup configure +Configuring T3847-1.0... +Warning: Unknown extensions: ThisDoesNotExist diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3847/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T3847/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3847/setup.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude +-- Test that other-extensions of disabled component do not +-- effect configure step. +main = setupAndCabalTest $ setup "configure" ["--disable-tests"] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3932/Setup.hs b/cabal/cabal-testsuite/PackageTests/Regression/T3932/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3932/Setup.hs @@ -0,0 +1,5 @@ +import CabalMessage (message) +import System.Exit +import System.IO + +main = hPutStrLn stderr message >> exitFailure diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3932/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T3932/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3932/cabal.out @@ -0,0 +1,2 @@ +# cabal update +Downloading the latest package list from test-local-repo diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3932/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T3932/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3932/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3932/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T3932/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3932/cabal.test.hs @@ -0,0 +1,12 @@ +import Test.Cabal.Prelude +main = cabalTest $ + -- This repository contains a Cabal-1.18.0.0 option, which would + -- normally would satisfy the repository, except for new-build's + -- extra constraint that setup Cabal must be 1.20. If we don't + -- have a choice like this available, the unsatisfied constraint + -- won't be reported. + withRepo "repo" $ do + -- Don't record because output wobbles based on installed database. + recordMode DoNotRecord $ do + fails (cabal' "new-build" []) >>= + assertOutputContains "Setup.hs requires >=1.20" diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3932/custom-setup-old-cabal.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T3932/custom-setup-old-cabal.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3932/custom-setup-old-cabal.cabal @@ -0,0 +1,8 @@ +name: custom-setup +version: 1.0 +build-type: Custom + +custom-setup + setup-depends: base, Cabal < 1.20 + +library diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T3932/repo/Cabal-1.18.0.0/Cabal.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T3932/repo/Cabal-1.18.0.0/Cabal.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T3932/repo/Cabal-1.18.0.0/Cabal.cabal @@ -0,0 +1,6 @@ +name: Cabal +version: 1.18.0.0 +build-type: Simple +cabal-version: >= 1.10 + +library diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4025/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T4025/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4025/setup.cabal.out @@ -0,0 +1,9 @@ +# Setup configure +Resolving dependencies... +Configuring T4025-1.0... +Warning: Packages using 'cabal-version: >= 1.10' must specify the 'default-language' field for each component (e.g. Haskell98 or Haskell2010). If a component uses different languages in different modules then list the other ones in the 'other-languages' field. +# Setup build +Preprocessing library for T4025-1.0.. +Building library for T4025-1.0.. +Preprocessing executable 'exe' for T4025-1.0.. +Building executable 'exe' for T4025-1.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4025/setup.out b/cabal/cabal-testsuite/PackageTests/Regression/T4025/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4025/setup.out @@ -0,0 +1,8 @@ +# Setup configure +Configuring T4025-1.0... +Warning: Packages using 'cabal-version: >= 1.10' must specify the 'default-language' field for each component (e.g. Haskell98 or Haskell2010). If a component uses different languages in different modules then list the other ones in the 'other-languages' field. +# Setup build +Preprocessing library for T4025-1.0.. +Building library for T4025-1.0.. +Preprocessing executable 'exe' for T4025-1.0.. +Building executable 'exe' for T4025-1.0.. diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4025/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T4025/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4025/setup.test.hs @@ -0,0 +1,13 @@ +import Test.Cabal.Prelude +-- Test that we don't accidentally add the inplace directory to +-- an executable RPATH. Don't test on Windows, which doesn't +-- support RPATH. +main = setupAndCabalTest $ do + skipIf =<< isWindows + setup "configure" ["--enable-executable-dynamic"] + setup "build" [] + -- This should fail as it we should NOT be able to find the + -- dynamic library for the internal library (since we didn't + -- install it). If we incorrectly encoded our local dist + -- dir in the RPATH, this will succeed. + recordMode DoNotRecord . fails $ runExe "exe" [] diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4154/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T4154/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4154/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4154/install-time-with-constraint.out b/cabal/cabal-testsuite/PackageTests/Regression/T4154/install-time-with-constraint.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4154/install-time-with-constraint.out @@ -0,0 +1,8 @@ +# cabal update +Downloading the latest package list from test-local-repo +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following would be built: + - Cabal-99999 (lib) (requires download & build) + - time-99999 (lib:time) (first run) diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4154/install-time-with-constraint.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T4154/install-time-with-constraint.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4154/install-time-with-constraint.test.hs @@ -0,0 +1,15 @@ +import Test.Cabal.Prelude + +-- Test that unqualified command line constraints do not constrain setup +-- dependencies. cabal should be able to install the local time-99999 by +-- building its setup script with the installed time, even though the installed +-- time doesn't fit the constraint. +main = cabalTest $ withRepo "repo" $ do + cabal "new-build" ["time", "--constraint=time==99999", "--dry-run"] + + -- Temporarily disabled recording here because output is not stable + recordMode DoNotRecord $ do + -- Constraining all uses of 'time' results in a cyclic dependency + -- between 'Cabal' and the new 'time'. + r <- fails $ cabal' "new-build" ["time", "--constraint=any.time==99999", "--dry-run"] + assertOutputContains "cyclic dependencies; conflict set: time:setup.Cabal, time:setup.time" r diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4154/repo/Cabal-99999/Cabal.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T4154/repo/Cabal-99999/Cabal.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4154/repo/Cabal-99999/Cabal.cabal @@ -0,0 +1,7 @@ +name: Cabal +version: 99999 +cabal-version: >=1.8 +build-type: Simple + +library + build-depends: base, time diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4154/time.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T4154/time.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4154/time.cabal @@ -0,0 +1,10 @@ +name: time +version: 99999 +cabal-version: >=1.8 +build-type: Custom + +custom-setup + setup-depends: base, Cabal == 99999 + +library + build-depends: base diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4202/.gitignore b/cabal/cabal-testsuite/PackageTests/Regression/T4202/.gitignore new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4202/.gitignore @@ -0,0 +1,1 @@ +p/P.hs diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4202/cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T4202/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4202/cabal.out @@ -0,0 +1,26 @@ +# cabal new-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - p-1.0 (lib) (first run) + - q-1.0 (exe:qexe) (first run) +Configuring library for p-1.0.. +Preprocessing library for p-1.0.. +Building library for p-1.0.. +Configuring executable 'qexe' for q-1.0.. +Preprocessing executable 'qexe' for q-1.0.. +Building executable 'qexe' for q-1.0.. +# cabal new-build +Build profile: -w ghc- -O1 +In order, the following will be built: + - p-1.0 (lib) (file P.hs changed) +Preprocessing library for p-1.0.. +Building library for p-1.0.. +# cabal new-build +Build profile: -w ghc- -O1 +In order, the following will be built: + - q-1.0 (exe:qexe) (file /cabal.dist/work/dist/build//ghc-/p-1.0/cache/build changed) +Preprocessing executable 'qexe' for q-1.0.. +Building executable 'qexe' for q-1.0.. +# q qexe +BBB diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4202/cabal.project b/cabal/cabal-testsuite/PackageTests/Regression/T4202/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4202/cabal.project @@ -0,0 +1,1 @@ +packages: p q diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4202/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T4202/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4202/cabal.test.hs @@ -0,0 +1,12 @@ +import Test.Cabal.Prelude +main = cabalTest $ + withSourceCopy . withDelay $ do + writeSourceFile ("p/P.hs") "module P where\np = \"AAA\"" + cabal "new-build" ["p","q"] + delay + writeSourceFile ("p/P.hs") "module P where\np = \"BBB\"" + cabal "new-build" ["p"] + cabal "new-build" ["q"] + withPlan $ + runPlanExe' "q" "qexe" [] + >>= assertOutputContains "BBB" diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4202/p/p.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T4202/p/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4202/p/p.cabal @@ -0,0 +1,9 @@ +name: p +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: P + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4202/q/Q.hs b/cabal/cabal-testsuite/PackageTests/Regression/T4202/q/Q.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4202/q/Q.hs @@ -0,0 +1,2 @@ +import P +main = putStrLn p diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4202/q/q.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T4202/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4202/q/q.cabal @@ -0,0 +1,9 @@ +name: q +version: 1.0 +build-type: Simple +cabal-version: >= 1.10 + +executable qexe + main-is: Q.hs + build-depends: base, p + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4270/Lib.hs b/cabal/cabal-testsuite/PackageTests/Regression/T4270/Lib.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4270/Lib.hs @@ -0,0 +1,4 @@ +module Lib where + +foo :: Bool +foo = True diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4270/T4270.cabal b/cabal/cabal-testsuite/PackageTests/Regression/T4270/T4270.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4270/T4270.cabal @@ -0,0 +1,20 @@ +name: T4270 +version: 0.1 +cabal-version: >= 1.2 +license: BSD3 +author: Benno Fünfstück +stability: stable +category: PackageTests +build-type: Simple +cabal-version: >= 1.9.2 + +description: Check type detailed-0.9 test suites with dynamic linking. + +library + exposed-modules: Lib + build-depends: base + +test-suite test + type: detailed-0.9 + test-module: Test + build-depends: base, Cabal, T4270 diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4270/Test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T4270/Test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4270/Test.hs @@ -0,0 +1,17 @@ +module Test where + +import Lib + +import Distribution.TestSuite + +tests :: IO [Test] +tests = return [Test bar] + where + bar = TestInstance + { run = return $ Finished run + , name = "test" + , tags = [] + , options = [] + , setOption = \_ _ -> Right bar + } + run = if foo then Pass else Fail "should pass" diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4270/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/Regression/T4270/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4270/setup.cabal.out @@ -0,0 +1,18 @@ +# Setup configure +Resolving dependencies... +Configuring T4270-0.1... +# Setup build +Preprocessing library for T4270-0.1.. +Building library for T4270-0.1.. +Preprocessing test suite 'test' for T4270-0.1.. +Building test suite 'test' for T4270-0.1.. +# Setup test +Preprocessing library for T4270-0.1.. +Building library for T4270-0.1.. +Preprocessing test suite 'test' for T4270-0.1.. +Building test suite 'test' for T4270-0.1.. +Running 1 test suites... +Test suite test: RUNNING... +Test suite test: PASS +Test suite logged to: setup.cabal.dist/work/dist/test/T4270-0.1-test.log +1 of 1 test suites (1 of 1 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4270/setup.out b/cabal/cabal-testsuite/PackageTests/Regression/T4270/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4270/setup.out @@ -0,0 +1,13 @@ +# Setup configure +Configuring T4270-0.1... +# Setup build +Preprocessing library for T4270-0.1.. +Building library for T4270-0.1.. +Preprocessing test suite 'test' for T4270-0.1.. +Building test suite 'test' for T4270-0.1.. +# Setup test +Running 1 test suites... +Test suite test: RUNNING... +Test suite test: PASS +Test suite logged to: setup.dist/work/dist/test/T4270-0.1-test.log +1 of 1 test suites (1 of 1 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/Regression/T4270/setup.test.hs b/cabal/cabal-testsuite/PackageTests/Regression/T4270/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Regression/T4270/setup.test.hs @@ -0,0 +1,10 @@ +import Test.Cabal.Prelude +-- Test if detailed-0.9 builds correctly and runs +-- when linked dynamically +-- See https://github.com/haskell/cabal/issues/4270 +main = setupAndCabalTest $ do + skipUnless =<< hasSharedLibraries + skipUnless =<< hasCabalShared + skipUnless =<< hasCabalForGhc + setup_build ["--enable-tests", "--enable-executable-dynamic"] + setup "test" [] diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/cabal.out b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/cabal.out @@ -0,0 +1,12 @@ +# cabal sandbox init +Writing a default package environment file to /cabal.dist/cabal.sandbox.config +Creating a new sandbox at /cabal.dist/sandbox +# cabal sandbox add-source +# cabal sandbox add-source +# cabal install +Resolving dependencies... +Configuring q-0.1.0.0... +Preprocessing library for q-0.1.0.0.. +Building library for q-0.1.0.0.. +Installing library in +Installed q-0.1.0.0 diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/cabal.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withSandbox $ do + cabal_sandbox "add-source" ["p"] + cabal_sandbox "add-source" ["q"] + cabal "install" ["q"] diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/p/LICENSE b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/p/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/p/LICENSE diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/p/Setup.hs b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/p/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/p/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/p/p.cabal b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/p/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/p/p.cabal @@ -0,0 +1,11 @@ +name: p +version: 0.1.0.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/q/LICENSE b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/q/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/q/LICENSE diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/q/Setup.hs b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/q/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/q/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/q/q.cabal b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/MultipleSources/q/q.cabal @@ -0,0 +1,11 @@ +name: q +version: 0.1.0.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/p/Main.hs b/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/p/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/p/Main.hs @@ -0,0 +1,4 @@ +import Q (message) + +main :: IO () +main = putStrLn message diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/p/p.cabal b/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/p/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/p/p.cabal @@ -0,0 +1,8 @@ +name: p +version: 1.0 +build-type: Simple +cabal-version: >= 1.2 + +executable p + main-is: Main.hs + build-depends: q, base diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/q/Q.hs b/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/q/Q.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/q/Q.hs @@ -0,0 +1,4 @@ +module Q where + +message :: String +message = "message" diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/q/Q.hs.in2 b/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/q/Q.hs.in2 new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/q/Q.hs.in2 @@ -0,0 +1,4 @@ +module Q where + +message :: String +message = "message updated" diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/q/q.cabal b/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/q/q.cabal @@ -0,0 +1,8 @@ +name: q +version: 1.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base + exposed-modules: Q diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/sandbox.out b/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/sandbox.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/sandbox.out @@ -0,0 +1,17 @@ +# cabal sandbox init +Writing a default package environment file to /sandbox.dist/cabal.sandbox.config +Creating a new sandbox at /sandbox.dist/sandbox +# cabal sandbox add-source +# cabal install +Resolving dependencies... +Configuring q-1.0... +Preprocessing library for q-1.0.. +Building library for q-1.0.. +Installing library in +Installed q-1.0 +# cabal run +message +# cabal run +In order, the following will be installed: +q-1.0 (reinstall) +message updated diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/sandbox.test.hs b/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/sandbox.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Reinstall/sandbox.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withSourceCopy . withDelay . withDirectory "p" . withSandbox $ do + cabal_sandbox "add-source" ["../q"] + cabal "install" ["--only-dependencies"] + recordMode RecordAll $ cabal "run" ["p", "-v0"] + delay + copySourceFileTo "../q/Q.hs.in2" "../q/Q.hs" + recordMode RecordAll $ cabal "run" ["p", "-v0"] diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/p/LICENSE b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/p/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/p/LICENSE diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/p/Setup.hs b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/p/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/p/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/p/p.cabal b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/p/p.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/p/p.cabal @@ -0,0 +1,11 @@ +name: p +version: 0.1.0.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/q/LICENSE b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/q/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/q/LICENSE diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/q/Setup.hs b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/q/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/q/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/q/q.cabal b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/q/q.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/q/q.cabal @@ -0,0 +1,11 @@ +name: q +version: 0.1.0.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/sandbox.out b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/sandbox.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/sandbox.out @@ -0,0 +1,15 @@ +# cabal sandbox init +Writing a default package environment file to /sandbox.dist/cabal.sandbox.config +Creating a new sandbox at /sandbox.dist/sandbox +# cabal sandbox add-source +# cabal sandbox delete-source +Warning: Sources not registered: "q" + +cabal: The sources with the above errors were skipped. ("q") +# cabal sandbox add-source +# cabal sandbox delete-source +Success deleting sources: "p" "q" + +Note: 'sandbox delete-source' only unregisters the source dependency, but does not remove the package from the sandbox package DB. + +Use 'sandbox hc-pkg -- unregister' to do that. diff --git a/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/sandbox.test.hs b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/sandbox.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/Sandbox/Sources/sandbox.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + withSandbox $ do + cabal_sandbox "add-source" ["p"] + fails $ cabal_sandbox "delete-source" ["q"] + cabal_sandbox "add-source" ["q"] + cabal_sandbox "delete-source" ["p", "q"] diff --git a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Resolving dependencies... +Configuring templateHaskell-0.1... +# Setup build +Preprocessing executable 'main' for templateHaskell-0.1.. +Building executable 'main' for templateHaskell-0.1.. +Preprocessing library for templateHaskell-0.1.. +Building library for templateHaskell-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.out b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring templateHaskell-0.1... +# Setup build +Preprocessing executable 'main' for templateHaskell-0.1.. +Building executable 'main' for templateHaskell-0.1.. +Preprocessing library for templateHaskell-0.1.. +Building library for templateHaskell-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.test.hs b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/dynamic/setup.test.hs @@ -0,0 +1,6 @@ +import Test.Cabal.Prelude +-- Test building a dynamic library/executable which uses Template +-- Haskell +main = setupAndCabalTest $ do + skipUnless =<< hasSharedLibraries + setup_build ["--enable-shared", "--enable-executable-dynamic"] diff --git a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Resolving dependencies... +Configuring templateHaskell-0.1... +# Setup build +Preprocessing executable 'main' for templateHaskell-0.1.. +Building executable 'main' for templateHaskell-0.1.. +Preprocessing library for templateHaskell-0.1.. +Building library for templateHaskell-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.out b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring templateHaskell-0.1... +# Setup build +Preprocessing executable 'main' for templateHaskell-0.1.. +Building executable 'main' for templateHaskell-0.1.. +Preprocessing library for templateHaskell-0.1.. +Building library for templateHaskell-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.test.hs b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/profiling/setup.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude +-- Test building a profiled library/executable which uses Template Haskell +-- (setup has to build the non-profiled version first) +main = setupAndCabalTest $ do + skipUnless =<< hasProfiledLibraries + setup_build ["--enable-library-profiling", + "--enable-profiling"] diff --git a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Resolving dependencies... +Configuring templateHaskell-0.1... +# Setup build +Preprocessing executable 'main' for templateHaskell-0.1.. +Building executable 'main' for templateHaskell-0.1.. +Preprocessing library for templateHaskell-0.1.. +Building library for templateHaskell-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/setup.out b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring templateHaskell-0.1... +# Setup build +Preprocessing executable 'main' for templateHaskell-0.1.. +Building executable 'main' for templateHaskell-0.1.. +Preprocessing library for templateHaskell-0.1.. +Building library for templateHaskell-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/setup.test.hs b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TemplateHaskell/vanilla/setup.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +-- Test building a vanilla library/executable which uses Template Haskell +main = setupAndCabalTest $ setup_build [] diff --git a/cabal/cabal-testsuite/PackageTests/TestNameCollision/child/child.cabal b/cabal/cabal-testsuite/PackageTests/TestNameCollision/child/child.cabal --- a/cabal/cabal-testsuite/PackageTests/TestNameCollision/child/child.cabal +++ b/cabal/cabal-testsuite/PackageTests/TestNameCollision/child/child.cabal @@ -17,3 +17,4 @@ test-module: Test hs-source-dirs: tests build-depends: base, Cabal, child + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/TestNameCollision/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/TestNameCollision/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestNameCollision/setup.cabal.out @@ -0,0 +1,28 @@ +# Setup configure +Resolving dependencies... +Configuring parent-0.1... +# Setup build +Preprocessing library for parent-0.1.. +Building library for parent-0.1.. +# Setup copy +Installing library in +# Setup register +Registering library for parent-0.1.. +# Setup configure +Resolving dependencies... +Configuring child-0.1... +# Setup build +Preprocessing library for child-0.1.. +Building library for child-0.1.. +Preprocessing test suite 'parent' for child-0.1.. +Building test suite 'parent' for child-0.1.. +# Setup test +Preprocessing library for child-0.1.. +Building library for child-0.1.. +Preprocessing test suite 'parent' for child-0.1.. +Building test suite 'parent' for child-0.1.. +Running 1 test suites... +Test suite parent: RUNNING... +Test suite parent: PASS +Test suite logged to: ../setup.cabal.dist/work/child/dist/test/child-0.1-parent.log +1 of 1 test suites (1 of 1 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/TestNameCollision/setup.out b/cabal/cabal-testsuite/PackageTests/TestNameCollision/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestNameCollision/setup.out @@ -0,0 +1,22 @@ +# Setup configure +Configuring parent-0.1... +# Setup build +Preprocessing library for parent-0.1.. +Building library for parent-0.1.. +# Setup copy +Installing library in +# Setup register +Registering library for parent-0.1.. +# Setup configure +Configuring child-0.1... +# Setup build +Preprocessing library for child-0.1.. +Building library for child-0.1.. +Preprocessing test suite 'parent' for child-0.1.. +Building test suite 'parent' for child-0.1.. +# Setup test +Running 1 test suites... +Test suite parent: RUNNING... +Test suite parent: PASS +Test suite logged to: ../setup.dist/work/child/dist/test/child-0.1-parent.log +1 of 1 test suites (1 of 1 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/TestNameCollision/setup.test.hs b/cabal/cabal-testsuite/PackageTests/TestNameCollision/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestNameCollision/setup.test.hs @@ -0,0 +1,11 @@ +import Test.Cabal.Prelude +-- Test that if test suite has a name which conflicts with a package +-- which is in the database, we can still use the test case (they +-- should NOT shadow). +main = setupAndCabalTest $ do + skipUnless =<< hasCabalForGhc -- use of library test suite + withPackageDb $ do + withDirectory "parent" $ setup_install [] + withDirectory "child" $ do + setup_build ["--enable-tests"] + setup "test" [] diff --git a/cabal/cabal-testsuite/PackageTests/TestOptions/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/TestOptions/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestOptions/setup.cabal.out @@ -0,0 +1,24 @@ +# Setup configure +Resolving dependencies... +Configuring TestOptions-0.1... +# Setup build +Preprocessing test suite 'test-TestOptions' for TestOptions-0.1.. +Building test suite 'test-TestOptions' for TestOptions-0.1.. +Preprocessing executable 'dummy' for TestOptions-0.1.. +Building executable 'dummy' for TestOptions-0.1.. +# Setup test +Preprocessing test suite 'test-TestOptions' for TestOptions-0.1.. +Building test suite 'test-TestOptions' for TestOptions-0.1.. +Running 1 test suites... +Test suite test-TestOptions: RUNNING... +Test suite test-TestOptions: PASS +Test suite logged to: setup.cabal.dist/work/dist/test/TestOptions-0.1-test-TestOptions.log +1 of 1 test suites (1 of 1 test cases) passed. +# Setup test +Preprocessing test suite 'test-TestOptions' for TestOptions-0.1.. +Building test suite 'test-TestOptions' for TestOptions-0.1.. +Running 1 test suites... +Test suite test-TestOptions: RUNNING... +Test suite test-TestOptions: PASS +Test suite logged to: setup.cabal.dist/work/dist/test/TestOptions-0.1-test-TestOptions.log +1 of 1 test suites (1 of 1 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/TestOptions/setup.out b/cabal/cabal-testsuite/PackageTests/TestOptions/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestOptions/setup.out @@ -0,0 +1,19 @@ +# Setup configure +Configuring TestOptions-0.1... +# Setup build +Preprocessing test suite 'test-TestOptions' for TestOptions-0.1.. +Building test suite 'test-TestOptions' for TestOptions-0.1.. +Preprocessing executable 'dummy' for TestOptions-0.1.. +Building executable 'dummy' for TestOptions-0.1.. +# Setup test +Running 1 test suites... +Test suite test-TestOptions: RUNNING... +Test suite test-TestOptions: PASS +Test suite logged to: setup.dist/work/dist/test/TestOptions-0.1-test-TestOptions.log +1 of 1 test suites (1 of 1 test cases) passed. +# Setup test +Running 1 test suites... +Test suite test-TestOptions: RUNNING... +Test suite test-TestOptions: PASS +Test suite logged to: setup.dist/work/dist/test/TestOptions-0.1-test-TestOptions.log +1 of 1 test suites (1 of 1 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/TestOptions/setup.test.hs b/cabal/cabal-testsuite/PackageTests/TestOptions/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestOptions/setup.test.hs @@ -0,0 +1,9 @@ +import Test.Cabal.Prelude +-- Test --test-option(s) flags on ./Setup test +main = setupAndCabalTest $ do + setup_build ["--enable-tests"] + setup "test" ["--test-options=1 2 3"] + setup "test" [ "--test-option=1" + , "--test-option=2" + , "--test-option=3" + ] diff --git a/cabal/cabal-testsuite/PackageTests/TestStanza/Check.hs b/cabal/cabal-testsuite/PackageTests/TestStanza/Check.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/TestStanza/Check.hs +++ /dev/null @@ -1,28 +0,0 @@ -module PackageTests.TestStanza.Check where - -import PackageTests.PackageTester - -import Distribution.Version -import Distribution.Simple.LocalBuildInfo -import Distribution.Package -import Distribution.PackageDescription - -suite :: TestM () -suite = do - assertOutputDoesNotContain "unknown section type" - =<< cabal' "configure" [] - dist_dir <- distDir - lbi <- liftIO $ getPersistBuildConfig dist_dir - let anticipatedTestSuite = emptyTestSuite - { testName = mkUnqualComponentName "dummy" - , testInterface = TestSuiteExeV10 (mkVersion [1,0]) "dummy.hs" - , testBuildInfo = emptyBuildInfo - { targetBuildDepends = - [ Dependency (mkPackageName "base") anyVersion ] - , hsSourceDirs = ["."] - } - } - gotTestSuite = head $ testSuites (localPkgDescr lbi) - assertEqual "parsed test-suite stanza does not match anticipated" - anticipatedTestSuite gotTestSuite - return () diff --git a/cabal/cabal-testsuite/PackageTests/TestStanza/my.cabal b/cabal/cabal-testsuite/PackageTests/TestStanza/my.cabal --- a/cabal/cabal-testsuite/PackageTests/TestStanza/my.cabal +++ b/cabal/cabal-testsuite/PackageTests/TestStanza/my.cabal @@ -5,6 +5,7 @@ stability: stable category: PackageTests build-type: Simple +cabal-version: >= 1.10 description: Check that Cabal recognizes the Test stanza defined below. @@ -12,8 +13,10 @@ Library exposed-modules: MyLibrary build-depends: base + default-language: Haskell2010 test-suite dummy main-is: dummy.hs type: exitcode-stdio-1.0 build-depends: base + default-language: Haskell2010 diff --git a/cabal/cabal-testsuite/PackageTests/TestStanza/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/TestStanza/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestStanza/setup.cabal.out @@ -0,0 +1,3 @@ +# Setup configure +Resolving dependencies... +Configuring TestStanza-0.1... diff --git a/cabal/cabal-testsuite/PackageTests/TestStanza/setup.out b/cabal/cabal-testsuite/PackageTests/TestStanza/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestStanza/setup.out @@ -0,0 +1,2 @@ +# Setup configure +Configuring TestStanza-0.1... diff --git a/cabal/cabal-testsuite/PackageTests/TestStanza/setup.test.hs b/cabal/cabal-testsuite/PackageTests/TestStanza/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestStanza/setup.test.hs @@ -0,0 +1,23 @@ +import Test.Cabal.Prelude + +import Distribution.Version +import Distribution.Simple.LocalBuildInfo +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Types.UnqualComponentName +import Control.Monad.IO.Class +import Distribution.Simple.Configure + +main = setupAndCabalTest $ do + assertOutputDoesNotContain "unknown section type" + =<< setup' "configure" ["--enable-tests"] + lbi <- getLocalBuildInfoM + let gotTestSuite = head $ testSuites (localPkgDescr lbi) + assertEqual "testName" (mkUnqualComponentName "dummy") + (testName gotTestSuite) + assertEqual "testInterface" (TestSuiteExeV10 (mkVersion [1,0]) "dummy.hs") + (testInterface gotTestSuite) + -- NB: Not testing targetBuildDepends (testBuildInfo gotTestSuite) + -- as dependency varies with cabal-install + assertEqual "testBuildInfo/hsSourceDirs" ["."] (hsSourceDirs (testBuildInfo gotTestSuite)) + return () diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/Check.hs b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/Check.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/Check.hs +++ /dev/null @@ -1,129 +0,0 @@ -module PackageTests.TestSuiteTests.ExeV10.Check (tests) where - -import qualified Control.Exception as E (IOException, catch) -import Control.Monad (forM_, liftM4, when) -import Data.Maybe (catMaybes) -import System.FilePath -import Test.Tasty.HUnit (testCase) - -import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) -import Distribution.Simple.Compiler (compilerId) -import Distribution.Types.LocalBuildInfo (localPackage) -import Distribution.Simple.LocalBuildInfo (compiler, localCompatPackageKey) -import Distribution.Simple.Hpc -import Distribution.Simple.Program.Builtin (hpcProgram) -import Distribution.Simple.Program.Db - ( emptyProgramDb, configureProgram, requireProgramVersion ) -import Distribution.Text (display) -import qualified Distribution.Verbosity as Verbosity -import Distribution.Version (mkVersion, orLaterVersion) - -import PackageTests.PackageTester - -tests :: SuiteConfig -> TestTreeM () -tests config = do - -- TODO: hierarchy and subnaming is a little unfortunate - tc "Test" "Default" $ do - cabal_build ["--enable-tests"] - -- This one runs both tests, including the very LONG Foo - -- test which prints a lot of output - cabal "test" ["--show-details=direct"] - groupTests "WithHpc" $ hpcTestMatrix config - groupTests "WithoutHpc" $ do - -- Ensures that even if -fhpc is manually provided no .tix file is output. - tc "NoTix" "NoHpcNoTix" $ do - dist_dir <- distDir - cabal_build - [ "--enable-tests" - , "--ghc-option=-fhpc" - , "--ghc-option=-hpcdir" - , "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" ] - cabal "test" ["test-Short", "--show-details=direct"] - lbi <- liftIO $ getPersistBuildConfig dist_dir - let way = guessWay lbi - shouldNotExist $ tixFilePath dist_dir way "test-Short" - -- Ensures that even if a .tix file happens to be left around - -- markup isn't generated. - tc "NoMarkup" "NoHpcNoMarkup" $ do - dist_dir <- distDir - let tixFile = tixFilePath dist_dir Vanilla "test-Short" - withEnv [("HPCTIXFILE", Just tixFile)] $ do - cabal_build - [ "--enable-tests" - , "--ghc-option=-fhpc" - , "--ghc-option=-hpcdir" - , "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" ] - cabal "test" ["test-Short", "--show-details=direct"] - shouldNotExist $ htmlDir dist_dir Vanilla "test-Short" "hpc_index.html" - where - tc :: String -> String -> TestM a -> TestTreeM () - tc name subname m - = testTree' $ testCase name - (runTestM config "TestSuiteTests/ExeV10" (Just subname) m) - -hpcTestMatrix :: SuiteConfig -> TestTreeM () -hpcTestMatrix config = forM_ (choose4 [True, False]) $ - \(libProf, exeProf, exeDyn, shared) -> do - let name | null suffixes = "Vanilla" - | otherwise = intercalate "-" suffixes - where - suffixes = catMaybes - [ if libProf then Just "LibProf" else Nothing - , if exeProf then Just "ExeProf" else Nothing - , if exeDyn then Just "ExeDyn" else Nothing - , if shared then Just "Shared" else Nothing - ] - opts = catMaybes - [ enable libProf "library-profiling" - , enable exeProf "profiling" - , enable exeDyn "executable-dynamic" - , enable shared "shared" - ] - where - enable cond flag - | cond = Just $ "--enable-" ++ flag - | otherwise = Nothing - -- Ensure that both .tix file and markup are generated if coverage - -- is enabled. - testUnless ((exeDyn || shared) && not (hasSharedLibraries config)) $ - tc name ("WithHpc-" ++ name) $ do - isCorrectVersion <- liftIO $ correctHpcVersion - when isCorrectVersion $ do - dist_dir <- distDir - cabal_build ("--enable-tests" : "--enable-coverage" : opts) - cabal "test" ["test-Short", "--show-details=direct"] - lbi <- liftIO $ getPersistBuildConfig dist_dir - let way = guessWay lbi - CompilerId comp version = compilerId (compiler lbi) - subdir - | comp == GHC && version >= mkVersion [7, 10] = - localCompatPackageKey lbi - | otherwise = display (localPackage lbi) - mapM_ shouldExist - [ mixDir dist_dir way "my-0.1" subdir "Foo.mix" - , mixDir dist_dir way "test-Short" "Main.mix" - , tixFilePath dist_dir way "test-Short" - , htmlDir dist_dir way "test-Short" "hpc_index.html" - ] - where - tc :: String -> String -> TestM a -> TestTreeM () - tc name subname m - = testTree' $ testCase name - (runTestM config "TestSuiteTests/ExeV10" (Just subname) m) - - choose4 :: [a] -> [(a, a, a, a)] - choose4 xs = liftM4 (,,,) xs xs xs xs - --- | Checks for a suitable HPC version for testing. -correctHpcVersion :: IO Bool -correctHpcVersion = do - let programDb' = emptyProgramDb - let verbosity = Verbosity.normal - let verRange = orLaterVersion (mkVersion [0,7]) - programDb <- configureProgram verbosity hpcProgram programDb' - (requireProgramVersion verbosity hpcProgram verRange programDb - >> return True) `catchIO` (\_ -> return False) - where - -- Distribution.Compat.Exception is hidden. - catchIO :: IO a -> (E.IOException -> IO a) -> IO a - catchIO = E.catch diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.out b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.out @@ -0,0 +1,26 @@ +# cabal new-test +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - my-0.1 (lib) (first run) + - my-0.1 (test:test-Short) (first run) + - my-0.1 (test:test-Foo) (first run) +Configuring library for my-0.1.. +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Configuring test suite 'test-Short' for my-0.1.. +Preprocessing test suite 'test-Short' for my-0.1.. +Building test suite 'test-Short' for my-0.1.. +Running 1 test suites... +Test suite test-Short: RUNNING... +Test suite test-Short: PASS +Test suite logged to: /cabal.dist/work/./dist/build//ghc-/my-0.1/t/test-Short/test/my-0.1-test-Short.log +1 of 1 test suites (1 of 1 test cases) passed. +Configuring test suite 'test-Foo' for my-0.1.. +Preprocessing test suite 'test-Foo' for my-0.1.. +Building test suite 'test-Foo' for my-0.1.. +Running 1 test suites... +Test suite test-Foo: RUNNING... +Test suite test-Foo: PASS +Test suite logged to: /cabal.dist/work/./dist/build//ghc-/my-0.1/t/test-Foo/test/my-0.1-test-Foo.log +1 of 1 test suites (1 of 1 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.project b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.project new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.project @@ -0,0 +1,1 @@ +packages: . diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude + +main = cabalTest $ do + cabal "new-test" [] diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-markup.cabal.out b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-markup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-markup.cabal.out @@ -0,0 +1,20 @@ +# Setup configure +Resolving dependencies... +Configuring my-0.1... +# Setup build +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Preprocessing test suite 'test-Foo' for my-0.1.. +Building test suite 'test-Foo' for my-0.1.. +Preprocessing test suite 'test-Short' for my-0.1.. +Building test suite 'test-Short' for my-0.1.. +# Setup test +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Preprocessing test suite 'test-Short' for my-0.1.. +Building test suite 'test-Short' for my-0.1.. +Running 1 test suites... +Test suite test-Short: RUNNING... +Test suite test-Short: PASS +Test suite logged to: setup-no-markup.cabal.dist/work/dist/test/my-0.1-test-Short.log +1 of 1 test suites (1 of 1 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-markup.out b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-markup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-markup.out @@ -0,0 +1,16 @@ +# Setup configure +Configuring my-0.1... +# Setup build +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Preprocessing test suite 'test-Foo' for my-0.1.. +Building test suite 'test-Foo' for my-0.1.. +Preprocessing test suite 'test-Short' for my-0.1.. +Building test suite 'test-Short' for my-0.1.. +# Setup test +Running 1 test suites... +Test suite test-Short: RUNNING... +Test suite test-Short: PASS +Test suite logged to: +setup-no-markup.dist/work/dist/test/my-0.1-test-Short.log +1 of 1 test suites (1 of 1 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-markup.test.hs b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-markup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-markup.test.hs @@ -0,0 +1,16 @@ +import Test.Cabal.Prelude +import Distribution.Simple.Hpc + +-- Ensures that even if a .tix file happens to be left around +-- markup isn't generated. +main = setupAndCabalTest $ do + dist_dir <- fmap testDistDir getTestEnv + let tixFile = tixFilePath dist_dir Vanilla "test-Short" + withEnv [("HPCTIXFILE", Just tixFile)] $ do + setup_build + [ "--enable-tests" + , "--ghc-option=-fhpc" + , "--ghc-option=-hpcdir" + , "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" ] + setup "test" ["test-Short", "--show-details=direct"] + shouldNotExist $ htmlDir dist_dir Vanilla "test-Short" "hpc_index.html" diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-tix.cabal.out b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-tix.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-tix.cabal.out @@ -0,0 +1,20 @@ +# Setup configure +Resolving dependencies... +Configuring my-0.1... +# Setup build +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Preprocessing test suite 'test-Foo' for my-0.1.. +Building test suite 'test-Foo' for my-0.1.. +Preprocessing test suite 'test-Short' for my-0.1.. +Building test suite 'test-Short' for my-0.1.. +# Setup test +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Preprocessing test suite 'test-Short' for my-0.1.. +Building test suite 'test-Short' for my-0.1.. +Running 1 test suites... +Test suite test-Short: RUNNING... +Test suite test-Short: PASS +Test suite logged to: ../work/dist/test/my-0.1-test-Short.log +1 of 1 test suites (1 of 1 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-tix.out b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-tix.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-tix.out @@ -0,0 +1,15 @@ +# Setup configure +Configuring my-0.1... +# Setup build +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Preprocessing test suite 'test-Foo' for my-0.1.. +Building test suite 'test-Foo' for my-0.1.. +Preprocessing test suite 'test-Short' for my-0.1.. +Building test suite 'test-Short' for my-0.1.. +# Setup test +Running 1 test suites... +Test suite test-Short: RUNNING... +Test suite test-Short: PASS +Test suite logged to: ../work/dist/test/my-0.1-test-Short.log +1 of 1 test suites (1 of 1 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-tix.test.hs b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-tix.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-no-tix.test.hs @@ -0,0 +1,27 @@ +import Test.Cabal.Prelude +import Distribution.Simple.Hpc + +-- When -fhpc is manually provided, but --enable-coverage is not, +-- the desired behavior is that we pass on -fhpc to GHC, but do NOT +-- attempt to do anything with the tix file (i.e., do not change +-- where it gets output, do not attempt to run hpc on it.) +-- +-- This was requested in #1945, by a user who wanted to handle the +-- coverage manually. Unfortunately, this behavior is (not yet) +-- documented in the manual. (In fact, coverage is not documented +-- at all.) +-- +main = setupAndCabalTest $ do + -- Source copy is necessary as GHC defaults to dumping tix + -- file in the CWD, and we do NOT clean it up after the fact. + withSourceCopy $ do + dist_dir <- fmap testDistDir getTestEnv + setup_build + [ "--enable-tests" + , "--ghc-option=-fhpc" + , "--ghc-option=-hpcdir" + , "--ghc-option=" ++ dist_dir ++ "/hpc/vanilla" ] + setup "test" ["test-Short", "--show-details=direct"] + lbi <- getLocalBuildInfoM + let way = guessWay lbi + shouldNotExist $ tixFilePath dist_dir way "test-Short" diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-with-hpc.multitest.hs b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-with-hpc.multitest.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-with-hpc.multitest.hs @@ -0,0 +1,98 @@ +import qualified Control.Exception as E (IOException, catch) +import Control.Monad +import Control.Monad.IO.Class +import Data.Maybe (catMaybes) +import System.FilePath +import Data.List + +import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) +import Distribution.Simple.Compiler (compilerId) +import Distribution.Types.LocalBuildInfo (localPackage) +import Distribution.Simple.LocalBuildInfo (compiler, localCompatPackageKey) +import Distribution.Simple.Hpc +import Distribution.Simple.Program.Builtin (hpcProgram) +import Distribution.Simple.Program.Db + ( emptyProgramDb, configureProgram, requireProgramVersion ) +import Distribution.Text (display) +import qualified Distribution.Verbosity as Verbosity +import Distribution.Version (mkVersion, orLaterVersion) + +import Test.Cabal.Prelude + +main = + forM_ (choose4 [True, False]) $ \(libProf, exeProf, exeDyn, shared) -> + -- NB: inside so we cleanup each time. This seems to + -- be important on Mac OS X, where leftover build products + -- can cause errors like this: + -- + -- Test suite test-Short: RUNNING... + -- setup-with-hpc.dist/dist/build/test-Short/test-Short + -- dyld: Library not loaded: + -- @rpath/libHSmy-0.1-B1rF0UIcOou1OUvUhHrTHK-ghc7.8.4.dylib + -- Referenced from: + -- /Users/travis/build/haskell/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-with-hpc.dist/dist/build/test-Short/test-Short + -- Reason: image not found + -- + -- This should get fixed eventually, but not today as I don't + -- have an actual Mac OS X box to debug on. + setupAndCabalTest . recordMode DoNotRecord $ do + let name | null suffixes = "Vanilla" + | otherwise = intercalate "-" suffixes + where + suffixes = catMaybes + [ if libProf then Just "LibProf" else Nothing + , if exeProf then Just "ExeProf" else Nothing + , if exeDyn then Just "ExeDyn" else Nothing + , if shared then Just "Shared" else Nothing + ] + opts = catMaybes + [ enable libProf "library-profiling" + , enable exeProf "profiling" + , enable exeDyn "executable-dynamic" + , enable shared "shared" + ] + where + enable cond flag + | cond = Just $ "--enable-" ++ flag + | otherwise = Nothing + -- Ensure that both .tix file and markup are generated if coverage + -- is enabled. + shared_libs <- hasSharedLibraries + prof_libs <- hasProfiledLibraries + unless ((exeDyn || shared) && not shared_libs) $ do + unless ((libProf || exeProf) && not prof_libs) $ do + isCorrectVersion <- liftIO $ correctHpcVersion + when isCorrectVersion $ do + dist_dir <- fmap testDistDir getTestEnv + setup_build ("--enable-tests" : "--enable-coverage" : opts) + setup "test" ["test-Short", "--show-details=direct"] + lbi <- getLocalBuildInfoM + let way = guessWay lbi + CompilerId comp version = compilerId (compiler lbi) + subdir + | comp == GHC && version >= mkVersion [7,10] = + localCompatPackageKey lbi + | otherwise = display (localPackage lbi) + mapM_ shouldExist + [ mixDir dist_dir way "my-0.1" subdir "Foo.mix" + , mixDir dist_dir way "test-Short" "Main.mix" + , tixFilePath dist_dir way "test-Short" + , htmlDir dist_dir way "test-Short" "hpc_index.html" + ] + where + choose4 :: [a] -> [(a, a, a, a)] + choose4 xs = liftM4 (,,,) xs xs xs xs + +-- | Checks for a suitable HPC version for testing. +correctHpcVersion :: IO Bool +correctHpcVersion = do + let programDb' = emptyProgramDb + let verbosity = Verbosity.normal + let verRange = orLaterVersion (mkVersion [0,7]) + programDb <- configureProgram verbosity hpcProgram programDb' + (requireProgramVersion verbosity hpcProgram verRange programDb + >> return True) `catchIO` (\_ -> return False) + where + -- Distribution.Compat.Exception is hidden. + catchIO :: IO a -> (E.IOException -> IO a) -> IO a + catchIO = E.catch diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-with-hpc.out b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-with-hpc.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup-with-hpc.out diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup.cabal.out @@ -0,0 +1,25 @@ +# Setup configure +Resolving dependencies... +Configuring my-0.1... +# Setup build +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Preprocessing test suite 'test-Foo' for my-0.1.. +Building test suite 'test-Foo' for my-0.1.. +Preprocessing test suite 'test-Short' for my-0.1.. +Building test suite 'test-Short' for my-0.1.. +# Setup test +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Preprocessing test suite 'test-Foo' for my-0.1.. +Building test suite 'test-Foo' for my-0.1.. +Preprocessing test suite 'test-Short' for my-0.1.. +Building test suite 'test-Short' for my-0.1.. +Running 2 test suites... +Test suite test-Foo: RUNNING... +Test suite test-Foo: PASS +Test suite logged to: setup.cabal.dist/work/dist/test/my-0.1-test-Foo.log +Test suite test-Short: RUNNING... +Test suite test-Short: PASS +Test suite logged to: setup.cabal.dist/work/dist/test/my-0.1-test-Short.log +2 of 2 test suites (2 of 2 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup.out b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup.out @@ -0,0 +1,18 @@ +# Setup configure +Configuring my-0.1... +# Setup build +Preprocessing library for my-0.1.. +Building library for my-0.1.. +Preprocessing test suite 'test-Foo' for my-0.1.. +Building test suite 'test-Foo' for my-0.1.. +Preprocessing test suite 'test-Short' for my-0.1.. +Building test suite 'test-Short' for my-0.1.. +# Setup test +Running 2 test suites... +Test suite test-Foo: RUNNING... +Test suite test-Foo: PASS +Test suite logged to: setup.dist/work/dist/test/my-0.1-test-Foo.log +Test suite test-Short: RUNNING... +Test suite test-Short: PASS +Test suite logged to: setup.dist/work/dist/test/my-0.1-test-Short.log +2 of 2 test suites (2 of 2 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup.test.hs b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/setup.test.hs @@ -0,0 +1,7 @@ +import Test.Cabal.Prelude + +main = setupAndCabalTest $ do + setup_build ["--enable-tests"] + -- This one runs both tests, including the very LONG Foo + -- test which prints a lot of output + setup "test" ["--show-details=direct"] diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.cabal.out b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.cabal.out @@ -0,0 +1,18 @@ +# Setup configure +Resolving dependencies... +Configuring LibV09-0.1... +# Setup build +Preprocessing library for LibV09-0.1.. +Building library for LibV09-0.1.. +Preprocessing test suite 'LibV09-Deadlock' for LibV09-0.1.. +Building test suite 'LibV09-Deadlock' for LibV09-0.1.. +# Setup test +Preprocessing library for LibV09-0.1.. +Building library for LibV09-0.1.. +Preprocessing test suite 'LibV09-Deadlock' for LibV09-0.1.. +Building test suite 'LibV09-Deadlock' for LibV09-0.1.. +Running 1 test suites... +Test suite LibV09-Deadlock: RUNNING... +Test suite LibV09-Deadlock: FAIL +Test suite logged to: setup-deadlock.cabal.dist/work/dist/test/LibV09-0.1-LibV09-Deadlock.log +0 of 1 test suites (0 of 1000 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.out b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.out @@ -0,0 +1,14 @@ +# Setup configure +Configuring LibV09-0.1... +# Setup build +Preprocessing library for LibV09-0.1.. +Building library for LibV09-0.1.. +Preprocessing test suite 'LibV09-Deadlock' for LibV09-0.1.. +Building test suite 'LibV09-Deadlock' for LibV09-0.1.. +# Setup test +Running 1 test suites... +Test suite LibV09-Deadlock: RUNNING... +Test suite LibV09-Deadlock: FAIL +Test suite logged to: +setup-deadlock.dist/work/dist/test/LibV09-0.1-LibV09-Deadlock.log +0 of 1 test suites (0 of 1000 test cases) passed. diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.test.hs b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = setupAndCabalTest $ do + skipUnless =<< hasCabalForGhc + setup_build ["--enable-tests"] + fails $ setup "test" [] diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.cabal.out @@ -0,0 +1,8 @@ +# Setup configure +Resolving dependencies... +Configuring LibV09-0.1... +# Setup build +Preprocessing library for LibV09-0.1.. +Building library for LibV09-0.1.. +Preprocessing test suite 'LibV09-Deadlock' for LibV09-0.1.. +Building test suite 'LibV09-Deadlock' for LibV09-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.out b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.out @@ -0,0 +1,7 @@ +# Setup configure +Configuring LibV09-0.1... +# Setup build +Preprocessing library for LibV09-0.1.. +Building library for LibV09-0.1.. +Preprocessing test suite 'LibV09-Deadlock' for LibV09-0.1.. +Building test suite 'LibV09-Deadlock' for LibV09-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.test.hs b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +-- Test if detailed-0.9 builds correctly +main = setupAndCabalTest $ do + skipUnless =<< hasCabalForGhc + setup_build ["--enable-tests"] diff --git a/cabal/cabal-testsuite/PackageTests/Tests.hs b/cabal/cabal-testsuite/PackageTests/Tests.hs deleted file mode 100644 --- a/cabal/cabal-testsuite/PackageTests/Tests.hs +++ /dev/null @@ -1,750 +0,0 @@ -module PackageTests.Tests(tests) where - -import PackageTests.PackageTester - -import qualified PackageTests.AutogenModules.Package.Check -import qualified PackageTests.AutogenModules.SrcDist.Check -import qualified PackageTests.BenchmarkStanza.Check -import qualified PackageTests.CaretOperator.Check -import qualified PackageTests.TestStanza.Check -import qualified PackageTests.DeterministicAr.Check -import qualified PackageTests.TestSuiteTests.ExeV10.Check -import qualified PackageTests.ForeignLibs.Check - -import Distribution.Types.TargetInfo -import Distribution.Types.LocalBuildInfo - -import Distribution.Package -import Distribution.Simple.LocalBuildInfo - ( absoluteComponentInstallDirs - , InstallDirs (..) - , ComponentLocalBuildInfo(componentUnitId), ComponentName(..) ) -import Distribution.Simple.InstallDirs ( CopyDest(NoCopyDest) ) -import Distribution.Simple.BuildPaths ( mkLibName, mkSharedLibName ) -import Distribution.Simple.Compiler ( compilerId ) -import Distribution.System (buildOS, OS(Windows)) -import Distribution.Version - -import Control.Monad -import System.Directory -import Test.Tasty (mkTimeout, localOption) - -import qualified Data.Char as Char - -tests :: SuiteConfig -> TestTreeM () -tests config = do - - --------------------------------------------------------------------- - -- * External tests - - -- Test that Cabal parses 'benchmark' sections correctly - tc "BenchmarkStanza" PackageTests.BenchmarkStanza.Check.suite - - -- Test that Cabal parses 'test' sections correctly - tc "TestStanza" PackageTests.TestStanza.Check.suite - - -- Test that Cabal parses '^>=' operator correctly. - -- Don't run this for GHC 7.0/7.2, which doesn't have a recent - -- enough version of pretty. (But this is pretty dumb.) - tc "CaretOperator" . whenGhcVersion (>= mkVersion [7,3])$ - PackageTests.CaretOperator.Check.suite - - -- Test that Cabal determinstically generates object archives - tc "DeterministicAr" PackageTests.DeterministicAr.Check.suite - - -- Test that cabal shows all the 'autogen-modules' warnings. - tc "AutogenModules/Package" PackageTests.AutogenModules.Package.Check.suite - -- Test that Cabal parses and uses 'autogen-modules' fields correctly - tc "AutogenModules/SrcDist" PackageTests.AutogenModules.SrcDist.Check.suite - - -- Test that foreign libraries work - tc "ForeignLibs" PackageTests.ForeignLibs.Check.suite - - --------------------------------------------------------------------- - -- * Test suite tests - - -- TODO: This shouldn't be necessary, but there seems to be some - -- bug in the way the test is written. Not going to lose sleep - -- over this... but would be nice to fix. - testWhen (hasCabalForGhc config) - . groupTests "TestSuiteTests/ExeV10" $ - (PackageTests.TestSuiteTests.ExeV10.Check.tests config) - - -- Test if detailed-0.9 builds correctly - testWhen (hasCabalForGhc config) - . tcs "TestSuiteTests/LibV09" "Build" $ cabal_build ["--enable-tests"] - - -- Tests for #2489, stdio deadlock - testWhen (hasCabalForGhc config) - . mapTestTrees (localOption (mkTimeout $ 10 ^ (8 :: Int))) - . tcs "TestSuiteTests/LibV09" "Deadlock" $ do - cabal_build ["--enable-tests"] - shouldFail $ cabal "test" [] - - --------------------------------------------------------------------- - -- * Inline tests - - -- Test if exitcode-stdio-1.0 benchmark builds correctly - tc "BenchmarkExeV10" $ cabal_build ["--enable-benchmarks"] - - -- Test --benchmark-option(s) flags on ./Setup bench - tc "BenchmarkOptions" $ do - cabal_build ["--enable-benchmarks"] - cabal "bench" [ "--benchmark-options=1 2 3" ] - cabal "bench" [ "--benchmark-option=1" - , "--benchmark-option=2" - , "--benchmark-option=3" - ] - - -- Test --test-option(s) flags on ./Setup test - tc "TestOptions" $ do - cabal_build ["--enable-tests"] - cabal "test" ["--test-options=1 2 3"] - cabal "test" [ "--test-option=1" - , "--test-option=2" - , "--test-option=3" - ] - - -- Test attempt to have executable depend on internal - -- library, but cabal-version is too old. - tc "BuildDeps/InternalLibrary0" $ do - r <- shouldFail $ cabal' "configure" [] - -- Should tell you how to enable the desired behavior - let sb = "library which is defined within the same package." - assertOutputContains sb r - - -- Test executable depends on internal library. - tc "BuildDeps/InternalLibrary1" $ cabal_build [] - - -- Test that internal library is preferred to an installed on - -- with the same name and version - tc "BuildDeps/InternalLibrary2" $ internal_lib_test "internal" - - -- Test that internal library is preferred to an installed on - -- with the same name and LATER version - tc "BuildDeps/InternalLibrary3" $ internal_lib_test "internal" - - -- On old versions of Cabal, an explicit dependency constraint which - -- doesn't match the internal library causes us to use external - -- library. We got rid of this functionality in 1.25; now, we always - -- use internal, and just emit an error if you check. - tcs "BuildDeps/InternalLibrary4" "external" $ internal_lib_test "internal" - - -- On a previous buggy version of my patch, the test above passed only - -- because the installed library caused Cabal to think that the - -- dependency was fulfilled. Make sure we ignore the dependency - -- entirely. - tcs "BuildDeps/InternalLibrary4" "ignore" $ cabal_build [] - - -- Test "old build-dep behavior", where we should get the - -- same package dependencies on all targets if cabal-version - -- is sufficiently old. - tc "BuildDeps/SameDepsAllRound" $ cabal_build [] - - -- Test "new build-dep behavior", where each target gets - -- separate dependencies. This tests that an executable - -- dep does not leak into the library. - tc "BuildDeps/TargetSpecificDeps1" $ do - cabal "configure" [] - r <- shouldFail $ cabal' "build" [] - assertRegex "error should be in MyLibrary.hs" "^MyLibrary.hs:" r - assertRegex - "error should be \"Could not find module `Text\\.PrettyPrint\"" - "(Could not find module|Failed to load interface for).*Text\\.PrettyPrint" r - - -- This is a control on TargetSpecificDeps1; it should - -- succeed. - tc "BuildDeps/TargetSpecificDeps2" $ cabal_build [] - - -- Test "new build-dep behavior", where each target gets - -- separate dependencies. This tests that an library - -- dep does not leak into the executable. - tc "BuildDeps/TargetSpecificDeps3" $ do - cabal "configure" [] - r <- shouldFail $ cabal' "build" [] - assertRegex "error should be in lemon.hs" "^lemon.hs:" r - assertRegex - "error should be \"Could not find module `Text\\.PrettyPrint\"" - "(Could not find module|Failed to load interface for).*Text\\.PrettyPrint" r - - -- Test that Paths module is generated and available for executables. - tc "PathsModule/Executable" $ cabal_build [] - - -- Test that Paths module is generated and available for libraries. - tc "PathsModule/Library" $ cabal_build [] - - -- Check that preprocessors (hsc2hs) are run - tc "PreProcess" $ cabal_build ["--enable-tests", "--enable-benchmarks"] - - -- Check that preprocessors that generate extra C sources are handled - tc "PreProcessExtraSources" $ cabal_build ["--enable-tests", - "--enable-benchmarks"] - - -- Test building a vanilla library/executable which uses Template Haskell - tc "TemplateHaskell/vanilla" $ cabal_build [] - - -- Test building a profiled library/executable which uses Template Haskell - -- (Cabal has to build the non-profiled version first) - tc "TemplateHaskell/profiling" $ cabal_build ["--enable-library-profiling", - "--enable-profiling"] - - -- Test building a dynamic library/executable which uses Template - -- Haskell - testWhen (hasSharedLibraries config) $ - tc "TemplateHaskell/dynamic" $ cabal_build ["--enable-shared", - "--enable-executable-dynamic"] - - -- Test building an executable whose main() function is defined in a C - -- file - tc "CMain" $ cabal_build [] - - -- Test build when the library is empty, for #1241 - tc "EmptyLib" $ - withPackage "empty" $ cabal_build [] - - -- Test that "./Setup haddock" works correctly - tc "Haddock" $ do - dist_dir <- distDir - let haddocksDir = dist_dir "doc" "html" "Haddock" - cabal "configure" [] - cabal "haddock" [] - let docFiles - = map (haddocksDir ) - ["CPP.html", "Literate.html", "NoCPP.html", "Simple.html"] - mapM_ (assertFindInFile "For hiding needles.") docFiles - - -- Test that Haddock with a newline in synopsis works correctly, #3004 - tc "HaddockNewline" $ do - cabal "configure" [] - cabal "haddock" [] - - -- Test that Cabal properly orders GHC flags passed to GHC (when - -- there are multiple ghc-options fields.) - tc "OrderFlags" $ cabal_build [] - - -- Test that reexported modules build correctly - tcs "ReexportedModules" "p" . whenGhcVersion (>= mkVersion [7,9]) $ do - withPackageDb $ do - withPackage "p" $ cabal_install ["--cabal-file", "p.cabal"] - withPackage "q" $ do - cabal_build [] - tcs "ReexportedModules" "fail-other" . whenGhcVersion (>= mkVersion [7,9]) $ do - withPackage "p" $ do - r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail-other.cabal"] - assertOutputContains "Private" r - tcs "ReexportedModules" "fail-ambiguous" . whenGhcVersion (>= mkVersion [7,9]) $ do - withPackageDb $ do - withPackage "containers-dupe" $ cabal_install [] - withPackage "p" $ do - r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail-ambiguous.cabal"] - assertOutputContains "Data.Map" r - tcs "ReexportedModules" "fail-missing" . whenGhcVersion (>= mkVersion [7,9]) $ do - withPackage "p" $ do - r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail-missing.cabal"] - assertOutputContains "Missing" r - - -- Test that module name ambiguity can be resolved using package - -- qualified imports. (Paper Backpack doesn't natively support - -- this but we must!) - tcs "Ambiguity" "package-import" $ do - withPackageDb $ do - withPackage "p" $ cabal_install [] - withPackage "q" $ cabal_install [] - withPackage "package-import" $ do - cabal_build [] - runExe' "package-import" [] >>= assertOutputContains "p q" - - -- Test that we can resolve a module name ambiguity when reexporting - -- by explicitly specifying what package we want. - tcs "Ambiguity" "reexport" . whenGhcVersion (>= mkVersion [7,9]) $ do - withPackageDb $ do - withPackage "p" $ cabal_install [] - withPackage "q" $ cabal_install [] - withPackage "reexport" $ cabal_install [] - withPackage "reexport-test" $ do - cabal_build [] - runExe' "reexport-test" [] >>= assertOutputContains "p q" - - -- Test that Cabal computes different IPIDs when the source changes. - tc "UniqueIPID" . withPackageDb $ do - withPackage "P1" $ cabal "configure" [] - withPackage "P2" $ cabal "configure" [] - withPackage "P1" $ cabal "build" [] - withPackage "P1" $ cabal "build" [] -- rebuild should work - r1 <- withPackage "P1" $ cabal' "register" ["--print-ipid", "--inplace"] - withPackage "P2" $ cabal "build" [] - r2 <- withPackage "P2" $ cabal' "register" ["--print-ipid", "--inplace"] - let exIPID s = takeWhile (/= '\n') $ - head . filter (isPrefixOf $ "UniqueIPID-0.1-") $ (tails s) - when ((exIPID $ resultOutput r1) == (exIPID $ resultOutput r2)) $ - assertFailure $ "cabal has not calculated different Installed " ++ - "package ID when source is changed." - - -- Test that if two components have the same module name, they do not - -- clobber each other. - testWhen (hasCabalForGhc config) $ -- uses library test suite - tc "DuplicateModuleName" $ do - cabal_build ["--enable-tests"] - r1 <- shouldFail $ cabal' "test" ["foo"] - assertOutputContains "test B" r1 - assertOutputContains "test A" r1 - r2 <- shouldFail $ cabal' "test" ["foo2"] - assertOutputContains "test C" r2 - assertOutputContains "test A" r2 - - -- Test that if test suite has a name which conflicts with a package - -- which is in the database, we can still use the test case (they - -- should NOT shadow). - testWhen (hasCabalForGhc config) - . tc "TestNameCollision" $ do - withPackageDb $ do - withPackage "parent" $ cabal_install [] - withPackage "child" $ do - cabal_build ["--enable-tests"] - cabal "test" [] - - -- Test that '--allow-newer' works via the 'Setup.hs configure' interface. - tc "AllowNewer" $ do - shouldFail $ cabal "configure" [] - cabal "configure" ["--allow-newer"] - shouldFail $ cabal "configure" ["--allow-newer=baz,quux"] - cabal "configure" ["--allow-newer=base", "--allow-newer=baz,quux"] - cabal "configure" ["--allow-newer=bar", "--allow-newer=base,baz" - ,"--allow-newer=quux"] - shouldFail $ cabal "configure" ["--enable-tests"] - cabal "configure" ["--enable-tests", "--allow-newer"] - shouldFail $ cabal "configure" ["--enable-benchmarks"] - cabal "configure" ["--enable-benchmarks", "--allow-newer"] - shouldFail $ cabal "configure" ["--enable-benchmarks", "--enable-tests"] - cabal "configure" ["--enable-benchmarks", "--enable-tests" - ,"--allow-newer"] - shouldFail $ cabal "configure" ["--allow-newer=Foo:base"] - shouldFail $ cabal "configure" ["--allow-newer=Foo:base" - ,"--enable-tests", "--enable-benchmarks"] - cabal "configure" ["--allow-newer=AllowNewer:base"] - cabal "configure" ["--allow-newer=AllowNewer:base" - ,"--allow-newer=Foo:base"] - cabal "configure" ["--allow-newer=AllowNewer:base" - ,"--allow-newer=Foo:base" - ,"--enable-tests", "--enable-benchmarks"] - - -- Test that '--allow-older' works via the 'Setup.hs configure' interface. - tc "AllowOlder" $ do - shouldFail $ cabal "configure" [] - cabal "configure" ["--allow-older"] - shouldFail $ cabal "configure" ["--allow-older=baz,quux"] - cabal "configure" ["--allow-older=base", "--allow-older=baz,quux"] - cabal "configure" ["--allow-older=bar", "--allow-older=base,baz" - ,"--allow-older=quux"] - shouldFail $ cabal "configure" ["--enable-tests"] - cabal "configure" ["--enable-tests", "--allow-older"] - shouldFail $ cabal "configure" ["--enable-benchmarks"] - cabal "configure" ["--enable-benchmarks", "--allow-older"] - shouldFail $ cabal "configure" ["--enable-benchmarks", "--enable-tests"] - cabal "configure" ["--enable-benchmarks", "--enable-tests" - ,"--allow-older"] - shouldFail $ cabal "configure" ["--allow-older=Foo:base"] - shouldFail $ cabal "configure" ["--allow-older=Foo:base" - ,"--enable-tests", "--enable-benchmarks"] - cabal "configure" ["--allow-older=AllowOlder:base"] - cabal "configure" ["--allow-older=AllowOlder:base" - ,"--allow-older=Foo:base"] - cabal "configure" ["--allow-older=AllowOlder:base" - ,"--allow-older=Foo:base" - ,"--enable-tests", "--enable-benchmarks"] - - -- Test that Cabal can choose flags to disable building a component when that - -- component's dependencies are unavailable. The build should succeed without - -- requiring the component's dependencies or imports. - tc "BuildableField" $ do - r <- cabal' "configure" ["-v"] - assertOutputContains "Flags chosen: build-exe=False" r - cabal "build" [] - - -- TODO: Enable these tests on Windows - unlessWindows $ do - tc "GhcPkgGuess/SameDirectory" $ ghc_pkg_guess "ghc" - tc "GhcPkgGuess/SameDirectoryVersion" $ ghc_pkg_guess "ghc-7.10" - tc "GhcPkgGuess/SameDirectoryGhcVersion" $ ghc_pkg_guess "ghc-7.10" - - unlessWindows $ do - tc "GhcPkgGuess/Symlink" $ do - -- We don't want to distribute a tarball with symlinks. See #3190. - withSymlink "bin/ghc" - "PackageTests/GhcPkgGuess/Symlink/ghc" $ - ghc_pkg_guess "ghc" - - tc "GhcPkgGuess/SymlinkVersion" $ do - withSymlink "bin/ghc-7.10" - "PackageTests/GhcPkgGuess/SymlinkVersion/ghc" $ - ghc_pkg_guess "ghc" - - tc "GhcPkgGuess/SymlinkGhcVersion" $ do - withSymlink "bin/ghc-7.10" - "PackageTests/GhcPkgGuess/SymlinkGhcVersion/ghc" $ - ghc_pkg_guess "ghc" - - -- Basic test for internal libraries (in p); package q is to make - -- sure that the internal library correctly is used, not the - -- external library. - tc "InternalLibraries" $ do - withPackageDb $ do - withPackage "q" $ cabal_install [] - withPackage "p" $ do - cabal_install [] - cabal "clean" [] - r <- runInstalledExe' "foo" [] - assertOutputContains "I AM THE ONE" r - - -- Test to see if --gen-script works. - tcs "InternalLibraries" "gen-script" $ do - withPackageDb $ do - withPackage "p" $ do - cabal_build [] - cabal "copy" [] - cabal "register" ["--gen-script"] - _ <- if buildOS == Windows - then shell "cmd" ["/C", "register.bat"] - else shell "sh" ["register.sh"] - return () - -- Make sure we can see p - withPackage "r" $ cabal_install [] - - -- Test to see if --gen-pkg-config works. - tcs "InternalLibraries" "gen-pkg-config" $ do - withPackageDb $ do - withPackage "p" $ do - cabal_build [] - cabal "copy" [] - let dir = "pkg-config.bak" - cabal "register" ["--gen-pkg-config=" ++ dir] - -- Infelicity! Does not respect CWD. - pkg_dir <- packageDir - let notHidden = not . isHidden - isHidden name = "." `isPrefixOf` name - confs <- fmap (sort . filter notHidden) - . liftIO $ getDirectoryContents (pkg_dir dir) - forM_ confs $ \conf -> ghcPkg "register" [pkg_dir dir conf] - - -- Make sure we can see p - withPackage "r" $ cabal_install [] - - -- Internal libraries used by a statically linked executable: - -- no libraries should get installed or registered. (Note, - -- this does build shared libraries just to make sure they - -- don't get installed, so this test doesn't work on Windows.) - testWhen (hasSharedLibraries config) $ - tcs "InternalLibraries/Executable" "Static" $ - multiple_libraries_executable False - - -- Internal libraries used by a dynamically linked executable: - -- ONLY the dynamic library should be installed, no registration - testWhen (hasSharedLibraries config) $ - tcs "InternalLibraries/Executable" "Dynamic" $ - multiple_libraries_executable True - - -- Internal library used by public library; it must be installed and - -- registered. - tc "InternalLibraries/Library" $ do - withPackageDb $ do - withPackage "foolib" $ cabal_install [] - withPackage "fooexe" $ do - cabal_build [] - runExe' "fooexe" [] - >>= assertOutputContains "25" - - -- Test to ensure that cabal_macros.h are computed per-component. - tc "Macros" $ do - cabal_build [] - runExe' "macros-a" [] - >>= assertOutputContains "macros-a" - runExe' "macros-b" [] - >>= assertOutputContains "macros-b" - - -- Test for 'build-type: Configure' example from the Cabal manual. - -- Disabled on Windows since MingW doesn't ship with autoreconf by - -- default. - unlessWindows $ do - tc "Configure" $ do - _ <- shell "autoreconf" ["-i"] - cabal_build [] - - tc "ConfigureComponent/Exe" $ do - withPackageDb $ do - cabal_install ["goodexe"] - runExe' "goodexe" [] >>= assertOutputContains "OK" - - tcs "ConfigureComponent/SubLib" "sublib-explicit" $ do - withPackageDb $ do - cabal_install ["sublib", "--cid", "sublib-0.1-abc"] - cabal_install ["exe", "--dependency", "sublib=sublib-0.1-abc"] - runExe' "exe" [] >>= assertOutputContains "OK" - - tcs "ConfigureComponent/SubLib" "sublib" $ do - withPackageDb $ do - cabal_install ["sublib"] - cabal_install ["exe"] - runExe' "exe" [] >>= assertOutputContains "OK" - - tcs "ConfigureComponent/Test" "test" $ do - withPackageDb $ do - cabal_install ["test-for-cabal"] - withPackage "testlib" $ cabal_install [] - cabal "configure" ["testsuite"] - cabal "build" [] - cabal "test" [] - - -- Test that per-component copy works, when only building library - tc "CopyComponent/Lib" $ - withPackageDb $ do - cabal "configure" [] - cabal "build" ["lib:p"] - cabal "copy" ["lib:p"] - - -- Test that per-component copy works, when only building one executable - tc "CopyComponent/Exe" $ - withPackageDb $ do - cabal "configure" [] - cabal "build" ["myprog"] - cabal "copy" ["myprog"] - - -- Test internal custom preprocessor - tc "CustomPreProcess" $ do - cabal_build [] - runExe' "hello-world" [] - >>= assertOutputContains "hello from A" - - -- Test PATH-munging - tc "BuildToolsPath" $ do - cabal_build [] - runExe' "hello-world" [] - >>= assertOutputContains "1111" - - -- Test that executable recompilation works - -- https://github.com/haskell/cabal/issues/3294 - tc "Regression/T3294" $ do - pkg_dir <- packageDir - liftIO $ writeFile (pkg_dir "Main.hs") "main = putStrLn \"aaa\"" - cabal "configure" [] - cabal "build" [] - runExe' "T3294" [] >>= assertOutputContains "aaa" - ghcFileModDelay - liftIO $ writeFile (pkg_dir "Main.hs") "main = putStrLn \"bbb\"" - cabal "build" [] - runExe' "T3294" [] >>= assertOutputContains "bbb" - - -- Test that other-extensions of disabled component do not - -- effect configure step. - tc "Regression/T3847" $ do - cabal "configure" ["--disable-tests"] - - -- Test that we don't pick up include-dirs from libraries - -- we didn't actually depend on. - tc "Regression/T2971" $ do - withPackageDb $ do - withPackage "p" $ cabal_install [] - withPackage "q" $ do - cabal "configure" [] - assertOutputContains "T2971test.h" - =<< shouldFail (cabal' "build" []) - - -- Test that we pick up include dirs from internal library - tc "Regression/T2971a" $ cabal_build [] - - -- Test that we don't accidentally add the inplace directory to - -- an executable RPATH. Don't test on Windows, which doesn't - -- support RPATH. - unlessWindows $ do - tc "Regression/T4025" $ do - cabal "configure" ["--enable-executable-dynamic"] - cabal "build" [] - -- This should fail as it we should NOT be able to find the - -- dynamic library for the internal library (since we didn't - -- install it). If we incorrectly encoded our local dist - -- dir in the RPATH, this will succeed. - shouldFail $ runExe' "exe" [] - - -- Test error message we report when a non-buildable target is - -- requested to be built - -- TODO: We can give a better error message here, see #3858. - tcs "BuildTargetErrors" "non-buildable" $ do - cabal "configure" [] - assertOutputContains "There is no component" - =<< shouldFail (cabal' "build" ["not-buildable-exe"]) - - tc "Backpack/Includes1" . whenGhcVersion (>= mkVersion [8,1]) $ do - cabal "configure" [] - r <- shouldFail $ cabal' "build" [] - assertBool "error should be in B.hs" $ - resultOutput r =~ "^B.hs:" - assertBool "error should be \"Could not find module Data.Set\"" $ - resultOutput r =~ "(Could not find module|Failed to load interface).*Data.Set" - - tcs "Backpack/Includes2" "internal" . whenGhcVersion (>= mkVersion [8,1]) $ do - withPackageDb $ do - cabal_install ["--cabal-file", "Includes2.cabal"] - -- TODO: haddock for internal method doesn't work - runExe' "exe" [] >>= assertOutputContains "minemysql minepostgresql" - - tcs "Backpack/Includes2" "internal-fail" . whenGhcVersion (>= mkVersion [8,1]) $ do - withPackageDb $ do - r <- shouldFail $ cabal' "configure" ["--cabal-file", "fail.cabal"] - assertOutputContains "mysql" r - - tcs "Backpack/Includes2" "external" . whenGhcVersion (>= mkVersion [8,1]) $ do - withPackageDb $ do - withPackage "mylib" $ cabal_install_with_docs ["--ipid", "mylib-0.1.0.0"] - withPackage "mysql" $ cabal_install_with_docs ["--ipid", "mysql-0.1.0.0"] - withPackage "postgresql" $ cabal_install_with_docs ["--ipid", "postgresql-0.1.0.0"] - withPackage "mylib" $ - cabal_install_with_docs ["--ipid", "mylib-0.1.0.0", - "--instantiate-with", "Database=mysql-0.1.0.0:Database.MySQL"] - withPackage "mylib" $ - cabal_install_with_docs ["--ipid", "mylib-0.1.0.0", - "--instantiate-with", "Database=postgresql-0.1.0.0:Database.PostgreSQL"] - withPackage "src" $ cabal_install_with_docs [] - withPackage "exe" $ do - cabal_install_with_docs [] - runExe' "exe" [] >>= assertOutputContains "minemysql minepostgresql" - - tcs "Backpack/Includes2" "per-component" . whenGhcVersion (>= mkVersion [8,1]) $ do - withPackageDb $ do - let cabal_install' args = cabal_install_with_docs (["--cabal-file", "Includes2.cabal"] ++ args) - cabal_install' ["mylib", "--cid", "mylib-0.1.0.0"] - cabal_install' ["mysql", "--cid", "mysql-0.1.0.0"] - cabal_install' ["postgresql", "--cid", "postgresql-0.1.0.0"] - cabal_install' ["mylib", "--cid", "mylib-0.1.0.0", - "--instantiate-with", "Database=mysql-0.1.0.0:Database.MySQL"] - cabal_install' ["mylib", "--cid", "mylib-0.1.0.0", - "--instantiate-with", "Database=postgresql-0.1.0.0:Database.PostgreSQL"] - cabal_install' ["Includes2"] - cabal_install' ["exe"] - runExe' "exe" [] >>= assertOutputContains "minemysql minepostgresql" - - tcs "Backpack/Includes3" "internal" . whenGhcVersion (>= mkVersion [8,1]) $ do - withPackageDb $ do - cabal_install [] - -- TODO: refactorize - pkg_dir <- packageDir - _ <- run (Just pkg_dir) "touch" ["indef/Foo.hs"] - cabal "build" [] - runExe' "exe" [] >>= assertOutputContains "fromList [(0,2),(2,4)]" - - tcs "Backpack/Includes3" "external-fail" . whenGhcVersion (>= mkVersion [8,1]) $ do - withPackageDb $ do - withPackage "sigs" $ cabal_install [] - withPackage "indef" $ cabal_install [] - -- Forgot to build the instantiated versions! - withPackage "exe" $ do - r <- shouldFail $ cabal' "configure" [] - assertOutputContains "indef-0.1.0.0" r - return () - - tcs "Backpack/Includes3" "external-ok" . whenGhcVersion (>= mkVersion [8,1]) $ do - withPackageDb $ do - containers_result <- ghcPkg' "field" ["--global", "containers", "id"] - containers_id <- case stripPrefix "id: " (resultOutput containers_result) of - Just x -> return (takeWhile (not . Char.isSpace) x) - Nothing -> error "could not determine id of containers" - withPackage "sigs" $ cabal_install_with_docs ["--ipid", "sigs-0.1.0.0"] - withPackage "indef" $ cabal_install_with_docs ["--ipid", "indef-0.1.0.0"] - withPackage "sigs" $ do - -- NB: this REUSES the dist directory that we typechecked - -- indefinitely, but it's OK; the recompile checker should get it. - cabal_install_with_docs ["--ipid", "sigs-0.1.0.0", - "--instantiate-with", "Data.Map=" ++ containers_id ++ ":Data.Map"] - withPackage "indef" $ do - -- Ditto. - cabal_install_with_docs ["--ipid", "indef-0.1.0.0", - "--instantiate-with", "Data.Map=" ++ containers_id ++ ":Data.Map"] - withPackage "exe" $ do - cabal_install [] - runExe' "exe" [] >>= assertOutputContains "fromList [(0,2),(2,4)]" - - tcs "Backpack/Includes3" "external-explicit" . whenGhcVersion (>= mkVersion [8,1]) $ do - withPackageDb $ do - withPackage "sigs" $ cabal_install_with_docs ["--cid", "sigs-0.1.0.0", "lib:sigs"] - withPackage "indef" $ cabal_install_with_docs ["--cid", "indef-0.1.0.0", "--dependency=sigs=sigs-0.1.0.0", "lib:indef"] - - tc "Backpack/Includes4" . whenGhcVersion (>= mkVersion [8,1]) $ do - withPackageDb $ do - cabal_install [] - runExe' "exe" [] >>= assertOutputContains "A (B (A (B" - - tc "Backpack/Includes5" . whenGhcVersion (>= mkVersion [8,1]) $ do - cabal "configure" [] - r <- shouldFail $ cabal' "build" [] - assertOutputContains "Foobar" r - assertOutputContains "Could not find" r - return () - - tc "Backpack/Reexport1" . whenGhcVersion (>= mkVersion [8,1]) $ do - withPackageDb $ do - withPackage "p" $ cabal_install_with_docs [] - withPackage "q" $ do - cabal_build [] - cabal "haddock" [] - - where - ghc_pkg_guess bin_name = do - cwd <- packageDir - with_ghc <- getWithGhcPath - r <- withEnv [("WITH_GHC", Just with_ghc)] - . shouldFail $ cabal' "configure" ["-w", cwd bin_name] - assertOutputContains "is version 9999999" r - return () - - -- Shared test function for BuildDeps/InternalLibrary* tests. - internal_lib_test expect = withPackageDb $ do - withPackage "to-install" $ cabal_install [] - cabal_build [] - r <- runExe' "lemon" [] - assertEqual - ("executable should have linked with the " ++ expect ++ " library") - ("foo foo myLibFunc " ++ expect) - (concatOutput (resultOutput r)) - - assertRegex :: String -> String -> Result -> TestM () - assertRegex msg regex r = let out = resultOutput r - in assertBool (msg ++ ",\nactual output:\n" ++ out) - (out =~ regex) - - multiple_libraries_executable is_dynamic = - withPackageDb $ do - cabal_install $ [ if is_dynamic then "--enable-executable-dynamic" - else "--disable-executable-dynamic" - , "--enable-shared"] - dist_dir <- distDir - lbi <- liftIO $ getPersistBuildConfig dist_dir - let pkg_descr = localPkgDescr lbi - compiler_id = compilerId (compiler lbi) - cname = CSubLibName $ mkUnqualComponentName "foo-internal" - [target] = componentNameTargets' pkg_descr lbi cname - uid = componentUnitId (targetCLBI target) - InstallDirs{libdir=dir,dynlibdir=dyndir} = - absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest - assertBool "interface files should be installed" - =<< liftIO (doesFileExist (dir "Foo.hi")) - assertBool "static library should be installed" - =<< liftIO (doesFileExist (dir mkLibName uid)) - if is_dynamic - then - assertBool "dynamic library MUST be installed" - =<< liftIO (doesFileExist (dyndir mkSharedLibName - compiler_id uid)) - else - assertBool "dynamic library should be installed" - =<< liftIO (doesFileExist (dyndir mkSharedLibName - compiler_id uid)) - shouldFail $ ghcPkg "describe" ["foo"] - -- clean away the dist directory so that we catch accidental - -- dependence on the inplace files - cabal "clean" [] - runInstalledExe' "foo" [] >>= assertOutputContains "46" - - tc :: FilePath -> TestM a -> TestTreeM () - tc name = testTree config name - - tcs :: FilePath -> FilePath -> TestM a -> TestTreeM () - tcs name sub_name m - = testTreeSub config name sub_name m diff --git a/cabal/cabal-testsuite/PackageTests/UniqueIPID/setup.cabal.out b/cabal/cabal-testsuite/PackageTests/UniqueIPID/setup.cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/UniqueIPID/setup.cabal.out @@ -0,0 +1,12 @@ +# Setup configure +Resolving dependencies... +Configuring UniqueIPID-0.1... +# Setup configure +Resolving dependencies... +Configuring UniqueIPID-0.1... +# Setup build +Preprocessing library for UniqueIPID-0.1.. +Building library for UniqueIPID-0.1.. +# Setup build +Preprocessing library for UniqueIPID-0.1.. +Building library for UniqueIPID-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/UniqueIPID/setup.out b/cabal/cabal-testsuite/PackageTests/UniqueIPID/setup.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/UniqueIPID/setup.out @@ -0,0 +1,10 @@ +# Setup configure +Configuring UniqueIPID-0.1... +# Setup configure +Configuring UniqueIPID-0.1... +# Setup build +Preprocessing library for UniqueIPID-0.1.. +Building library for UniqueIPID-0.1.. +# Setup build +Preprocessing library for UniqueIPID-0.1.. +Building library for UniqueIPID-0.1.. diff --git a/cabal/cabal-testsuite/PackageTests/UniqueIPID/setup.test.hs b/cabal/cabal-testsuite/PackageTests/UniqueIPID/setup.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/UniqueIPID/setup.test.hs @@ -0,0 +1,16 @@ +import Test.Cabal.Prelude +import Data.List +-- Test that setup computes different IPIDs when dependencies change +main = setupAndCabalTest $ do + withPackageDb $ do + withDirectory "P1" $ setup "configure" ["--disable-deterministic"] + withDirectory "P2" $ setup "configure" ["--disable-deterministic"] + withDirectory "P1" $ setup "build" [] + withDirectory "P1" $ setup "build" [] -- rebuild should work + recordMode DoNotRecord $ do + r1 <- withDirectory "P1" $ setup' "register" ["--print-ipid", "--inplace"] + withDirectory "P2" $ setup "build" [] + r2 <- withDirectory "P2" $ setup' "register" ["--print-ipid", "--inplace"] + let exIPID s = takeWhile (/= '\n') $ + head . filter (isPrefixOf $ "UniqueIPID-0.1-") $ (tails s) + assertNotEqual "ipid match" (exIPID $ resultOutput r1) (exIPID $ resultOutput r2) diff --git a/cabal/cabal-testsuite/PackageTests/UserConfig/cabal.out b/cabal/cabal-testsuite/PackageTests/UserConfig/cabal.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/UserConfig/cabal.out @@ -0,0 +1,8 @@ +# cabal user-config +Writing default configuration to /cabal.dist/cabal-config +# cabal user-config +cabal: /cabal.dist/cabal-config already exists. +# cabal user-config +Writing default configuration to /cabal.dist/cabal-config +# cabal user-config +Writing default configuration to /cabal.dist/cabal-config2 diff --git a/cabal/cabal-testsuite/PackageTests/UserConfig/cabal.test.hs b/cabal/cabal-testsuite/PackageTests/UserConfig/cabal.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/PackageTests/UserConfig/cabal.test.hs @@ -0,0 +1,13 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + workdir <- fmap testWorkDir getTestEnv + let conf = workdir "cabal-config" + cabalG ["--config-file", conf] "user-config" ["init"] + shouldExist conf + fails $ cabalG ["--config-file", workdir "cabal-config"] "user-config" ["init"] + cabalG ["--config-file", conf] "user-config" ["-f", "init"] + shouldExist conf + let conf2 = workdir "cabal-config2" + withEnv [("CABAL_CONFIG", Just conf2)] $ do + cabal "user-config" ["init"] + shouldExist conf2 diff --git a/cabal/cabal-testsuite/README.md b/cabal/cabal-testsuite/README.md --- a/cabal/cabal-testsuite/README.md +++ b/cabal/cabal-testsuite/README.md @@ -1,54 +1,311 @@ cabal-testsuite is a suite of integration tests for Cabal-based -frameworks. At the moment it only supports testing against -Setup scripts but we hope to make it more flexible. +frameworks. -Writing package tests -===================== +How to run +---------- -The tests under the [PackageTests] directory define and build packages -that exercise various components of Cabal. Each test case is an [HUnit] -test. The entry point for the test suite, where all the test cases are -listed, is [PackageTests.hs]. There are utilities for calling the stages -of Cabal's build process in [PackageTests/PackageTester.hs]; have a look -at an existing test case to see how they are used. +1. Build `cabal-tests` (`cabal new-build cabal-tests`) +2. Run the `cabal-tests` executable. It will scan for all tests + in your current directory and subdirectories and run them. + To run a specific set of tests, use `cabal-tests PATH ...`. You can + control parallelism using the `-j` flag. -In order to run the tests, `PackageTests` needs to know where the inplace -copy of Cabal being tested is, as well as some information which was -used to configure it. By default, `PackageTests` tries to look at the -`LocalBuildInfo`, but if the format of `LocalBuildInfo` has changed -between the version of Cabal which ran the configure step, and the -version of Cabal we are testing against, this may fail. In that -case, you can manually specify the information we need using -the following environment variables: +There are a few useful flags: -* `CABAL_PACKAGETESTS_GHC` is the path to the GHC you compiled Cabal with -* `CABAL_PACKAGETESTS_WITH_GHC` is the path for the GHC you want to have - Cabal use when running tests; i.e., you can change this to a different - version of GHC to see how Cabal handles that version. If omitted, - it defaults to `CABAL_PACKAGETESTS_GHC`. -* `CABAL_PACKAGETESTS_DB_STACK` is a PATH-style list of package database paths, - `clear`, `global` and `user`. Each component of the list is - interpreted the same way as Cabal's `-package-db` flag. This list - must contain the copy of Cabal you are planning to test against - (as well as its transitive dependencies). By default, we guess - that it is just the global and user database. However, if some of - Cabal's dependencies were installed in a sandbox or other non-standard - location, you will need to add it. Most commonly, if you are are - using 'new-build' you'll need to add - dist-newstyle/packagedb/ghc-VERSION and $HOME/.cabal/store/ghc-VERSION/package.db - to your database stack. (In most situations, the actual inplace - database Cabal was registered into is automatically detected.) +* `--with-cabal PATH` can be used to specify the path of a + `cabal-install` executable. IF YOU DO NOT SPECIFY THIS FLAG, + CABAL INSTALL TESTS WILL NOT RUN. -There are a few extra options to toggle (e.g. `CABAL_PACKAGETESTS_GHC_PKG` -lets you explicitly set ghc-pkg in case Cabal can't autodetect it) but -the three above. +* `--with-ghc PATH` can be used to specify an alternate version of + GHC to ask the tests to compile with. -If you can successfully run the test suite, we'll print out examples -of all of these values for you under "Environment". +* `--builddir DIR` can be used to manually specify the dist directory + that was used to build `cabal-tests`; this can be used if + the autodetection doesn't work correctly (which may be the + case for old versions of GHC.) -[PackageTests]: PackageTests -[HUnit]: http://hackage.haskell.org/package/HUnit -[PackageTests.hs]: PackageTests.hs -[PackageTests/PackageTester.hs]: PackageTests/PackageTester.hs -[detailed]: ../Distribution/TestSuite.hs -[PackageTests/BuildTestSuiteDetailedV09/Check.hs]: PackageTests/BuildTestSuiteDetailedV09/Check.hs +How to write +------------ + +If you learn better by example, just look at the tests that live +in `cabal-testsuite/PackageTests`; if you `git log -p`, you can +see the full contents of various commits which added a test for +various functionality. See if you can find an existing test that +is similar to what you want to test. + +Otherwise, here is a walkthrough: + +1. Create the package(s) that you need for your test in a + new directory. (Currently, tests are stored in `PackageTests` + and `tests`; we might reorganize this soon.) + +2. Create one or more `.test.hs` scripts in your directory, using + the template: + ``` + import Test.Cabal.Prelude + main = setupAndCabalTest $ do + -- your test code here + ``` + + `setupAndCabal` test indicates that invocations of `setup` + should work both for a raw `Setup` script, as well as + `cabal-install` (if your test works only for one or the + other, use `setupTest` or `cabalTest`). + + Code runs in the `TestM` monad, which manages some administrative + environment (e.g., the test that is running, etc.) + `Test.Cabal.Prelude` contains a number of useful functions + for testing implemented in this monad, including the functions `cabal` + and `setup` which let you invoke those respective programs. You should + read through that file to get a sense for what capabilities + are possible (grep for use-sites of functions to see how they + are used). If you don't see something anywhere, that's probably + because it isn't implemented. Implement it! + +3. Run your tests using `cabal-tests` (no need to rebuild when + you add or modify a test; it is automatically picked up.) + The first time you run a test, assuming everything else is + in order, it will complain that the actual output doesn't match + the expected output. Use the `--accept` flag to accept the + output if it makes sense! + +We also support a `.multitest.hs` prefix; eventually this will +allow multiple tests to be defined in one file but run in parallel; +at the moment, these just indicate long running tests that should +be run early (to avoid straggling.) + +Frequently asked questions +-------------------------- + +For all of these answers, to see examples of the functions in +question, grep the test suite. + +**Why isn't some output I added to Cabal showing up in the recorded +test output?** Only "marked" output is picked up by Cabal; currently, +only `notice`, `warn` and `die` produce marked output. Use those +combinators for your output. + +**How do I safely let my test modify version-controlled source files?** +Use `withSourceCopy`. Note that you MUST `git add` +all files which are relevant to the test; otherwise they will not be +available when running the test. + +**How can I add a dependency on a package from Hackage in a test?** +By default, the test suite is completely independent of the contents +of Hackage, to ensure that it keeps working across all GHC versions. +If possible, define the package locally. If the package needs +to be from Hackage (e.g., you are testing the global store code +in new-build), use `withRepo "repo"` to initialize a "fake" Hackage with +the packages placed in the `repo` directory. + +**How do I run an executable that my test built?** The specific +function you should use depends on how you built the executable: + +* If you built it using `Setup build`, use `runExe` +* If you installed it using `Setup install` or `cabal install`, use + `runInstalledExe`. +* If you built it with `cabal new-build`, use `runPlanExe`; note + that you will need to run this inside of a `withPlan` that is + placed *after* you have invoked `new-build`. (Grep + for an example!) + +**How do I turn of accept tests? My test output wobbles to much.** +Use `recordMode DoNotRecord`. This should be a last resort; consider +modifying Cabal so that the output is stable. If you must do this, make +sure you add extra, manual tests to ensure the output looks like what +you expect. + +**How can I manually test for a string in output?** Use the hyphenated +variants of a command (e.g., `cabal'` rather than `cabal`) and use +`assertOutputContains`. Note that this will search over BOTH stdout +and stderr. + +**How do I skip running a test in some environments?** Use the +`skipIf` and `skipUnless` combinators. Useful parameters to test +these with include `hasSharedLibraries`, `hasProfiledLibraries`, +`hasCabalShared`, `ghcVersionIs`, `isWindows`, `isLinux`, `isOSX` +and `hasCabalForGhc`. + +**I programatically modified a file in my test suite, but Cabal/GHC +doesn't seem to be picking it up.** You need to sleep sufficiently +long before editing a file, in order for file system timestamp +resolution to pick it up. Use `withDelay` and `delay` prior to +making a modification. + +**How do I mark a test as broken?** Use `expectBroken`, which takes +the ticket number as its first argument. Note that this does NOT +handle accept-test brokenness, so you will have to add a manual +string output test, if that is how your test is "failing." + +Hermetic tests +-------------- + +By default, we run tests directly on the source code that is checked into the +source code repository. However, some tests require programatically +modifying source files, or interact with Cabal commands which are +not hermetic (e.g., `cabal freeze`). In this case, cabal-testsuite +supports opting into a hermetic test, where we first make copy of all +the relevant source code before starting the test. You can opt into +this mode using the 'withSourceCopy' combinator (search for examples!) +This mode is subject to the following limitations: + +* You must be running the test inside a valid Git checkout of the test + suite (`withSourceCopy` uses Git to determine which files should be copied.) + +* You must `git add` all files which are relevant to the test, otherwise + they will not be copied. + +* The source copy is still made at a well-known location, so running + a test is still not reentrant. (See also Known Limitations.) + +Design notes +------------ + +This is the second rewrite of the integration testing framework. The +primary goal was to use Haskell as the test language (letting us take +advantage of a real programming language, and use utilities provided to +us by the Cabal library itself), while at the same time compensating for +two perceived problems of pure-Haskell test suites: + +* Haskell test suites are generally compiled before they run + (for example, this is the modus operandi of `cabal test`). + In practice, this results in a long edit-recompile cycle + when working on tests. This hurts a lot when you would + like to experimentally edit a test when debugging an issue. + +* Haskell's metaprogramming facilities (e.g., Template Haskell) + can't handle dynamically loading modules from the file system; + thus, there ends up being a considerable amount of boilerplate + needed to "wire" up test cases to the central test runner. + +Our approach to address these issues is to maintain Haskell test scripts +as self-contained programs which are run by the GHCi interpreter. +This is not altogether trivial, and so there are a few important +technical innovations to make this work: + +* Unlike a traditional test program which can be built by the Cabal + build system, these test scripts must be interpretable at + runtime (outside of the build system.) Our approach to handle + this is to link against the same version of Cabal that was + used to build the top-level test program (by way of a Custom + setup linked against the Cabal library under test) and then + use this library to compute the necessary GHC flags to pass + to these scripts. + +* The startup latency of `runghc` can be quite high, which adds up + when you have many tests. To solve this, in `Test.Cabal.Server` + we have an implementation an GHCi server, for which we can reuse + a GHCi instance as we are running test scripts. It took some + technical ingenuity to implement this, but the result is that + running scripts is essentially free. + +Here is the general outline of how the `cabal-tests` program operates: + +1. It first loads the cached `LocalBuildInfo` associated with the + host build system (which was responsible for building `cabal-tests` + in the first place.) This information lets us compute the + flags that we will use to subsequently invoke GHC. + +2. We then recursively scan the current working directory, looking + for files suffixed `.test.hs`; these are the test scripts we + will run. + +3. For every thread specified via the `-j`, we spawn a GHCi + server, and then use these to run the test scripts until all + test scripts have been run. + +The new `cabal-tests` runner doesn't use Tasty because I couldn't +figure out how to get out the threading setting, and then spawn +that many GHCi servers to service the running threads. Improvements +welcome. + +Expect tests +------------ + +An expect test is a test where we read out the output of the test +and compare it directly against a saved copy of the test output. +When test output changes, you can ask the test suite to "accept" +the new output, which automatically overwrites the old expected +test output with the new. + +Supporting expect tests with Cabal is challenging, because Cabal +interacts with multiple versions of external components (most +prominently GHC) with different variants of their output, and no +one wants to rerun a test on four different versions of GHC to make +sure we've picked up the correct output in all cases. + +Still, we'd like to take advantage of expect tests for Cabal's error +reporting. So here's our strategy: + +1. We have a new verbosity flag +markoutput which lets you toggle the emission + of '-----BEGIN CABAL OUTPUT-----' and '-----END CABAL OUTPUT-----' + stanzas. + +2. When someone requests an expect test, we ONLY consider output between + these flags. + +The expectation is that Cabal will only enclose output it controls +between these stanzas. In practice, this just means we wrap die, +warn and notice with these markers. + +An added benefit of this strategy is that we can continue operating +at high verbosity by default (which is very helpful for having useful +diagnostic information immediately, e.g. in CI.) + +We also need to deal with nondeterminism in test output in some +situations. Here are the most common ones: + +* Dependency solving output on failure is still non-deterministic, due to + its dependence on the global package database. We're tracking this + in https://github.com/haskell/cabal/issues/4332 but for now, we're + not running expect tests on this output. + +* Tests against Custom setup will build against the Cabal that shipped with + GHC, so you need to be careful NOT to record this output (since we + don't control that output.) + +* We have some munging on the output, to remove common sources of + non-determinism: paths, GHC versions, boot package versions, etc. + Check normalizeOutput to see what we do. Note that we save + *normalized* output, so if you modify the normalizer you will + need to rerun the test suite accepting everything. + +* The Setup interface gets a `--enable-deterministic` flag which we + pass by default. The intent is to make Cabal more deterministic; + for example, with this flag we no longer compute a hash when + computing IPIDs, but just use the tag `-inplace`. You can manually + disable this using `--disable-deterministic` (as is the case with + `UniqueIPID`.) + +Some other notes: + +* It's good style to put default-language in all your stanzas, so + Cabal doesn't complain about it (that warning is marked!) Ditto + with cabal-version at the top of your Cabal file. + +* If you can't get the output of a test to be deterministic, no + problem: just exclude it from recording and do a manual test + on the output for the string you're looking for. Try to be + deterministic, but sometimes it's not (easily) possible. + +Non-goals +--------- + +Here are some things we do not currently plan on supporting: + +* A file format for specifying multiple packages and source files. + While in principle there is nothing wrong with making it easier + to write tests, tests stored in this manner are more difficult + to debug with, as they must first be "decompressed" into a full + folder hierarchy before they can be interacted with. (But some + of our tests need substantial setup; for example, tests that + have to setup a package repository. In this case, because there + already is a setup necessary, we might consider making things easier here.) + +Known limitations +----------------- + +* Tests are NOT reentrant: test build products are always built into + the same location, and if you run the same test at the same time, + you will clobber each other. This is convenient for debugging and + doesn't seem to be a problem in practice. diff --git a/cabal/cabal-testsuite/Test/Cabal/CheckArMetadata.hs b/cabal/cabal-testsuite/Test/Cabal/CheckArMetadata.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/Test/Cabal/CheckArMetadata.hs @@ -0,0 +1,88 @@ +---------------------------------------------------------------------------- +-- | +-- Module : Test.Cabal.CheckArMetadata +-- Created : 8 July 2017 +-- +-- Check well-formedness of metadata of .a files that @ar@ command produces. +-- One of the crucial properties of .a files is that they must be +-- deterministic - i.e. they must not include creation date as their +-- contents to facilitate deterministic builds. +---------------------------------------------------------------------------- + +{-# LANGUAGE OverloadedStrings #-} + +module Test.Cabal.CheckArMetadata (checkMetadata) where + +import Test.Cabal.Prelude + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Char (isSpace) +import System.IO + +import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) +import Distribution.Package (getHSLibraryName) +import Distribution.Version (mkVersion) +import Distribution.Simple.Compiler (compilerId) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, compiler, localUnitId) + +-- Almost a copypasta of Distribution.Simple.Program.Ar.wipeMetadata +checkMetadata :: LocalBuildInfo -> FilePath -> IO () +checkMetadata lbi dir = withBinaryFile path ReadMode $ \ h -> + hFileSize h >>= checkArchive h + where + path = dir "lib" ++ getHSLibraryName (localUnitId lbi) ++ ".a" + + _ghc_7_10 = case compilerId (compiler lbi) of + CompilerId GHC version | version >= mkVersion [7, 10] -> True + _ -> False + + checkError msg = assertFailure ( + "PackageTests.DeterministicAr.checkMetadata: " ++ msg ++ + " in " ++ path) >> undefined + archLF = "!\x0a" -- global magic, 8 bytes + x60LF = "\x60\x0a" -- header magic, 2 bytes + metadata = BS.concat + [ "0 " -- mtime, 12 bytes + , "0 " -- UID, 6 bytes + , "0 " -- GID, 6 bytes + , "0644 " -- mode, 8 bytes + ] + headerSize = 60 + + -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details + checkArchive :: Handle -> Integer -> IO () + checkArchive h archiveSize = do + global <- BS.hGet h (BS.length archLF) + unless (global == archLF) $ checkError "Bad global header" + checkHeader (toInteger $ BS.length archLF) + + where + checkHeader :: Integer -> IO () + checkHeader offset = case compare offset archiveSize of + EQ -> return () + GT -> checkError (atOffset "Archive truncated") + LT -> do + header <- BS.hGet h headerSize + unless (BS.length header == headerSize) $ + checkError (atOffset "Short header") + let magic = BS.drop 58 header + unless (magic == x60LF) . checkError . atOffset $ + "Bad magic " ++ show magic ++ " in header" + + unless (metadata == BS.take 32 (BS.drop 16 header)) + . checkError . atOffset $ "Metadata has changed" + + let size = BS.take 10 $ BS.drop 48 header + objSize <- case reads (BS8.unpack size) of + [(n, s)] | all isSpace s -> return n + _ -> checkError (atOffset "Bad file size in header") + + let nextHeader = offset + toInteger headerSize + + -- Odd objects are padded with an extra '\x0a' + if odd objSize then objSize + 1 else objSize + hSeek h AbsoluteSeek nextHeader + checkHeader nextHeader + + where + atOffset msg = msg ++ " at offset " ++ show offset diff --git a/cabal/cabal-testsuite/Test/Cabal/Monad.hs b/cabal/cabal-testsuite/Test/Cabal/Monad.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/Test/Cabal/Monad.hs @@ -0,0 +1,659 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The test monad +module Test.Cabal.Monad ( + -- * High-level runners + setupAndCabalTest, + setupTest, + cabalTest, + -- * The monad + TestM, + runTestM, + -- * Helper functions + programPathM, + requireProgramM, + isAvailableProgram, + hackageRepoToolProgram, + gitProgram, + cabalProgram, + diffProgram, + -- * The test environment + TestEnv(..), + getTestEnv, + -- * Recording mode + RecordMode(..), + testRecordMode, + -- * Regex utility (move me somewhere else) + resub, + -- * Derived values from 'TestEnv' + testCurrentDir, + testWorkDir, + testPrefixDir, + testDistDir, + testPackageDbDir, + testHomeDir, + testSandboxDir, + testSandboxConfigFile, + testRepoDir, + testKeysDir, + testSourceCopyDir, + testUserCabalConfigFile, + testActualFile, + -- * Skipping tests + skip, + skipIf, + skipUnless, + skipExitCode, + -- * Known broken tests + expectedBroken, + unexpectedSuccess, + expectedBrokenExitCode, + unexpectedSuccessExitCode, + -- whenHasSharedLibraries, + -- * Arguments (TODO: move me) + CommonArgs(..), + renderCommonArgs, + commonArgParser, +) where + +import Test.Cabal.Script +import Test.Cabal.Plan + +import Distribution.Simple.Compiler + ( PackageDBStack, PackageDB(..), compilerFlavor + , Compiler, compilerVersion ) +import Distribution.System +import Distribution.Simple.Program.Db +import Distribution.Simple.Program +import Distribution.Simple.Configure + ( getPersistBuildConfig, configCompilerEx ) +import Distribution.Types.LocalBuildInfo +import Distribution.Version +import Distribution.Text +import Distribution.Package + +import Distribution.Verbosity + +import qualified Control.Exception as E +import Control.Monad +import Control.Monad.Trans.Reader +import Control.Monad.IO.Class +import Data.Maybe +import Control.Applicative +import Data.Monoid +import qualified Data.Foldable as F +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.IO.Error (isDoesNotExistError) +import System.Process hiding (env) +import Options.Applicative +import Text.Regex + +data CommonArgs = CommonArgs { + argCabalInstallPath :: Maybe FilePath, + argGhcPath :: Maybe FilePath, + argHackageRepoToolPath :: Maybe FilePath, + argHaddockPath :: Maybe FilePath, + argAccept :: Bool, + argSkipSetupTests :: Bool + } + +commonArgParser :: Parser CommonArgs +commonArgParser = CommonArgs + <$> optional (option str + ( help "Path to cabal-install executable to test" + <> long "with-cabal" + <> metavar "PATH" + )) + <*> optional (option str + ( help "GHC to ask Cabal to use via --with-ghc flag" + <> short 'w' + <> long "with-ghc" + <> metavar "PATH" + )) + <*> optional (option str + ( help "Path to hackage-repo-tool to use for repository manipulation" + <> long "with-hackage-repo-tool" + <> metavar "PATH" + )) + <*> optional (option str + ( help "Path to haddock to use for --with-haddock flag" + <> long "with-haddock" + <> metavar "PATH" + )) + <*> switch + ( long "accept" + <> help "Accept output" + ) + <*> switch (long "skip-setup-tests" <> help "Skip setup tests") + +renderCommonArgs :: CommonArgs -> [String] +renderCommonArgs args = + maybe [] (\x -> ["--with-cabal", x]) (argCabalInstallPath args) ++ + maybe [] (\x -> ["--with-ghc", x]) (argGhcPath args) ++ + maybe [] (\x -> ["--with-haddock", x]) (argHaddockPath args) ++ + maybe [] (\x -> ["--with-hackage-repo-tool", x]) (argHackageRepoToolPath args) ++ + (if argAccept args then ["--accept"] else []) ++ + (if argSkipSetupTests args then ["--skip-setup-tests"] else []) + +data TestArgs = TestArgs { + testArgDistDir :: FilePath, + testArgScriptPath :: FilePath, + testCommonArgs :: CommonArgs + } + +testArgParser :: Parser TestArgs +testArgParser = TestArgs + <$> option str + ( help "Build directory of cabal-testsuite" + <> long "builddir" + <> metavar "DIR") + <*> argument str ( metavar "FILE") + <*> commonArgParser + +skip :: TestM () +skip = liftIO $ do + putStrLn "SKIP" + exitWith (ExitFailure skipExitCode) + +skipIf :: Bool -> TestM () +skipIf b = when b skip + +skipUnless :: Bool -> TestM () +skipUnless b = unless b skip + +expectedBroken :: TestM () +expectedBroken = liftIO $ do + putStrLn "EXPECTED FAIL" + exitWith (ExitFailure expectedBrokenExitCode) + +unexpectedSuccess :: TestM () +unexpectedSuccess = liftIO $ do + putStrLn "UNEXPECTED OK" + exitWith (ExitFailure unexpectedSuccessExitCode) + +skipExitCode :: Int +skipExitCode = 64 + +expectedBrokenExitCode :: Int +expectedBrokenExitCode = 65 + +unexpectedSuccessExitCode :: Int +unexpectedSuccessExitCode = 66 + +catchSkip :: IO a -> IO a -> IO a +catchSkip m r = m `E.catch` \e -> + case e of + ExitFailure c | c == skipExitCode + -> r + _ -> E.throwIO e + +setupAndCabalTest :: TestM () -> IO () +setupAndCabalTest m = do + r1 <- (setupTest m >> return False) `catchSkip` return True + r2 <- (cabalTest' "cabal" m >> return False) `catchSkip` return True + when (r1 && r2) $ do + putStrLn "SKIP" + exitWith (ExitFailure skipExitCode) + +setupTest :: TestM () -> IO () +setupTest m = runTestM "" $ do + env <- getTestEnv + skipIf (testSkipSetupTests env) + m + +cabalTest :: TestM () -> IO () +cabalTest = cabalTest' "" + +cabalTest' :: String -> TestM () -> IO () +cabalTest' mode m = runTestM mode $ do + skipUnless =<< isAvailableProgram cabalProgram + withReaderT (\nenv -> nenv { testCabalInstallAsSetup = True }) m + +type TestM = ReaderT TestEnv IO + +gitProgram :: Program +gitProgram = simpleProgram "git" + +hackageRepoToolProgram :: Program +hackageRepoToolProgram = simpleProgram "hackage-repo-tool" + +cabalProgram :: Program +cabalProgram = (simpleProgram "cabal") { + -- Do NOT search for executable named cabal, it's probably + -- not the one you were intending to test + programFindLocation = \_ _ -> return Nothing + } + +diffProgram :: Program +diffProgram = simpleProgram "diff" + +-- | Run a test in the test monad according to program's arguments. +runTestM :: String -> TestM a -> IO a +runTestM mode m = do + args <- execParser (info testArgParser mempty) + let dist_dir = testArgDistDir args + (script_dir0, script_filename) = splitFileName (testArgScriptPath args) + script_base = dropExtensions script_filename + -- Canonicalize this so that it is stable across working directory changes + script_dir <- canonicalizePath script_dir0 + lbi <- getPersistBuildConfig dist_dir + let verbosity = normal -- TODO: configurable + senv <- mkScriptEnv verbosity lbi + -- Add test suite specific programs + let program_db0 = + addKnownPrograms + ([gitProgram, hackageRepoToolProgram, cabalProgram, diffProgram] ++ builtinPrograms) + (withPrograms lbi) + -- Reconfigure according to user flags + let cargs = testCommonArgs args + + -- Reconfigure GHC + (comp, platform, program_db2) <- case argGhcPath cargs of + Nothing -> return (compiler lbi, hostPlatform lbi, program_db0) + Just ghc_path -> do + -- All the things that get updated paths from + -- configCompilerEx. The point is to make sure + -- we reconfigure these when we need them. + let program_db1 = unconfigureProgram "ghc" + . unconfigureProgram "ghc-pkg" + . unconfigureProgram "hsc2hs" + . unconfigureProgram "haddock" + . unconfigureProgram "hpc" + . unconfigureProgram "runghc" + . unconfigureProgram "gcc" + . unconfigureProgram "ld" + . unconfigureProgram "ar" + . unconfigureProgram "strip" + $ program_db0 + -- TODO: this actually leaves a pile of things unconfigured. + -- Optimal strategy for us is to lazily configure them, so + -- we don't pay for things we don't need. A bit difficult + -- to do in the current design. + configCompilerEx + (Just (compilerFlavor (compiler lbi))) + (Just ghc_path) + Nothing + program_db1 + verbosity + + program_db3 <- + reconfigurePrograms verbosity + ([("cabal", p) | p <- maybeToList (argCabalInstallPath cargs)] ++ + [("hackage-repo-tool", p) + | p <- maybeToList (argHackageRepoToolPath cargs)] ++ + [("haddock", p) | p <- maybeToList (argHaddockPath cargs)]) + [] -- --prog-options not supported ATM + program_db2 + -- configCompilerEx only marks some programs as known, so to pick + -- them up we must configure them + program_db <- configureAllKnownPrograms verbosity program_db3 + + let db_stack = + case argGhcPath (testCommonArgs args) of + Nothing -> withPackageDB lbi + -- Can't use the build package db stack since they + -- are all for the wrong versions! TODO: Make + -- this configurable + Just _ -> [GlobalPackageDB] + env = TestEnv { + testSourceDir = script_dir, + testSubName = script_base, + testMode = mode, + testProgramDb = program_db, + testPlatform = platform, + testCompiler = comp, + testPackageDBStack = db_stack, + testVerbosity = verbosity, + testMtimeChangeDelay = Nothing, + testScriptEnv = senv, + testSetupPath = dist_dir "setup" "setup", + testSkipSetupTests = argSkipSetupTests (testCommonArgs args), + testHaveCabalShared = withSharedLib lbi, + testEnvironment = + -- Try to avoid Unicode output + [ ("LC_ALL", Just "C") + -- Hermetic builds (knot-tied) + , ("HOME", Just (testHomeDir env))], + testShouldFail = False, + testRelativeCurrentDir = ".", + testHavePackageDb = False, + testHaveSandbox = False, + testHaveRepo = False, + testHaveSourceCopy = False, + testCabalInstallAsSetup = False, + testCabalProjectFile = "cabal.project", + testPlan = Nothing, + testRecordDefaultMode = DoNotRecord, + testRecordUserMode = Nothing, + testRecordNormalizer = id + } + let go = do cleanup + r <- m + check_expect (argAccept (testCommonArgs args)) + return r + runReaderT go env + where + cleanup = do + env <- getTestEnv + onlyIfExists . removeDirectoryRecursive $ testWorkDir env + -- NB: it's important to initialize this ourselves, as + -- the default configuration hardcodes Hackage, which we do + -- NOT want to assume for these tests (no test should + -- hit Hackage.) + liftIO $ createDirectoryIfMissing True (testHomeDir env ".cabal") + ghc_path <- programPathM ghcProgram + liftIO $ writeFile (testUserCabalConfigFile env) + $ unlines [ "with-compiler: " ++ ghc_path ] + + check_expect accept = do + env <- getTestEnv + actual_raw <- liftIO $ readFileOrEmpty (testActualFile env) + expect <- liftIO $ readFileOrEmpty (testExpectFile env) + norm_env <- mkNormalizerEnv + let actual = normalizeOutput norm_env actual_raw + when (words actual /= words expect) $ do + -- First try whitespace insensitive diff + let actual_fp = testNormalizedActualFile env + expect_fp = testNormalizedExpectFile env + liftIO $ writeFile actual_fp actual + liftIO $ writeFile expect_fp expect + liftIO $ putStrLn "Actual output differs from expected:" + b <- diff ["-uw"] expect_fp actual_fp + unless b . void $ diff ["-u"] expect_fp actual_fp + if accept + then do liftIO $ putStrLn "Accepting new output." + liftIO $ writeFileNoCR (testExpectFile env) actual + else liftIO $ exitWith (ExitFailure 1) + +readFileOrEmpty :: FilePath -> IO String +readFileOrEmpty f = readFile f `E.catch` \e -> + if isDoesNotExistError e + then return "" + else E.throwIO e + +-- | Runs 'diff' with some arguments on two files, outputting the +-- diff to stderr, and returning true if the two files differ +diff :: [String] -> FilePath -> FilePath -> TestM Bool +diff args path1 path2 = do + diff_path <- programPathM diffProgram + (_,_,_,h) <- liftIO $ + createProcess (proc diff_path (args ++ [path1, path2])) { + std_out = UseHandle stderr + } + r <- liftIO $ waitForProcess h + return (r /= ExitSuccess) + +-- | Write a file with no CRs, always. +writeFileNoCR :: FilePath -> String -> IO () +writeFileNoCR f s = + withFile f WriteMode $ \h -> do + hSetNewlineMode h noNewlineTranslation + hPutStr h s + +normalizeOutput :: NormalizerEnv -> String -> String +normalizeOutput nenv = + -- Munge away .exe suffix on filenames (Windows) + resub "([A-Za-z0-9.-]+)\\.exe" "\\1" + -- Normalize backslashes to forward slashes to normalize + -- file paths + . map (\c -> if c == '\\' then '/' else c) + -- Install path frequently has architecture specific elements, so + -- nub it out + . resub "Installing (.+) in .+" "Installing \\1 in " + -- Things that look like libraries + . resub "libHS[A-Za-z0-9.-]+\\.(so|dll|a|dynlib)" "" + -- This is dumb but I don't feel like pulling in another dep for + -- string search-replace. Make sure we do this before backslash + -- normalization! + . resub (posixRegexEscape (normalizerRoot nenv)) "/" + . appEndo (F.fold (map (Endo . packageIdRegex) (normalizerKnownPackages nenv))) + -- Look for foo-0.1/installed-0d6... + -- These installed packages will vary depending on GHC version + -- Makes assumption that installed packages don't have numbers + -- in package name segment. + -- Apply this before packageIdRegex, otherwise this regex doesn't match. + . resub "([a-zA-Z]+(-[a-zA-Z])*)-[0-9]+(\\.[0-9]+)*/installed-[A-Za-z0-9.]+" + "\\1-/installed-..." + . -- Normalize architecture + resub (posixRegexEscape (display (normalizerPlatform nenv))) "" + -- Normalize the current GHC version. Apply this BEFORE packageIdRegex, + -- which will pick up the install ghc library (which doesn't have the + -- date glob). + . (if normalizerGhcVersion nenv /= nullVersion + then resub (posixRegexEscape (display (normalizerGhcVersion nenv)) + -- Also glob the date, for nightly GHC builds + ++ "(\\.[0-9]+)?") + "" + else id) + where + packageIdRegex pid = + resub (posixRegexEscape (display pid) ++ "(-[A-Za-z0-9.-]+)?") + ((display (packageName pid)) ++ "-") + +data NormalizerEnv = NormalizerEnv { + normalizerRoot :: FilePath, + normalizerGhcVersion :: Version, + normalizerKnownPackages :: [PackageId], + normalizerPlatform :: Platform + } + +mkNormalizerEnv :: TestM NormalizerEnv +mkNormalizerEnv = do + env <- getTestEnv + ghc_pkg_program <- requireProgramM ghcPkgProgram + -- Arguably we should use Cabal's APIs but I am too lazy + -- to remember what it is + list_out <- liftIO $ readProcess (programPath ghc_pkg_program) + ["list", "--global", "--simple-output"] "" + return NormalizerEnv { + normalizerRoot + = addTrailingPathSeparator (testSourceDir env), + normalizerGhcVersion + = compilerVersion (testCompiler env), + normalizerKnownPackages + = mapMaybe simpleParse (words list_out), + normalizerPlatform + = testPlatform env + } + +posixSpecialChars :: [Char] +posixSpecialChars = ".^$*+?()[{\\|" + +posixRegexEscape :: String -> String +posixRegexEscape = concatMap (\c -> if c `elem` posixSpecialChars then ['\\', c] else [c]) + +resub :: String {- search -} -> String {- replace -} -> String {- input -} -> String +resub search replace s = + subRegex (mkRegex search) s replace + +requireProgramM :: Program -> TestM ConfiguredProgram +requireProgramM program = do + env <- getTestEnv + (configured_program, _) <- liftIO $ + requireProgram (testVerbosity env) program (testProgramDb env) + return configured_program + +programPathM :: Program -> TestM FilePath +programPathM program = do + fmap programPath (requireProgramM program) + +isAvailableProgram :: Program -> TestM Bool +isAvailableProgram program = do + env <- getTestEnv + case lookupProgram program (testProgramDb env) of + Just _ -> return True + Nothing -> do + -- It might not have been configured. Try to configure. + progdb <- liftIO $ configureProgram (testVerbosity env) program (testProgramDb env) + case lookupProgram program progdb of + Just _ -> return True + Nothing -> return False + +-- | Run an IO action, and suppress a "does not exist" error. +onlyIfExists :: MonadIO m => IO () -> m () +onlyIfExists m = + liftIO $ E.catch m $ \(e :: IOError) -> + unless (isDoesNotExistError e) $ E.throwIO e + +data TestEnv = TestEnv + -- UNCHANGING: + + { + -- | Path to the test directory, as specified by path to test + -- script. + testSourceDir :: FilePath + -- | Test sub-name, used to qualify dist/database directory to avoid + -- conflicts. + , testSubName :: String + -- | Test mode, further qualifies multiple invocations of the + -- same test source code. + , testMode :: String + -- | Program database to use when we want ghc, ghc-pkg, etc. + , testProgramDb :: ProgramDb + -- | Compiler we are running tests for + , testCompiler :: Compiler + -- | Platform we are running tests on + , testPlatform :: Platform + -- | Package database stack (actually this changes lol) + , testPackageDBStack :: PackageDBStack + -- | How verbose to be + , testVerbosity :: Verbosity + -- | How long we should 'threadDelay' to make sure the file timestamp is + -- updated correctly for recompilation tests. Nothing if we haven't + -- calibrated yet. + , testMtimeChangeDelay :: Maybe Int + -- | Script environment for runghc + , testScriptEnv :: ScriptEnv + -- | Setup script path + , testSetupPath :: FilePath + -- | Skip Setup tests? + , testSkipSetupTests :: Bool + -- | Do we have shared libraries for the Cabal-under-tests? + -- This is used for example to determine whether we can build + -- detailed-0.9 tests dynamically, since they link against Cabal-under-test. + , testHaveCabalShared :: Bool + + -- CHANGING: + + -- | Environment override + , testEnvironment :: [(String, Maybe String)] + -- | When true, we invert the meaning of command execution failure + , testShouldFail :: Bool + -- | The current working directory, relative to 'testSourceDir' + , testRelativeCurrentDir :: FilePath + -- | Says if we've initialized the per-test package DB + , testHavePackageDb :: Bool + -- | Says if we're working in a sandbox + , testHaveSandbox :: Bool + -- | Says if we've setup a repository + , testHaveRepo :: Bool + -- | Says if we've copied the source to a hermetic directory + , testHaveSourceCopy :: Bool + -- | Says if we're testing cabal-install as setup + , testCabalInstallAsSetup :: Bool + -- | Says what cabal.project file to use (probed) + , testCabalProjectFile :: FilePath + -- | Cached record of the plan metadata from a new-build + -- invocation; controlled by 'withPlan'. + , testPlan :: Maybe Plan + -- | If user mode is not set, this is the record mode we default to. + , testRecordDefaultMode :: RecordMode + -- | User explicitly set record mode. Not implemented ATM. + , testRecordUserMode :: Maybe RecordMode + -- | Function to normalize recorded output + , testRecordNormalizer :: String -> String + } + +testRecordMode :: TestEnv -> RecordMode +testRecordMode env = fromMaybe (testRecordDefaultMode env) (testRecordUserMode env) + +data RecordMode = DoNotRecord | RecordMarked | RecordAll + deriving (Show, Eq, Ord) + +getTestEnv :: TestM TestEnv +getTestEnv = ask + +------------------------------------------------------------------------ +-- * Directories + +-- | The absolute path to the root of the package directory; it's +-- where the Cabal file lives. This is what you want the CWD of cabal +-- calls to be. +testCurrentDir :: TestEnv -> FilePath +testCurrentDir env = + (if testHaveSourceCopy env + then testSourceCopyDir env + else testSourceDir env) testRelativeCurrentDir env + +testName :: TestEnv -> String +testName env = testSubName env <.> testMode env + +-- | The absolute path to the directory containing all the +-- files for ALL tests associated with a test (respecting +-- subtests.) To clean, you ONLY need to delete this directory. +testWorkDir :: TestEnv -> FilePath +testWorkDir env = + testSourceDir env (testName env <.> "dist") + +-- | The absolute prefix where installs go. +testPrefixDir :: TestEnv -> FilePath +testPrefixDir env = testWorkDir env "usr" + +-- | The absolute path to the build directory that should be used +-- for the current package in a test. +testDistDir :: TestEnv -> FilePath +testDistDir env = testWorkDir env "work" testRelativeCurrentDir env "dist" + +-- | The absolute path to the shared package database that should +-- be used by all packages in this test. +testPackageDbDir :: TestEnv -> FilePath +testPackageDbDir env = testWorkDir env "packagedb" + +-- | The absolute prefix where our simulated HOME directory is. +testHomeDir :: TestEnv -> FilePath +testHomeDir env = testWorkDir env "home" + +-- | The absolute prefix of our sandbox directory +testSandboxDir :: TestEnv -> FilePath +testSandboxDir env = testWorkDir env "sandbox" + +-- | The sandbox configuration file +testSandboxConfigFile :: TestEnv -> FilePath +testSandboxConfigFile env = testWorkDir env "cabal.sandbox.config" + +-- | The absolute prefix of our local secure repository, which we +-- use to simulate "external" packages +testRepoDir :: TestEnv -> FilePath +testRepoDir env = testWorkDir env "repo" + +-- | The absolute prefix of keys for the test. +testKeysDir :: TestEnv -> FilePath +testKeysDir env = testWorkDir env "keys" + +-- | If 'withSourceCopy' is used, where the source files go. +testSourceCopyDir :: TestEnv -> FilePath +testSourceCopyDir env = testWorkDir env "source" + +-- | The user cabal config file +-- TODO: Not obviously working on Windows +testUserCabalConfigFile :: TestEnv -> FilePath +testUserCabalConfigFile env = testHomeDir env ".cabal" "config" + +-- | The file where the expected output of the test lives +testExpectFile :: TestEnv -> FilePath +testExpectFile env = testSourceDir env testName env <.> "out" + +-- | Where we store the actual output +testActualFile :: TestEnv -> FilePath +testActualFile env = testWorkDir env testName env <.> "comp.out" + +-- | Where we will write the normalized actual file (for diffing) +testNormalizedActualFile :: TestEnv -> FilePath +testNormalizedActualFile env = testActualFile env <.> "normalized" + +-- | Where we will write the normalized expected file (for diffing) +testNormalizedExpectFile :: TestEnv -> FilePath +testNormalizedExpectFile env = testWorkDir env testName env <.> "out.normalized" diff --git a/cabal/cabal-testsuite/Test/Cabal/Plan.hs b/cabal/cabal-testsuite/Test/Cabal/Plan.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/Test/Cabal/Plan.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Utilities for understanding @plan.json@. +module Test.Cabal.Plan ( + Plan, + planDistDir, +) where + +import Distribution.Text +import Distribution.Types.ComponentName +import Distribution.Package +import qualified Data.Text as Text +import Data.Aeson +import Data.Aeson.Types +import Control.Monad + +-- TODO: index this +data Plan = Plan { planInstallPlan :: [InstallItem] } + +data InstallItem + = APreExisting + | AConfiguredGlobal + | AConfiguredInplace ConfiguredInplace + +-- local or inplace package +data ConfiguredInplace = ConfiguredInplace + { configuredInplaceDistDir :: FilePath + , configuredInplacePackageName :: PackageName + , configuredInplaceComponentName :: Maybe ComponentName } + +instance FromJSON Plan where + parseJSON (Object v) = fmap Plan (v .: "install-plan") + parseJSON invalid = typeMismatch "Plan" invalid + +instance FromJSON InstallItem where + parseJSON obj@(Object v) = do + t <- v .: "type" + case t :: String of + "pre-existing" -> return APreExisting + "configured" -> do + s <- v .: "style" + case s :: String of + "global" -> return AConfiguredGlobal + "inplace" -> AConfiguredInplace `fmap` parseJSON obj + "local" -> AConfiguredInplace `fmap` parseJSON obj + _ -> fail $ "unrecognized value of 'style' field: " ++ s + _ -> fail "unrecognized value of 'type' field" + parseJSON invalid = typeMismatch "InstallItem" invalid + +instance FromJSON ConfiguredInplace where + parseJSON (Object v) = do + dist_dir <- v .: "dist-dir" + pkg_name <- v .: "pkg-name" + component_name <- v .:? "component-name" + return (ConfiguredInplace dist_dir pkg_name component_name) + parseJSON invalid = typeMismatch "ConfiguredInplace" invalid + +instance FromJSON PackageName where + parseJSON (String t) = return (mkPackageName (Text.unpack t)) + parseJSON invalid = typeMismatch "PackageName" invalid + +instance FromJSON ComponentName where + parseJSON (String t) = + case simpleParse s of + Nothing -> fail ("could not parse component-name: " ++ s) + Just r -> return r + where s = Text.unpack t + parseJSON invalid = typeMismatch "ComponentName" invalid + +planDistDir :: Plan -> PackageName -> ComponentName -> FilePath +planDistDir plan pkg_name cname = + case concatMap p (planInstallPlan plan) of + [x] -> x + [] -> error $ "planDistDir: component " ++ display cname + ++ " of package " ++ display pkg_name ++ " either does not" + ++ " exist in the install plan or does not have a dist-dir" + _ -> error $ "planDistDir: found multiple copies of component " ++ display cname + ++ " of package " ++ display pkg_name ++ " in install plan" + where + p APreExisting = [] + p AConfiguredGlobal = [] + p (AConfiguredInplace conf) = do + guard (configuredInplacePackageName conf == pkg_name) + guard $ case configuredInplaceComponentName conf of + Nothing -> True + Just cname' -> cname == cname' + return (configuredInplaceDistDir conf) diff --git a/cabal/cabal-testsuite/Test/Cabal/Prelude.hs b/cabal/cabal-testsuite/Test/Cabal/Prelude.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/Test/Cabal/Prelude.hs @@ -0,0 +1,927 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} + +-- | Generally useful definitions that we expect most test scripts +-- to use. +module Test.Cabal.Prelude ( + module Test.Cabal.Prelude, + module Test.Cabal.Monad, + module Test.Cabal.Run, + module System.FilePath, + module Control.Monad, + module Distribution.Version, + module Distribution.Simple.Program, +) where + +import Test.Cabal.Script +import Test.Cabal.Run +import Test.Cabal.Monad +import Test.Cabal.Plan + +import Distribution.Compat.Time (calibrateMtimeChangeDelay) +import Distribution.Simple.Compiler (PackageDBStack, PackageDB(..)) +import Distribution.Simple.Program.Types +import Distribution.Simple.Program.Db +import Distribution.Simple.Program +import Distribution.System (OS(Windows,Linux,OSX), buildOS) +import Distribution.Simple.Utils + ( withFileContents, tryFindPackageDesc ) +import Distribution.Simple.Configure + ( getPersistBuildConfig ) +import Distribution.Version +import Distribution.Package +import Distribution.Types.UnqualComponentName +import Distribution.Types.LocalBuildInfo +import Distribution.PackageDescription +import Distribution.PackageDescription.Parsec + +import Distribution.Compat.Stack + +import Text.Regex.TDFA + +import Control.Concurrent.Async +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Lazy as BSL +import Control.Monad +import Control.Monad.Trans.Reader +import Control.Monad.IO.Class +import qualified Data.ByteString.Char8 as C +import Data.List +import Data.Maybe +import System.Exit +import System.FilePath +import Control.Concurrent (threadDelay) +import qualified Data.Char as Char +import System.Directory + +#ifndef mingw32_HOST_OS +import Control.Monad.Catch ( bracket_ ) +import System.Posix.Files ( createSymbolicLink ) +#endif + +------------------------------------------------------------------------ +-- * Utilities + +runM :: FilePath -> [String] -> TestM Result +runM path args = do + env <- getTestEnv + r <- liftIO $ run (testVerbosity env) + (Just (testCurrentDir env)) + (testEnvironment env) + path + args + recordLog r + requireSuccess r + +runProgramM :: Program -> [String] -> TestM Result +runProgramM prog args = do + configured_prog <- requireProgramM prog + -- TODO: Consider also using other information from + -- ConfiguredProgram, e.g., env and args + runM (programPath configured_prog) args + +getLocalBuildInfoM :: TestM LocalBuildInfo +getLocalBuildInfoM = do + env <- getTestEnv + liftIO $ getPersistBuildConfig (testDistDir env) + +------------------------------------------------------------------------ +-- * Changing parameters + +withDirectory :: FilePath -> TestM a -> TestM a +withDirectory f = withReaderT + (\env -> env { testRelativeCurrentDir = testRelativeCurrentDir env f }) + +-- We append to the environment list, as per 'getEffectiveEnvironment' +-- which prefers the latest override. +withEnv :: [(String, Maybe String)] -> TestM a -> TestM a +withEnv e = withReaderT (\env -> env { testEnvironment = testEnvironment env ++ e }) + +-- HACK please don't use me +withEnvFilter :: (String -> Bool) -> TestM a -> TestM a +withEnvFilter p = withReaderT (\env -> env { testEnvironment = filter (p . fst) (testEnvironment env) }) + +------------------------------------------------------------------------ +-- * Running Setup + +marked_verbose :: String +marked_verbose = "-vverbose +markoutput +nowrap" + +setup :: String -> [String] -> TestM () +setup cmd args = void (setup' cmd args) + +setup' :: String -> [String] -> TestM Result +setup' cmd args = do + env <- getTestEnv + when ((cmd == "register" || cmd == "copy") && not (testHavePackageDb env)) $ + error "Cannot register/copy without using 'withPackageDb'" + ghc_path <- programPathM ghcProgram + haddock_path <- programPathM haddockProgram + let args' = case cmd of + "configure" -> + -- If the package database is empty, setting --global + -- here will make us error loudly if we try to install + -- into a bad place. + [ "--global" + -- NB: technically unnecessary with Cabal, but + -- definitely needed for Setup, which doesn't + -- respect cabal.config + , "--with-ghc", ghc_path + , "--with-haddock", haddock_path + -- This avoids generating hashes in our package IDs, + -- which helps the test suite's expect tests. + , "--enable-deterministic" + -- These flags make the test suite run faster + -- Can't do this unless we LD_LIBRARY_PATH correctly + -- , "--enable-executable-dynamic" + -- , "--disable-optimization" + -- Specify where we want our installed packages to go + , "--prefix=" ++ testPrefixDir env + ] ++ packageDBParams (testPackageDBStack env) + ++ args + _ -> args + let rel_dist_dir = definitelyMakeRelative (testCurrentDir env) (testDistDir env) + full_args = cmd : [marked_verbose, "--distdir", rel_dist_dir] ++ args' + defaultRecordMode RecordMarked $ do + recordHeader ["Setup", cmd] + if testCabalInstallAsSetup env + then runProgramM cabalProgram full_args + else do + pdfile <- liftIO $ tryFindPackageDesc (testCurrentDir env) + pdesc <- liftIO $ readGenericPackageDescription (testVerbosity env) pdfile + if buildType (packageDescription pdesc) == Just Simple + then runM (testSetupPath env) full_args + -- Run the Custom script! + else do + r <- liftIO $ runghc (testScriptEnv env) + (Just (testCurrentDir env)) + (testEnvironment env) + (testCurrentDir env "Setup.hs") + full_args + recordLog r + requireSuccess r + -- This code is very tempting (and in principle should be quick: + -- after all we are loading the built version of Cabal), but + -- actually it costs quite a bit in wallclock time (e.g. 54sec to + -- 68sec on AllowNewer, working with un-optimized Cabal.) + {- + r <- liftIO $ runghc (testScriptEnv env) + (Just (testCurrentDir env)) + (testEnvironment env) + "Setup.hs" + (cmd : ["-v", "--distdir", testDistDir env] ++ args') + -- don't forget to check results... + -} + +definitelyMakeRelative :: FilePath -> FilePath -> FilePath +definitelyMakeRelative base0 path0 = + let go [] path = joinPath path + go base [] = joinPath (replicate (length base) "..") + go (x:xs) (y:ys) + | x == y = go xs ys + | otherwise = go (x:xs) [] go [] (y:ys) + -- NB: It's important to normalize, as otherwise if + -- we see "foo/./bar" we'll incorrectly conclude that we need + -- to go "../../.." to get out of it. + in go (splitPath (normalise base0)) (splitPath (normalise path0)) + +-- | This abstracts the common pattern of configuring and then building. +setup_build :: [String] -> TestM () +setup_build args = do + setup "configure" args + setup "build" [] + return () + +-- | This abstracts the common pattern of "installing" a package. +setup_install :: [String] -> TestM () +setup_install args = do + setup "configure" args + setup "build" [] + setup "copy" [] + setup "register" [] + return () + +-- | This abstracts the common pattern of "installing" a package, +-- with haddock documentation. +setup_install_with_docs :: [String] -> TestM () +setup_install_with_docs args = do + setup "configure" args + setup "build" [] + setup "haddock" [] + setup "copy" [] + setup "register" [] + return () + +packageDBParams :: PackageDBStack -> [String] +packageDBParams dbs = "--package-db=clear" + : map (("--package-db=" ++) . convert) dbs + where + convert :: PackageDB -> String + convert GlobalPackageDB = "global" + convert UserPackageDB = "user" + convert (SpecificPackageDB path) = path + +------------------------------------------------------------------------ +-- * Running cabal + +cabal :: String -> [String] -> TestM () +cabal "sandbox" _ = + error "Use cabal_sandbox instead" +cabal cmd args = void (cabal' cmd args) + +cabal' :: String -> [String] -> TestM Result +cabal' = cabalG' [] + +cabalG :: [String] -> String -> [String] -> TestM () +cabalG global_args cmd args = void (cabalG' global_args cmd args) + +cabalG' :: [String] -> String -> [String] -> TestM Result +cabalG' _ "sandbox" _ = + -- NB: We don't just auto-pass this through, because it's + -- possible that the first argument isn't the sub-sub-command. + -- So make sure the user specifies it correctly. + error "Use cabal_sandbox' instead" +cabalG' global_args cmd args = do + env <- getTestEnv + -- Freeze writes out cabal.config to source directory, this is not + -- overwritable + when (cmd `elem` ["freeze"]) requireHasSourceCopy + let extra_args + -- Sandboxes manage dist dir + | testHaveSandbox env + = install_args + | cmd `elem` ["update", "outdated", "user-config", "manpage", "freeze"] + = [ ] + -- new-build commands are affected by testCabalProjectFile + | "new-" `isPrefixOf` cmd + = [ "--builddir", testDistDir env + , "--project-file", testCabalProjectFile env + , "-j1" ] + | otherwise + = [ "--builddir", testDistDir env ] ++ + install_args + install_args + | cmd == "install" + || cmd == "build" = [ "-j1" ] + | otherwise = [] + extra_global_args + | testHaveSandbox env + = [ "--sandbox-config-file", testSandboxConfigFile env ] + | otherwise + = [] + cabal_args = extra_global_args + ++ global_args + ++ [ cmd, marked_verbose ] + ++ extra_args + ++ args + defaultRecordMode RecordMarked $ do + recordHeader ["cabal", cmd] + cabal_raw' cabal_args + +cabal_sandbox :: String -> [String] -> TestM () +cabal_sandbox cmd args = void $ cabal_sandbox' cmd args + +cabal_sandbox' :: String -> [String] -> TestM Result +cabal_sandbox' cmd args = do + env <- getTestEnv + let cabal_args = [ "--sandbox-config-file", testSandboxConfigFile env + , "sandbox", cmd + , marked_verbose ] + ++ args + defaultRecordMode RecordMarked $ do + recordHeader ["cabal", "sandbox", cmd] + cabal_raw' cabal_args + +cabal_raw' :: [String] -> TestM Result +cabal_raw' cabal_args = runProgramM cabalProgram cabal_args + +withSandbox :: TestM a -> TestM a +withSandbox m = do + env0 <- getTestEnv + -- void $ cabal_raw' ["sandbox", "init", "--sandbox", testSandboxDir env0] + cabal_sandbox "init" ["--sandbox", testSandboxDir env0] + withReaderT (\env -> env { testHaveSandbox = True }) m + +withProjectFile :: FilePath -> TestM a -> TestM a +withProjectFile fp m = + withReaderT (\env -> env { testCabalProjectFile = fp }) m + +-- | Assuming we've successfully configured a new-build project, +-- read out the plan metadata so that we can use it to do other +-- operations. +withPlan :: TestM a -> TestM a +withPlan m = do + env0 <- getTestEnv + Just plan <- JSON.decode `fmap` + liftIO (BSL.readFile (testDistDir env0 "cache" "plan.json")) + withReaderT (\env -> env { testPlan = Just plan }) m + +-- | Run an executable from a package. Requires 'withPlan' to have +-- been run so that we can find the dist dir. +runPlanExe :: String {- package name -} -> String {- component name -} + -> [String] -> TestM () +runPlanExe pkg_name cname args = void $ runPlanExe' pkg_name cname args + +-- | Run an executable from a package. Requires 'withPlan' to have +-- been run so that we can find the dist dir. Also returns 'Result'. +runPlanExe' :: String {- package name -} -> String {- component name -} + -> [String] -> TestM Result +runPlanExe' pkg_name cname args = do + Just plan <- testPlan `fmap` getTestEnv + let dist_dir = planDistDir plan (mkPackageName pkg_name) + (CExeName (mkUnqualComponentName cname)) + defaultRecordMode RecordAll $ do + recordHeader [pkg_name, cname] + runM (dist_dir "build" cname cname) args + +------------------------------------------------------------------------ +-- * Running ghc-pkg + +withPackageDb :: TestM a -> TestM a +withPackageDb m = do + env <- getTestEnv + let db_path = testPackageDbDir env + if testHavePackageDb env + then m + else withReaderT (\nenv -> + nenv { testPackageDBStack + = testPackageDBStack env + ++ [SpecificPackageDB db_path] + , testHavePackageDb = True + } ) + $ do ghcPkg "init" [db_path] + m + +ghcPkg :: String -> [String] -> TestM () +ghcPkg cmd args = void (ghcPkg' cmd args) + +ghcPkg' :: String -> [String] -> TestM Result +ghcPkg' cmd args = do + env <- getTestEnv + unless (testHavePackageDb env) $ + error "Must initialize package database using withPackageDb" + -- NB: testDBStack already has the local database + ghcConfProg <- requireProgramM ghcProgram + let db_stack = testPackageDBStack env + extraArgs = ghcPkgPackageDBParams + (fromMaybe + (error "ghc-pkg: cannot detect version") + (programVersion ghcConfProg)) + db_stack + recordHeader ["ghc-pkg", cmd] + runProgramM ghcPkgProgram (cmd : extraArgs ++ args) + +ghcPkgPackageDBParams :: Version -> PackageDBStack -> [String] +ghcPkgPackageDBParams version dbs = concatMap convert dbs where + convert :: PackageDB -> [String] + -- Ignoring global/user is dodgy but there's no way good + -- way to give ghc-pkg the correct flags in this case. + convert GlobalPackageDB = [] + convert UserPackageDB = [] + convert (SpecificPackageDB path) + | version >= mkVersion [7,6] + = ["--package-db=" ++ path] + | otherwise + = ["--package-conf=" ++ path] + +------------------------------------------------------------------------ +-- * Running other things + +-- | Run an executable that was produced by cabal. The @exe_name@ +-- is precisely the name of the executable section in the file. +runExe :: String -> [String] -> TestM () +runExe exe_name args = void (runExe' exe_name args) + +runExe' :: String -> [String] -> TestM Result +runExe' exe_name args = do + env <- getTestEnv + defaultRecordMode RecordAll $ do + recordHeader [exe_name] + runM (testDistDir env "build" exe_name exe_name) args + +-- | Run an executable that was installed by cabal. The @exe_name@ +-- is precisely the name of the executable. +runInstalledExe :: String -> [String] -> TestM () +runInstalledExe exe_name args = void (runInstalledExe' exe_name args) + +-- | Run an executable that was installed by cabal. Use this +-- instead of 'runInstalledExe' if you need to inspect the +-- stdout/stderr output. +runInstalledExe' :: String -> [String] -> TestM Result +runInstalledExe' exe_name args = do + env <- getTestEnv + defaultRecordMode RecordAll $ do + recordHeader [exe_name] + runM (testPrefixDir env "bin" exe_name) args + +-- | Run a shell command in the current directory. +shell :: String -> [String] -> TestM Result +shell exe args = runM exe args + +------------------------------------------------------------------------ +-- * Repository manipulation + +-- Workflows we support: +-- 1. Test comes with some packages (directories in repository) which +-- should be in the repository and available for depsolving/installing +-- into global store. +-- +-- Workflows we might want to support in the future +-- * Regression tests may want to test on Hackage index. They will +-- operate deterministically as they will be pinned to a timestamp. +-- (But should we allow this? Have to download the tarballs in that +-- case. Perhaps dep solver only!) +-- * We might sdist a local package, and then upload it to the +-- repository +-- * Some of our tests involve old versions of Cabal. This might +-- be one of the rare cases where we're willing to grab the entire +-- tarball. +-- +-- Properties we want to hold: +-- 1. Tests can be run offline. No dependence on hackage.haskell.org +-- beyond what we needed to actually get the build of Cabal working +-- itself +-- 2. Tests are deterministic. Updates to Hackage should not cause +-- tests to fail. (OTOH, it's good to run tests on most recent +-- Hackage index; some sort of canary test which is run nightly. +-- Point is it should NOT be tied to cabal source code.) +-- +-- Technical notes: +-- * We depend on hackage-repo-tool binary. It would better if it was +-- libified into hackage-security but this has not been done yet. +-- + +hackageRepoTool :: String -> [String] -> TestM () +hackageRepoTool cmd args = void $ hackageRepoTool' cmd args + +hackageRepoTool' :: String -> [String] -> TestM Result +hackageRepoTool' cmd args = do + recordHeader ["hackage-repo-tool", cmd] + runProgramM hackageRepoToolProgram (cmd : args) + +tar :: [String] -> TestM () +tar args = void $ tar' args + +tar' :: [String] -> TestM Result +tar' args = do + recordHeader ["tar"] + runProgramM tarProgram args + +-- | Creates a tarball of a directory, such that if you +-- archive the directory "/foo/bar/baz" to "mine.tgz", @tar tf@ reports +-- @baz/file1@, @baz/file2@, etc. +archiveTo :: FilePath -> FilePath -> TestM () +src `archiveTo` dst = do + -- TODO: Consider using the @tar@ library? + let (src_parent, src_dir) = splitFileName src + -- TODO: --format ustar, like createArchive? + tar ["-czf", dst, "-C", src_parent, src_dir] + +infixr 4 `archiveTo` + +-- | Given a directory (relative to the 'testCurrentDir') containing +-- a series of directories representing packages, generate an +-- external repository corresponding to all of these packages +withRepo :: FilePath -> TestM a -> TestM a +withRepo repo_dir m = do + env <- getTestEnv + + -- Check if hackage-repo-tool is available, and skip if not + skipUnless =<< isAvailableProgram hackageRepoToolProgram + + -- 1. Generate keys + hackageRepoTool "create-keys" ["--keys", testKeysDir env] + -- 2. Initialize repo directory + let package_dir = testRepoDir env "package" + liftIO $ createDirectoryIfMissing True (testRepoDir env "index") + liftIO $ createDirectoryIfMissing True package_dir + -- 3. Create tarballs + pkgs <- liftIO $ getDirectoryContents (testCurrentDir env repo_dir) + forM_ pkgs $ \pkg -> do + case pkg of + '.':_ -> return () + _ -> testCurrentDir env repo_dir pkg + `archiveTo` + package_dir pkg <.> "tar.gz" + -- 4. Initialize repository + hackageRepoTool "bootstrap" ["--keys", testKeysDir env, "--repo", testRepoDir env] + -- 5. Wire it up in .cabal/config + -- TODO: libify this + let package_cache = testHomeDir env ".cabal" "packages" + liftIO $ appendFile (testUserCabalConfigFile env) + $ unlines [ "repository test-local-repo" + , " url: file:" ++ testRepoDir env + , " secure: True" + -- TODO: Hypothetically, we could stick in the + -- correct key here + , " root-keys: " + , " key-threshold: 0" + , "remote-repo-cache: " ++ package_cache ] + -- 6. Create local directories (TODO: this is a bug #4136, once you + -- fix that this can be removed) + liftIO $ createDirectoryIfMissing True (package_cache "test-local-repo") + -- 7. Update our local index + cabal "update" [] + -- 8. Profit + withReaderT (\env' -> env' { testHaveRepo = True }) m + -- TODO: Arguably should undo everything when we're done... + +------------------------------------------------------------------------ +-- * Subprocess run results + +requireSuccess :: Result -> TestM Result +requireSuccess r@Result { resultCommand = cmd + , resultExitCode = exitCode + , resultOutput = output } = withFrozenCallStack $ do + env <- getTestEnv + when (exitCode /= ExitSuccess && not (testShouldFail env)) $ + assertFailure $ "Command " ++ cmd ++ " failed.\n" ++ + "Output:\n" ++ output ++ "\n" + when (exitCode == ExitSuccess && testShouldFail env) $ + assertFailure $ "Command " ++ cmd ++ " succeeded.\n" ++ + "Output:\n" ++ output ++ "\n" + return r + +initWorkDir :: TestM () +initWorkDir = do + env <- getTestEnv + liftIO $ createDirectoryIfMissing True (testWorkDir env) + +-- | Record a header to help identify the output to the expect +-- log. Unlike the 'recordLog', we don't record all arguments; +-- just enough to give you an idea of what the command might have +-- been. (This is because the arguments may not be deterministic, +-- so we don't want to spew them to the log.) +recordHeader :: [String] -> TestM () +recordHeader args = do + env <- getTestEnv + let mode = testRecordMode env + str_header = "# " ++ intercalate " " args ++ "\n" + header = C.pack (testRecordNormalizer env str_header) + case mode of + DoNotRecord -> return () + _ -> do + initWorkDir + liftIO $ putStr str_header + liftIO $ C.appendFile (testWorkDir env "test.log") header + liftIO $ C.appendFile (testActualFile env) header + +recordLog :: Result -> TestM () +recordLog res = do + env <- getTestEnv + let mode = testRecordMode env + initWorkDir + liftIO $ C.appendFile (testWorkDir env "test.log") + (C.pack $ "+ " ++ resultCommand res ++ "\n" + ++ resultOutput res ++ "\n\n") + liftIO . C.appendFile (testActualFile env) . C.pack . testRecordNormalizer env $ + case mode of + RecordAll -> unlines (lines (resultOutput res)) + RecordMarked -> getMarkedOutput (resultOutput res) + DoNotRecord -> "" + +getMarkedOutput :: String -> String -- trailing newline +getMarkedOutput out = unlines (go (lines out) False) + where + go [] _ = [] + go (x:xs) True + | "-----END CABAL OUTPUT-----" `isPrefixOf` x + = go xs False + | otherwise = x : go xs True + go (x:xs) False + -- NB: Windows has extra goo at the end + | "-----BEGIN CABAL OUTPUT-----" `isPrefixOf` x + = go xs True + | otherwise = go xs False + +------------------------------------------------------------------------ +-- * Test helpers + +assertFailure :: WithCallStack (String -> m ()) +assertFailure msg = withFrozenCallStack $ error msg + +assertExitCode :: MonadIO m => WithCallStack (ExitCode -> Result -> m ()) +assertExitCode code result = + when (code /= resultExitCode result) $ + assertFailure $ "Expected exit code: " + ++ show code + ++ "\nActual: " + ++ show (resultExitCode result) + +assertEqual :: (Eq a, Show a, MonadIO m) => WithCallStack (String -> a -> a -> m ()) +assertEqual s x y = + withFrozenCallStack $ + when (x /= y) $ + error (s ++ ":\nExpected: " ++ show x ++ "\nActual: " ++ show y) + +assertNotEqual :: (Eq a, Show a, MonadIO m) => WithCallStack (String -> a -> a -> m ()) +assertNotEqual s x y = + withFrozenCallStack $ + when (x == y) $ + error (s ++ ":\nGot both: " ++ show x) + +assertBool :: MonadIO m => WithCallStack (String -> Bool -> m ()) +assertBool s x = + withFrozenCallStack $ + unless x $ error s + +shouldExist :: MonadIO m => WithCallStack (FilePath -> m ()) +shouldExist path = + withFrozenCallStack $ + liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") + +shouldNotExist :: MonadIO m => WithCallStack (FilePath -> m ()) +shouldNotExist path = + withFrozenCallStack $ + liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") . not + +assertRegex :: MonadIO m => String -> String -> Result -> m () +assertRegex msg regex r = + withFrozenCallStack $ + let out = resultOutput r + in assertBool (msg ++ ",\nactual output:\n" ++ out) + (out =~ regex) + +fails :: TestM a -> TestM a +fails = withReaderT (\env -> env { testShouldFail = not (testShouldFail env) }) + +defaultRecordMode :: RecordMode -> TestM a -> TestM a +defaultRecordMode mode = withReaderT (\env -> env { + testRecordDefaultMode = mode + }) + +recordMode :: RecordMode -> TestM a -> TestM a +recordMode mode = withReaderT (\env -> env { + testRecordUserMode = Just mode + }) + +recordNormalizer :: (String -> String) -> TestM a -> TestM a +recordNormalizer f = + withReaderT (\env -> env { testRecordNormalizer = testRecordNormalizer env . f }) + +assertOutputContains :: MonadIO m => WithCallStack (String -> Result -> m ()) +assertOutputContains needle result = + withFrozenCallStack $ + unless (needle `isInfixOf` (concatOutput output)) $ + assertFailure $ " expected: " ++ needle + where output = resultOutput result + +assertOutputDoesNotContain :: MonadIO m => WithCallStack (String -> Result -> m ()) +assertOutputDoesNotContain needle result = + withFrozenCallStack $ + when (needle `isInfixOf` (concatOutput output)) $ + assertFailure $ "unexpected: " ++ needle + where output = resultOutput result + +assertFindInFile :: MonadIO m => WithCallStack (String -> FilePath -> m ()) +assertFindInFile needle path = + withFrozenCallStack $ + liftIO $ withFileContents path + (\contents -> + unless (needle `isInfixOf` contents) + (assertFailure ("expected: " ++ needle ++ "\n" ++ + " in file: " ++ path))) + +assertFileDoesContain :: MonadIO m => WithCallStack (FilePath -> String -> m ()) +assertFileDoesContain path needle = + withFrozenCallStack $ + liftIO $ withFileContents path + (\contents -> + unless (needle `isInfixOf` contents) + (assertFailure ("expected: " ++ needle ++ "\n" ++ + " in file: " ++ path))) + +assertFileDoesNotContain :: MonadIO m => WithCallStack (FilePath -> String -> m ()) +assertFileDoesNotContain path needle = + withFrozenCallStack $ + liftIO $ withFileContents path + (\contents -> + when (needle `isInfixOf` contents) + (assertFailure ("expected: " ++ needle ++ "\n" ++ + " in file: " ++ path))) + +-- | Replace line breaks with spaces, correctly handling "\r\n". +concatOutput :: String -> String +concatOutput = unwords . lines . filter ((/=) '\r') + +------------------------------------------------------------------------ +-- * Skipping tests + +hasSharedLibraries :: TestM Bool +hasSharedLibraries = do + shared_libs_were_removed <- ghcVersionIs (>= mkVersion [7,8]) + return (not (buildOS == Windows && shared_libs_were_removed)) + +hasProfiledLibraries :: TestM Bool +hasProfiledLibraries = do + env <- getTestEnv + ghc_path <- programPathM ghcProgram + let prof_test_hs = testWorkDir env "Prof.hs" + liftIO $ writeFile prof_test_hs "module Prof where" + r <- liftIO $ run (testVerbosity env) (Just (testCurrentDir env)) + (testEnvironment env) ghc_path ["-prof", "-c", prof_test_hs] + return (resultExitCode r == ExitSuccess) + +-- | Check if the GHC that is used for compiling package tests has +-- a shared library of the cabal library under test in its database. +-- +-- An example where this is needed is if you want to dynamically link +-- detailed-0.9 test suites, since those depend on the Cabal library unde rtest. +hasCabalShared :: TestM Bool +hasCabalShared = do + env <- getTestEnv + return (testHaveCabalShared env) + +ghcVersionIs :: WithCallStack ((Version -> Bool) -> TestM Bool) +ghcVersionIs f = do + ghc_program <- requireProgramM ghcProgram + case programVersion ghc_program of + Nothing -> error $ "ghcVersionIs: no ghc version for " + ++ show (programLocation ghc_program) + Just v -> return (f v) + +isWindows :: TestM Bool +isWindows = return (buildOS == Windows) + +isOSX :: TestM Bool +isOSX = return (buildOS == OSX) + +isLinux :: TestM Bool +isLinux = return (buildOS == Linux) + +hasCabalForGhc :: TestM Bool +hasCabalForGhc = do + env <- getTestEnv + ghc_program <- requireProgramM ghcProgram + (runner_ghc_program, _) <- liftIO $ requireProgram + (testVerbosity env) + ghcProgram + (runnerProgramDb (testScriptEnv env)) + -- TODO: I guess, to be more robust what we should check for + -- specifically is that the Cabal library we want to use + -- will be picked up by the package db stack of ghc-program + return (programPath ghc_program == programPath runner_ghc_program) + +-- | If you want to use a Custom setup with new-build, it needs to +-- be 1.20 or later. Ordinarily, Cabal can go off and build a +-- sufficiently recent Cabal if necessary, but in our test suite, +-- by default, we try to avoid doing so (since that involves a +-- rather lengthy build process), instead using the boot Cabal if +-- possible. But some GHCs don't have a recent enough boot Cabal! +-- You'll want to exclude them in that case. +-- +hasNewBuildCompatBootCabal :: TestM Bool +hasNewBuildCompatBootCabal = ghcVersionIs (>= mkVersion [7,9]) + +------------------------------------------------------------------------ +-- * Broken tests + +expectBroken :: Int -> TestM a -> TestM () +expectBroken ticket m = do + env <- getTestEnv + liftIO . withAsync (runReaderT m env) $ \a -> do + r <- waitCatch a + case r of + Left e -> do + putStrLn $ "This test is known broken, see #" ++ show ticket ++ ":" + print e + runReaderT expectedBroken env + Right _ -> do + runReaderT unexpectedSuccess env + +expectBrokenIf :: Bool -> Int -> TestM a -> TestM () +expectBrokenIf False _ m = void $ m +expectBrokenIf True ticket m = expectBroken ticket m + +expectBrokenUnless :: Bool -> Int -> TestM a -> TestM () +expectBrokenUnless b = expectBrokenIf (not b) + +------------------------------------------------------------------------ +-- * Miscellaneous + +git :: String -> [String] -> TestM () +git cmd args = void $ git' cmd args + +git' :: String -> [String] -> TestM Result +git' cmd args = do + recordHeader ["git", cmd] + runProgramM gitProgram (cmd : args) + +gcc :: [String] -> TestM () +gcc args = void $ gcc' args + +gcc' :: [String] -> TestM Result +gcc' args = do + recordHeader ["gcc"] + runProgramM gccProgram args + +ghc :: [String] -> TestM () +ghc args = void $ ghc' args + +ghc' :: [String] -> TestM Result +ghc' args = do + recordHeader ["ghc"] + runProgramM ghcProgram args + +-- | If a test needs to modify or write out source files, it's +-- necessary to make a hermetic copy of the source files to operate +-- on. This function arranges for this to be done. +-- +-- This requires the test repository to be a Git checkout, because +-- we use the Git metadata to figure out what files to copy into the +-- hermetic copy. +withSourceCopy :: TestM a -> TestM a +withSourceCopy m = do + env <- getTestEnv + let cwd = testCurrentDir env + dest = testSourceCopyDir env + r <- git' "ls-files" ["--cached", "--modified"] + forM_ (lines (resultOutput r)) $ \f -> do + unless (isTestFile f) $ do + liftIO $ createDirectoryIfMissing True (takeDirectory (dest f)) + liftIO $ copyFile (cwd f) (dest f) + withReaderT (\nenv -> nenv { testHaveSourceCopy = True }) m + +-- | Look up the 'InstalledPackageId' of a package name. +getIPID :: String -> TestM String +getIPID pn = do + r <- ghcPkg' "field" ["--global", pn, "id"] + -- Don't choke on warnings from ghc-pkg + case mapMaybe (stripPrefix "id: ") (lines (resultOutput r)) of + [x] -> return (takeWhile (not . Char.isSpace) x) + _ -> error $ "could not determine id of " ++ pn + +-- | Delay a sufficient period of time to permit file timestamp +-- to be updated. +delay :: TestM () +delay = do + env <- getTestEnv + is_old_ghc <- ghcVersionIs (< mkVersion [7,7]) + -- For old versions of GHC, we only had second-level precision, + -- so we need to sleep a full second. Newer versions use + -- millisecond level precision, so we only have to wait + -- the granularity of the underlying filesystem. + -- TODO: cite commit when GHC got better precision; this + -- version bound was empirically generated. + liftIO . threadDelay $ + if is_old_ghc + then 1000000 + else fromMaybe + (error "Delay must be enclosed by withDelay") + (testMtimeChangeDelay env) + +-- | Calibrate file modification time delay, if not +-- already determined. +withDelay :: TestM a -> TestM a +withDelay m = do + env <- getTestEnv + case testMtimeChangeDelay env of + Nothing -> do + -- Figure out how long we need to delay for recompilation tests + (_, mtimeChange) <- liftIO $ calibrateMtimeChangeDelay + withReaderT (\nenv -> nenv { testMtimeChangeDelay = Just mtimeChange }) m + Just _ -> m + +-- | Create a symlink for the duration of the provided action. If the symlink +-- already exists, it is deleted. Does not work on Windows. +withSymlink :: FilePath -> FilePath -> TestM a -> TestM a +#ifdef mingw32_HOST_OS +withSymlink _oldpath _newpath _act = + error "PackageTests.PackageTester.withSymlink: does not work on Windows!" +#else +withSymlink oldpath newpath0 act = do + env <- getTestEnv + let newpath = testCurrentDir env newpath0 + symlinkExists <- liftIO $ doesFileExist newpath + when symlinkExists $ liftIO $ removeFile newpath + bracket_ (liftIO $ createSymbolicLink oldpath newpath) + (liftIO $ removeFile newpath) act +#endif + +writeSourceFile :: FilePath -> String -> TestM () +writeSourceFile fp s = do + requireHasSourceCopy + cwd <- fmap testCurrentDir getTestEnv + liftIO $ writeFile (cwd fp) s + +copySourceFileTo :: FilePath -> FilePath -> TestM () +copySourceFileTo src dest = do + requireHasSourceCopy + cwd <- fmap testCurrentDir getTestEnv + liftIO $ copyFile (cwd src) (cwd dest) + +requireHasSourceCopy :: TestM () +requireHasSourceCopy = do + env <- getTestEnv + unless (testHaveSourceCopy env) $ do + error "This operation requires a source copy; use withSourceCopy and 'git add' all test files" + +-- NB: Keep this synchronized with partitionTests +isTestFile :: FilePath -> Bool +isTestFile f = + case takeExtensions f of + ".test.hs" -> True + ".multitest.hs" -> True + _ -> False diff --git a/cabal/cabal-testsuite/Test/Cabal/Run.hs b/cabal/cabal-testsuite/Test/Cabal/Run.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/Test/Cabal/Run.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE NondecreasingIndentation #-} +-- | A module for running commands in a chatty way. +module Test.Cabal.Run ( + run, + Result(..) +) where + +import Distribution.Compat.CreatePipe (createPipe) +import Distribution.Simple.Program.Run +import Distribution.Verbosity + +import Control.Concurrent.Async +import System.Process (runProcess, waitForProcess, showCommandForUser) +import System.IO +import System.Exit +import System.Directory +import System.FilePath + +-- | The result of invoking the command line. +data Result = Result + { resultExitCode :: ExitCode + , resultCommand :: String + , resultOutput :: String + } deriving Show + +-- | Run a command, streaming its output to stdout, and return a 'Result' +-- with this information. +run :: Verbosity -> Maybe FilePath -> [(String, Maybe String)] -> FilePath -> [String] -> IO Result +run _verbosity mb_cwd env_overrides path0 args = do + -- In our test runner, we allow a path to be relative to the + -- current directory using the same heuristic as shells: + -- 'foo' refers to an executable in the PATH, but './foo' + -- and 'foo/bar' refer to relative files. + -- + -- Unfortunately, we cannot just pass these relative paths directly: + -- 'runProcess' resolves an executable path not with respect to the + -- current working directory, but the working directory that the + -- subprocess will execute in. Thus, IF we have a relative + -- path which is not a bare executable name, we have to tack on + -- the CWD to make it resolve correctly + cwd <- getCurrentDirectory + let path | length (splitPath path0) /= 1 && isRelative path0 + = cwd path0 + | otherwise + = path0 + + mb_env <- getEffectiveEnvironment env_overrides + putStrLn $ "+ " ++ showCommandForUser path args + (readh, writeh) <- createPipe + hSetBuffering readh LineBuffering + hSetBuffering writeh LineBuffering + let drain = do + r <- hGetContents readh + putStr r -- forces the output + hClose readh + return r + withAsync drain $ \sync -> do + + -- NB: do NOT extend this to take stdin; then we will + -- start deadlocking on AppVeyor. See https://github.com/haskell/process/issues/76 + pid <- runProcess path args mb_cwd mb_env Nothing {- no stdin -} + (Just writeh) (Just writeh) + + -- wait for the program to terminate + exitcode <- waitForProcess pid + out <- wait sync + + return Result { + resultExitCode = exitcode, + resultCommand = showCommandForUser path args, + resultOutput = out + } diff --git a/cabal/cabal-testsuite/Test/Cabal/Script.hs b/cabal/cabal-testsuite/Test/Cabal/Script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/Test/Cabal/Script.hs @@ -0,0 +1,104 @@ +-- | Functionality for invoking Haskell scripts with the correct +-- package database setup. +module Test.Cabal.Script ( + ScriptEnv(..), + mkScriptEnv, + runnerGhcArgs, + runnerCommand, + runghc, +) where + +import Test.Cabal.Run + +import Distribution.Backpack +import Distribution.Types.ModuleRenaming +import Distribution.Types.LocalBuildInfo +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentName +import Distribution.Types.UnqualComponentName +import Distribution.Utils.NubList +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Builtin +import Distribution.Simple.Program.GHC +import Distribution.Simple.Program +import Distribution.Simple.Compiler +import Distribution.Verbosity +import Distribution.System +import Distribution.Simple.Setup (Flag(..)) + +import System.Directory +import qualified Data.Monoid as M + +-- | The runner environment, which contains all of the important +-- parameters for invoking GHC. Mostly subset of 'LocalBuildInfo'. +data ScriptEnv = ScriptEnv + { runnerProgramDb :: ProgramDb + , runnerPackageDbStack :: PackageDBStack + , runnerVerbosity :: Verbosity + , runnerPlatform :: Platform + , runnerCompiler :: Compiler + , runnerPackages :: [(OpenUnitId, ModuleRenaming)] + } + +-- | Convert package database into absolute path, so that +-- if we change working directories in a subprocess we get the correct database. +canonicalizePackageDB :: PackageDB -> IO PackageDB +canonicalizePackageDB (SpecificPackageDB path) + = SpecificPackageDB `fmap` canonicalizePath path +canonicalizePackageDB x = return x + +-- | Create a 'ScriptEnv' from a 'LocalBuildInfo' configured with +-- the GHC that we want to use. +mkScriptEnv :: Verbosity -> LocalBuildInfo -> IO ScriptEnv +mkScriptEnv verbosity lbi = do + package_db <- mapM canonicalizePackageDB (withPackageDB lbi) + return $ ScriptEnv + { runnerVerbosity = verbosity + , runnerProgramDb = withPrograms lbi + , runnerPackageDbStack = package_db + , runnerPlatform = hostPlatform lbi + , runnerCompiler = compiler lbi + -- NB: the set of packages available to test.hs scripts will COINCIDE + -- with the dependencies on the cabal-testsuite library + , runnerPackages = cabalTestsPackages lbi + } + +-- | Compute the set of @-package-id@ flags which would be passed when +-- building the public library. Assumes that the public library is +-- non-Backpack. +cabalTestsPackages :: LocalBuildInfo -> [(OpenUnitId, ModuleRenaming)] +cabalTestsPackages lbi = + case componentNameCLBIs lbi (CExeName (mkUnqualComponentName "cabal-tests")) of + [clbi] -> componentIncludes clbi + _ -> error "cabalTestsPackages" + +-- | Run a script with 'runghc', under the 'ScriptEnv'. +runghc :: ScriptEnv -> Maybe FilePath -> [(String, Maybe String)] + -> FilePath -> [String] -> IO Result +runghc senv mb_cwd env_overrides script_path args = do + (real_path, real_args) <- runnerCommand senv mb_cwd env_overrides script_path args + run (runnerVerbosity senv) mb_cwd env_overrides real_path real_args + +-- | Compute the command line which should be used to run a Haskell +-- script with 'runghc'. +runnerCommand :: ScriptEnv -> Maybe FilePath -> [(String, Maybe String)] + -> FilePath -> [String] -> IO (FilePath, [String]) +runnerCommand senv _mb_cwd _env_overrides script_path args = do + (prog, _) <- requireProgram verbosity runghcProgram (runnerProgramDb senv) + return (programPath prog, + runghc_args ++ ["--"] ++ map ("--ghc-arg="++) ghc_args ++ [script_path] ++ args) + where + verbosity = runnerVerbosity senv + runghc_args = [] + ghc_args = runnerGhcArgs senv + +-- | Compute the GHC flags to invoke 'runghc' with under a 'ScriptEnv'. +runnerGhcArgs :: ScriptEnv -> [String] +runnerGhcArgs senv = + renderGhcOptions (runnerCompiler senv) (runnerPlatform senv) ghc_options + where + ghc_options = M.mempty { ghcOptPackageDBs = runnerPackageDbStack senv + , ghcOptPackages = toNubListR (runnerPackages senv) + -- Avoid picking stray module files that look + -- like our imports + , ghcOptSourcePathClear = Flag True } diff --git a/cabal/cabal-testsuite/Test/Cabal/Server.hs b/cabal/cabal-testsuite/Test/Cabal/Server.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/Test/Cabal/Server.hs @@ -0,0 +1,437 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NondecreasingIndentation #-} +-- | A GHC run-server, which supports running multiple GHC scripts +-- without having to restart from scratch. +module Test.Cabal.Server ( + Server, + serverProcessId, + ServerLogMsg(..), + ServerLogMsgType(..), + ServerResult(..), + withNewServer, + runOnServer, + runMain, +) where + +import Test.Cabal.Script + +import Prelude hiding (log) +import Control.Concurrent.MVar +import Control.Concurrent +import Control.Concurrent.Async +import System.Process +import System.IO +import System.Exit +import Data.List +import Distribution.Simple.Program.Db +import Distribution.Simple.Program +import Control.Exception +import qualified Control.Exception as E +import Control.Monad +import Data.IORef +import Data.Maybe + +import Distribution.Verbosity + +import System.Process.Internals +#if mingw32_HOST_OS +import qualified System.Win32.Process as Win32 +#endif + +-- TODO: Compare this implementation with +-- https://github.com/ndmitchell/ghcid/blob/master/src/Language/Haskell/Ghcid.hs +-- which does something similar + +-- ----------------------------------------------------------------- -- +-- Public API +-- ----------------------------------------------------------------- -- + +-- | A GHCi server session, which we can ask to run scripts. +-- It operates in a *fixed* runner environment as specified +-- by 'serverScriptEnv'. +data Server = Server { + serverStdin :: Handle, + serverStdout :: Handle, + serverStderr :: Handle, + serverProcessHandle :: ProcessHandle, + serverProcessId :: ProcessId, + serverScriptEnv :: ScriptEnv, + -- | Accumulators which we use to keep tracking + -- of stdout/stderr we've incrementally read out. In the event + -- of an error we'll use this to give diagnostic information. + serverStdoutAccum :: MVar [String], + serverStderrAccum :: MVar [String], + serverLogChan :: Chan ServerLogMsg + } + +-- | Portable representation of process ID; just a string rendered +-- number. +type ProcessId = String + +data ServerLogMsg = ServerLogMsg ServerLogMsgType String + | ServerLogEnd +data ServerLogMsgType = ServerOut ProcessId + | ServerErr ProcessId + | ServerIn ProcessId + | ServerMeta ProcessId + | AllServers + +data ServerResult = ServerResult { -- Result + serverResultExitCode :: ExitCode, + serverResultCommand :: String, + serverResultStdout :: String, + serverResultStderr :: String + } + +-- | With 'ScriptEnv', create a new GHCi 'Server' session. +-- When @f@ returns, the server is terminated and no longer +-- valid. +withNewServer :: Chan ServerLogMsg -> ScriptEnv -> (Server -> IO a) -> IO a +withNewServer chan senv f = + bracketWithInit (startServer chan senv) initServer stopServer f + +-- | Like 'bracket', but with an initialization function on the resource +-- which will be called, unmasked, on the resource to transform it +-- in some way. If the initialization function throws an exception, the cleanup +-- handler will get invoked with the original resource; if it succeeds, the +-- cleanup handler will get invoked with the transformed resource. +-- The cleanup handler must be able to handle both cases. +-- +-- This can help avoid race conditions in certain situations: with +-- normal use of 'bracket', the resource acquisition function +-- MUST return immediately after the resource is acquired. If it +-- performs any interruptible actions afterwards, it could be +-- interrupted and the exception handler not called. +bracketWithInit :: IO a -> (a -> IO a) -> (a -> IO b) -> (a -> IO c) -> IO c +bracketWithInit before initialize after thing = + mask $ \restore -> do + a0 <- before + a <- restore (initialize a0) `onException` after a0 + r <- restore (thing a) `onException` after a + _ <- after a + return r + +-- | Run an hs script on the GHCi server, returning the 'ServerResult' of +-- executing the command. +-- +-- * The script MUST have an @hs@ or @lhs@ filename; GHCi +-- will reject non-Haskell filenames. +-- +-- * If the script is not well-typed, the returned output +-- will be of GHC's compile errors. +-- +-- * Inside your script, do not rely on 'getProgName' having +-- a sensible value. +-- +-- * Current working directory and environment overrides +-- are currently not implemented. +-- +runOnServer :: Server -> Maybe FilePath -> [(String, Maybe String)] + -> FilePath -> [String] -> IO ServerResult +runOnServer s mb_cwd env_overrides script_path args = do + -- TODO: cwd not implemented + when (isJust mb_cwd) $ error "runOnServer change directory not implemented" + -- TODO: env_overrides not implemented + unless (null env_overrides) $ error "runOnServer set environment not implemented" + + -- Set arguments returned by System.getArgs + write s $ ":set args " ++ show args + -- Output start sigil (do it here so we pick up compilation + -- failures) + write s $ "System.IO.hPutStrLn System.IO.stdout " ++ show start_sigil + write s $ "System.IO.hPutStrLn System.IO.stderr " ++ show start_sigil + _ <- readUntilSigil s start_sigil IsOut + _ <- readUntilSigil s start_sigil IsErr + -- Drain the output produced by the script as we are running so that + -- we do not deadlock over a full pipe. + withAsync (readUntilEnd s IsOut) $ \a_exit_out -> do + withAsync (readUntilSigil s end_sigil IsErr) $ \a_err -> do + -- NB: No :set prog; don't rely on this value in test scripts, + -- we pass it in via the arguments + -- NB: load drops all bindings, which is GOOD. Avoid holding onto + -- garbage. + write s $ ":load " ++ script_path + -- Create a ref which will record the exit status of the command + -- NB: do this after :load so it doesn't get dropped + write s $ "ref <- Data.IORef.newIORef (System.Exit.ExitFailure 1)" + -- TODO: What if an async exception gets raised here? At the + -- moment, there is no way to recover until we get to the top-level + -- bracket; then stopServer which correctly handles this case. + -- If you do want to be able to abort this computation but KEEP + -- USING THE SERVER SESSION, you will need to have a lot more + -- sophisticated logic. + write s $ "Test.Cabal.Server.runMain ref Main.main" + -- Output end sigil. + -- NB: We're line-oriented, so we MUST add an extra newline + -- to ensure that we see the end sigil. + write s $ "System.IO.hPutStrLn System.IO.stdout " ++ show "" + write s $ "System.IO.hPutStrLn System.IO.stderr " ++ show "" + write s $ "Data.IORef.readIORef ref >>= \\e -> " ++ + " System.IO.hPutStrLn System.IO.stdout (" ++ show end_sigil ++ " ++ \" \" ++ show e)" + write s $ "System.IO.hPutStrLn System.IO.stderr " ++ show end_sigil + (code, out) <- wait a_exit_out + err <- wait a_err + + -- Give the user some indication about how they could run the + -- command by hand. + (real_path, real_args) <- runnerCommand (serverScriptEnv s) mb_cwd env_overrides script_path args + return ServerResult { + serverResultExitCode = code, + serverResultCommand = showCommandForUser real_path real_args, + serverResultStdout = out, + serverResultStderr = err + } + +-- | Helper function which we use in the GHCi session to communicate +-- the exit code of the process. +runMain :: IORef ExitCode -> IO () -> IO () +runMain ref m = do + E.catch (m >> writeIORef ref ExitSuccess) serverHandler + where + serverHandler :: SomeException -> IO () + serverHandler e = do + -- TODO: Probably a few more cases you could handle; + -- e.g., StackOverflow should return 2; also signals. + writeIORef ref $ + case fromException e of + Just exit_code -> exit_code + -- Only rethrow for non ExitFailure exceptions + _ -> ExitFailure 1 + case fromException e :: Maybe ExitCode of + Just _ -> return () + _ -> throwIO e + +-- ----------------------------------------------------------------- -- +-- Initialize/tear down +-- ----------------------------------------------------------------- -- + +-- | Start a new GHCi session. +startServer :: Chan ServerLogMsg -> ScriptEnv -> IO Server +startServer chan senv = do + (prog, _) <- requireProgram verbosity ghcProgram (runnerProgramDb senv) + let ghc_args = runnerGhcArgs senv ++ ["--interactive", "-v0", "-ignore-dot-ghci"] + proc_spec = (proc (programPath prog) ghc_args) { + create_group = True, + -- Closing fds is VERY important to avoid + -- deadlock; we won't see the end of a + -- stream until everyone gives up. + close_fds = True, + std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe + } + -- printRawCommandAndArgsAndEnv (runnerVerbosity senv) (programPath prog) ghc_args Nothing + when (verbosity >= verbose) $ + writeChan chan (ServerLogMsg AllServers (showCommandForUser (programPath prog) ghc_args)) + (Just hin, Just hout, Just herr, proch) <- createProcess proc_spec + out_acc <- newMVar [] + err_acc <- newMVar [] + tid <- myThreadId + return Server { + serverStdin = hin, + serverStdout = hout, + serverStderr = herr, + serverProcessHandle = proch, + serverProcessId = show tid, + serverLogChan = chan, + serverStdoutAccum = out_acc, + serverStderrAccum = err_acc, + serverScriptEnv = senv + } + where + verbosity = runnerVerbosity senv + +-- | Unmasked initialization for the server +initServer :: Server -> IO Server +initServer s0 = do + -- NB: withProcessHandle reads an MVar and is interruptible +#if mingw32_HOST_OS + pid <- withProcessHandle (serverProcessHandle s0) $ \ph -> + case ph of + OpenHandle x -> fmap show (Win32.getProcessId x) + ClosedHandle _ -> return (serverProcessId s0) +#else + pid <- withProcessHandle (serverProcessHandle s0) $ \ph -> + case ph of + OpenHandle x -> return (show x) + -- TODO: handle OpenExtHandle? + _ -> return (serverProcessId s0) +#endif + let s = s0 { serverProcessId = pid } + -- We will read/write a line at a time, including for + -- output; our demarcation tokens are an entire line. + forM_ [serverStdin, serverStdout, serverStderr] $ \f -> do + hSetBuffering (f s) LineBuffering + hSetEncoding (f s) utf8 + write s ":set prompt \"\"" + write s "System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering" + return s + +-- | Stop a GHCi session. +stopServer :: Server -> IO () +stopServer s = do + -- This is quite a bit of funny business. + -- On Linux, terminateProcess will send a SIGINT, which + -- GHCi will swallow and actually only use to terminate + -- whatever computation is going on at that time. So we + -- have to follow up with an actual :quit command to + -- finish it up (if you delete it, the processes will + -- hang around). On Windows, this will just actually kill + -- the process so the rest should be unnecessary. + mb_exit <- getProcessExitCode (serverProcessHandle s) + + let hardKiller = do + threadDelay 2000000 -- 2sec + log ServerMeta s $ "Terminating..." + terminateProcess (serverProcessHandle s) + softKiller = do + -- Ask to quit. If we're in the middle of a computation, + -- this will buffer up (unless the program is intercepting + -- stdin, but that should NOT happen.) + ignore $ write s ":quit" + + -- NB: it's important that we used create_group. We + -- run this AFTER write s ":quit" because if we C^C + -- sufficiently early in GHCi startup process, GHCi + -- will actually die, and then hClose will fail because + -- the ":quit" command was buffered up but never got + -- flushed. + interruptProcessGroupOf (serverProcessHandle s) + + log ServerMeta s $ "Waiting..." + -- Close input BEFORE waiting, close output AFTER waiting. + -- If you get either order wrong, deadlock! + hClose (serverStdin s) + -- waitForProcess has race condition + -- https://github.com/haskell/process/issues/46 + waitForProcess $ serverProcessHandle s + + let drain f = do + r <- hGetContents (f s) + _ <- evaluate (length r) + hClose (f s) + return r + withAsync (drain serverStdout) $ \a_out -> do + withAsync (drain serverStderr) $ \a_err -> do + + r <- case mb_exit of + Nothing -> do + log ServerMeta s $ "Terminating GHCi" + race hardKiller softKiller + Just exit -> do + log ServerMeta s $ "GHCi died unexpectedly" + return (Right exit) + + -- Drain the output buffers + rest_out <- wait a_out + rest_err <- wait a_err + if r /= Right ExitSuccess && + r /= Right (ExitFailure (-2)) -- SIGINT; happens frequently for some reason + then do withMVar (serverStdoutAccum s) $ \acc -> + mapM_ (info ServerOut s) (reverse acc) + info ServerOut s rest_out + withMVar (serverStderrAccum s) $ \acc -> + mapM_ (info ServerErr s) (reverse acc) + info ServerErr s rest_err + info ServerMeta s $ + (case r of + Left () -> "GHCi was forcibly terminated" + Right exit -> "GHCi exited with " ++ show exit) ++ + if verbosity < verbose + then " (use -v for more information)" + else "" + else log ServerOut s rest_out + + log ServerMeta s $ "Done" + return () + where + verbosity = runnerVerbosity (serverScriptEnv s) + +-- Using the procedure from +-- https://www.schoolofhaskell.com/user/snoyberg/general-haskell/exceptions/catching-all-exceptions +ignore :: IO () -> IO () +ignore m = withAsync m $ \a -> void (waitCatch a) + +-- ----------------------------------------------------------------- -- +-- Utility functions +-- ----------------------------------------------------------------- -- + +log :: (ProcessId -> ServerLogMsgType) -> Server -> String -> IO () +log ctor s msg = + when (verbosity >= verbose) $ info ctor s msg + where + verbosity = runnerVerbosity (serverScriptEnv s) + +info :: (ProcessId -> ServerLogMsgType) -> Server -> String -> IO () +info ctor s msg = + writeChan chan (ServerLogMsg (ctor (serverProcessId s)) msg) + where + chan = serverLogChan s + +-- | Write a string to the prompt of the GHCi server. +write :: Server -> String -> IO () +write s msg = do + log ServerIn s $ msg + hPutStrLn (serverStdin s) msg + hFlush (serverStdin s) -- line buffering should get it, but just for good luck + +accumulate :: MVar [String] -> String -> IO () +accumulate acc msg = + modifyMVar_ acc (\msgs -> return (msg:msgs)) + +flush :: MVar [String] -> IO [String] +flush acc = modifyMVar acc (\msgs -> return ([], reverse msgs)) + +data OutOrErr = IsOut | IsErr + +serverHandle :: Server -> OutOrErr -> Handle +serverHandle s IsOut = serverStdout s +serverHandle s IsErr = serverStderr s + +serverAccum :: Server -> OutOrErr -> MVar [String] +serverAccum s IsOut = serverStdoutAccum s +serverAccum s IsErr = serverStderrAccum s + +outOrErrMsgType :: OutOrErr -> (ProcessId -> ServerLogMsgType) +outOrErrMsgType IsOut = ServerOut +outOrErrMsgType IsErr = ServerErr + +-- | Consume output from the GHCi server until we hit a "start +-- sigil" (indicating that the subsequent output is for the +-- command we want.) Call this only immediately after you +-- send a command to GHCi to emit the start sigil. +readUntilSigil :: Server -> String -> OutOrErr -> IO String +readUntilSigil s sigil outerr = do + l <- hGetLine (serverHandle s outerr) + log (outOrErrMsgType outerr) s l + if sigil `isPrefixOf` l -- NB: on Windows there might be extra goo at end + then intercalate "\n" `fmap` flush (serverAccum s outerr) + else do accumulate (serverAccum s outerr) l + readUntilSigil s sigil outerr + +-- | Consume output from the GHCi server until we hit the +-- end sigil. Return the consumed output as well as the +-- exit code (which is at the end of the sigil). +readUntilEnd :: Server -> OutOrErr -> IO (ExitCode, String) +readUntilEnd s outerr = go [] + where + go rs = do + l <- hGetLine (serverHandle s outerr) + log (outOrErrMsgType outerr) s l + if end_sigil `isPrefixOf` l + -- NB: NOT unlines, we don't want the trailing newline! + then do exit <- evaluate (parseExit l) + _ <- flush (serverAccum s outerr) -- TODO: don't toss this out + return (exit, intercalate "\n" (reverse rs)) + else do accumulate (serverAccum s outerr) l + go (l:rs) + parseExit l = read (drop (length end_sigil) l) + +-- | The start and end sigils. This should be chosen to be +-- reasonably unique, so that test scripts don't accidentally +-- generate them. If these get spuriously generated, we will +-- probably deadlock. +start_sigil, end_sigil :: String +start_sigil = "BEGIN Test.Cabal.Server" +end_sigil = "END Test.Cabal.Server" diff --git a/cabal/cabal-testsuite/Test/Cabal/Workdir.hs b/cabal/cabal-testsuite/Test/Cabal/Workdir.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/Test/Cabal/Workdir.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP #-} +-- | Functions for interrogating the current working directory +module Test.Cabal.Workdir where + +import Distribution.Simple.Setup +import Distribution.Simple.Configure + +import System.Directory +import System.FilePath + +#if MIN_VERSION_base(4,6,0) +import System.Environment ( getExecutablePath ) +#endif + +-- | Guess what the dist directory of a running executable is, +-- by using the conventional layout of built executables +-- in relation to the top of a dist directory. Will not work +-- if the executable has been installed somewhere else. +guessDistDir :: IO FilePath +guessDistDir = do +#if MIN_VERSION_base(4,6,0) + exe_path <- canonicalizePath =<< getExecutablePath + let dist0 = dropFileName exe_path ".." ".." + b <- doesFileExist (dist0 "setup-config") +#else + let dist0 = error "no path" + b = False +#endif + if b then canonicalizePath dist0 + else findDistPrefOrDefault NoFlag >>= canonicalizePath 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 @@ -1,6 +1,6 @@ name: cabal-testsuite -version: 1.25.0.0 -copyright: 2003-2016, Cabal Development Team (see AUTHORS file) +version: 2.1.0.0 +copyright: 2003-2017, Cabal Development Team (see AUTHORS file) license: BSD3 license-file: LICENSE author: Cabal Development Team @@ -17,332 +17,57 @@ extra-source-files: README.md - -- Generated with 'misc/gen-extra-source-files.sh' - -- Do NOT edit this section manually; instead, run the script. - -- BEGIN gen-extra-source-files - PackageTests/AllowNewer/AllowNewer.cabal - PackageTests/AllowNewer/benchmarks/Bench.hs - PackageTests/AllowNewer/src/Foo.hs - PackageTests/AllowNewer/tests/Test.hs - PackageTests/AllowOlder/AllowOlder.cabal - PackageTests/AllowOlder/benchmarks/Bench.hs - PackageTests/AllowOlder/src/Foo.hs - PackageTests/AllowOlder/tests/Test.hs - PackageTests/Ambiguity/p/Dupe.hs - PackageTests/Ambiguity/p/p.cabal - PackageTests/Ambiguity/package-import/A.hs - PackageTests/Ambiguity/package-import/package-import.cabal - PackageTests/Ambiguity/q/Dupe.hs - PackageTests/Ambiguity/q/q.cabal - PackageTests/Ambiguity/reexport-test/Main.hs - PackageTests/Ambiguity/reexport-test/reexport-test.cabal - PackageTests/Ambiguity/reexport/reexport.cabal - PackageTests/AutogenModules/Package/Dummy.hs - PackageTests/AutogenModules/Package/MyBenchModule.hs - PackageTests/AutogenModules/Package/MyExeModule.hs - PackageTests/AutogenModules/Package/MyLibModule.hs - PackageTests/AutogenModules/Package/MyLibrary.hs - PackageTests/AutogenModules/Package/MyTestModule.hs - PackageTests/AutogenModules/Package/my.cabal - PackageTests/AutogenModules/SrcDist/Dummy.hs - PackageTests/AutogenModules/SrcDist/MyBenchModule.hs - PackageTests/AutogenModules/SrcDist/MyExeModule.hs - PackageTests/AutogenModules/SrcDist/MyLibModule.hs - PackageTests/AutogenModules/SrcDist/MyLibrary.hs - PackageTests/AutogenModules/SrcDist/MyTestModule.hs - PackageTests/AutogenModules/SrcDist/my.cabal - PackageTests/Backpack/Includes1/A.hs - PackageTests/Backpack/Includes1/B.hs - PackageTests/Backpack/Includes1/Includes1.cabal - PackageTests/Backpack/Includes2/Includes2.cabal - PackageTests/Backpack/Includes2/exe/Main.hs - PackageTests/Backpack/Includes2/exe/exe.cabal - PackageTests/Backpack/Includes2/fail.cabal - PackageTests/Backpack/Includes2/mylib/Mine.hs - PackageTests/Backpack/Includes2/mylib/mylib.cabal - PackageTests/Backpack/Includes2/mysql/Database/MySQL.hs - PackageTests/Backpack/Includes2/mysql/mysql.cabal - PackageTests/Backpack/Includes2/postgresql/Database/PostgreSQL.hs - PackageTests/Backpack/Includes2/postgresql/postgresql.cabal - PackageTests/Backpack/Includes2/src/App.hs - PackageTests/Backpack/Includes2/src/src.cabal - PackageTests/Backpack/Includes3/Includes3.cabal - PackageTests/Backpack/Includes3/exe/Main.hs - PackageTests/Backpack/Includes3/exe/exe.cabal - PackageTests/Backpack/Includes3/indef/Foo.hs - PackageTests/Backpack/Includes3/indef/indef.cabal - PackageTests/Backpack/Includes3/sigs/sigs.cabal - PackageTests/Backpack/Includes4/Includes4.cabal - PackageTests/Backpack/Includes4/Main.hs - PackageTests/Backpack/Includes4/impl/A.hs - PackageTests/Backpack/Includes4/impl/B.hs - PackageTests/Backpack/Includes4/impl/Rec.hs - PackageTests/Backpack/Includes4/indef/C.hs - PackageTests/Backpack/Includes5/A.hs - PackageTests/Backpack/Includes5/B.hs - PackageTests/Backpack/Includes5/Includes5.cabal - PackageTests/Backpack/Includes5/impl/Foobar.hs - PackageTests/Backpack/Includes5/impl/Quxbaz.hs - PackageTests/Backpack/Indef1/Indef1.cabal - PackageTests/Backpack/Indef1/Provide.hs - PackageTests/Backpack/Reexport1/p/P.hs - PackageTests/Backpack/Reexport1/p/p.cabal - PackageTests/Backpack/Reexport1/q/Q.hs - PackageTests/Backpack/Reexport1/q/q.cabal - PackageTests/BenchmarkExeV10/Foo.hs - PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs - PackageTests/BenchmarkExeV10/my.cabal - PackageTests/BenchmarkOptions/BenchmarkOptions.cabal - PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs - PackageTests/BenchmarkStanza/my.cabal - PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal - PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs - PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal - PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs - PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs - PackageTests/BuildDeps/InternalLibrary0/my.cabal - PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs - PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs - PackageTests/BuildDeps/InternalLibrary1/my.cabal - PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs - PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs - PackageTests/BuildDeps/InternalLibrary2/my.cabal - PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs - PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs - PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal - PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs - PackageTests/BuildDeps/InternalLibrary3/my.cabal - PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs - PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs - PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal - PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs - PackageTests/BuildDeps/InternalLibrary4/my.cabal - PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs - PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs - PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal - PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs - PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal - PackageTests/BuildDeps/SameDepsAllRound/lemon.hs - PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs - PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs - PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs - PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal - PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs - PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs - PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal - PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs - PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs - PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal - PackageTests/BuildTargetErrors/BuildTargetErrors.cabal - PackageTests/BuildTargetErrors/Main.hs - PackageTests/BuildTestSuiteDetailedV09/Dummy2.hs - PackageTests/BuildToolsPath/A.hs - PackageTests/BuildToolsPath/MyCustomPreprocessor.hs - PackageTests/BuildToolsPath/build-tools-path.cabal - PackageTests/BuildToolsPath/hello/Hello.hs - PackageTests/BuildableField/BuildableField.cabal - PackageTests/BuildableField/Main.hs - PackageTests/CMain/Bar.hs - PackageTests/CMain/foo.c - PackageTests/CMain/my.cabal - PackageTests/CaretOperator/my.cabal - PackageTests/Configure/A.hs - PackageTests/Configure/Setup.hs - PackageTests/Configure/include/HsZlibConfig.h.in - PackageTests/Configure/zlib.buildinfo.in - PackageTests/Configure/zlib.cabal - PackageTests/ConfigureComponent/Exe/Bad.hs - PackageTests/ConfigureComponent/Exe/Exe.cabal - PackageTests/ConfigureComponent/Exe/Good.hs - PackageTests/ConfigureComponent/SubLib/Lib.cabal - PackageTests/ConfigureComponent/SubLib/Lib.hs - PackageTests/ConfigureComponent/SubLib/exe/Exe.hs - PackageTests/ConfigureComponent/Test/Lib.hs - PackageTests/ConfigureComponent/Test/Test.cabal - PackageTests/ConfigureComponent/Test/testlib/TestLib.hs - PackageTests/ConfigureComponent/Test/testlib/testlib.cabal - PackageTests/ConfigureComponent/Test/tests/Test.hs - PackageTests/CopyComponent/Exe/Main.hs - PackageTests/CopyComponent/Exe/Main2.hs - PackageTests/CopyComponent/Exe/myprog.cabal - PackageTests/CopyComponent/Lib/Main.hs - PackageTests/CopyComponent/Lib/p.cabal - PackageTests/CopyComponent/Lib/src/P.hs - PackageTests/CustomPreProcess/Hello.hs - PackageTests/CustomPreProcess/MyCustomPreprocessor.hs - PackageTests/CustomPreProcess/Setup.hs - PackageTests/CustomPreProcess/internal-preprocessor-test.cabal - PackageTests/DeterministicAr/Lib.hs - PackageTests/DeterministicAr/my.cabal - PackageTests/DuplicateModuleName/DuplicateModuleName.cabal - PackageTests/DuplicateModuleName/src/Foo.hs - PackageTests/DuplicateModuleName/tests/Foo.hs - PackageTests/DuplicateModuleName/tests2/Foo.hs - PackageTests/EmptyLib/empty/empty.cabal - PackageTests/ForeignLibs/UseLib.c - PackageTests/ForeignLibs/csrc/MyForeignLibWrapper.c - PackageTests/ForeignLibs/my-foreign-lib.cabal - PackageTests/ForeignLibs/src/MyForeignLib/AnotherVal.hs - PackageTests/ForeignLibs/src/MyForeignLib/Hello.hs - PackageTests/ForeignLibs/src/MyForeignLib/SomeBindings.hsc - PackageTests/GhcPkgGuess/SameDirectory/SameDirectory.cabal - PackageTests/GhcPkgGuess/SameDirectory/ghc - PackageTests/GhcPkgGuess/SameDirectory/ghc-pkg - PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/SameDirectory.cabal - PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-7.10 - PackageTests/GhcPkgGuess/SameDirectoryGhcVersion/ghc-pkg-ghc-7.10 - PackageTests/GhcPkgGuess/SameDirectoryVersion/SameDirectory.cabal - PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-7.10 - PackageTests/GhcPkgGuess/SameDirectoryVersion/ghc-pkg-7.10 - PackageTests/GhcPkgGuess/Symlink/SameDirectory.cabal - PackageTests/GhcPkgGuess/Symlink/bin/ghc - PackageTests/GhcPkgGuess/Symlink/bin/ghc-pkg - PackageTests/GhcPkgGuess/SymlinkGhcVersion/SameDirectory.cabal - PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-7.10 - PackageTests/GhcPkgGuess/SymlinkGhcVersion/bin/ghc-pkg-7.10 - PackageTests/GhcPkgGuess/SymlinkVersion/SameDirectory.cabal - PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-7.10 - PackageTests/GhcPkgGuess/SymlinkVersion/bin/ghc-pkg-ghc-7.10 - PackageTests/Haddock/CPP.hs - PackageTests/Haddock/Literate.lhs - PackageTests/Haddock/NoCPP.hs - PackageTests/Haddock/Simple.hs - PackageTests/Haddock/my.cabal - PackageTests/HaddockNewline/A.hs - PackageTests/HaddockNewline/HaddockNewline.cabal - PackageTests/HaddockNewline/Setup.hs - PackageTests/InternalLibraries/Executable/exe/Main.hs - PackageTests/InternalLibraries/Executable/foo.cabal - PackageTests/InternalLibraries/Executable/src/Foo.hs - PackageTests/InternalLibraries/Library/fooexe/Main.hs - PackageTests/InternalLibraries/Library/fooexe/fooexe.cabal - PackageTests/InternalLibraries/Library/foolib/Foo.hs - PackageTests/InternalLibraries/Library/foolib/foolib.cabal - PackageTests/InternalLibraries/Library/foolib/private/Internal.hs - PackageTests/InternalLibraries/p/Foo.hs - PackageTests/InternalLibraries/p/p.cabal - PackageTests/InternalLibraries/p/p/P.hs - PackageTests/InternalLibraries/p/q/Q.hs - PackageTests/InternalLibraries/q/Q.hs - PackageTests/InternalLibraries/q/q.cabal - PackageTests/InternalLibraries/r/R.hs - PackageTests/InternalLibraries/r/r.cabal - PackageTests/Macros/A.hs - PackageTests/Macros/B.hs - PackageTests/Macros/Main.hs - PackageTests/Macros/macros.cabal - PackageTests/Macros/src/C.hs - PackageTests/Options.hs - PackageTests/OrderFlags/Foo.hs - PackageTests/OrderFlags/my.cabal - PackageTests/PathsModule/Executable/Main.hs - PackageTests/PathsModule/Executable/my.cabal - PackageTests/PathsModule/Library/my.cabal - PackageTests/PreProcess/Foo.hsc - PackageTests/PreProcess/Main.hs - PackageTests/PreProcess/my.cabal - PackageTests/PreProcessExtraSources/Foo.hsc - PackageTests/PreProcessExtraSources/Main.hs - PackageTests/PreProcessExtraSources/my.cabal - PackageTests/ReexportedModules/containers-dupe/Data/Map.hs - PackageTests/ReexportedModules/containers-dupe/containers-dupe.cabal - PackageTests/ReexportedModules/p/Private.hs - PackageTests/ReexportedModules/p/Public.hs - PackageTests/ReexportedModules/p/fail-ambiguous.cabal - PackageTests/ReexportedModules/p/fail-missing.cabal - PackageTests/ReexportedModules/p/fail-other.cabal - PackageTests/ReexportedModules/p/p.cabal - PackageTests/ReexportedModules/q/A.hs - PackageTests/ReexportedModules/q/q.cabal - PackageTests/Regression/T2971/p/include/T2971test.h - PackageTests/Regression/T2971/p/p.cabal - PackageTests/Regression/T2971/q/Bar.hsc - PackageTests/Regression/T2971/q/Foo.hs - PackageTests/Regression/T2971/q/q.cabal - PackageTests/Regression/T2971a/Main.hsc - PackageTests/Regression/T2971a/T2971a.cabal - PackageTests/Regression/T2971a/include/T2971a.h - PackageTests/Regression/T3294/T3294.cabal - PackageTests/Regression/T3847/Main.hs - PackageTests/Regression/T3847/T3847.cabal - PackageTests/Regression/T4025/A.hs - PackageTests/Regression/T4025/T4025.cabal - PackageTests/Regression/T4025/exe/Main.hs - PackageTests/TemplateHaskell/dynamic/Exe.hs - PackageTests/TemplateHaskell/dynamic/Lib.hs - PackageTests/TemplateHaskell/dynamic/TH.hs - PackageTests/TemplateHaskell/dynamic/my.cabal - PackageTests/TemplateHaskell/profiling/Exe.hs - PackageTests/TemplateHaskell/profiling/Lib.hs - PackageTests/TemplateHaskell/profiling/TH.hs - PackageTests/TemplateHaskell/profiling/my.cabal - PackageTests/TemplateHaskell/vanilla/Exe.hs - PackageTests/TemplateHaskell/vanilla/Lib.hs - PackageTests/TemplateHaskell/vanilla/TH.hs - PackageTests/TemplateHaskell/vanilla/my.cabal - PackageTests/TestNameCollision/child/Child.hs - PackageTests/TestNameCollision/child/child.cabal - PackageTests/TestNameCollision/child/tests/Test.hs - PackageTests/TestNameCollision/parent/Parent.hs - PackageTests/TestNameCollision/parent/parent.cabal - PackageTests/TestOptions/TestOptions.cabal - PackageTests/TestOptions/test-TestOptions.hs - PackageTests/TestStanza/my.cabal - PackageTests/TestSuiteTests/ExeV10/Foo.hs - PackageTests/TestSuiteTests/ExeV10/my.cabal - PackageTests/TestSuiteTests/ExeV10/tests/test-Foo.hs - PackageTests/TestSuiteTests/ExeV10/tests/test-Short.hs - PackageTests/TestSuiteTests/LibV09/Lib.hs - PackageTests/TestSuiteTests/LibV09/LibV09.cabal - PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs - PackageTests/UniqueIPID/P1/M.hs - PackageTests/UniqueIPID/P1/my.cabal - PackageTests/UniqueIPID/P2/M.hs - PackageTests/UniqueIPID/P2/my.cabal - PackageTests/multInst/my.cabal - -- END gen-extra-source-files - source-repository head type: git location: https://github.com/haskell/cabal/ subdir: cabal-testsuite --- Large, system tests that build packages. -test-suite package-tests - type: exitcode-stdio-1.0 - main-is: PackageTests.hs - other-modules: - PackageTests.AutogenModules.Package.Check - PackageTests.AutogenModules.SrcDist.Check - PackageTests.BenchmarkStanza.Check - PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check - PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check - PackageTests.CaretOperator.Check - PackageTests.DeterministicAr.Check - PackageTests.ForeignLibs.Check - PackageTests.TestStanza.Check - PackageTests.TestSuiteTests.ExeV10.Check - PackageTests.PackageTester - PackageTests.Tests +library + exposed-modules: + Test.Cabal.Workdir + Test.Cabal.Script + Test.Cabal.Run + Test.Cabal.Plan + Test.Cabal.Prelude + Test.Cabal.Server + Test.Cabal.Monad + Test.Cabal.CheckArMetadata build-depends: + aeson >= 1.1 && <1.3, + attoparsec, + async, base, - containers, - tagged, - tasty, - tasty-hunit, + bytestring, transformers, - time, - Cabal, + optparse-applicative >=0.13 && <0.15, process, directory, filepath, - bytestring, - regex-posix, - old-time + regex-compat-tdfa, + regex-tdfa, + text, + Cabal >= 2.1 + ghc-options: -Wall -fwarn-tabs if !os(windows) build-depends: unix, exceptions - ghc-options: -Wall -rtsopts - default-extensions: CPP + else + build-depends: Win32 + default-language: Haskell2010 + +executable cabal-tests + main-is: cabal-tests.hs + hs-source-dirs: main + ghc-options: -threaded -Wall -fwarn-tabs + build-depends: + async, + base, + Cabal >= 2.1, + clock, + filepath, + process, + optparse-applicative, + cabal-testsuite, + exceptions default-language: Haskell2010 custom-setup diff --git a/cabal/cabal-testsuite/main/cabal-tests.hs b/cabal/cabal-testsuite/main/cabal-tests.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/main/cabal-tests.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE PatternGuards #-} + +import Test.Cabal.Workdir +import Test.Cabal.Script +import Test.Cabal.Server +import Test.Cabal.Monad + +import Distribution.Verbosity (normal, verbose, Verbosity) +import Distribution.Simple.Configure (getPersistBuildConfig) +import Distribution.Simple.Utils (getDirectoryContentsRecursive) + +import Options.Applicative +import Control.Concurrent.MVar +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception +import Control.Monad +import qualified Control.Exception as E +import GHC.Conc (numCapabilities) +import Data.List +import Data.Monoid +import Text.Printf +import qualified System.Clock as Clock +import System.IO +import System.FilePath +import System.Exit +import System.Process (callProcess, showCommandForUser) + +-- | Record for arguments that can be passed to @cabal-tests@ executable. +data MainArgs = MainArgs { + mainArgThreads :: Int, + mainArgTestPaths :: [String], + mainArgHideSuccesses :: Bool, + mainArgVerbose :: Bool, + mainArgQuiet :: Bool, + mainArgDistDir :: Maybe FilePath, + mainCommonArgs :: CommonArgs + } + +-- | optparse-applicative parser for 'MainArgs' +mainArgParser :: Parser MainArgs +mainArgParser = MainArgs + <$> option auto + ( help "Number of threads to run" + <> short 'j' + <> showDefault + <> value numCapabilities + <> metavar "INT") + <*> many (argument str (metavar "FILE")) + <*> switch + ( long "hide-successes" + <> help "Do not print test cases as they are being run" + ) + <*> switch + ( long "verbose" + <> short 'v' + <> help "Be verbose" + ) + <*> switch + ( long "quiet" + <> short 'q' + <> help "Only output stderr on failure" + ) + <*> optional (option str + ( help "Dist directory we were built with" + <> long "builddir" + <> metavar "DIR")) + <*> commonArgParser + +main :: IO () +main = do + -- By default, stderr is not buffered. This isn't really necessary + -- for us, and it causes problems on Windows, see: + -- https://github.com/appveyor/ci/issues/1364 + hSetBuffering stderr LineBuffering + + -- Parse arguments + args <- execParser (info mainArgParser mempty) + let verbosity = if mainArgVerbose args then verbose else normal + + -- To run our test scripts, we need to be able to run Haskell code + -- linked against the Cabal library under test. The most efficient + -- way to get this information is by querying the *host* build + -- system about the information. + -- + -- Fortunately, because we are using a Custom setup, our Setup + -- script is bootstrapped against the Cabal library we're testing + -- against, so can use our dependency on Cabal to read out the build + -- info *for this package*. + -- + -- NB: Currently assumes that per-component build is NOT turned on + -- for Custom. + dist_dir <- case mainArgDistDir args of + Just dist_dir -> return dist_dir + Nothing -> guessDistDir + when (verbosity >= verbose) $ + hPutStrLn stderr $ "Using dist dir: " ++ dist_dir + lbi <- getPersistBuildConfig dist_dir + + -- Get ready to go! + senv <- mkScriptEnv verbosity lbi + let runTest runner path + = runner Nothing [] path $ + ["--builddir", dist_dir, path] ++ renderCommonArgs (mainCommonArgs args) + + case mainArgTestPaths args of + [path] -> do + -- Simple runner + (real_path, real_args) <- runTest (runnerCommand senv) path + hPutStrLn stderr $ showCommandForUser real_path real_args + callProcess real_path real_args + hPutStrLn stderr "OK" + user_paths -> do + -- Read out tests from filesystem + hPutStrLn stderr $ "threads: " ++ show (mainArgThreads args) + + test_scripts <- if null user_paths + then findTests + else return user_paths + -- NB: getDirectoryContentsRecursive is lazy IO, but it + -- doesn't handle directories disappearing gracefully. Fix + -- this! + (single_tests, multi_tests) <- evaluate (partitionTests test_scripts) + let all_tests = multi_tests ++ single_tests + margin = maximum (map length all_tests) + 2 + hPutStrLn stderr $ "tests to run: " ++ show (length all_tests) + + -- TODO: Get parallelization out of multitests by querying + -- them for their modes and then making a separate worker + -- for each. But for now, just run them earlier to avoid + -- them straggling at the end + work_queue <- newMVar all_tests + unexpected_fails_var <- newMVar [] + unexpected_passes_var <- newMVar [] + + chan <- newChan + let logAll msg = writeChan chan (ServerLogMsg AllServers msg) + logEnd = writeChan chan ServerLogEnd + -- NB: don't use withAsync as we do NOT want to cancel this + -- on an exception + async_logger <- async (withFile "cabal-tests.log" WriteMode $ outputThread verbosity chan) + + -- Make sure we pump out all the logs before quitting + (\m -> finally m (logEnd >> wait async_logger)) $ do + + -- NB: Need to use withAsync so that if the main thread dies + -- (due to ctrl-c) we tear down all of the worker threads. + let go server = do + let split [] = return ([], Nothing) + split (y:ys) = return (ys, Just y) + logMeta msg = writeChan chan + $ ServerLogMsg + (ServerMeta (serverProcessId server)) + msg + mb_work <- modifyMVar work_queue split + case mb_work of + Nothing -> return () + Just path -> do + when (verbosity >= verbose) $ + logMeta $ "Running " ++ path + start <- getTime + r <- runTest (runOnServer server) path + end <- getTime + let time = end - start + code = serverResultExitCode r + status + | code == ExitSuccess + = "OK" + | code == ExitFailure skipExitCode + = "SKIP" + | code == ExitFailure expectedBrokenExitCode + = "KNOWN FAIL" + | code == ExitFailure unexpectedSuccessExitCode + = "UNEXPECTED OK" + | otherwise + = "FAIL" + unless (mainArgHideSuccesses args && status /= "FAIL") $ do + logMeta $ + path ++ replicate (margin - length path) ' ' ++ status ++ + if time >= 0.01 + then printf " (%.2fs)" time + else "" + when (status == "FAIL") $ do -- TODO: ADT + let description + | mainArgQuiet args = serverResultStderr r + | otherwise = + "$ " ++ serverResultCommand r ++ "\n" ++ + "stdout:\n" ++ serverResultStdout r ++ "\n" ++ + "stderr:\n" ++ serverResultStderr r ++ "\n" + logMeta $ + description + ++ "*** unexpected failure for " ++ path ++ "\n\n" + modifyMVar_ unexpected_fails_var $ \paths -> + return (path:paths) + when (status == "UNEXPECTED OK") $ + modifyMVar_ unexpected_passes_var $ \paths -> + return (path:paths) + go server + + mask $ \restore -> do + -- Start as many threads as requested by -j to spawn + -- GHCi servers and start running tests off of the + -- run queue. + -- NB: we don't use 'withAsync' because it's more + -- convenient to generate n threads this way (and when + -- one fails, we can cancel everyone at once.) + as <- replicateM (mainArgThreads args) + (async (restore (withNewServer chan senv go))) + restore (mapM_ wait as) `E.catch` \e -> do + -- Be patient, because if you ^C again, you might + -- leave some zombie GHCi processes around! + logAll "Shutting down GHCi sessions (please be patient)..." + -- Start cleanup on all threads concurrently. + mapM_ (async . cancel) as + -- Wait for the threads to finish cleaning up. NB: + -- do NOT wait on the cancellation asynchronous actions; + -- these complete when the message is *delivered*, not + -- when cleanup is done. + rs <- mapM waitCatch as + -- Take a look at the returned exit codes, and figure out + -- if something errored in an unexpected way. This + -- could mean there's a zombie. + forM_ rs $ \r -> case r of + Left err + | Just ThreadKilled <- fromException err + -> return () + | otherwise + -> logAll ("Unexpected failure on GHCi exit: " ++ show e) + _ -> return () + -- Propagate the exception + throwIO (e :: SomeException) + + unexpected_fails <- takeMVar unexpected_fails_var + unexpected_passes <- takeMVar unexpected_passes_var + if not (null (unexpected_fails ++ unexpected_passes)) + then do + unless (null unexpected_passes) . logAll $ + "UNEXPECTED OK: " ++ intercalate " " unexpected_passes + unless (null unexpected_fails) . logAll $ + "UNEXPECTED FAIL: " ++ intercalate " " unexpected_fails + exitFailure + else logAll "OK" + +findTests :: IO [FilePath] +findTests = getDirectoryContentsRecursive "." + +partitionTests :: [FilePath] -> ([FilePath], [FilePath]) +partitionTests = go [] [] + where + go ts ms [] = (ts, ms) + go ts ms (f:fs) = + -- NB: Keep this synchronized with isTestFile + case takeExtensions f of + ".test.hs" -> go (f:ts) ms fs + ".multitest.hs" -> go ts (f:ms) fs + _ -> go ts ms fs + +outputThread :: Verbosity -> Chan ServerLogMsg -> Handle -> IO () +outputThread verbosity chan log_handle = go "" + where + go prev_hdr = do + v <- readChan chan + case v of + ServerLogEnd -> return () + ServerLogMsg t msg -> do + let ls = lines msg + pre s c + | verbosity >= verbose + -- Didn't use printf as GHC 7.4 + -- doesn't understand % 7s. + = replicate (7 - length s) ' ' ++ s ++ " " ++ c : " " + | otherwise = "" + hdr = case t of + AllServers -> "" + ServerMeta s -> pre s ' ' + ServerIn s -> pre s '<' + ServerOut s -> pre s '>' + ServerErr s -> pre s '!' + ws = replicate (length hdr) ' ' + mb_hdr l | hdr == prev_hdr = ws ++ l + | otherwise = hdr ++ l + ls' = case ls of + [] -> [] + r:rs -> + mb_hdr r : map (ws ++) rs + logmsg = unlines ls' + hPutStr stderr logmsg + hPutStr log_handle logmsg + go hdr + +-- Cribbed from tasty +type Time = Double + +getTime :: IO Time +getTime = do + t <- Clock.getTime Clock.Monotonic + let ns = realToFrac $ Clock.toNanoSecs t + return $ ns / 10 ^ (9 :: Int) diff --git a/cabal/cabal-testsuite/tests/Setup.hs b/cabal/cabal-testsuite/tests/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/tests/Setup.hs @@ -0,0 +1,4 @@ +import System.Exit + +main :: IO () +main = exitFailure diff --git a/cabal/cabal-testsuite/tests/fail.out b/cabal/cabal-testsuite/tests/fail.out new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/tests/fail.out @@ -0,0 +1,1 @@ +# Setup configure diff --git a/cabal/cabal-testsuite/tests/fail.test.hs b/cabal/cabal-testsuite/tests/fail.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/tests/fail.test.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE ScopedTypeVariables #-} +import Test.Cabal.Prelude +import Data.IORef +import Control.Monad.IO.Class +import Control.Exception (ErrorCall) + +import qualified Control.Monad.Catch as Catch + +main = setupTest $ do + -- the following is a hack to check that `setup configure` indeed + -- fails: all tests use `assertFailure` which uses `error` if the fail + -- + -- note: we cannot use `fails $ do ...` here since that only checks that all + -- assertions fail. If there is no assertion in `m`, then `fails m` will *succeed*. + -- That's not what we want. So `fails (return ())` for example succeeds, even though + -- `return ()` doesn't fail. + succeededRef <- liftIO $ newIORef True + setup "configure" [] `Catch.catch` \(_ :: ErrorCall) -> + liftIO $ writeIORef succeededRef False + succeeded <- liftIO $ readIORef succeededRef + assertBool "test should have failed, but succeeded instead (configure exits with failure)" $ not succeeded diff --git a/cabal/cabal-testsuite/tests/ok.test.hs b/cabal/cabal-testsuite/tests/ok.test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/tests/ok.test.hs @@ -0,0 +1,2 @@ +import Test.Cabal.Prelude +main = return () diff --git a/cabal/cabal-testsuite/tests/tests.cabal b/cabal/cabal-testsuite/tests/tests.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-testsuite/tests/tests.cabal @@ -0,0 +1,4 @@ +name: foo +version: 0.1 +build-type: Custom + diff --git a/cabal/cabal.project b/cabal/cabal.project --- a/cabal/cabal.project +++ b/cabal/cabal.project @@ -1,13 +1,18 @@ -packages: Cabal/ cabal-testsuite/ cabal-install/ -constraints: unix >= 2.7.1.0 +packages: Cabal/ cabal-testsuite/ cabal-install/ solver-benchmarks/ +constraints: unix >= 2.7.1.0, + cabal-install +lib +monolithic -- 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 + -- + -- 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 diff --git a/cabal/cabal.project.meta b/cabal/cabal.project.meta new file mode 100644 --- /dev/null +++ b/cabal/cabal.project.meta @@ -0,0 +1,1 @@ +packages: cabal-dev-scripts diff --git a/cabal/cabal.project.travis b/cabal/cabal.project.travis --- a/cabal/cabal.project.travis +++ b/cabal/cabal.project.travis @@ -3,6 +3,15 @@ -- Turn off parallelization to get good errors. jobs: 1 +constraints: cabal-install +monolithic + +-- 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!) diff --git a/cabal/generics-sop-lens.hs b/cabal/generics-sop-lens.hs new file mode 100644 --- /dev/null +++ b/cabal/generics-sop-lens.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +import qualified GHC.Generics as GHC +import Data.Char (toLower) +import Data.List (stripPrefix) +import Data.Typeable +import Generics.SOP +import Generics.SOP.GGP + +-- | An example of generic deriving of lens code. +-- +-- >>> putStrLn $ genericLenses (Proxy :: Proxy Foobar) +-- fooBar :: Lens' Foobar Int +-- fooBar f s = fmap (\x -> s { T.fooBar = x }) (T.fooBar s) +-- {-# INLINE fooBar #-} +-- +-- fooXyzzy :: Lens' Foobar [[Char]] +-- fooXyzzy f s = fmap (\x -> s { T.fooXyzzy = x }) (T.fooXyzzy s) +-- {-# INLINE fooXyzzy #-} +-- ... +-- +-- /Note:/ 'FilePath' i.e @type@ aliases are lost. +-- +data Foobar = Foobar + { fooBar :: Int + , fooXyzzy :: [FilePath] + , fooQuux :: Bool + } + deriving (GHC.Generic) + +genericLenses + :: forall a xs proxy. (GDatatypeInfo a, GCode a ~ '[xs], All Typeable xs) + => proxy a + -> String +genericLenses p = case gdatatypeInfo p of + Newtype _ _ _ -> "-- newtype deriving not implemented" + ADT _ _ (Constructor _ :* Nil) -> "-- fieldnameless deriving not implemented" + ADT _ _ (Infix _ _ _ :* Nil) -> "-- infix consturctor deriving not implemented" + ADT _ dn (Record _ fis :* Nil) -> + unlines $ concatMap replaceTypes $ hcollapse $ hcmap (Proxy :: Proxy Typeable) derive fis + where + derive :: forall x. Typeable x => FieldInfo x -> K [String] x + derive (FieldInfo fi) = K + [ fi ++ " :: Lens' " ++ dn ++ " " ++ showsPrec 11 (typeRep (Proxy :: Proxy x)) [] + , fi ++ " f s = fmap (\\x -> s { T." ++ fi ++ " = x }) (f (T." ++ fi ++ " s))" + , "{-# INLINE " ++ fi ++ " #-}" + , "" + ] + +genericClassyLenses + :: forall a xs proxy. (GDatatypeInfo a, GCode a ~ '[xs], All Typeable xs) + => proxy a + -> String +genericClassyLenses p = case gdatatypeInfo p of + Newtype _ _ _ -> "-- newtype deriving not implemented" + ADT _ _ (Constructor _ :* Nil) -> "-- fieldnameless deriving not implemented" + ADT _ _ (Infix _ _ _ :* Nil) -> "-- infix consturctor deriving not implemented" + ADT _ dn (Record _ fis :* Nil) -> + unlines $ concatMap replaceTypes $ + [[ "class Has" ++ dn ++ " a where" + , " " ++ dn' ++ " :: Lens' a " ++ dn + , "" + ]] ++ + (hcollapse $ hcmap (Proxy :: Proxy Typeable) deriveCls fis) ++ + [[ "" + , "instance Has" ++ dn ++ " " ++ dn ++ " where" + , " " ++ dn' ++ " = id" + , " {-# INLINE " ++ dn' ++ " #-}" + ]] ++ + (hcollapse $ hcmap (Proxy :: Proxy Typeable) deriveInst fis) + where + dn' = case dn of + [] -> [] + c:cs -> toLower c : cs + + deriveCls :: forall x. Typeable x => FieldInfo x -> K [String] x + deriveCls (FieldInfo fi) = K + [ " " ++ fi ++ " :: Lens' a " ++ showsPrec 11 (typeRep (Proxy :: Proxy x)) [] + , " " ++ fi ++ " = " ++ dn' ++ " . " ++ fi + , " {-# INLINE " ++ fi ++ " #-}" + , "" + ] + + deriveInst :: forall x. Typeable x => FieldInfo x -> K [String] x + deriveInst (FieldInfo fi) = K + [ " " ++ fi ++ " f s = fmap (\\x -> s { T." ++ fi ++ " = x }) (f (T." ++ fi ++ " s))" + , " {-# INLINE " ++ fi ++ " #-}" + , "" + ] + +replaceTypes :: [String] -> [String] +replaceTypes = map + $ replace "[Char]" "String" + +replace :: String -> String -> String -> String +replace needle replacement = go where + go [] = [] + go xs@(x:xs') + | Just ys <- stripPrefix needle xs = replacement ++ go ys + | otherwise = x : go xs' diff --git a/cabal/solver-benchmarks/HackageBenchmark.hs b/cabal/solver-benchmarks/HackageBenchmark.hs new file mode 100644 --- /dev/null +++ b/cabal/solver-benchmarks/HackageBenchmark.hs @@ -0,0 +1,320 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module HackageBenchmark ( + hackageBenchmarkMain + +-- Exposed for testing: + , CabalResult(..) + , isSignificantTimeDifference + , combineTrialResults + , isSignificantResult + , shouldContinueAfterFirstTrial + ) where + +import Control.Monad (forM_, replicateM, unless, when) +import qualified Data.ByteString as B +import Data.List (nub, unzip4) +import Data.Maybe (isJust) +import Data.Monoid ((<>)) +import Data.String (fromString) +import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime) +import qualified Data.Vector.Unboxed as V +import Options.Applicative +import Statistics.Sample (mean, stdDev) +import Statistics.Test.MannWhitneyU ( PositionTest(..), TestResult(..) + , mannWhitneyUCriticalValue + , mannWhitneyUtest) +import Statistics.Types (PValue, mkPValue) +import System.Exit (ExitCode(..), exitFailure) +import System.IO ( BufferMode(LineBuffering), hPutStrLn, hSetBuffering, stderr + , stdout) +import System.Process ( StdStream(CreatePipe), CreateProcess(..), callProcess + , createProcess, readProcess, shell, waitForProcess ) +import Text.Printf (printf) + +import Distribution.Package (PackageName, mkPackageName, unPackageName) + +data Args = Args { + argCabal1 :: FilePath + , argCabal2 :: FilePath + , argCabal1Flags :: [String] + , argCabal2Flags :: [String] + , argPackages :: [PackageName] + , argMinRunTimeDifferenceToRerun :: Double + , argPValue :: PValue Double + , argTrials :: Int + , argPrintTrials :: Bool + , argPrintSkippedPackages :: Bool + , argTimeoutSeconds :: Int + } + +data CabalTrial = CabalTrial NominalDiffTime CabalResult + +data CabalResult + = Solution + | NoInstallPlan + | BackjumpLimit + | PkgNotFound + | Timeout + | Unknown + deriving (Eq, Show) + +hackageBenchmarkMain :: IO () +hackageBenchmarkMain = do + hSetBuffering stdout LineBuffering + args@Args {..} <- execParser parserInfo + checkArgs args + printConfig args + pkgs <- getPackages args + putStrLn "" + + let -- The maximum length of the heading and package names. + nameColumnWidth :: Int + nameColumnWidth = + maximum $ map length $ "package" : map unPackageName pkgs + runCabal1 = runCabal argTimeoutSeconds argCabal1 argCabal1Flags + runCabal2 = runCabal argTimeoutSeconds argCabal2 argCabal2Flags + + -- When the output contains both trails and summaries, label each row as + -- "trial" or "summary". + when argPrintTrials $ putStr $ printf "%-16s " "trial/summary" + putStrLn $ + printf "%-*s %-13s %-13s %11s %11s %11s %11s %11s" + nameColumnWidth "package" "result1" "result2" + "mean1" "mean2" "stddev1" "stddev2" "speedup" + + forM_ pkgs $ \pkg -> do + let printTrial msgType result1 result2 time1 time2 = + putStrLn $ + printf "%-16s %-*s %-13s %-13s %10.3fs %10.3fs" + msgType nameColumnWidth (unPackageName pkg) + (show result1) (show result2) + (diffTimeToDouble time1) (diffTimeToDouble time2) + + CabalTrial t1 r1 <- runCabal1 pkg + CabalTrial t2 r2 <- runCabal2 pkg + if not $ + shouldContinueAfterFirstTrial argMinRunTimeDifferenceToRerun t1 t2 r1 r2 + then when argPrintSkippedPackages $ + if argPrintTrials + then printTrial "trial (skipping)" r1 r2 t1 t2 + else putStrLn $ printf "%-*s (first run times were too similar)" + nameColumnWidth (unPackageName pkg) + else do + when argPrintTrials $ printTrial "trial" r1 r2 t1 t2 + (ts1, ts2, rs1, rs2) <- (unzip4 . ((t1, t2, r1, r2) :) <$>) + . replicateM (argTrials - 1) $ do + CabalTrial t1' r1' <- runCabal1 pkg + CabalTrial t2' r2' <- runCabal2 pkg + when argPrintTrials $ printTrial "trial" r1' r2' t1' t2' + return (t1', t2', r1', r2') + + let result1 = combineTrialResults rs1 + result2 = combineTrialResults rs2 + times1 = V.fromList (map diffTimeToDouble ts1) + times2 = V.fromList (map diffTimeToDouble ts2) + mean1 = mean times1 + mean2 = mean times2 + stddev1 = stdDev times1 + stddev2 = stdDev times2 + speedup = mean1 / mean2 + + when argPrintTrials $ putStr $ printf "%-16s " "summary" + if isSignificantResult result1 result2 + || isSignificantTimeDifference argPValue ts1 ts2 + then putStrLn $ + printf "%-*s %-13s %-13s %10.3fs %10.3fs %10.3fs %10.3fs %10.3f" + nameColumnWidth (unPackageName pkg) + (show result1) (show result2) mean1 mean2 stddev1 stddev2 speedup + else when (argPrintTrials || argPrintSkippedPackages) $ + putStrLn $ + printf "%-*s (not significant)" nameColumnWidth (unPackageName pkg) + where + checkArgs :: Args -> IO () + checkArgs Args {..} = do + let die msg = hPutStrLn stderr msg >> exitFailure + unless (argTrials > 0) $ die "--trials must be greater than 0." + unless (argMinRunTimeDifferenceToRerun >= 0) $ + die "--min-run-time-percentage-difference-to-rerun must be non-negative." + unless (isSampleLargeEnough argPValue argTrials) $ + die "p-value is too small for the number of trials." + + printConfig :: Args -> IO () + printConfig Args {..} = do + putStrLn "Comparing:" + putStrLn $ "1: " ++ argCabal1 ++ " " ++ unwords argCabal1Flags + callProcess argCabal1 ["--version"] + putStrLn $ "2: " ++ argCabal2 ++ " " ++ unwords argCabal2Flags + callProcess argCabal2 ["--version"] + -- TODO: Print index state. + putStrLn "Base package database:" + callProcess "ghc-pkg" ["list"] + + getPackages :: Args -> IO [PackageName] + getPackages Args {..} = do + pkgs <- + if null argPackages + then do + putStrLn $ "Obtaining the package list (using " ++ argCabal1 ++ ") ..." + list <- readProcess argCabal1 ["list", "--simple-output"] "" + return $ nub [mkPackageName $ head (words line) | line <- lines list] + else do + putStrLn "Using given package list ..." + return argPackages + putStrLn $ "Done, got " ++ show (length pkgs) ++ " packages." + return pkgs + +runCabal :: Int -> FilePath -> [String] -> PackageName -> IO CabalTrial +runCabal timeoutSeconds cabal flags pkg = do + ((exitCode, err), time) <- timeEvent $ do + let timeout = "timeout --foreground -sINT " ++ show timeoutSeconds + cabalCmd = + unwords $ + [cabal, "install", unPackageName pkg, "--dry-run", "-v0"] ++ flags + cmd = (shell (timeout ++ " " ++ cabalCmd)) { std_err = CreatePipe } + + -- TODO: Read stdout and compare the install plans. + (_, _, Just errh, ph) <- createProcess cmd + err <- B.hGetContents errh + (, err) <$> waitForProcess ph + let exhaustiveMsg = + "After searching the rest of the dependency tree exhaustively" + result + | exitCode == ExitSuccess = Solution + | exitCode == ExitFailure 124 = Timeout + | fromString exhaustiveMsg `B.isInfixOf` err = NoInstallPlan + | fromString "Backjump limit reached" `B.isInfixOf` err = BackjumpLimit + | fromString "There is no package named" `B.isInfixOf` err = PkgNotFound + | otherwise = Unknown + return (CabalTrial time result) + +isSampleLargeEnough :: PValue Double -> Int -> Bool +isSampleLargeEnough pvalue trials = + -- mannWhitneyUCriticalValue, which can fail with too few samples, is only + -- used when both sample sizes are less than or equal to 20. + trials > 20 || isJust (mannWhitneyUCriticalValue (trials, trials) pvalue) + +isSignificantTimeDifference :: PValue Double -> [NominalDiffTime] -> [NominalDiffTime] -> Bool +isSignificantTimeDifference pvalue xs ys = + let toVector = V.fromList . map diffTimeToDouble + in case mannWhitneyUtest SamplesDiffer pvalue (toVector xs) (toVector ys) of + Nothing -> error "not enough data for mannWhitneyUtest" + Just Significant -> True + Just NotSignificant -> False + +-- Should we stop after the first trial of this package to save time? This +-- function skips the package if the results are uninteresting and the times are +-- within --min-run-time-percentage-difference-to-rerun. +shouldContinueAfterFirstTrial :: Double + -> NominalDiffTime + -> NominalDiffTime + -> CabalResult + -> CabalResult + -> Bool +shouldContinueAfterFirstTrial 0 _ _ _ _ = True +shouldContinueAfterFirstTrial _ _ _ Timeout Timeout = False +shouldContinueAfterFirstTrial maxRunTimeDifferenceToIgnore t1 t2 r1 r2 = + isSignificantResult r1 r2 + || abs (t1 - t2) / min t1 t2 >= realToFrac (maxRunTimeDifferenceToIgnore / 100) + +isSignificantResult :: CabalResult -> CabalResult -> Bool +isSignificantResult r1 r2 = r1 /= r2 || not (isExpectedResult r1) + +-- Is this result expected in a benchmark run on all of Hackage? +isExpectedResult :: CabalResult -> Bool +isExpectedResult Solution = True +isExpectedResult NoInstallPlan = True +isExpectedResult BackjumpLimit = True +isExpectedResult Timeout = True +isExpectedResult PkgNotFound = False +isExpectedResult Unknown = False + +-- Combine CabalResults from multiple trials. Ignoring timeouts, all results +-- should be the same. If they aren't the same, we returns Unknown. +combineTrialResults :: [CabalResult] -> CabalResult +combineTrialResults rs + | allEqual rs = head rs + | allEqual [r | r <- rs, r /= Timeout] = Timeout + | otherwise = Unknown + where + allEqual :: Eq a => [a] -> Bool + allEqual xs = length (nub xs) == 1 + +timeEvent :: IO a -> IO (a, NominalDiffTime) +timeEvent task = do + start <- getCurrentTime + r <- task + end <- getCurrentTime + return (r, diffUTCTime end start) + +diffTimeToDouble :: NominalDiffTime -> Double +diffTimeToDouble = fromRational . toRational + +parserInfo :: ParserInfo Args +parserInfo = info (argParser <**> helper) + ( fullDesc + <> progDesc ("Find differences between two cabal commands when solving" + ++ " for all packages on Hackage.") + <> header "hackage-benchmark" ) + +argParser :: Parser Args +argParser = Args + <$> strOption + ( long "cabal1" + <> metavar "PATH" + <> help "First cabal executable") + <*> strOption + ( long "cabal2" + <> metavar "PATH" + <> help "Second cabal executable") + <*> option (words <$> str) + ( long "cabal1-flags" + <> value [] + <> metavar "FLAGS" + <> help "Extra flags for the first cabal executable") + <*> option (words <$> str) + ( long "cabal2-flags" + <> value [] + <> metavar "FLAGS" + <> help "Extra flags for the second cabal executable") + <*> option (map mkPackageName . words <$> str) + ( long "packages" + <> value [] + <> metavar "PACKAGES" + <> help ("Space separated list of packages to test, or all of Hackage" + ++ " if unspecified")) + <*> option auto + ( long "min-run-time-percentage-difference-to-rerun" + <> showDefault + <> value 0.0 + <> metavar "PERCENTAGE" + <> help ("Stop testing a package when the difference in run times in" + ++ " the first trial are within this percentage, in order to" + ++ " save time")) + <*> option (mkPValue <$> auto) + ( long "pvalue" + <> showDefault + <> value (mkPValue 0.05) + <> metavar "DOUBLE" + <> help ("p-value used to determine whether to print the results for" + ++ " each package")) + <*> option auto + ( long "trials" + <> showDefault + <> value 10 + <> metavar "N" + <> help "Number of trials for each package") + <*> switch + ( long "print-trials" + <> help "Whether to include the results from individual trials in the output") + <*> switch + ( long "print-skipped-packages" + <> help "Whether to include skipped packages in the output") + <*> option auto + ( long "timeout" + <> showDefault + <> value 90 + <> metavar "SECONDS" + <> help "Maximum time to run a cabal command, in seconds") diff --git a/cabal/solver-benchmarks/LICENSE b/cabal/solver-benchmarks/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/solver-benchmarks/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2003-2017, Cabal Development Team. +See the AUTHORS file for the full list of copyright holders. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cabal/solver-benchmarks/README.md b/cabal/solver-benchmarks/README.md new file mode 100644 --- /dev/null +++ b/cabal/solver-benchmarks/README.md @@ -0,0 +1,17 @@ +Dependency Solver Benchmarks +============================ + +hackage-benchmark +----------------- + +The goal of this benchmark is to find examples of packages that show a +difference in behavior between two versions of cabal. It doesn't try +to determine which version of cabal performs better. + +`hackage-benchmark` compares two `cabal` commands by running each one +on each package in a list. The list is either the package index or a +list of packages provided on the command line. In order to save time, +the benchmark initially only runs one trial for each package. If the +results (solution, no solution, timeout, etc.) are the same and the +times are too similar, it skips the package. Otherwise, it runs more +trials and prints the results if they are significant. diff --git a/cabal/solver-benchmarks/main/hackage-benchmark.hs b/cabal/solver-benchmarks/main/hackage-benchmark.hs new file mode 100644 --- /dev/null +++ b/cabal/solver-benchmarks/main/hackage-benchmark.hs @@ -0,0 +1,4 @@ +import HackageBenchmark + +main :: IO () +main = hackageBenchmarkMain diff --git a/cabal/solver-benchmarks/solver-benchmarks.cabal b/cabal/solver-benchmarks/solver-benchmarks.cabal new file mode 100644 --- /dev/null +++ b/cabal/solver-benchmarks/solver-benchmarks.cabal @@ -0,0 +1,60 @@ +name: solver-benchmarks +version: 2.1.0.0 +copyright: 2003-2017, Cabal Development Team (see AUTHORS file) +license: BSD3 +license-file: LICENSE +author: Cabal Development Team +maintainer: cabal-devel@haskell.org +homepage: http://www.haskell.org/cabal/ +bug-reports: https://github.com/haskell/cabal/issues +synopsis: Benchmarks for the cabal dependency solver +description: + This package contains benchmarks that test cabal's dependency solver by running the cabal executable. +category: Distribution +cabal-version: >=1.10 +build-type: Simple + +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/haskell/cabal/ + subdir: solver-benchmarks + +library + ghc-options: -Wall -fwarn-tabs + exposed-modules: + HackageBenchmark + build-depends: + base, + bytestring, + Cabal >= 2.1, + optparse-applicative, + process, + time, + statistics >= 0.14 && < 0.15, + vector + default-language: Haskell2010 + +executable hackage-benchmark + main-is: hackage-benchmark.hs + hs-source-dirs: main + ghc-options: -threaded -Wall -fwarn-tabs + build-depends: + base, + solver-benchmarks + default-language: Haskell2010 + +test-suite unit-tests + type: exitcode-stdio-1.0 + main-is: HackageBenchmarkTest.hs + hs-source-dirs: tests + ghc-options: -threaded -Wall -fwarn-tabs + build-depends: + base, + solver-benchmarks, + statistics >= 0.14 && < 0.15, + tasty, + tasty-hunit + default-language: Haskell2010 diff --git a/cabal/solver-benchmarks/tests/HackageBenchmarkTest.hs b/cabal/solver-benchmarks/tests/HackageBenchmarkTest.hs new file mode 100644 --- /dev/null +++ b/cabal/solver-benchmarks/tests/HackageBenchmarkTest.hs @@ -0,0 +1,89 @@ +import HackageBenchmark +import Statistics.Types (mkPValue) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (assert, testCase, (@?=)) + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "unit tests" [ + + testGroup "isSignificantTimeDifference" [ + + testCase "detect increase in distribution" $ assert $ + isSignificantTimeDifference (mkPValue 0.05) [1,2..7] [4,5..10] + + , testCase "detect decrease in distribution" $ assert $ + isSignificantTimeDifference (mkPValue 0.05) [1,2..7] [-2,-1..4] + + , testCase "ignore same data" $ assert $ + not $ isSignificantTimeDifference (mkPValue 0.05) [1,2..10] [1,2..10] + + , testCase "same data with high p-value is significant" $ assert $ + isSignificantTimeDifference (mkPValue 0.9) [1,2..10] [1,2..10] + + , testCase "ignore outlier" $ assert $ + not $ isSignificantTimeDifference (mkPValue 0.05) [1, 2, 1, 1, 1] [2, 1, 50, 1, 1] + ] + + , testGroup "combineTrialResults" [ + + testCase "convert unexpected difference to Unknown" $ + combineTrialResults [NoInstallPlan, BackjumpLimit] @?= Unknown + + , testCase "return one of identical errors" $ + combineTrialResults [NoInstallPlan, NoInstallPlan] @?= NoInstallPlan + + , testCase "return one of identical successes" $ + combineTrialResults [Solution, Solution] @?= Solution + + , testCase "timeout overrides other results" $ + combineTrialResults [Solution, Timeout, Solution] @?= Timeout + + , testCase "convert unexpected difference to Unknown, even with timeout" $ + combineTrialResults [Solution, Timeout, NoInstallPlan] @?= Unknown + ] + + , testGroup "isSignificantResult" [ + + testCase "different results are significant" $ assert $ + isSignificantResult NoInstallPlan BackjumpLimit + + , testCase "unknown result is significant" $ assert $ + isSignificantResult Unknown Unknown + + , testCase "PkgNotFound is significant" $ assert $ + isSignificantResult PkgNotFound PkgNotFound + + , testCase "same expected error is not significant" $ assert $ + not $ isSignificantResult NoInstallPlan NoInstallPlan + + , testCase "success is not significant" $ assert $ + not $ isSignificantResult Solution Solution + ] + + , testGroup "shouldContinueAfterFirstTrial" [ + + testCase "rerun when min difference is zero" $ assert $ + shouldContinueAfterFirstTrial 0 1.0 1.0 Solution Solution + + , testCase "rerun when min difference is zero, even with timeout" $ assert $ + shouldContinueAfterFirstTrial 0 1.0 1.0 Timeout Timeout + + , testCase "treat timeouts as the same time" $ assert $ + not $ shouldContinueAfterFirstTrial 0.000001 89.9 92.0 Timeout Timeout + + , testCase "skip when times are too close - 1" $ assert $ + not $ shouldContinueAfterFirstTrial 10 1.0 0.91 Solution Solution + + , testCase "skip when times are too close - 2" $ assert $ + not $ shouldContinueAfterFirstTrial 10 1.0 1.09 Solution Solution + + , testCase "rerun when times aren't too close - 1" $ assert $ + shouldContinueAfterFirstTrial 10 1.0 0.905 Solution Solution + + , testCase "rerun when times aren't too close - 2" $ assert $ + shouldContinueAfterFirstTrial 10 1.0 1.1 Solution Solution + ] + ] diff --git a/cabal/stack.yaml b/cabal/stack.yaml --- a/cabal/stack.yaml +++ b/cabal/stack.yaml @@ -1,52 +1,15 @@ -resolver: ghc-8.0.1 +resolver: nightly-2017-11-01 packages: - Cabal/ - cabal-install/ +- cabal-testsuite/ extra-deps: -- ansi-terminal-0.6.2.3 -- ansi-wl-pprint-0.6.7.3 -- async-2.1.0 -- base16-bytestring-0.1.1.6 -- base64-bytestring-1.0.0.1 -- clock-0.7.2 -- cryptohash-sha256-0.11.100.1 -- ed25519-0.0.5.0 -- edit-distance-0.2.2.1 -- exceptions-0.8.2.1 -- hackage-security-0.5.2.2 -- hashable-1.2.4.0 -- haskell-lexer-1.0 -- HTTP-4000.3.3 -- mtl-2.2.1 -- network-2.6.2.1 -- network-uri-2.6.1.0 -- old-locale-1.0.0.7 -- old-time-1.1.0.3 -- optparse-applicative-0.12.1.0 -- parsec-3.1.11 -- pretty-show-1.6.10 -- primitive-0.6.1.0 -- QuickCheck-2.8.2 -- random-1.1 -- regex-base-0.93.2 -- regex-posix-0.95.2 -- regex-tdfa-1.2.2 -- stm-2.4.4.1 -- tagged-0.8.4 -- tar-0.5.0.3 -- tasty-0.11.0.3 -- tasty-hunit-0.9.2 -- tasty-quickcheck-0.8.4 -- text-1.2.2.1 -- tf-random-0.5 -- transformers-compat-0.5.1.4 -- unbounded-delays-0.1.0.9 -- zlib-0.6.1.1 -flags: {} + - resolv-0.1.1.1 nix: packages: - autoconf - automake - haskellPackages.happy + - haskellPackages.alex - zlib - zlib.out diff --git a/cabal/travis-common.sh b/cabal/travis-common.sh --- a/cabal/travis-common.sh +++ b/cabal/travis-common.sh @@ -1,7 +1,23 @@ set -e -CABAL_VERSION="1.25.0.0" +HACKAGE_REPO_TOOL_VERSION="0.1.1" +CABAL_VERSION="2.1.0.0" +if [ "$TRAVIS_OS_NAME" = "linux" ]; then + ARCH="x86_64-linux" +else + ARCH="x86_64-osx" +fi + +CABAL_STORE_DB="${HOME}/.cabal/store/ghc-${GHCVER}/package.db" +CABAL_LOCAL_DB="${TRAVIS_BUILD_DIR}/dist-newstyle/packagedb/ghc-${GHCVER}" +CABAL_BDIR="${TRAVIS_BUILD_DIR}/dist-newstyle/build/$ARCH/ghc-$GHCVER/Cabal-${CABAL_VERSION}" +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_VERSION}" +CABAL_INSTALL_SETUP="${CABAL_INSTALL_BDIR}/setup/setup" +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}/c/hackage-repo-tool" + # --------------------------------------------------------------------- # Timing / diagnostic output # --------------------------------------------------------------------- @@ -30,4 +46,8 @@ exit 1 fi echo "----" +} + +travis_retry () { + $* || (sleep 1 && $*) || (sleep 2 && $*) } diff --git a/cabal/travis-deploy.sh b/cabal/travis-deploy.sh --- a/cabal/travis-deploy.sh +++ b/cabal/travis-deploy.sh @@ -8,7 +8,7 @@ (cd cabal-website && git checkout --track -b gh-pages origin/gh-pages) rm -rf cabal-website/doc mkdir -p cabal-website/doc/html - mv dist-newstyle/build/Cabal-1.25.0.0/doc/html/Cabal \ + mv dist-newstyle/build/Cabal-2.1.0.0/doc/html/Cabal \ cabal-website/doc/html/Cabal (cd cabal-website && git add --all .) (cd cabal-website && \ diff --git a/cabal/travis-install.sh b/cabal/travis-install.sh --- a/cabal/travis-install.sh +++ b/cabal/travis-install.sh @@ -1,9 +1,7 @@ #!/bin/sh set -ex -travis_retry () { - $* || (sleep 1 && $*) || (sleep 2 && $*) -} +. ./travis-common.sh if [ "$GHCVER" = "none" ]; then travis_retry sudo add-apt-repository -y ppa:hvr/ghc @@ -15,12 +13,16 @@ if [ "$TRAVIS_OS_NAME" = "linux" ]; then travis_retry sudo add-apt-repository -y ppa:hvr/ghc travis_retry sudo apt-get update - travis_retry sudo apt-get install --force-yes cabal-install-1.24 happy-1.19.5 alex-3.1.7 ghc-$GHCVER-prof ghc-$GHCVER-dyn + travis_retry sudo apt-get install --force-yes cabal-install-head cabal-install-2.0 happy-1.19.5 alex-3.1.7 ghc-$GHCVER-prof ghc-$GHCVER-dyn if [ "x$TEST_OTHER_VERSIONS" = "xYES" ]; then travis_retry sudo apt-get install --force-yes ghc-7.0.4-prof ghc-7.0.4-dyn ghc-7.2.2-prof ghc-7.2.2-dyn ghc-head-prof ghc-head-dyn; fi elif [ "$TRAVIS_OS_NAME" = "osx" ]; then case $GHCVER in + 8.0.2) + GHCURL=http://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-x86_64-apple-darwin.tar.xz; + GHCXZ=YES + ;; 8.0.1) GHCURL=http://downloads.haskell.org/~ghc/8.0.1/ghc-8.0.1-x86_64-apple-darwin.tar.xz; GHCXZ=YES @@ -57,10 +59,9 @@ make install; cd ..; - travis_retry curl -L https://www.haskell.org/cabal/release/cabal-install-1.24.0.0/cabal-install-1.24.0.0-x86_64-apple-darwin-yosemite.tar.gz -o cabal-install.tar.gz - TAR=$PWD/cabal-install.tar.gz mkdir "${HOME}/bin" - (cd "${HOME}/bin" && tar -xzf "$TAR") + travis_retry curl -L https://www.haskell.org/cabal/release/cabal-install-2.0.0.0/cabal-install-2.0.0.0-x86_64-apple-darwin-sierra.tar.xz | tar xJO > "${HOME}/bin/cabal" + chmod a+x "${HOME}/bin/cabal" "${HOME}/bin/cabal" --version else diff --git a/cabal/travis-meta.sh b/cabal/travis-meta.sh --- a/cabal/travis-meta.sh +++ b/cabal/travis-meta.sh @@ -2,6 +2,8 @@ . ./travis-common.sh +export PATH=/opt/cabal/head/bin:$PATH + # --------------------------------------------------------------------- # Check that auto-generated files/fields are up to date. # --------------------------------------------------------------------- @@ -10,11 +12,8 @@ # Currently doesn't work because Travis uses --depth=50 when cloning. #./Cabal/misc/gen-authors.sh > AUTHORS -# Regenerate the 'extra-source-files' field in Cabal.cabal. -(cd Cabal && timed ./misc/gen-extra-source-files.hs Cabal.cabal) || exit $? - -# Regenerate the 'extra-source-files' field in cabal-install.cabal. -(cd cabal-install && ../Cabal/misc/gen-extra-source-files.hs cabal-install.cabal) || exit $? +# Regenerate files +timed make gen-extra-source-files # Fail if the diff is not empty. timed ./Cabal/misc/travis-diff-files.sh diff --git a/cabal/travis-script.sh b/cabal/travis-script.sh --- a/cabal/travis-script.sh +++ b/cabal/travis-script.sh @@ -7,30 +7,74 @@ # If you make a separate matrix entry in .travis.yml it can # be run in parallel. +# NB: the '|| exit $?' workaround is required on old broken versions of bash +# that ship with OS X. See https://github.com/haskell/cabal/pull/3624 and +# http://stackoverflow.com/questions/14970663/why-doesnt-bash-flag-e-exit-when-a-subshell-fails + . ./travis-common.sh -CABAL_STORE_DB="${HOME}/.cabal/store/ghc-${GHCVER}/package.db" -CABAL_LOCAL_DB="${PWD}/dist-newstyle/packagedb/ghc-${GHCVER}" -CABAL_BDIR="${PWD}/dist-newstyle/build/Cabal-${CABAL_VERSION}" -CABAL_TESTSUITE_BDIR="${PWD}/dist-newstyle/build/cabal-testsuite-${CABAL_VERSION}" -CABAL_INSTALL_BDIR="${PWD}/dist-newstyle/build/cabal-install-${CABAL_VERSION}" -CABAL_INSTALL_SETUP="${CABAL_INSTALL_BDIR}/setup/setup" # --hide-successes uses terminal control characters which mess up # Travis's log viewer. So just print them all! TEST_OPTIONS="" +# To be enabled temporarily when you need to pre-populate the Travis +# cache to avoid timeout. +#SKIP_TESTS=YES + # --------------------------------------------------------------------- +# Parse options +# --------------------------------------------------------------------- + +usage() { + echo -e -n "Usage: `basename $0`\n-j jobs\n" +} + +jobs="-j1" +while getopts ":hj:" opt; do + case $opt in + h) + usage + exit 0 + ;; + j) + jobs="-j$OPTARG" + ;; + :) + # Argument-less -j + if [ "$OPTARG" = "j" ]; then + jobs="-j" + fi + ;; + \?) + echo "Invalid option: $OPTARG" + usage + exit 1 + ;; + esac +done +shift $((OPTIND-1)) + +# Do not try to use -j with GHC older than 7.8 +case $GHCVER in + 7.4*|7.6*) + jobs="" + ;; + *) + ;; +esac + +# --------------------------------------------------------------------- # Update the Cabal index # --------------------------------------------------------------------- timed cabal update # --------------------------------------------------------------------- -# Install happy if necessary +# Install executables if necessary # --------------------------------------------------------------------- if ! command -v happy; then - timed cabal install happy + timed cabal install $jobs happy fi # --------------------------------------------------------------------- @@ -39,6 +83,12 @@ cp cabal.project.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.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 # --------------------------------------------------------------------- @@ -46,59 +96,49 @@ # Needed to work around some bugs in nix-local-build code. export CABAL_BUILDDIR="${CABAL_BDIR}" -# NB: Best to do everything for a single package together as it's -# more efficient (since new-build will uselessly try to rebuild -# Cabal otherwise). -if [ "x$PARSEC" = "xYES" ]; then - timed cabal new-build -fparsec Cabal Cabal:unit-tests Cabal:parser-tests Cabal:parser-hackage-tests -else - timed cabal new-build Cabal Cabal:unit-tests -fi - -# NB: the '|| exit $?' workaround is required on old broken versions of bash -# that ship with OS X. See https://github.com/haskell/cabal/pull/3624 and -# http://stackoverflow.com/questions/14970663/why-doesnt-bash-flag-e-exit-when-a-subshell-fails +if [ "x$CABAL_INSTALL_ONLY" != "xYES" ] ; then + # We're doing a full build and test of Cabal -# Run tests -(cd Cabal && timed ${CABAL_BDIR}/build/unit-tests/unit-tests $TEST_OPTIONS) || exit $? + # NB: Best to do everything for a single package together as it's + # more efficient (since new-build will uselessly try to rebuild + # Cabal otherwise). + timed cabal new-build $jobs Cabal Cabal:unit-tests Cabal:check-tests Cabal:parser-tests Cabal:parser-hackage-tests --enable-tests -if [ "x$PARSEC" = "xYES" ]; then - # Parser unit tests - (cd Cabal && timed ${CABAL_BDIR}/build/parser-tests/parser-tests $TEST_OPTIONS) || exit $? + # Run haddock. + if [ "$TRAVIS_OS_NAME" = "linux" ]; then + (cd Cabal && timed cabal act-as-setup --build-type=Simple -- haddock --builddir=${CABAL_BDIR}) || exit $? + fi - # Test we can parse Hackage - (cd Cabal && timed ${CABAL_BDIR}/build/parser-tests/parser-hackage-tests $TEST_OPTIONS) | tail || exit $? + # Check for package warnings + (cd Cabal && timed cabal check) || exit $? fi -# Run haddock (hack: use the Setup script from package-tests!) -(cd Cabal && timed cabal act-as-setup --build-type=Simple -- haddock --builddir=${CABAL_BDIR}) || exit $? - -# Check for package warnings -(cd Cabal && timed cabal check) || exit $? - unset CABAL_BUILDDIR # Build and run the package tests export CABAL_BUILDDIR="${CABAL_TESTSUITE_BDIR}" -timed cabal new-build cabal-testsuite:package-tests +# NB: We always build this test runner, because it is used +# both by Cabal and cabal-install +timed cabal new-build $jobs cabal-testsuite:cabal-tests -(cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/package-tests/package-tests $TEST_OPTIONS) || exit $? +if [ "x$SKIP_TESTS" != "xYES" ]; then + (cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/cabal-tests/cabal-tests --builddir=${CABAL_TESTSUITE_BDIR} -j3 $TEST_OPTIONS) || exit $? +fi # Redo the package tests with different versions of GHC if [ "x$TEST_OTHER_VERSIONS" = "xYES" ]; then - (export CABAL_PACKAGETESTS_WITH_GHC="/opt/ghc/7.0.4/bin/ghc"; \ - cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/package-tests/package-tests $TEST_OPTIONS) - (export CABAL_PACKAGETESTS_WITH_GHC="/opt/ghc/7.2.2/bin/ghc"; \ - cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/package-tests/package-tests $TEST_OPTIONS) - (export CABAL_PACKAGETESTS_WITH_GHC="/opt/ghc/head/bin/ghc"; \ - cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/package-tests/package-tests $TEST_OPTIONS) + (cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/cabal-tests/cabal-tests --builddir=${CABAL_TESTSUITE_BDIR} $TEST_OPTIONS --with-ghc="/opt/ghc/7.0.4/bin/ghc") + (cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/cabal-tests/cabal-tests --builddir=${CABAL_TESTSUITE_BDIR} $TEST_OPTIONS --with-ghc="/opt/ghc/7.2.2/bin/ghc") + (cd cabal-testsuite && timed ${CABAL_TESTSUITE_BDIR}/build/cabal-tests/cabal-tests --builddir=${CABAL_TESTSUITE_BDIR} $TEST_OPTIONS --with-ghc="/opt/ghc/head/bin/ghc") fi unset CABAL_BUILDDIR if [ "x$CABAL_LIB_ONLY" = "xYES" ]; then + # If this fails, we WANT to fail, because the tests will not be running then + (timed ./travis/upload.sh) || exit $? exit 0; fi @@ -109,29 +149,43 @@ # Needed to work around some bugs in nix-local-build code. export CABAL_BUILDDIR="${CABAL_INSTALL_BDIR}" -timed cabal new-build cabal-install:cabal \ - cabal-install:integration-tests \ - cabal-install:integration-tests2 \ - cabal-install:unit-tests \ - cabal-install:solver-quickcheck +if [ "x$DEBUG_EXPENSIVE_ASSERTIONS" = "xYES" ]; then + CABAL_INSTALL_FLAGS=-fdebug-expensive-assertions +fi -# The integration-tests2 need the hackage index, and need it in the secure -# format, which is not necessarily the default format of the bootstrap cabal. -# If the format does match then this will be very quick. -timed ${CABAL_INSTALL_BDIR}/build/cabal/cabal update +# NB: For Travis, we do a *monolithic* build, which means all the +# test suites are baked into the cabal binary +timed cabal new-build $jobs $CABAL_INSTALL_FLAGS cabal-install:cabal -# Run tests -(cd cabal-install && timed ${CABAL_INSTALL_BDIR}/build/unit-tests/unit-tests $TEST_OPTIONS) || exit $? -(cd cabal-install && timed ${CABAL_INSTALL_BDIR}/build/solver-quickcheck/solver-quickcheck $TEST_OPTIONS --quickcheck-tests=1000) || exit $? -(cd cabal-install && timed ${CABAL_INSTALL_BDIR}/build/integration-tests/integration-tests $TEST_OPTIONS) || exit $? -(cd cabal-install && timed ${CABAL_INSTALL_BDIR}/build/integration-tests2/integration-tests2 $TEST_OPTIONS) || exit $? +timed cabal new-build $jobs hackage-repo-tool +if [ "x$SKIP_TESTS" = "xYES" ]; then + exit 1; +fi + # Haddock -(cd cabal-install && timed ${CABAL_INSTALL_SETUP} haddock --builddir=${CABAL_INSTALL_BDIR} ) || exit $? +# TODO: Figure out why this needs to be run before big tests +if [ "$TRAVIS_OS_NAME" = "linux" ]; then + (cd cabal-install && timed ${CABAL_INSTALL_SETUP} haddock --builddir=${CABAL_INSTALL_BDIR} ) || exit $? +fi +# Tests need this +timed ${CABAL_INSTALL_BDIR}/build/cabal/cabal 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_BDIR}/build/cabal/cabal --with-hackage-repo-tool ${HACKAGE_REPO_TOOL_BDIR}/build/hackage-repo-tool/hackage-repo-tool $TEST_OPTIONS) || exit $? + (cd cabal-install && timed cabal check) || exit $? +if [ "x$TEST_SOLVER_BENCHMARKS" = "xYES" ]; then + timed cabal new-build $jobs solver-benchmarks:hackage-benchmark solver-benchmarks:unit-tests + timed ${SOLVER_BENCHMARKS_BDIR}/c/unit-tests/build/unit-tests/unit-tests $TEST_OPTIONS +fi + unset CABAL_BUILDDIR # Check what we got ${CABAL_INSTALL_BDIR}/build/cabal/cabal --version + +# If this fails, we WANT to fail, because the tests will not be running then +(timed ./travis/upload.sh) || exit $? diff --git a/cabal/travis/README.md b/cabal/travis/README.md new file mode 100644 --- /dev/null +++ b/cabal/travis/README.md @@ -0,0 +1,82 @@ +# Continuous integration on Travis + +This folder contains scripts for running CI on Travis. + +The most unusual thing about our Travis setup is that, after we finish +building our project, we upload the build products to Git (via the +haskell-pushbot account) to a separate repository to do testing. +There are two reasons we do this: + +1. On our slowest configuration (GHC 8 on Mac OS X), the time to + build and run tests was easily bumping up against the Travis time + limit. By uploading our build products to a separate account, + we get twice as much time to run our builds. + +2. Travis parallelism is limited on a per-account basis; if we + upload build products to another account, we get more parallelism! + (Travis, let us know if you don't like this :) + +Here is the general lifecycle of a Travis run: + +1. For each build matrix configuration, we run ../travis-script.sh + to build Cabal, cabal-install, and all of the test suites. + +2. Once the build is successful, we invoke upload.sh to upload + the build products to the cabal-binaries repository. This is done + using the private key id_rsa (associated with haskell-pushbot's + account). This upload contains its own .travis.yml (customized + for the particular build matrix configuration), and some special + JSON metadata in the commit message. + +3. Triggered by the push to cabal-binaries, Travis on haskell-pushbot + will run the tests. After this finishes, it will invoke a webhook + that invokes sake-bot (https://github.com/ezyang/sake-bot, currently + installed at https://sake-bot.herokuapp.com/) which will post + back the GitHub status result to the upstream Cabal repository. + +## Who maintains this setup + +Unfortunately, there are some infrastructural permissions which +don't coincide with the GitHub permissions for the Cabal project. +Here are the relevant bits: + +* The GitHub account haskell-pushbot is owned by @ezyang (along + with the associated Travis account.) + +* The Heroku instance https://sake-bot.herokuapp.com/ is maintained by @ezyang. + It has a private key for a GitHub integration on the Haskell + GitHub organization (which gives it permissions to update + statuses on the Cabal project). + +Fortunately, if @ezyang ever gets run over a bus, all of these +infrastructural bits can be reconfigured. Here is what you +would need to do: + +* Create a new GitHub account to replace haskell-pushbot + +* Generate a new private key, associate it with the GH account, and + replace id_rsa and id_rsa.pub with the new account + +* Create a new binaries repository, modify the invocation of + "git remote add" in upload.sh to point to the new location. + Enable Travis for this repository. + +* Create a new Heroku instance of https://github.com/ezyang/sake-bot + (use the "Deploy with Heroku" button.) Follow the instructions + there; you'll need a private key for an integration associated + with the Haskell organization; talk to one of the admins there + to get the key. + +That's it! + +## Limitations + +If you push to your local account and run Travis, the builds will +still take place in the shared cabal-binaries Travis instance, and +you won't get status updates (because sake-bot doesn't have permissions +to update the status update on any repository besides its own.) +In principle, it should be possible for upload.sh to autodetect if you +have a cabal-binaries repository setup on your local account, and use +that instead, but as the sake-bot integration can only be installed +on the same account it was created for, getting sake-bot setup would +be annoyingly fiddly. Shout if you need this to work. diff --git a/cabal/travis/binaries/.travis.yml b/cabal/travis/binaries/.travis.yml new file mode 100644 --- /dev/null +++ b/cabal/travis/binaries/.travis.yml @@ -0,0 +1,33 @@ +language: c +dist: trusty +# This doesn't actually help because we always push a single +# commit to the branch in question +#git: +# # https://github.com/travis-ci/travis-ci/issues/4575 +# depth: 1 +sudo: required +before_install: + - export PATH=/opt/ghc/$GHCVER/bin:$PATH + - export PATH=$HOME/.ghc-install/$GHCVER/bin:$PATH + - export PATH=$HOME/bin:$PATH + - export PATH=$HOME/.cabal/bin:$PATH + - export PATH=$HOME/.local/bin:$PATH + - export PATH=/opt/cabal/1.24/bin:$PATH + - export PATH=/opt/happy/1.19.5/bin:$PATH + - export PATH=/opt/alex/3.1.7/bin:$PATH + - ./travis-install.sh +script: + - ./travis-test.sh +after_success: + - ./travis-cleanup.sh +notifications: + webhooks: + urls: https://sake-bot.herokuapp.com/ + on_start: always + irc: + channels: + - "chat.freenode.net##haskell-cabal" + slack: haskell-cabal:sCq6GLfy9N8MJrInosg871n4 +# To append on: +# env: GHCVER=7.6.3 UPSTREAM_BUILD_DIR=/home/travis/user/repo +# os: linux diff --git a/cabal/travis/binaries/travis-cleanup.sh b/cabal/travis/binaries/travis-cleanup.sh new file mode 100644 --- /dev/null +++ b/cabal/travis/binaries/travis-cleanup.sh @@ -0,0 +1,8 @@ +#!/bin/sh + +# See travis/upload.sh for more documentation + +git remote set-url --push origin git@github.com:haskell-pushbot/cabal-binaries.git +(umask 177 && cp id_rsa $HOME/.ssh/id_rsa) +ssh-keyscan github.com >> $HOME/.ssh/known_hosts +git push origin --delete "$(git rev-parse --abbrev-ref HEAD)" diff --git a/cabal/travis/binaries/travis-test.sh b/cabal/travis/binaries/travis-test.sh new file mode 100644 --- /dev/null +++ b/cabal/travis/binaries/travis-test.sh @@ -0,0 +1,42 @@ +#!/bin/sh + +. ./travis-common.sh + +# --hide-successes uses terminal control characters which mess up +# Travis's log viewer. So just print them all! +TEST_OPTIONS="" + +# Setup symlink so that paths look the same +mkdir -p $(dirname $UPSTREAM_BUILD_DIR) +ln -s $TRAVIS_BUILD_DIR $UPSTREAM_BUILD_DIR + +# Run tests +(timed Cabal/unit-tests $TEST_OPTIONS) || exit $? + +# Check tests +(cd Cabal && timed ./check-tests $TEST_OPTIONS) || exit $? + +# Parser unit tests +(cd Cabal && timed ./parser-tests $TEST_OPTIONS) || exit $? + +# Test we can parse Hackage +(cd Cabal && timed ./parser-hackage-tests $TEST_OPTIONS) | tail || exit $? + +if [ "x$CABAL_LIB_ONLY" = "xYES" ]; then + exit 0; +fi + +# --------------------------------------------------------------------- +# cabal-install +# --------------------------------------------------------------------- + +# Update index +(timed cabal-install/cabal update) || exit $? + +# Run tests +(timed env CABAL_INSTALL_MONOLITHIC_MODE=UnitTests cabal-install/cabal $TEST_OPTIONS) || exit $? +(timed env CABAL_INSTALL_MONOLITHIC_MODE=MemoryUsageTests cabal-install/cabal $TEST_OPTIONS +RTS -M4M -K1K -RTS) || exit $? + +# These need the cabal-install directory +(cd cabal-install && timed env CABAL_INSTALL_MONOLITHIC_MODE=SolverQuickCheck ./cabal $TEST_OPTIONS --quickcheck-tests=1000) || exit $? +(cd cabal-install && timed env CABAL_INSTALL_MONOLITHIC_MODE=IntegrationTests2 ./cabal $TEST_OPTIONS) || exit $? diff --git a/cabal/travis/id_rsa b/cabal/travis/id_rsa new file mode 100644 --- /dev/null +++ b/cabal/travis/id_rsa @@ -0,0 +1,27 @@ +-----BEGIN RSA PRIVATE KEY----- +MIIEpAIBAAKCAQEAwyBagHDRv7lqPz0Jus26XmLa9erl29MAT2ns2LURbszqhP6v +KW5bp0bYeCrBOhUUq14tNpI/5xDnHdt1GJGztiLzTu9FLy7gts4xmkYlkiAJeUkg +RGUeWDU0oK6Df5jkxu0N+tYcxMFMZLi1Nmm4ISGpYPHvfAPwRDRAojFZBFFI1vYO +4awyz5X6DaMHu/D+TSTHDBzNDtq2oCWtDT1hh2Bhtxw5ZGeujlEXWLkp9eoA/TU/ +RBWL4s2xAot81iEWNN5xhFijlt2RsBLpqTj+TcEpvU9xMXYkQFpyqPJzxMsjHo4i +50qnZdKQXeZJd/ZmIiAt4B4/tlSLz6RUmfSQfwIDAQABAoIBAQCXlrD4i61Hx2IV +UvQWHfGlliMJXb3JM3lQOLh5+uFaNPQU8k9eXo/xuoY9hOmsl+gA4h86ABCJEIac +mXu05Ky62RgwwI39A+wr2LCMa+aQSTdS9E6PFAeo+1yxYCJkpIFHUa7EqkabTJhu +v1h4t1UG2EHgQNSOgfjM49M6rh+7y5b8NDH/67y0ygdaXQAlqPOxmllKAKJWKrCd +zsrhaZXezPljblzGQpaV0+EhGGbrrqaos+kdraZcYXqo++sGEnITg2ElCHtGf0/0 +h1yr1PtNeLvhC0w/3piZnA58ls8OmXy0erVi9Pj1LLGEbeuFSz81+6SpmORgx1Kd +4jazO1mxAoGBAOM2SXvmqS+8CCI3u52I9bbkE4keIM54tzFLNHWQknVHQn04GGxC +lXjjcTyLNW2rT04RfGs2tXSse3sgEg1x/4uqo/kJvdZAAG9vUlWNukzqEVawVu84 +AJhhqWQWGSdOhnOS7G2aXjdrTfIvlvwjuUBii4s0fRw6QE0s5vpVyNh9AoGBANvZ +WtYnuQuzsedhZDB0Chrg/z83DYpxlubDeP3iWnT7eBXes1nTLM0r9AChFCbyX6Ml +Wd5phCbjvZrtQG04E90xHQNFq77F5q9U8D0gJIDi3fcktRrP9pCQqZhCbuLTKhxa +eFFS3W8c7pivQLsdwr29wZK+yegN6ksZax7OktmrAoGAewGw1rsRbR5G6P9zOt4i +6FihmuIMsLr5sl4ckGksYQGrJU9xKWsCsOexLi3PRwgvbvxYd1Ku+fNHBmleXJkS +1/IRw4lalNshYTLLSDXqXil6KYxeBDQ1XknBAsZT58vDTl6EUPH5f9c/45WQEADn +EcxH750C/n0qwp1EjtJSYaECgYBTSZi8IPhdkooHWkIWiR9651pLnJOoqze73Lnt +lN8oCkyIHIJduT7zy3747g0wZAoPSIsvU1IZWZXvJ4qM1f3Qgla3cqGJ+HdYXRlW +TuMFYO0uP93MdpS2V9eoMyLHE7CUZUHHrVjuS0uo1Fv1h2TLdSPscBMVso/cO5j1 +ZtUDWQKBgQCrIdI4X25eQg7h9noZkOkv0puQQJ/g/+sE7DOL6van74dtVSbgahwu +/7umITYSfvkEFfbck5m7Yvsaje1Mzj0skXX8tST80WrCYwJ3BCY+BYvHoYOjhPt/ +q3Ycs1SPZ0Ao7/NkTEnkv0+hIGb5K99UvvLNXTk83pYcS09i5TfXDA== +-----END RSA PRIVATE KEY----- diff --git a/cabal/travis/id_rsa.pub b/cabal/travis/id_rsa.pub new file mode 100644 --- /dev/null +++ b/cabal/travis/id_rsa.pub @@ -0,0 +1,1 @@ +ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQDDIFqAcNG/uWo/PQm6zbpeYtr16uXb0wBPaezYtRFuzOqE/q8pblunRth4KsE6FRSrXi02kj/nEOcd23UYkbO2IvNO70UvLuC2zjGaRiWSIAl5SSBEZR5YNTSgroN/mOTG7Q361hzEwUxkuLU2abghIalg8e98A/BENECiMVkEUUjW9g7hrDLPlfoNowe78P5NJMcMHM0O2ragJa0NPWGHYGG3HDlkZ66OURdYuSn16gD9NT9EFYvizbECi3zWIRY03nGEWKOW3ZGwEumpOP5NwSm9T3ExdiRAWnKo8nPEyyMejiLnSqdl0pBd5kl39mYiIC3gHj+2VIvPpFSZ9JB/ ezyang@sabre diff --git a/cabal/travis/upload.sh b/cabal/travis/upload.sh new file mode 100644 --- /dev/null +++ b/cabal/travis/upload.sh @@ -0,0 +1,94 @@ +#!/bin/sh + +set -x + +. ./travis-common.sh + +# Read out ACCOUNT and REPO from the slug +# Cribbed from http://unix.stackexchange.com/a/53323/118117 +ACCOUNT=${TRAVIS_REPO_SLUG%%"/"*} +REPO=${TRAVIS_REPO_SLUG#*"/"} + +# TAG will be used to uniquely identify a matrix entry; we +# need to push each matrix entry to a separate branch. +TAG="$TRAVIS_OS_NAME-$GHCVER$TAGSUFFIX" + +# This is the commit for which we want a GitHub status update +# ping to go to. Note that it is NOT TRAVIS_COMMIT unconditionally, +# since if we have a pull request, this commit will be a merge +# commit which no one from GitHub will be able to see. +COMMIT=${TRAVIS_PULL_REQUEST_SHA:-$TRAVIS_COMMIT} + +# This is just to help you correlate the build to what it's for +if [ "x$TRAVIS_PULL_REQUEST" != "xfalse" ]; then + ORIGIN="${TRAVIS_REPO_SLUG}/pull/$TRAVIS_PULL_REQUEST" + URL="pull/${TRAVIS_PULL_REQUEST}" +else + ORIGIN="${TRAVIS_REPO_SLUG}/${TRAVIS_BRANCH}" + URL="commits/${TRAVIS_BRANCH}" +fi + +# Git will complain if these fields don't work when committing, +# so set them up. +git config --global user.name "$(git --no-pager show -s --format='%an' $COMMIT)" +git config --global user.email "$(git --no-pager show -s --format='%ae' $COMMIT)" +git config --global push.default simple + +cd travis + +# Setup SSH key we will use to push to binaries repository. +# umask to get the permissions to be 600 (not 400, because the deploy +# script in .travis.yml is going to clobber this private key) +(umask 177 && cp id_rsa $HOME/.ssh/id_rsa) + +# Setup SSH keys +ssh-keyscan github.com >> $HOME/.ssh/known_hosts + +cd binaries + +# Setup binaries repository for pushing +git init +# TODO: Update this +git remote add origin git@github.com:haskell-pushbot/cabal-binaries.git + +# Make some final modifications to .travis.yml based so +# that downstream builds with the correct configuration +echo "env: GHCVER=$GHCVER UPSTREAM_BUILD_DIR=$TRAVIS_BUILD_DIR CABAL_LIB_ONLY=$CABAL_LIB_ONLY TEST_OTHER_VERSIONS=$TEST_OTHER_VERSIONS" >> .travis.yml +echo "os: $TRAVIS_OS_NAME" >> .travis.yml +if [ "x$GHCVER" = "x7.8.4" ] && [ "x$TRAVIS_OS_NAME" = "xosx" ]; then + echo "osx_image: xcode6.4" >> .travis.yml +fi + +# Make directory layout +mkdir Cabal +mkdir cabal-install +cp -R $TRAVIS_BUILD_DIR/Cabal/tests Cabal +cp -R $TRAVIS_BUILD_DIR/cabal-install/tests cabal-install +# Copy in credentials so we can delete branch when done +cp $TRAVIS_BUILD_DIR/travis/id_rsa . +# Install all of the necessary files for testing +cp $TRAVIS_BUILD_DIR/travis-install.sh . +cp $TRAVIS_BUILD_DIR/travis-common.sh . +# The binaries to test (statically linked, of course!) +cp ${CABAL_BDIR}/c/unit-tests/build/unit-tests/unit-tests Cabal +cp ${CABAL_BDIR}/c/check-tests/build/check-tests/check-tests Cabal +cp ${CABAL_BDIR}/c/parser-tests/build/parser-tests/parser-tests Cabal +cp ${CABAL_BDIR}/c/parser-hackage-tests/build/parser-hackage-tests/parser-hackage-tests Cabal +if [ "x$CABAL_LIB_ONLY" != "xYES" ]; then + cp ${CABAL_INSTALL_BDIR}/build/cabal/cabal cabal-install +fi + +# Add, commit, push +git add . +# The JSON in the commit message is used by the webhook listening +# on the downstream repo to figure out who to communicate the +# status update back to +git commit -m '{"origin":"'$ORIGIN'", + +"url":"'$URL'", +"account":"'$ACCOUNT'", +"repo":"'$REPO'", +"commit": "'$COMMIT'", +"tag":"'$TAG'" +}' +travis_retry git push -f origin "HEAD:$TAG/$COMMIT" diff --git a/cabal/update-cabal-files.sh b/cabal/update-cabal-files.sh --- a/cabal/update-cabal-files.sh +++ b/cabal/update-cabal-files.sh @@ -1,4 +1,3 @@ #!/bin/sh (cd Cabal; misc/gen-extra-source-files.hs Cabal.cabal) -(cd cabal-testsuite; ../Cabal/misc/gen-extra-source-files.hs cabal-testsuite.cabal) (cd cabal-install; ../Cabal/misc/gen-extra-source-files.hs cabal-install.cabal) diff --git a/hackage-security/.travis.yml b/hackage-security/.travis.yml --- a/hackage-security/.travis.yml +++ b/hackage-security/.travis.yml @@ -1,128 +1,69 @@ -# see also https://github.com/hvr/multi-ghc-travis +# See also https://github.com/hvr/multi-ghc-travis language: c sudo: false cache: directories: - - $HOME/.cabsnap - $HOME/.cabal/packages + - $HOME/.cabal/store before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar + # 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 matrix: include: -# cabal 1.16's solver is too weak for GHC 7.4 - - env: CABALVER=1.22 GHCVER=7.4.2 - compiler: ": #GHC 7.4.2" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.4.2], sources: [hvr-ghc]}} - - env: CABALVER=1.16 GHCVER=7.6.3 - compiler: ": #GHC 7.6.3" - addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3], sources: [hvr-ghc]}} - - env: CABALVER=1.18 GHCVER=7.8.4 - compiler: ": #GHC 7.8.4" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}} - - env: CABALVER=1.22 GHCVER=7.10.3 - compiler: ": #GHC 7.10.3" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} - - env: CABALVER=1.24 GHCVER=8.0.1 - compiler: ": #GHC 8.0.1" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}} + - 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.1" + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.1], 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.1" + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}} before_install: + - HC=${CC} - unset CC - - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH - - TARGETS="hackage-security/ hackage-security-curl/ hackage-security-HTTP/ hackage-root-tool/ hackage-repo-tool/ example-client/ hackage-security-http-client/"; - + - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH + install: -# Compute install plan (which we use as a travis cache key) - cabal --version - - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; - then - zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > - $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; - fi + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - travis_retry cabal update -v - - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - - cabal install --constraint="directory installed" --constraint="bytestring installed" --only-dependencies --enable-tests --dry -v $TARGETS > installplan.txt - - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt - -# check whether current requested install-plan matches cached package-db snapshot - - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; - then - echo "cabal build-cache HIT"; - rm -rfv .ghc; - cp -a $HOME/.cabsnap/ghc $HOME/.ghc; - cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; - else - echo "cabal build-cache MISS"; - rm -rf $HOME/.cabsnap; - mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; - cabal install --constraint="directory installed" --constraint="bytestring installed" --only-dependencies --enable-tests $TARGETS; - fi - -# snapshot package-db on cache miss - - if [ ! -d $HOME/.cabsnap ]; - then - echo "snapshotting package-db to build-cache"; - mkdir $HOME/.cabsnap; - cp -a $HOME/.ghc $HOME/.cabsnap/ghc; - cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; - fi + - 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. script: - - cd hackage-security/ - - cabal configure --enable-tests -v2 - - cabal build - - cabal sdist - - cabal test - - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ") - - cd .. - - - cd hackage-security-curl/ - - cabal configure -v2 - - cabal build - - cabal sdist - - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ") - - cd .. - - - cd hackage-security-HTTP/ - - cabal configure -v2 - - cabal build - - cabal sdist - - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ") - - cd .. - - - cd hackage-root-tool/ - - cabal configure -v2 - - cabal build - - cabal sdist - - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ") - - cd .. - - - cd hackage-repo-tool/ - - cabal configure -v2 - - cabal build - - cabal sdist - - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ") - - cd .. +# 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/ - - cd hackage-security-http-client/ - - cabal configure -v2 - - cabal build - - cabal sdist - - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ") - - cd .. + # 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 - - cd example-client/ - - cabal configure -v2 - - cabal build - - cabal sdist - - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ") - - cd .. + # build all packages and run testsuite + - cp -v ../cabal.project ./ + - cabal new-build ${XCABFLAGS} -j1 all + - cabal new-test ${XCABFLAGS} -j1 all # EOF diff --git a/hackage-security/cabal.project b/hackage-security/cabal.project new file mode 100644 --- /dev/null +++ b/hackage-security/cabal.project @@ -0,0 +1,15 @@ +-- See http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html + +packages: hackage-security + hackage-security-http-client + example-client + hackage-security-curl + hackage-root-tool + hackage-repo-tool + hackage-security-HTTP + +package hackage-security + tests: true + +-- FIXME/TODO +-- packages: precompute-fileinfo 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 @@ -39,13 +39,13 @@ Hackage.Security.RepoTool.Util.IO Prelude build-depends: base >= 4.4 && < 5, - Cabal >= 1.12 && < 1.25, + Cabal >= 1.12 && < 2.1, bytestring >= 0.9 && < 0.11, - directory >= 1.1 && < 1.3, + directory >= 1.1 && < 1.4, filepath >= 1.2 && < 1.5, - optparse-applicative >= 0.11 && < 0.13, + optparse-applicative >= 0.11 && < 0.14, tar >= 0.4 && < 0.6, - time >= 1.2 && < 1.7, + time >= 1.2 && < 1.9, unix >= 2.5 && < 2.8, zlib >= 0.5 && < 0.7, hackage-security >= 0.5 && < 0.6 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 @@ -27,7 +27,7 @@ main-is: Main.hs build-depends: base >= 4.4 && < 5, filepath >= 1.2 && < 1.5, - optparse-applicative >= 0.11 && < 0.13, + optparse-applicative >= 0.11 && < 0.14, hackage-security >= 0.5 && < 0.6 default-language: Haskell2010 other-extensions: CPP, ScopedTypeVariables, RecordWildCards 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 @@ -20,7 +20,7 @@ build-depends: base >= 4.4, bytestring >= 0.9, data-default-class >= 0.0, - http-client >= 0.4 && < 0.5, + http-client >= 0.5 && < 0.6, http-types >= 0.8, hackage-security >= 0.5 && < 0.6 hs-source-dirs: src 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,13 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} module Hackage.Security.Client.Repository.HttpLib.HttpClient ( withClient + , makeHttpLib -- ** Re-exports , Manager -- opaque ) where import Control.Exception +import Control.Monad (void) import Data.ByteString (ByteString) -import Data.Default.Class (def) import Network.URI import Network.HTTP.Client (Manager) import qualified Data.ByteString as BS @@ -32,10 +33,7 @@ withClient :: ProxyConfig HttpClient.Proxy -> (Manager -> HttpLib -> IO a) -> IO a withClient proxyConfig callback = do manager <- HttpClient.newManager (setProxy HttpClient.defaultManagerSettings) - callback manager HttpLib { - httpGet = get manager - , httpGetRange = getRange manager - } + callback manager $ makeHttpLib manager where setProxy = HttpClient.managerSetProxy $ case proxyConfig of @@ -43,6 +41,13 @@ ProxyConfigUse p -> HttpClient.useProxy p ProxyConfigAuto -> HttpClient.proxyEnvironment Nothing +-- | Create an 'HttpLib' value from a preexisting 'Manager'. +makeHttpLib :: Manager -> HttpLib +makeHttpLib manager = HttpLib + { httpGet = get manager + , httpGetRange = getRange manager + } + {------------------------------------------------------------------------------- Individual methods -------------------------------------------------------------------------------} @@ -55,7 +60,7 @@ get manager reqHeaders uri callback = wrapCustomEx $ do -- TODO: setUri fails under certain circumstances; in particular, when -- the URI contains URL auth. Not sure if this is a concern. - request' <- HttpClient.setUri def uri + request' <- HttpClient.setUri HttpClient.defaultRequest uri let request = setRequestHeaders reqHeaders $ request' checkHttpException $ HttpClient.withResponse request manager $ \response -> do @@ -68,10 +73,8 @@ -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a) -> IO a getRange manager reqHeaders uri (from, to) callback = wrapCustomEx $ do - request' <- HttpClient.setUri def uri - let request = setRange from to - $ setRequestHeaders reqHeaders - $ request' + request <- (setRange from to . setRequestHeaders reqHeaders) + `fmap` HttpClient.setUri HttpClient.defaultRequest uri checkHttpException $ HttpClient.withResponse request manager $ \response -> do let br = wrapCustomEx $ HttpClient.responseBody response case () of @@ -80,10 +83,9 @@ () | HttpClient.responseStatus response == HttpClient.ok200 -> callback HttpStatus200OK (getResponseHeaders response) br _otherwise -> - throwChecked $ HttpClient.StatusCodeException - (HttpClient.responseStatus response) - (HttpClient.responseHeaders response) - (HttpClient.responseCookieJar response) + throwChecked $ + HttpClient.HttpExceptionRequest request $ + HttpClient.StatusCodeException (void response) BS.empty -- | Wrap custom exceptions -- 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 @@ -24,8 +24,8 @@ maintainer: edsko@well-typed.com copyright: Copyright 2015-2016 Well-Typed LLP category: Distribution -homepage: https://github.com/well-typed/hackage-security -bug-reports: https://github.com/well-typed/hackage-security/issues +homepage: https://github.com/haskell/hackage-security +bug-reports: https://github.com/haskell/hackage-security/issues build-type: Simple cabal-version: >=1.10 @@ -34,7 +34,7 @@ source-repository head type: git - location: https://github.com/well-typed/hackage-security.git + location: https://github.com/haskell/hackage-security.git flag base48 description: Are we using base 4.8 or later? @@ -99,9 +99,8 @@ base16-bytestring >= 0.1.1 && < 0.2, base64-bytestring >= 1.0 && < 1.1, bytestring >= 0.9 && < 0.11, - Cabal >= 1.14 && < 1.26, + Cabal >= 1.14 && < 2.2, containers >= 0.4 && < 0.6, - directory >= 1.1.0.2 && < 1.3, ed25519 >= 0.0 && < 0.1, filepath >= 1.2 && < 1.5, mtl >= 2.2 && < 2.3, @@ -111,16 +110,17 @@ -- 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.7, + time >= 1.2 && < 1.9, transformers >= 0.4 && < 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.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 + build-depends: directory >= 1.2 && < 1.4 hs-source-dirs: src default-language: Haskell2010 default-extensions: DefaultSignatures @@ -147,11 +147,10 @@ OverlappingInstances PackageImports UndecidableInstances + -- use the new stage1/cross-compile-friendly Quotes subset of TH for new GHCs if impl(ghc >= 8.0) - -- place holder until Hackage allows to edit in the new extension token - -- other-extensions: TemplateHaskellQuotes - other-extensions: + other-extensions: TemplateHaskellQuotes else other-extensions: TemplateHaskell @@ -160,7 +159,7 @@ if flag(base48) build-depends: base >= 4.8 else - build-depends: old-locale >= 1.0 + build-depends: base < 4.8, old-locale == 1.0.* -- The URI type got split out off the network package after version 2.5, and -- moved to a separate network-uri package. Since we don't need the rest of diff --git a/hackage-security/hackage-security/src/Text/JSON/Canonical.hs b/hackage-security/hackage-security/src/Text/JSON/Canonical.hs --- a/hackage-security/hackage-security/src/Text/JSON/Canonical.hs +++ b/hackage-security/hackage-security/src/Text/JSON/Canonical.hs @@ -321,8 +321,8 @@ jstring = doubleQuotes . hcat . map jchar jchar :: Char -> Doc -jchar '"' = Doc.char '\\' <> Doc.char '"' -jchar '\\' = Doc.char '\\' <> Doc.char '\\' +jchar '"' = Doc.char '\\' Doc.<> Doc.char '"' +jchar '\\' = Doc.char '\\' Doc.<> Doc.char '\\' jchar c = Doc.char c jarray :: [JSValue] -> Doc @@ -331,7 +331,7 @@ jobject :: [(String, JSValue)] -> Doc jobject = sep . punctuate' lbrace comma rbrace - . map (\(k,v) -> sep [jstring k <> colon, nest 2 (jvalue v)]) + . map (\(k,v) -> sep [jstring k Doc.<> colon, nest 2 (jvalue v)]) -- | Punctuate in this style: @@ -345,7 +345,7 @@ -- > ] -- punctuate' :: Doc -> Doc -> Doc -> [Doc] -> [Doc] -punctuate' l _ r [] = [l <> r] +punctuate' l _ r [] = [l Doc.<> r] punctuate' l _ r [x] = [l <+> x <+> r] punctuate' l p r (x:xs) = l <+> x : go xs where 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, GADTs #-} +{-# LANGUAGE CPP, RecordWildCards, GADTs #-} module Main (main) where -- stdlib @@ -15,7 +15,11 @@ import qualified Data.ByteString.Lazy.Char8 as BS -- Cabal -import Distribution.Package (PackageName(..)) +#if MIN_VERSION_Cabal(2,0,0) +import Distribution.Package (mkPackageName) +#else +import Distribution.Package (PackageName(PackageName)) +#endif -- hackage-security import Hackage.Security.Client @@ -253,7 +257,7 @@ indexEntryContent entry @?= testEntrycontent case indexEntryPathParsed entry of Just (IndexPkgPrefs pkgname) -> do - pkgname @?= PackageName "foo" + pkgname @?= mkPackageName "foo" case indexEntryContentParsed entry of Right () -> return () _ -> fail "unexpected index entry content" @@ -263,7 +267,7 @@ where Right path = Tar.toTarPath False "foo/preferred-versions" testEntrycontent = BS.pack "foo >= 1" - testEntryIndexFile = IndexPkgPrefs (PackageName "foo") + testEntryIndexFile = IndexPkgPrefs (mkPackageName "foo") {------------------------------------------------------------------------------- @@ -503,3 +507,9 @@ -- | Return @Just@ the current time checkExpiry :: IO (Maybe UTCTime) checkExpiry = Just `fmap` getCurrentTime + +#if !MIN_VERSION_Cabal(2,0,0) +-- | Emulate Cabal2's @mkPackageName@ constructor-function +mkPackageName :: String -> PackageName +mkPackageName = PackageName +#endif diff --git a/hackage-security/stack.yaml b/hackage-security/stack.yaml --- a/hackage-security/stack.yaml +++ b/hackage-security/stack.yaml @@ -1,13 +1,12 @@ -resolver: lts-3.4 +resolver: lts-7.14 packages: -- hackage-security -- precompute-fileinfo -- hackage-security-http-client - example-client -- hackage-security-curl -- hackage-root-tool - hackage-repo-tool +- hackage-root-tool +- hackage-security - hackage-security-HTTP +- hackage-security-curl +- hackage-security-http-client +- precompute-fileinfo extra-deps: -- ed25519-0.0.2.0 -- zlib-0.6.1.1 +- http-client-0.5.5 diff --git a/hackport.cabal b/hackport.cabal --- a/hackport.cabal +++ b/hackport.cabal @@ -1,5 +1,5 @@ Name: hackport -Version: 0.5.4 +Version: 0.5.5 License: GPL License-file: LICENSE Author: Henning Günther, Duncan Coutts, Lennart Kolmodin @@ -133,7 +133,8 @@ Default-Language: Haskell98 Main-Is: tests/resolveCat.hs Hs-Source-Dirs: ., cabal, cabal/Cabal, cabal/cabal-install, tests - Build-Depends: base >= 3 && < 5, + Build-Depends: array, + base >= 3 && < 5, binary, deepseq >= 1.3, bytestring, @@ -142,6 +143,7 @@ extensible-exceptions, filepath, HUnit, + parsec, pretty, process, split, @@ -155,7 +157,8 @@ Default-Language: Haskell98 Main-Is: tests/print_deps.hs Hs-Source-Dirs: ., cabal, cabal/Cabal, cabal/cabal-install, tests - Build-Depends: base >= 3 && < 5, + Build-Depends: array, + base >= 3 && < 5, binary, deepseq >= 1.3, bytestring, @@ -164,6 +167,7 @@ extensible-exceptions, filepath, HUnit, + parsec, pretty, process, time, @@ -176,7 +180,8 @@ Default-Language: Haskell98 Main-Is: tests/normalize_deps.hs Hs-Source-Dirs: ., cabal, cabal/Cabal, cabal/cabal-install, tests - Build-Depends: base >= 3 && < 5, + Build-Depends: array, + base >= 3 && < 5, binary, deepseq >= 1.3, bytestring, @@ -185,6 +190,7 @@ extensible-exceptions, filepath, HUnit, + parsec, pretty, process, time,