diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,7 +1,7 @@ -cabal-version: 3.0 +cabal-version: 3.6 name: Cabal -version: 3.14.2.0 -copyright: 2003-2024, Cabal Development Team (see AUTHORS file) +version: 3.16.1.0 +copyright: 2003-2025, Cabal Development Team (see AUTHORS file) license: BSD-3-Clause license-file: LICENSE author: Cabal Development Team @@ -29,35 +29,47 @@ location: https://github.com/haskell/cabal/ subdir: Cabal +flag git-rev + description: include Git revision hash in version + default: False + manual: True + library default-language: Haskell2010 hs-source-dirs: src build-depends: - Cabal-syntax ^>= 3.14, - array >= 0.4.0.1 && < 0.6, - base >= 4.13 && < 5, - bytestring >= 0.10.0.0 && < 0.13, - containers >= 0.5.0.0 && < 0.8, - deepseq >= 1.3.0.1 && < 1.6, - directory >= 1.2 && < 1.4, - filepath >= 1.3.0.1 && < 1.6, - pretty >= 1.1.1 && < 1.2, - process >= 1.2.1.0 && < 1.7, - time >= 1.4.0.1 && < 1.15 + , Cabal-syntax ^>= 3.16.1.0 + , array >= 0.4.0.1 && < 0.6 + , base >= 4.13 && < 5 + , bytestring >= 0.10.0.0 && < 0.13 + , containers >= 0.5.0.0 && < 0.9 + , deepseq >= 1.3.0.1 && < 1.7 + , directory >= 1.2 && < 1.4 + , filepath >= 1.3.0.1 && < 1.6 + , pretty >= 1.1.1 && < 1.2 + , process >= 1.2.1.0 && < 1.7 + , time >= 1.4.0.1 && < 1.16 if os(windows) - build-depends: Win32 >= 2.3.0.0 && < 2.15 + build-depends: + , Win32 >= 2.3.0.0 && < 2.15 else - build-depends: unix >= 2.8.6.0 && < 2.9 + build-depends: + , unix >= 2.8.6.0 && < 2.9 + if flag(git-rev) + build-depends: + , githash ^>= 0.1.7.0 + cpp-options: -DGIT_REV + ghc-options: -Wall -fno-ignore-asserts - -fwarn-tabs - -fwarn-incomplete-uni-patterns - -fwarn-incomplete-record-updates - -fno-warn-unticked-promoted-constructors + -Wtabs + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wno-unticked-promoted-constructors if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances @@ -114,7 +126,6 @@ Distribution.Simple.Haddock Distribution.Simple.Glob Distribution.Simple.Glob.Internal - Distribution.Simple.HaskellSuite Distribution.Simple.Hpc Distribution.Simple.Install Distribution.Simple.InstallDirs @@ -248,6 +259,7 @@ Distribution.Types.ConfVar, Distribution.Types.Dependency, Distribution.Types.DependencyMap, + Distribution.Types.DependencySatisfaction, Distribution.Types.ExeDependency, Distribution.Types.Executable, Distribution.Types.Executable.Lens, @@ -271,6 +283,8 @@ Distribution.Types.Library.Lens, Distribution.Types.LibraryName, Distribution.Types.LibraryVisibility, + Distribution.Types.MissingDependency, + Distribution.Types.MissingDependencyReason, Distribution.Types.Mixin, Distribution.Types.Module, Distribution.Types.ModuleReexport, @@ -316,9 +330,9 @@ build-depends: -- transformers-0.4.0.0 doesn't have record syntax e.g. for Identity -- See also https://github.com/ekmett/transformers-compat/issues/35 - transformers (>= 0.3 && < 0.4) || (>=0.4.1.0 && <0.7), - mtl >= 2.1 && < 2.4, - parsec >= 3.1.13.0 && < 3.2 + , transformers (>= 0.3 && < 0.4) || (>=0.4.1.0 && <0.7) + , mtl >= 2.1 && < 2.4 + , parsec >= 3.1.13.0 && < 3.2 other-modules: Distribution.Backpack.PreExistingComponent diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +# 3.16.1.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) December 2025 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.16.1.0.md + +# 3.16.0.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) July 2025 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.16.0.0.md + # 3.14.2.0 [Mikolaj Konarski](mailto:mikolaj@well-typed.com) April 2025 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.14.2.0.md @@ -776,7 +782,7 @@ * Many checks added for common mistakes * New `--package-db=` option for specific package databases * Many internal changes to support cabal-install - * Stricter parsing for version strings, eg dissalows "1.05" + * Stricter parsing for version strings, eg disallows "1.05" * Improved user guide introduction * Programatica support removed * New options `--program-prefix/suffix` allows eg versioned programs diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2024, Cabal Development Team. +Copyright (c) 2003-2025, 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/src/Distribution/Backpack/Configure.hs b/src/Distribution/Backpack/Configure.hs --- a/src/Distribution/Backpack/Configure.hs +++ b/src/Distribution/Backpack/Configure.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-} @@ -37,7 +35,7 @@ import qualified Distribution.InstalledPackageInfo as Installed import Distribution.ModuleName import Distribution.Package -import Distribution.PackageDescription +import Distribution.PackageDescription (FlagAssignment, PackageDescription (..), libName) import Distribution.Simple.Compiler import Distribution.Simple.Flag import Distribution.Simple.LocalBuildInfo diff --git a/src/Distribution/Backpack/ConfiguredComponent.hs b/src/Distribution/Backpack/ConfiguredComponent.hs --- a/src/Distribution/Backpack/ConfiguredComponent.hs +++ b/src/Distribution/Backpack/ConfiguredComponent.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE PatternGuards #-} - -- | See module Distribution.Backpack.ConfiguredComponent ( ConfiguredComponent (..) diff --git a/src/Distribution/Backpack/Id.hs b/src/Distribution/Backpack/Id.hs --- a/src/Distribution/Backpack/Id.hs +++ b/src/Distribution/Backpack/Id.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -- | See @@ -13,7 +14,7 @@ import Distribution.PackageDescription import Distribution.Simple.Compiler -import Distribution.Simple.Flag (Flag (..)) +import Distribution.Simple.Flag (Flag, pattern Flag, pattern NoFlag) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo import Distribution.Types.ComponentId diff --git a/src/Distribution/Backpack/ModuleScope.hs b/src/Distribution/Backpack/ModuleScope.hs --- a/src/Distribution/Backpack/ModuleScope.hs +++ b/src/Distribution/Backpack/ModuleScope.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} -- | See diff --git a/src/Distribution/Backpack/PreModuleShape.hs b/src/Distribution/Backpack/PreModuleShape.hs --- a/src/Distribution/Backpack/PreModuleShape.hs +++ b/src/Distribution/Backpack/PreModuleShape.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Backpack.PreModuleShape diff --git a/src/Distribution/Compat/Environment.hs b/src/Distribution/Compat/Environment.hs --- a/src/Distribution/Compat/Environment.hs +++ b/src/Distribution/Compat/Environment.hs @@ -63,7 +63,7 @@ {- FOURMOLU_DISABLE -} # if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall -# elif defined(x86_64_HOST_ARCH) +# elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) # define WINDOWS_CCONV ccall # else # error Unknown mingw32 arch diff --git a/src/Distribution/Compat/FilePath.hs b/src/Distribution/Compat/FilePath.hs --- a/src/Distribution/Compat/FilePath.hs +++ b/src/Distribution/Compat/FilePath.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} module Distribution.Compat.FilePath ( isExtensionOf diff --git a/src/Distribution/Compat/GetShortPathName.hs b/src/Distribution/Compat/GetShortPathName.hs --- a/src/Distribution/Compat/GetShortPathName.hs +++ b/src/Distribution/Compat/GetShortPathName.hs @@ -23,7 +23,7 @@ import Foreign.Marshal.Array (allocaArray) {- FOURMOLU_DISABLE -} -#ifdef x86_64_HOST_ARCH +#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) #define WINAPI ccall #else #define WINAPI stdcall diff --git a/src/Distribution/Compat/Internal/TempFile.hs b/src/Distribution/Compat/Internal/TempFile.hs --- a/src/Distribution/Compat/Internal/TempFile.hs +++ b/src/Distribution/Compat/Internal/TempFile.hs @@ -12,20 +12,9 @@ import System.FilePath (()) -import System.IO (Handle, openBinaryTempFile, openTempFile) -#if defined(__IO_MANAGER_WINIO__) -import System.IO (openBinaryTempFileWithDefaultPermissions) -import System.Posix.Internals (c_getpid) -#else -import Control.Exception (onException) -import Data.Bits ((.|.)) -import Foreign.C (CInt, eEXIST, getErrno, errnoToIOError) -import GHC.IO.Handle.FD (fdToHandle) -import System.Posix.Internals (c_getpid, c_open, c_close, o_EXCL, o_BINARY, withFilePath, - o_CREAT, o_RDWR, o_NONBLOCK, o_NOCTTY) -#endif - +import System.IO (Handle, openBinaryTempFile, openBinaryTempFileWithDefaultPermissions, openTempFile) import System.IO.Error (isAlreadyExistsError) +import System.Posix.Internals (c_getpid) #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) import System.Directory ( createDirectory ) @@ -33,92 +22,8 @@ import qualified System.Posix #endif --- ------------------------------------------------------------ - --- * temporary files - --- ------------------------------------------------------------ - --- This is here for Haskell implementations that do not come with --- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. --- TODO: This file should probably be removed. - --- This is a copy/paste of the openBinaryTempFile definition, but --- it uses 666 rather than 600 for the permissions. Newer versions --- of base have a new function with this behavior which we use on --- Windows when the new IO manager is used. openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) -openNewBinaryFile dir template = do - --- This method can't be used under WINIO. Also the current implementation has --- thread safety issues depending on which GHC is used. On newer GHC's let's --- use the built in one. -#if defined(__IO_MANAGER_WINIO__) - openBinaryTempFileWithDefaultPermissions dir template -#else - pid <- c_getpid - findTempName pid - where - -- We split off the last extension, so we can use .foo.ext files - -- for temporary files (hidden on Unix OSes). Unfortunately we're - -- below file path in the hierarchy here. - (prefix,suffix) = - case break (== '.') $ reverse template of - -- First case: template contains no '.'s. Just re-reverse it. - (rev_suffix, "") -> (reverse rev_suffix, "") - -- Second case: template contains at least one '.'. Strip the - -- dot from the prefix and prepend it to the suffix (if we don't - -- do this, the unique number will get added after the '.' and - -- thus be part of the extension, which is wrong.) - (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) - -- Otherwise, something is wrong, because (break (== '.')) should - -- always return a pair with either the empty string or a string - -- beginning with '.' as the second component. - _ -> error "bug in System.IO.openTempFile" - - oflags = rw_flags .|. o_EXCL .|. o_BINARY - - findTempName x = do - fd <- withFilePath filepath $ \ f -> - c_open f oflags 0o666 - if fd < 0 - then do - errno <- getErrno - if errno == eEXIST - then findTempName (x+1) - else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) - else do - -- TODO: We want to tell fdToHandle what the file path is, - -- as any exceptions etc will only be able to report the - -- FD currently - h <- fdToHandle fd `onException` c_close fd - return (filepath, h) - where - filename = prefix ++ show x ++ suffix - filepath = dir `combine` filename - - -- FIXME: bits copied from System.FilePath - combine a b - | null b = a - | null a = b - | last a == pathSeparator = a ++ b - | otherwise = a ++ [pathSeparator] ++ b - --- FIXME: Copied from GHC.Handle -std_flags, output_flags, rw_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -rw_flags = output_flags .|. o_RDWR - --- FIXME: Should use System.FilePath library -pathSeparator :: Char -#ifdef mingw32_HOST_OS -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif --- /* __IO_MANAGER_WINIO__ */ -#endif +openNewBinaryFile = openBinaryTempFileWithDefaultPermissions createTempDirectory :: FilePath -> String -> IO FilePath createTempDirectory dir template = do diff --git a/src/Distribution/Compat/Time.hs b/src/Distribution/Compat/Time.hs --- a/src/Distribution/Compat/Time.hs +++ b/src/Distribution/Compat/Time.hs @@ -94,7 +94,7 @@ return $! ModTime (qwTime :: Word64) {- FOURMOLU_DISABLE -} -#ifdef x86_64_HOST_ARCH +#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) #define CALLCONV ccall #else #define CALLCONV stdcall diff --git a/src/Distribution/GetOpt.hs b/src/Distribution/GetOpt.hs --- a/src/Distribution/GetOpt.hs +++ b/src/Distribution/GetOpt.hs @@ -134,11 +134,11 @@ -- | Pretty printing of short options. -- * With required arguments can be given as: -- @-w PATH or -wPATH (but not -w=PATH)@ --- This is dislayed as: +-- This is displayed as: -- @-w PATH or -wPATH@ -- * With optional but default arguments can be given as: -- @-j or -jNUM (but not -j=NUM or -j NUM)@ --- This is dislayed as: +-- This is displayed as: -- @-j[NUM]@ fmtShort :: ArgDescr a -> Char -> String fmtShort (NoArg _) so = "-" ++ [so] @@ -152,11 +152,11 @@ -- | Pretty printing of long options. -- * With required arguments can be given as: -- @--with-compiler=PATH (but not --with-compiler PATH)@ --- This is dislayed as: +-- This is displayed as: -- @--with-compiler=PATH@ -- * With optional but default arguments can be given as: -- @--jobs or --jobs=NUM (but not --jobs NUM)@ --- This is dislayed as: +-- This is displayed as: -- @--jobs[=NUM]@ fmtLong :: ArgDescr a -> String -> String fmtLong (NoArg _) lo = "--" ++ lo diff --git a/src/Distribution/PackageDescription/Check.hs b/src/Distribution/PackageDescription/Check.hs --- a/src/Distribution/PackageDescription/Check.hs +++ b/src/Distribution/PackageDescription/Check.hs @@ -268,8 +268,6 @@ checkP (not . null $ dups names) (PackageBuildImpossible $ DuplicateSections dupes) - -- PackageDescription checks. - checkPackageDescription packageDescription_ -- Flag names. mapM_ checkFlagName genPackageFlags_ diff --git a/src/Distribution/PackageDescription/Check/Common.hs b/src/Distribution/PackageDescription/Check/Common.hs --- a/src/Distribution/PackageDescription/Check/Common.hs +++ b/src/Distribution/PackageDescription/Check/Common.hs @@ -80,7 +80,7 @@ -- shared targets that match fads = filter (flip elem dqs . fst) ads -- the names of such targets - inNam = nub $ map fst fads :: [UnqualComponentName] + inName = nub $ map fst fads :: [UnqualComponentName] -- the dependencies of such targets inDep = concatMap snd fads :: [Dependency] @@ -97,7 +97,7 @@ -- text, ← no warning, inherited -- monadacme ← warning! let fFun d = - notElem (unqualName d) inNam + notElem (unqualName d) inName && notElem (unqualName d) (map unqualName inDep) diff --git a/src/Distribution/PackageDescription/Check/Monad.hs b/src/Distribution/PackageDescription/Check/Monad.hs --- a/src/Distribution/PackageDescription/Check/Monad.hs +++ b/src/Distribution/PackageDescription/Check/Monad.hs @@ -242,7 +242,7 @@ -- There are some errors which, even though severe, will -- be allowed by Hackage *if* under a non-default flag. isErrAllowable :: PackageCheck -> Bool - isErrAllowable c = case extractCheckExplantion c of + isErrAllowable c = case extractCheckExplanation c of (WErrorUnneeded _) -> True (JUnneeded _) -> True (FDeferTypeErrorsUnneeded _) -> True diff --git a/src/Distribution/PackageDescription/Check/Paths.hs b/src/Distribution/PackageDescription/Check/Paths.hs --- a/src/Distribution/PackageDescription/Check/Paths.hs +++ b/src/Distribution/PackageDescription/Check/Paths.hs @@ -10,6 +10,7 @@ module Distribution.PackageDescription.Check.Paths ( checkGlob , checkPath + , checkPackageFileNamesWithGlob , fileExtensionSupportedLanguage , isGoodRelativeDirectoryPath , isGoodRelativeFilePath diff --git a/src/Distribution/PackageDescription/Check/Target.hs b/src/Distribution/PackageDescription/Check/Target.hs --- a/src/Distribution/PackageDescription/Check/Target.hs +++ b/src/Distribution/PackageDescription/Check/Target.hs @@ -21,7 +21,7 @@ import Distribution.CabalSpecVersion import Distribution.Compat.Lens import Distribution.Compiler -import Distribution.ModuleName (ModuleName) +import Distribution.ModuleName (ModuleName, toFilePath) import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Check.Common @@ -61,6 +61,8 @@ _libVisibility_ libBuildInfo_ ) = do + mapM_ checkModuleName (explicitLibModules lib) + checkP (libName_ == LMainLibName && isSub) (PackageBuildImpossible UnnamedInternal) @@ -144,6 +146,8 @@ let cet = CETExecutable exeName_ modulePath_ = getSymbolicPath symbolicModulePath_ + mapM_ checkModuleName (exeModules exe) + -- § Exe specific checks checkP (null modulePath_) @@ -205,6 +209,9 @@ TestSuiteUnsupported tt -> tellP (PackageBuildWarning $ TestsuiteNotSupported tt) _ -> return () + + mapM_ checkModuleName (testModules ts) + checkP mainIsWrongExt (PackageBuildImpossible NoHsLhsMain) @@ -257,6 +264,8 @@ -- Target type/name (benchmark). let cet = CETBenchmark benchmarkName_ + mapM_ checkModuleName (benchmarkModules bm) + -- § Interface & bm specific tests. case benchmarkInterface_ of BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> @@ -294,6 +303,11 @@ BenchmarkExeV10 _ f -> takeExtension (getSymbolicPath f) `notElem` [".hs", ".lhs"] _ -> False +-- | Check if a module name is valid on both Windows and Posix systems +checkModuleName :: Monad m => ModuleName -> CheckM m () +checkModuleName moduleName = + checkPackageFileNamesWithGlob PathKindFile (toFilePath moduleName) + -- ------------------------------------------------------------ -- Build info -- ------------------------------------------------------------ @@ -800,6 +814,7 @@ checkCLikeOptions LangC "cc-options" (ccOptions bi) ldOpts checkCLikeOptions LangCPlusPlus "cxx-options" (cxxOptions bi) ldOpts checkCPPOptions (cppOptions bi) + checkJSPOptions (jsppOptions bi) -- | Checks GHC options for commonly misused or non-portable flags. checkGHCOptions @@ -892,6 +907,12 @@ ) checkAlternatives title + "jspp-options" + ( [(flag, flag) | flag@('-' : 'D' : _) <- ghcNoRts] + ++ [(flag, flag) | flag@('-' : 'U' : _) <- ghcNoRts] + ) + checkAlternatives + title "include-dirs" [(flag, dir) | flag@('-' : 'I' : dir) <- ghcNoRts] checkAlternatives @@ -1077,5 +1098,22 @@ checkP (not $ any (`isPrefixOf` opt) ["-D", "-U", "-I"]) (PackageBuildWarning (COptCPP opt)) + ) + opts + +checkJSPOptions + :: Monad m + => [String] -- Options in String form. + -> CheckM m () +checkJSPOptions opts = do + checkAlternatives + "jspp-options" + "include-dirs" + [(flag, dir) | flag@('-' : 'I' : dir) <- opts] + mapM_ + ( \opt -> + checkP + (not $ any (`isPrefixOf` opt) ["-D", "-U", "-I"]) + (PackageBuildWarning (OptJSPP opt)) ) opts diff --git a/src/Distribution/PackageDescription/Check/Warning.hs b/src/Distribution/PackageDescription/Check/Warning.hs --- a/src/Distribution/PackageDescription/Check/Warning.hs +++ b/src/Distribution/PackageDescription/Check/Warning.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -25,7 +24,7 @@ , ppPackageCheck , ppCheckExplanationId , isHackageDistError - , extractCheckExplantion + , extractCheckExplanation , filterPackageChecksById , filterPackageChecksByIdString ) where @@ -124,7 +123,7 @@ ff c = flip notElem is . checkExplanationId - . extractCheckExplantion + . extractCheckExplanation $ c -- | Filter Package Check by Check explanation /string/. @@ -215,6 +214,7 @@ | OptWithRts String | COptONumber String WarnLang | COptCPP String + | OptJSPP String | OptAlternatives String String [(String, String)] | RelativeOutside String FilePath | AbsolutePath String FilePath @@ -296,14 +296,14 @@ -- to be a ad hoc monoid. -- Convenience. -extractCheckExplantion :: PackageCheck -> CheckExplanation -extractCheckExplantion (PackageBuildImpossible e) = e -extractCheckExplantion (PackageBuildWarning e) = e -extractCheckExplantion (PackageDistSuspicious e) = e -extractCheckExplantion (PackageDistSuspiciousWarn e) = e -extractCheckExplantion (PackageDistInexcusable e) = e +extractCheckExplanation :: PackageCheck -> CheckExplanation +extractCheckExplanation (PackageBuildImpossible e) = e +extractCheckExplanation (PackageBuildWarning e) = e +extractCheckExplanation (PackageDistSuspicious e) = e +extractCheckExplanation (PackageDistSuspiciousWarn e) = e +extractCheckExplanation (PackageDistInexcusable e) = e --- | Identifier for the speficic 'CheckExplanation'. This ensures `--ignore` +-- | Identifier for the specific 'CheckExplanation'. This ensures `--ignore` -- can output a warning on unrecognised values. -- ☞ N.B.: should be kept in sync with 'CheckExplanation'. data CheckExplanationID @@ -381,6 +381,7 @@ | CIOptWithRts | CICOptONumber | CICOptCPP + | CIOptJSPP | CIOptAlternatives | CIRelativeOutside | CIAbsolutePath @@ -526,6 +527,7 @@ checkExplanationId (OptWithRts{}) = CIOptWithRts checkExplanationId (COptONumber{}) = CICOptONumber checkExplanationId (COptCPP{}) = CICOptCPP +checkExplanationId (OptJSPP{}) = CIOptJSPP checkExplanationId (OptAlternatives{}) = CIOptAlternatives checkExplanationId (RelativeOutside{}) = CIRelativeOutside checkExplanationId (AbsolutePath{}) = CIAbsolutePath @@ -678,6 +680,7 @@ ppCheckExplanationId CIOptWithRts = "option-with-rtsopts" ppCheckExplanationId CICOptONumber = "option-opt-c" ppCheckExplanationId CICOptCPP = "cpp-options" +ppCheckExplanationId CIOptJSPP = "jspp-options" ppCheckExplanationId CIOptAlternatives = "misplaced-c-opt" ppCheckExplanationId CIRelativeOutside = "relative-path-outside" ppCheckExplanationId CIAbsolutePath = "absolute-path" @@ -1087,6 +1090,8 @@ ++ " --disable-optimization flag." ppExplanation (COptCPP opt) = "'cpp-options: " ++ opt ++ "' is not a portable C-preprocessor flag." +ppExplanation (OptJSPP opt) = + "'jspp-options: " ++ opt ++ "' is not a portable JavaScript-preprocessor flag." ppExplanation (OptAlternatives badField goodField flags) = "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) diff --git a/src/Distribution/Simple.hs b/src/Distribution/Simple.hs --- a/src/Distribution/Simple.hs +++ b/src/Distribution/Simple.hs @@ -1,12 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- {- Work around this warning: @@ -15,7 +12,8 @@ (imported from Distribution.Simple.UserHooks): Deprecated: "Please use the new testing interface instead!" -} -{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | -- Module : Distribution.Simple diff --git a/src/Distribution/Simple/Bench.hs b/src/Distribution/Simple/Bench.hs --- a/src/Distribution/Simple/Bench.hs +++ b/src/Distribution/Simple/Bench.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -25,7 +24,7 @@ import qualified Distribution.PackageDescription as PD import Distribution.Pretty -import Distribution.Simple.Build (addInternalBuildToolsFixed) +import Distribution.Simple.Build (addInternalBuildTools) import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.Errors @@ -72,8 +71,8 @@ lbi { -- Include any build-tool-depends on build tools internal to the current package. LBI.withPrograms = - addInternalBuildToolsFixed - (Just curDir) + addInternalBuildTools + curDir pkg_descr lbi (benchmarkBuildInfo bm) diff --git a/src/Distribution/Simple/Build.hs b/src/Distribution/Simple/Build.hs --- a/src/Distribution/Simple/Build.hs +++ b/src/Distribution/Simple/Build.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} @@ -48,7 +47,6 @@ -- * Handling of internal build tools , addInternalBuildTools - , addInternalBuildToolsFixed ) where import Distribution.Compat.Prelude @@ -74,7 +72,6 @@ import Distribution.Package import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.HaskellSuite as HaskellSuite import qualified Distribution.Simple.PackageIndex as Index import qualified Distribution.Simple.UHC as UHC @@ -98,7 +95,6 @@ import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PreProcess import Distribution.Simple.Program -import Distribution.Simple.Program.Builtin (haskellSuiteProgram) import Distribution.Simple.Program.Db import qualified Distribution.Simple.Program.GHC as GHC import Distribution.Simple.Program.Types @@ -197,7 +193,7 @@ clbi = targetCLBI target bi = componentBuildInfo comp -- Include any build-tool-depends on build tools internal to the current package. - progs' = addInternalBuildToolsFixed (Just curDir) pkg_descr lbi bi (withPrograms lbi) + progs' = addInternalBuildTools curDir pkg_descr lbi bi (withPrograms lbi) lbi' = lbi { withPrograms = progs' @@ -320,7 +316,6 @@ flavorToProgram GHCJS = Just ghcjsProgram flavorToProgram UHC = Just uhcProgram flavorToProgram JHC = Just jhcProgram - flavorToProgram HaskellSuite{} = Just haskellSuiteProgram flavorToProgram _ = Nothing repl @@ -386,8 +381,8 @@ { withPackageDB = withPackageDB lbi' ++ [internalPackageDB] , withPrograms = -- Include any build-tool-depends on build tools internal to the current package. - addInternalBuildToolsFixed - (Just curDir) + addInternalBuildTools + curDir pkg_descr lbi' (componentBuildInfo comp) @@ -931,18 +926,14 @@ -- directory environment variable for the current package to the current -- 'progOverrideEnv', so that any programs configured from now on will be -- able to invoke these build tools. --- --- NB: This function will be removed in the next Cabal major version --- (use addInternalBuildTools instead). This function is introduced solely for --- backporting in a PVP compliant way. -addInternalBuildToolsFixed - :: Maybe (AbsolutePath (Dir Pkg)) +addInternalBuildTools + :: AbsolutePath (Dir Pkg) -> PackageDescription -> LocalBuildInfo -> BuildInfo -> ProgramDb -> ProgramDb -addInternalBuildToolsFixed mpwd pkg lbi bi progs = +addInternalBuildTools pwd pkg lbi bi progs = prependProgramSearchPathNoLogging internalToolPaths [pkgDataDirVar] @@ -962,26 +953,10 @@ makeRelativePathEx (toolName' toolName' <.> exeExtension (hostPlatform lbi)) ] + -- This is an absolute path, so if a process changes directory, it can still + -- find the datadir (#10717) dataDirPath :: FilePath - dataDirPath = - case mpwd of - -- This is an absolute path, so if a process changes directory, it can still - -- find the datadir (#10717) - Just pwd -> interpretSymbolicPathAbsolute pwd (dataDir pkg) - -- This is just wrong, but implemented for PVP compliance.. - Nothing -> interpretSymbolicPathCWD (dataDir pkg) - -{-# WARNING addInternalBuildTools "This function is broken, use addInternalBuildToolsFixed instead" #-} - --- | A backwards compatible (broken) version of `addInternalBuildTools`, do not --- use this function. Use 'addInternalBuildToolsFixed' instead. -addInternalBuildTools - :: PackageDescription - -> LocalBuildInfo - -> BuildInfo - -> ProgramDb - -> ProgramDb -addInternalBuildTools = addInternalBuildToolsFixed Nothing + dataDirPath = interpretSymbolicPathAbsolute pwd (dataDir pkg) -- TODO: build separate libs in separate dirs so that we can build -- multiple libs, e.g. for 'LibTest' library-style test suites @@ -999,7 +974,6 @@ GHC -> GHC.buildLib flags numJobs pkg_descr lbi lib clbi GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi - HaskellSuite{} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi _ -> dieWithException verbosity BuildingNotSupportedWithCompiler -- | Build a foreign library diff --git a/src/Distribution/Simple/Build/Inputs.hs b/src/Distribution/Simple/Build/Inputs.hs --- a/src/Distribution/Simple/Build/Inputs.hs +++ b/src/Distribution/Simple/Build/Inputs.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} - module Distribution.Simple.Build.Inputs ( -- * Inputs of actions for building components PreBuildComponentInputs (..) diff --git a/src/Distribution/Simple/Build/Macros.hs b/src/Distribution/Simple/Build/Macros.hs --- a/src/Distribution/Simple/Build/Macros.hs +++ b/src/Distribution/Simple/Build/Macros.hs @@ -58,7 +58,7 @@ , let (major1, major2, minor) = majorMinor ver ] , Z.zPackageKey = case clbi of - LibComponentLocalBuildInfo{} -> componentCompatPackageKey clbi + LibComponentLocalBuildInfo{componentCompatPackageKey = compatPackageKey} -> compatPackageKey _ -> "" , Z.zComponentId = prettyShow (componentComponentId clbi) , Z.zPackageVersion = pkgVersion (package pkg_descr) diff --git a/src/Distribution/Simple/Build/PackageInfoModule.hs b/src/Distribution/Simple/Build/PackageInfoModule.hs --- a/src/Distribution/Simple/Build/PackageInfoModule.hs +++ b/src/Distribution/Simple/Build/PackageInfoModule.hs @@ -10,7 +10,7 @@ -- Generating the PackageInfo_pkgname module. -- -- This is a module that Cabal generates for the benefit of packages. It --- enables them to find their package informations. +-- enables them to find their package information. module Distribution.Simple.Build.PackageInfoModule ( generatePackageInfoModule ) where diff --git a/src/Distribution/Simple/Build/PackageInfoModule/Z.hs b/src/Distribution/Simple/Build/PackageInfoModule/Z.hs --- a/src/Distribution/Simple/Build/PackageInfoModule/Z.hs +++ b/src/Distribution/Simple/Build/PackageInfoModule/Z.hs @@ -22,8 +22,25 @@ return () else do return () - tell "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n" + tell "{-# OPTIONS_GHC -Wno-missing-import-lists #-}\n" tell "{-# OPTIONS_GHC -w #-}\n" + tell "\n" + tell "{-|\n" + tell "Module : PackageInfo_" + tell (zPackageName z_root) + tell "\n" + tell "Description : Contents of some of the package's Cabal file's fields.\n" + tell "\n" + tell "WARNING: This module was generated by Cabal. Any modifications will be\n" + tell "overwritten if the module is regenerated.\n" + tell "\n" + tell "This module exports values that record information from some of the fields of\n" + tell "the package's Cabal package description file (Cabal file).\n" + tell "\n" + tell "For further information about the fields in a Cabal file, see the Cabal User\n" + tell "Guide.\n" + tell "-}\n" + tell "\n" tell "module PackageInfo_" tell (zPackageName z_root) tell " (\n" @@ -37,23 +54,29 @@ tell "import Data.Version (Version(..))\n" tell "import Prelude\n" tell "\n" + tell "-- |The content of the @name@ field of the package's Cabal file, but with any\n" + tell "-- hyphen characters replaced by underscore characters.\n" tell "name :: String\n" tell "name = " tell (show $ zPackageName z_root) tell "\n" + tell "-- |The content of the @version@ field of the package's Cabal file.\n" tell "version :: Version\n" tell "version = Version " tell (zVersionDigits z_root) tell " []\n" tell "\n" + tell "-- |The content of the @synopsis@ field of the package's Cabal file.\n" tell "synopsis :: String\n" tell "synopsis = " tell (show $ zSynopsis z_root) tell "\n" + tell "-- |The content of the @copyright@ field of the package's Cabal file.\n" tell "copyright :: String\n" tell "copyright = " tell (show $ zCopyright z_root) tell "\n" + tell "-- |The content of the @homepage@ field of the package's Cabal file.\n" tell "homepage :: String\n" tell "homepage = " tell (show $ zHomepage z_root) diff --git a/src/Distribution/Simple/Build/PathsModule.hs b/src/Distribution/Simple/Build/PathsModule.hs --- a/src/Distribution/Simple/Build/PathsModule.hs +++ b/src/Distribution/Simple/Build/PathsModule.hs @@ -51,6 +51,7 @@ , Z.zIsWindows = isWindows , Z.zIsI386 = buildArch == I386 , Z.zIsX8664 = buildArch == X86_64 + , Z.zIsAArch64 = buildArch == AArch64 , Z.zNot = not , Z.zManglePkgName = showPkgName , Z.zPrefix = show flat_prefix diff --git a/src/Distribution/Simple/Build/PathsModule/Z.hs b/src/Distribution/Simple/Build/PathsModule/Z.hs --- a/src/Distribution/Simple/Build/PathsModule/Z.hs +++ b/src/Distribution/Simple/Build/PathsModule/Z.hs @@ -12,6 +12,7 @@ zIsWindows :: Bool, zIsI386 :: Bool, zIsX8664 :: Bool, + zIsAArch64 :: Bool, zPrefix :: FilePath, zBindir :: FilePath, zLibdir :: FilePath, @@ -50,8 +51,27 @@ return () else do return () - tell "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n" + tell "{-# OPTIONS_GHC -Wno-missing-import-lists #-}\n" tell "{-# OPTIONS_GHC -w #-}\n" + tell "\n" + tell "{-|\n" + tell "Module : Paths_" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "\n" + tell "Description : Data file location, and package version and installation\n" + tell " directories.\n" + tell "\n" + tell "WARNING: This module was generated by Cabal. Any modifications will be\n" + tell "overwritten if the module is regenerated.\n" + tell "\n" + tell "This module exports a function to locate data files, and values that record\n" + tell "the version of the package and some directories which the package has been\n" + tell "configured to be installed into.\n" + tell "\n" + tell "For further information about Cabal's options for its configuration step, and\n" + tell "their default values, see the Cabal User Guide.\n" + tell "-}\n" + tell "\n" tell "module Paths_" tell (zManglePkgName z_root (zPackageName z_root)) tell " (\n" @@ -69,7 +89,6 @@ return () tell "\n" tell "import qualified Control.Exception as Exception\n" - tell "import qualified Data.List as List\n" tell "import Data.Version (Version(..))\n" tell "import System.Environment (getEnv)\n" tell "import Prelude\n" @@ -101,18 +120,64 @@ tell "catchIO = Exception.catch\n" return () tell "\n" + tell "-- |The package version.\n" tell "version :: Version\n" tell "version = Version " tell (zVersionDigits z_root) tell " []\n" tell "\n" + tell "-- |If the argument is a filename, the result is the name of a corresponding\n" + tell "-- file on the system on which the program is running, if the file were listed\n" + tell "-- in the @data-files@ field of the package's Cabal package description file.\n" + tell "-- No check is performed that the given filename is listed in that field.\n" tell "getDataFileName :: FilePath -> IO FilePath\n" tell "getDataFileName name = do\n" tell " dir <- getDataDir\n" tell " return (dir `joinFileName` name)\n" tell "\n" - tell "getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n" + tell "-- |The location of the directory specified by Cabal's @--bindir@ option (where\n" + tell "-- executables that the user might invoke are installed). This can be overridden\n" + tell "-- at runtime using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_bindir.\n" + tell "getBinDir :: IO FilePath\n" tell "\n" + tell "-- |The location of the directory specified by Cabal's @--libdir@ option (where\n" + tell "-- object libraries are installed). This can be overridden at runtime using the\n" + tell "-- environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libdir.\n" + tell "getLibDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--dynlibdir@ option\n" + tell "-- (where dynamic libraries are installed). This can be overridden at runtime\n" + tell "-- using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_dynlibdir.\n" + tell "getDynLibDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--datadir@ option (where\n" + tell "-- architecture-independent data files are installed). This can be overridden at\n" + tell "-- runtime using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_datadir.\n" + tell "getDataDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--libexedir@ option\n" + tell "-- (where executables that are not expected to be invoked directly by the user\n" + tell "-- are installed). This can be overridden at runtime using the environment\n" + tell "-- variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libexedir.\n" + tell "getLibexecDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--sysconfdir@ option\n" + tell "-- (where configuration files are installed). This can be overridden at runtime\n" + tell "-- using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_sysconfdir.\n" + tell "getSysconfDir :: IO FilePath\n" + tell "\n" let z_var0_function_defs = do tell "minusFileName :: FilePath -> String -> FilePath\n" @@ -285,9 +350,16 @@ tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" return () else do - tell "-- win32 supported only with I386, X86_64\n" - tell "c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" - tell "c_GetModuleFileName = _\n" + if (zIsAArch64 z_root) + then do + tell "foreign import ccall unsafe \"windows.h GetModuleFileNameW\"\n" + tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + return () + else do + tell "-- win32 supported only with I386, X86_64, AArch64\n" + tell "c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + tell "c_GetModuleFileName = _\n" + return () return () return () tell "\n" @@ -306,9 +378,14 @@ tell "joinFileName \"\" fname = fname\n" tell "joinFileName \".\" fname = fname\n" tell "joinFileName dir \"\" = dir\n" - tell "joinFileName dir fname\n" - tell " | isPathSeparator (List.last dir) = dir ++ fname\n" + tell "joinFileName dir@(c:cs) fname\n" + tell " | isPathSeparator (lastChar c cs) = dir ++ fname\n" tell " | otherwise = dir ++ pathSeparator : fname\n" + tell " where\n" + tell " -- We do not use Data.List.NonEmpty.last, as that would limit the module to\n" + tell " -- base >= 4.9.0.0 (GHC >= 8.0.1).\n" + tell " lastChar x [] = x\n" + tell " lastChar _ (x:xs) = lastChar x xs\n" tell "\n" tell "pathSeparator :: Char\n" if (zIsWindows z_root) diff --git a/src/Distribution/Simple/BuildTarget.hs b/src/Distribution/Simple/BuildTarget.hs --- a/src/Distribution/Simple/BuildTarget.hs +++ b/src/Distribution/Simple/BuildTarget.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- diff --git a/src/Distribution/Simple/BuildToolDepends.hs b/src/Distribution/Simple/BuildToolDepends.hs --- a/src/Distribution/Simple/BuildToolDepends.hs +++ b/src/Distribution/Simple/BuildToolDepends.hs @@ -13,7 +13,7 @@ import Distribution.Package import Distribution.PackageDescription --- | Same as 'desugarBuildTool', but requires atomic informations (package +-- | Same as 'desugarBuildTool', but requires atomic information (package -- name, executable names) instead of a whole 'PackageDescription'. desugarBuildToolSimple :: PackageName @@ -34,7 +34,6 @@ , "hsc2hs" , "c2hs" , "cpphs" - , "greencard" , "hspec-discover" ] allowMap = Map.fromList $ flip map allowlist $ \n -> diff --git a/src/Distribution/Simple/Command.hs b/src/Distribution/Simple/Command.hs --- a/src/Distribution/Simple/Command.hs +++ b/src/Distribution/Simple/Command.hs @@ -624,8 +624,8 @@ -- | Mark command as hidden. Hidden commands don't show up in the 'progname -- help' or 'progname --help' output. hiddenCommand :: Command action -> Command action -hiddenCommand (Command name synopsys f _cmdType) = - Command name synopsys f HiddenCommand +hiddenCommand (Command name synopsis f _cmdType) = + Command name synopsis f HiddenCommand commandAddAction :: CommandUI flags diff --git a/src/Distribution/Simple/Compiler.hs b/src/Distribution/Simple/Compiler.hs --- a/src/Distribution/Simple/Compiler.hs +++ b/src/Distribution/Simple/Compiler.hs @@ -1,6 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} @@ -86,6 +84,7 @@ , libraryDynDirSupported , libraryVisibilitySupported , jsemSupported + , reexportedAsSupported -- * Support for profiling detail levels , ProfDetailLevel (..) @@ -434,6 +433,14 @@ where v = compilerVersion comp +-- | Does the compiler support the -reexported-modules "A as B" syntax +reexportedAsSupported :: Compiler -> Bool +reexportedAsSupported comp = case compilerFlavor comp of + GHC -> v >= mkVersion [9, 12] + _ -> False + where + v = compilerVersion comp + -- | Does this compiler support a package database entry with: -- "dynamic-library-dirs"? libraryDynDirSupported :: Compiler -> Bool @@ -481,7 +488,7 @@ waySupported way comp = case compilerFlavor comp of GHC -> - -- Infomation about compiler ways is only accurately reported after + -- Information about compiler ways is only accurately reported after -- 9.10.1. Which is useful as this is before profiling dynamic support -- was introduced. (See GHC #24881) if compilerVersion comp >= mkVersion [9, 10, 1] @@ -502,11 +509,13 @@ -- | Is the compiler distributed with profiling dynamic libraries profilingDynamicSupported :: Compiler -> Maybe Bool -profilingDynamicSupported comp = - -- Certainly not before this version, as it was not implemented yet. - if compilerVersion comp <= mkVersion [9, 11, 0] - then Just False - else waySupported "p_dyn" comp +profilingDynamicSupported comp + | GHC <- compilerFlavor comp + , -- Certainly not before 9.11, as prof+dyn was not implemented yet. + compilerVersion comp <= mkVersion [9, 11, 0] = + Just False + | otherwise = + waySupported "p_dyn" comp -- | Either profiling dynamic is definitely supported or we don't know (so assume -- it is) diff --git a/src/Distribution/Simple/Configure.hs b/src/Distribution/Simple/Configure.hs --- a/src/Distribution/Simple/Configure.hs +++ b/src/Distribution/Simple/Configure.hs @@ -48,8 +48,10 @@ , getInstalledPackagesMonitorFiles , getInstalledPackagesById , getPackageDBContents + , configCompiler , configCompilerEx , configCompilerAuxEx + , configCompilerProgDb , computeEffectiveProfiling , ccLdOptionsBuildInfo , checkForeignDeps @@ -105,18 +107,20 @@ import Distribution.Simple.Utils import Distribution.System import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.DependencySatisfaction (DependencySatisfaction (..)) import Distribution.Types.GivenComponent import qualified Distribution.Types.LocalBuildConfig as LBC import Distribution.Types.LocalBuildInfo +import Distribution.Types.MissingDependencyReason (MissingDependencyReason (..)) import Distribution.Types.PackageVersionConstraint import Distribution.Utils.LogProgress import Distribution.Utils.NubList +import Distribution.Utils.String (trim) import Distribution.Verbosity import Distribution.Version import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.HaskellSuite as HaskellSuite import qualified Distribution.Simple.UHC as UHC import Control.Exception @@ -153,7 +157,6 @@ ( canonicalizePath , createDirectoryIfMissing , doesFileExist - , getTemporaryDirectory , removeFile ) import System.FilePath @@ -1478,7 +1481,7 @@ -> Map (PackageName, ComponentName) PromisedComponent -> Map (PackageName, ComponentName) InstalledPackageInfo -- ^ required dependencies - -> (Dependency -> Bool) + -> (Dependency -> DependencySatisfaction) dependencySatisfiable use_external_internal_deps exact_config @@ -1504,16 +1507,14 @@ internalDepSatisfiable else -- Backward compatibility for the old sublibrary syntax - ( sublibs == mainLibSet - && Map.member - ( pn - , CLibName $ - LSubLibName $ - packageNameToUnqualComponentName depName - ) - requiredDepsMap - ) - || all visible sublibs + let depComponentName = + CLibName $ LSubLibName $ packageNameToUnqualComponentName depName + invisibleLibraries = NES.filter (not . visible) sublibs + in if sublibs == mainLibSet && Map.member (pn, depComponentName) requiredDepsMap + then Satisfied + else case nonEmpty $ Set.toList invisibleLibraries of + Nothing -> Satisfied + Just invisibleLibraries' -> Unsatisfied $ MissingLibrary invisibleLibraries' | isInternalDep = if use_external_internal_deps then -- When we are doing per-component configure, we now need to @@ -1530,12 +1531,31 @@ isInternalDep = pn == depName depSatisfiable = - not . null $ PackageIndex.lookupDependency installedPackageSet depName vr + let allVersions = PackageIndex.lookupPackageName installedPackageSet depName + eligibleVersions = + [ version + | (version, _infos) <- PackageIndex.eligibleDependencies allVersions + ] + in if null $ PackageIndex.matchingDependencies vr allVersions + then + if null eligibleVersions + then Unsatisfied $ MissingPackage + else Unsatisfied $ WrongVersion eligibleVersions + else Satisfied internalDepSatisfiable = - Set.isSubsetOf (NES.toSet sublibs) packageLibraries + let missingLibraries = (NES.toSet sublibs) `Set.difference` packageLibraries + in case nonEmpty $ Set.toList missingLibraries of + Nothing -> Satisfied + Just missingLibraries' -> Unsatisfied $ MissingLibrary missingLibraries' + internalDepSatisfiableExternally = - all (\ln -> not $ null $ PackageIndex.lookupInternalDependency installedPackageSet pn vr ln) sublibs + -- TODO: Might need to propagate information on which versions _are_ available, if any... + let missingLibraries = + NES.filter (null . PackageIndex.lookupInternalDependency installedPackageSet pn vr) sublibs + in case nonEmpty $ Set.toList missingLibraries of + Nothing -> Satisfied + Just missingLibraries' -> Unsatisfied $ MissingLibrary missingLibraries' -- Check whether a library exists and is visible. -- We don't disambiguate between dependency on non-existent or private @@ -1570,7 +1590,7 @@ -> ConfigFlags -> ComponentRequestedSpec -> [PackageVersionConstraint] - -> (Dependency -> Bool) + -> (Dependency -> DependencySatisfaction) -- ^ tests if a dependency is satisfiable. -- Might say it's satisfiable even when not. -> Compiler @@ -2050,8 +2070,6 @@ GHC -> GHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb GHCJS -> GHCJS.getInstalledPackages verbosity mbWorkDir packageDBs' progdb UHC -> UHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb - HaskellSuite{} -> - HaskellSuite.getInstalledPackages verbosity packageDBs' progdb flv -> dieWithException verbosity $ HowToFindInstalledPackages flv where @@ -2377,7 +2395,6 @@ pkgconfig ["--modversion", pkg] `catchIO` (\_ -> dieWithException verbosity $ PkgConfigNotFound pkg versionRequirement) `catchExit` (\_ -> dieWithException verbosity $ PkgConfigNotFound pkg versionRequirement) - let trim = dropWhile isSpace . dropWhileEnd isSpace let v = PkgconfigVersion (toUTF8BS $ trim version) if not (withinPkgconfigVersionRange v range) then dieWithException verbosity $ BadVersion pkg versionRequirement v @@ -2469,10 +2486,14 @@ programDb verbosity +-- | Configure the compiler and associated programs such as @hc-pkg@, @haddock@ +-- and toolchain program such as @ar@, @ld@. configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath + -- ^ user-specified @hc@ path (optional) -> Maybe FilePath + -- ^ user-specified @hc-pkg@ path (optional) -> ProgramDb -> Verbosity -> IO (Compiler, Platform, ProgramDb) @@ -2481,11 +2502,46 @@ (comp, maybePlatform, programDb) <- case hcFlavor of GHC -> GHC.configure verbosity hcPath hcPkg progdb GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb - UHC -> UHC.configure verbosity hcPath hcPkg progdb - HaskellSuite{} -> HaskellSuite.configure verbosity hcPath hcPkg progdb + UHC -> UHC.configure verbosity hcPath progdb _ -> dieWithException verbosity UnknownCompilerException return (comp, fromMaybe buildPlatform maybePlatform, programDb) +-- | Configure the compiler ONLY. +configCompiler + :: Maybe CompilerFlavor + -> Maybe FilePath + -- ^ user-specified @hc@ path (optional) + -> ProgramDb + -> Verbosity + -> IO (Compiler, Platform, ProgramDb) +configCompiler mbFlavor hcPath progdb verbosity = do + (comp, maybePlatform, programDb) <- + case mbFlavor of + Nothing -> dieWithException verbosity UnknownCompilerException + Just hcFlavor -> + case hcFlavor of + GHC -> GHC.configureCompiler verbosity hcPath progdb + GHCJS -> GHCJS.configureCompiler verbosity hcPath progdb + UHC -> UHC.configure verbosity hcPath progdb + _ -> dieWithException verbosity UnknownCompilerException + return (comp, fromMaybe buildPlatform maybePlatform, programDb) + +-- | Configure programs associated to the compiler, such as @hc-pkg@, @haddock@ +-- and toolchain program such as @ar@, @ld@. +configCompilerProgDb + :: Verbosity + -> Compiler + -> ProgramDb + -- ^ program database containing the compiler + -> Maybe FilePath + -- ^ user-specified @hc-pkg@ path (optional) + -> IO ProgramDb +configCompilerProgDb verbosity comp hcProgDb hcPkgPath = do + case compilerFlavor comp of + GHC -> GHC.compilerProgramDb verbosity comp hcProgDb hcPkgPath + GHCJS -> GHCJS.compilerProgramDb verbosity comp hcProgDb hcPkgPath + _ -> return hcProgDb + -- ----------------------------------------------------------------------------- -- Testing C lib and header dependencies @@ -2672,10 +2728,9 @@ builds :: String -> [ProgArg] -> IO Bool builds program args = - do - tempDir <- makeSymbolicPath <$> getTemporaryDirectory - withTempFileCwd mbWorkDir tempDir ".c" $ \cName cHnd -> - withTempFileCwd mbWorkDir tempDir "" $ \oNname oHnd -> do + withTempFileCwd ".c" $ \cName cHnd -> + withTempFileCwd "" $ \oNname oHnd -> + do hPutStrLn cHnd program hClose cHnd hClose oHnd @@ -2687,8 +2742,8 @@ (withPrograms lbi) (getSymbolicPath cName : "-o" : getSymbolicPath oNname : args) return True - `catchIO` (\_ -> return False) - `catchExit` (\_ -> return False) + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) explainErrors Nothing [] = return () -- should be impossible! explainErrors _ _ @@ -2854,6 +2909,7 @@ goGhcPlatform :: Platform -> Maybe String goGhcPlatform (Platform _ OSX) = goGhcOsx (foreignLibType flib) goGhcPlatform (Platform _ Linux) = goGhcLinux (foreignLibType flib) + goGhcPlatform (Platform _ FreeBSD) = goGhcLinux (foreignLibType flib) goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib) goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib) goGhcPlatform _ = diff --git a/src/Distribution/Simple/ConfigureScript.hs b/src/Distribution/Simple/ConfigureScript.hs --- a/src/Distribution/Simple/ConfigureScript.hs +++ b/src/Distribution/Simple/ConfigureScript.hs @@ -5,7 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Distribution.Simple.ConfigureScript @@ -78,6 +78,18 @@ -- We don't try and tell configure which ld to use, as we don't have -- a way to pass its flags too + -- Do not presume the CXX compiler is available, but it always will be after 9.4. + (mcxxProgShort, mcxxFlags) <- do + mprog <- needProgram verbosity gppProgram programDb + case mprog of + Just (p, _) -> do + let pInv = programInvocation p [] + let cxxProg = progInvokePath pInv + let cxxFlags = progInvokeArgs pInv + cxxProgShort <- getShortPathName cxxProg + return (Just cxxProgShort, Just cxxFlags) + Nothing -> return (Nothing, Nothing) + let configureFile' = toUnix configureFile -- autoconf is fussy about filenames, and has a set of forbidden -- characters that can't appear in the build directory, etc: @@ -159,9 +171,7 @@ ) ] let extraPath = fromNubList $ configProgramPathExtra cfg - let cflagsEnv = - maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) $ - lookup "CFLAGS" env + let mkFlagsEnv fs var = maybe (unwords fs) (++ (" " ++ unwords fs)) (lookup var env) spSep = [FilePath.searchPathSeparator] pathEnv = maybe @@ -169,11 +179,17 @@ ((intercalate spSep extraPath ++ spSep) ++) $ lookup "PATH" env overEnv = - ("CFLAGS", Just cflagsEnv) - : [("PATH", Just pathEnv) | not (null extraPath)] + ("CFLAGS", Just (mkFlagsEnv ccFlags "CFLAGS")) + : [("CXXFLAGS", Just (mkFlagsEnv cxxFlags "CXXFLAGS")) | Just cxxFlags <- [mcxxFlags]] + ++ [("PATH", Just pathEnv) | not (null extraPath)] ++ cabalFlagEnv maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)] - args' = configureFile' : args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag + args' = + configureFile' + : args + ++ ["CC=" ++ ccProgShort] + ++ ["CXX=" ++ cxxProgShort | Just cxxProgShort <- [mcxxProgShort]] + ++ maybeHostFlag shProg = simpleProgram "sh" progDb <- prependProgramSearchPath verbosity extraPath [] emptyProgramDb shConfiguredProg <- diff --git a/src/Distribution/Simple/Errors.hs b/src/Distribution/Simple/Errors.hs --- a/src/Distribution/Simple/Errors.hs +++ b/src/Distribution/Simple/Errors.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} - ----------------------------------------------------------------------------- -- Module : Distribution.Simple.Errors @@ -31,6 +29,7 @@ import Distribution.Simple.PreProcess.Types (Suffix) import Distribution.Simple.SetupHooks.Errors import Distribution.System (OS) +import Distribution.Types.MissingDependency (MissingDependency) import Distribution.Types.VersionRange.Internal () import Distribution.Version import Text.PrettyPrint @@ -79,8 +78,6 @@ | NoSupportBuildingTestSuite TestType | NoSupportBuildingBenchMark BenchmarkType | BuildingNotSupportedWithCompiler - | ProvideHaskellSuiteTool String - | CannotDetermineCompilerVersion | PkgDumpFailed | FailedToParseOutput | CantFindSourceModule ModuleName @@ -126,7 +123,7 @@ | CantFindForeignLibraries [String] | ExpectedAbsoluteDirectory FilePath | FlagsNotSpecified [FlagName] - | EncounteredMissingDependency [Dependency] + | EncounteredMissingDependency [MissingDependency] | CompilerDoesn'tSupportThinning | CompilerDoesn'tSupportReexports | CompilerDoesn'tSupportBackpack @@ -172,6 +169,7 @@ | UnknownVersionDb String VersionRange FilePath | MissingCoveredInstalledLibrary UnitId | SetupHooksException SetupHooksException + | MultiReplDoesNotSupportComplexReexportedModules PackageName ComponentName deriving (Show) exceptionCode :: CabalException -> Int @@ -211,8 +209,8 @@ NoSupportBuildingTestSuite{} -> 4106 NoSupportBuildingBenchMark{} -> 5320 BuildingNotSupportedWithCompiler{} -> 7077 - ProvideHaskellSuiteTool{} -> 7509 - CannotDetermineCompilerVersion{} -> 4519 + -- Retired: ProvideHaskellSuiteTool{} -> 7509 + -- Retired: CannotDetermineCompilerVersion{} -> 4519 PkgDumpFailed{} -> 2291 FailedToParseOutput{} -> 5500 CantFindSourceModule{} -> 8870 @@ -305,6 +303,7 @@ MissingCoveredInstalledLibrary{} -> 9341 SetupHooksException err -> setupHooksExceptionCode err + MultiReplDoesNotSupportComplexReexportedModules{} -> 9355 versionRequirement :: VersionRange -> String versionRequirement range @@ -365,8 +364,6 @@ NoSupportBuildingTestSuite test_type -> "No support for building test suite type " ++ show test_type NoSupportBuildingBenchMark benchMarkType -> "No support for building benchmark type " ++ show benchMarkType BuildingNotSupportedWithCompiler -> "Building is not supported with this compiler." - ProvideHaskellSuiteTool msg -> show msg - CannotDetermineCompilerVersion -> "haskell-suite: couldn't determine compiler version" PkgDumpFailed -> "pkg dump failed" FailedToParseOutput -> "failed to parse output of 'pkg dump'" CantFindSourceModule moduleName -> "can't find source for module " ++ prettyShow moduleName @@ -552,7 +549,7 @@ . nest 4 . sep . punctuate comma - . map (pretty . simplifyDependency) + . map pretty $ missing ) CompilerDoesn'tSupportThinning -> @@ -800,3 +797,10 @@ ++ "' in package database stack." SetupHooksException err -> setupHooksExceptionMessage err + MultiReplDoesNotSupportComplexReexportedModules pname cname -> + "When attempting start the repl for " + ++ showComponentName cname + ++ " from package " + ++ prettyShow pname + ++ " a module renaming was found.\n" + ++ "Multi-repl does not work with complicated reexported-modules until GHC-9.12." diff --git a/src/Distribution/Simple/Flag.hs b/src/Distribution/Simple/Flag.hs --- a/src/Distribution/Simple/Flag.hs +++ b/src/Distribution/Simple/Flag.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- @@ -20,7 +18,9 @@ -- -- Split off from "Distribution.Simple.Setup" to break import cycles. module Distribution.Simple.Flag - ( Flag (..) + ( Flag + , pattern Flag + , pattern NoFlag , allFlags , toFlag , fromFlag @@ -33,6 +33,7 @@ , BooleanFlag (..) ) where +import Data.Monoid (Last (..)) import Distribution.Compat.Prelude hiding (get) import Distribution.Compat.Stack import Prelude () @@ -62,43 +63,15 @@ -- 'NoFlag' and later flags override earlier ones. -- -- Isomorphic to 'Maybe' a. -data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Foldable, Traversable) - -instance Binary a => Binary (Flag a) -instance Structured a => Structured (Flag a) - -instance Functor Flag where - fmap f (Flag x) = Flag (f x) - fmap _ NoFlag = NoFlag - -instance Applicative Flag where - (Flag x) <*> y = x <$> y - NoFlag <*> _ = NoFlag - pure = Flag - -instance Monoid (Flag a) where - mempty = NoFlag - mappend = (<>) +type Flag = Last -instance Semigroup (Flag a) where - _ <> f@(Flag _) = f - f <> NoFlag = f +pattern Flag :: a -> Last a +pattern Flag a = Last (Just a) -instance Bounded a => Bounded (Flag a) where - minBound = toFlag minBound - maxBound = toFlag maxBound +pattern NoFlag :: Last a +pattern NoFlag = Last Nothing -instance Enum a => Enum (Flag a) where - fromEnum = fromEnum . fromFlag - toEnum = toFlag . toEnum - enumFrom (Flag a) = map toFlag . enumFrom $ a - enumFrom _ = [] - enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b - enumFromThen _ _ = [] - enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b - enumFromTo _ _ = [] - enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c - enumFromThenTo _ _ _ = [] +{-# COMPLETE Flag, NoFlag #-} -- | Wraps a value in 'Flag'. toFlag :: a -> Flag a @@ -111,26 +84,22 @@ -- | Extracts a value from a 'Flag', and returns the default value on 'NoFlag'. fromFlagOrDefault :: a -> Flag a -> a -fromFlagOrDefault _ (Flag x) = x -fromFlagOrDefault def NoFlag = def +fromFlagOrDefault def = fromMaybe def . getLast -- | Converts a 'Flag' value to a 'Maybe' value. flagToMaybe :: Flag a -> Maybe a -flagToMaybe (Flag x) = Just x -flagToMaybe NoFlag = Nothing +flagToMaybe = getLast -- | Pushes a function through a 'Flag' value, and returns a default -- if the 'Flag' value is 'NoFlag'. -- -- @since 3.4.0.0 flagElim :: b -> (a -> b) -> Flag a -> b -flagElim n _ NoFlag = n -flagElim _ f (Flag x) = f x +flagElim n f = maybe n f . getLast -- | Converts a 'Flag' value to a list. flagToList :: Flag a -> [a] -flagToList (Flag x) = [x] -flagToList NoFlag = [] +flagToList = maybeToList . getLast -- | Returns 'True' only if every 'Flag' 'Bool' value is Flag True, else 'False'. allFlags :: [Flag Bool] -> Flag Bool @@ -141,8 +110,7 @@ -- | Converts a 'Maybe' value to a 'Flag' value. maybeToFlag :: Maybe a -> Flag a -maybeToFlag Nothing = NoFlag -maybeToFlag (Just x) = Flag x +maybeToFlag = Last -- | Merge the elements of a list 'Flag' with another list 'Flag'. mergeListFlag :: Flag [a] -> Flag [a] -> Flag [a] diff --git a/src/Distribution/Simple/GHC.hs b/src/Distribution/Simple/GHC.hs --- a/src/Distribution/Simple/GHC.hs +++ b/src/Distribution/Simple/GHC.hs @@ -5,7 +5,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -42,6 +41,8 @@ module Distribution.Simple.GHC ( getGhcInfo , configure + , configureCompiler + , compilerProgramDb , getInstalledPackages , getInstalledPackagesMonitorFiles , getPackageDBContents @@ -86,8 +87,8 @@ import Control.Arrow ((***)) import Control.Monad (forM_) -import Data.List (stripPrefix) import qualified Data.Map as Map +import Data.Maybe (fromJust) import Distribution.CabalSpecVersion import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo @@ -154,75 +155,56 @@ -- ----------------------------------------------------------------------------- -- Configuring +-- | Configure GHC, and then auxiliary programs such as @ghc-pkg@, @haddock@ +-- as well as toolchain programs such as @ar@, @ld. configure :: Verbosity -> Maybe FilePath + -- ^ user-specified @ghc@ path (optional) -> Maybe FilePath + -- ^ user-specified @ghc-pkg@ path (optional) -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) configure verbosity hcPath hcPkgPath conf0 = do + (comp, compPlatform, progdb1) <- configureCompiler verbosity hcPath conf0 + compProgDb <- compilerProgramDb verbosity comp progdb1 hcPkgPath + return (comp, compPlatform, compProgDb) + +-- | Configure GHC. +configureCompiler + :: Verbosity + -> Maybe FilePath + -- ^ user-specified @ghc@ path (optional) + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configureCompiler verbosity hcPath conf0 = do (ghcProg, ghcVersion, progdb1) <- requireProgramVersion verbosity ghcProgram (orLaterVersion (mkVersion [7, 0, 1])) (userMaybeSpecifyPath "ghc" hcPath conf0) - let implInfo = ghcVersionImplInfo ghcVersion - -- Cabal currently supports ghc >= 7.0.1 && < 9.14 - -- ... and the following odd development version - unless (ghcVersion < mkVersion [9, 14]) $ + -- Cabal currently supports GHC less than `maxGhcVersion` + let maxGhcVersion = mkVersion [9, 16] + unless (ghcVersion < maxGhcVersion) $ warn verbosity $ "Unknown/unsupported 'ghc' version detected " ++ "(Cabal " ++ prettyShow cabalVersion - ++ " supports 'ghc' version < 9.14): " + ++ " supports 'ghc' version < " + ++ prettyShow maxGhcVersion + ++ "): " ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion - -- This is slightly tricky, we have to configure ghc first, then we use the - -- location of ghc to help find ghc-pkg in the case that the user did not - -- specify the location of ghc-pkg directly: - (ghcPkgProg, ghcPkgVersion, progdb2) <- - requireProgramVersion - verbosity - ghcPkgProgram - { programFindLocation = guessGhcPkgFromGhcPath ghcProg - } - anyVersion - (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1) - - when (ghcVersion /= ghcPkgVersion) $ - dieWithException verbosity $ - VersionMismatchGHC (programPath ghcProg) ghcVersion (programPath ghcPkgProg) ghcPkgVersion - -- Likewise we try to find the matching hsc2hs and haddock programs. - let hsc2hsProgram' = - hsc2hsProgram - { programFindLocation = guessHsc2hsFromGhcPath ghcProg - } - haddockProgram' = - haddockProgram - { programFindLocation = guessHaddockFromGhcPath ghcProg - } - hpcProgram' = - hpcProgram - { programFindLocation = guessHpcFromGhcPath ghcProg - } - runghcProgram' = - runghcProgram - { programFindLocation = guessRunghcFromGhcPath ghcProg - } - progdb3 = - addKnownProgram haddockProgram' $ - addKnownProgram hsc2hsProgram' $ - addKnownProgram hpcProgram' $ - addKnownProgram runghcProgram' progdb2 - + let implInfo = ghcVersionImplInfo ghcVersion languages <- Internal.getLanguages verbosity implInfo ghcProg extensions0 <- Internal.getExtensions verbosity implInfo ghcProg ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg + let ghcInfoMap = Map.fromList ghcInfo filterJS = if ghcVersion < mkVersion [9, 8] then filterExt JavaScriptFFI else id extensions = @@ -247,8 +229,20 @@ compilerId :: CompilerId compilerId = CompilerId GHC ghcVersion + -- The @AbiTag@ is the @Project Unit Id@ but with redundant information from the compiler version removed. + -- For development versions of the compiler these look like: + -- @Project Unit Id@: "ghc-9.13-inplace" + -- @compilerId@: "ghc-9.13.20250413" + -- So, we need to be careful to only strip the /common/ prefix. + -- In this example, @AbiTag@ is "inplace". compilerAbiTag :: AbiTag - compilerAbiTag = maybe NoAbiTag AbiTag (Map.lookup "Project Unit Id" ghcInfoMap >>= stripPrefix (prettyShow compilerId <> "-")) + compilerAbiTag = + maybe + NoAbiTag + AbiTag + ( dropWhile (== '-') . stripCommonPrefix (prettyShow compilerId) + <$> Map.lookup "Project Unit Id" ghcInfoMap + ) let comp = Compiler @@ -260,10 +254,74 @@ , compilerProperties = ghcInfoMap } compPlatform = Internal.targetPlatform ghcInfo - -- configure gcc and ld - progdb4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap progdb3 - return (comp, compPlatform, progdb4) + return (comp, compPlatform, progdb1) +-- | Given a configured @ghc@ program, configure auxiliary programs such +-- as @ghc-pkg@ or @haddock@, as well as toolchain programs such as @ar@, @ld@, +-- based on: +-- +-- - the location of the @ghc@ executable, +-- - toolchain information in the GHC settings file. +compilerProgramDb + :: Verbosity + -> Compiler + -> ProgramDb + -> Maybe FilePath + -- ^ user-specified @ghc-pkg@ path (optional) + -> IO ProgramDb +compilerProgramDb verbosity comp progdb1 hcPkgPath = do + let + ghcProg = fromJust $ lookupProgram ghcProgram progdb1 + ghcVersion = compilerVersion comp + + -- This is slightly tricky, we have to configure ghc first, then we use the + -- location of ghc to help find ghc-pkg in the case that the user did not + -- specify the location of ghc-pkg directly: + (ghcPkgProg, ghcPkgVersion, progdb2) <- + requireProgramVersion + verbosity + ghcPkgProgram + { programFindLocation = guessGhcPkgFromGhcPath ghcProg + } + anyVersion + (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1) + + when (ghcVersion /= ghcPkgVersion) $ + dieWithException verbosity $ + VersionMismatchGHC (programPath ghcProg) ghcVersion (programPath ghcPkgProg) ghcPkgVersion + -- Likewise we try to find the matching hsc2hs and haddock programs. + let hsc2hsProgram' = + hsc2hsProgram + { programFindLocation = guessHsc2hsFromGhcPath ghcProg + } + haddockProgram' = + haddockProgram + { programFindLocation = guessHaddockFromGhcPath ghcProg + } + hpcProgram' = + hpcProgram + { programFindLocation = guessHpcFromGhcPath ghcProg + } + runghcProgram' = + runghcProgram + { programFindLocation = guessRunghcFromGhcPath ghcProg + } + progdb3 = + addKnownProgram haddockProgram' $ + addKnownProgram hsc2hsProgram' $ + addKnownProgram hpcProgram' $ + addKnownProgram runghcProgram' progdb2 + + -- configure gcc, ld, ar etc... based on the paths stored + -- in the GHC settings file + progdb4 = + Internal.configureToolchain + (ghcVersionImplInfo ghcVersion) + ghcProg + (compilerProperties comp) + progdb3 + return progdb4 + -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find -- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking -- for a versioned or unversioned ghc-pkg in the same dir, that is: @@ -632,6 +690,8 @@ } checkPackageDbStack verbosity comp packageDBs (ghcProg, _) <- requireProgram verbosity ghcProgram progdb + -- This doesn't pass source file arguments to GHC, so we don't have to worry + -- about using a response file here. runGHC verbosity ghcProg comp platform Nothing replOpts -- ----------------------------------------------------------------------------- diff --git a/src/Distribution/Simple/GHC/Build/ExtraSources.hs b/src/Distribution/Simple/GHC/Build/ExtraSources.hs --- a/src/Distribution/Simple/GHC/Build/ExtraSources.hs +++ b/src/Distribution/Simple/GHC/Build/ExtraSources.hs @@ -23,6 +23,7 @@ import Distribution.Simple.GHC.Build.Utils import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program.Types +import Distribution.Simple.Setup.Common (commonSetupTempFileOptions) import Distribution.System (Arch (JavaScript), Platform (..)) import Distribution.Types.ComponentLocalBuildInfo import Distribution.Utils.Path @@ -176,7 +177,17 @@ sources = viewSources (targetComponent targetInfo) comp = compiler lbi platform = hostPlatform lbi - runGhcProg = runGHC verbosity ghcProg comp platform + tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags buildingWhat + runGhcProg = + runGHCWithResponseFile + "ghc.rsp" + Nothing + tempFileOptions + verbosity + ghcProg + comp + platform + mbWorkDir buildAction :: SymbolicPath Pkg File -> IO () buildAction sourceFile = do @@ -219,7 +230,7 @@ compileIfNeeded :: GhcOptions -> IO () compileIfNeeded opts = do needsRecomp <- checkNeedsRecompilation mbWorkDir sourceFile opts - when needsRecomp $ runGhcProg mbWorkDir opts + when needsRecomp $ runGhcProg opts createDirectoryIfMissingVerbose verbosity True (i odir) case targetComponent targetInfo of @@ -251,6 +262,7 @@ DynWay -> compileIfNeeded sharedSrcOpts ProfWay -> compileIfNeeded profSrcOpts ProfDynWay -> compileIfNeeded profSharedSrcOpts + -- build any sources if (null sources || componentIsIndefinite clbi) then return mempty diff --git a/src/Distribution/Simple/GHC/Build/Link.hs b/src/Distribution/Simple/GHC/Build/Link.hs --- a/src/Distribution/Simple/GHC/Build/Link.hs +++ b/src/Distribution/Simple/GHC/Build/Link.hs @@ -1,16 +1,17 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} module Distribution.Simple.GHC.Build.Link where import Distribution.Compat.Prelude import Prelude () +import Control.Monad import Control.Monad.IO.Class import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.Set as Set +import Distribution.Backpack import Distribution.Compat.Binary (encode) import Distribution.Compat.ResponseFile import Distribution.InstalledPackageInfo (InstalledPackageInfo) @@ -24,6 +25,7 @@ import Distribution.Simple.Build.Inputs import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler +import Distribution.Simple.Errors import Distribution.Simple.GHC.Build.Modules import Distribution.Simple.GHC.Build.Utils (exeTargetName, flibBuildName, flibTargetName, withDynFLib) import Distribution.Simple.GHC.ImplInfo @@ -98,6 +100,7 @@ clbi = buildCLBI pbci isIndef = componentIsIndefinite clbi mbWorkDir = mbWorkDirLBI lbi + tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags what -- See Note [Symbolic paths] in Distribution.Utils.Path i = interpretSymbolicPathLBI lbi @@ -188,10 +191,25 @@ -- exports. when (case component of CLib lib -> null (allLibModules lib clbi); _ -> False) $ warn verbosity "No exposed modules" - runReplOrWriteFlags ghcProg lbi replFlags replOpts_final (pkgName (PD.package pkg_descr)) target + runReplOrWriteFlags + ghcProg + lbi + replFlags + replOpts_final + (pkgName (PD.package pkg_descr)) + target _otherwise -> let - runGhcProg = runGHC verbosity ghcProg comp platform mbWorkDir + runGhcProg = + runGHCWithResponseFile + "ghc.rsp" + Nothing + tempFileOptions + verbosity + ghcProg + comp + platform + mbWorkDir platform = hostPlatform lbi comp = compiler lbi get_rpaths ways = @@ -725,31 +743,54 @@ runReplOrWriteFlags ghcProg lbi rflags ghcOpts pkg_name target = let bi = componentBuildInfo $ targetComponent target clbi = targetCLBI target + cname = componentName (targetComponent target) comp = compiler lbi platform = hostPlatform lbi common = configCommonFlags $ configFlags lbi mbWorkDir = mbWorkDirLBI lbi verbosity = fromFlag $ setupVerbosity common + tempFileOptions = commonSetupTempFileOptions common in case replOptionsFlagOutput (replReplOptions rflags) of - NoFlag -> runGHC verbosity ghcProg comp platform mbWorkDir ghcOpts + NoFlag -> do + -- If a specific GHC implementation is specified, use it + runReplProgram + (flagToMaybe $ replWithRepl (replReplOptions rflags)) + tempFileOptions + verbosity + ghcProg + comp + platform + mbWorkDir + ghcOpts Flag out_dir -> do let uid = componentUnitId clbi this_unit = prettyShow uid + getOpenModName (OpenModule _ mn) = Just mn + getOpenModName (OpenModuleVar{}) = Nothing reexported_modules = - [ mn | LibComponentLocalBuildInfo{componentExposedModules = exposed_mods} <- [clbi], IPI.ExposedModule mn (Just{}) <- exposed_mods + [ (from_mn, to_mn) | LibComponentLocalBuildInfo{componentExposedModules = exposed_mods} <- [clbi], IPI.ExposedModule to_mn (Just m) <- exposed_mods, Just from_mn <- [getOpenModName m] ] + renderReexportedModule (from_mn, to_mn) + | reexportedAsSupported comp = + pure $ prettyShow from_mn ++ " as " ++ prettyShow to_mn + | otherwise = + if from_mn == to_mn + then pure $ prettyShow to_mn + else dieWithException verbosity (MultiReplDoesNotSupportComplexReexportedModules pkg_name cname) hidden_modules = otherModules bi - extra_opts = - concat $ - [ ["-this-package-name", prettyShow pkg_name] - , case mbWorkDir of - Nothing -> [] - Just wd -> ["-working-dir", getSymbolicPath wd] - ] - ++ [ ["-reexported-module", prettyShow m] | m <- reexported_modules - ] - ++ [ ["-hidden-module", prettyShow m] | m <- hidden_modules - ] + render_extra_opts = do + rexp_mods <- mapM renderReexportedModule reexported_modules + pure $ + concat $ + [ ["-this-package-name", prettyShow pkg_name] + , case mbWorkDir of + Nothing -> [] + Just wd -> ["-working-dir", getSymbolicPath wd] + ] + ++ [ ["-reexported-module", m] | m <- rexp_mods + ] + ++ [ ["-hidden-module", prettyShow m] | m <- hidden_modules + ] -- Create "paths" subdirectory if it doesn't exist. This is where we write -- information about how the PATH was augmented. createDirectoryIfMissing False (out_dir "paths") @@ -757,6 +798,7 @@ writeFileAtomic (out_dir "paths" this_unit) (encode ghcProg) -- Write out options for this component into a file ready for loading into -- the multi-repl + extra_opts <- render_extra_opts writeFileAtomic (out_dir this_unit) $ BS.pack $ escapeArgs $ diff --git a/src/Distribution/Simple/GHC/Build/Modules.hs b/src/Distribution/Simple/GHC/Build/Modules.hs --- a/src/Distribution/Simple/GHC/Build/Modules.hs +++ b/src/Distribution/Simple/GHC/Build/Modules.hs @@ -1,9 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} module Distribution.Simple.GHC.Build.Modules ( buildHaskellModules @@ -137,20 +135,29 @@ | BuildRepl{} <- what = True | otherwise = False - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? FIX: what about exeName.hi-boot? + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? FIX: what about exeName.hi-boot? - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = if isLib then libCoverage lbi else exeCoverage lbi - hpcdir way - | forRepl = mempty -- HPC is not supported in ghci - | isCoverageEnabled = Flag $ Hpc.mixDir (coerceSymbolicPath $ coerceSymbolicPath buildTargetDir extraCompilationArtifacts) way - | otherwise = mempty + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + isCoverageEnabled = if isLib then libCoverage lbi else exeCoverage lbi + hpcdir way + | forRepl = mempty -- HPC is not supported in ghci + | isCoverageEnabled = Flag $ Hpc.mixDir (coerceSymbolicPath $ coerceSymbolicPath buildTargetDir extraCompilationArtifacts) way + | otherwise = mempty - let mbWorkDir = mbWorkDirLBI lbi - runGhcProg = runGHC verbosity ghcProg comp platform mbWorkDir + tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags what + runGhcProg = + runGHCWithResponseFile + "ghc.rsp" + Nothing + tempFileOptions + verbosity + ghcProg + comp + platform + mbWorkDir platform = hostPlatform lbi (hsMains, scriptMains) = diff --git a/src/Distribution/Simple/GHC/EnvironmentParser.hs b/src/Distribution/Simple/GHC/EnvironmentParser.hs --- a/src/Distribution/Simple/GHC/EnvironmentParser.hs +++ b/src/Distribution/Simple/GHC/EnvironmentParser.hs @@ -1,8 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} module Distribution.Simple.GHC.EnvironmentParser (parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc (..)) where diff --git a/src/Distribution/Simple/GHC/Internal.hs b/src/Distribution/Simple/GHC/Internal.hs --- a/src/Distribution/Simple/GHC/Internal.hs +++ b/src/Distribution/Simple/GHC/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -67,7 +68,7 @@ import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.Errors -import Distribution.Simple.Flag (Flag (NoFlag), maybeToFlag, toFlag) +import Distribution.Simple.Flag (Flag, maybeToFlag, toFlag, pattern NoFlag) import Distribution.Simple.GHC.ImplInfo import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program @@ -85,7 +86,7 @@ import Distribution.Verbosity import Distribution.Version (Version) import Language.Haskell.Extension -import System.Directory (getDirectoryContents, getTemporaryDirectory) +import System.Directory (getDirectoryContents) import System.Environment (getEnv) import System.FilePath ( takeDirectory @@ -111,6 +112,11 @@ , programPostConf = configureGcc } . addKnownProgram + gppProgram + { programFindLocation = findProg gppProgramName extraGppPath + , programPostConf = configureGpp + } + . addKnownProgram ldProgram { programFindLocation = findProg ldProgramName extraLdPath , programPostConf = \v cp -> @@ -137,6 +143,7 @@ maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName) gccProgramName = maybeName gccProgram mbGccLocation + gppProgramName = maybeName gppProgram mbGppLocation ldProgramName = maybeName ldProgram mbLdLocation arProgramName = maybeName arProgram mbArLocation stripProgramName = maybeName stripProgram mbStripLocation @@ -149,18 +156,20 @@ mbDir = maybeToList . fmap takeDirectory $ mbPath extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir + extraGppPath = mkExtraPath mbGppLocation windowsExtraGppDir extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir extraArPath = mkExtraPath mbArLocation windowsExtraArDir extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir -- on Windows finding and configuring ghc's gcc & binutils is a bit special ( windowsExtraGccDir + , windowsExtraGppDir , windowsExtraLdDir , windowsExtraArDir , windowsExtraStripDir ) = let b = mingwBinDir binPrefix - in (b, b, b, b) + in (b, b, b, b, b) findProg :: String @@ -176,11 +185,13 @@ -- Read tool locations from the 'ghc --info' output. Useful when -- cross-compiling. mbGccLocation = Map.lookup "C compiler command" ghcInfo + mbGppLocation = Map.lookup "C++ compiler command" ghcInfo mbLdLocation = Map.lookup "ld command" ghcInfo mbArLocation = Map.lookup "ar command" ghcInfo mbStripLocation = Map.lookup "strip command" ghcInfo ccFlags = getFlags "C compiler flags" + cxxFlags = getFlags "C++ compiler flags" -- GHC 7.8 renamed "Gcc Linker flags" to "C compiler link flags" -- and "Ld Linker flags" to "ld flags" (GHC #4862). gccLinkerFlags = getFlags "Gcc Linker flags" ++ getFlags "C compiler link flags" @@ -210,6 +221,15 @@ ++ gccLinkerFlags } + configureGpp :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureGpp _v gppProg = do + return + gppProg + { programDefaultArgs = + programDefaultArgs gppProg + ++ cxxFlags + } + configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureLd v ldProg = do ldProg' <- configureLd' v ldProg @@ -221,9 +241,8 @@ -- we need to find out if ld supports the -x flag configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureLd' verbosity ldProg = do - tempDir <- getTemporaryDirectory - ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> - withTempFile tempDir ".o" $ \testofile testohnd -> do + ldx <- withTempFile ".c" $ \testcfile testchnd -> + withTempFile ".o" $ \testofile testohnd -> do hPutStrLn testchnd "int foo() { return 0; }" hClose testchnd hClose testohnd @@ -236,7 +255,7 @@ , "-o" , testofile ] - withTempFile tempDir ".o" $ \testofile' testohnd' -> + withTempFile ".o" $ \testofile' testohnd' -> do hClose testohnd' _ <- @@ -468,6 +487,7 @@ ) ++ asmOptions bi , ghcOptObjDir = toFlag odir + , ghcOptExtra = hcOptions GHC bi } componentJsGhcOptions @@ -485,11 +505,13 @@ ghcOptVerbosity = toFlag (min verbosity normal) , ghcOptMode = toFlag GhcModeCompile , ghcOptInputFiles = toNubListR [filename] + , ghcOptJSppOptions = jsppOptions bi , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptHideAllPackages = toFlag True , ghcOptPackageDBs = withPackageDB lbi , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi , ghcOptObjDir = toFlag odir + , ghcOptExtra = hcOptions GHC bi } componentGhcOptions @@ -547,6 +569,7 @@ ++ [autogenPackageModulesDir lbi] , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptCppOptions = cppOptions bi + , ghcOptJSppOptions = jsppOptions bi , ghcOptCppIncludes = toNubListR $ [coerceSymbolicPath (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] @@ -603,7 +626,7 @@ , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) , ghcOptDebugInfo = toFlag (withDebugInfo lbi) - , ghcOptExtra = cmmOptions bi + , ghcOptExtra = hcOptions GHC bi <> cmmOptions bi , ghcOptObjDir = toFlag odir } diff --git a/src/Distribution/Simple/GHCJS.hs b/src/Distribution/Simple/GHCJS.hs --- a/src/Distribution/Simple/GHCJS.hs +++ b/src/Distribution/Simple/GHCJS.hs @@ -1,11 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} module Distribution.Simple.GHCJS ( getGhcInfo , configure + , configureCompiler + , compilerProgramDb , getInstalledPackages , getInstalledPackagesMonitorFiles , getPackageDBContents @@ -88,6 +89,7 @@ import Control.Monad (msum) import Data.Char (isLower) import qualified Data.Map as Map +import Data.Maybe (fromJust) import System.Directory ( canonicalizePath , createDirectoryIfMissing @@ -107,13 +109,29 @@ -- ----------------------------------------------------------------------------- -- Configuring +-- | Configure GHCJS, and then auxiliary programs such as @ghc-pkg@, @haddock@ +-- as well as toolchain programs such as @ar@, @ld. configure :: Verbosity -> Maybe FilePath + -- ^ user-specified @ghcjs@ path (optional) -> Maybe FilePath + -- ^ user-specified @ghcjs-pkg@ path (optional) -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) configure verbosity hcPath hcPkgPath conf0 = do + (comp, compPlatform, progdb1) <- configureCompiler verbosity hcPath conf0 + compProgDb <- compilerProgramDb verbosity comp progdb1 hcPkgPath + return (comp, compPlatform, compProgDb) + +-- | Configure GHCJS. +configureCompiler + :: Verbosity + -> Maybe FilePath + -- ^ user-specified @ghc@ path (optional) + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configureCompiler verbosity hcPath conf0 = do (ghcjsProg, ghcjsVersion, progdb1) <- requireProgramVersion verbosity @@ -134,6 +152,43 @@ let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion + languages <- Internal.getLanguages verbosity implInfo ghcjsProg + extensions <- Internal.getExtensions verbosity implInfo ghcjsProg + + ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg + let ghcInfoMap = Map.fromList ghcjsInfo + + let comp = + Compiler + { compilerId = CompilerId GHCJS ghcjsVersion + , compilerAbiTag = + AbiTag $ + "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion) + , compilerCompat = [CompilerId GHC ghcjsGhcVersion] + , compilerLanguages = languages + , compilerExtensions = extensions + , compilerProperties = ghcInfoMap + } + compPlatform = Internal.targetPlatform ghcjsInfo + return (comp, compPlatform, progdb1) + +-- | Given a configured @ghcjs@ program, configure auxiliary programs such +-- as @ghcjs-pkg@ or @haddock@, based on the location of the @ghcjs@ executable. +compilerProgramDb + :: Verbosity + -> Compiler + -> ProgramDb + -> Maybe FilePath + -- ^ user-specified @ghc-pkg@ path (optional) + -> IO ProgramDb +compilerProgramDb verbosity comp progdb1 hcPkgPath = do + let + ghcjsProg = fromJust $ lookupProgram ghcjsProgram progdb1 + ghcjsVersion = compilerVersion comp + ghcjsGhcVersion = case compilerCompat comp of + [CompilerId GHC ghcjsGhcVer] -> ghcjsGhcVer + compat -> error $ "could not parse ghcjsGhcVersion:" ++ show compat + -- This is slightly tricky, we have to configure ghc first, then we use the -- location of ghc to help find ghc-pkg in the case that the user did not -- specify the location of ghc-pkg directly: @@ -188,25 +243,7 @@ addKnownProgram hpcProgram' $ {- addKnownProgram runghcProgram' -} progdb2 - languages <- Internal.getLanguages verbosity implInfo ghcjsProg - extensions <- Internal.getExtensions verbosity implInfo ghcjsProg - - ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg - let ghcInfoMap = Map.fromList ghcjsInfo - - let comp = - Compiler - { compilerId = CompilerId GHCJS ghcjsVersion - , compilerAbiTag = - AbiTag $ - "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion) - , compilerCompat = [CompilerId GHC ghcjsGhcVersion] - , compilerLanguages = languages - , compilerExtensions = extensions - , compilerProperties = ghcInfoMap - } - compPlatform = Internal.targetPlatform ghcjsInfo - return (comp, compPlatform, progdb3) + return progdb3 guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram diff --git a/src/Distribution/Simple/Glob.hs b/src/Distribution/Simple/Glob.hs --- a/src/Distribution/Simple/Glob.hs +++ b/src/Distribution/Simple/Glob.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} @@ -370,7 +369,6 @@ "Null dir passed to runDirFileGlob; interpreting it " ++ "as '.'. This is probably an internal error." let root = if null rawRoot then "." else rawRoot - debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'." -- This function might be called from the project root with dir as -- ".". Walking the tree starting there involves going into .git/ -- and dist-newstyle/, which is a lot of work for no reward, so @@ -379,7 +377,7 @@ -- the whole directory if *, and just the specific file if it's a -- literal. let - (prefixSegments, variablePattern) = splitConstantPrefix pat + (prefixSegments, pathOrVariablePattern) = splitConstantPrefix pat joinedPrefix = joinPath prefixSegments -- The glob matching function depends on whether we care about the cabal version or not @@ -431,17 +429,37 @@ concat <$> traverse (\subdir -> go globPath (dir subdir)) subdirs go GlobDirTrailing dir = return [GlobMatch dir] - directoryExists <- doesDirectoryExist (root joinedPrefix) - if directoryExists - then go variablePattern joinedPrefix - else return [GlobMissingDirectory joinedPrefix] + case pathOrVariablePattern of + Left filename -> do + let filepath = joinedPrefix filename + debug verbosity $ "Treating glob as filepath literal '" ++ filepath ++ "' in directory '" ++ root ++ "'." + directoryExists <- doesDirectoryExist (root filepath) + if directoryExists + then pure [GlobMatchesDirectory filepath] + else do + exist <- doesFileExist (root filepath) + pure $ + if exist + then [GlobMatch filepath] + else [] + Right variablePattern -> do + debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'." + directoryExists <- doesDirectoryExist (root joinedPrefix) + if directoryExists + then go variablePattern joinedPrefix + else return [GlobMissingDirectory joinedPrefix] where -- \| Extract the (possibly null) constant prefix from the pattern. -- This has the property that, if @(pref, final) = splitConstantPrefix pat@, -- then @pat === foldr GlobDir final pref@. - splitConstantPrefix :: Glob -> ([FilePath], Glob) - splitConstantPrefix = unfoldr' step + splitConstantPrefix :: Glob -> ([FilePath], Either FilePath Glob) + splitConstantPrefix = fmap literalize . unfoldr' step where + literalize (GlobFile [Literal filename]) = + Left filename + literalize glob = + Right glob + step (GlobDir [Literal seg] pat') = Right (seg, pat') step pat' = Left pat' diff --git a/src/Distribution/Simple/Glob/Internal.hs b/src/Distribution/Simple/Glob/Internal.hs --- a/src/Distribution/Simple/Glob/Internal.hs +++ b/src/Distribution/Simple/Glob/Internal.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- diff --git a/src/Distribution/Simple/Haddock.hs b/src/Distribution/Simple/Haddock.hs --- a/src/Distribution/Simple/Haddock.hs +++ b/src/Distribution/Simple/Haddock.hs @@ -5,7 +5,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -67,12 +66,9 @@ import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Program.ResponseFile import Distribution.Simple.Register -import Distribution.Simple.Setup.Common -import Distribution.Simple.Setup.Haddock -import Distribution.Simple.Setup.Hscolour +import Distribution.Simple.Setup import Distribution.Simple.SetupHooks.Internal ( BuildHooks (..) - , BuildingWhat (..) , noBuildHooks ) import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks @@ -265,6 +261,7 @@ mbWorkDir = flagToMaybe $ haddockWorkingDir flags comp = compiler lbi platform = hostPlatform lbi + config = configFlags lbi quickJmpFlag = haddockQuickJump flags' flags = case haddockTarget of @@ -282,9 +279,7 @@ flag f = fromFlag $ f flags tmpFileOpts = - defaultTempFileOptions - { optKeepTempFiles = flag haddockKeepTempFiles - } + commonSetupTempFileOptions $ configCommonFlags config htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags @@ -342,7 +337,7 @@ clbi = targetCLBI target bi = componentBuildInfo component -- Include any build-tool-depends on build tools internal to the current package. - progs' = addInternalBuildToolsFixed (Just curDir) pkg_descr lbi bi (withPrograms lbi) + progs' = addInternalBuildTools curDir pkg_descr lbi bi (withPrograms lbi) lbi' = lbi { withPrograms = progs' @@ -554,9 +549,11 @@ -> IO () createHaddockIndex verbosity programDb comp platform mbWorkDir flags = do let args = fromHaddockProjectFlags flags + tmpFileOpts = + commonSetupTempFileOptions $ haddockProjectCommonFlags $ flags (haddockProg, _version) <- getHaddockProg verbosity programDb comp args (Flag True) - runHaddock verbosity mbWorkDir defaultTempFileOptions comp platform haddockProg False args + runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg False args -- ------------------------------------------------------------------------------ -- Contributions to HaddockArgs (see also Doctest.hs for very similar code). @@ -621,6 +618,7 @@ , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags) , argLinkedSource = Flag True , argResourcesDir = haddockProjectResourcesDir flags + , argCssFile = haddockProjectCss flags } fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs @@ -1073,7 +1071,13 @@ let vanillaOpts = componentGhcOptions normal lbi bi clbi (buildDir lbi) i = interpretSymbolicPath mbWorkDir - copyDir ghcDir tmpDir = copyDirectoryRecursive verbosity (i $ fromFlag $ ghcDir vanillaOpts) (i tmpDir) + copyDir getGhcDir tmpDir = do + let ghcDir = i $ fromFlag $ getGhcDir vanillaOpts + ghcDirExists <- doesDirectoryExist ghcDir + -- Don't try to copy artifacts if they don't exist, e.g. if + -- we have not yet run the 'build' command. + when ghcDirExists $ + copyDirectoryRecursive verbosity ghcDir (i tmpDir) copyDir ghcOptObjDir tmpObjDir copyDir ghcOptHiDir tmpHiDir -- copyDir ghcOptStubDir tmpStubDir -- (see W.1 in Note [Hi Haddock Recompilation Avoidance]) @@ -1134,8 +1138,6 @@ withResponseFile verbosity tmpFileOpts - mbWorkDir - outputDir "haddock-response.txt" (if haddockSupportsUTF8 then Just utf8 else Nothing) renderedArgs @@ -1145,7 +1147,7 @@ (Flag pfile, _) -> withPrologueArgs ["--prologue=" ++ pfile] (_, Flag prologueText) -> - withTempFileEx tmpFileOpts mbWorkDir outputDir "haddock-prologue.txt" $ + withTempFileEx tmpFileOpts "haddock-prologue.txt" $ \prologueFileName h -> do when haddockSupportsUTF8 (hSetEncoding h utf8) hPutStrLn h prologueText @@ -1386,7 +1388,7 @@ let missing = [pkgid | Left pkgid <- interfaces] warning = - "The documentation for the following packages are not " + "The following packages have no Haddock documentation " ++ "installed. No links will be generated to these packages: " ++ intercalate ", " (map prettyShow missing) flags = rights interfaces diff --git a/src/Distribution/Simple/HaskellSuite.hs b/src/Distribution/Simple/HaskellSuite.hs deleted file mode 100644 --- a/src/Distribution/Simple/HaskellSuite.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Distribution.Simple.HaskellSuite where - -import Distribution.Compat.Prelude -import Prelude () - -import qualified Data.List.NonEmpty as NE - -import Distribution.InstalledPackageInfo hiding (includeDirs) -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Parsec (simpleParsec) -import Distribution.Pretty -import Distribution.Simple.BuildPaths -import Distribution.Simple.Compiler -import Distribution.Simple.Errors -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.Program -import Distribution.Simple.Program.Builtin -import Distribution.Simple.Utils -import Distribution.System (Platform) -import Distribution.Utils.Path -import Distribution.Verbosity -import Distribution.Version -import Language.Haskell.Extension - -configure - :: Verbosity - -> Maybe FilePath - -> Maybe FilePath - -> ProgramDb - -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity mbHcPath hcPkgPath progdb0 = do - -- We have no idea how a haskell-suite tool is named, so we require at - -- 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 (dieWithException verbosity $ ProvideHaskellSuiteTool msg) return mbHcPath - - when (isJust hcPkgPath) $ - warn verbosity "--with-hc-pkg option is ignored for haskell-suite" - - (comp, confdCompiler, progdb1) <- configureCompiler hcPath progdb0 - - -- Update our pkg tool. It uses the same executable as the compiler, but - -- all command start with "pkg" - (confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb1 - let progdb2 = - updateProgram - confdPkg - { programLocation = programLocation confdCompiler - , programDefaultArgs = ["pkg"] - } - progdb1 - - return (comp, Nothing, progdb2) - where - configureCompiler hcPath progdb0' = do - let - haskellSuiteProgram' = - haskellSuiteProgram - { programFindLocation = \v p -> findProgramOnSearchPath v p hcPath - } - - -- NB: cannot call requireProgram right away — it'd think that - -- the program is already configured and won't reconfigure it again. - -- Instead, call configureProgram directly first. - progdb1 <- configureProgram verbosity haskellSuiteProgram' progdb0' - (confdCompiler, progdb2) <- requireProgram verbosity haskellSuiteProgram' progdb1 - - extensions <- getExtensions verbosity confdCompiler - languages <- getLanguages verbosity confdCompiler - (compName, compVersion) <- - getCompilerVersion verbosity confdCompiler - - let - comp = - Compiler - { compilerId = CompilerId (HaskellSuite compName) compVersion - , compilerAbiTag = NoAbiTag - , compilerCompat = [] - , compilerLanguages = languages - , compilerExtensions = extensions - , compilerProperties = mempty - } - - return (comp, confdCompiler, progdb2) - -hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version) -hstoolVersion = findProgramVersion "--hspkg-version" id - -numericVersion :: Verbosity -> FilePath -> IO (Maybe Version) -numericVersion = findProgramVersion "--compiler-version" (fromMaybe "" . safeLast . words) - -getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version) -getCompilerVersion verbosity prog = do - output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"] - let - parts = words output - name = concat $ safeInit parts -- there shouldn't be any spaces in the name anyway - versionStr = fromMaybe "" $ safeLast parts - version <- - maybe - (dieWithException verbosity CannotDetermineCompilerVersion) - return - $ simpleParsec versionStr - return (name, version) - -getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe CompilerFlag)] -getExtensions verbosity prog = do - extStrs <- - lines - `fmap` rawSystemStdout verbosity (programPath prog) ["--supported-extensions"] - return - [(ext, Just $ "-X" ++ prettyShow ext) | Just ext <- map simpleParsec extStrs] - -getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, CompilerFlag)] -getLanguages verbosity prog = do - langStrs <- - lines - `fmap` rawSystemStdout verbosity (programPath prog) ["--supported-languages"] - return - [(ext, "-G" ++ prettyShow ext) | Just ext <- map simpleParsec langStrs] - --- Other compilers do some kind of a packagedb stack check here. Not sure --- if we need something like that as well. -getInstalledPackages - :: Verbosity - -- Not migrated to work with --working-dir but this is legacy dead code - -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) - -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity packagedbs progdb = - liftM (PackageIndex.fromList . concat) $ for packagedbs $ \packagedb -> - do - str <- - getDbProgramOutput - verbosity - haskellSuitePkgProgram - progdb - ["dump", packageDbOpt packagedb] - `catchExit` \_ -> dieWithException verbosity PkgDumpFailed - - case parsePackages str of - Right ok -> return ok - _ -> dieWithException verbosity FailedToParseOutput - where - parsePackages str = - case partitionEithers $ map (parseInstalledPackageInfo . toUTF8BS) (splitPkgs str) of - ([], ok) -> Right [pkg | (_, pkg) <- ok] - (msgss, _) -> Left (foldMap NE.toList msgss) - - splitPkgs :: String -> [String] - splitPkgs = map unlines . splitWith ("---" ==) . lines - where - splitWith :: (a -> Bool) -> [a] -> [[a]] - splitWith p xs = - ys : case zs of - [] -> [] - _ : ws -> splitWith p ws - where - (ys, zs) = break p xs - -buildLib - :: Verbosity - -> PackageDescription - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO () -buildLib verbosity pkg_descr lbi lib clbi = do - -- In future, there should be a mechanism for the compiler to request any - -- number of the above parameters (or their parts) — in particular, - -- pieces of PackageDescription. - -- - -- For now, we only pass those that we know are used. - - let odir = buildDir lbi - bi = libBuildInfo lib - srcDirs = map u (hsSourceDirs bi) ++ [u odir] - dbStack = withPackageDB lbi - language = fromMaybe Haskell98 (defaultLanguage bi) - progdb = withPrograms lbi - pkgid = packageId pkg_descr - u = interpretSymbolicPathCWD -- See Note [Symbolic paths] in Distribution.Utils.Path - runDbProgramCwd verbosity (mbWorkDirLBI lbi) haskellSuiteProgram progdb $ - ["compile", "--build-dir", u odir] - ++ concat [["-i", d] | d <- srcDirs] - ++ concat - [ ["-I", d] - | d <- - [ u $ autogenComponentModulesDir lbi clbi - , u $ autogenPackageModulesDir lbi - , u odir - ] - ++ map u (includeDirs bi) - ] - ++ [packageDbOpt pkgDb | pkgDb <- dbStack] - ++ ["--package-name", prettyShow pkgid] - ++ concat - [ ["--package-id", prettyShow ipkgid] - | (ipkgid, _) <- componentPackageDeps clbi - ] - ++ ["-G", prettyShow language] - ++ concat [["-X", prettyShow ex] | ex <- usedExtensions bi] - ++ cppOptions (libBuildInfo lib) - ++ [prettyShow modu | modu <- allLibModules lib clbi] - -installLib - :: Verbosity - -> LocalBuildInfo - -> FilePath - -- ^ install location - -> FilePath - -- ^ install location for dynamic libraries - -> FilePath - -- ^ Build location - -> PackageDescription - -> Library - -> ComponentLocalBuildInfo - -> IO () -installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib clbi = do - let progdb = withPrograms lbi - wdir = mbWorkDirLBI lbi - runDbProgramCwd verbosity wdir haskellSuitePkgProgram progdb $ - [ "install-library" - , "--build-dir" - , builtDir - , "--target-dir" - , targetDir - , "--dynlib-target-dir" - , dynlibTargetDir - , "--package-id" - , prettyShow $ packageId pkg - ] - ++ map prettyShow (allLibModules lib clbi) - -registerPackage - :: Verbosity - -> ProgramDb - -> PackageDBStackS from - -> InstalledPackageInfo - -> IO () -registerPackage verbosity progdb packageDbs installedPkgInfo = do - (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb - - runProgramInvocation verbosity $ - ( programInvocation - hspkg - ["update", packageDbOpt $ registrationPackageDB packageDbs] - ) - { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo - } - -initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO () -initPackageDB verbosity progdb dbPath = - runDbProgram - verbosity - haskellSuitePkgProgram - progdb - ["init", dbPath] - -packageDbOpt :: PackageDBX (SymbolicPath from (Dir PkgDB)) -> String -packageDbOpt GlobalPackageDB = "--global" -packageDbOpt UserPackageDB = "--user" -packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ interpretSymbolicPathCWD db diff --git a/src/Distribution/Simple/Install.hs b/src/Distribution/Simple/Install.hs --- a/src/Distribution/Simple/Install.hs +++ b/src/Distribution/Simple/Install.hs @@ -74,7 +74,6 @@ import Distribution.Simple.Errors import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.HaskellSuite as HaskellSuite import Distribution.Simple.Setup.Common import qualified Distribution.Simple.UHC as UHC @@ -249,16 +248,6 @@ GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - HaskellSuite _ -> - HaskellSuite.installLib - verbosity - lbi - libPref - dynlibPref - buildPref - pkg_descr - lib - clbi _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do @@ -307,7 +296,6 @@ GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe UHC -> return () - HaskellSuite{} -> return () _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) diff --git a/src/Distribution/Simple/InstallDirs.hs b/src/Distribution/Simple/InstallDirs.hs --- a/src/Distribution/Simple/InstallDirs.hs +++ b/src/Distribution/Simple/InstallDirs.hs @@ -537,7 +537,7 @@ -- csidl_PROGRAM_FILES_COMMON = 0x002b {- FOURMOLU_DISABLE -} -#ifdef x86_64_HOST_ARCH +#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) #define CALLCONV ccall #else #define CALLCONV stdcall diff --git a/src/Distribution/Simple/LocalBuildInfo.hs b/src/Distribution/Simple/LocalBuildInfo.hs --- a/src/Distribution/Simple/LocalBuildInfo.hs +++ b/src/Distribution/Simple/LocalBuildInfo.hs @@ -1,8 +1,6 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- diff --git a/src/Distribution/Simple/PackageIndex.hs b/src/Distribution/Simple/PackageIndex.hs --- a/src/Distribution/Simple/PackageIndex.hs +++ b/src/Distribution/Simple/PackageIndex.hs @@ -67,6 +67,7 @@ , lookupSourcePackageId , lookupPackageId , lookupPackageName + , lookupInternalPackageName , lookupDependency , lookupInternalDependency @@ -92,6 +93,10 @@ , dependencyCycles , dependencyGraph , moduleNameIndex + + -- ** Filters on lookup results + , eligibleDependencies + , matchingDependencies ) where import qualified Data.Map.Strict as Map @@ -473,7 +478,18 @@ -> [(Version, [a])] lookupPackageName index name = -- Do not match internal libraries - case Map.lookup (name, LMainLibName) (packageIdIndex index) of + lookupInternalPackageName index name LMainLibName + +-- | Does a lookup by source package name and library name. +-- +-- Also looks up internal packages. +lookupInternalPackageName + :: PackageIndex a + -> PackageName + -> LibraryName + -> [(Version, [a])] +lookupInternalPackageName index name library = + case Map.lookup (name, library) (packageIdIndex index) of Nothing -> [] Just pvers -> Map.toList pvers @@ -508,22 +524,45 @@ -> LibraryName -> [(Version, [IPI.InstalledPackageInfo])] lookupInternalDependency index name versionRange libn = - case Map.lookup (name, libn) (packageIdIndex index) of - Nothing -> [] - Just pvers -> - [ (ver, pkgs') - | (ver, pkgs) <- Map.toList pvers - , ver `withinRange` versionRange - , let pkgs' = filter eligible pkgs - , -- Enforce the invariant - not (null pkgs') - ] + matchingDependencies versionRange $ + lookupInternalPackageName index name libn + +-- | Filter a set of installed packages to ones eligible as dependencies. +-- +-- When we select for dependencies, we ONLY want to pick up indefinite +-- packages, or packages with no instantiations. We'll do mix-in linking to +-- improve any such package into an instantiated one later. +-- +-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. +eligibleDependencies + :: [(Version, [IPI.InstalledPackageInfo])] + -> [(Version, [IPI.InstalledPackageInfo])] +eligibleDependencies versions = + [ (ver, pkgs') + | (ver, pkgs) <- versions + , let pkgs' = filter eligible pkgs + , -- Enforce the invariant + not (null pkgs') + ] where - -- When we select for dependencies, we ONLY want to pick up indefinite - -- packages, or packages with no instantiations. We'll do mix-in - -- linking to improve any such package into an instantiated one - -- later. eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg) + +-- | Get eligible dependencies from a list of versions. +-- +-- This can be used to filter the output of 'lookupPackageName' or +-- 'lookupInternalPackageName'. +-- +-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. +matchingDependencies + :: VersionRange + -> [(Version, [IPI.InstalledPackageInfo])] + -> [(Version, [IPI.InstalledPackageInfo])] +matchingDependencies versionRange versions = + let eligibleVersions = eligibleDependencies versions + in [ (ver, pkgs) + | (ver, pkgs) <- eligibleVersions + , ver `withinRange` versionRange + ] -- diff --git a/src/Distribution/Simple/PreProcess.hs b/src/Distribution/Simple/PreProcess.hs --- a/src/Distribution/Simple/PreProcess.hs +++ b/src/Distribution/Simple/PreProcess.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -36,7 +35,6 @@ , runSimplePreProcessor , ppCpp , ppCpp' - , ppGreenCard , ppC2hs , ppHsc2hs , ppHappy @@ -347,8 +345,8 @@ createDirectoryIfMissingVerbose verbosity True destDir runPreProcessorWithHsBootHack pp - (getSymbolicPath $ psrcLoc, getSymbolicPath $ psrcRelFile) - (getSymbolicPath $ buildLoc, srcStem <.> "hs") + (psrcLoc, getSymbolicPath $ psrcRelFile) + (buildLoc, srcStem <.> "hs") where i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path buildAsSrcLoc :: SymbolicPath Pkg (Dir Source) @@ -363,20 +361,25 @@ pp (inBaseDir, inRelativeFile) (outBaseDir, outRelativeFile) = do + -- Preprocessors are expected to take into account the working + -- directory, e.g. using runProgramCwd with a working directory + -- computed with mbWorkDirLBI. + -- Hence the use of 'getSymbolicPath' here. runPreProcessor pp - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) + (getSymbolicPath $ inBaseDir, inRelativeFile) + (getSymbolicPath $ outBaseDir, outRelativeFile) verbosity - exists <- doesFileExist inBoot - when exists $ copyFileVerbose verbosity inBoot outBoot - where + -- Here we interact directly with the file system, so we must + -- interpret symbolic paths with respect to the working directory. + let + inFile = normalise (i inBaseDir inRelativeFile) + outFile = normalise (i outBaseDir outRelativeFile) inBoot = replaceExtension inFile "hs-boot" outBoot = replaceExtension outFile "hs-boot" - - inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) + exists <- doesFileExist inBoot + when exists $ copyFileVerbose verbosity inBoot outBoot -- ------------------------------------------------------------ @@ -384,20 +387,6 @@ -- ------------------------------------------------------------ -ppGreenCard :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppGreenCard _ lbi _ = - PreProcessor - { platformIndependent = False - , ppOrdering = unsorted - , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - runDbProgramCwd - verbosity - (mbWorkDirLBI lbi) - greencardProgram - (withPrograms lbi) - (["-tffi", "-o" ++ outFile, inFile]) - } - -- This one is useful for preprocessors that can't handle literate source. -- We also need a way to chain preprocessors. ppUnlit :: PreProcessor @@ -511,8 +500,6 @@ withResponseFile verbosity defaultTempFileOptions - mbWorkDir - (makeSymbolicPath $ takeDirectory outFile) "hsc2hs-response.txt" Nothing pureArgs @@ -763,10 +750,6 @@ ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr - HaskellSuite{} -> - ["-D__HASKELL_SUITE__"] - ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr - ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr _ -> [] where comp = compiler lbi @@ -876,11 +859,10 @@ ppSuffixes :: [PPSuffixHandler] -> [Suffix] ppSuffixes = map fst --- | Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. +-- | Standard preprocessors: c2hs, hsc2hs, happy, alex and cpphs. knownSuffixHandlers :: [PPSuffixHandler] knownSuffixHandlers = - [ (Suffix "gc", ppGreenCard) - , (Suffix "chs", ppC2hs) + [ (Suffix "chs", ppC2hs) , (Suffix "hsc", ppHsc2hs) , (Suffix "x", ppAlex) , (Suffix "y", ppHappy) diff --git a/src/Distribution/Simple/PreProcess/Types.hs b/src/Distribution/Simple/PreProcess/Types.hs --- a/src/Distribution/Simple/PreProcess/Types.hs +++ b/src/Distribution/Simple/PreProcess/Types.hs @@ -44,11 +44,12 @@ -- > ppTestHandler = -- > PreProcessor { -- > platformIndependent = True, +-- > ppOrdering = \_ _ -> return, -- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> -- > do info verbosity (inFile++" has been preprocessed to "++outFile) -- > stuff <- readFile inFile -- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) --- > return ExitSuccess +-- > return () -- -- We split the input and output file names into a base directory and the -- rest of the file name. The input base dir is the path in the list of search diff --git a/src/Distribution/Simple/Program.hs b/src/Distribution/Simple/Program.hs --- a/src/Distribution/Simple/Program.hs +++ b/src/Distribution/Simple/Program.hs @@ -111,10 +111,10 @@ , ghcPkgProgram , ghcjsProgram , ghcjsPkgProgram - , hmakeProgram , jhcProgram , uhcProgram , gccProgram + , gppProgram , arProgram , stripProgram , happyProgram @@ -125,7 +125,6 @@ , hscolourProgram , doctestProgram , haddockProgram - , greencardProgram , ldProgram , tarProgram , cppProgram diff --git a/src/Distribution/Simple/Program/Ar.hs b/src/Distribution/Simple/Program/Ar.hs --- a/src/Distribution/Simple/Program/Ar.hs +++ b/src/Distribution/Simple/Program/Ar.hs @@ -154,7 +154,7 @@ (initial, middle, final) (map getSymbolicPath files) ] - else withResponseFile verbosity defaultTempFileOptions mbWorkDir tmpDir "ar.rsp" Nothing (map getSymbolicPath files) $ + else withResponseFile verbosity defaultTempFileOptions "ar.rsp" Nothing (map getSymbolicPath files) $ \path -> runProgramInvocation verbosity $ invokeWithResponseFile path unless diff --git a/src/Distribution/Simple/Program/Builtin.hs b/src/Distribution/Simple/Program/Builtin.hs --- a/src/Distribution/Simple/Program/Builtin.hs +++ b/src/Distribution/Simple/Program/Builtin.hs @@ -20,12 +20,10 @@ , runghcProgram , ghcjsProgram , ghcjsPkgProgram - , hmakeProgram , jhcProgram - , haskellSuiteProgram - , haskellSuitePkgProgram , uhcProgram , gccProgram + , gppProgram , arProgram , stripProgram , happyProgram @@ -36,7 +34,6 @@ , hscolourProgram , doctestProgram , haddockProgram - , greencardProgram , ldProgram , tarProgram , cppProgram @@ -74,9 +71,6 @@ , ghcPkgProgram , ghcjsProgram , ghcjsPkgProgram - , haskellSuiteProgram - , haskellSuitePkgProgram - , hmakeProgram , jhcProgram , uhcProgram , hpcProgram @@ -89,7 +83,6 @@ , hsc2hsProgram , c2hsProgram , cpphsProgram - , greencardProgram , -- platform toolchain gccProgram , arProgram @@ -104,33 +97,45 @@ ghcProgram = (simpleProgram "ghc") { programFindVersion = findProgramVersion "--numeric-version" id - , -- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/8825 - -- (spurious warning on non-english locales) - programPostConf = \_verbosity ghcProg -> - do - let ghcProg' = - ghcProg - { programOverrideEnv = - ("LANGUAGE", Just "en") - : programOverrideEnv ghcProg - } - -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4. - affectedVersionRange = - intersectVersionRanges - (laterVersion $ mkVersion [7, 8, 0]) - (earlierVersion $ mkVersion [7, 8, 4]) - return $ - maybe - ghcProg - ( \v -> - if withinRange v affectedVersionRange - then ghcProg' - else ghcProg - ) - (programVersion ghcProg) + , programPostConf = ghcPostConf , programNormaliseArgs = normaliseGhcArgs } + where + ghcPostConf _verbosity ghcProg = do + let setLanguageEnv prog = + prog + { programOverrideEnv = + ("LANGUAGE", Just "en") + : programOverrideEnv ghcProg + } + ignorePackageEnv prog = prog{programDefaultArgs = "-package-env=-" : programDefaultArgs prog} + + -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4. + affectedVersionRange = + intersectVersionRanges + (laterVersion $ mkVersion [7, 8, 0]) + (earlierVersion $ mkVersion [7, 8, 4]) + + canIgnorePackageEnv = orLaterVersion $ mkVersion [8, 4, 4] + + applyWhen cond f prog = if cond then f prog else prog + + return $ + maybe + ghcProg + ( \v -> + -- By default, ignore GHC_ENVIRONMENT variable of any package environmnet + -- files. See #10759 + applyWhen (withinRange v canIgnorePackageEnv) ignorePackageEnv + -- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/8825 + -- (spurious warning on non-english locales) + $ + applyWhen (withinRange v affectedVersionRange) setLanguageEnv $ + ghcProg + ) + (programVersion ghcProg) + runghcProgram :: Program runghcProgram = (simpleProgram "runghc") @@ -170,17 +175,6 @@ _ -> "" } -hmakeProgram :: Program -hmakeProgram = - (simpleProgram "hmake") - { programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "hmake --version" gives a string line - -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" - case words str of - (_ : ver : _) -> ver - _ -> "" - } - jhcProgram :: Program jhcProgram = (simpleProgram "jhc") @@ -208,32 +202,6 @@ _ -> "" } --- This represents a haskell-suite compiler. Of course, the compiler --- itself probably is not called "haskell-suite", so this is not a real --- program. (But we don't know statically the name of the actual compiler, --- so this is the best we can do.) --- --- Having this Program value serves two purposes: --- --- 1. We can accept options for the compiler in the form of --- --- --haskell-suite-option(s)=... --- --- 2. We can find a program later using this static id (with --- requireProgram). --- --- The path to the real compiler is found and recorded in the ProgramDb --- during the configure phase. -haskellSuiteProgram :: Program -haskellSuiteProgram = - simpleProgram "haskell-suite" - --- This represent a haskell-suite package manager. See the comments for --- haskellSuiteProgram. -haskellSuitePkgProgram :: Program -haskellSuitePkgProgram = - simpleProgram "haskell-suite-pkg" - happyProgram :: Program happyProgram = (simpleProgram "happy") @@ -262,6 +230,13 @@ { programFindVersion = findProgramVersion "-dumpversion" id } +gppProgram :: Program +gppProgram = + (simpleProgram "gpp") + { programFindVersion = findProgramVersion "-dumpversion" id + , programFindLocation = \v p -> findProgramOnSearchPath v p "g++" + } + arProgram :: Program arProgram = simpleProgram "ar" @@ -334,9 +309,6 @@ _ -> "" , programNormaliseArgs = \_ _ args -> args } - -greencardProgram :: Program -greencardProgram = simpleProgram "greencard" ldProgram :: Program ldProgram = diff --git a/src/Distribution/Simple/Program/Find.hs b/src/Distribution/Simple/Program/Find.hs --- a/src/Distribution/Simple/Program/Find.hs +++ b/src/Distribution/Simple/Program/Find.hs @@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} diff --git a/src/Distribution/Simple/Program/GHC.hs b/src/Distribution/Simple/Program/GHC.hs --- a/src/Distribution/Simple/Program/GHC.hs +++ b/src/Distribution/Simple/Program/GHC.hs @@ -5,7 +5,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} module Distribution.Simple.Program.GHC ( GhcOptions (..) @@ -16,6 +15,8 @@ , ghcInvocation , renderGhcOptions , runGHC + , runGHCWithResponseFile + , runReplProgram , packageDbArgsDb , normaliseGhcArgs ) where @@ -32,8 +33,10 @@ import Distribution.Simple.Flag import Distribution.Simple.GHC.ImplInfo import Distribution.Simple.Program.Find (getExtraPathEnv) +import Distribution.Simple.Program.ResponseFile import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types +import Distribution.Simple.Utils (TempFileOptions, infoNoWrap) import Distribution.System import Distribution.Types.ComponentId import Distribution.Types.ParStrat @@ -42,17 +45,19 @@ import Distribution.Verbosity import Distribution.Version +import GHC.IO.Encoding (TextEncoding) import Language.Haskell.Extension import Data.List (stripPrefix) import qualified Data.Map as Map import Data.Monoid (All (..), Any (..), Endo (..)) import qualified Data.Set as Set +import qualified System.Process as Process normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String] normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs | ghcVersion `withinRange` supportedGHCVersions = - argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs + argumentFilters . filter simpleFilters . filterRtsArgs $ ghcArgs where supportedGHCVersions :: VersionRange supportedGHCVersions = orLaterVersion (mkVersion [8, 0]) @@ -162,18 +167,9 @@ flagArgumentFilter ["-ghci-script", "-H", "-interactive-print"] - filterRtsOpts :: [String] -> [String] - filterRtsOpts = go False - where - go :: Bool -> [String] -> [String] - go _ [] = [] - go _ ("+RTS" : opts) = go True opts - go _ ("-RTS" : opts) = go False opts - go isRTSopts (opt : opts) = addOpt $ go isRTSopts opts - where - addOpt - | isRTSopts = id - | otherwise = (opt :) + -- \| Remove RTS arguments from a list. + filterRtsArgs :: [String] -> [String] + filterRtsArgs = snd . splitRTSArgs simpleFilters :: String -> Bool simpleFilters = @@ -442,6 +438,8 @@ -- the @ghc -i@ flag (@-i@ on its own with no path argument). , ghcOptSourcePath :: NubListR (SymbolicPath Pkg (Dir Source)) -- ^ Search path for Haskell source files; the @ghc -i@ flag. + , ghcOptUnitFiles :: [FilePath] + -- ^ Unit files to load; the @ghc -unit@ flag. , ------------- -- Packages @@ -510,6 +508,8 @@ -- ^ Options to pass through to the Assembler. , ghcOptCppOptions :: [String] -- ^ Options to pass through to CPP; the @ghc -optP@ flag. + , ghcOptJSppOptions :: [String] + -- ^ Options to pass through to CPP; the @ghc -optJSP@ flag. @since 3.16.0.0 , ghcOptCppIncludePath :: NubListR (SymbolicPath Pkg (Dir Include)) -- ^ Search path for CPP includes like header files; the @ghc -I@ flag. , ghcOptCppIncludes :: NubListR (SymbolicPath Pkg File) @@ -647,6 +647,97 @@ runProgramInvocation verbosity =<< ghcInvocation verbosity ghcProg comp platform mbWorkDir opts +runGHCWithResponseFile + :: FilePath + -> Maybe TextEncoding + -> TempFileOptions + -> Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> GhcOptions + -> IO () +runGHCWithResponseFile fileNameTemplate encoding tempFileOptions verbosity ghcProg comp platform maybeWorkDir opts = do + invocation <- ghcInvocation verbosity ghcProg comp platform maybeWorkDir opts + + let compilerSupportsResponseFiles = + case compilerCompatVersion GHC comp of + -- GHC 9.4 is the first version which supports response files. + Just version -> version >= mkVersion [9, 4] + Nothing -> False + + args = progInvokeArgs invocation + + if not compilerSupportsResponseFiles + then runProgramInvocation verbosity invocation + else do + let (rtsArgs, otherArgs) = splitRTSArgs args + + withResponseFile + verbosity + tempFileOptions + fileNameTemplate + encoding + otherArgs + $ \responseFile -> do + let newInvocation = + invocation{progInvokeArgs = ('@' : responseFile) : rtsArgs} + + infoNoWrap verbosity $ + "GHC response file arguments: " + <> case otherArgs of + [] -> "" + arg : args' -> Process.showCommandForUser arg args' + + runProgramInvocation verbosity newInvocation + +-- Note [Make --interactive the first argument to GHC] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The ghc argument @--interactive@ needs to be the first argument to the +-- ghc invocation, because Haskell Language Server used to rely on this. +-- This was initially changed for Cabal 3.16, but it broke all existing Haskell +-- Language Server prebuilt binaries. +-- To avoid this, we uphold this assumption in Haskell Language Server until the next +-- Cabal release (3.18). +-- +-- The solution is to make sure that @--interactive@ is not passed as an argument in +-- the response file that is usually passed to ghc. +-- Instead, we filter out @--interactive@ and always pass it as the first argument, +-- if it exists. +-- +-- We plan to remove this Hack in Cabal 3.18. + +-- Start the repl. Either use `ghc`, or the program specified by the --with-repl flag. +runReplProgram + :: Maybe FilePath + -- ^ --with-repl argument + -> TempFileOptions + -> Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> GhcOptions + -> IO () +runReplProgram withReplProg _tempFileOptions verbosity ghcProg comp platform mbWorkDir ghcOpts = + let replProg = case withReplProg of + Just path -> ghcProg{programLocation = FoundOnSystem path} + Nothing -> ghcProg + in do + -- in runGHCWithResponseFile "ghci.rsp" Nothing tempFileOptions verbosity replProg comp platform mbWorkDir ghcOpts + -- See Note [Make --interactive the first argument to GHC] + -- In Cabal 3.18, restore the line above. + invocation <- ghcInvocation verbosity replProg comp platform mbWorkDir ghcOpts + let invocation' = + let + argsWithoutInteractive = filter (/= "--interactive") (progInvokeArgs invocation) + in + invocation + { progInvokeArgs = ["--interactive"] <> argsWithoutInteractive + } + runProgramInvocation verbosity invocation' + ghcInvocation :: Verbosity -> ConfiguredProgram @@ -786,6 +877,7 @@ ["-I" ++ u dir | dir <- flags ghcOptCppIncludePath] , ["-optP" ++ opt | opt <- ghcOptCppOptions opts] + , ["-optJSP" ++ opt | opt <- ghcOptJSppOptions opts] , concat [ ["-optP-include", "-optP" ++ u inc] | inc <- flags ghcOptCppIncludes @@ -897,6 +989,8 @@ , [prettyShow modu | modu <- flags ghcOptInputModules] , concat [["-o", u out] | out <- flag ghcOptOutputFile] , concat [["-dyno", out] | out <- flag ghcOptOutputDynFile] + , -- unit files + concat [["-unit", "@" ++ unit] | unit <- ghcOptUnitFiles opts] , --------------- -- Extra @@ -959,6 +1053,26 @@ packageDbArgs implInfo | flagPackageConf implInfo = packageDbArgsConf | otherwise = packageDbArgsDb + +-- | Split a list of command-line arguments into RTS arguments and non-RTS +-- arguments. +splitRTSArgs :: [String] -> ([String], [String]) +splitRTSArgs args = + let addRTSArg arg ~(rtsArgs, nonRTSArgs) = (arg : rtsArgs, nonRTSArgs) + addNonRTSArg arg ~(rtsArgs, nonRTSArgs) = (rtsArgs, arg : nonRTSArgs) + + go _ [] = ([], []) + go isRTSArg (arg : rest) = + case arg of + "+RTS" -> addRTSArg arg $ go True rest + "-RTS" -> addRTSArg arg $ go False rest + "--RTS" -> ([arg], rest) + "--" -> ([], arg : rest) + _ -> + if isRTSArg + then addRTSArg arg $ go isRTSArg rest + else addNonRTSArg arg $ go isRTSArg rest + in go False args -- ----------------------------------------------------------------------------- -- Boilerplate Monoid instance for GhcOptions diff --git a/src/Distribution/Simple/Program/Internal.hs b/src/Distribution/Simple/Program/Internal.hs --- a/src/Distribution/Simple/Program/Internal.hs +++ b/src/Distribution/Simple/Program/Internal.hs @@ -17,21 +17,28 @@ -- | Extract the version number from the output of 'strip --version'. -- --- Invoking "strip --version" gives very inconsistent results. We ignore --- everything in parentheses (see #2497), look for the first word that starts --- with a number, and try parsing out the first two components of it. Non-GNU --- 'strip' doesn't appear to have a version flag. +-- Invoking "strip --version" gives very inconsistent results. We +-- ignore everything in parentheses (see #2497), look for the first +-- word that starts with a number, and try parsing out the first two +-- components of it. Non-GNU, non-LLVM 'strip' doesn't appear to have +-- a version flag. stripExtractVersion :: String -> String stripExtractVersion str = let numeric "" = False numeric (x : _) = isDigit x + closingParentheses = + [ ")" + , -- LLVM strip outputs "llvm-strip, compatible with GNU strip\nLLVM (http://llvm.org/):\n..." + "):" + ] + -- Filter out everything in parentheses. filterPar' :: Int -> [String] -> [String] filterPar' _ [] = [] filterPar' n (x : xs) | n >= 0 && "(" `isPrefixOf` x = filterPar' (n + 1) ((safeTail x) : xs) - | n > 0 && ")" `isSuffixOf` x = filterPar' (n - 1) xs + | n > 0 && any (`isSuffixOf` x) closingParentheses = filterPar' (n - 1) xs | n > 0 = filterPar' n xs | otherwise = x : filterPar' n xs diff --git a/src/Distribution/Simple/Program/Ld.hs b/src/Distribution/Simple/Program/Ld.hs --- a/src/Distribution/Simple/Program/Ld.hs +++ b/src/Distribution/Simple/Program/Ld.hs @@ -83,8 +83,6 @@ middle = ld middleArgs final = ld finalArgs - targetDir = takeDirectorySymbolicPath target - invokeWithResponseFile :: FilePath -> ProgramInvocation invokeWithResponseFile atFile = ld $ simpleArgs ++ ['@' : atFile] @@ -106,7 +104,7 @@ if oldVersionManualOverride || responseArgumentsNotSupported then run $ multiStageProgramInvocation simple (initial, middle, final) (map getSymbolicPath files) - else withResponseFile verbosity defaultTempFileOptions mbWorkDir targetDir "ld.rsp" Nothing (map getSymbolicPath files) $ + else withResponseFile verbosity defaultTempFileOptions "ld.rsp" Nothing (map getSymbolicPath files) $ \path -> runProgramInvocation verbosity $ invokeWithResponseFile path where tmpfile = target <.> "tmp" -- perhaps should use a proper temp file diff --git a/src/Distribution/Simple/Program/ResponseFile.hs b/src/Distribution/Simple/Program/ResponseFile.hs --- a/src/Distribution/Simple/Program/ResponseFile.hs +++ b/src/Distribution/Simple/Program/ResponseFile.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} ---------------------------------------------------------------------------- @@ -27,10 +26,6 @@ withResponseFile :: Verbosity -> TempFileOptions - -> Maybe (SymbolicPath CWD (Dir Pkg)) - -- ^ Working directory - -> SymbolicPath Pkg (Dir Response) - -- ^ Directory to create response file in. -> String -- ^ Template for response file name. -> Maybe TextEncoding @@ -39,8 +34,8 @@ -- ^ Arguments to put into response file. -> (FilePath -> IO a) -> IO a -withResponseFile verbosity tmpFileOpts mbWorkDir responseDir fileNameTemplate encoding arguments f = - withTempFileEx tmpFileOpts mbWorkDir responseDir fileNameTemplate $ \responsePath hf -> do +withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f = + withTempFileEx tmpFileOpts fileNameTemplate $ \responsePath hf -> do let responseFileName = getSymbolicPath responsePath traverse_ (hSetEncoding hf) encoding let responseContents = diff --git a/src/Distribution/Simple/Program/Run.hs b/src/Distribution/Simple/Program/Run.hs --- a/src/Distribution/Simple/Program/Run.hs +++ b/src/Distribution/Simple/Program/Run.hs @@ -3,7 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -62,6 +61,7 @@ , progInvokeInputEncoding :: IOEncoding -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. , progInvokeOutputEncoding :: IOEncoding + , progInvokeWhen :: IO Bool } data IOEncoding @@ -83,6 +83,7 @@ , progInvokeInput = Nothing , progInvokeInputEncoding = IOEncodingText , progInvokeOutputEncoding = IOEncodingText + , progInvokeWhen = pure True } simpleProgramInvocation diff --git a/src/Distribution/Simple/Program/Types.hs b/src/Distribution/Simple/Program/Types.hs --- a/src/Distribution/Simple/Program/Types.hs +++ b/src/Distribution/Simple/Program/Types.hs @@ -142,7 +142,7 @@ , programMonitorFiles :: [FilePath] -- ^ In addition to the 'programLocation' where the program was found, -- these are additional locations that were looked at. The combination - -- of ths found location and these not-found locations can be used to + -- of this found location and these not-found locations can be used to -- monitor to detect when the re-configuring the program might give a -- different result (e.g. found in a different location). } diff --git a/src/Distribution/Simple/Register.hs b/src/Distribution/Simple/Register.hs --- a/src/Distribution/Simple/Register.hs +++ b/src/Distribution/Simple/Register.hs @@ -59,7 +59,6 @@ import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.HaskellSuite as HaskellSuite import qualified Distribution.Simple.PackageIndex as Index import qualified Distribution.Simple.UHC as UHC @@ -371,7 +370,6 @@ GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath UHC -> return () - HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath _ -> dieWithException verbosity CreatePackageDB doesPackageDBExist :: FilePath -> IO Bool @@ -436,8 +434,6 @@ case compilerFlavor comp of GHC -> GHC.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions GHCJS -> GHCJS.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions - HaskellSuite{} -> - HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo _ | HcPkg.registerMultiInstance registerOptions -> dieWithException verbosity RegisMultiplePkgNotSupported @@ -497,9 +493,9 @@ { IPI.sourcePackageId = packageId pkg , IPI.installedUnitId = componentUnitId clbi , IPI.installedComponentId_ = componentComponentId clbi - , IPI.instantiatedWith = componentInstantiatedWith clbi + , IPI.instantiatedWith = expectLibraryComponent (maybeComponentInstantiatedWith clbi) , IPI.sourceLibName = libName lib - , IPI.compatPackageKey = componentCompatPackageKey clbi + , IPI.compatPackageKey = expectLibraryComponent (maybeComponentCompatPackageKey clbi) , -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license IPI.license = if ghc84 @@ -518,7 +514,7 @@ , IPI.indefinite = componentIsIndefinite clbi , IPI.exposed = libExposed lib , IPI.exposedModules = - componentExposedModules clbi + expectLibraryComponent (maybeComponentExposedModules clbi) -- add virtual modules into the list of exposed modules for the -- package database as well. ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi) @@ -601,6 +597,8 @@ ) | otherwise = (libdir installDirs : dynlibdir installDirs : extraLibDirs', []) + expectLibraryComponent (Just attribute) = attribute + expectLibraryComponent Nothing = (error "generalInstalledPackageInfo: Expected a library component, got something else.") -- the compiler doesn't understand the dynamic-library-dirs field so we -- add the dyn directory to the "normal" list in the library-dirs field diff --git a/src/Distribution/Simple/Setup.hs b/src/Distribution/Simple/Setup.hs --- a/src/Distribution/Simple/Setup.hs +++ b/src/Distribution/Simple/Setup.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -- | @@ -38,6 +38,7 @@ , globalCommand , CommonSetupFlags (..) , defaultCommonSetupFlags + , commonSetupTempFileOptions , ConfigFlags (..) , emptyConfigFlags , defaultConfigFlags @@ -118,7 +119,9 @@ , splitArgs , defaultDistPref , optionDistPref - , Flag (..) + , Flag + , pattern Flag + , pattern NoFlag , toFlag , fromFlag , fromFlagOrDefault diff --git a/src/Distribution/Simple/Setup/Benchmark.hs b/src/Distribution/Simple/Setup/Benchmark.hs --- a/src/Distribution/Simple/Setup/Benchmark.hs +++ b/src/Distribution/Simple/Setup/Benchmark.hs @@ -118,7 +118,8 @@ [] ["benchmark-options"] ( "give extra options to benchmark executables " - ++ "(name templates can use $pkgid, $compiler, " + ++ "(split on spaces, use \"\" to prevent splitting; " + ++ "name templates can use $pkgid, $compiler, " ++ "$os, $arch, $benchmark)" ) benchmarkOptions @@ -132,7 +133,7 @@ [] ["benchmark-option"] ( "give extra option to benchmark executables " - ++ "(no need to quote options containing spaces, " + ++ "(passed directly as a single argument; " ++ "name template can use $pkgid, $compiler, " ++ "$os, $arch, $benchmark)" ) diff --git a/src/Distribution/Simple/Setup/Common.hs b/src/Distribution/Simple/Setup/Common.hs --- a/src/Distribution/Simple/Setup/Common.hs +++ b/src/Distribution/Simple/Setup/Common.hs @@ -1,8 +1,7 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -- | @@ -20,6 +19,7 @@ ( CommonSetupFlags (..) , defaultCommonSetupFlags , withCommonSetupOptions + , commonSetupTempFileOptions , CopyDest (..) , configureCCompiler , configureLinker @@ -33,7 +33,9 @@ , defaultDistPref , extraCompilationArtifacts , optionDistPref - , Flag (..) + , Flag + , pattern Flag + , pattern NoFlag , toFlag , fromFlag , fromFlagOrDefault @@ -82,6 +84,13 @@ -- -- TODO: this one should not be here, it's just that the silly -- UserHooks stop us from passing extra info in other ways + , setupKeepTempFiles :: Flag Bool + -- ^ When this flag is set, temporary files will be kept after building. + -- + -- Note: Keeping temporary files is important functionality for HLS, which + -- runs @cabal repl@ with a fake GHC to get CLI arguments. It will need the + -- temporary files (including multi unit repl response files) to stay, even + -- after the @cabal repl@ command exits. } deriving (Eq, Show, Read, Generic) @@ -103,8 +112,17 @@ , setupDistPref = NoFlag , setupCabalFilePath = NoFlag , setupTargets = [] + , setupKeepTempFiles = NoFlag } +-- | Get `TempFileOptions` that respect the `setupKeepTempFiles` flag. +commonSetupTempFileOptions :: CommonSetupFlags -> TempFileOptions +commonSetupTempFileOptions options = + TempFileOptions + { optKeepTempFiles = + fromFlagOrDefault False (setupKeepTempFiles options) + } + commonSetupOptions :: ShowOrParseArgs -> [OptionField CommonSetupFlags] commonSetupOptions showOrParseArgs = [ optionVerbosity @@ -121,6 +139,14 @@ setupCabalFilePath (\v flags -> flags{setupCabalFilePath = v}) (reqSymbolicPathArgFlag "PATH") + , option + "" + ["keep-temp-files"] + ( "Keep temporary files." + ) + setupKeepTempFiles + (\keepTempFiles flags -> flags{setupKeepTempFiles = keepTempFiles}) + trueArg -- NB: no --working-dir flag, as that value is populated using the -- global flag (see Distribution.Simple.Setup.Global.globalCommand). ] @@ -252,7 +278,9 @@ [prog ++ "-option"] ( "give an extra option to " ++ prog - ++ " (no need to quote options containing spaces)" + ++ " (passed directly to " + ++ prog + ++ " as a single argument)" ) get set @@ -289,7 +317,10 @@ option "" [prog ++ "-options"] - ("give extra options to " ++ prog) + ( "give extra options to " + ++ prog + ++ " (split on spaces, use \"\" to prevent splitting)" + ) get set (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) diff --git a/src/Distribution/Simple/Setup/Config.hs b/src/Distribution/Simple/Setup/Config.hs --- a/src/Distribution/Simple/Setup/Config.hs +++ b/src/Distribution/Simple/Setup/Config.hs @@ -438,13 +438,6 @@ [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") , (Flag GHCJS, ([], ["ghcjs"]), "compile with GHCJS") , (Flag UHC, ([], ["uhc"]), "compile with UHC") - , -- "haskell-suite" compiler id string will be replaced - -- by a more specific one during the configure stage - - ( Flag (HaskellSuite "haskell-suite") - , ([], ["haskell-suite"]) - , "compile with a haskell-suite compiler" - ) ] ) , option @@ -1101,7 +1094,7 @@ (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc] (NoFlag, NoFlag) -> [] hc_flag_name - -- TODO kill off thic bc hack when defaultUserHooks is removed. + -- TODO kill off this bc hack when defaultUserHooks is removed. | bcHack = "--with-hc=" | otherwise = "--with-compiler=" optFlag name config_field = case config_field flags of diff --git a/src/Distribution/Simple/Setup/Copy.hs b/src/Distribution/Simple/Setup/Copy.hs --- a/src/Distribution/Simple/Setup/Copy.hs +++ b/src/Distribution/Simple/Setup/Copy.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternSynonyms #-} diff --git a/src/Distribution/Simple/Setup/Haddock.hs b/src/Distribution/Simple/Setup/Haddock.hs --- a/src/Distribution/Simple/Setup/Haddock.hs +++ b/src/Distribution/Simple/Setup/Haddock.hs @@ -107,7 +107,6 @@ , haddockHscolourCss :: Flag FilePath , haddockContents :: Flag PathTemplate , haddockIndex :: Flag PathTemplate - , haddockKeepTempFiles :: Flag Bool , haddockBaseUrl :: Flag String , haddockResourcesDir :: Flag String , haddockOutputDir :: Flag FilePath @@ -162,7 +161,6 @@ , haddockQuickJump = Flag False , haddockHscolourCss = NoFlag , haddockContents = NoFlag - , haddockKeepTempFiles = Flag False , haddockIndex = NoFlag , haddockBaseUrl = NoFlag , haddockResourcesDir = NoFlag @@ -216,13 +214,6 @@ showOrParseArgs [ option "" - ["keep-temp-files"] - "Keep temporary files" - haddockKeepTempFiles - (\b flags -> flags{haddockKeepTempFiles = b}) - trueArg - , option - "" ["hoogle"] "Generate a hoogle database" haddockHoogle @@ -409,7 +400,8 @@ deriving (Eq, Show) data HaddockProjectFlags = HaddockProjectFlags - { haddockProjectHackage :: Flag Bool + { haddockProjectCommonFlags :: !CommonSetupFlags + , haddockProjectHackage :: Flag Bool -- ^ a shortcut option which builds documentation linked to hackage. It implies: -- * `--html-location='https://hackage.haskell.org/package/$prg-$version/docs' -- * `--quickjump` @@ -442,9 +434,7 @@ , -- haddockContent is not supported, a fixed value is provided -- haddockIndex is not supported, a fixed value is provided -- haddockDistPerf is not supported, note: it changes location of the haddocks - haddockProjectKeepTempFiles :: Flag Bool - , haddockProjectVerbosity :: Flag Verbosity - , -- haddockBaseUrl is not supported, a fixed value is provided + -- haddockBaseUrl is not supported, a fixed value is provided haddockProjectResourcesDir :: Flag String , haddockProjectUseUnicode :: Flag Bool } @@ -453,7 +443,8 @@ defaultHaddockProjectFlags :: HaddockProjectFlags defaultHaddockProjectFlags = HaddockProjectFlags - { haddockProjectHackage = Flag False + { haddockProjectCommonFlags = defaultCommonSetupFlags + , haddockProjectHackage = Flag False , haddockProjectDir = Flag "./haddocks" , haddockProjectPrologue = NoFlag , haddockProjectTestSuites = Flag False @@ -467,8 +458,6 @@ , haddockProjectInternal = Flag False , haddockProjectCss = NoFlag , haddockProjectHscolourCss = NoFlag - , haddockProjectKeepTempFiles = Flag False - , haddockProjectVerbosity = Flag normal , haddockProjectResourcesDir = NoFlag , haddockProjectInterfaces = NoFlag , haddockProjectUseUnicode = NoFlag @@ -513,140 +502,134 @@ emptyProgramDb haddockProjectOptions :: ShowOrParseArgs -> [OptionField HaddockProjectFlags] -haddockProjectOptions _showOrParseArgs = - [ option - "" - ["hackage"] - ( concat - [ "A short-cut option to build documentation linked to hackage." - ] - ) - haddockProjectHackage - (\v flags -> flags{haddockProjectHackage = v}) - trueArg - , option - "" - ["output"] - "Output directory" - haddockProjectDir - (\v flags -> flags{haddockProjectDir = v}) - (optArg' "DIRECTORY" maybeToFlag (fmap Just . flagToList)) - , option - "" - ["prologue"] - "File path to a prologue file in haddock format" - haddockProjectPrologue - (\v flags -> flags{haddockProjectPrologue = v}) - (optArg' "PATH" maybeToFlag (fmap Just . flagToList)) - , option - "" - ["hoogle"] - "Generate a hoogle database" - haddockProjectHoogle - (\v flags -> flags{haddockProjectHoogle = v}) - trueArg - , option - "" - ["html-location"] - "Location of HTML documentation for pre-requisite packages" - haddockProjectHtmlLocation - (\v flags -> flags{haddockProjectHtmlLocation = v}) - (reqArgFlag "URL") - , option - "" - ["executables"] - "Run haddock for Executables targets" - haddockProjectExecutables - (\v flags -> flags{haddockProjectExecutables = v}) - trueArg - , option - "" - ["tests"] - "Run haddock for Test Suite targets" - haddockProjectTestSuites - (\v flags -> flags{haddockProjectTestSuites = v}) - trueArg - , option - "" - ["benchmarks"] - "Run haddock for Benchmark targets" - haddockProjectBenchmarks - (\v flags -> flags{haddockProjectBenchmarks = v}) - trueArg - , option - "" - ["foreign-libraries"] - "Run haddock for Foreign Library targets" - haddockProjectForeignLibs - (\v flags -> flags{haddockProjectForeignLibs = v}) - trueArg - , option - "" - ["all", "haddock-all"] - "Run haddock for all targets" - ( \f -> - allFlags - [ haddockProjectExecutables f - , haddockProjectTestSuites f - , haddockProjectBenchmarks f - , haddockProjectForeignLibs f +haddockProjectOptions showOrParseArgs = + withCommonSetupOptions + haddockProjectCommonFlags + (\c f -> f{haddockProjectCommonFlags = c}) + showOrParseArgs + [ option + "" + ["hackage"] + ( concat + [ "A short-cut option to build documentation linked to hackage." ] - ) - ( \v flags -> - flags - { haddockProjectExecutables = v - , haddockProjectTestSuites = v - , haddockProjectBenchmarks = v - , haddockProjectForeignLibs = v - } - ) - trueArg - , option - "" - ["internal"] - "Run haddock for internal modules and include all symbols" - haddockProjectInternal - (\v flags -> flags{haddockProjectInternal = v}) - trueArg - , option - "" - ["css"] - "Use PATH as the haddock stylesheet" - haddockProjectCss - (\v flags -> flags{haddockProjectCss = v}) - (reqArgFlag "PATH") - , option - "" - ["hscolour-css"] - "Use PATH as the HsColour stylesheet" - haddockProjectHscolourCss - (\v flags -> flags{haddockProjectHscolourCss = v}) - (reqArgFlag "PATH") - , option - "" - ["keep-temp-files"] - "Keep temporary files" - haddockProjectKeepTempFiles - (\b flags -> flags{haddockProjectKeepTempFiles = b}) - trueArg - , optionVerbosity - haddockProjectVerbosity - (\v flags -> flags{haddockProjectVerbosity = v}) - , option - "" - ["resources-dir"] - "location of Haddocks static / auxiliary files" - haddockProjectResourcesDir - (\v flags -> flags{haddockProjectResourcesDir = v}) - (reqArgFlag "DIR") - , option - "" - ["use-unicode"] - "Pass --use-unicode option to haddock" - haddockProjectUseUnicode - (\v flags -> flags{haddockProjectUseUnicode = v}) - trueArg - ] + ) + haddockProjectHackage + (\v flags -> flags{haddockProjectHackage = v}) + trueArg + , option + "" + ["output"] + "Output directory" + haddockProjectDir + (\v flags -> flags{haddockProjectDir = v}) + (optArg' "DIRECTORY" maybeToFlag (fmap Just . flagToList)) + , option + "" + ["prologue"] + "File path to a prologue file in haddock format" + haddockProjectPrologue + (\v flags -> flags{haddockProjectPrologue = v}) + (optArg' "PATH" maybeToFlag (fmap Just . flagToList)) + , option + "" + ["hoogle"] + "Generate a hoogle database" + haddockProjectHoogle + (\v flags -> flags{haddockProjectHoogle = v}) + trueArg + , option + "" + ["html-location"] + "Location of HTML documentation for pre-requisite packages" + haddockProjectHtmlLocation + (\v flags -> flags{haddockProjectHtmlLocation = v}) + (reqArgFlag "URL") + , option + "" + ["executables"] + "Run haddock for Executables targets" + haddockProjectExecutables + (\v flags -> flags{haddockProjectExecutables = v}) + trueArg + , option + "" + ["tests"] + "Run haddock for Test Suite targets" + haddockProjectTestSuites + (\v flags -> flags{haddockProjectTestSuites = v}) + trueArg + , option + "" + ["benchmarks"] + "Run haddock for Benchmark targets" + haddockProjectBenchmarks + (\v flags -> flags{haddockProjectBenchmarks = v}) + trueArg + , option + "" + ["foreign-libraries"] + "Run haddock for Foreign Library targets" + haddockProjectForeignLibs + (\v flags -> flags{haddockProjectForeignLibs = v}) + trueArg + , option + "" + ["all", "haddock-all"] + "Run haddock for all targets" + ( \f -> + allFlags + [ haddockProjectExecutables f + , haddockProjectTestSuites f + , haddockProjectBenchmarks f + , haddockProjectForeignLibs f + ] + ) + ( \v flags -> + flags + { haddockProjectExecutables = v + , haddockProjectTestSuites = v + , haddockProjectBenchmarks = v + , haddockProjectForeignLibs = v + } + ) + trueArg + , option + "" + ["internal"] + "Run haddock for internal modules and include all symbols" + haddockProjectInternal + (\v flags -> flags{haddockProjectInternal = v}) + trueArg + , option + "" + ["css"] + "Use PATH as the haddock stylesheet" + haddockProjectCss + (\v flags -> flags{haddockProjectCss = v}) + (reqArgFlag "PATH") + , option + "" + ["hscolour-css"] + "Use PATH as the HsColour stylesheet" + haddockProjectHscolourCss + (\v flags -> flags{haddockProjectHscolourCss = v}) + (reqArgFlag "PATH") + , option + "" + ["resources-dir"] + "location of Haddocks static / auxiliary files" + haddockProjectResourcesDir + (\v flags -> flags{haddockProjectResourcesDir = v}) + (reqArgFlag "DIR") + , option + "" + ["use-unicode"] + "Pass --use-unicode option to haddock" + haddockProjectUseUnicode + (\v flags -> flags{haddockProjectUseUnicode = v}) + trueArg + ] emptyHaddockProjectFlags :: HaddockProjectFlags emptyHaddockProjectFlags = mempty diff --git a/src/Distribution/Simple/Setup/Install.hs b/src/Distribution/Simple/Setup/Install.hs --- a/src/Distribution/Simple/Setup/Install.hs +++ b/src/Distribution/Simple/Setup/Install.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternSynonyms #-} diff --git a/src/Distribution/Simple/Setup/Repl.hs b/src/Distribution/Simple/Setup/Repl.hs --- a/src/Distribution/Simple/Setup/Repl.hs +++ b/src/Distribution/Simple/Setup/Repl.hs @@ -54,6 +54,7 @@ { replOptionsFlags :: [String] , replOptionsNoLoad :: Flag Bool , replOptionsFlagOutput :: Flag FilePath + , replWithRepl :: Flag FilePath } deriving (Show, Generic) @@ -85,7 +86,7 @@ instance Structured ReplOptions instance Monoid ReplOptions where - mempty = ReplOptions mempty (Flag False) NoFlag + mempty = ReplOptions mempty (Flag False) NoFlag NoFlag mappend = (<>) instance Semigroup ReplOptions where @@ -229,4 +230,11 @@ replOptionsFlagOutput (\p flags -> flags{replOptionsFlagOutput = p}) (reqArg "DIR" (succeedReadE Flag) flagToList) + , option + [] + ["with-repl"] + "Give the path to a program to use for REPL" + replWithRepl + (\v flags -> flags{replWithRepl = v}) + (reqArgFlag "PATH") ] diff --git a/src/Distribution/Simple/Setup/Test.hs b/src/Distribution/Simple/Setup/Test.hs --- a/src/Distribution/Simple/Setup/Test.hs +++ b/src/Distribution/Simple/Setup/Test.hs @@ -245,7 +245,8 @@ [] ["test-options"] ( "give extra options to test executables " - ++ "(name templates can use $pkgid, $compiler, " + ++ "(split on spaces, use \"\" to prevent splitting; " + ++ "name templates can use $pkgid, $compiler, " ++ "$os, $arch, $test-suite)" ) testOptions @@ -259,7 +260,7 @@ [] ["test-option"] ( "give extra option to test executables " - ++ "(no need to quote options containing spaces, " + ++ "(passed directly as a single argument; " ++ "name template can use $pkgid, $compiler, " ++ "$os, $arch, $test-suite)" ) diff --git a/src/Distribution/Simple/SetupHooks/Internal.hs b/src/Distribution/Simple/SetupHooks/Internal.hs --- a/src/Distribution/Simple/SetupHooks/Internal.hs +++ b/src/Distribution/Simple/SetupHooks/Internal.hs @@ -7,7 +7,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -- | diff --git a/src/Distribution/Simple/SetupHooks/Rule.hs b/src/Distribution/Simple/SetupHooks/Rule.hs --- a/src/Distribution/Simple/SetupHooks/Rule.hs +++ b/src/Distribution/Simple/SetupHooks/Rule.hs @@ -9,10 +9,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} @@ -612,9 +610,9 @@ -> StaticPtr (arg -> res) -> arg -> Command arg res -mkCommand dict actionPtr arg = +mkCommand dict action arg = Command - { actionPtr = UserStatic actionPtr + { actionPtr = UserStatic action , actionArg = ScopedArgument arg , cmdInstances = UserStatic dict } @@ -723,7 +721,7 @@ how much to read in order to reconstruct the associated opaque 'ByteString'. To ensure we always serialise/deserialise including the length of the data, the 'ScopedArgument' newtype is used, with a custom 'Binary' instance that always -incldues the length. We use this newtype: +includes the length. We use this newtype: - in the definition of 'CommandData', for arguments to rules, - in the definition of 'DepsRes', for the result of dynamic dependency computations. @@ -824,9 +822,9 @@ } | Dict <- deRefStaticPtr instsPtr -> Just $ do - (deps, depsRes) <- runCommand depsCmd + (deps, dynDeps) <- runCommand depsCmd -- See Note [Hooks Binary instances] - return $ (deps, Binary.encode $ ScopedArgument @User depsRes) + return $ (deps, Binary.encode $ ScopedArgument @User dynDeps) -- | Project out the command for running the rule, passing in the result of -- the dependency computation if there was one. diff --git a/src/Distribution/Simple/ShowBuildInfo.hs b/src/Distribution/Simple/ShowBuildInfo.hs --- a/src/Distribution/Simple/ShowBuildInfo.hs +++ b/src/Distribution/Simple/ShowBuildInfo.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -- | -- This module defines a simple JSON-based format for exporting basic diff --git a/src/Distribution/Simple/Test.hs b/src/Distribution/Simple/Test.hs --- a/src/Distribution/Simple/Test.hs +++ b/src/Distribution/Simple/Test.hs @@ -27,7 +27,7 @@ import qualified Distribution.PackageDescription as PD import Distribution.Pretty -import Distribution.Simple.Build (addInternalBuildToolsFixed) +import Distribution.Simple.Build (addInternalBuildTools) import Distribution.Simple.Compiler import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs @@ -96,8 +96,8 @@ lbi { withPrograms = -- Include any build-tool-depends on build tools internal to the current package. - addInternalBuildToolsFixed - (Just curDir) + addInternalBuildTools + curDir pkg_descr lbi (PD.testBuildInfo suite) diff --git a/src/Distribution/Simple/UHC.hs b/src/Distribution/Simple/UHC.hs --- a/src/Distribution/Simple/UHC.hs +++ b/src/Distribution/Simple/UHC.hs @@ -59,10 +59,9 @@ configure :: Verbosity -> Maybe FilePath - -> Maybe FilePath -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity hcPath _hcPkgPath progdb = do +configure verbosity hcPath progdb = do (_uhcProg, uhcVersion, progdb') <- requireProgramVersion verbosity diff --git a/src/Distribution/Simple/Utils.hs b/src/Distribution/Simple/Utils.hs --- a/src/Distribution/Simple/Utils.hs +++ b/src/Distribution/Simple/Utils.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -9,6 +7,9 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +#ifdef GIT_REV +{-# LANGUAGE TemplateHaskell #-} +#endif ----------------------------------------------------------------------------- @@ -28,6 +29,7 @@ -- various directory and file functions that do extra logging. module Distribution.Simple.Utils ( cabalVersion + , cabalGitInfo -- * logging and errors , dieNoVerbosity @@ -183,6 +185,7 @@ , listUnion , listUnionRight , ordNub + , sortNub , ordNubBy , ordNubRight , safeHead @@ -192,6 +195,7 @@ , unintersperse , wrapText , wrapLine + , stripCommonPrefix -- * FilePath stuff , isAbsoluteOnAnyPlatform @@ -250,6 +254,7 @@ , getDirectoryContents , getModificationTime , getPermissions + , getTemporaryDirectory , removeDirectoryRecursive , removeFile ) @@ -286,6 +291,16 @@ import qualified System.Process as Process import qualified Text.PrettyPrint as Disp +#ifdef GIT_REV +import Data.Either (isLeft) +import GitHash + ( giHash + , giBranch + , giCommitDate + , tGitInfoCwdTry + ) +#endif + -- We only get our own version number when we're building with ourselves cabalVersion :: Version #if defined(BOOTSTRAPPED_CABAL) @@ -296,6 +311,30 @@ cabalVersion = mkVersion [3,0] --used when bootstrapping #endif +-- | +-- `Cabal` Git information. Only filled in if built in a Git tree in +-- development mode and Template Haskell is available. +cabalGitInfo :: String +#ifdef GIT_REV +cabalGitInfo = if giHash' == "" + then "" + else concat [ "(commit " + , giHash' + , branchInfo + , ", " + , either (const "") giCommitDate gi' + , ")" + ] + where + gi' = $$tGitInfoCwdTry + giHash' = take 7 . either (const "") giHash $ gi' + branchInfo | isLeft gi' = "" + | either id giBranch gi' == "master" = "" + | otherwise = " on " <> either id giBranch gi' +#else +cabalGitInfo = "" +#endif + -- ---------------------------------------------------------------------------- -- Exception and logging utils @@ -387,7 +426,7 @@ =<< pure . addErrorPrefix =<< prefixWithProgName msg --- Type which will be a wrapper for cabal -expections and cabal-install exceptions +-- Type which will be a wrapper for cabal -exceptions and cabal-install exceptions data VerboseException a = VerboseException CallStack POSIXTime Verbosity a deriving (Show) @@ -533,7 +572,7 @@ warn :: Verbosity -> String -> IO () warn verbosity msg = warnMessage "Warning" verbosity msg --- | Like 'warn', but prepend @Error: …@ instead of @Waring: …@ before the +-- | Like 'warn', but prepend @Error: …@ instead of @Warning: …@ before the -- the message. Useful when you want to highlight the condition is an error -- but do not want to quit the program yet. warnError :: Verbosity -> String -> IO () @@ -1733,23 +1772,17 @@ -- | Use a temporary filename that doesn't already exist withTempFile - :: FilePath - -- ^ Temp dir to create the file in - -> String + :: String -- ^ File name template. See 'openTempFile'. -> (FilePath -> Handle -> IO a) -> IO a -withTempFile tmpDir template f = withFrozenCallStack $ - withTempFileCwd Nothing (makeSymbolicPath tmpDir) template $ +withTempFile template f = withFrozenCallStack $ + withTempFileCwd template $ \fp h -> f (getSymbolicPath fp) h -- | Use a temporary filename that doesn't already exist. withTempFileCwd - :: Maybe (SymbolicPath CWD (Dir Pkg)) - -- ^ Working directory - -> SymbolicPath Pkg (Dir tmpDir) - -- ^ Temp dir to create the file in - -> String + :: String -- ^ File name template. See 'openTempFile'. -> (SymbolicPath Pkg File -> Handle -> IO a) -> IO a @@ -1758,20 +1791,17 @@ -- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' -- argument. withTempFileEx - :: forall a tmpDir + :: forall a . TempFileOptions - -> Maybe (SymbolicPath CWD (Dir Pkg)) - -- ^ Working directory - -> SymbolicPath Pkg (Dir tmpDir) - -- ^ Temp dir to create the file in -> String -- ^ File name template. See 'openTempFile'. -> (SymbolicPath Pkg File -> Handle -> IO a) -> IO a -withTempFileEx opts mbWorkDir tmpDir template action = +withTempFileEx opts template action = do + tmp <- getTemporaryDirectory withFrozenCallStack $ Exception.bracket - (openTempFile (i tmpDir) template) + (openTempFile tmp template) ( \(name, handle) -> do hClose handle unless (optKeepTempFiles opts) $ @@ -1779,12 +1809,11 @@ removeFile $ name ) - (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg fn) h)) + (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg tmp fn) h)) where - i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path - mkRelToPkg :: FilePath -> SymbolicPath Pkg File - mkRelToPkg fp = - tmpDir makeRelativePathEx (takeFileName fp) + mkRelToPkg :: FilePath -> FilePath -> SymbolicPath Pkg File + mkRelToPkg tmp fp = + makeSymbolicPath tmp makeRelativePathEx (takeFileName fp) -- 'openTempFile' returns a path of the form @i tmpDir fn@, but we -- want 'withTempFileEx' to return @tmpDir fn@. So we split off @@ -2034,3 +2063,10 @@ buildInfoExt :: String buildInfoExt = ".buildinfo" + +-- | @stripCommonPrefix xs ys@ gives you @ys@ without the common prefix with @xs@. +stripCommonPrefix :: String -> String -> String +stripCommonPrefix (x : xs) (y : ys) + | x == y = stripCommonPrefix xs ys + | otherwise = y : ys +stripCommonPrefix _ ys = ys diff --git a/src/Distribution/Types/ComponentLocalBuildInfo.hs b/src/Distribution/Types/ComponentLocalBuildInfo.hs --- a/src/Distribution/Types/ComponentLocalBuildInfo.hs +++ b/src/Distribution/Types/ComponentLocalBuildInfo.hs @@ -5,6 +5,8 @@ ( ComponentLocalBuildInfo (..) , componentIsIndefinite , maybeComponentInstantiatedWith + , maybeComponentCompatPackageKey + , maybeComponentExposedModules ) where import Distribution.Compat.Prelude @@ -125,3 +127,13 @@ maybeComponentInstantiatedWith LibComponentLocalBuildInfo{componentInstantiatedWith = insts} = Just insts maybeComponentInstantiatedWith _ = Nothing + +maybeComponentCompatPackageKey :: ComponentLocalBuildInfo -> Maybe String +maybeComponentCompatPackageKey + LibComponentLocalBuildInfo{componentCompatPackageKey = key} = Just key +maybeComponentCompatPackageKey _ = Nothing + +maybeComponentExposedModules :: ComponentLocalBuildInfo -> Maybe [Installed.ExposedModule] +maybeComponentExposedModules + LibComponentLocalBuildInfo{componentExposedModules = exposed} = Just exposed +maybeComponentExposedModules _ = Nothing diff --git a/src/Distribution/Types/LocalBuildConfig.hs b/src/Distribution/Types/LocalBuildConfig.hs --- a/src/Distribution/Types/LocalBuildConfig.hs +++ b/src/Distribution/Types/LocalBuildConfig.hs @@ -2,8 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} diff --git a/src/Distribution/Types/LocalBuildInfo.hs b/src/Distribution/Types/LocalBuildInfo.hs --- a/src/Distribution/Types/LocalBuildInfo.hs +++ b/src/Distribution/Types/LocalBuildInfo.hs @@ -446,7 +446,7 @@ let -- enable-library-profiling (enable (static profiling way)) .p_o -- enable-shared (enabled dynamic way) .dyn_o - -- enable-profiling-shared (enable dyanmic profilng way) .p_dyn_o + -- enable-profiling-shared (enable dynamic profilng way) .p_dyn_o -- enable-library-vanilla (enable vanilla way) .o -- -- enable-executable-dynamic => build dynamic executables diff --git a/src/Distribution/Utils/IOData.hs b/src/Distribution/Utils/IOData.hs --- a/src/Distribution/Utils/IOData.hs +++ b/src/Distribution/Utils/IOData.hs @@ -80,7 +80,7 @@ -- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose' -- --- This is the dual operation ot 'hGetIODataContents', +-- This is the dual operation to 'hGetIODataContents', -- and consequently the handle is closed with `hClose`. -- -- /Note:/ this performs lazy-IO. diff --git a/src/Distribution/Utils/LogProgress.hs b/src/Distribution/Utils/LogProgress.hs --- a/src/Distribution/Utils/LogProgress.hs +++ b/src/Distribution/Utils/LogProgress.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} module Distribution.Utils.LogProgress