diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,7 +1,7 @@ -cabal-version: 3.6 +cabal-version: 3.8 name: Cabal -version: 3.16.1.0 -copyright: 2003-2025, Cabal Development Team (see AUTHORS file) +version: 3.18.1.0 +copyright: 2003-2026, Cabal Development Team (see AUTHORS file) license: BSD-3-Clause license-file: LICENSE author: Cabal Development Team @@ -13,7 +13,7 @@ The Haskell Common Architecture for Building Applications and Libraries: a framework defining a common interface for authors to more easily build their Haskell applications in a portable way. - . + The Haskell Cabal is part of a larger infrastructure for distributing, organizing, and cataloging Haskell libraries and tools. category: Distribution @@ -39,25 +39,29 @@ hs-source-dirs: src build-depends: - , Cabal-syntax ^>= 3.16.1.0 + , Cabal-syntax ^>= 3.18 , 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 + , base >= 4.17 && < 5 + , bytestring >= 0.10.8 && < 0.13 + , containers >= 0.5.8.2 && < 0.9 + , deepseq >= 1.4 && < 1.7 + , directory >= 1.2.7 && < 1.4 + , filepath >= 1.4.2 && < 1.6 , pretty >= 1.1.1 && < 1.2 - , process >= 1.2.1.0 && < 1.7 - , time >= 1.4.0.1 && < 1.16 + , process >= 1.6.20.0 && < 1.6.24 || == 1.6.26.0 || >= 1.6.26.2 && < 1.7 + , time >= 1.4.0.1 && < 1.17 if os(windows) build-depends: - , Win32 >= 2.3.0.0 && < 2.15 + , Win32 >= 2.4.0.0 && < 2.15 else build-depends: , unix >= 2.8.6.0 && < 2.9 + if os(darwin) + build-depends: + , process >= 1.6.29.0 + if flag(git-rev) build-depends: , githash ^>= 0.1.7.0 @@ -77,6 +81,9 @@ if impl(ghc >= 8.0) && impl(ghc < 8.8) ghc-options: -Wnoncanonical-monadfail-instances + if impl(ghc >= 9.14) + ghc-options: -Wno-pattern-namespace-specifier -Wno-incomplete-record-selectors + exposed-modules: Distribution.Backpack.Configure Distribution.Backpack.ComponentsGraph @@ -91,16 +98,14 @@ Distribution.Utils.LogProgress Distribution.Utils.MapAccum Distribution.Compat.CreatePipe - Distribution.Compat.Directory Distribution.Compat.Environment - Distribution.Compat.FilePath Distribution.Compat.Internal.TempFile Distribution.Compat.ResponseFile Distribution.Compat.Prelude.Internal Distribution.Compat.Process Distribution.Compat.Stack + Distribution.Compat.SysInfo Distribution.Compat.Time - Distribution.Make Distribution.PackageDescription.Check Distribution.ReadE Distribution.Simple @@ -162,6 +167,7 @@ Distribution.Simple.UHC Distribution.Simple.UserHooks Distribution.Simple.SetupHooks.Errors + Distribution.Simple.SetupHooks.HooksMain Distribution.Simple.SetupHooks.Internal Distribution.Simple.SetupHooks.Rule Distribution.Simple.Utils @@ -194,7 +200,6 @@ Distribution.Compat.Exception, Distribution.Compat.Graph, Distribution.Compat.Lens, - Distribution.Compat.MonadFail, Distribution.Compat.Newtype, Distribution.Compat.NonEmptySet, Distribution.Compat.Parsing, @@ -328,9 +333,7 @@ -- Parsec parser-related modules 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) + , transformers >= 0.5.6 && < 0.7 , mtl >= 2.1 && < 2.4 , parsec >= 3.1.13.0 && < 3.2 @@ -345,7 +348,6 @@ Distribution.Compat.Async Distribution.Compat.CopyFile Distribution.Compat.GetShortPathName - Distribution.Compat.SnocList Distribution.GetOpt Distribution.Lex Distribution.PackageDescription.Check.Common diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,6 @@ +# 3.18.1.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) July 2026 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.18.1.0.md + # 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 @@ -589,7 +592,7 @@ * Support module thinning and renaming (#2038). * Add a new license type: UnspecifiedLicense (#2141). * Remove support for Hugs and nhc98 (#2168). - * Invoke `tar` with `--formar ustar` if possible in `sdist` (#1903). + * Invoke `tar` with `--format ustar` if possible in `sdist` (#1903). * Replace `--enable-library-coverage` with `--enable-coverage`, which enables program coverage for all components (#1945). * Suggest that `ExitFailure 9` is probably due to memory diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2025, Cabal Development Team. +Copyright (c) 2003-2026, 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 @@ -31,6 +31,7 @@ import Distribution.InstalledPackageInfo ( InstalledPackageInfo , emptyInstalledPackageInfo + , requiredSignatures ) import qualified Distribution.InstalledPackageInfo as Installed import Distribution.ModuleName @@ -261,6 +262,19 @@ packageDependsIndex = PackageIndex.fromList (lefts local_graph) fullIndex = Graph.fromDistinctList local_graph + let + -- Map from dependency UnitId to its PackageId, built from includes + -- of all ready components. Used to resolve opaque hashed UnitIds + -- in broken-package error messages. + depPkgMap :: Map UnitId PackageId + depPkgMap = + Map.fromList + [ (unDefUnitId (ci_id ci), ci_pkgid ci) + | rc <- graph + , Right instc <- [rc_i rc] + , ci <- instc_includes instc + ] + case Graph.broken fullIndex of [] -> return () -- If there are promised dependencies, we don't know what the dependencies @@ -270,26 +284,33 @@ broken | not (null promisedPkgDeps) -> return () | otherwise -> - -- TODO: ppr this - dieProgress . text $ - "The following packages are broken because other" - ++ " packages they depend on are missing. These broken " - ++ "packages must be rebuilt before they can be used.\n" - -- TODO: Undupe. - ++ unlines - [ "installed package " - ++ prettyShow (packageId pkg) - ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) - | (Left pkg, deps) <- broken - ] - ++ unlines - [ "planned package " - ++ prettyShow (packageId pkg) - ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) - | (Right pkg, deps) <- broken - ] + dieProgress $ + text "The following packages are broken because other" + <+> text "packages they depend on are missing. These broken" + <+> text "packages must be rebuilt before they can be used." + $$ nest + 2 + ( vcat $ + [ hang + (text "installed package" <+> pretty (packageId pkg)) + 4 + ( text "is broken due to missing package" + <+> hsep (punctuate comma (map pretty deps)) + ) + | (Left pkg, deps) <- broken + ] + ++ [ hang + (text "planned package" <+> pretty (packageId pkg)) + 4 + ( vcat $ + text "is broken due to missing package" + : [ nest 2 (dispMissingDep installedPackageSet depPkgMap dep) + | dep <- deps + ] + ) + | (Right pkg, deps) <- broken + ] + ) -- In this section, we'd like to look at the 'packageDependsIndex' -- and see if we've picked multiple versions of the same @@ -338,6 +359,48 @@ -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps) return (clbis, packageDependsIndex) +-- | Pretty-print a missing dependency, resolving opaque hashed 'UnitId's +-- to their human-readable package id and signature info when possible. +-- +-- When an indefinite Backpack package is installed separately (e.g. via +-- nix callCabal2nix), only the indefinite variant (with unfilled signatures) +-- exists in the package DB. The consumer needs an instantiated variant +-- which was never built. The fix is to add both packages to the same +-- cabal project so cabal can fill the signatures. +dispMissingDep + :: InstalledPackageIndex + -- ^ all installed packages + -> Map UnitId PackageId + -- ^ dep UnitId to its PackageId (from includes) + -> UnitId + -- ^ the missing dependency + -> Doc +dispMissingDep installedPkgSet depPkgMap uid = + case Map.lookup uid depPkgMap of + Just pkgid -> + let ipiSigs = + [ sigs + | ipi <- PackageIndex.lookupSourcePackageId installedPkgSet pkgid + , let sigs = requiredSignatures ipi + , not (Set.null sigs) + ] + in case ipiSigs of + (sigs : _) -> + pretty pkgid + <+> parens + ( text "has unfilled" + <+> (if Set.size sigs > 1 then text "signatures:" else text "signature:") + <+> hsep (punctuate comma (map pretty (Set.toList sigs))) + ) + $$ nest + 2 + ( text "The package is installed as indefinite." + $$ text "To use it, rebuild it in the same cabal project as the" + <+> text "consumer so cabal can fill the signatures." + ) + [] -> pretty pkgid <+> parens (pretty uid) + Nothing -> pretty uid + -- Build ComponentLocalBuildInfo for each component we are going -- to build. -- @@ -353,7 +416,7 @@ go rc = case rc_component rc of CLib lib -> - let convModuleExport (modname', (Module uid modname)) + let convModuleExport (modname', Module uid modname) | this_uid == unDefUnitId uid , modname' == modname = Installed.ExposedModule modname' Nothing 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 @@ -83,7 +83,7 @@ (text "component" <+> pretty (cc_cid cc)) 4 ( vcat - [ hsep $ + [ hsep [ text "include" , pretty (ci_id incl) , pretty (ci_renaming incl) diff --git a/src/Distribution/Backpack/LinkedComponent.hs b/src/Distribution/Backpack/LinkedComponent.hs --- a/src/Distribution/Backpack/LinkedComponent.hs +++ b/src/Distribution/Backpack/LinkedComponent.hs @@ -161,9 +161,7 @@ lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) lookupUid cid = - fromMaybe - (error "linkComponent: lookupUid") - (Map.lookup cid pkg_map) + Map.findWithDefault (error "linkComponent: lookupUid") cid pkg_map let orErr (Right x) = return x orErr (Left [err]) = dieProgress err @@ -260,7 +258,17 @@ hang (text "Non-library component has unfilled requirements:") 4 - (vcat [pretty req | req <- Set.toList reqs]) + ( vcat + [ case Map.lookup req (modScopeRequires linked_shape0) of + Just srcs@(_ : _) -> + hang + (pretty req) + 4 + (vcat [text "brought into scope by" <+> dispModuleSource (getSource src) | src <- srcs]) + _ -> pretty req + | req <- Set.toList reqs + ] + ) -- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg -- won't allow it (since someone could directly synthesize @@ -290,7 +298,7 @@ (text "Problem with module re-exports:") 2 (vcat [hang (text "-") 2 l | l <- ls]) - reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do + reexports_list <- hdl . flip map src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do case Map.lookup from (modScopeProvides linked_shape) of Just cands@(x0 : xs0) -> do -- Make sure there is at least one candidate @@ -331,7 +339,7 @@ -- TODO: doublecheck we have checked for -- src_provs duplicates already! -- These are normal module exports. - [(mod_name, (OpenModule this_uid mod_name)) | mod_name <- src_provs] + [(mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs] ++ -- These are reexports, which we managed to resolve to something in an external package. [(mn_new, om) | (mn_new, Just om) <- reexports_list] @@ -373,7 +381,7 @@ , lc_component = component , lc_public = is_public , -- These must be executables - lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps + lc_exe_deps = map (fmap (`IndefFullUnitId` Map.empty)) exe_deps , lc_shape = final_linked_shape , lc_includes = linked_includes , lc_sig_includes = linked_sig_includes diff --git a/src/Distribution/Backpack/MixLink.hs b/src/Distribution/Backpack/MixLink.hs --- a/src/Distribution/Backpack/MixLink.hs +++ b/src/Distribution/Backpack/MixLink.hs @@ -115,10 +115,9 @@ reqs_doc | null reqs = dispModuleSource (getSource req) | otherwise = - ( text " " - <+> dispModuleSource (getSource req) - $$ vcat [text "and" <+> dispModuleSource (getSource r) | r <- reqs] - ) + text " " + <+> dispModuleSource (getSource req) + $$ vcat [text "and" <+> dispModuleSource (getSource r) | r <- reqs] linkProvision _ _ _ = error "linkProvision" ----------------------------------------------------------------------- diff --git a/src/Distribution/Backpack/ReadyComponent.hs b/src/Distribution/Backpack/ReadyComponent.hs --- a/src/Distribution/Backpack/ReadyComponent.hs +++ b/src/Distribution/Backpack/ReadyComponent.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -- | See @@ -210,7 +211,7 @@ in (f x, s') instance Applicative InstM where - pure a = InstM $ \s -> (a, s) + pure a = InstM (a,) InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s (x', s'') = x s' @@ -402,11 +403,9 @@ -- Top-level instantiation per subst0 | not (Map.null subst0) , [lc] <- filter lc_public (Map.elems cmap) = - do - _ <- instantiateUnitId (lc_cid lc) subst0 - return () + void $ instantiateUnitId (lc_cid lc) subst0 | otherwise = forM_ (Map.elems cmap) $ \lc -> if null (lc_insts lc) - then instantiateUnitId (lc_cid lc) Map.empty >> return () - else indefiniteUnitId (lc_cid lc) >> return () + then void $ instantiateUnitId (lc_cid lc) Map.empty + else void $ indefiniteUnitId (lc_cid lc) diff --git a/src/Distribution/Backpack/UnifyM.hs b/src/Distribution/Backpack/UnifyM.hs --- a/src/Distribution/Backpack/UnifyM.hs +++ b/src/Distribution/Backpack/UnifyM.hs @@ -186,7 +186,7 @@ failIfErrs = do env <- getUnifEnv errs <- liftST $ readSTRef (unify_errs env) - when (not (null errs)) failM + unless (null errs) failM tryM :: UnifyM s a -> UnifyM s (Maybe a) tryM m = @@ -535,9 +535,7 @@ <+> vcat (map pretty (v : vs)) return v - let req_rename_fn k = case Map.lookup k req_rename of - Nothing -> k - Just v -> v + let req_rename_fn k = Map.findWithDefault k k req_rename -- Requirement substitution. -- diff --git a/src/Distribution/Compat/CopyFile.hs b/src/Distribution/Compat/CopyFile.hs --- a/src/Distribution/Compat/CopyFile.hs +++ b/src/Distribution/Compat/CopyFile.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} +{- HLINT ignore "Use fewer imports" -} + module Distribution.Compat.CopyFile ( copyFile , copyFileChanged @@ -15,23 +17,29 @@ import Distribution.Compat.Prelude import Prelude () -#ifndef mingw32_HOST_OS -import Distribution.Compat.Internal.TempFile +import qualified Data.ByteString.Lazy as BSL +import System.Directory + ( doesFileExist + ) +import System.IO + ( IOMode (ReadMode) + , hFileSize + , withBinaryFile + ) +#ifndef mingw32_HOST_OS import Control.Exception ( bracketOnError ) -import qualified Data.ByteString.Lazy as BSL import Data.Bits ( (.|.) ) import System.IO.Error ( ioeSetLocation ) import System.Directory - ( doesFileExist, renameFile, removeFile ) + ( renameFile, removeFile ) import System.FilePath ( takeDirectory ) import System.IO - ( IOMode(ReadMode), hClose, hGetBuf, hPutBuf, hFileSize - , withBinaryFile ) + ( hClose, hGetBuf, hPutBuf, openBinaryTempFile ) import Foreign ( allocaBytes ) @@ -42,28 +50,9 @@ #else /* else mingw32_HOST_OS */ -import qualified Data.ByteString.Lazy as BSL -import System.IO.Error - ( ioeSetLocation ) import System.Directory - ( doesFileExist ) -import System.FilePath - ( addTrailingPathSeparator - , hasTrailingPathSeparator - , isPathSeparator - , isRelative - , joinDrive - , joinPath - , pathSeparator - , pathSeparators - , splitDirectories - , splitDrive - ) -import System.IO - ( IOMode(ReadMode), hFileSize - , withBinaryFile ) + ( copyFileWithMetadata ) -import qualified System.Win32.File as Win32 ( copyFile ) #endif /* mingw32_HOST_OS */ copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO () @@ -91,11 +80,11 @@ -- | Copies a file to a new destination. -- Often you should use `copyFileChanged` instead. copyFile :: FilePath -> FilePath -> IO () +#ifndef mingw32_HOST_OS copyFile fromFPath toFPath = copy `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile")) where -#ifndef mingw32_HOST_OS copy = withBinaryFile fromFPath ReadMode $ \hFrom -> bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> do allocaBytes bufferSize $ copyContents hFrom hTmp @@ -113,116 +102,7 @@ hPutBuf hTo buffer count copyContents hFrom hTo buffer #else - copy = Win32.copyFile (toExtendedLengthPath fromFPath) - (toExtendedLengthPath toFPath) - False - --- NOTE: Shamelessly lifted from System.Directory.Internal.Windows - --- | Add the @"\\\\?\\"@ prefix if necessary or possible. The path remains --- unchanged if the prefix is not added. This function can sometimes be used --- to bypass the @MAX_PATH@ length restriction in Windows API calls. --- --- See Note [Path normalization]. -toExtendedLengthPath :: FilePath -> FilePath -toExtendedLengthPath path - | isRelative path = path - | otherwise = - case normalisedPath of - '\\' : '?' : '?' : '\\' : _ -> normalisedPath - '\\' : '\\' : '?' : '\\' : _ -> normalisedPath - '\\' : '\\' : '.' : '\\' : _ -> normalisedPath - '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath - _ -> "\\\\?\\" <> normalisedPath - where normalisedPath = simplifyWindows path - --- | Similar to 'normalise' but: --- --- * empty paths stay empty, --- * parent dirs (@..@) are expanded, and --- * paths starting with @\\\\?\\@ are preserved. --- --- The goal is to preserve the meaning of paths better than 'normalise'. --- --- Note [Path normalization] --- 'normalise' doesn't simplify path names but will convert / into \\ --- this would normally not be a problem as once the path hits the RTS we would --- have simplified the path then. However since we're calling the WIn32 API --- directly we have to do the simplification before the call. Without this the --- path Z:// would become Z:\\\\ and when converted to a device path the path --- becomes \\?\Z:\\\\ which is an invalid path. --- --- This is not a bug in normalise as it explicitly states that it won't simplify --- a FilePath. -simplifyWindows :: FilePath -> FilePath -simplifyWindows "" = "" -simplifyWindows path = - case drive' of - "\\\\?\\" -> drive' <> subpath - _ -> simplifiedPath - where - simplifiedPath = joinDrive drive' subpath' - (drive, subpath) = splitDrive path - drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive)) - subpath' = appendSep . avoidEmpty . prependSep . joinPath . - stripPardirs . expandDots . skipSeps . - splitDirectories $ subpath - - upperDrive d = case d of - c : ':' : s | isAlpha c && all isPathSeparator s -> toUpper c : ':' : s - _ -> d - skipSeps = filter (not . (`elem` (pure <$> pathSeparators))) - stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..") - | otherwise = id - prependSep | subpathIsAbsolute = (pathSeparator :) - | otherwise = id - avoidEmpty | not pathIsAbsolute - && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:." - = emptyToCurDir - | otherwise = id - appendSep p | hasTrailingPathSep - && not (pathIsAbsolute && null p) - = addTrailingPathSeparator p - | otherwise = p - pathIsAbsolute = not (isRelative path) - subpathIsAbsolute = any isPathSeparator (take 1 subpath) - hasTrailingPathSep = hasTrailingPathSeparator subpath - --- | Given a list of path segments, expand @.@ and @..@. The path segments --- must not contain path separators. -expandDots :: [FilePath] -> [FilePath] -expandDots = reverse . go [] - where - go ys' xs' = - case xs' of - [] -> ys' - x : xs -> - case x of - "." -> go ys' xs - ".." -> - case ys' of - [] -> go (x : ys') xs - ".." : _ -> go (x : ys') xs - _ : ys -> go ys xs - _ -> go (x : ys') xs - --- | Convert to the right kind of slashes. -normalisePathSeps :: FilePath -> FilePath -normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p - --- | Remove redundant trailing slashes and pick the right kind of slash. -normaliseTrailingSep :: FilePath -> FilePath -normaliseTrailingSep path = do - let path' = reverse path - let (sep, path'') = span isPathSeparator path' - let addSep = if null sep then id else (pathSeparator :) - reverse (addSep path'') - --- | Convert empty paths to the current directory, otherwise leave it --- unchanged. -emptyToCurDir :: FilePath -> FilePath -emptyToCurDir "" = "." -emptyToCurDir path = path +copyFile = copyFileWithMetadata #endif /* mingw32_HOST_OS */ -- | Like `copyFile`, but does not touch the target if source and destination diff --git a/src/Distribution/Compat/Directory.hs b/src/Distribution/Compat/Directory.hs deleted file mode 100644 --- a/src/Distribution/Compat/Directory.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Distribution.Compat.Directory - ( listDirectory - , makeAbsolute - , doesPathExist - ) where - -#if MIN_VERSION_directory(1,2,7) -import System.Directory as Dir hiding (doesPathExist) -import System.Directory (doesPathExist) -#else -import System.Directory as Dir -#endif -#if !MIN_VERSION_directory(1,2,2) -import System.FilePath as Path -#endif - -#if !MIN_VERSION_directory(1,2,5) - -listDirectory :: FilePath -> IO [FilePath] -listDirectory path = - filter f `fmap` Dir.getDirectoryContents path - where f filename = filename /= "." && filename /= ".." - -#endif - -#if !MIN_VERSION_directory(1,2,2) - -makeAbsolute :: FilePath -> IO FilePath -makeAbsolute p | Path.isAbsolute p = return p - | otherwise = do - cwd <- Dir.getCurrentDirectory - return $ cwd p - -#endif - -#if !MIN_VERSION_directory(1,2,7) - -doesPathExist :: FilePath -> IO Bool -doesPathExist path = do - -- not using Applicative, as this way we can do less IO - e <- doesDirectoryExist path - if e - then return True - else doesFileExist path - -#endif 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 @@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} module Distribution.Compat.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv) @@ -8,22 +6,10 @@ import Distribution.Compat.Prelude import Prelude () -import qualified Prelude import System.Environment (lookupEnv, unsetEnv) import qualified System.Environment as System - -import Distribution.Compat.Stack - -#ifdef mingw32_HOST_OS -import Foreign.C -import GHC.Windows -#else -import Foreign.C.Types -import Foreign.C.String -import Foreign.C.Error (throwErrnoIfMinus1_) -import System.Posix.Internals ( withFilePath ) -#endif /* mingw32_HOST_OS */ +import qualified System.Environment.Blank as Blank (setEnv) getEnvironment :: IO [(String, String)] #ifdef mingw32_HOST_OS @@ -39,48 +25,5 @@ #endif -- | @setEnv name value@ sets the specified environment variable to @value@. --- --- Throws `Control.Exception.IOException` if either @name@ or @value@ is the --- empty string or contains an equals sign. setEnv :: String -> String -> IO () -setEnv key value_ = setEnv_ key value - where - -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We - -- still strip it manually so that the null check above succeeds if a value - -- starts with NUL. - value = takeWhile (/= '\NUL') value_ - -setEnv_ :: String -> String -> IO () - -#ifdef mingw32_HOST_OS - -setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do - success <- c_SetEnvironmentVariable k v - unless success (throwGetLastError "setEnv") - where - _ = callStack -- TODO: attach CallStack to exception - -{- FOURMOLU_DISABLE -} -# if defined(i386_HOST_ARCH) -# define WINDOWS_CCONV stdcall -# elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) -# define WINDOWS_CCONV ccall -# else -# error Unknown mingw32 arch -# endif /* i386_HOST_ARCH */ - -foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW" - c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> Prelude.IO Bool -#else -setEnv_ key value = do - withFilePath key $ \ keyP -> - withFilePath value $ \ valueP -> - throwErrnoIfMinus1_ "setenv" $ - c_setenv keyP valueP (fromIntegral (fromEnum True)) - where - _ = callStack -- TODO: attach CallStack to exception - -foreign import ccall unsafe "setenv" - c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt -#endif /* mingw32_HOST_OS */ -{- FOURMOLU_ENABLE -} +setEnv key value = Blank.setEnv key value True diff --git a/src/Distribution/Compat/FilePath.hs b/src/Distribution/Compat/FilePath.hs deleted file mode 100644 --- a/src/Distribution/Compat/FilePath.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} - -module Distribution.Compat.FilePath - ( isExtensionOf - , stripExtension - ) where - -import Data.List (isSuffixOf, stripPrefix) -import System.FilePath - -#if !MIN_VERSION_filepath(1,4,2) -isExtensionOf :: String -> FilePath -> Bool -isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions -isExtensionOf ext = isSuffixOf ('.':ext) . takeExtensions -#endif - -#if !MIN_VERSION_filepath(1,4,1) -stripExtension :: String -> FilePath -> Maybe FilePath -stripExtension [] path = Just path -stripExtension ext@(x:_) path = stripSuffix dotExt path - where - dotExt = if isExtSeparator x then ext else '.':ext - stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] - stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys) -#endif diff --git a/src/Distribution/Compat/GetShortPathName.hs b/src/Distribution/Compat/GetShortPathName.hs --- a/src/Distribution/Compat/GetShortPathName.hs +++ b/src/Distribution/Compat/GetShortPathName.hs @@ -1,56 +1,29 @@ {-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ - --- | --- Module : Distribution.Compat.GetShortPathName +-- | Win32 API 'GetShortPathName' function, which returns MS DOS short path name +-- (up to 8 characters for file name + 3 for file extension). -- --- Maintainer : cabal-devel@haskell.org --- Portability : Windows-only +-- What's going on here? Why do we care about MS DOS? +-- In practice the short name serves as an alternative name, +-- which does not contain spaces even if the original name does. +-- Some applications (including certain versions of Autoconf) do not like +-- spaces in filenames, so getting a short path name gives us +-- a chance to work around it. That's not bullet proof though: +-- some objects might not have a short name. -- --- Win32 API 'GetShortPathName' function. +-- Writing this comment in 2026, I don't know whether the aforementioned +-- issue with Autoconf and spaces remains relevant. It's possible +-- that things have improved during the last 10 years +-- since https://github.com/haskell/cabal/issues/3185 was merged. +-- +-- Compare to the similar functionality in Stack: +-- https://hackage.haskell.org/package/stack-3.3.1/docs/src/Stack.Config.html#local-6989586621679973356 module Distribution.Compat.GetShortPathName (getShortPathName) where -import Distribution.Compat.Prelude -import Prelude () - #ifdef mingw32_HOST_OS -import qualified Prelude -import qualified System.Win32 as Win32 -import System.Win32 (LPCTSTR, LPTSTR, DWORD) -import Foreign.Marshal.Array (allocaArray) - -{- FOURMOLU_DISABLE -} -#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) -#define WINAPI ccall -#else -#define WINAPI stdcall -#endif - -foreign import WINAPI unsafe "windows.h GetShortPathNameW" - c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> Prelude.IO DWORD - --- | On Windows, retrieves the short path form of the specified path. On --- non-Windows, does nothing. See https://github.com/haskell/cabal/issues/3185. --- --- From MS's GetShortPathName docs: --- --- Passing NULL for [the second] parameter and zero for cchBuffer --- will always return the required buffer size for a --- specified lpszLongPath. --- -getShortPathName :: FilePath -> IO FilePath -getShortPathName path = - Win32.withTString path $ \c_path -> do - c_len <- Win32.failIfZero "GetShortPathName #1 failed!" $ - c_GetShortPathName c_path Win32.nullPtr 0 - let arr_len = fromIntegral c_len - allocaArray arr_len $ \c_out -> do - void $ Win32.failIfZero "GetShortPathName #2 failed!" $ - c_GetShortPathName c_path c_out c_len - Win32.peekTString c_out +import System.Win32.Info (getShortPathName) #else @@ -58,4 +31,3 @@ getShortPathName path = return path #endif -{- FOURMOLU_ENABLE -} 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 @@ -10,10 +10,11 @@ import Distribution.Compat.Exception +import GHC.IORef (IORef, atomicModifyIORef'_, newIORef) import System.FilePath (()) - import System.IO (Handle, openBinaryTempFile, openBinaryTempFileWithDefaultPermissions, openTempFile) import System.IO.Error (isAlreadyExistsError) +import System.IO.Unsafe (unsafePerformIO) import System.Posix.Internals (c_getpid) #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) @@ -28,17 +29,21 @@ createTempDirectory :: FilePath -> String -> IO FilePath createTempDirectory dir template = do pid <- c_getpid - findTempName pid - where - findTempName x = do - let relpath = template ++ "-" ++ show x - dirpath = dir relpath - r <- tryIO $ mkPrivateDir dirpath - case r of - Right _ -> return relpath - Left e - | isAlreadyExistsError e -> findTempName (x + 1) - | otherwise -> ioError e + let findTempName = do + (counter, _) <- atomicModifyIORef'_ tempDirectoryCounter (+ 1) + let relpath = template ++ "-" ++ show pid ++ show counter + dirpath = dir relpath + r <- tryIO $ mkPrivateDir dirpath + case r of + Right _ -> pure relpath + Left e + | isAlreadyExistsError e -> findTempName + | otherwise -> ioError e + findTempName + +tempDirectoryCounter :: IORef Word +tempDirectoryCounter = unsafePerformIO $ newIORef 0 +{-# NOINLINE tempDirectoryCounter #-} mkPrivateDir :: String -> IO () #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) diff --git a/src/Distribution/Compat/ResponseFile.hs b/src/Distribution/Compat/ResponseFile.hs --- a/src/Distribution/Compat/ResponseFile.hs +++ b/src/Distribution/Compat/ResponseFile.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - --- Compatibility layer for GHC.ResponseFile --- Implementation from base 4.12.0 is used. --- http://hackage.haskell.org/package/base-4.12.0.0/src/LICENSE module Distribution.Compat.ResponseFile (expandResponse, escapeArgs) where import Distribution.Compat.Prelude @@ -16,12 +10,12 @@ import System.IO (hPutStrLn, stderr) import System.IO.Error --- | The arg file / response file parser. --- --- This is not a well-documented capability, and is a bit eccentric --- (try @cabal \@foo \@bar@ to see what that does), but is crucial --- for allowing complex arguments to cabal and cabal-install when --- using command prompts with strongly-limited argument length. +-- | This is a more elaborate version of 'GHC.ResponseFile.expandResponse', +-- which not only substitute @\@foo@ with the contents of file @foo@, +-- but performs such substitution recursively. +-- In doing so we keep closer to the reference implementation +-- of @expandargv@ in @argv.c@ from @binutils@, although this additional functionality +-- likely remains unused by Haskell tooling. expandResponse :: [String] -> IO [String] expandResponse = go recursionLimit "." where @@ -33,8 +27,8 @@ | otherwise = const $ hPutStrLn stderr "Error: response file recursion limit exceeded." >> exitFailure expand :: Int -> FilePath -> String -> IO [String] - expand n dir arg@('@' : f) = readRecursively n (dir f) `catchIOError` const (print "?" >> return [arg]) + expand n dir arg@('@' : f) = readRecursively n (dir f) `catchIOError` const (return [arg]) expand _n _dir x = return [x] readRecursively :: Int -> FilePath -> IO [String] - readRecursively n f = go (n - 1) (takeDirectory f) =<< unescapeArgs <$> readFile f + readRecursively n f = go (n - 1) (takeDirectory f) . unescapeArgs =<< readFile f diff --git a/src/Distribution/Compat/SnocList.hs b/src/Distribution/Compat/SnocList.hs deleted file mode 100644 --- a/src/Distribution/Compat/SnocList.hs +++ /dev/null @@ -1,34 +0,0 @@ ------------------------------------------------------------------------------ - --- | --- Module : Distribution.Compat.SnocList --- License : BSD3 --- --- Maintainer : cabal-dev@haskell.org --- Stability : experimental --- Portability : portable --- --- A very reversed list. Has efficient `snoc` -module Distribution.Compat.SnocList - ( SnocList - , runSnocList - , snoc - ) where - -import Distribution.Compat.Prelude -import Prelude () - -newtype SnocList a = SnocList [a] - -snoc :: SnocList a -> a -> SnocList a -snoc (SnocList xs) x = SnocList (x : xs) - -runSnocList :: SnocList a -> [a] -runSnocList (SnocList xs) = reverse xs - -instance Semigroup (SnocList a) where - SnocList xs <> SnocList ys = SnocList (ys <> xs) - -instance Monoid (SnocList a) where - mempty = SnocList [] - mappend = (<>) diff --git a/src/Distribution/Compat/Stack.hs b/src/Distribution/Compat/Stack.hs --- a/src/Distribution/Compat/Stack.hs +++ b/src/Distribution/Compat/Stack.hs @@ -4,7 +4,6 @@ module Distribution.Compat.Stack ( WithCallStack , CallStack - , annotateCallStackIO , withFrozenCallStack , withLexicalCallStack , callStack @@ -13,15 +12,13 @@ ) where import GHC.Stack -import System.IO.Error type WithCallStack a = HasCallStack => a -- | Give the *parent* of the person who invoked this; -- so it's most suitable for being called from a utility function. -- You probably want to call this using 'withFrozenCallStack'; otherwise --- it's not very useful. We didn't implement this for base-4.8.1 --- because we cannot rely on freezing to have taken place. +-- it's not very useful. parentSrcLocPrefix :: WithCallStack String parentSrcLocPrefix = case getCallStack callStack of @@ -37,18 +34,3 @@ withLexicalCallStack f = let stk = ?callStack in \x -> let ?callStack = stk in f x - --- | This function is for when you *really* want to add a call --- stack to raised IO, but you don't have a --- 'Distribution.Verbosity.Verbosity' so you can't use --- 'Distribution.Simple.Utils.annotateIO'. If you have a 'Verbosity', --- please use that function instead. -annotateCallStackIO :: WithCallStack (IO a -> IO a) -annotateCallStackIO = modifyIOError f - where - f ioe = - ioeSetErrorString ioe - . wrapCallStack - $ ioeGetErrorString ioe - wrapCallStack s = - prettyCallStack callStack ++ "\n" ++ s diff --git a/src/Distribution/Compat/SysInfo.hs b/src/Distribution/Compat/SysInfo.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Compat/SysInfo.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE CPP #-} + +module Distribution.Compat.SysInfo + ( fullCompilerVersion + ) where + +import Data.Version (Version) +import qualified System.Info as SI + +fullCompilerVersion :: Version +#if MIN_VERSION_base(4,15,0) +fullCompilerVersion = SI.fullCompilerVersion +#else +fullCompilerVersion = SI.compilerVersion +#endif 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 @@ -1,17 +1,11 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Compat.Time - ( ModTime (..) -- Needed for testing + ( ModTime , getModTime , getFileAge , getCurTime - , posixSecondsToModTime - , calibrateMtimeChangeDelay ) where @@ -20,39 +14,10 @@ import System.Directory (getModificationTime) -import Distribution.Simple.Utils (withTempDirectoryCwd) -import Distribution.Utils.Path (getSymbolicPath, sameDirectory) -import Distribution.Verbosity (silent) - -import System.FilePath - import Data.Time (diffUTCTime, getCurrentTime) -import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixDayLength) - -#if defined mingw32_HOST_OS - -import qualified Prelude -import Data.Bits ((.|.), unsafeShiftL) -import Data.Bits (finiteBitSize) - -import Foreign ( allocaBytes, peekByteOff ) -import System.IO.Error ( mkIOError, doesNotExistErrorType ) -import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString ) - -#else - -import System.Posix.Files - ( FileStatus, getFileStatus -#if MIN_VERSION_unix(2,6,0) - , modificationTimeHiRes -#else - , modificationTime -#endif - ) - -#endif +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixDayLength, utcTimeToPOSIXSeconds) --- | An opaque type representing a file's modification time, represented +-- | File's modification time, represented -- internally as a 64-bit unsigned integer in the Windows UTC format. newtype ModTime = ModTime Word64 deriving (Binary, Generic, Bounded, Eq, Ord) @@ -65,83 +30,14 @@ instance Read ModTime where readsPrec p str = map (first ModTime) (readsPrec p str) --- | Return modification time of the given file. Works around the low clock --- resolution problem that 'getModificationTime' has on GHC < 7.8. --- --- This is a modified version of the code originally written for Shake by Neil --- Mitchell. See module Development.Shake.FileInfo. +-- | Return modification time of the given file. getModTime :: FilePath -> IO ModTime - -#if defined mingw32_HOST_OS - --- Directly against the Win32 API. -getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do - res <- getFileAttributesEx path info - if not res - then do - let err = mkIOError doesNotExistErrorType - "Distribution.Compat.Time.getModTime" - Nothing (Just path) - ioError err - else do - dwLow <- peekByteOff info - index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime - dwHigh <- peekByteOff info - index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime - let qwTime = - (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh) - .|. (fromIntegral (dwLow :: DWORD)) - return $! ModTime (qwTime :: Word64) - -{- FOURMOLU_DISABLE -} -#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) -#define CALLCONV ccall -#else -#define CALLCONV stdcall -#endif - -foreign import CALLCONV "windows.h GetFileAttributesExW" - c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> Prelude.IO BOOL - -getFileAttributesEx :: String -> LPVOID -> IO BOOL -getFileAttributesEx path lpFileInformation = - withTString path $ \c_path -> - c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation - -getFileExInfoStandard :: Int32 -getFileExInfoStandard = 0 - -size_WIN32_FILE_ATTRIBUTE_DATA :: Int -size_WIN32_FILE_ATTRIBUTE_DATA = 36 - -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20 - -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int -index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24 - -#else - --- Directly against the unix library. -getModTime path = do - st <- getFileStatus path - return $! (extractFileTime st) - -extractFileTime :: FileStatus -> ModTime -extractFileTime x = posixTimeToModTime (modificationTimeHiRes x) - -#endif -{- FOURMOLU_ENABLE -} +getModTime = fmap (posixTimeToModTime . utcTimeToPOSIXSeconds) . getModificationTime windowsTick, secToUnixEpoch :: Word64 windowsTick = 10000000 secToUnixEpoch = 11644473600 --- | Convert POSIX seconds to ModTime. -posixSecondsToModTime :: Int64 -> ModTime -posixSecondsToModTime s = - ModTime $ ((fromIntegral s :: Word64) + secToUnixEpoch) * windowsTick - -- | Convert 'POSIXTime' to 'ModTime'. posixTimeToModTime :: POSIXTime -> ModTime posixTimeToModTime p = @@ -158,33 +54,4 @@ -- | Return the current time as 'ModTime'. getCurTime :: IO ModTime -getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'. - --- | Based on code written by Neil Mitchell for Shake. See --- 'sleepFileTimeCalibrate' in 'Test.Type'. Returns a pair --- of microsecond values: first, the maximum delay seen, and the --- recommended delay to use before testing for file modification change. --- The returned delay is never smaller --- than 10 ms, but never larger than 1 second. -calibrateMtimeChangeDelay :: IO (Int, Int) -calibrateMtimeChangeDelay = - withTempDirectoryCwd silent Nothing sameDirectory "calibration-" $ \dir -> do - let fileName = getSymbolicPath dir "probe" - mtimes <- for [1 .. 25] $ \(i :: Int) -> time $ do - writeFile fileName $ show i - t0 <- getModTime fileName - let spin j = do - writeFile fileName $ show (i, j) - t1 <- getModTime fileName - unless (t0 < t1) (spin $ j + 1) - spin (0 :: Int) - let mtimeChange = maximum mtimes - mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2 - return (mtimeChange, mtimeChange') - where - time :: IO () -> IO Int - time act = do - t0 <- getCurrentTime - act - t1 <- getCurrentTime - return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds +getCurTime = posixTimeToModTime `fmap` getPOSIXTime diff --git a/src/Distribution/GetOpt.hs b/src/Distribution/GetOpt.hs --- a/src/Distribution/GetOpt.hs +++ b/src/Distribution/GetOpt.hs @@ -230,7 +230,7 @@ -- take a look at the next cmd line arg and decide what to do with it getNext :: String -> [String] -> [OptDescr a] -> (OptKind a, [String]) -getNext ('-' : '-' : []) rest _ = (EndOfOpts, rest) +getNext ['-', '-'] rest _ = (EndOfOpts, rest) getNext ('-' : '-' : xs) rest optDescr = longOpt xs rest optDescr getNext ('-' : x : xs) rest optDescr = shortOpt x xs rest optDescr getNext a rest _ = (NonOpt a, rest) diff --git a/src/Distribution/Make.hs b/src/Distribution/Make.hs deleted file mode 100644 --- a/src/Distribution/Make.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ - --- copy : --- $(MAKE) install prefix=$(destdir)/$(prefix) \ --- bindir=$(destdir)/$(bindir) \ - --- | --- Module : Distribution.Make --- Copyright : Martin Sjögren 2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is an alternative build system that delegates everything to the @make@ --- program. All the commands just end up calling @make@ with appropriate --- arguments. The intention was to allow preexisting packages that used --- makefiles to be wrapped into Cabal packages. In practice essentially all --- such packages were converted over to the \"Simple\" build system instead. --- Consequently this module is not used much and it certainly only sees cursory --- maintenance and no testing. Perhaps at some point we should stop pretending --- that it works. --- --- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build --- Haskell tools using a back-end build system based on make. Obviously we --- assume that there is a configure script, and that after the ConfigCmd has --- been run, there is a Makefile. Further assumptions: --- --- [ConfigCmd] We assume the configure script accepts --- @--with-hc@, --- @--with-hc-pkg@, --- @--prefix@, --- @--bindir@, --- @--libdir@, --- @--libexecdir@, --- @--datadir@. --- --- [BuildCmd] We assume that the default Makefile target will build everything. --- --- [InstallCmd] We assume there is an @install@ target. Note that we assume that --- this does *not* register the package! --- --- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@. --- The @copy@ target should probably just invoke @make install@ --- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix) --- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make --- install@ directly here is that we don\'t know the value of @$(prefix)@. --- --- [SDistCmd] We assume there is a @dist@ target. --- --- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@. --- --- [UnregisterCmd] We assume there is an @unregister@ target. --- --- [HaddockCmd] We assume there is a @docs@ or @doc@ target. -module Distribution.Make - ( module Distribution.Package - , License (..) - , Version - , defaultMain - , defaultMainArgs - ) where - -import Distribution.Compat.Prelude -import Prelude () - --- local -import Distribution.License -import Distribution.Package -import Distribution.Pretty -import Distribution.Simple.Command -import Distribution.Simple.Program -import Distribution.Simple.Setup -import Distribution.Simple.Utils -import Distribution.Version - -import System.Environment (getArgs, getProgName) - -defaultMain :: IO () -defaultMain = getArgs >>= defaultMainArgs - -defaultMainArgs :: [String] -> IO () -defaultMainArgs = defaultMainHelper - -defaultMainHelper :: [String] -> IO () -defaultMainHelper args = do - command <- commandsRun (globalCommand commands) commands args - case command of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> - case commandParse of - _ - | fromFlag (globalVersion flags) -> printVersion - | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action - where - printHelp help = getProgName >>= putStr . help - printOptionsList = putStr . unlines - printErrors errs = do - putStr (intercalate "\n" errs) - exitWith (ExitFailure 1) - printNumericVersion = putStrLn $ prettyShow cabalVersion - printVersion = - putStrLn $ - "Cabal library version " - ++ prettyShow cabalVersion - progs = defaultProgramDb - commands = - [ configureCommand progs `commandAddAction` configureAction - , buildCommand progs `commandAddAction` buildAction - , installCommand `commandAddAction` installAction - , copyCommand `commandAddAction` copyAction - , haddockCommand `commandAddAction` haddockAction - , cleanCommand `commandAddAction` cleanAction - , sdistCommand `commandAddAction` sdistAction - , registerCommand `commandAddAction` registerAction - , unregisterCommand `commandAddAction` unregisterAction - ] - -configureAction :: ConfigFlags -> [String] -> IO () -configureAction flags args = do - noExtraFlags args - let verbosity = fromFlag $ configVerbosity flags - mbWorkDir = flagToMaybe $ configWorkingDir flags - rawSystemExit verbosity mbWorkDir "sh" $ - "configure" - : configureArgs backwardsCompatHack flags - where - backwardsCompatHack = True - -copyAction :: CopyFlags -> [String] -> IO () -copyAction flags args = do - noExtraFlags args - let verbosity = fromFlag $ copyVerbosity flags - mbWorkDir = flagToMaybe $ copyWorkingDir flags - destArgs = case fromFlag $ copyDest flags of - NoCopyDest -> ["install"] - CopyTo path -> ["copy", "destdir=" ++ path] - CopyToDb _ -> error "CopyToDb not supported via Make" - - rawSystemExit verbosity mbWorkDir "make" destArgs - -installAction :: InstallFlags -> [String] -> IO () -installAction flags args = do - noExtraFlags args - let verbosity = fromFlag $ installVerbosity flags - mbWorkDir = flagToMaybe $ installWorkingDir flags - rawSystemExit verbosity mbWorkDir "make" ["install"] - rawSystemExit verbosity mbWorkDir "make" ["register"] - -haddockAction :: HaddockFlags -> [String] -> IO () -haddockAction flags args = do - noExtraFlags args - let verbosity = fromFlag $ haddockVerbosity flags - mbWorkDir = flagToMaybe $ haddockWorkingDir flags - rawSystemExit verbosity mbWorkDir "make" ["docs"] - `catchIO` \_ -> - rawSystemExit verbosity mbWorkDir "make" ["doc"] - -buildAction :: BuildFlags -> [String] -> IO () -buildAction flags args = do - noExtraFlags args - let verbosity = fromFlag $ buildVerbosity flags - mbWorkDir = flagToMaybe $ buildWorkingDir flags - rawSystemExit verbosity mbWorkDir "make" [] - -cleanAction :: CleanFlags -> [String] -> IO () -cleanAction flags args = do - noExtraFlags args - let verbosity = fromFlag $ cleanVerbosity flags - mbWorkDir = flagToMaybe $ cleanWorkingDir flags - rawSystemExit verbosity mbWorkDir "make" ["clean"] - -sdistAction :: SDistFlags -> [String] -> IO () -sdistAction flags args = do - noExtraFlags args - let verbosity = fromFlag $ sDistVerbosity flags - mbWorkDir = flagToMaybe $ sDistWorkingDir flags - rawSystemExit verbosity mbWorkDir "make" ["dist"] - -registerAction :: RegisterFlags -> [String] -> IO () -registerAction flags args = do - noExtraFlags args - let verbosity = fromFlag $ registerVerbosity flags - mbWorkDir = flagToMaybe $ registerWorkingDir flags - rawSystemExit verbosity mbWorkDir "make" ["register"] - -unregisterAction :: RegisterFlags -> [String] -> IO () -unregisterAction flags args = do - noExtraFlags args - let verbosity = fromFlag $ registerVerbosity flags - mbWorkDir = flagToMaybe $ registerWorkingDir flags - rawSystemExit verbosity mbWorkDir "make" ["unregister"] 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 @@ -47,10 +47,13 @@ import Prelude () import Data.List (group) +import qualified Data.List as L import Distribution.CabalSpecVersion import Distribution.Compat.Lens import Distribution.Compiler +import Distribution.FieldGrammar.Parsec (freeTextIgnoreDotlineVers) import Distribution.License +import Distribution.ModuleName (toFilePath) import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Check.Common @@ -79,12 +82,15 @@ import qualified Distribution.SPDX as SPDX import qualified System.Directory as System -import qualified System.Directory (getDirectoryContents) +import qualified System.Directory (listDirectory) import qualified System.FilePath.Windows as FilePath.Windows (isValid) import qualified Data.Set as Set import qualified Distribution.Utils.ShortText as ShortText +import qualified Distribution.Utils.String as String +import qualified Distribution.Compat.Lens as L +import qualified Distribution.Types.BuildInfo.Lens as L import qualified Distribution.Types.GenericPackageDescription.Lens as L import Control.Monad @@ -171,14 +177,14 @@ CheckPackageContentOps { doesFileExist = System.doesFileExist . relative , doesDirectoryExist = System.doesDirectoryExist . relative - , getDirectoryContents = System.Directory.getDirectoryContents . relative + , listDirectory = System.Directory.listDirectory . relative , getFileContents = BS.readFile . relative } checkPreIO = CheckPreDistributionOps { runDirFileGlobM = \fp g -> runDirFileGlob verbosity (Just . specVersion $ packageDescription gpd) (root fp) g - , getDirectoryContentsM = System.Directory.getDirectoryContents . relative + , listDirectoryM = System.Directory.listDirectory . relative } relative :: FilePath -> FilePath @@ -239,7 +245,7 @@ -- Targets should be present... let condAllLibraries = maybeToList condLibrary_ - ++ (map snd condSubLibraries_) + ++ map snd condSubLibraries_ checkP ( and [ null condExecutables_ @@ -348,6 +354,18 @@ -- Duplicate modules. mapM_ tellP (checkDuplicateModules gpd) + + -- Module name checks (path validity on Windows and tar). + -- We collect all unique module names from the GPD and check each + -- once, rather than re-checking in every conditional branch. + let allModuleNames = + Set.fromList $ + maybe [] (explicitLibModules . ignoreConditions) condLibrary_ + ++ concatMap (explicitLibModules . ignoreConditions . snd) condSubLibraries_ + ++ concatMap (exeModules . ignoreConditions . snd) condExecutables_ + ++ concatMap (testModules . ignoreConditions . snd) condTestSuites_ + ++ concatMap (benchmarkModules . ignoreConditions . snd) condBenchmarks_ + mapM_ (\m -> checkPackageFileNamesWithGlob PathKindFile (toFilePath m)) allModuleNames where -- todo is this caught at parse time? checkFlagName :: Monad m => PackageFlag -> CheckM m () @@ -423,7 +441,7 @@ -- But it is OK for executables to have the same name. nsubs <- asksCM (pnSubLibs . ccNames) checkP - (any (== prettyShow pn) (prettyShow <$> nsubs)) + (prettyShow pn `elem` (prettyShow <$> nsubs)) (PackageBuildImpossible $ IllegalLibraryName pn) -- § Fields check. @@ -451,6 +469,20 @@ ) (PackageDistSuspicious ShortDesc) + -- § Freeform fields no longer include "dotlines". Generally taken from + -- Distribution.PackageDescription.FieldGrammar fields that use some + -- freeTextField parser. + checkDotline "author" _author_ + checkDotline "bug-reports" _bugReports_ + checkDotline "category" category_ + checkDotline "copyright" _copyright_ + checkDotline "description" description_ + checkDotline "homepage" _homepage_ + checkDotline "maintainer" maintainer_ + checkDotline "package-url" _pkgUrl_ + checkDotline "stability" _stability_ + checkDotline "synopsis" synopsis_ + -- § Paths. mapM_ (checkPath False "extra-source-files" PathKindGlob . getSymbolicPath) extraSrcFiles_ mapM_ (checkPath False "extra-tmp-files" PathKindFile . getSymbolicPath) extraTmpFiles_ @@ -507,7 +539,7 @@ ( isNothing setupBuildInfo_ && buildTypeRaw_ == Just Custom ) - (PackageDistSuspiciousWarn CVExpliticDepsCustomSetup) + (PackageDistSuspiciousWarn CVExplicitDepsCustomSetup) checkP (isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2) (PackageBuildWarning NoBuildType) @@ -557,6 +589,19 @@ in tellP (PackageDistInexcusable (InvalidTestWith dep)) ) +-- | Issue a warning if the text contains any "dotlines". +checkDotline :: Monad m => String -> ShortText.ShortText -> CheckM m () +checkDotline fieldName fieldVal = do + checkSpecVerGte + freeTextIgnoreDotlineVers + (hasDotline fieldVal) + (PackageDistSuspiciousWarn $ FreeTextDotline fieldName) + where + hasDotline = + L.any ((== ".") . String.trim) + . L.lines + . ShortText.fromShortText + checkSetupBuildInfo :: Monad m => Maybe SetupBuildInfo -> CheckM m () checkSetupBuildInfo Nothing = return () checkSetupBuildInfo (Just (SetupBuildInfo ds _)) = do @@ -586,8 +631,7 @@ checkP (not . FilePath.Windows.isValid . prettyShow $ pkgName_) (PackageDistInexcusable $ InvalidNameWin pkgName_) - checkP (isPrefixOf "z-" . prettyShow $ pkgName_) $ - (PackageDistInexcusable ZPrefix) + checkP (isPrefixOf "z-" . prettyShow $ pkgName_) (PackageDistInexcusable ZPrefix) checkNewLicense :: Monad m => SPDX.License -> CheckM m () checkNewLicense lic = do @@ -629,7 +673,7 @@ -- licenses so don't need license files. nullLicFiles ) - $ (PackageDistSuspicious NoLicenseFile) + (PackageDistSuspicious NoLicenseFile) case unknownLicenseVersion lic of Just knownVersions -> tellP @@ -706,7 +750,7 @@ checkP (any isAbsoluteOnAnyPlatform repoSubdir_) (PackageDistInexcusable SubdirRelPath) - case join . fmap isGoodRelativeDirectoryPath $ repoSubdir_ of + case isGoodRelativeDirectoryPath =<< repoSubdir_ of Just err -> tellP (PackageDistInexcusable $ SubdirGoodRelPath err) @@ -754,7 +798,7 @@ findPackageDesc :: Monad m => CheckPackageContentOps m -> m [FilePath] findPackageDesc ops = do let dir = "." - files <- getDirectoryContents ops dir + files <- listDirectory ops dir -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal -- file we filter to exclude dirs and null base file names: cabalFiles <- @@ -833,7 +877,9 @@ ( \ops -> do ba <- doesFileExist ops "Setup.hs" bb <- doesFileExist ops "Setup.lhs" - return (not $ ba || bb) + bc <- doesFileExist ops "SetupHooks.hs" + bd <- doesFileExist ops "SetupHooks.lhs" + return (not $ ba || bb || bc || bd) ) (PackageDistInexcusable MissingSetupFile) @@ -882,7 +928,7 @@ -- one). -> [GlobResult FilePath] -- List of glob results. -> [PackageCheck] -checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs) +checkGlobResult title fp rs = dirCheck ++ mapMaybe getWarning rs where dirCheck | all (not . withoutNoMatchesWarning) rs = @@ -936,14 +982,14 @@ -- each of those branch will be checked one by one. extractAssocDeps :: UnqualComponentName -- Name of the target library - -> CondTree ConfVar [Dependency] Library + -> CondTree ConfVar Library -> AssocDep extractAssocDeps n ct = let a = ignoreConditions ct in -- Merging is fine here, remember the specific -- library dependencies will be checked branch -- by branch. - (n, snd a) + (n, L.view L.targetBuildDepends a) -- | August 2022: this function is an oddity due to the historical -- GenericPackageDescription/PackageDescription split (check @@ -979,8 +1025,8 @@ } -- From target to simple, unconditional CondTree. - t2c :: a -> CondTree ConfVar [Dependency] a - t2c a = CondNode a [] [] + t2c :: a -> CondTree ConfVar a + t2c a = CondNode a [] -- From named target to unconditional CondTree. Notice we have -- a function to extract the name *and* a function to modify @@ -990,7 +1036,7 @@ :: (a -> UnqualComponentName) -> (a -> a) -> a - -> (UnqualComponentName, CondTree ConfVar [Dependency] a) + -> (UnqualComponentName, CondTree ConfVar a) t2cName nf mf a = (nf a, t2c . mf $ a) ln :: Library -> UnqualComponentName @@ -1022,8 +1068,8 @@ ciPreDistOps ( \ops -> do -- 1. Get root files, see if they are interesting to us. - rootContents <- getDirectoryContentsM ops "." - -- Recall getDirectoryContentsM arg is relative to root path. + rootContents <- listDirectoryM ops "." + -- Recall listDirectoryM arg is relative to root path. let des = filter isDesirableExtraDocFile rootContents -- 2. Realise Globs. @@ -1060,13 +1106,10 @@ -> [FilePath] -- Actuals. -> [PackageCheck] checkDoc b ds as = - let fds = map ("." ) $ filter (flip notElem as) ds - in if null fds - then [] - else - [ PackageDistSuspiciousWarn $ - MissingExpectedDocFiles b fds - ] + [ PackageDistSuspiciousWarn $ MissingExpectedDocFiles b fds + | let fds = map ("." ) $ filter (`notElem` as) ds + , not (null fds) + ] checkDocMove :: Bool -- Cabal spec ≥ 1.18? @@ -1075,13 +1118,10 @@ -> [FilePath] -- Actuals. -> [PackageCheck] checkDocMove b field ds as = - let fds = filter (flip elem as) ds - in if null fds - then [] - else - [ PackageDistSuspiciousWarn $ - WrongFieldForExpectedDocFiles b field fds - ] + [ PackageDistSuspiciousWarn $ WrongFieldForExpectedDocFiles b field fds + | let fds = filter (`elem` as) ds + , not (null fds) + ] -- Predicate for desirable documentation file on Hackage server. isDesirableExtraDocFile :: FilePath -> Bool 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 @@ -26,6 +26,7 @@ import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Check.Monad +import Distribution.Simple.Utils (ordNub) import Distribution.Utils.Generic (isAscii) import Distribution.Version @@ -61,7 +62,7 @@ -- be used together with checkPVP. Important: usually “base” or “Cabal”, -- as the error is slightly different. -- Note that `partitionDeps` will also filter out dependencies which are --- already present in a inherithed fashion (e.g. an exe which imports the +-- already present in a inherited fashion (e.g. an exe which imports the -- main library will not need to specify upper bounds on shared dependencies, -- hence we do not return those). -- @@ -80,7 +81,7 @@ -- shared targets that match fads = filter (flip elem dqs . fst) ads -- the names of such targets - inName = nub $ map fst fads :: [UnqualComponentName] + inName = ordNub $ map fst fads :: [UnqualComponentName] -- the dependencies of such targets inDep = concatMap snd fads :: [Dependency] diff --git a/src/Distribution/PackageDescription/Check/Conditional.hs b/src/Distribution/PackageDescription/Check/Conditional.hs --- a/src/Distribution/PackageDescription/Check/Conditional.hs +++ b/src/Distribution/PackageDescription/Check/Conditional.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} -- | -- Module : Distribution.PackageDescription.Check.Conditional @@ -21,7 +23,6 @@ import Distribution.Compiler import Distribution.ModuleName (ModuleName) -import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Check.Monad import Distribution.System @@ -61,21 +62,18 @@ . (Eq a, Monoid a) => [PackageFlag] -- User flags. -> TargetAnnotation a - -> CondTree ConfVar [Dependency] a - -> CondTree ConfVar [Dependency] (TargetAnnotation a) -annotateCondTree fs ta (CondNode a c bs) = + -> CondTree ConfVar a + -> CondTree ConfVar (TargetAnnotation a) +annotateCondTree fs ta (CondNode a bs) = let ta' = updateTargetAnnotation a ta bs' = map (annotateBranch ta') bs bs'' = crossAnnotateBranches defTrueFlags bs' - in CondNode ta' c bs'' + in CondNode ta' bs'' where annotateBranch :: TargetAnnotation a - -> CondBranch ConfVar [Dependency] a - -> CondBranch - ConfVar - [Dependency] - (TargetAnnotation a) + -> CondBranch ConfVar a + -> CondBranch ConfVar (TargetAnnotation a) annotateBranch wta (CondBranch k t mf) = let uf = isPkgFlagCond k wta' = wta{taPackageFlag = taPackageFlag wta || uf} @@ -92,7 +90,7 @@ -- \*off* by default. isPkgFlagCond :: Condition ConfVar -> Bool isPkgFlagCond (Lit _) = False - isPkgFlagCond (Var (PackageFlag f)) = elem f defOffFlags + isPkgFlagCond (Var (PackageFlag f)) = f `elem` defOffFlags isPkgFlagCond (Var _) = False isPkgFlagCond (CNot cn) = not (isPkgFlagCond cn) isPkgFlagCond (CAnd ca cb) = isPkgFlagCond ca || isPkgFlagCond cb @@ -117,13 +115,13 @@ :: forall a . (Eq a, Monoid a) => [PackageFlag] -- `default: true` flags. - -> [CondBranch ConfVar [Dependency] (TargetAnnotation a)] - -> [CondBranch ConfVar [Dependency] (TargetAnnotation a)] + -> [CondBranch ConfVar (TargetAnnotation a)] + -> [CondBranch ConfVar (TargetAnnotation a)] crossAnnotateBranches fs bs = map crossAnnBranch bs where crossAnnBranch - :: CondBranch ConfVar [Dependency] (TargetAnnotation a) - -> CondBranch ConfVar [Dependency] (TargetAnnotation a) + :: CondBranch ConfVar (TargetAnnotation a) + -> CondBranch ConfVar (TargetAnnotation a) crossAnnBranch wr = let rs = filter (/= wr) bs @@ -131,24 +129,23 @@ in updateTargetAnnBranch (mconcat ts) wr - realiseBranch :: CondBranch ConfVar [Dependency] (TargetAnnotation a) -> Maybe a + realiseBranch :: CondBranch ConfVar (TargetAnnotation a) -> Maybe a realiseBranch b = let -- We are only interested in True by default package flags. realiseBranchFunction :: ConfVar -> Either ConfVar Bool realiseBranchFunction (PackageFlag n) | elem n (map flagName fs) = Right True realiseBranchFunction _ = Right False - ms = simplifyCondBranch realiseBranchFunction (fmap taTarget b) in - fmap snd ms + simplifyCondBranch realiseBranchFunction (fmap taTarget b) updateTargetAnnBranch :: a - -> CondBranch ConfVar [Dependency] (TargetAnnotation a) - -> CondBranch ConfVar [Dependency] (TargetAnnotation a) + -> CondBranch ConfVar (TargetAnnotation a) + -> CondBranch ConfVar (TargetAnnotation a) updateTargetAnnBranch a (CondBranch k t mt) = - let updateTargetAnnTree (CondNode ka c wbs) = - (CondNode (updateTargetAnnotation a ka) c wbs) + let updateTargetAnnTree (CondNode ka wbs) = + CondNode (updateTargetAnnotation a ka) wbs in CondBranch k (updateTargetAnnTree t) (updateTargetAnnTree <$> mt) -- | A conditional target is a library, exe, benchmark etc., destructured @@ -163,7 +160,7 @@ -- Naming function (some targets -- need to have their name -- spoonfed to them. - -> (UnqualComponentName, CondTree ConfVar [Dependency] a) + -> (UnqualComponentName, CondTree ConfVar a) -- Target name/condtree. -> CheckM m () checkCondTarget fs cf nf (unqualName, ct) = @@ -172,9 +169,9 @@ -- Walking the tree. Remember that CondTree is not a binary -- tree but a /rose/tree. wTree - :: CondTree ConfVar [Dependency] (TargetAnnotation a) + :: CondTree ConfVar (TargetAnnotation a) -> CheckM m () - wTree (CondNode ta _ bs) + wTree (CondNode ta bs) -- There are no branches ([] == True) *or* every branch -- is “simple” (i.e. missing a 'condBranchIfFalse' part). -- This is convenient but not necessarily correct in all @@ -190,13 +187,13 @@ mapM_ wBranch bs isSimple - :: CondBranch ConfVar [Dependency] (TargetAnnotation a) + :: CondBranch ConfVar (TargetAnnotation a) -> Bool isSimple (CondBranch _ _ Nothing) = True isSimple (CondBranch _ _ (Just _)) = False wBranch - :: CondBranch ConfVar [Dependency] (TargetAnnotation a) + :: CondBranch ConfVar (TargetAnnotation a) -> CheckM m () wBranch (CondBranch k t mf) = do checkCondVars k @@ -228,38 +225,31 @@ checkDuplicateModules :: GenericPackageDescription -> [PackageCheck] checkDuplicateModules pkg = concatMap checkLib (maybe id (:) (condLibrary pkg) . map snd $ condSubLibraries pkg) - ++ concatMap checkExe (map snd $ condExecutables pkg) - ++ concatMap checkTest (map snd $ condTestSuites pkg) - ++ concatMap checkBench (map snd $ condBenchmarks pkg) + ++ concatMap (checkExe . snd) (condExecutables pkg) + ++ concatMap (checkTest . snd) (condTestSuites pkg) + ++ concatMap (checkBench . snd) (condBenchmarks pkg) where -- the duplicate modules check is has not been thoroughly vetted for backpack checkLib = checkDups "library" (\l -> explicitLibModules l ++ map moduleReexportName (reexportedModules l)) checkExe = checkDups "executable" exeModules checkTest = checkDups "test suite" testModules checkBench = checkDups "benchmark" benchmarkModules - checkDups :: String -> (a -> [ModuleName]) -> CondTree v c a -> [PackageCheck] + checkDups :: String -> (a -> [ModuleName]) -> CondTree v a -> [PackageCheck] checkDups s getModules t = let sumPair (x, x') (y, y') = (x + x' :: Int, y + y' :: Int) mergePair (x, x') (y, y') = (x + x', max y y') maxPair (x, x') (y, y') = (max x x', max y y') + libMap :: Map ModuleName (Int, Int) libMap = foldCondTree Map.empty - (\(_, v) -> Map.fromListWith sumPair . map (\x -> (x, (1, 1))) $ getModules v) + (\v -> Map.fromListWith sumPair . map (,(1, 1)) $ getModules v) (Map.unionWith mergePair) -- if a module may occur in nonexclusive branches count it twice strictly and once loosely. (Map.unionWith maxPair) -- a module occurs the max of times it might appear in exclusive branches t dupLibsStrict = Map.keys $ Map.filter ((> 1) . fst) libMap dupLibsLax = Map.keys $ Map.filter ((> 1) . snd) libMap - in if not (null dupLibsLax) - then - [ PackageBuildImpossible - (DuplicateModule s dupLibsLax) - ] - else - if not (null dupLibsStrict) - then - [ PackageDistSuspicious - (PotentialDupModule s dupLibsStrict) - ] - else [] + in if + | not (null dupLibsLax) -> [PackageBuildImpossible (DuplicateModule s dupLibsLax)] + | not (null dupLibsStrict) -> [PackageDistSuspicious (PotentialDupModule s dupLibsStrict)] + | otherwise -> [] 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 @@ -39,6 +39,7 @@ , liftInt , tellP , checkSpecVer + , checkSpecVerGte ) where import Distribution.Compat.Prelude @@ -92,7 +93,7 @@ data CheckPackageContentOps m = CheckPackageContentOps { doesFileExist :: FilePath -> m Bool , doesDirectoryExist :: FilePath -> m Bool - , getDirectoryContents :: FilePath -> m [FilePath] + , listDirectory :: FilePath -> m [FilePath] , getFileContents :: FilePath -> m BS.ByteString } @@ -102,7 +103,7 @@ -- (e.g. a VCS work tree). data CheckPreDistributionOps m = CheckPreDistributionOps { runDirFileGlobM :: FilePath -> Glob -> m [GlobResult FilePath] - , getDirectoryContentsM :: FilePath -> m [FilePath] + , listDirectoryM :: FilePath -> m [FilePath] } -- | Context to perform checks (will be the Reader part in your monad). @@ -135,8 +136,7 @@ -- | Creates a pristing 'CheckCtx'. With pristine we mean everything that -- can be deduced by GPD but *not* user flags information. pristineCheckCtx - :: Monad m - => CheckInterface m + :: CheckInterface m -> GenericPackageDescription -> CheckCtx m pristineCheckCtx ci gpd = @@ -150,7 +150,7 @@ -- | Adds useful bits to 'CheckCtx' (as now, whether we are operating under -- a user off-by-default flag). -initCheckCtx :: Monad m => TargetAnnotation a -> CheckCtx m -> CheckCtx m +initCheckCtx :: TargetAnnotation a -> CheckCtx m -> CheckCtx m initCheckCtx t c = c{ccFlag = taPackageFlag t} -- | 'TargetAnnotation' collects contextual information on the target we are @@ -322,7 +322,7 @@ po <- asksCM (acc . ccInterface) maybe (return ()) (lc . mck) po where - lc :: Monad m => m (Maybe PackageCheck) -> CheckM m () + lc :: m (Maybe PackageCheck) -> CheckM m () lc wmck = do b <- liftCM wmck maybe (return ()) (check True) b @@ -369,3 +369,16 @@ checkSpecVer vc cond c = do vp <- asksCM ccSpecVersion unless (vp >= vc) (checkP cond c) + +-- | Like 'checkSpecVer', except performs the check when our +-- spec version >= the param. +checkSpecVerGte + :: Monad m + => CabalSpecVersion -- Perform this check only if our + -- spec version is >= than this. + -> Bool -- Check condition. + -> PackageCheck -- Check message. + -> CheckM m () +checkSpecVerGte vc cond c = do + vp <- asksCM ccSpecVersion + when (vp >= vc) (checkP cond c) 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + -- | -- Module : Distribution.PackageDescription.Check.Target -- Copyright : Lennart Kolmodin 2008, Francesco Ariis 2023 @@ -21,7 +23,7 @@ import Distribution.CabalSpecVersion import Distribution.Compat.Lens import Distribution.Compiler -import Distribution.ModuleName (ModuleName, toFilePath) +import Distribution.ModuleName (ModuleName) import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Check.Common @@ -61,8 +63,6 @@ _libVisibility_ libBuildInfo_ ) = do - mapM_ checkModuleName (explicitLibModules lib) - checkP (libName_ == LMainLibName && isSub) (PackageBuildImpossible UnnamedInternal) @@ -79,7 +79,7 @@ checkP ( not $ all - (flip elem (explicitLibModules lib)) + (`elem` explicitLibModules lib) (libModulesAutogen lib) ) (PackageBuildImpossible AutogenNotExposed) @@ -91,7 +91,7 @@ (flip elem (allExplicitIncludes lib) . getSymbolicPath) (view L.autogenIncludes lib) ) - $ (PackageBuildImpossible AutogenIncludesNotIncluded) + (PackageBuildImpossible AutogenIncludesNotIncluded) -- § Build infos. checkBuildInfo @@ -146,8 +146,6 @@ let cet = CETExecutable exeName_ modulePath_ = getSymbolicPath symbolicModulePath_ - mapM_ checkModuleName (exeModules exe) - -- § Exe specific checks checkP (null modulePath_) @@ -157,7 +155,7 @@ checkP ( pid /= fakePackageId && not (null modulePath_) - && not (fileExtensionSupportedLanguage $ modulePath_) + && not (fileExtensionSupportedLanguage modulePath_) ) (PackageBuildImpossible NoHsLhsMain) @@ -172,7 +170,7 @@ -- Alas exeModules ad exeModulesAutogen (exported from -- Distribution.Types.Executable) take `Executable` as a parameter. checkP - (not $ all (flip elem (exeModules exe)) (exeModulesAutogen exe)) + (not $ all (`elem` exeModules exe) (exeModulesAutogen exe)) (PackageBuildImpossible $ AutogenNoOther cet) checkP ( not $ @@ -209,16 +207,13 @@ TestSuiteUnsupported tt -> tellP (PackageBuildWarning $ TestsuiteNotSupported tt) _ -> return () - - mapM_ checkModuleName (testModules ts) - checkP mainIsWrongExt (PackageBuildImpossible NoHsLhsMain) checkP ( not $ all - (flip elem (testModules ts)) + (`elem` testModules ts) (testModulesAutogen ts) ) (PackageBuildImpossible $ AutogenNoOther cet) @@ -264,8 +259,6 @@ -- Target type/name (benchmark). let cet = CETBenchmark benchmarkName_ - mapM_ checkModuleName (benchmarkModules bm) - -- § Interface & bm specific tests. case benchmarkInterface_ of BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> @@ -280,7 +273,7 @@ checkP ( not $ all - (flip elem (benchmarkModules bm)) + (`elem` benchmarkModules bm) (benchmarkModulesAutogen bm) ) (PackageBuildImpossible $ AutogenNoOther cet) @@ -303,11 +296,6 @@ 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 -- ------------------------------------------------------------ @@ -395,7 +383,7 @@ mapM_ checkIntDep (targetBuildDepends bi) df <- asksCM ccDesugar -- This way we can use the same function for legacy&non exedeps. - let ds = buildToolDepends bi ++ catMaybes (map df $ buildTools bi) + let ds = buildToolDepends bi ++ mapMaybe df (buildTools bi) mapM_ checkBTDep ds where checkLang :: Monad m => Language -> CheckM m () @@ -540,8 +528,7 @@ (not . null $ extraDynLibFlavours bi) (PackageDistInexcusable $ CVExtraDynamic [extraDynLibFlavours bi]) -- virtual-modules requires ≥ 2.2 - checkSpecVer CabalSpecV2_2 (not . null $ virtualModules bi) $ - (PackageDistInexcusable CVVirtualModules) + checkSpecVer CabalSpecV2_2 (not . null $ virtualModules bi) (PackageDistInexcusable CVVirtualModules) -- Check use of thinning and renaming. checkSpecVer CabalSpecV2_0 @@ -572,8 +559,8 @@ checkBuildInfoExtensions :: Monad m => BuildInfo -> CheckM m () checkBuildInfoExtensions bi = do let exts = allExtensions bi - extCabal1_2 = nub $ filter (`elem` compatExtensionsExtra) exts - extCabal1_4 = nub $ filter (`notElem` compatExtensions) exts + extCabal1_2 = ordNub $ filter (`elem` compatExtensionsExtra) exts + extCabal1_4 = ordNub $ filter (`notElem` compatExtensions) exts -- As of Cabal-1.4 we can add new extensions without worrying -- about breaking old versions of cabal. checkSpecVer @@ -655,9 +642,7 @@ , DeriveDataTypeable , ConstrainedClassMethods ] - ++ map - DisableExtension - [MonoPatBinds] + ++ [DisableExtension MonoPatBinds] -- Autogenerated modules (Paths_, PackageInfo_) checks. We could pass this -- function something more specific than the whole BuildInfo, but it would be @@ -692,7 +677,7 @@ -- PackageBuildImpossible and not merely PackageDistInexcusable. checkSpecVer CabalSpecV3_12 - (elem autoInfoModuleName allModsForAuto) + (autoInfoModuleName `elem` allModsForAuto) (PackageBuildImpossible CVAutogenPackageInfoGuard) where allModsForAuto :: [ModuleName] @@ -970,7 +955,7 @@ ) (PackageDistInexcusable . DynamicUnneeded) checkFlagsP - ( \opt -> case opt of + ( \case "-j" -> True ('-' : 'j' : d : _) -> isDigit d _ -> False 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 @@ -170,6 +170,7 @@ | UnknownExtensions [String] | LanguagesAsExtension [String] | DeprecatedExtensions [(Extension, Maybe Extension)] + | FreeTextDotline String | MissingFieldCategory | MissingFieldMaintainer | MissingFieldSynopsis @@ -244,7 +245,7 @@ | CVSourceRepository | CVExtensions CabalSpecVersion [Extension] | CVCustomSetup - | CVExpliticDepsCustomSetup + | CVExplicitDepsCustomSetup | CVAutogenPaths | CVAutogenPackageInfo | CVAutogenPackageInfoGuard @@ -337,6 +338,7 @@ | CIUnknownExtensions | CILanguagesAsExtension | CIDeprecatedExtensions + | CIFreeTextDotline | CIMissingFieldCategory | CIMissingFieldMaintainer | CIMissingFieldSynopsis @@ -411,7 +413,7 @@ | CICVSourceRepository | CICVExtensions | CICVCustomSetup - | CICVExpliticDepsCustomSetup + | CICVExplicitDepsCustomSetup | CICVAutogenPaths | CICVAutogenPackageInfo | CICVAutogenPackageInfoGuard @@ -483,6 +485,7 @@ checkExplanationId (UnknownExtensions{}) = CIUnknownExtensions checkExplanationId (LanguagesAsExtension{}) = CILanguagesAsExtension checkExplanationId (DeprecatedExtensions{}) = CIDeprecatedExtensions +checkExplanationId (FreeTextDotline{}) = CIFreeTextDotline checkExplanationId (MissingFieldCategory{}) = CIMissingFieldCategory checkExplanationId (MissingFieldMaintainer{}) = CIMissingFieldMaintainer checkExplanationId (MissingFieldSynopsis{}) = CIMissingFieldSynopsis @@ -557,7 +560,7 @@ checkExplanationId (CVSourceRepository{}) = CICVSourceRepository checkExplanationId (CVExtensions{}) = CICVExtensions checkExplanationId (CVCustomSetup{}) = CICVCustomSetup -checkExplanationId (CVExpliticDepsCustomSetup{}) = CICVExpliticDepsCustomSetup +checkExplanationId (CVExplicitDepsCustomSetup{}) = CICVExplicitDepsCustomSetup checkExplanationId (CVAutogenPaths{}) = CICVAutogenPaths checkExplanationId (CVAutogenPackageInfo{}) = CICVAutogenPackageInfo checkExplanationId (CVAutogenPackageInfoGuard{}) = CICVAutogenPackageInfoGuard @@ -636,6 +639,7 @@ ppCheckExplanationId CIUnknownExtensions = "unknown-extension" ppCheckExplanationId CILanguagesAsExtension = "languages-as-extensions" ppCheckExplanationId CIDeprecatedExtensions = "deprecated-extensions" +ppCheckExplanationId CIFreeTextDotline = "free-text-dotline" ppCheckExplanationId CIMissingFieldCategory = "no-category" ppCheckExplanationId CIMissingFieldMaintainer = "no-maintainer" ppCheckExplanationId CIMissingFieldSynopsis = "no-synopsis" @@ -710,7 +714,7 @@ ppCheckExplanationId CICVSourceRepository = "source-repository" ppCheckExplanationId CICVExtensions = "incompatible-extension" ppCheckExplanationId CICVCustomSetup = "no-setup-depends" -ppCheckExplanationId CICVExpliticDepsCustomSetup = "dependencies-setup" +ppCheckExplanationId CICVExplicitDepsCustomSetup = "dependencies-setup" ppCheckExplanationId CICVAutogenPaths = "no-autogen-paths" ppCheckExplanationId CICVAutogenPackageInfo = "no-autogen-pinfo" ppCheckExplanationId CICVAutogenPackageInfoGuard = "autogen-guard" @@ -910,6 +914,11 @@ ++ "'." | (ext, Just replacement) <- ourDeprecatedExtensions ] +ppExplanation (FreeTextDotline field) = + "Empty lines with a dot '.' in field '" + ++ field + ++ "' are unnecessary for creating newlines " + ++ "(and treated literally) in cabal 3.0+" ppExplanation MissingFieldCategory = "No 'category' field." ppExplanation MissingFieldMaintainer = "No 'maintainer' field." ppExplanation MissingFieldSynopsis = "No 'synopsis' field." @@ -926,7 +935,8 @@ ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which " ++ "serves as a headline. " ++ "Please refer to for more details." + ++ "cabal-package-description-file.html#package-properties> " + ++ "for more details." ppExplanation (InvalidTestWith testedWithImpossibleRanges) = "Invalid 'tested-with' version range: " ++ commaSep (map prettyShow testedWithImpossibleRanges) @@ -1248,7 +1258,7 @@ ++ "that specifies the dependencies of the Setup.hs script itself. " ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " ++ "so a simple example would be 'setup-depends: base, Cabal'." -ppExplanation CVExpliticDepsCustomSetup = +ppExplanation CVExplicitDepsCustomSetup = "From version 1.24 cabal supports specifying explicit dependencies " ++ "for Custom setup scripts. Consider using 'cabal-version: 1.24' or " ++ "higher and adding a 'custom-setup' section with a 'setup-depends' " @@ -1463,7 +1473,8 @@ ++ quote (getSymbolicPath file) ++ " which does not exist." ppExplanation MissingSetupFile = - "The package is missing a Setup.hs or Setup.lhs script." + "The package is missing a Setup.hs or Setup.lhs or SetupHooks.hs " + ++ "or SetupHooks.lhs script." ppExplanation MissingConfigureScript = "The 'build-type' is 'Configure' but there is no 'configure' script. " ++ "You probably need to run 'autoreconf -i' to generate it." diff --git a/src/Distribution/Simple.hs b/src/Distribution/Simple.hs --- a/src/Distribution/Simple.hs +++ b/src/Distribution/Simple.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- {- Work around this warning: @@ -13,7 +14,6 @@ Deprecated: "Please use the new testing interface instead!" -} {-# OPTIONS_GHC -Wno-deprecations #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | -- Module : Distribution.Simple @@ -38,8 +38,7 @@ -- simple software. -- -- The original idea was that there could be different build systems that all --- presented the same compatible command line interfaces. There is still a --- "Distribution.Make" system but in practice no packages use it. +-- presented the same compatible command line interfaces. module Distribution.Simple ( module Distribution.Package , module Distribution.Version @@ -51,6 +50,7 @@ , defaultMain , defaultMainNoRead , defaultMainArgs + , defaultMainArgsWithHandles -- * Customization , UserHooks (..) @@ -64,9 +64,25 @@ -- ** Standard sets of hooks , simpleUserHooks + , simpleUserHooksWithHandles , autoconfUserHooks , autoconfSetupHooks , emptyUserHooks + + -- ** Simple actions (library interface) + , configureAction + , buildAction + , replAction + , installAction + , copyAction + , haddockAction + , cleanAction + , sdistAction + , hscolourAction + , registerAction + , unregisterAction + , testAction + , benchAction ) where import Control.Exception (try) @@ -117,13 +133,9 @@ -- Base import Data.List (unionBy, (\\)) -import System.Directory - ( doesDirectoryExist - , doesFileExist - , removeDirectoryRecursive - , removeFile - ) +import System.Directory (removePathForcibly) import System.Environment (getArgs, getProgName) +import System.IO (hPutStr, hPutStrLn) -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the @@ -136,12 +148,17 @@ defaultMainArgs :: [String] -> IO () defaultMainArgs = defaultMainHelper simpleUserHooks +-- | A version of 'defaultMainArgs' that allows passing explicit verbosity handles. +defaultMainArgsWithHandles :: VerbosityHandles -> [String] -> IO () +defaultMainArgsWithHandles verbHandles = + defaultMainHelperWithHandles verbHandles simpleUserHooks + defaultMainWithSetupHooks :: SetupHooks -> IO () -defaultMainWithSetupHooks setup_hooks = - getArgs >>= defaultMainWithSetupHooksArgs setup_hooks +defaultMainWithSetupHooks setupHooks = + getArgs >>= defaultMainWithSetupHooksArgs setupHooks defaultVerbosityHandles -defaultMainWithSetupHooksArgs :: SetupHooks -> [String] -> IO () -defaultMainWithSetupHooksArgs setupHooks = +defaultMainWithSetupHooksArgs :: SetupHooks -> VerbosityHandles -> [String] -> IO () +defaultMainWithSetupHooksArgs setupHooks verbHandles = defaultMainHelper $ simpleUserHooks { confHook = setup_confHook @@ -153,13 +170,24 @@ , hscolourHook = setup_hscolourHook } where + preBuildHook = + case SetupHooks.preBuildComponentRules (SetupHooks.buildHooks setupHooks) of + Nothing -> const $ return [] + Just pbcRules -> \pbci -> runPreBuildHooks verbHandles pbci pbcRules + postBuildHook = + case SetupHooks.postBuildComponentHook (SetupHooks.buildHooks setupHooks) of + Nothing -> const $ return () + Just hk -> hk + setup_confHook :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo - setup_confHook = + setup_confHook p = configure_setupHooks (SetupHooks.configureHooks setupHooks) + p + verbHandles setup_buildHook :: PackageDescription @@ -168,12 +196,14 @@ -> BuildFlags -> IO () setup_buildHook pkg_descr lbi hooks flags = - build_setupHooks - (SetupHooks.buildHooks setupHooks) - pkg_descr - lbi - flags - (allSuffixHandlers hooks) + void $ + build_setupHooks + (preBuildHook, postBuildHook) + verbHandles + pkg_descr + lbi + flags + (allSuffixHandlers hooks) setup_copyHook :: PackageDescription @@ -184,6 +214,7 @@ setup_copyHook pkg_descr lbi _hooks flags = install_setupHooks (SetupHooks.installHooks setupHooks) + verbHandles pkg_descr lbi flags @@ -197,6 +228,7 @@ setup_installHook = defaultInstallHook_setupHooks (SetupHooks.installHooks setupHooks) + verbHandles setup_replHook :: PackageDescription @@ -206,13 +238,15 @@ -> [String] -> IO () setup_replHook pkg_descr lbi hooks flags args = - repl_setupHooks - (SetupHooks.buildHooks setupHooks) - pkg_descr - lbi - flags - (allSuffixHandlers hooks) - args + void $ + repl_setupHooks + preBuildHook + verbHandles + pkg_descr + lbi + flags + (allSuffixHandlers hooks) + args setup_haddockHook :: PackageDescription @@ -221,12 +255,14 @@ -> HaddockFlags -> IO () setup_haddockHook pkg_descr lbi hooks flags = - haddock_setupHooks - (SetupHooks.buildHooks setupHooks) - pkg_descr - lbi - (allSuffixHandlers hooks) - flags + void $ + haddock_setupHooks + preBuildHook + verbHandles + pkg_descr + lbi + (allSuffixHandlers hooks) + flags setup_hscolourHook :: PackageDescription @@ -235,12 +271,14 @@ -> HscolourFlags -> IO () setup_hscolourHook pkg_descr lbi hooks flags = - hscolour_setupHooks - (SetupHooks.buildHooks setupHooks) - pkg_descr - lbi - (allSuffixHandlers hooks) - flags + void $ + hscolour_setupHooks + preBuildHook + verbHandles + pkg_descr + lbi + (allSuffixHandlers hooks) + flags -- | A customizable version of 'defaultMain'. defaultMainWithHooks :: UserHooks -> IO () @@ -281,38 +319,59 @@ -- getting 'CommandParse' data back, which is then pattern-matched into -- IO actions for execution, with arguments applied by the parser. defaultMainHelper :: UserHooks -> Args -> IO () -defaultMainHelper hooks args = topHandler $ do - args' <- expandResponse args - command <- commandsRun (globalCommand commands) commands args' - case command of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (globalFlags, commandParse) -> - case commandParse of - _ - | fromFlag (globalVersion globalFlags) -> printVersion - | fromFlag (globalNumericVersion globalFlags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action globalFlags +defaultMainHelper = defaultMainHelperWithHandles defaultVerbosityHandles + +-- | A version of 'defaultMainHelper' that allows setting the logging handles. +defaultMainHelperWithHandles :: VerbosityHandles -> UserHooks -> Args -> IO () +defaultMainHelperWithHandles verbHandles hooks args = + topHandler (isUserException (Proxy @(VerboseException CabalException))) $ do + args' <- expandResponse args + command <- commandsRun (globalCommand commands) commands args' + case command of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalFlags, commandParse) -> + case commandParse of + _ + | fromFlag (globalVersion globalFlags) -> printVersion + | fromFlag (globalFullVersion globalFlags) -> printFullVersion + | fromFlag (globalNumericVersion globalFlags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action globalFlags where - printHelp help = getProgName >>= putStr . help - printOptionsList = putStr . unlines + outHandle = vStdoutHandle verbHandles + printHelp help = getProgName >>= hPutStr outHandle . help + printOptionsList = hPutStr outHandle . unlines printErrors errs = do - putStr (intercalate "\n" errs) + hPutStr outHandle (intercalate "\n" errs) exitWith (ExitFailure 1) - printNumericVersion = putStrLn $ prettyShow cabalVersion + printNumericVersion = + hPutStrLn outHandle $ prettyShow cabalVersion printVersion = - putStrLn $ + hPutStrLn outHandle $ "Cabal library version " ++ prettyShow cabalVersion - + printFullVersion = + hPutStrLn outHandle $ + "Cabal library version " + ++ prettyShow cabalVersion + ++ cabalGitInfo' + ++ "\nwith " + ++ cabalCompilerInfo + cabalGitInfo' + | null cabalGitInfo = [] + | otherwise = ' ' : cabalGitInfo progs = addKnownPrograms (hookedPrograms hooks) defaultProgramDb - addAction :: CommandUI flags -> (GlobalFlags -> UserHooks -> flags -> [String] -> IO res) -> Command (GlobalFlags -> IO ()) + addAction + :: CommandUI flags + -> (VerbosityHandles -> GlobalFlags -> UserHooks -> flags -> [String] -> IO res) + -> Command (GlobalFlags -> IO ()) addAction cmd action = - cmd `commandAddAction` \flags as globalFlags -> void $ action globalFlags hooks flags as + cmd `commandAddAction` \flags as globalFlags -> + void $ action verbHandles globalFlags hooks flags as commands :: [Command (GlobalFlags -> IO ())] commands = [ configureCommand progs `addAction` configureAction @@ -341,8 +400,8 @@ overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] overridesPP = unionBy (\x y -> fst x == fst y) -configureAction :: GlobalFlags -> UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo -configureAction globalFlags hooks flags args = do +configureAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo +configureAction verbHandles globalFlags hooks flags args = do distPref <- findDistPrefOrDefault (setupDistPref $ configCommonFlags flags) let commonFlags = configCommonFlags flags commonFlags' = @@ -356,7 +415,7 @@ { configCommonFlags = commonFlags' } mbWorkDir = flagToMaybe $ setupWorkingDir commonFlags' - verbosity = fromFlag $ setupVerbosity commonFlags' + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonFlags') -- See docs for 'HookedBuildInfo' pbi <- preConf hooks args flags' @@ -404,17 +463,18 @@ return (Just pdfile, descr) getCommonFlags - :: GlobalFlags + :: VerbosityHandles + -> GlobalFlags -> UserHooks -> CommonSetupFlags -> Args -> IO (LocalBuildInfo, CommonSetupFlags) -getCommonFlags globalFlags hooks commonFlags args = do +getCommonFlags verbHandles globalFlags hooks commonFlags args = do distPref <- findDistPrefOrDefault (setupDistPref commonFlags) - let verbosity = fromFlag $ setupVerbosity commonFlags + let verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonFlags) lbi <- getBuildConfig globalFlags hooks verbosity distPref let common' = configCommonFlags $ configFlags lbi - return $ + return ( lbi , commonFlags { setupDistPref = toFlag distPref @@ -427,11 +487,11 @@ } ) -buildAction :: GlobalFlags -> UserHooks -> BuildFlags -> Args -> IO () -buildAction globalFlags hooks flags args = do +buildAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> BuildFlags -> Args -> IO () +buildAction verbHandles globalFlags hooks flags args = do let common = buildCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{buildCommonFlags = common'} progs <- @@ -451,11 +511,11 @@ flags' args -replAction :: GlobalFlags -> UserHooks -> ReplFlags -> Args -> IO () -replAction globalFlags hooks flags args = do +replAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> ReplFlags -> Args -> IO () +replAction verbHandles globalFlags hooks flags args = do let common = replCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{replCommonFlags = common'} progs <- reconfigurePrograms @@ -479,11 +539,11 @@ replHook hooks pkg_descr lbi' hooks flags' args postRepl hooks args flags' pkg_descr lbi' -hscolourAction :: GlobalFlags -> UserHooks -> HscolourFlags -> Args -> IO () -hscolourAction globalFlags hooks flags args = do +hscolourAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> HscolourFlags -> Args -> IO () +hscolourAction verbHandles globalFlags hooks flags args = do let common = hscolourCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (_lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{hscolourCommonFlags = common'} distPref = fromFlag $ setupDistPref common' @@ -497,11 +557,11 @@ flags' args -haddockAction :: GlobalFlags -> UserHooks -> HaddockFlags -> Args -> IO () -haddockAction globalFlags hooks flags args = do +haddockAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> HaddockFlags -> Args -> IO () +haddockAction verbHandles globalFlags hooks flags args = do let common = haddockCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{haddockCommonFlags = common'} progs <- @@ -521,10 +581,10 @@ flags' args -cleanAction :: GlobalFlags -> UserHooks -> CleanFlags -> Args -> IO () -cleanAction globalFlags hooks flags args = do +cleanAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> CleanFlags -> Args -> IO () +cleanAction verbHandles globalFlags hooks flags args = do let common = cleanCommonFlags flags - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) distPref <- findDistPrefOrDefault (setupDistPref common) elbi <- tryGetBuildConfig globalFlags hooks verbosity distPref let common' = @@ -569,11 +629,11 @@ cleanHook hooks pkg_descr () hooks flags' postClean hooks args flags' pkg_descr () -copyAction :: GlobalFlags -> UserHooks -> CopyFlags -> Args -> IO () -copyAction globalFlags hooks flags args = do +copyAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> CopyFlags -> Args -> IO () +copyAction verbHandles globalFlags hooks flags args = do let common = copyCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (_lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{copyCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedAction @@ -586,11 +646,11 @@ flags' args -installAction :: GlobalFlags -> UserHooks -> InstallFlags -> Args -> IO () -installAction globalFlags hooks flags args = do +installAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> InstallFlags -> Args -> IO () +installAction verbHandles globalFlags hooks flags args = do let common = installCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (_lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{installCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedAction @@ -604,20 +664,20 @@ args -- Since Cabal-3.4 UserHooks are completely ignored -sdistAction :: GlobalFlags -> UserHooks -> SDistFlags -> Args -> IO () -sdistAction _globalFlags _hooks flags _args = do +sdistAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> SDistFlags -> Args -> IO () +sdistAction verbHandles _globalFlags _hooks flags _args = do let mbWorkDir = flagToMaybe $ sDistWorkingDir flags (_, ppd) <- confPkgDescr emptyUserHooks verbosity mbWorkDir Nothing let pkg_descr = flattenPackageDescription ppd - sdist pkg_descr flags srcPref knownSuffixHandlers + sdist verbHandles pkg_descr flags srcPref knownSuffixHandlers where - verbosity = fromFlag (setupVerbosity $ sDistCommonFlags flags) + verbosity = mkVerbosity verbHandles $ fromFlag (setupVerbosity $ sDistCommonFlags flags) -testAction :: GlobalFlags -> UserHooks -> TestFlags -> Args -> IO () -testAction globalFlags hooks flags args = do +testAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> TestFlags -> Args -> IO () +testAction verbHandles globalFlags hooks flags args = do let common = testCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (_lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{testCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedActionWithArgs @@ -630,11 +690,11 @@ flags' args -benchAction :: GlobalFlags -> UserHooks -> BenchmarkFlags -> Args -> IO () -benchAction globalFlags hooks flags args = do +benchAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> BenchmarkFlags -> Args -> IO () +benchAction verbHandles globalFlags hooks flags args = do let common = benchmarkCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (_lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{benchmarkCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedActionWithArgs @@ -647,11 +707,11 @@ flags' args -registerAction :: GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO () -registerAction globalFlags hooks flags args = do +registerAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO () +registerAction verbHandles globalFlags hooks flags args = do let common = registerCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (_lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{registerCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedAction @@ -664,11 +724,11 @@ flags' args -unregisterAction :: GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO () -unregisterAction globalFlags hooks flags args = do +unregisterAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO () +unregisterAction verbHandles globalFlags hooks flags args = do let common = registerCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (_lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{registerCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedAction @@ -758,14 +818,14 @@ verbosity (PackageDescription{library = Nothing}) (Just _, _) = - dieWithException verbosity $ NoLibraryForPackage + dieWithException verbosity NoLibraryForPackage sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes) - | exe1 : _ <- nonExistant = + | exe1 : _ <- nonExistent = dieWithException verbosity $ SanityCheckHookedBuildInfo exe1 where - pkgExeNames = nub (map exeName (executables pkg_descr)) - hookExeNames = nub (map fst hookExes) - nonExistant = hookExeNames \\ pkgExeNames + pkgExeNames = ordNub (map exeName (executables pkg_descr)) + hookExeNames = ordNub (map fst hookExes) + nonExistent = hookExeNames \\ pkgExeNames sanityCheckHookedBuildInfo _ _ _ = return () -- | Try to read the 'localBuildInfoFile' @@ -826,18 +886,18 @@ , configCommonFlags = (configCommonFlags cFlags) { -- Use the current, not saved verbosity level: - setupVerbosity = Flag verbosity + setupVerbosity = Flag $ verbosityFlags verbosity } } - configureAction globalFlags hooks cFlags' (extraConfigArgs lbi) + configureAction (verbosityHandles verbosity) globalFlags hooks cFlags' (extraConfigArgs lbi) -- -------------------------------------------------------------------------- -- Cleaning -clean :: PackageDescription -> CleanFlags -> IO () -clean pkg_descr flags = do +clean :: VerbosityHandles -> PackageDescription -> CleanFlags -> IO () +clean verbHandles pkg_descr flags = do let common = cleanCommonFlags flags - verbosity = fromFlag (setupVerbosity common) + verbosity = mkVerbosity verbHandles (fromFlag (setupVerbosity common)) distPref = fromFlagOrDefault defaultDistPref $ setupDistPref common mbWorkDir = flagToMaybe $ setupWorkingDir common i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path @@ -851,23 +911,14 @@ -- remove the whole dist/ directory rather than tracking exactly what files -- we created in there. - chattyTry "removing dist/" $ do - exists <- doesDirectoryExist distPath - when exists (removeDirectoryRecursive distPath) + chattyTry verbosity "removing dist/" $ do + removePathForcibly distPath -- Any extra files the user wants to remove - traverse_ (removeFileOrDirectory . i) (extraTmpFiles pkg_descr) + traverse_ (removePathForcibly . i) (extraTmpFiles pkg_descr) -- If the user wanted to save the config, write it back traverse_ (writePersistBuildConfig mbWorkDir distPref) maybeConfig - where - removeFileOrDirectory :: FilePath -> IO () - removeFileOrDirectory fname = do - isDir <- doesDirectoryExist fname - isFile <- doesFileExist fname - if isDir - then removeDirectoryRecursive fname - else when isFile $ removeFile fname -- -------------------------------------------------------------------------- -- Default hooks @@ -875,28 +926,38 @@ -- | Hooks that correspond to a plain instantiation of the -- \"simple\" build system simpleUserHooks :: UserHooks -simpleUserHooks = +simpleUserHooks = simpleUserHooksWithHandles defaultVerbosityHandles + +-- | A version of 'simpleUserHooks' that allows setting custom logging handles. +simpleUserHooksWithHandles :: VerbosityHandles -> UserHooks +simpleUserHooksWithHandles verbHandles = emptyUserHooks - { confHook = configure + { confHook = \p -> configure_setupHooks SetupHooks.noConfigureHooks p verbHandles , postConf = finalChecks - , buildHook = defaultBuildHook - , replHook = defaultReplHook - , copyHook = \desc lbi _ f -> install desc lbi f + , buildHook = defaultBuildHook verbHandles + , replHook = defaultReplHook verbHandles + , copyHook = \desc lbi _ f -> install_setupHooks SetupHooks.noInstallHooks verbHandles desc lbi f , -- 'install' has correct 'copy' behavior with params - instHook = defaultInstallHook - , testHook = defaultTestHook - , benchHook = defaultBenchHook - , cleanHook = \p _ _ f -> clean p f - , hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f - , haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f - , regHook = defaultRegHook - , unregHook = \p l _ f -> unregister p l f + instHook = defaultInstallHook verbHandles + , testHook = defaultTestHook verbHandles + , benchHook = defaultBenchHook verbHandles + , cleanHook = \p _ _ f -> clean verbHandles p f + , hscolourHook = \p l h f -> void $ hscolour_setupHooks noBuildHooks verbHandles p l (allSuffixHandlers h) f + , haddockHook = \p l h f -> void $ haddock_setupHooks noBuildHooks verbHandles p l (allSuffixHandlers h) f + , regHook = defaultRegHook verbHandles + , unregHook = \p l _ f -> unregisterWithHandles verbHandles p l f } where + noBuildHooks pbci@(SetupHooks.PreBuildComponentInputs{SetupHooks.localBuildInfo = lbi}) = + builtinPreBuildHooks + (buildType (localPkgDescr lbi)) + pbci finalChecks _args flags pkg_descr lbi = - checkForeignDeps pkg_descr lbi (lessVerbose verbosity) + checkForeignDeps pkg_descr lbi (modifyVerbosityFlags lessVerbose verbosity) where - verbosity = fromFlag (setupVerbosity $ configCommonFlags flags) + verbosity = + mkVerbosity verbHandles $ + fromFlag (setupVerbosity $ configCommonFlags flags) -- | Basic autoconf 'UserHooks': -- @@ -933,9 +994,10 @@ defaultPostConf args flags pkg_descr lbi = do let common = configCommonFlags flags - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity defaultVerbosityHandles (fromFlag $ setupVerbosity common) mbWorkDir = flagToMaybe $ setupWorkingDir common runConfigureScript + defaultVerbosityHandles flags (flagAssignment lbi) (withPrograms lbi) @@ -953,7 +1015,7 @@ -> IO HookedBuildInfo readHookWithArgs get_common_flags _args flags = do let common = get_common_flags flags - verbosity = fromFlag (setupVerbosity common) + verbosity = mkVerbosity defaultVerbosityHandles (fromFlag (setupVerbosity common)) mbWorkDir = flagToMaybe $ setupWorkingDir common distPref = setupDistPref common dist_dir <- findDistPrefOrDefault distPref @@ -966,7 +1028,7 @@ -> IO HookedBuildInfo readHook get_common_flags args flags = do let common = get_common_flags flags - verbosity = fromFlag (setupVerbosity common) + verbosity = mkVerbosity defaultVerbosityHandles (fromFlag (setupVerbosity common)) mbWorkDir = flagToMaybe $ setupWorkingDir common distPref = setupDistPref common noExtraFlags args @@ -1010,7 +1072,7 @@ , LBC.hostPlatform = plat } } - ) = runConfigureScript cfg flags progs plat + ) = runConfigureScript defaultVerbosityHandles cfg flags progs plat pre_conf_comp :: SetupHooks.PreConfComponentInputs @@ -1025,7 +1087,7 @@ , SetupHooks.component = component } ) = do - let verbosity = fromFlag $ configVerbosity cfg + let verbosity = mkVerbosity defaultVerbosityHandles (fromFlag $ configVerbosity cfg) mbWorkDir = flagToMaybe $ configWorkingDir cfg distPref = configDistPref cfg dist_dir <- findDistPrefOrDefault distPref @@ -1046,48 +1108,52 @@ } defaultTestHook - :: Args + :: VerbosityHandles + -> Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO () -defaultTestHook args pkg_descr localbuildinfo _ flags = - test args pkg_descr localbuildinfo flags +defaultTestHook verbHandles args pkg_descr localbuildinfo _ flags = + test args verbHandles pkg_descr localbuildinfo flags defaultBenchHook - :: Args + :: VerbosityHandles + -> Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO () -defaultBenchHook args pkg_descr localbuildinfo _ flags = - bench args pkg_descr localbuildinfo flags +defaultBenchHook verbHandles args pkg_descr localbuildinfo _ flags = + bench args verbHandles pkg_descr localbuildinfo flags defaultInstallHook - :: PackageDescription + :: VerbosityHandles + -> PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () -defaultInstallHook = - defaultInstallHook_setupHooks SetupHooks.noInstallHooks +defaultInstallHook verbHandles = + defaultInstallHook_setupHooks SetupHooks.noInstallHooks verbHandles defaultInstallHook_setupHooks :: SetupHooks.InstallHooks + -> VerbosityHandles -> PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () -defaultInstallHook_setupHooks inst_hooks pkg_descr localbuildinfo _ flags = do +defaultInstallHook_setupHooks inst_hooks verbHandles pkg_descr localbuildinfo _ flags = do let copyFlags = defaultCopyFlags { copyDest = installDest flags , copyCommonFlags = installCommonFlags flags } - install_setupHooks inst_hooks pkg_descr localbuildinfo copyFlags + install_setupHooks inst_hooks verbHandles pkg_descr localbuildinfo copyFlags let registerFlags = defaultRegisterFlags { regInPlace = installInPlace flags @@ -1095,38 +1161,60 @@ , registerCommonFlags = installCommonFlags flags } when (hasLibs pkg_descr) $ - register pkg_descr localbuildinfo registerFlags + registerWithHandles verbHandles pkg_descr localbuildinfo registerFlags defaultBuildHook - :: PackageDescription + :: VerbosityHandles + -> PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () -defaultBuildHook pkg_descr localbuildinfo hooks flags = - build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) +defaultBuildHook verbHandles pkg_descr localbuildinfo hooks flags = + void $ + build_setupHooks + (builtinPreBuildHooks (buildType pkg_descr), const $ pure ()) + verbHandles + pkg_descr + localbuildinfo + flags + (allSuffixHandlers hooks) defaultReplHook - :: PackageDescription + :: VerbosityHandles + -> PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO () -defaultReplHook pkg_descr localbuildinfo hooks flags args = - repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args +defaultReplHook verbHandles pkg_descr localbuildinfo hooks flags args = + void $ + repl_setupHooks + (builtinPreBuildHooks (buildType pkg_descr)) + verbHandles + pkg_descr + localbuildinfo + flags + (allSuffixHandlers hooks) + args defaultRegHook - :: PackageDescription + :: VerbosityHandles + -> PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () -defaultRegHook pkg_descr localbuildinfo _ flags = - if hasLibs pkg_descr - then register pkg_descr localbuildinfo flags - else +defaultRegHook verbHandles pkg_descr localbuildinfo _ flags + | hasLibs pkg_descr = + registerWithHandles verbHandles pkg_descr localbuildinfo flags + | otherwise = setupMessage - (fromFlag (setupVerbosity $ registerCommonFlags flags)) + verbosity "Package contains no library to register:" (packageId pkg_descr) + where + verbosity = + mkVerbosity verbHandles $ + fromFlag (setupVerbosity $ registerCommonFlags flags) 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 @@ -41,6 +41,7 @@ import Distribution.Types.Benchmark (Benchmark (benchmarkBuildInfo)) import Distribution.Types.UnqualComponentName import Distribution.Utils.Path +import Distribution.Verbosity import System.Directory (doesFileExist) @@ -48,6 +49,7 @@ bench :: Args -- ^ positional command-line arguments + -> VerbosityHandles -> PD.PackageDescription -- ^ information from the .cabal file -> LBI.LocalBuildInfo @@ -55,9 +57,9 @@ -> BenchmarkFlags -- ^ flags sent to benchmark -> IO () -bench args pkg_descr lbi flags = do +bench args verbHandles pkg_descr lbi flags = do curDir <- LBI.absoluteWorkingDirLBI lbi - let verbosity = fromFlag $ benchmarkVerbosity flags + let verbosity = mkVerbosity verbHandles (fromFlag $ benchmarkVerbosity flags) benchmarkNames = args pkgBenchmarks = PD.benchmarks pkg_descr enabledBenchmarks = LBI.enabledBenchLBIs pkg_descr lbi 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,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} @@ -25,6 +26,7 @@ ( -- * Build build , build_setupHooks + , buildComponent -- * Repl , repl @@ -33,6 +35,8 @@ -- * Build preparation , preBuildComponent + , runPreBuildHooks + , builtinPreBuildHooks , AutogenFile (..) , AutogenFileContents , writeBuiltinAutogenFiles @@ -91,6 +95,7 @@ import Distribution.Simple.BuildTarget import Distribution.Simple.BuildToolDepends import Distribution.Simple.Configure +import Distribution.Simple.Errors import Distribution.Simple.Flag import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PreProcess @@ -104,9 +109,8 @@ import Distribution.Simple.Setup.Config import Distribution.Simple.Setup.Repl import Distribution.Simple.SetupHooks.Internal - ( BuildHooks (..) - , BuildingWhat (..) - , noBuildHooks + ( BuildingWhat (..) + , buildingWhatVerbosity ) import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks @@ -126,8 +130,7 @@ import Control.Monad import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map -import Distribution.Simple.Errors -import System.Directory (doesFileExist, removeFile) + import System.FilePath (takeDirectory) -- ----------------------------------------------------------------------------- @@ -143,10 +146,17 @@ -> [PPSuffixHandler] -- ^ preprocessors to run before compiling -> IO () -build = build_setupHooks noBuildHooks +build pkg lbi flags pps = + void $ build_setupHooks noHooks defaultVerbosityHandles pkg lbi flags pps + where + noHooks = (const $ return [], const $ return ()) build_setupHooks - :: BuildHooks + :: ( SetupHooks.PreBuildComponentInputs -> IO [SetupHooks.MonitorFilePath] + , SetupHooks.PostBuildComponentInputs -> IO () + ) + -- ^ build hooks + -> VerbosityHandles -> PackageDescription -- ^ Mostly information from the .cabal file -> LocalBuildInfo @@ -155,15 +165,20 @@ -- ^ Flags that the user passed to build -> [PPSuffixHandler] -- ^ preprocessors to run before compiling - -> IO () + -> IO [SetupHooks.MonitorFilePath] build_setupHooks - (BuildHooks{preBuildComponentRules = mbPbcRules, postBuildComponentHook = mbPostBuild}) + (preBuildHook, postBuildHook) + verbHandles pkg_descr lbi flags suffixHandlers = do + let verbosity = mkVerbosity verbHandles (fromFlag $ buildVerbosity flags) + distPref = fromFlag $ buildDistPref flags checkSemaphoreSupport verbosity (compiler lbi) flags + targets <- readTargetInfos verbosity pkg_descr lbi (buildTargets flags) + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) info verbosity $ "Component build order: " @@ -188,7 +203,7 @@ curDir <- absoluteWorkingDirLBI lbi -- Now do the actual building - (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do + (mons, _) <- (\f -> foldM f ([], installedPkgs lbi) componentsToBuild) $ \(monsAcc, index) target -> do let comp = targetComponent target clbi = targetCLBI target bi = componentBuildInfo comp @@ -200,24 +215,14 @@ , withPackageDB = withPackageDB lbi ++ [internalPackageDB] , installedPkgs = index } - runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () - runPreBuildHooks lbi2 tgt = - let inputs = - SetupHooks.PreBuildComponentInputs - { SetupHooks.buildingWhat = BuildNormal flags - , SetupHooks.localBuildInfo = lbi2 - , SetupHooks.targetInfo = tgt - } - in for_ mbPbcRules $ \pbcRules -> do - (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules - SetupHooks.executeRules verbosity lbi2 tgt ruleFromId - preBuildComponent runPreBuildHooks verbosity lbi' target + pbci = SetupHooks.PreBuildComponentInputs (BuildNormal flags) lbi' target + mons <- preBuildComponent (preBuildHook pbci) verbosity lbi' target let numJobs = buildNumJobs flags par_strat <- toFlag <$> case buildUseSemaphore flags of Flag sem_name -> case numJobs of Flag{} -> do - warn verbosity $ "Ignoring -j due to --semaphore" + warn verbosity "Ignoring -j due to --semaphore" return $ UseSem sem_name NoFlag -> return $ UseSem sem_name NoFlag -> return $ case numJobs of @@ -225,6 +230,7 @@ NoFlag -> Serial mb_ipi <- buildComponent + verbHandles flags par_strat pkg_descr @@ -239,19 +245,16 @@ , SetupHooks.localBuildInfo = lbi' , SetupHooks.targetInfo = target } - for_ mbPostBuild ($ postBuildInputs) - return (maybe index (Index.insert `flip` index) mb_ipi) + postBuildHook postBuildInputs + return (monsAcc <> mons, maybe index (`Index.insert` index) mb_ipi) - return () - where - distPref = fromFlag (buildDistPref flags) - verbosity = fromFlag (buildVerbosity flags) + return mons -- | Check for conditions that would prevent the build from succeeding. checkSemaphoreSupport :: Verbosity -> Compiler -> BuildFlags -> IO () checkSemaphoreSupport verbosity comp flags = do - unless (jsemSupported comp || (isNothing (flagToMaybe (buildUseSemaphore flags)))) $ + unless (jsemSupported comp || isNothing (flagToMaybe (buildUseSemaphore flags))) $ dieWithException verbosity CheckSemaphoreSupport -- | Write available build information for 'LocalBuildInfo' to disk. @@ -301,10 +304,9 @@ ++ unlines warns LBS.writeFile buildInfoFile buildInfoText - when (not shouldDumpBuildInfo) $ do + unless shouldDumpBuildInfo $ -- Remove existing build-info.json as it might be outdated now. - exists <- doesFileExist buildInfoFile - when exists $ removeFile buildInfoFile + removeFileForcibly buildInfoFile where buildInfoFile = interpretSymbolicPathLBI lbi $ buildInfoPref distPref shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo @@ -329,11 +331,21 @@ -- ^ preprocessors to run before compiling -> [String] -> IO () -repl = repl_setupHooks noBuildHooks +repl pkg lbi flags pps args = + void $ + repl_setupHooks + (const $ return []) + defaultVerbosityHandles + pkg + lbi + flags + pps + args repl_setupHooks - :: BuildHooks - -- ^ build hook + :: (SetupHooks.PreBuildComponentInputs -> IO [SetupHooks.MonitorFilePath]) + -- ^ pre-build hook + -> VerbosityHandles -> PackageDescription -- ^ Mostly information from the .cabal file -> LocalBuildInfo @@ -343,25 +355,26 @@ -> [PPSuffixHandler] -- ^ preprocessors to run before compiling -> [String] - -> IO () + -> IO [SetupHooks.MonitorFilePath] repl_setupHooks - (BuildHooks{preBuildComponentRules = mbPbcRules}) + preBuildHook + verbHandles pkg_descr lbi flags suffixHandlers args = do let distPref = fromFlag (replDistPref flags) - verbosity = fromFlag (replVerbosity flags) + verbosity = mkVerbosity verbHandles $ fromFlag (replVerbosity flags) target <- - readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of + readTargetInfos verbosity pkg_descr lbi args >>= \case -- This seems DEEPLY questionable. [] -> case allTargetsInBuildOrder' pkg_descr lbi of (target : _) -> return target - [] -> dieWithException verbosity $ FailedToDetermineTarget + [] -> dieWithException verbosity FailedToDetermineTarget [target] -> return target - _ -> dieWithException verbosity $ NoMultipleTargets + _ -> dieWithException verbosity NoMultipleTargets let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] debug verbosity $ "Component build order: " @@ -388,27 +401,19 @@ (componentBuildInfo comp) (withPrograms lbi') } - runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () - runPreBuildHooks lbi2 tgt = - let inputs = - SetupHooks.PreBuildComponentInputs - { SetupHooks.buildingWhat = BuildRepl flags - , SetupHooks.localBuildInfo = lbi2 - , SetupHooks.targetInfo = tgt - } - in for_ mbPbcRules $ \pbcRules -> do - (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules - SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + pbci lbi' tgt = SetupHooks.PreBuildComponentInputs (BuildRepl flags) lbi' tgt - -- build any dependent components - sequence_ - [ do - let clbi = targetCLBI subtarget - comp = targetComponent subtarget - lbi' <- lbiForComponent comp lbi - preBuildComponent runPreBuildHooks verbosity lbi' subtarget + -- build any dependent components and collect their monitored file paths + depMonitors <- fmap concat $ for (safeInit componentsToBuild) $ \subtarget -> do + let clbi = targetCLBI subtarget + comp = targetComponent subtarget + lbi' <- lbiForComponent comp lbi + monitors <- preBuildComponent (preBuildHook (pbci lbi' subtarget)) verbosity lbi' subtarget + + _mb_ipi <- buildComponent - (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag verbosity}}) + verbHandles + (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag $ verbosityFlags verbosity}}) NoFlag pkg_descr lbi' @@ -416,16 +421,21 @@ comp clbi distPref - | subtarget <- safeInit componentsToBuild - ] + return monitors + -- REPL for target components let clbi = targetCLBI target comp = targetComponent target lbi' <- lbiForComponent comp lbi - preBuildComponent runPreBuildHooks verbosity lbi' target + + targetMonitors <- + preBuildComponent (preBuildHook (pbci lbi' target)) verbosity lbi' target + replComponent flags verbosity pkg_descr lbi' suffixHandlers comp clbi distPref + return (depMonitors <> targetMonitors) + -- | Start an interpreter without loading any package files. startInterpreter :: Verbosity @@ -441,7 +451,8 @@ _ -> dieWithException verbosity REPLNotSupported buildComponent - :: BuildFlags + :: VerbosityHandles + -> BuildFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo @@ -450,13 +461,14 @@ -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Dist) -> IO (Maybe InstalledPackageInfo) -buildComponent flags _ _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ = - dieWithException (fromFlag $ buildVerbosity flags) $ +buildComponent verbHandles flags _ _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ = + dieWithException (mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags) $ NoSupportBuildingTestSuite tt -buildComponent flags _ _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ = - dieWithException (fromFlag $ buildVerbosity flags) $ +buildComponent verbHandles flags _ _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ = + dieWithException (mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags) $ NoSupportBuildingBenchMark tt buildComponent + verbHandles flags numJobs pkg_descr @@ -473,7 +485,7 @@ distPref = do inplaceDir <- absoluteWorkingDirLBI lbi0 - let verbosity = fromFlag $ buildVerbosity flags + let verbosity = mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 inplaceDir distPref preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers @@ -487,7 +499,7 @@ (maybeComponentInstantiatedWith clbi) let libbi = libBuildInfo lib lib' = lib{libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir} - buildLib flags numJobs pkg lbi lib' libClbi + buildLib verbHandles flags numJobs pkg lbi lib' libClbi -- NB: need to enable multiple instances here, because on 7.10+ -- the package name is the same as the library, and we still -- want the registration to go through. @@ -509,6 +521,7 @@ buildExe verbosity numJobs pkg_descr lbi exe' exeClbi return Nothing -- Can't depend on test suite buildComponent + verbHandles flags numJobs pkg_descr @@ -518,7 +531,7 @@ clbi distPref = do - let verbosity = fromFlag $ buildVerbosity flags + let verbosity = mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi setupMessage' @@ -537,18 +550,17 @@ flip addExtraCmmSources extras $ flip addExtraCxxSources extras $ flip addExtraCSources extras $ - flip addExtraJsSources extras $ - libbi + addExtraJsSources libbi extras } - buildLib flags numJobs pkg_descr lbi lib' clbi + buildLib verbHandles flags numJobs pkg_descr lbi lib' clbi let oneComponentRequested (OneComponentRequestedSpec _) = True oneComponentRequested _ = False -- Don't register inplace if we're only building a single component; -- it's not necessary because there won't be any subsequent builds -- that need to tag us - if (not (oneComponentRequested (componentEnabledSpec lbi))) + if not (oneComponentRequested (componentEnabledSpec lbi)) then do -- Register the library in-place, so exes can depend -- on internally defined libraries. @@ -566,7 +578,7 @@ lib' lbi clbi - debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo) + debug verbosity $ "Registering inplace:\n" ++ IPI.showInstalledPackageInfo installedPkgInfo registerPackage verbosity (compiler lbi) @@ -615,8 +627,8 @@ -> Verbosity -> IO (SymbolicPath Pkg (Dir Source), [ModuleName.ModuleName]) generateCode codeGens nm pdesc bi lbi clbi verbosity = do - when (not . null $ codeGens) $ createDirectoryIfMissingVerbose verbosity True $ i tgtDir - (\x -> (tgtDir, x)) . concat <$> mapM go codeGens + unless (null codeGens) $ createDirectoryIfMissingVerbose verbosity True $ i tgtDir + (tgtDir,) . concat <$> mapM go codeGens where allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc) dependencyLibs = filter (const True) allLibs -- intersect with componentPackageDeps of clbi @@ -625,6 +637,7 @@ mbWorkDir = mbWorkDirLBI lbi i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path tgtDir = buildDir lbi makeRelativePathEx (nm' nm' ++ "-gen") + verbLevel = verbosityLevel verbosity go :: String -> IO [ModuleName.ModuleName] go codeGenProg = fmap fromString . lines @@ -635,7 +648,7 @@ (withPrograms lbi) ( map interpretSymbolicPathCWD (tgtDir : srcDirs) ++ ( "--" - : GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbosity lbi bi clbi tgtDir) + : GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbLevel lbi bi clbi tgtDir) ) ) @@ -719,7 +732,7 @@ extras <- preprocessExtras verbosity comp lbi let libbi = libBuildInfo lib lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} - replLib replFlags pkg lbi lib' libClbi + replLib (verbosityHandles verbosity) replFlags pkg lbi lib' libClbi replComponent replFlags verbosity @@ -730,29 +743,30 @@ clbi _ = do + let verbHandles = verbosityHandles verbosity preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi case comp of CLib lib -> do let libbi = libBuildInfo lib lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} - replLib replFlags pkg_descr lbi lib' clbi + replLib verbHandles replFlags pkg_descr lbi lib' clbi CFLib flib -> - replFLib replFlags pkg_descr lbi flib clbi + replFLib verbHandles replFlags pkg_descr lbi flib clbi CExe exe -> do let ebi = buildInfo exe exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} - replExe replFlags pkg_descr lbi exe' clbi + replExe verbHandles replFlags pkg_descr lbi exe' clbi CTest test@TestSuite{testInterface = TestSuiteExeV10{}} -> do let exe = testSuiteExeV10AsExe test let ebi = buildInfo exe exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} - replExe replFlags pkg_descr lbi exe' clbi + replExe verbHandles replFlags pkg_descr lbi exe' clbi CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}} -> do let exe = benchmarkExeV10asExe bm let ebi = buildInfo exe exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} - replExe replFlags pkg_descr lbi exe' clbi + replExe verbHandles replFlags pkg_descr lbi exe' clbi #if __GLASGOW_HASKELL__ < 811 -- silence pattern-match warnings prior to GHC 9.0 _ -> error "impossible" @@ -874,13 +888,12 @@ -- that exposes the relevant test suite library. deps = (IPI.installedUnitId ipi, mungedId ipi) - : ( filter - ( \(_, x) -> - let name = prettyShow $ mungedName x - in name == "Cabal" || name == "base" - ) - (componentPackageDeps clbi) + : filter + ( \(_, x) -> + let name = prettyShow $ mungedName x + in name == "Cabal" || name == "base" ) + (componentPackageDeps clbi) exeClbi = ExeComponentLocalBuildInfo { -- TODO: this is a hack, but as long as this is unique @@ -909,7 +922,7 @@ createInternalPackageDB verbosity lbi distPref = do existsAlready <- doesPackageDBExist dbPath when existsAlready $ deletePackageDB dbPath - createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath + createPackageDB verbosity (compiler lbi) (withPrograms lbi) dbPath return (SpecificPackageDB dbRelPath) where dbRelPath = internalPackageDBPath lbi distPref @@ -961,17 +974,18 @@ -- TODO: build separate libs in separate dirs so that we can build -- multiple libs, e.g. for 'LibTest' library-style test suites buildLib - :: BuildFlags + :: VerbosityHandles + -> BuildFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () -buildLib flags numJobs pkg_descr lbi lib clbi = - let verbosity = fromFlag $ buildVerbosity flags +buildLib verbHandles flags numJobs pkg_descr lbi lib clbi = + let verbosity = mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags in case compilerFlavor (compiler lbi) of - GHC -> GHC.buildLib flags numJobs pkg_descr lbi lib clbi + GHC -> GHC.buildLib verbHandles 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 _ -> dieWithException verbosity BuildingNotSupportedWithCompiler @@ -1009,33 +1023,35 @@ _ -> dieWithException verbosity BuildingNotSupportedWithCompiler replLib - :: ReplFlags + :: VerbosityHandles + -> ReplFlags -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () -replLib replFlags pkg_descr lbi lib clbi = - let verbosity = fromFlag $ replVerbosity replFlags +replLib verbHandles replFlags pkg_descr lbi lib clbi = + let verbosity = mkVerbosity verbHandles (fromFlag $ replVerbosity replFlags) opts = replReplOptions replFlags in case compilerFlavor (compiler lbi) of -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass -- NoFlag as the numJobs parameter. - GHC -> GHC.replLib replFlags NoFlag pkg_descr lbi lib clbi + GHC -> GHC.replLib verbHandles replFlags NoFlag pkg_descr lbi lib clbi GHCJS -> GHCJS.replLib (replOptionsFlags opts) verbosity NoFlag pkg_descr lbi lib clbi _ -> dieWithException verbosity REPLNotSupported replExe - :: ReplFlags + :: VerbosityHandles + -> ReplFlags -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () -replExe flags pkg_descr lbi exe clbi = - let verbosity = fromFlag $ replVerbosity flags +replExe verbHandles flags pkg_descr lbi exe clbi = + let verbosity = mkVerbosity verbHandles $ fromFlag $ replVerbosity flags in case compilerFlavor (compiler lbi) of - GHC -> GHC.replExe flags NoFlag pkg_descr lbi exe clbi + GHC -> GHC.replExe verbHandles flags NoFlag pkg_descr lbi exe clbi GHCJS -> GHCJS.replExe (replOptionsFlags $ replReplOptions flags) @@ -1048,16 +1064,17 @@ _ -> dieWithException verbosity REPLNotSupported replFLib - :: ReplFlags + :: VerbosityHandles + -> ReplFlags -> PackageDescription -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo -> IO () -replFLib flags pkg_descr lbi exe clbi = - let verbosity = fromFlag $ replVerbosity flags +replFLib verbHandles flags pkg_descr lbi exe clbi = + let verbosity = mkVerbosity verbHandles (fromFlag $ replVerbosity flags) in case compilerFlavor (compiler lbi) of - GHC -> GHC.replFLib flags NoFlag pkg_descr lbi exe clbi + GHC -> GHC.replFLib verbHandles flags NoFlag pkg_descr lbi exe clbi _ -> dieWithException verbosity REPLNotSupported -- | Runs 'componentInitialBuildSteps' on every configured component. @@ -1118,21 +1135,54 @@ -- | Creates the autogenerated files for a particular configured component, -- and runs the pre-build hook. preBuildComponent - :: (LocalBuildInfo -> TargetInfo -> IO ()) + :: IO r -- ^ pre-build hook -> Verbosity -> LocalBuildInfo -- ^ Configuration information -> TargetInfo - -> IO () + -> IO r preBuildComponent preBuildHook verbosity lbi tgt = do let pkg_descr = localPkgDescr lbi clbi = targetCLBI tgt compBuildDir = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi createDirectoryIfMissingVerbose verbosity True compBuildDir writeBuiltinAutogenFiles verbosity pkg_descr lbi clbi - preBuildHook lbi tgt + preBuildHook +-- | Compute and execute 'PreBuildComponentRules', returning the monitored +-- files declared by the rules. +runPreBuildHooks + :: VerbosityHandles + -> SetupHooks.PreBuildComponentInputs + -> SetupHooks.PreBuildComponentRules + -> IO [SetupHooks.MonitorFilePath] +runPreBuildHooks + verbHandles + pbci@( SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = what + , SetupHooks.localBuildInfo = lbi + , SetupHooks.targetInfo = tgt + } + ) + pbcRules = do + let verbosity = mkVerbosity verbHandles $ buildingWhatVerbosity what + (rules, mons) <- SetupHooks.computeRules verbosity pbci pbcRules + SetupHooks.executeRules verbosity lbi tgt rules + return mons + +-- | Built-in pre-build 'SetupHooks' for a given 'BuildType'. +builtinPreBuildHooks + :: BuildType + -> SetupHooks.PreBuildComponentInputs + -> IO [SetupHooks.MonitorFilePath] +builtinPreBuildHooks _ = + -- NB: currently there are no built-in pre-build hooks. + -- + -- In the future, we may want to migrate built-in preprocessors (such as + -- @hsc2hs@, @alex@, @happy@) to pre-build hooks. + const (return []) + -- | Generate and write to disk all built-in autogenerated files -- for the specified component. These files will be put in the -- autogenerated module directory for this component @@ -1173,7 +1223,7 @@ pathsFile = AutogenModule (autogenPathsModuleName pkg) (Suffix "hs") pathsContents = toUTF8LBS $ generatePathsModule pkg lbi clbi packageInfoFile = AutogenModule (autogenPackageInfoModuleName pkg) (Suffix "hs") - packageInfoContents = toUTF8LBS $ generatePackageInfoModule pkg lbi + packageInfoContents = toUTF8LBS $ generatePackageInfoModule pkg cppHeaderFile = AutogenFile $ toShortText cppHeaderName cppHeaderContents = toUTF8LBS $ generateCabalMacrosHeader pkg lbi clbi 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 @@ -44,7 +44,7 @@ } -- | Get the @'Verbosity'@ from the context the component being built is in. -buildVerbosity :: PreBuildComponentInputs -> Verbosity +buildVerbosity :: PreBuildComponentInputs -> VerbosityFlags buildVerbosity = buildingWhatVerbosity . buildingWhat -- | Get the @'Component'@ being built. 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 @@ -19,11 +19,14 @@ import Prelude () import Distribution.Package -import Distribution.PackageDescription -import Distribution.Simple.Compiler -import Distribution.Simple.LocalBuildInfo -import Distribution.Utils.ShortText -import Distribution.Version + ( PackageName + , packageName + , packageVersion + , unPackageName + ) +import Distribution.Types.PackageDescription (PackageDescription (..)) +import Distribution.Types.Version (versionNumbers) +import Distribution.Utils.ShortText (fromShortText) import qualified Distribution.Simple.Build.PackageInfoModule.Z as Z @@ -33,8 +36,8 @@ -- ------------------------------------------------------------ -generatePackageInfoModule :: PackageDescription -> LocalBuildInfo -> String -generatePackageInfoModule pkg_descr lbi = +generatePackageInfoModule :: PackageDescription -> String +generatePackageInfoModule pkg_descr = Z.render Z.Z { Z.zPackageName = showPkgName $ packageName pkg_descr @@ -42,15 +45,7 @@ , Z.zSynopsis = fromShortText $ synopsis pkg_descr , Z.zCopyright = fromShortText $ copyright pkg_descr , Z.zHomepage = fromShortText $ homepage pkg_descr - , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax } - where - supports_rebindable_syntax = ghc_newer_than (mkVersion [7, 0, 1]) - - ghc_newer_than minVersion = - case compilerCompatVersion GHC (compiler lbi) of - Nothing -> False - Just version -> version `withinRange` orLaterVersion minVersion showPkgName :: PackageName -> String showPkgName = map fixchar . unPackageName 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 @@ -2,7 +2,7 @@ module Distribution.Simple.Build.PackageInfoModule.Z (render, Z (..)) where -import Distribution.ZinzaPrelude +import Distribution.ZinzaPrelude (Generic, execWriter, tell) data Z = Z { zPackageName :: String @@ -10,19 +10,12 @@ , zSynopsis :: String , zCopyright :: String , zHomepage :: String - , zSupportsNoRebindableSyntax :: Bool } deriving (Generic) render :: Z -> String render z_root = execWriter $ do - if (zSupportsNoRebindableSyntax z_root) - then do - tell "{-# LANGUAGE NoRebindableSyntax #-}\n" - return () - else do - return () - tell "{-# OPTIONS_GHC -Wno-missing-import-lists #-}\n" + tell "{-# LANGUAGE NoRebindableSyntax #-}\n" tell "{-# OPTIONS_GHC -w #-}\n" tell "\n" tell "{-|\n" 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 @@ -44,8 +44,6 @@ Z.Z { Z.zPackageName = packageName pkg_descr , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr - , Z.zSupportsCpp = supports_cpp - , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax , Z.zAbsolute = absolute , Z.zRelocatable = relocatable lbi , Z.zIsWindows = isWindows @@ -63,15 +61,6 @@ , Z.zSysconfdir = zSysconfdir } where - supports_cpp = supports_language_pragma - supports_rebindable_syntax = ghc_newer_than (mkVersion [7, 0, 1]) - supports_language_pragma = ghc_newer_than (mkVersion [6, 6, 1]) - - ghc_newer_than minVersion = - case compilerCompatVersion GHC (compiler lbi) of - Nothing -> False - Just version -> version `withinRange` orLaterVersion minVersion - -- In several cases we cannot make relocatable installations absolute = hasLibs pkg_descr -- we can only make progs relocatable 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 @@ -5,8 +5,6 @@ data Z = Z {zPackageName :: PackageName, zVersionDigits :: String, - zSupportsCpp :: Bool, - zSupportsNoRebindableSyntax :: Bool, zAbsolute :: Bool, zRelocatable :: Bool, zIsWindows :: Bool, @@ -25,33 +23,14 @@ deriving Generic render :: Z -> String render z_root = execWriter $ do - if (zSupportsCpp z_root) - then do - tell "{-# LANGUAGE CPP #-}\n" - return () - else do - return () - if (zSupportsNoRebindableSyntax z_root) - then do - tell "{-# LANGUAGE NoRebindableSyntax #-}\n" - return () - else do - return () + tell "{-# LANGUAGE CPP #-}\n" + tell "{-# LANGUAGE NoRebindableSyntax #-}\n" if (zNot z_root (zAbsolute z_root)) then do tell "{-# LANGUAGE ForeignFunctionInterface #-}\n" return () else do return () - if (zSupportsCpp z_root) - then do - tell "#if __GLASGOW_HASKELL__ >= 810\n" - tell "{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}\n" - tell "#endif\n" - return () - else do - return () - tell "{-# OPTIONS_GHC -Wno-missing-import-lists #-}\n" tell "{-# OPTIONS_GHC -w #-}\n" tell "\n" tell "{-|\n" @@ -100,25 +79,8 @@ else do return () tell "\n" - if (zSupportsCpp z_root) - then do - tell "#if defined(VERSION_base)\n" - tell "\n" - tell "#if MIN_VERSION_base(4,0,0)\n" - tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n" - tell "#else\n" - tell "catchIO :: IO a -> (Exception.Exception -> IO a) -> IO a\n" - tell "#endif\n" - tell "\n" - tell "#else\n" - tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n" - tell "#endif\n" - tell "catchIO = Exception.catch\n" - return () - else do - tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n" - tell "catchIO = Exception.catch\n" - return () + tell "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n" + tell "catchIO = Exception.catch\n" tell "\n" tell "-- |The package version.\n" tell "version :: Version\n" diff --git a/src/Distribution/Simple/BuildPaths.hs b/src/Distribution/Simple/BuildPaths.hs --- a/src/Distribution/Simple/BuildPaths.hs +++ b/src/Distribution/Simple/BuildPaths.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -26,6 +27,7 @@ , haddockPref , autogenPackageModulesDir , autogenComponentModulesDir + , preBuildRulesCacheFile , autogenPathsModuleName , autogenPackageInfoModuleName , cppHeaderName @@ -41,6 +43,7 @@ , mkSharedLibName , mkProfSharedLibName , mkStaticLibName + , mkBytecodeLibName , mkGenericSharedBundledLibName , exeExtension , objExtension @@ -158,6 +161,15 @@ autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Source) autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi makeRelativePathEx "autogen" +-- | The path to the pre-build rules cache file for a component, used to +-- compute rule staleness across runs. +preBuildRulesCacheFile + :: LocalBuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg File +preBuildRulesCacheFile lbi clbi = + componentBuildDir lbi clbi makeRelativePathEx "setup-hooks-rules.cache" + -- NB: Look at 'checkForeignDeps' for where a simplified version of this -- has been copy-pasted. @@ -320,8 +332,8 @@ -> [SymbolicPathX allowAbsolute Pkg (Dir Source)] -> [ModuleName.ModuleName] -> IO [(ModuleName.ModuleName, SymbolicPathX allowAbsolute Pkg File)] -getSourceFiles verbosity mbWorkDir dirs modules = flip traverse modules $ \m -> - fmap ((,) m) $ +getSourceFiles verbosity mbWorkDir dirs modules = for modules $ \m -> + fmap (m,) $ findFileCwdWithExtension mbWorkDir builtinHaskellSuffixes @@ -407,6 +419,9 @@ "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion + +mkBytecodeLibName :: CompilerId -> UnitId -> String +mkBytecodeLibName _comp lib = getHSLibraryName lib <.> ".bytecodelib" -- | Create a library name for a bundled shared library from a given name. -- This matches the naming convention for shared libraries as implemented in 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 @@ -3,6 +3,8 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -40,6 +42,7 @@ , reportBuildTargetProblems ) where +import Data.Bifunctor (second) import Distribution.Compat.Prelude import Prelude () @@ -130,6 +133,9 @@ BuildTargetFile ComponentName FilePath deriving (Eq, Show, Generic) +-- | @since 3.18 +deriving instance Ord BuildTarget + instance Binary BuildTarget buildTargetComponentName :: BuildTarget -> ComponentName @@ -228,12 +234,12 @@ tokens :: CabalParsing m => m (String, Maybe (String, Maybe String)) tokens = - (\s -> (s, Nothing)) <$> parsecHaskellString + (,Nothing) <$> parsecHaskellString <|> (,) <$> token <*> P.optional (P.char ':' *> tokens2) tokens2 :: CabalParsing m => m (String, Maybe String) tokens2 = - (\s -> (s, Nothing)) <$> parsecHaskellString + (,Nothing) <$> parsecHaskellString <|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token)) token :: CabalParsing m => m String @@ -326,7 +332,7 @@ (things, got :| _) = unzip' expected' in BuildTargetExpected userTarget (NE.toList things) got | not (null nosuch) = BuildTargetNoSuch userTarget nosuch - | otherwise = error $ "resolveBuildTarget: internal error in matching" + | otherwise = error "resolveBuildTarget: internal error in matching" where expected = [(thing, got) | MatchErrorExpected thing got <- errs] nosuch = [(thing, got) | MatchErrorNoSuch thing got <- errs] @@ -353,9 +359,9 @@ where (amb, unamb) = step ql ts - userTargetQualLevel (UserBuildTargetSingle _) = QL1 - userTargetQualLevel (UserBuildTargetDouble _ _) = QL2 - userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3 + userTargetQualLevel UserBuildTargetSingle{} = QL1 + userTargetQualLevel UserBuildTargetDouble{} = QL2 + userTargetQualLevel UserBuildTargetTriple{} = QL3 step :: QualLevel @@ -407,7 +413,7 @@ targets -> dieWithException verbosity $ UnknownBuildTarget $ - map (\(target, nosuch) -> (showUserBuildTarget target, nosuch)) targets + map (first showUserBuildTarget) targets case [(t, ts) | BuildTargetAmbiguous t ts <- problems] of [] -> return () @@ -417,7 +423,7 @@ map ( \(target, amb) -> ( showUserBuildTarget target - , (map (\(ut, bt) -> (showUserBuildTarget ut, showBuildTargetKind bt)) amb) + , map (\(ut, bt) -> (showUserBuildTarget ut, showBuildTargetKind bt)) amb ) ) targets @@ -652,7 +658,7 @@ orNoSuchThing (showComponentKind ckind ++ " component") str $ increaseConfidenceFor $ matchInexactly - (\(ck, cn) -> (ck, caseFold cn)) + (second caseFold) [((cinfoKind c, cinfoStrName c), c) | c <- cs] (ckind, str) @@ -853,6 +859,9 @@ | MatchErrorNoSuch String String deriving (Show, Eq) +-- | @since 3.18 +deriving instance Ord MatchError + instance Alternative Match where empty = mzero (<|>) = mplus @@ -905,10 +914,10 @@ NoMatch d ms >>= _ = NoMatch d ms ExactMatch d xs >>= f = addDepth d $ - foldr matchPlus matchZero (map f xs) + foldr (matchPlus . f) matchZero xs InexactMatch d xs >>= f = addDepth d . forceInexact $ - foldr matchPlus matchZero (map f xs) + foldr (matchPlus . f) matchZero xs addDepth :: Confidence -> Match a -> Match a addDepth d' (NoMatch d msgs) = NoMatch (d' + d) msgs @@ -941,13 +950,13 @@ increaseConfidenceFor :: Match a -> Match a increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r -nubMatches :: Eq a => Match a -> Match a +nubMatches :: Ord a => Match a -> Match a nubMatches (NoMatch d msgs) = NoMatch d msgs -nubMatches (ExactMatch d xs) = ExactMatch d (nub xs) -nubMatches (InexactMatch d xs) = InexactMatch d (nub xs) +nubMatches (ExactMatch d xs) = ExactMatch d (ordNub xs) +nubMatches (InexactMatch d xs) = InexactMatch d (ordNub xs) nubMatchErrors :: Match a -> Match a -nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs) +nubMatchErrors (NoMatch d msgs) = NoMatch d (ordNub msgs) nubMatchErrors (ExactMatch d xs) = ExactMatch d xs nubMatchErrors (InexactMatch d xs) = InexactMatch d xs @@ -968,14 +977,14 @@ -- | Given a matcher and a key to look up, use the matcher to find all the -- possible matches. There may be 'None', a single 'Unambiguous' match or -- you may have an 'Ambiguous' match with several possibilities. -findMatch :: Eq b => Match b -> MaybeAmbiguous b +findMatch :: Ord b => Match b -> MaybeAmbiguous b findMatch match = case match of - NoMatch _ msgs -> None (nub msgs) + NoMatch _ msgs -> None (ordNub msgs) ExactMatch _ xs -> checkAmbiguous xs InexactMatch _ xs -> checkAmbiguous xs where - checkAmbiguous xs = case nub xs of + checkAmbiguous xs = case ordNub xs of [x] -> Unambiguous x xs' -> Ambiguous xs' @@ -1016,9 +1025,7 @@ matchInexactly cannonicalise xs = \x -> case Map.lookup x m of Just ys -> exactMatches ys - Nothing -> case Map.lookup (cannonicalise x) m' of - Just ys -> inexactMatches ys - Nothing -> matchZero + Nothing -> maybe matchZero inexactMatches (Map.lookup (cannonicalise x) m') where m = Map.fromListWith (++) [(k, [x]) | (k, x) <- xs] diff --git a/src/Distribution/Simple/BuildWay.hs b/src/Distribution/Simple/BuildWay.hs --- a/src/Distribution/Simple/BuildWay.hs +++ b/src/Distribution/Simple/BuildWay.hs @@ -1,14 +1,21 @@ {-# LANGUAGE LambdaCase #-} -module Distribution.Simple.BuildWay where +module Distribution.Simple.BuildWay + ( BuildWay (..) + , buildWayObjectExtension + , buildWayInterfaceExtension + ) where data BuildWay = StaticWay | DynWay | ProfWay | ProfDynWay deriving (Eq, Ord, Show, Read, Enum) --- | Returns the object/interface extension prefix for the given build way (e.g. "dyn_" for 'DynWay') -buildWayPrefix :: BuildWay -> String -buildWayPrefix = \case - StaticWay -> "" - ProfWay -> "p_" - DynWay -> "dyn_" - ProfDynWay -> "p_dyn_" +-- | Returns the object extension for the given build way (e.g. "dyn_o" for 'DynWay' on ELF) +buildWayObjectExtension :: String -> BuildWay -> String +buildWayObjectExtension ext = \case + StaticWay -> ext + ProfWay -> "p_" ++ ext + DynWay -> "dyn_" ++ ext + ProfDynWay -> "p_dyn_" ++ ext + +buildWayInterfaceExtension :: BuildWay -> String +buildWayInterfaceExtension = buildWayObjectExtension "hi" 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 @@ -91,6 +91,7 @@ import Prelude () import qualified Data.Array as Array +import Data.Either (rights) import qualified Data.List as List import Distribution.Compat.Lens (ALens', (#~), (^#)) import qualified Distribution.GetOpt as GetOpt @@ -394,7 +395,7 @@ liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b liftOptDescr get' set' (ChoiceOpt opts) = ChoiceOpt - [ (d, ff, liftSet get' set' set, (get . get')) + [ (d, ff, liftSet get' set' set, get . get') | (d, ff, set, get) <- opts ] liftOptDescr get' set' (OptArg d ff ad set (dv, mkDef) get) = @@ -589,11 +590,11 @@ -- Note: It is crucial to use reverse function composition here or to -- reverse the flags here as we want to process the flags left to right -- but data flow in function composition is right to left. - accum flags = foldr (flip (.)) id [f | Right f <- flags] + accum flags = foldr (flip (.)) id (rights flags) unrecognised opts = [ "unrecognized " ++ "'" - ++ (commandName command) + ++ commandName command ++ "'" ++ " option `" ++ opt @@ -719,7 +720,7 @@ CommandList list -> pure $ CommandList (list ++ commandNames) CommandErrors _ -> pure $ CommandHelp globalHelp CommandReadyToGo (_, []) -> pure $ CommandHelp globalHelp - CommandReadyToGo (_, (name : cmdArgs')) -> + CommandReadyToGo (_, name : cmdArgs') -> case lookupCommand name of [Command _ _ action _] -> case action ("--help" : cmdArgs') of 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 @@ -50,6 +50,7 @@ , interpretPackageDBStack , coercePackageDB , coercePackageDBStack + , readPackageDb -- * Support for optimisation levels , OptimisationLevel (..) @@ -78,12 +79,14 @@ , profilingVanillaSupported , profilingVanillaSupportedOrUnknown , dynamicSupported + , bytecodeArtifactsSupported , backpackSupported , arResponseFilesSupported , arDashLSupported , libraryDynDirSupported , libraryVisibilitySupported , jsemSupported + , jsemVersion , reexportedAsSupported -- * Support for profiling detail levels @@ -93,17 +96,22 @@ , showProfDetailLevel ) where +import Distribution.Compat.CharParsing import Distribution.Compat.Prelude +import Distribution.Parsec import Distribution.Pretty import Prelude () import Distribution.Compiler +import Distribution.Package (PackageName) import Distribution.Simple.Utils +import Distribution.Types.UnitId (UnitId) import Distribution.Utils.Path import Distribution.Version import Language.Haskell.Extension +import Data.Bool (bool) import qualified Data.Map as Map (lookup) import System.Directory (canonicalizePath) @@ -120,12 +128,19 @@ -- ^ Supported language standards. , compilerExtensions :: [(Extension, Maybe CompilerFlag)] -- ^ Supported extensions. + , compilerWiredInUnitIds :: Maybe [(PackageName, UnitId)] + -- ^ 'UnitId's that the compiler doesn't support reinstalling. + -- For instance, when using GHC plugins, one wants to use the exact same + -- version of the `ghc` package as the one the compiler was linked against. + -- 'Nothing' indicates that the compiler hasn't supplied this + -- information and that we should act pessimistically. , compilerProperties :: Map String String -- ^ A key-value map for properties not covered by the above fields. } deriving (Eq, Generic, Show, Read) instance Binary Compiler +instance NFData Compiler instance Structured Compiler showCompilerId :: Compiler -> String @@ -178,6 +193,7 @@ (Just . compilerCompat $ c) (Just . map fst . compilerLanguages $ c) (Just . map fst . compilerExtensions $ c) + (compilerWiredInUnitIds c) -- ------------------------------------------------------------ @@ -201,8 +217,18 @@ deriving (Eq, Generic, Ord, Show, Read, Functor, Foldable, Traversable) instance Binary fp => Binary (PackageDBX fp) +instance NFData fp => NFData (PackageDBX fp) instance Structured fp => Structured (PackageDBX fp) +-- | Parse a PackageDB stack entry +-- +-- @since 3.7.0.0 +readPackageDb :: String -> Maybe PackageDB +readPackageDb "clear" = Nothing +readPackageDb "global" = Just GlobalPackageDB +readPackageDb "user" = Just UserPackageDB +readPackageDb other = Just (SpecificPackageDB (makeSymbolicPath other)) + -- | We typically get packages from several databases, and stack them -- together. This type lets us be explicit about that stacking. For example -- typical stacks include: @@ -292,22 +318,39 @@ deriving (Bounded, Enum, Eq, Generic, Read, Show) instance Binary OptimisationLevel +instance NFData OptimisationLevel instance Structured OptimisationLevel +instance Parsec OptimisationLevel where + parsec = parsecOptimisationLevel + +parsecOptimisationLevel :: CabalParsing m => m OptimisationLevel +parsecOptimisationLevel = boolParser <|> intParser + where + boolParser = bool NoOptimisation NormalOptimisation <$> parsec + intParser = intToOptimisationLevel <$> integral + flagToOptimisationLevel :: Maybe String -> OptimisationLevel flagToOptimisationLevel Nothing = NormalOptimisation flagToOptimisationLevel (Just s) = case reads s of - [(i, "")] - | i >= fromEnum (minBound :: OptimisationLevel) - && i <= fromEnum (maxBound :: OptimisationLevel) -> - toEnum i - | otherwise -> - error $ - "Bad optimisation level: " - ++ show i - ++ ". Valid values are 0..2" + [(i, "")] -> intToOptimisationLevel i _ -> error $ "Can't parse optimisation level " ++ s +intToOptimisationLevel :: Int -> OptimisationLevel +intToOptimisationLevel i + | i >= minLevel && i <= maxLevel = toEnum i + | otherwise = + error $ + "Bad optimisation level: " + ++ show i + ++ ". Valid values are " + ++ show minLevel + ++ ".." + ++ show maxLevel + where + minLevel = fromEnum (minBound :: OptimisationLevel) + maxLevel = fromEnum (maxBound :: OptimisationLevel) + -- ------------------------------------------------------------ -- * Debug info levels @@ -325,8 +368,15 @@ deriving (Bounded, Enum, Eq, Generic, Read, Show) instance Binary DebugInfoLevel +instance NFData DebugInfoLevel instance Structured DebugInfoLevel +instance Parsec DebugInfoLevel where + parsec = parsecDebugInfoLevel + +parsecDebugInfoLevel :: CabalParsing m => m DebugInfoLevel +parsecDebugInfoLevel = flagToDebugInfoLevel . pure <$> parsecToken + flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel flagToDebugInfoLevel Nothing = NormalDebugInfo flagToDebugInfoLevel (Just s) = case reads s of @@ -355,8 +405,7 @@ languageToFlags :: Compiler -> Maybe Language -> [CompilerFlag] languageToFlags comp = filter (not . null) - . catMaybes - . map (languageToFlag comp) + . mapMaybe (languageToFlag comp) . maybe [Haskell98] (\x -> [x]) languageToFlag :: Compiler -> Language -> Maybe CompilerFlag @@ -375,8 +424,7 @@ extensionsToFlags comp = nub . filter (not . null) - . catMaybes - . map (extensionToFlag comp) + . mapMaybe (extensionToFlag comp) -- | Looks up the flag for a given extension, for a given compiler. -- Ignores the subtlety of extensions which lack associated flags. @@ -433,6 +481,15 @@ where v = compilerVersion comp +-- | What semaphore protocol version does this compiler use? +-- +-- Returns @Nothing@ for compilers that don't report a "Semaphore version" +-- field in @ghc --info@ (i.e. GHC 9.8–9.14, which use v1). +jsemVersion :: Compiler -> Maybe Int +jsemVersion comp = case compilerFlavor comp of + GHC -> Map.lookup "Semaphore version" (compilerProperties comp) >>= readMaybe + _ -> Nothing + -- | Does the compiler support the -reexported-modules "A as B" syntax reexportedAsSupported :: Compiler -> Bool reexportedAsSupported comp = case compilerFlavor comp of @@ -445,15 +502,8 @@ -- "dynamic-library-dirs"? libraryDynDirSupported :: Compiler -> Bool libraryDynDirSupported comp = case compilerFlavor comp of - GHC -> - -- Not just v >= mkVersion [8,0,1,20161022], as there - -- are many GHC 8.1 nightlies which don't support this. - ( (v >= mkVersion [8, 0, 1, 20161022] && v < mkVersion [8, 1]) - || v >= mkVersion [8, 1, 20161021] - ) + GHC -> True _ -> False - where - v = compilerVersion comp -- | Does this compiler's "ar" command supports response file -- arguments (i.e. @file-style arguments). @@ -527,6 +577,14 @@ dynamicSupported :: Compiler -> Maybe Bool dynamicSupported comp = waySupported "dyn" comp +-- | Does the compiler support producing bytecode objects and bytecode libraries? +bytecodeArtifactsSupported :: Compiler -> Bool +bytecodeArtifactsSupported comp + | GHC <- compilerFlavor comp + , compilerVersion comp >= mkVersion [9, 15, 0] = + True + | otherwise = False + -- | Does this compiler support a package database entry with: -- "visibility"? libraryVisibilitySupported :: Compiler -> Bool @@ -572,7 +630,14 @@ deriving (Eq, Generic, Read, Show) instance Binary ProfDetailLevel +instance NFData ProfDetailLevel instance Structured ProfDetailLevel + +instance Parsec ProfDetailLevel where + parsec = parsecProfDetailLevel + +parsecProfDetailLevel :: CabalParsing m => m ProfDetailLevel +parsecProfDetailLevel = flagToProfDetailLevel <$> parsecToken flagToProfDetailLevel :: String -> ProfDetailLevel flagToProfDetailLevel "" = ProfDetailDefault 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 @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -32,6 +33,19 @@ module Distribution.Simple.Configure ( configure , configure_setupHooks + , computePackageInfo + , computePackageInfoFromIndex + , configureFinal + , runPreConfPackageHook + , runPostConfPackageHook + , runPreConfComponentHook + , configurePackage + , PackageInfo (..) + , mkProgramDb + , finalCheckPackage + , configureComponents + , mkPromisedDepsSet + , combinedConstraints , writePersistBuildConfig , getConfigStateFile , getPersistBuildConfig @@ -53,6 +67,9 @@ , configCompilerAuxEx , configCompilerProgDb , computeEffectiveProfiling + , adjustBuildOptions + , buildOptionsAdjustmentWarnings + , adjustBuildOptionsAndWarn , ccLdOptionsBuildInfo , checkForeignDeps , interpretPackageDbFlags @@ -77,7 +94,7 @@ import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Package import Distribution.PackageDescription -import Distribution.PackageDescription.Check hiding (doesFileExist) +import Distribution.PackageDescription.Check hiding (doesFileExist, listDirectory) import Distribution.PackageDescription.Configuration import Distribution.PackageDescription.PrettyPrint import Distribution.Simple.BuildTarget @@ -136,10 +153,6 @@ ) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map -import Distribution.Compat.Directory - ( doesPathExist - , listDirectory - ) import Distribution.Compat.Environment (lookupEnv) import Distribution.Parsec ( simpleParsec @@ -157,7 +170,8 @@ ( canonicalizePath , createDirectoryIfMissing , doesFileExist - , removeFile + , doesPathExist + , listDirectory ) import System.FilePath ( isAbsolute @@ -314,7 +328,7 @@ -- ^ The @dist@ directory path. -> IO (Maybe LocalBuildInfo) maybeGetPersistBuildConfig mbWorkDir = - liftM (either (const Nothing) Just) . tryGetPersistBuildConfig mbWorkDir + fmap (either (const Nothing) Just) . tryGetPersistBuildConfig mbWorkDir -- | After running configure, output the 'LocalBuildInfo' to the -- 'localBuildInfoFile'. @@ -424,7 +438,7 @@ -- ^ override \"dist\" prefix -> IO (SymbolicPath Pkg (Dir Dist)) findDistPref defDistPref overrideDistPref = do - envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR") + envDistPref <- parseEnvDistPref <$> lookupEnv "CABAL_BUILDDIR" return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref) where parseEnvDistPref env = @@ -445,111 +459,247 @@ findDistPrefOrDefault = findDistPref defaultDistPref -- | Perform the \"@.\/setup configure@\" action. --- Returns the @.setup-config@ file. +-- +-- Returns the @LocalBuildInfo@, also writing it to the @setup-config@ file. configure :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo -configure = configure_setupHooks noConfigureHooks +configure p cfg = do + lbi <- configure_setupHooks noConfigureHooks p defaultVerbosityHandles cfg + -- Write the 'LocalBuildInfo' to the @setup-config@ file. + -- + -- NB: the shared 'configure_setupHooks'/'configureFinal' functions deliberately + -- don't include this logic, as it is the responsibility of each top-level + -- configure entry point. + let distPref = fromFlag $ configDistPref cfg + mbWorkDir = flagToMaybe $ configWorkingDir cfg + writePersistBuildConfig mbWorkDir distPref lbi + return lbi +-- | Run the @Cabal@ library configure phase. +-- +-- NB: this function does /not/ persist the resulting 'LocalBuildInfo' to the +-- @setup-config@ file; that is the responsibility of callers. configure_setupHooks :: ConfigureHooks -> (GenericPackageDescription, HookedBuildInfo) + -> VerbosityHandles -> ConfigFlags -> IO LocalBuildInfo configure_setupHooks - (ConfigureHooks{preConfPackageHook, postConfPackageHook, preConfComponentHook}) + confHooks@(ConfigureHooks{preConfPackageHook}) (g_pkg_descr, hookedBuildInfo) + verbHandles cfg = do - -- Cabal pre-configure - let verbosity = fromFlag (configVerbosity cfg) - distPref = fromFlag $ configDistPref cfg - mbWorkDir = flagToMaybe $ configWorkingDir cfg - (lbc0, comp, platform, enabledComps) <- preConfigurePackage cfg g_pkg_descr + (lbc0, comp, platform, enabledComps) <- preConfigurePackage verbHandles cfg g_pkg_descr -- Package-wide pre-configure hook lbc1 <- - case preConfPackageHook of - Nothing -> return lbc0 - Just pre_conf -> do - let programDb0 = LBC.withPrograms lbc0 - programDb0' = programDb0{unconfiguredProgs = Map.empty} - input = - SetupHooks.PreConfPackageInputs - { SetupHooks.configFlags = cfg - , SetupHooks.localBuildConfig = lbc0{LBC.withPrograms = programDb0'} - , -- Unconfigured programs are not supplied to the hook, - -- as these cannot be passed over a serialisation boundary - -- (see the "Binary ProgramDb" instance). - SetupHooks.compiler = comp - , SetupHooks.platform = platform - } - SetupHooks.PreConfPackageOutputs - { SetupHooks.buildOptions = opts1 - , SetupHooks.extraConfiguredProgs = progs1 - } <- - pre_conf input - -- The package-wide pre-configure hook returns BuildOptions that - -- overrides the one it was passed in, as well as an update to - -- the ProgramDb in the form of new configured programs to add - -- to the program database. - return $ - lbc0 - { LBC.withBuildOptions = opts1 - , LBC.withPrograms = - updateConfiguredProgs - (`Map.union` progs1) - programDb0 - } + maybe + (return lbc0) + (runPreConfPackageHook cfg comp platform lbc0) + preConfPackageHook -- Cabal package-wide configure - (lbc2, pbd2, pkg_info) <- - finalizeAndConfigurePackage cfg lbc1 g_pkg_descr comp platform enabledComps + (allConstraints, pkgInfo) <- + computePackageInfo verbHandles cfg lbc1 g_pkg_descr comp + (packageDbs, pkg_descr0, flags) <- + finalizePackageDescription + verbHandles + cfg + g_pkg_descr + comp + platform + enabledComps + allConstraints + pkgInfo - -- Package-wide post-configure hook - for_ postConfPackageHook $ \postConfPkg -> do - let input = - SetupHooks.PostConfPackageInputs - { SetupHooks.localBuildConfig = lbc2 - , SetupHooks.packageBuildDescr = pbd2 - } - postConfPkg input + configureFinal + verbHandles + confHooks + hookedBuildInfo + cfg + lbc1 + (g_pkg_descr, pkg_descr0) + flags + enabledComps + comp + platform + packageDbs + pkgInfo - -- Per-component pre-configure hook - pkg_descr <- do - let pkg_descr2 = LBC.localPkgDescr pbd2 - applyComponentDiffs - verbosity - ( \c -> for preConfComponentHook $ \computeDiff -> do - let input = - SetupHooks.PreConfComponentInputs - { SetupHooks.localBuildConfig = lbc2 - , SetupHooks.packageBuildDescr = pbd2 - , SetupHooks.component = c - } - SetupHooks.PreConfComponentOutputs - { SetupHooks.componentDiff = diff - } <- - computeDiff input - return diff - ) - pkg_descr2 - let pbd3 = pbd2{LBC.localPkgDescr = pkg_descr} +configureFinal + :: VerbosityHandles + -> ConfigureHooks + -> HookedBuildInfo + -> ConfigFlags + -> LBC.LocalBuildConfig + -> (GenericPackageDescription, PackageDescription) + -> FlagAssignment + -> ComponentRequestedSpec + -> Compiler + -> Platform + -> PackageDBStack + -> PackageInfo + -> IO LocalBuildInfo +configureFinal + verbHandles + (ConfigureHooks{postConfPackageHook, preConfComponentHook}) + hookedBuildInfo + cfg + lbc0 + (gpkgDescr, pkgDescr0) + flags + enabledComps + comp + platform + packageDbs + pkgInfo@PackageInfo + { installedPackageSet = installedPkgSet + , promisedDepsSet = promisedDeps + } = + do + let verbosity = mkVerbosity verbHandles (fromFlag (configVerbosity cfg)) - -- Cabal per-component configure - externalPkgDeps <- finalCheckPackage g_pkg_descr pbd3 hookedBuildInfo pkg_info - lbi <- configureComponents lbc2 pbd3 pkg_info externalPkgDeps + -- Apply compiler capability checks to the incoming build options + -- (idempotent). + lbc1 <- do + let opts = LBC.withBuildOptions lbc0 + opts' <- adjustBuildOptionsAndWarn verbosity comp (LBC.withPrograms lbc0) opts + return lbc0{LBC.withBuildOptions = opts'} - writePersistBuildConfig mbWorkDir distPref lbi + -- Cabal package-wide configure + (lbc2, pbd2) <- + configurePackage verbHandles cfg lbc1 pkgDescr0 flags enabledComps comp platform packageDbs - return lbi + -- Package-wide post-configure hook + for_ postConfPackageHook $ runPostConfPackageHook lbc2 pbd2 -preConfigurePackage + -- Per-component pre-configure hooks + pkgDescr <- do + let pkgDescr2 = LBC.localPkgDescr pbd2 + applyComponentDiffs + verbosity + (for preConfComponentHook . runPreConfComponentHook lbc2 pbd2) + pkgDescr2 + let pbd3 = pbd2{LBC.localPkgDescr = pkgDescr} + + -- Cabal per-component configure + finalCheckPackage verbHandles gpkgDescr pbd3 hookedBuildInfo + + let + use_external_internal_deps = + case enabledComps of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + -- The list of 'InstalledPackageInfo' recording the selected + -- dependencies on external packages. + -- + -- Invariant: For any package name, there is at most one package + -- in externalPackageDeps which has that name. + -- + -- NB: The dependency selection is global over ALL components + -- in the package (similar to how allConstraints and + -- requiredDepsMap are global over all components). In particular, + -- if *any* component (post-flag resolution) has an unsatisfiable + -- dependency, we will fail. This can sometimes be undesirable + -- for users, see #1786 (benchmark conflicts with executable), + -- + -- In the presence of Backpack, these package dependencies are + -- NOT complete: they only ever include the INDEFINITE + -- dependencies. After we apply an instantiation, we'll get + -- definite references which constitute extra dependencies. + -- (Why not have cabal-install pass these in explicitly? + -- For one it's deterministic; for two, we need to associate + -- them with renamings which would require a far more complicated + -- input scheme than what we have today.) + externalPkgDeps <- + selectDependencies + verbosity + use_external_internal_deps + pkgInfo + pkgDescr + enabledComps + configureComponents verbHandles lbc2 pbd3 installedPkgSet promisedDeps externalPkgDeps + +runPreConfPackageHook :: ConfigFlags + -> Compiler + -> Platform + -> LBC.LocalBuildConfig + -> (SetupHooks.PreConfPackageInputs -> IO SetupHooks.PreConfPackageOutputs) + -> IO LBC.LocalBuildConfig +runPreConfPackageHook cfg comp platform lbc0 pre_conf = do + let programDb0 = LBC.withPrograms lbc0 + programDb0' = programDb0{unconfiguredProgs = Map.empty} + input = + SetupHooks.PreConfPackageInputs + { SetupHooks.configFlags = cfg + , SetupHooks.localBuildConfig = lbc0{LBC.withPrograms = programDb0'} + , -- Unconfigured programs are not supplied to the hook, + -- as these cannot be passed over a serialisation boundary + -- (see the "Binary ProgramDb" instance). + SetupHooks.compiler = comp + , SetupHooks.platform = platform + } + SetupHooks.PreConfPackageOutputs + { SetupHooks.buildOptions = opts1 + , SetupHooks.extraConfiguredProgs = progs1 + } <- + pre_conf input + -- The package-wide pre-configure hook returns a 'BuildOptions' that + -- overrides the one it was passed in, as well as an update to + -- the 'ProgramDb' in the form of new configured programs to add + -- to the program database. + return $ + lbc0 + { LBC.withBuildOptions = opts1 + , LBC.withPrograms = + updateConfiguredProgs + (`Map.union` progs1) + programDb0 + } + +runPostConfPackageHook + :: LBC.LocalBuildConfig + -> LBC.PackageBuildDescr + -> (SetupHooks.PostConfPackageInputs -> IO ()) + -> IO () +runPostConfPackageHook lbc2 pbd2 postConfPkg = + let input = + SetupHooks.PostConfPackageInputs + { SetupHooks.localBuildConfig = lbc2 + , SetupHooks.packageBuildDescr = pbd2 + } + in postConfPkg input + +runPreConfComponentHook + :: LBC.LocalBuildConfig + -> LBC.PackageBuildDescr + -> Component + -> (SetupHooks.PreConfComponentInputs -> IO SetupHooks.PreConfComponentOutputs) + -> IO SetupHooks.ComponentDiff +runPreConfComponentHook lbc pbd c hook = do + let input = + SetupHooks.PreConfComponentInputs + { SetupHooks.localBuildConfig = lbc + , SetupHooks.packageBuildDescr = pbd + , SetupHooks.component = c + } + SetupHooks.PreConfComponentOutputs + { SetupHooks.componentDiff = diff + } <- + hook input + return diff + +preConfigurePackage + :: VerbosityHandles + -> ConfigFlags -> GenericPackageDescription -> IO (LBC.LocalBuildConfig, Compiler, Platform, ComponentRequestedSpec) -preConfigurePackage cfg g_pkg_descr = do - let verbosity = fromFlag $ configVerbosity cfg +preConfigurePackage verbHandles cfg g_pkg_descr = do + let verbosity = mkVerbosity verbHandles (fromFlag $ configVerbosity cfg) -- Determine the component we are configuring, if a user specified -- one on the command line. We use a fake, flattened version of @@ -584,9 +734,8 @@ -- Make a data structure describing what components are enabled. let enabled :: ComponentRequestedSpec - enabled = case mb_cname of - Just cname -> OneComponentRequestedSpec cname - Nothing -> + enabled = + maybe ComponentRequestedSpec { -- The flag name (@--enable-tests@) is a -- little bit of a misnomer, because @@ -596,9 +745,10 @@ -- @buildable: False@ might make it -- not possible to enable. testsRequested = fromFlag (configTests cfg) - , benchmarksRequested = - fromFlag (configBenchmarks cfg) + , benchmarksRequested = fromFlag (configBenchmarks cfg) } + OneComponentRequestedSpec + mb_cname -- Some sanity checks related to enabling components. when ( isJust mb_cname @@ -609,7 +759,7 @@ checkDeprecatedFlags verbosity cfg checkExactConfiguration verbosity g_pkg_descr cfg - programDbPre <- mkProgramDb cfg (configPrograms cfg) + programDbPre <- mkProgramDb verbHandles cfg (configPrograms cfg) -- comp: the compiler we're building with -- compPlatform: the platform we're building for -- programDb: location and args of all programs we're @@ -623,7 +773,7 @@ (flagToMaybe (configHcPath cfg)) (flagToMaybe (configHcPkg cfg)) programDbPre - (lessVerbose verbosity) + (modifyVerbosityFlags lessVerbose verbosity) -- Where to build the package let builddir :: SymbolicPath Pkg (Dir Build) -- e.g. dist/build @@ -632,74 +782,42 @@ -- NB: create this directory now so that all configure hooks get -- to see it. (In practice, the Configure build-type needs it before -- the postConfPackageHook runs.) - createDirectoryIfMissingVerbose (lessVerbose verbosity) True $ + createDirectoryIfMissingVerbose (modifyVerbosityFlags lessVerbose verbosity) True $ interpretSymbolicPath mbWorkDir builddir - lbc <- computeLocalBuildConfig cfg comp programDb00 + lbc <- computeLocalBuildConfig verbHandles cfg comp programDb00 return (lbc, comp, compPlatform, enabled) computeLocalBuildConfig - :: ConfigFlags + :: VerbosityHandles + -> ConfigFlags -> Compiler -> ProgramDb -> IO LBC.LocalBuildConfig -computeLocalBuildConfig cfg comp programDb = do +computeLocalBuildConfig verbHandles cfg comp programDb = do let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common - -- Decide if we're going to compile with split sections. - split_sections :: Bool <- - if not (fromFlag $ configSplitSections cfg) - then return False - else case compilerFlavor comp of - GHC - | compilerVersion comp >= mkVersion [8, 0] -> - return True - GHCJS -> - return True - _ -> do - warn - verbosity - ( "this compiler does not support " - ++ "--enable-split-sections; ignoring" - ) - return False - - -- Decide if we're going to compile with split objects. - split_objs :: Bool <- - if not (fromFlag $ configSplitObjs cfg) - then return False - else case compilerFlavor comp of - _ | split_sections -> - do - warn - verbosity - ( "--enable-split-sections and " - ++ "--enable-split-objs are mutually " - ++ "exclusive; ignoring the latter" - ) - return False - GHC -> - return True - GHCJS -> - return True - _ -> do - warn - verbosity - ( "this compiler does not support " - ++ "--enable-split-objs; ignoring" - ) - return False + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + rawBuildOptions <- buildOptionsFromConfigFlags verbosity cfg comp + buildOptions <- adjustBuildOptionsAndWarn verbosity comp programDb rawBuildOptions + return $ + LBC.LocalBuildConfig + { extraConfigArgs = [] + , -- Currently configure does not + -- take extra args, but if it + -- did they would go here. + withPrograms = programDb + , withBuildOptions = buildOptions + } - -- Basically yes/no/unknown. - let linkerSupportsRelocations :: Maybe Bool - linkerSupportsRelocations = - case lookupProgramByName "ld" programDb of - Nothing -> Nothing - Just ld -> - case Map.lookup "Supports relocatable output" $ programProperties ld of - Just "YES" -> Just True - Just "NO" -> Just False - _other -> Nothing +-- | Compute a default 'LBC.BuildOptions' from 'ConfigFlags', applying +-- compiler-specific defaults but without compiler capability checks +-- (see 'adjustBuildOptionsAndWarn' for that). +buildOptionsFromConfigFlags + :: Verbosity + -> ConfigFlags + -> Compiler + -> IO LBC.BuildOptions +buildOptionsFromConfigFlags verbosity cfg comp = do let ghciLibByDefault = case compilerId comp of CompilerId GHC _ -> @@ -711,22 +829,11 @@ -- rely on them. By the time that bug was fixed, ghci had -- been changed to read shared libraries instead of archive -- files (see next code block). - not (GHC.compilerBuildWay comp `elem` [DynWay, ProfDynWay]) + GHC.compilerBuildWay comp `notElem` [DynWay, ProfDynWay] CompilerId GHCJS _ -> not (GHCJS.isDynamic comp) _ -> False - withGHCiLib_ <- - case fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg) of - -- NOTE: If linkerSupportsRelocations is Nothing this may still fail if the - -- linker does not support -r. - True | not (fromMaybe True linkerSupportsRelocations) -> do - warn verbosity $ - "--enable-library-for-ghci is not supported with the current" - ++ " linker; ignoring..." - return False - v -> return v - let sharedLibsByDefault | fromFlag (configDynExe cfg) = -- build a shared library if dynamically-linked @@ -752,6 +859,10 @@ -- into a huge .a archive) via GHCs -staticlib flag. fromFlagOrDefault False $ configStaticLib cfg + -- See doc/internal/bytecode-libraries.md for the end-to-end story. + withBytecodeLib_ = + fromFlagOrDefault False $ configBytecodeLib cfg + withDynExe_ = fromFlag $ configDynExe cfg withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg @@ -779,75 +890,191 @@ strip_lib <- strip_libexe "library" configStripLibs strip_exe <- strip_libexe "executable" configStripExes - let buildOptions = - setCoverage . setProfiling $ - LBC.BuildOptions - { withVanillaLib = fromFlag $ configVanillaLib cfg - , withSharedLib = withSharedLib_ - , withStaticLib = withStaticLib_ - , withDynExe = withDynExe_ - , withFullyStaticExe = withFullyStaticExe_ - , withProfLib = False - , withProfLibShared = False - , withProfLibDetail = ProfDetailNone - , withProfExe = False - , withProfExeDetail = ProfDetailNone - , withOptimization = fromFlag $ configOptimization cfg - , withDebugInfo = fromFlag $ configDebugInfo cfg - , withGHCiLib = withGHCiLib_ - , splitSections = split_sections - , splitObjs = split_objs - , stripExes = strip_exe - , stripLibs = strip_lib - , exeCoverage = False - , libCoverage = False - , relocatable = fromFlagOrDefault False $ configRelocatable cfg - } + return $ + setCoverage . setProfiling $ + LBC.BuildOptions + { withVanillaLib = fromFlag $ configVanillaLib cfg + , withSharedLib = withSharedLib_ + , withStaticLib = withStaticLib_ + , withBytecodeLib = withBytecodeLib_ + , withDynExe = withDynExe_ + , withFullyStaticExe = withFullyStaticExe_ + , withProfLib = False + , withProfLibShared = False + , withProfLibDetail = ProfDetailNone + , withProfExe = False + , withProfExeDetail = ProfDetailNone + , withOptimization = fromFlag $ configOptimization cfg + , withDebugInfo = fromFlag $ configDebugInfo cfg + , withGHCiLib = fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg) + , splitSections = fromFlagOrDefault False $ configSplitSections cfg + , splitObjs = fromFlagOrDefault False $ configSplitObjs cfg + , stripExes = strip_exe + , stripLibs = strip_lib + , exeCoverage = False + , libCoverage = False + , relocatable = fromFlagOrDefault False $ configRelocatable cfg + } - -- Dynamic executable, but no shared vanilla libraries - when (LBC.withDynExe buildOptions && not (LBC.withProfExe buildOptions) && not (LBC.withSharedLib buildOptions)) $ - warn verbosity $ - "Executables will use dynamic linking, but a shared library " - ++ "is not being built. Linking will fail if any executables " - ++ "depend on the library." +-- | Adjust 'LBC.BuildOptions' to be compatible with the given 'Compiler' and +-- 'ProgramDb'. +-- +-- See also 'adjustBuildOptionsAndWarn', which additionally informs the user +-- of unavailable requested features via warning messages. +adjustBuildOptions :: Compiler -> ProgramDb -> LBC.BuildOptions -> LBC.BuildOptions +adjustBuildOptions comp programDb opts = + opts + { LBC.splitSections = splitSec + , LBC.splitObjs = splitObj + , LBC.withGHCiLib = ghciLib + , LBC.withBytecodeLib = bytecodeLib + , LBC.exeCoverage = exeCov + , LBC.libCoverage = libCov + } + where + splitSec + | not (LBC.splitSections opts) = False + | GHC <- compilerFlavor comp + , compilerVersion comp >= mkVersion [8, 0] = + True + | GHCJS <- compilerFlavor comp = True + | otherwise = False -- not supported by this compiler + splitObj + | not (LBC.splitObjs opts) = False + | splitSec = False -- mutually exclusive with split-sections + | GHC <- compilerFlavor comp = True + | GHCJS <- compilerFlavor comp = True + | otherwise = False -- not supported by this compiler + linkerSupportsRelocations :: Maybe Bool + linkerSupportsRelocations = + case lookupProgramByName "ld" programDb of + Nothing -> Nothing + Just ld -> + case Map.lookup "Supports relocatable output" $ programProperties ld of + Just "YES" -> Just True + Just "NO" -> Just False + _other -> Nothing - -- Profiled dynamic executable, but no shared profiling libraries - when (LBC.withDynExe buildOptions && LBC.withProfExe buildOptions && not (LBC.withProfLibShared buildOptions)) $ - warn verbosity $ - "Executables will use profiled dynamic linking, but a profiled shared library " - ++ "is not being built. Linking will fail if any executables " - ++ "depend on the library." + ghciLib + | LBC.withGHCiLib opts + , not (fromMaybe True linkerSupportsRelocations) = + False + | otherwise = LBC.withGHCiLib opts - return $ - LBC.LocalBuildConfig - { extraConfigArgs = [] -- Currently configure does not - -- take extra args, but if it - -- did they would go here. - , withPrograms = programDb - , withBuildOptions = buildOptions - } + bytecodeLib + | LBC.withBytecodeLib opts + , not (bytecodeArtifactsSupported comp) = + False + | otherwise = LBC.withBytecodeLib opts + exeCov + | LBC.exeCoverage opts, not (coverageSupported comp) = False + | otherwise = LBC.exeCoverage opts + + libCov + | LBC.libCoverage opts, not (coverageSupported comp) = False + | otherwise = LBC.libCoverage opts + +-- | Warnings to emit after downgrading 'LBC.BuildOptions' when the +-- compiler (or another toolchain program) doesn't support a requested feature. +buildOptionsAdjustmentWarnings + :: Compiler + -> LBC.BuildOptions + -- ^ original options + -> LBC.BuildOptions + -- ^ adjusted options (result of 'adjustBuildOptions') + -> [String] +buildOptionsAdjustmentWarnings comp opts0 opts1 = + [ "This compiler does not support bytecode libraries; ignoring --enable-library-bytecode" + | LBC.withBytecodeLib opts0 + , not (LBC.withBytecodeLib opts1) + ] + ++ [ "this compiler does not support --enable-split-sections; ignoring" + | LBC.splitSections opts0 + , not (LBC.splitSections opts1) + ] + ++ [ if LBC.splitSections opts1 + then + "--enable-split-sections and --enable-split-objs are mutually " + ++ "exclusive; ignoring the latter" + else "this compiler does not support --enable-split-objs; ignoring" + | LBC.splitObjs opts0 + , not (LBC.splitObjs opts1) + ] + ++ [ "--enable-library-for-ghci is not supported with the current" + ++ " linker; ignoring..." + | LBC.withGHCiLib opts0 + , not (LBC.withGHCiLib opts1) + ] + ++ [ "The compiler " + ++ showCompilerId comp + ++ " does not support " + ++ "program coverage. Program coverage has been disabled." + | LBC.exeCoverage opts0 + , not (LBC.exeCoverage opts1) + ] + +-- | Like 'adjustBuildOptions', but includes warnings for downgraded +-- build options. +adjustBuildOptionsAndWarn + :: Verbosity + -> Compiler + -> ProgramDb + -> LBC.BuildOptions + -> IO LBC.BuildOptions +adjustBuildOptionsAndWarn verbosity comp programDb opts0 = do + let opts1 = adjustBuildOptions comp programDb opts0 + mapM_ (warn verbosity) (buildOptionsAdjustmentWarnings comp opts0 opts1) + + -- Also warn for any inconsistencies found in BuildOptions. + when + ( LBC.withDynExe opts1 + && not (LBC.withProfExe opts1) + && not (LBC.withSharedLib opts1) + ) + $ warn verbosity + $ "Executables will use dynamic linking, but a shared library " + ++ "is not being built. Linking will fail if any executables " + ++ "depend on the library." + when + ( LBC.withDynExe opts1 + && LBC.withProfExe opts1 + && not (LBC.withProfLibShared opts1) + ) + $ warn verbosity + $ "Executables will use profiled dynamic linking, but a profiled shared library " + ++ "is not being built. Linking will fail if any executables " + ++ "depend on the library." + return opts1 + data PackageInfo = PackageInfo { internalPackageSet :: Set LibraryName + -- ^ Libraries internal to the package , promisedDepsSet :: Map (PackageName, ComponentName) PromisedComponent + -- ^ Collection of components that are promised, i.e. are not installed already. + -- + -- See 'PromisedDependency' for more details. , installedPackageSet :: InstalledPackageIndex + -- ^ Installed packages , requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ Packages for which we have been given specific deps to use } configurePackage - :: ConfigFlags + :: VerbosityHandles + -> ConfigFlags -> LBC.LocalBuildConfig -> PackageDescription -> FlagAssignment -> ComponentRequestedSpec -> Compiler -> Platform - -> ProgramDb -> PackageDBStack -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr) -configurePackage cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 packageDbs = do +configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform packageDbs = do let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + programDb0 = LBC.withPrograms lbc0 -- add extra include/lib dirs as specified in cfg pkg_descr0 = addExtraIncludeLibDirsFromConfigFlags pkg_descr00 cfg @@ -883,12 +1110,12 @@ let unknownBuildTools = [ buildTool | buildTool <- buildTools bi - , Nothing == desugarBuildTool pkg_descr0 buildTool + , isNothing (desugarBuildTool pkg_descr0 buildTool) ] externBuildToolDeps ++ unknownBuildTools programDb1 <- - configureAllKnownPrograms (lessVerbose verbosity) programDb0 + configureAllKnownPrograms (modifyVerbosityFlags lessVerbose verbosity) programDb0 >>= configureRequiredPrograms verbosity requiredBuildTools (pkg_descr2, programDb2) <- @@ -907,7 +1134,7 @@ defaultInstallDirs' use_external_internal_deps (compilerFlavor comp) - (fromFlag (configUserInstall cfg)) + (fromFlagOrDefault True (configUserInstall cfg)) (hasLibs pkg_descr2) let installDirs = @@ -936,17 +1163,16 @@ return (lbc, pbd) -finalizeAndConfigurePackage - :: ConfigFlags +computePackageInfo + :: VerbosityHandles + -> ConfigFlags -> LBC.LocalBuildConfig -> GenericPackageDescription -> Compiler - -> Platform - -> ComponentRequestedSpec - -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr, PackageInfo) -finalizeAndConfigurePackage cfg lbc0 g_pkg_descr comp platform enabled = do + -> IO ([PackageVersionConstraint], PackageInfo) +computePackageInfo verbHandles cfg lbc0 g_pkg_descr comp = do let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) mbWorkDir = flagToMaybe $ setupWorkingDir common let programDb0 = LBC.withPrograms lbc0 @@ -954,21 +1180,33 @@ packageDbs :: PackageDBStack packageDbs = interpretPackageDbFlags - (fromFlag (configUserInstall cfg)) + (fromFlagOrDefault True (configUserInstall cfg)) (configPackageDBs cfg) -- The InstalledPackageIndex of all installed packages installedPackageSet :: InstalledPackageIndex <- getInstalledPackages - (lessVerbose verbosity) + (modifyVerbosityFlags lessVerbose verbosity) comp mbWorkDir packageDbs programDb0 + computePackageInfoFromIndex verbHandles cfg g_pkg_descr installedPackageSet - -- The set of package names which are "shadowed" by internal - -- packages, and which component they map to - let internalPackageSet :: Set LibraryName +-- | Like 'computePackageInfo' but takes a given 'InstalledPackageIndex' +-- instead of needing to query the @hc-pkg@ program to obtain it. +computePackageInfoFromIndex + :: VerbosityHandles + -> ConfigFlags + -> GenericPackageDescription + -> InstalledPackageIndex + -> IO ([PackageVersionConstraint], PackageInfo) +computePackageInfoFromIndex verbHandles cfg g_pkg_descr installedPackageSet = do + let common = configCommonFlags cfg + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + -- The set of package names which are "shadowed" by internal + -- packages, and which component they map to + internalPackageSet :: Set LibraryName internalPackageSet = getInternalLibraries g_pkg_descr -- Some sanity checks related to dynamic/static linking. @@ -999,14 +1237,37 @@ let promisedDepsSet = mkPromisedDepsSet (configPromisedDependencies cfg) - pkg_info = - PackageInfo + return + ( allConstraints + , PackageInfo { internalPackageSet , promisedDepsSet , installedPackageSet , requiredDepsMap } + ) +finalizePackageDescription + :: VerbosityHandles + -> ConfigFlags + -> GenericPackageDescription + -> Compiler + -> Platform + -> ComponentRequestedSpec + -> [PackageVersionConstraint] + -> PackageInfo + -> IO (PackageDBStack, PackageDescription, FlagAssignment) +finalizePackageDescription verbHandles cfg g_pkg_descr comp platform enabled allConstraints pkgInfo = do + let common = configCommonFlags cfg + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + + -- What package database(s) to use + let packageDbs :: PackageDBStack + packageDbs = + interpretPackageDbFlags + (fromFlagOrDefault True (configUserInstall cfg)) + (configPackageDBs cfg) + -- pkg_descr: The resolved package description, that does not contain any -- conditionals, because we have an assignment for -- every flag, either picking them ourselves using a @@ -1028,7 +1289,7 @@ ( pkg_descr0 :: PackageDescription , flags :: FlagAssignment ) <- - configureFinalizedPackage + finalizePackageDescription2 verbosity cfg enabled @@ -1038,27 +1299,12 @@ (fromFlagOrDefault False (configExactConfiguration cfg)) (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg)) (packageName g_pkg_descr) - installedPackageSet - internalPackageSet - promisedDepsSet - requiredDepsMap + pkgInfo ) comp platform g_pkg_descr - - (lbc, pbd) <- - configurePackage - cfg - lbc0 - pkg_descr0 - flags - enabled - comp - platform - programDb0 - packageDbs - return (lbc, pbd, pkg_info) + return (packageDbs, pkg_descr0, flags) addExtraIncludeLibDirsFromConfigFlags :: PackageDescription -> ConfigFlags -> PackageDescription @@ -1110,12 +1356,13 @@ } finalCheckPackage - :: GenericPackageDescription + :: VerbosityHandles + -> GenericPackageDescription -> LBC.PackageBuildDescr -> HookedBuildInfo - -> PackageInfo - -> IO ([PreExistingComponent], [ConfiguredPromisedComponent]) + -> IO () finalCheckPackage + verbHandles g_pkg_descr ( LBC.PackageBuildDescr { configFlags = cfg @@ -1125,16 +1372,11 @@ , componentEnabledSpec = enabled } ) - hookedBuildInfo - (PackageInfo{internalPackageSet, promisedDepsSet, installedPackageSet, requiredDepsMap}) = + hookedBuildInfo = do let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) cabalFileDir = packageRoot common - use_external_internal_deps = - case enabled of - OneComponentRequestedSpec{} -> True - ComponentRequestedSpec{} -> False checkCompilerProblems verbosity comp pkg_descr enabled checkPackageProblems @@ -1150,70 +1392,39 @@ -- Check languages and extensions -- TODO: Move this into a helper function. let langlist = - nub $ - catMaybes $ - map - defaultLanguage - (enabledBuildInfos pkg_descr enabled) + ordNub $ + mapMaybe defaultLanguage (enabledBuildInfos pkg_descr enabled) let langs = unsupportedLanguages comp langlist - when (not (null langs)) $ + unless (null langs) $ dieWithException verbosity $ - UnsupportedLanguages (packageId g_pkg_descr) (compilerId comp) (map prettyShow langs) + UnsupportedLanguages (packageId pkg_descr) (compilerId comp) (map prettyShow langs) let extlist = - nub $ + ordNub $ concatMap allExtensions (enabledBuildInfos pkg_descr enabled) let exts = unsupportedExtensions comp extlist - when (not (null exts)) $ + unless (null exts) $ dieWithException verbosity $ - UnsupportedLanguageExtension (packageId g_pkg_descr) (compilerId comp) (map prettyShow exts) + UnsupportedLanguageExtension (packageId pkg_descr) (compilerId comp) (map prettyShow exts) -- Check foreign library build requirements let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled] let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs - when (not (null unsupportedFLibs)) $ + unless (null unsupportedFLibs) $ dieWithException verbosity $ CantFindForeignLibraries unsupportedFLibs - -- The list of 'InstalledPackageInfo' recording the selected - -- dependencies on external packages. - -- - -- Invariant: For any package name, there is at most one package - -- in externalPackageDeps which has that name. - -- - -- NB: The dependency selection is global over ALL components - -- in the package (similar to how allConstraints and - -- requiredDepsMap are global over all components). In particular, - -- if *any* component (post-flag resolution) has an unsatisfiable - -- dependency, we will fail. This can sometimes be undesirable - -- for users, see #1786 (benchmark conflicts with executable), - -- - -- In the presence of Backpack, these package dependencies are - -- NOT complete: they only ever include the INDEFINITE - -- dependencies. After we apply an instantiation, we'll get - -- definite references which constitute extra dependencies. - -- (Why not have cabal-install pass these in explicitly? - -- For one it's deterministic; for two, we need to associate - -- them with renamings which would require a far more complicated - -- input scheme than what we have today.) - configureDependencies - verbosity - use_external_internal_deps - internalPackageSet - promisedDepsSet - installedPackageSet - requiredDepsMap - pkg_descr - enabled - configureComponents - :: LBC.LocalBuildConfig + :: VerbosityHandles + -> LBC.LocalBuildConfig -> LBC.PackageBuildDescr - -> PackageInfo + -> InstalledPackageIndex + -> Map (PackageName, ComponentName) PromisedComponent -> ([PreExistingComponent], [ConfiguredPromisedComponent]) -> IO LocalBuildInfo configureComponents + verbHandles lbc@(LBC.LocalBuildConfig{withPrograms = programDb}) pbd0@( LBC.PackageBuildDescr { configFlags = cfg @@ -1222,11 +1433,12 @@ , componentEnabledSpec = enabled } ) - (PackageInfo{promisedDepsSet, installedPackageSet}) + installedPackageSet + promisedDepsSet externalPkgDeps = do let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) use_external_internal_deps = case enabled of OneComponentRequestedSpec{} -> True @@ -1362,6 +1574,7 @@ dirinfo "Executables" (bindir dirs) (bindir relative) dirinfo "Libraries" (libdir dirs) (libdir relative) dirinfo "Dynamic Libraries" (dynlibdir dirs) (dynlibdir relative) + dirinfo "Bytecode Libraries" (bytecodelibdir dirs) (bytecodelibdir relative) dirinfo "Private executables" (libexecdir dirs) (libexecdir relative) dirinfo "Data files" (datadir dirs) (datadir relative) dirinfo "Documentation" (docdir dirs) (docdir relative) @@ -1380,16 +1593,17 @@ -- | Adds the extra program paths from the flags provided to @configure@ as -- well as specified locations for certain known programs and their default -- arguments. -mkProgramDb :: ConfigFlags -> ProgramDb -> IO ProgramDb -mkProgramDb cfg initialProgramDb = do +mkProgramDb :: VerbosityHandles -> ConfigFlags -> ProgramDb -> IO ProgramDb +mkProgramDb verbHandles cfg initialProgramDb = do programDb <- modifyProgramSearchPath (getProgramSearchPath initialProgramDb ++) -- We need to have the paths to programs installed by build-tool-depends before all other paths - <$> prependProgramSearchPath (fromFlagOrDefault normal (configVerbosity cfg)) searchpath [] initialProgramDb + <$> prependProgramSearchPath verbosity searchpath [] initialProgramDb pure . userSpecifyArgss (configProgramArgs cfg) . userSpecifyPaths (configProgramPaths cfg) $ programDb where + verbosity = mkVerbosity verbHandles $ fromFlagOrDefault normal (configVerbosity cfg) searchpath = fromNubList (configProgramPathExtra cfg) -- Note. We try as much as possible to _prepend_ rather than postpend the extra-prog-path @@ -1442,7 +1656,7 @@ let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg)) allFlags = map flagName . genPackageFlags $ pkg_descr0 diffFlags = allFlags \\ cmdlineFlags - when (not . null $ diffFlags) $ + unless (null diffFlags) $ dieWithException verbosity $ FlagsNotSpecified diffFlags @@ -1474,23 +1688,19 @@ -> Bool -- ^ allow depending on private libs? -> PackageName - -> InstalledPackageIndex - -- ^ installed set - -> Set LibraryName - -- ^ library components - -> Map (PackageName, ComponentName) PromisedComponent - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ required dependencies + -> PackageInfo -> (Dependency -> DependencySatisfaction) dependencySatisfiable use_external_internal_deps exact_config allow_private_deps pn - installedPackageSet - packageLibraries - promisedDeps - requiredDepsMap + PackageInfo + { internalPackageSet = packageLibraries + , promisedDepsSet = promisedDeps + , installedPackageSet + , requiredDepsMap + } (Dependency depName vr sublibs) | exact_config = -- When we're given '--exact-configuration', we assume that all @@ -1539,12 +1749,12 @@ in if null $ PackageIndex.matchingDependencies vr allVersions then if null eligibleVersions - then Unsatisfied $ MissingPackage + then Unsatisfied MissingPackage else Unsatisfied $ WrongVersion eligibleVersions else Satisfied internalDepSatisfiable = - let missingLibraries = (NES.toSet sublibs) `Set.difference` packageLibraries + let missingLibraries = NES.toSet sublibs `Set.difference` packageLibraries in case nonEmpty $ Set.toList missingLibraries of Nothing -> Satisfied Just missingLibraries' -> Unsatisfied $ MissingLibrary missingLibraries' @@ -1585,7 +1795,7 @@ -- | Finalize a generic package description. -- -- The workhorse is 'finalizePD'. -configureFinalizedPackage +finalizePackageDescription2 :: Verbosity -> ConfigFlags -> ComponentRequestedSpec @@ -1597,7 +1807,7 @@ -> Platform -> GenericPackageDescription -> IO (PackageDescription, FlagAssignment) -configureFinalizedPackage +finalizePackageDescription2 verbosity cfg enabled @@ -1653,25 +1863,17 @@ $ dieWithException verbosity CompilerDoesn'tSupportBackpack -- | Select dependencies for the package. -configureDependencies +selectDependencies :: Verbosity -> UseExternalInternalDeps - -> Set LibraryName - -> Map (PackageName, ComponentName) PromisedComponent - -> InstalledPackageIndex - -- ^ installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ required deps + -> PackageInfo -> PackageDescription -> ComponentRequestedSpec -> IO ([PreExistingComponent], [ConfiguredPromisedComponent]) -configureDependencies +selectDependencies verbosity use_external_internal_deps - packageLibraries - promisedDeps - installedPackageSet - requiredDepsMap + pkgInfo pkg_descr enableSpec = do let failedDeps :: [FailedDependency] @@ -1679,15 +1881,12 @@ (failedDeps, allPkgDeps) = partitionEithers $ concat - [ fmap (\s -> (dep, s)) <$> status + [ fmap (dep,) <$> status | dep <- enabledBuildDepends pkg_descr enableSpec , let status = selectDependency (package pkg_descr) - packageLibraries - promisedDeps - installedPackageSet - requiredDepsMap + pkgInfo use_external_internal_deps dep ] @@ -1941,15 +2140,7 @@ selectDependency :: PackageId -- ^ Package id of current package - -> Set LibraryName - -- ^ package libraries - -> Map (PackageName, ComponentName) PromisedComponent - -- ^ Set of components that are promised, i.e. are not installed already. See 'PromisedDependency' for more details. - -> InstalledPackageIndex - -- ^ Installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ Packages for which we have been given specific deps to - -- use + -> PackageInfo -> UseExternalInternalDeps -- ^ Are we configuring a -- single component? @@ -1957,10 +2148,13 @@ -> [Either FailedDependency DependencyResolution] selectDependency pkgid - internalIndex - promisedIndex - installedIndex - requiredDepsMap + ( PackageInfo + { internalPackageSet = internalIndex + , promisedDepsSet = promisedIndex + , installedPackageSet = installedIndex + , requiredDepsMap + } + ) use_external_internal_deps (Dependency dep_pkgname vr libs) = -- If the dependency specification matches anything in the internal package @@ -2067,7 +2261,7 @@ -- do not check empty packagedbs (ghc-pkg would error out) packageDBs' <- filterM packageDBExists packageDBs case compilerFlavor comp of - GHC -> GHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb + GHC -> GHC.getInstalledPackages verbosity mbWorkDir packageDBs' progdb GHCJS -> GHCJS.getInstalledPackages verbosity mbWorkDir packageDBs' progdb UHC -> UHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb flv -> @@ -2136,7 +2330,7 @@ -- | Looks up the 'InstalledPackageInfo' of the given 'UnitId's from the -- 'PackageDBStack' in the 'LocalBuildInfo'. getInstalledPackagesById - :: (Exception (VerboseException exception), Show exception, Typeable exception) + :: Exception (VerboseException exception) => Verbosity -> LocalBuildInfo -> (UnitId -> exception) @@ -2193,7 +2387,7 @@ , Map (PackageName, ComponentName) InstalledPackageInfo ) combinedConstraints constraints dependencies installedPackages = do - when (not (null badComponentIds)) $ + unless (null badComponentIds) $ Left $ CombinedConstraints (dispDependencies badComponentIds) @@ -2363,7 +2557,7 @@ | otherwise = do (_, _, progdb') <- requireProgramVersion - (lessVerbose verbosity) + (modifyVerbosityFlags lessVerbose verbosity) pkgConfigProgram (orLaterVersion $ mkVersion [0, 9, 0]) progdb @@ -2386,7 +2580,7 @@ allpkgs = concatMap pkgconfigDepends (enabledBuildInfos pkg_descr enabled) pkgconfig = getDbProgramOutput - (lessVerbose verbosity) + (modifyVerbosityFlags lessVerbose verbosity) pkgConfigProgram progdb @@ -2436,7 +2630,7 @@ pkgconfigBuildInfo :: [PkgconfigDependency] -> IO BuildInfo pkgconfigBuildInfo [] = return mempty pkgconfigBuildInfo pkgdeps = do - let pkgs = nub [prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps] + let pkgs = ordNub [prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps] ccflags <- pkgconfig ("--cflags" : pkgs) ldflags <- pkgconfig ("--libs" : pkgs) ldflags_static <- pkgconfig ("--libs" : "--static" : pkgs) @@ -2457,8 +2651,8 @@ let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' - (extraLibsStatic') = filter ("-l" `isPrefixOf`) ldflags_static - (extraLibDirsStatic') = filter ("-L" `isPrefixOf`) ldflags_static + extraLibsStatic' = filter ("-l" `isPrefixOf`) ldflags_static + extraLibDirsStatic' = filter ("-L" `isPrefixOf`) ldflags_static in mempty { includeDirs = map (makeSymbolicPath . drop 2) includeDirs' , extraLibs = map (drop 2) extraLibs' @@ -2473,12 +2667,13 @@ -- Determining the compiler details configCompilerAuxEx - :: ConfigFlags + :: VerbosityHandles + -> ConfigFlags -> IO (Compiler, Platform, ProgramDb) -configCompilerAuxEx cfg = do - programDb <- mkProgramDb cfg defaultProgramDb +configCompilerAuxEx verbHandles cfg = do + programDb <- mkProgramDb verbHandles cfg defaultProgramDb let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) configCompilerEx (flagToMaybe $ configHcFlavor cfg) (flagToMaybe $ configHcPath cfg) @@ -2578,14 +2773,10 @@ -- in either the generated (most likely by `configure`) -- build directory (e.g. `dist/build`) or in the source directory. -- - -- If it exists in both, we'll remove the one in the source - -- directory, as the generated should take precedence. + -- If it exists in both, issue a warning, because C compilers are + -- not guaranteed to pick the correct one and there appears to be + -- no way to control which is picked. -- - -- C compilers like to prefer source local relative includes, - -- so the search paths provided to the compiler via -I are - -- ignored if the included file can be found relative to the - -- including file. As such we need to take drastic measures - -- and delete the offending file in the source directory. checkDuplicateHeaders = do let relIncDirs = filter (not . isAbsolute) (collectField (fmap getSymbolicPath . includeDirs)) isHeader = isSuffixOf ".h" @@ -2602,9 +2793,7 @@ ++ (getSymbolicPath (buildDir lbi) hdr) ++ " and " ++ (baseDir hdr) - ++ "; removing " - ++ (baseDir hdr) - removeFile (baseDir hdr) + ++ ". Which one the C compiler will use is unspecified." findOffendingHdr = ifBuildsWith @@ -2766,7 +2955,7 @@ (errors, warnings) = partitionEithers (M.mapMaybe classEW $ pureChecks ++ ioChecks) if null errors - then traverse_ (warn verbosity) (map ppPackageCheck warnings) + then traverse_ (warn verbosity . ppPackageCheck) warnings else dieWithException verbosity $ CheckPackageProblems (map ppPackageCheck errors) where -- Classify error/warnings. Left: error, Right: warning. @@ -2809,7 +2998,7 @@ -- and RPATH, make sure you add your OS to RPATH-support list of: -- Distribution.Simple.GHC.getRPaths checkOS = - unless (os `elem` [OSX, Linux]) $ + unless (os `elem` [OSX, Linux, FreeBSD]) $ dieWithException verbosity $ NoOSSupport os "relocatable builds" where @@ -2817,7 +3006,7 @@ -- Check if the Compiler support relocatable builds checkCompiler = - unless (compilerFlavor comp `elem` [GHC]) $ + unless (compilerFlavor comp == GHC) $ dieWithException verbosity $ NoCompilerSupport (show comp) where @@ -2827,7 +3016,7 @@ packagePrefixRelative = unless (relativeInstallDirs installDirs) $ dieWithException verbosity $ - InstallDirsNotPrefixRelative (installDirs) + InstallDirsNotPrefixRelative installDirs where -- NB: should be good enough to check this against the default -- component ID, but if we wanted to be strictly correct we'd @@ -2836,22 +3025,20 @@ p = prefix installDirs relativeInstallDirs (InstallDirs{..}) = all - isJust - ( fmap - (stripPrefix p) - [ bindir - , libdir - , dynlibdir - , libexecdir - , includedir - , datadir - , docdir - , mandir - , htmldir - , haddockdir - , sysconfdir - ] - ) + (isJust . stripPrefix p) + [ bindir + , libdir + , dynlibdir + , bytecodelibdir + , libexecdir + , includedir + , datadir + , docdir + , mandir + , htmldir + , haddockdir + , sysconfdir + ] -- Check if the library dirs of the dependencies that are in the package -- database to which the package is installed are relative to the @@ -2861,7 +3048,7 @@ traverse_ (doCheck $ getSymbolicPath pkgr) ipkgs where doCheck pkgr ipkg - | maybe False (== pkgr) (IPI.pkgRoot ipkg) = + | Just pkgr == IPI.pkgRoot ipkg = for_ (IPI.libraryDirs ipkg) $ \libdir -> do -- When @prefix@ is not under @pkgroot@, -- @shortRelativePath prefix pkgroot@ will return a path with @@ -2895,12 +3082,7 @@ checkForeignLibSupported comp platform flib = go (compilerFlavor comp) where go :: CompilerFlavor -> Maybe String - go GHC - | compilerVersion comp < mkVersion [7, 8] = - unsupported - [ "Building foreign libraries is only supported with GHC >= 7.8" - ] - | otherwise = goGhcPlatform platform + go GHC = goGhcPlatform platform go _ = unsupported [ "Building foreign libraries is currently only supported with ghc" 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 @@ -35,14 +35,14 @@ import Distribution.System (Platform, buildPlatform) import Distribution.Utils.NubList import Distribution.Utils.Path +import Distribution.Verbosity -- Base -import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.Directory (createDirectoryIfMissing, doesFileExist, makeAbsolute) import qualified System.FilePath as FilePath #ifdef mingw32_HOST_OS import System.FilePath (normalise, splitDrive) #endif -import Distribution.Compat.Directory (makeAbsolute) import Distribution.Compat.Environment (getEnvironment) import Distribution.Compat.GetShortPathName (getShortPathName) @@ -50,15 +50,16 @@ import qualified Data.Map as Map runConfigureScript - :: ConfigFlags + :: VerbosityHandles + -> ConfigFlags -> FlagAssignment -> ProgramDb -> Platform -- ^ host platform -> IO () -runConfigureScript cfg flags programDb hp = do +runConfigureScript verbHandles cfg flags programDb hp = do let commonCfg = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity commonCfg + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonCfg) dist_dir <- findDistPrefOrDefault $ setupDistPref commonCfg let build_dir = dist_dir makeRelativePathEx "build" mbWorkDir = flagToMaybe $ setupWorkingDir commonCfg @@ -66,8 +67,7 @@ confExists <- doesFileExist configureScriptPath unless confExists $ dieWithException verbosity (ConfigureScriptNotFound configureScriptPath) - configureFile <- - makeAbsolute $ configureScriptPath + configureFile <- makeAbsolute configureScriptPath env <- getEnvironment (ccProg, ccFlags) <- configureCCompiler verbosity programDb ccProgShort <- getShortPathName ccProg @@ -183,7 +183,7 @@ : [("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)] + maybeHostFlag = ["--host=" ++ show (pretty hp) | hp /= buildPlatform] args' = configureFile' : args 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 @@ -49,10 +49,10 @@ | -- | @NoLibraryFound@ has been downgraded to a warning, and is therefore no longer emitted. NoLibraryFound | CompilerNotInstalled CompilerFlavor - | CantFindIncludeFile String + | CantFindIncludeFile String [String] | UnsupportedTestSuite String | UnsupportedBenchMark String - | NoIncludeFileFound String + | NoIncludeFileFound String [String] | NoModuleFound ModuleName [Suffix] | RegMultipleInstancePkg | SuppressingChecksOnFile @@ -96,8 +96,7 @@ | AmbiguousBuildTarget [(String, [(String, String)])] | CheckBuildTargets String | VersionMismatchGHC FilePath Version FilePath Version - | CheckPackageDbStackPost76 - | CheckPackageDbStackPre76 + | CheckPackageDbStack | GlobalPackageDbSpecifiedFirst | CantInstallForeignLib | NoSupportForPreProcessingTest TestType @@ -170,6 +169,7 @@ | MissingCoveredInstalledLibrary UnitId | SetupHooksException SetupHooksException | MultiReplDoesNotSupportComplexReexportedModules PackageName ComponentName + | StandaloneBytecodeNotSupportedYet deriving (Show) exceptionCode :: CabalException -> Int @@ -229,8 +229,8 @@ AmbiguousBuildTarget{} -> 7865 CheckBuildTargets{} -> 4733 VersionMismatchGHC{} -> 4000 - CheckPackageDbStackPost76{} -> 3000 - CheckPackageDbStackPre76{} -> 5640 + CheckPackageDbStack{} -> 3000 + -- Retired: CheckPackageDbStackPre76{} -> 5640 GlobalPackageDbSpecifiedFirst{} -> 2345 CantInstallForeignLib{} -> 8221 NoSupportForPreProcessingTest{} -> 3008 @@ -304,6 +304,7 @@ SetupHooksException err -> setupHooksExceptionCode err MultiReplDoesNotSupportComplexReexportedModules{} -> 9355 + StandaloneBytecodeNotSupportedYet -> 9356 versionRequirement :: VersionRange -> String versionRequirement range @@ -318,10 +319,10 @@ NoBenchMark bmName -> "no such benchmark: " ++ bmName NoLibraryFound -> "No executables and no library found. Nothing to do." CompilerNotInstalled compilerFlavor -> "installing with " ++ prettyShow compilerFlavor ++ "is not implemented" - CantFindIncludeFile file -> "can't find include file " ++ file + CantFindIncludeFile file sd -> "can't find include file " ++ file ++ " in any of the search dirs " ++ intercalate ", " sd UnsupportedTestSuite test_type -> "Unsupported test suite type: " ++ test_type UnsupportedBenchMark benchMarkType -> "Unsupported benchmark type: " ++ benchMarkType - NoIncludeFileFound f -> "can't find include file " ++ f + NoIncludeFileFound f sd -> "can't find include file " ++ f ++ " in any of the search dirs " ++ intercalate ", " sd NoModuleFound m suffixes -> "Could not find module: " ++ prettyShow m @@ -468,13 +469,9 @@ ++ ghcPkgProgPath ++ " is version " ++ prettyShow ghcPkgVersion - CheckPackageDbStackPost76 -> + CheckPackageDbStack -> "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times" - CheckPackageDbStackPre76 -> - "With current ghc versions the global package db is always used " - ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6," - ++ "see https://gitlab.haskell.org/ghc/ghc/-/issues/5977" GlobalPackageDbSpecifiedFirst -> "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times" @@ -804,3 +801,8 @@ ++ prettyShow pname ++ " a module renaming was found.\n" ++ "Multi-repl does not work with complicated reexported-modules until GHC-9.12." + StandaloneBytecodeNotSupportedYet -> + unlines + [ "The ecosystem doesn't support building packages with just bytecode libraries yet." + , "If you have run into this error, please comment on issue #" + ] diff --git a/src/Distribution/Simple/FileMonitor/Types.hs b/src/Distribution/Simple/FileMonitor/Types.hs --- a/src/Distribution/Simple/FileMonitor/Types.hs +++ b/src/Distribution/Simple/FileMonitor/Types.hs @@ -39,6 +39,7 @@ import qualified Distribution.Compat.CharParsing as P import Distribution.Parsec import Distribution.Pretty +import Distribution.Utils.Generic (isAsciiAlpha) import qualified Text.PrettyPrint as Disp -------------------------------------------------------------------------------- @@ -211,7 +212,7 @@ root = FilePathRoot "/" <$ P.char '/' home = FilePathHomeDir <$ P.string "~/" drive = do - dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') + dr <- P.satisfy isAsciiAlpha _ <- P.char ':' _ <- P.char '/' <|> P.char '\\' return (FilePathRoot (toUpper dr : ":\\")) 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 @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} @@ -60,7 +61,6 @@ , hcPkgInfo , registerPackage , Internal.componentGhcOptions - , Internal.componentCcGhcOptions , getGhcAppDir , getLibDir , compilerBuildWay @@ -91,7 +91,6 @@ import Data.Maybe (fromJust) import Distribution.CabalSpecVersion import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.Package import Distribution.PackageDescription as PD import Distribution.Pretty @@ -99,6 +98,7 @@ import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.Errors +import Distribution.Simple.Flag import qualified Distribution.Simple.GHC.Build as GHC import Distribution.Simple.GHC.Build.Modules (BuildWay (..)) import Distribution.Simple.GHC.Build.Utils @@ -142,7 +142,7 @@ , doesDirectoryExist , doesFileExist , getAppUserDataDirectory - , getDirectoryContents + , listDirectory #ifndef mingw32_HOST_OS , renameFile #endif @@ -186,9 +186,9 @@ (userMaybeSpecifyPath "ghc" hcPath conf0) -- Cabal currently supports GHC less than `maxGhcVersion` - let maxGhcVersion = mkVersion [9, 16] + let maxGhcVersion = mkVersion [10, 2] unless (ghcVersion < maxGhcVersion) $ - warn verbosity $ + info verbosity $ "Unknown/unsupported 'ghc' version detected " ++ "(Cabal " ++ prettyShow cabalVersion @@ -200,8 +200,8 @@ ++ prettyShow ghcVersion let implInfo = ghcVersionImplInfo ghcVersion - languages <- Internal.getLanguages verbosity implInfo ghcProg - extensions0 <- Internal.getExtensions verbosity implInfo ghcProg + languages <- Internal.getLanguages implInfo + extensions0 <- Internal.getExtensions verbosity ghcProg ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg @@ -209,10 +209,8 @@ filterJS = if ghcVersion < mkVersion [9, 8] then filterExt JavaScriptFFI else id extensions = -- workaround https://gitlab.haskell.org/ghc/ghc/-/issues/11214 - filterJS $ - -- see 'filterExtTH' comment below - filterExtTH $ - extensions0 + -- see 'filterExtTH' comment below + filterJS $ filterExtTH extensions0 -- starting with GHC 8.0, `TemplateHaskell` will be omitted from -- `--supported-extensions` when it's not available. @@ -229,21 +227,36 @@ compilerId :: CompilerId compilerId = CompilerId GHC ghcVersion + projectUnitId :: Maybe String + projectUnitId = Map.lookup "Project Unit Id" ghcInfoMap + -- 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". + -- If the @Project Unit Id@ exactly matches @compilerId@, stripping the + -- common prefix yields the empty string, which should be treated as + -- @NoAbiTag@ rather than @AbiTag ""@. compilerAbiTag :: AbiTag compilerAbiTag = - maybe - NoAbiTag - AbiTag - ( dropWhile (== '-') . stripCommonPrefix (prettyShow compilerId) - <$> Map.lookup "Project Unit Id" ghcInfoMap - ) + let abiTagSuffix = + dropWhile (== '-') . stripCommonPrefix (prettyShow compilerId) + <$> projectUnitId + in case abiTagSuffix of + Nothing -> NoAbiTag + Just "" -> NoAbiTag + Just tag -> AbiTag tag + wiredInUnitIds = do + ghcInternalUnitId <- Map.lookup "ghc-internal Unit Id" ghcInfoMap + ghcUnitId <- projectUnitId + pure + [ (mkPackageName "ghc", mkUnitId ghcUnitId) + , (mkPackageName "ghc-internal", mkUnitId ghcInternalUnitId) + ] + let comp = Compiler { compilerId @@ -252,6 +265,7 @@ , compilerLanguages = languages , compilerExtensions = extensions , compilerProperties = ghcInfoMap + , compilerWiredInUnitIds = wiredInUnitIds } compPlatform = Internal.targetPlatform ghcInfo return (comp, compPlatform, progdb1) @@ -270,25 +284,6 @@ -- ^ 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 @@ -306,20 +301,49 @@ runghcProgram { programFindLocation = guessRunghcFromGhcPath ghcProg } - progdb3 = - addKnownProgram haddockProgram' $ - addKnownProgram hsc2hsProgram' $ - addKnownProgram hpcProgram' $ - addKnownProgram runghcProgram' progdb2 + ghcPkgProgram' = + ghcPkgProgram + { programFindLocation = guessGhcPkgFromGhcPath ghcProg + } + progdb2 = + -- The knownPrograms are populated before userMaybeSpecifyPath + -- in the case that ProgramDb has been restored from a cache and is empty + -- See #11373 for where this went wrong before + userMaybeSpecifyPath "ghc-pkg" hcPkgPath $ + addKnownProgram haddockProgram' $ + addKnownProgram hsc2hsProgram' $ + addKnownProgram hpcProgram' $ + addKnownProgram runghcProgram' $ + addKnownProgram + ghcPkgProgram' + progdb1 + ghcProg = fromJust $ lookupProgram ghcProgram progdb1 + ghcVersion = compilerVersion comp + -- configure gcc, ld, ar etc... based on the paths stored -- in the GHC settings file - progdb4 = + progdb3 = Internal.configureToolchain (ghcVersionImplInfo ghcVersion) ghcProg (compilerProperties comp) - progdb3 + progdb2 + + -- 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, progdb4) <- + requireProgramVersion + verbosity + ghcPkgProgram' + anyVersion + progdb3 + + when (ghcVersion /= ghcPkgVersion) $ + dieWithException verbosity $ + VersionMismatchGHC (programPath ghcProg) ghcVersion (programPath ghcPkgProg) ghcPkgVersion + return progdb4 -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find @@ -469,14 +493,13 @@ -- | Given a package DB stack, return all installed packages. getInstalledPackages :: Verbosity - -> Compiler -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) -> ProgramDb -> IO InstalledPackageIndex -getInstalledPackages verbosity comp mbWorkDir packagedbs progdb = do +getInstalledPackages verbosity mbWorkDir packagedbs progdb = do checkPackageDbEnvVar verbosity - checkPackageDbStack verbosity comp packagedbs + checkPackageDbStack verbosity packagedbs pkgss <- getInstalledPackages' verbosity mbWorkDir packagedbs progdb index <- toPackageIndex verbosity pkgss progdb return $! hackRtsPackage index @@ -484,7 +507,7 @@ hackRtsPackage index = case PackageIndex.lookupPackageName index (mkPackageName "rts") of [(_, [rts])] -> - PackageIndex.insert (removeMingwIncludeDir rts) index + PackageIndex.insert rts index _ -> index -- No (or multiple) ghc rts package is registered!! -- Feh, whatever, the ghc test suite does some crazy stuff. @@ -556,39 +579,13 @@ checkPackageDbEnvVar verbosity = Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH" -checkPackageDbStack :: Eq fp => Verbosity -> Compiler -> PackageDBStackX fp -> IO () -checkPackageDbStack verbosity comp = - if flagPackageConf implInfo - then checkPackageDbStackPre76 verbosity - else checkPackageDbStackPost76 verbosity - where - implInfo = ghcVersionImplInfo (compilerVersion comp) - -checkPackageDbStackPost76 :: Eq fp => Verbosity -> PackageDBStackX fp -> IO () -checkPackageDbStackPost76 _ (GlobalPackageDB : rest) +checkPackageDbStack :: Eq fp => Verbosity -> PackageDBStackX fp -> IO () +checkPackageDbStack _ (GlobalPackageDB : rest) | GlobalPackageDB `notElem` rest = return () -checkPackageDbStackPost76 verbosity rest +checkPackageDbStack verbosity rest | GlobalPackageDB `elem` rest = - dieWithException verbosity CheckPackageDbStackPost76 -checkPackageDbStackPost76 _ _ = return () - -checkPackageDbStackPre76 :: Eq fp => Verbosity -> PackageDBStackX fp -> IO () -checkPackageDbStackPre76 _ (GlobalPackageDB : rest) - | GlobalPackageDB `notElem` rest = return () -checkPackageDbStackPre76 verbosity rest - | GlobalPackageDB `notElem` rest = - dieWithException verbosity CheckPackageDbStackPre76 -checkPackageDbStackPre76 verbosity _ = - dieWithException verbosity GlobalPackageDbSpecifiedFirst - --- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This --- breaks when you want to use a different gcc, so we need to filter --- it out. -removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo -removeMingwIncludeDir pkg = - let ids = InstalledPackageInfo.includeDirs pkg - ids' = filter (not . ("mingw" `isSuffixOf`)) ids - in pkg{InstalledPackageInfo.includeDirs = ids'} + dieWithException verbosity CheckPackageDbStack +checkPackageDbStack _ _ = return () -- | Get the packages from specific PackageDBs, not cumulative. getInstalledPackages' @@ -643,15 +640,16 @@ -- Building a library buildLib - :: BuildFlags + :: VerbosityHandles + -> BuildFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () -buildLib flags numJobs pkg lbi lib clbi = - GHC.build numJobs pkg $ +buildLib verbHandles flags numJobs pkg lbi lib clbi = + GHC.build numJobs verbHandles pkg $ PreBuildComponentInputs { buildingWhat = BuildNormal flags , localBuildInfo = lbi @@ -659,15 +657,16 @@ } replLib - :: ReplFlags + :: VerbosityHandles + -> ReplFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () -replLib flags numJobs pkg lbi lib clbi = - GHC.build numJobs pkg $ +replLib verbHandles flags numJobs pkg lbi lib clbi = + GHC.build numJobs verbHandles pkg $ PreBuildComponentInputs { buildingWhat = BuildRepl flags , localBuildInfo = lbi @@ -688,7 +687,7 @@ { ghcOptMode = toFlag GhcModeInteractive , ghcOptPackageDBs = packageDBs } - checkPackageDbStack verbosity comp packageDBs + checkPackageDbStack verbosity 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. @@ -707,28 +706,29 @@ -> ComponentLocalBuildInfo -> IO () buildFLib v numJobs pkg lbi flib clbi = - GHC.build numJobs pkg $ + GHC.build numJobs (verbosityHandles v) pkg $ PreBuildComponentInputs { buildingWhat = BuildNormal $ mempty { buildCommonFlags = - mempty{setupVerbosity = toFlag v} + mempty{setupVerbosity = toFlag $ verbosityFlags v} } , localBuildInfo = lbi , targetInfo = TargetInfo clbi (CFLib flib) } replFLib - :: ReplFlags + :: VerbosityHandles + -> ReplFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo -> IO () -replFLib replFlags njobs pkg lbi flib clbi = - GHC.build njobs pkg $ +replFLib verbHandles replFlags njobs pkg lbi flib clbi = + GHC.build njobs verbHandles pkg $ PreBuildComponentInputs { buildingWhat = BuildRepl replFlags , localBuildInfo = lbi @@ -745,28 +745,29 @@ -> ComponentLocalBuildInfo -> IO () buildExe v njobs pkg lbi exe clbi = - GHC.build njobs pkg $ + GHC.build njobs (verbosityHandles v) pkg $ PreBuildComponentInputs { buildingWhat = BuildNormal $ mempty { buildCommonFlags = - mempty{setupVerbosity = toFlag v} + mempty{setupVerbosity = toFlag $ verbosityFlags v} } , localBuildInfo = lbi , targetInfo = TargetInfo clbi (CExe exe) } replExe - :: ReplFlags + :: VerbosityHandles + -> ReplFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () -replExe replFlags njobs pkg lbi exe clbi = - GHC.build njobs pkg $ +replExe verbHandles replFlags njobs pkg lbi exe clbi = + GHC.build njobs verbHandles pkg $ PreBuildComponentInputs { buildingWhat = BuildRepl replFlags , localBuildInfo = lbi @@ -789,7 +790,7 @@ platform = hostPlatform lbi mbWorkDir = mbWorkDirLBI lbi vanillaArgs = - (Internal.componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + Internal.componentGhcOptions (verbosityLevel verbosity) lbi libBi clbi (componentBuildDir lbi clbi) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash , ghcOptInputModules = toNubListR $ exposedModules lib @@ -801,7 +802,7 @@ , ghcOptFPic = toFlag True , ghcOptHiSuffix = toFlag "dyn_hi" , ghcOptObjSuffix = toFlag "dyn_o" - , ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi + , ghcOptExtra = hcSharedOptions GHC libBi } profArgs = vanillaArgs @@ -813,7 +814,7 @@ (withProfLibDetail lbi) , ghcOptHiSuffix = toFlag "p_hi" , ghcOptObjSuffix = toFlag "p_o" - , ghcOptExtra = hcOptions GHC libBi ++ hcProfOptions GHC libBi + , ghcOptExtra = hcProfOptions GHC libBi } profDynArgs = vanillaArgs @@ -827,7 +828,7 @@ , ghcOptFPic = toFlag True , ghcOptHiSuffix = toFlag "p_dyn_hi" , ghcOptObjSuffix = toFlag "p_dyn_o" - , ghcOptExtra = hcOptions GHC libBi ++ hcProfSharedOptions GHC libBi + , ghcOptExtra = hcProfSharedOptions GHC libBi } ghcArgs = let (libWays, _, _) = buildWays lbi @@ -916,10 +917,8 @@ else installOrdinaryFile verbosity src dst -- Now install appropriate symlinks if library is versioned let (Platform _ os) = hostPlatform lbi - when (not (null (foreignLibVersion flib os))) $ do - when (os /= Linux) $ - dieWithException verbosity $ - CantInstallForeignLib + unless (null (foreignLibVersion flib os)) $ do + when (os /= Linux) $ dieWithException verbosity CantInstallForeignLib #ifndef mingw32_HOST_OS -- 'createSymbolicLink file1 file2' creates a symbolic link -- named 'file2' which points to the file 'file1'. @@ -928,7 +927,7 @@ -- directory it's created in. -- Finally, we first create the symlinks in a temporary -- directory and then rename to simulate 'ln --force'. - withTempDirectory verbosity dstDir nm $ \tmpDir -> do + withTempDirectory dstDir nm $ \tmpDir -> do let link1 = flibBuildName lbi flib link2 = "lib" ++ nm <.> "so" createSymbolicLink name (tmpDir link1) @@ -940,7 +939,7 @@ nm = unUnqualComponentName $ foreignLibName flib #endif /* mingw32_HOST_OS */ --- | Install for ghc, .hi, .a and, if --with-ghci given, .o +-- | Install for ghc, .hi, .a, .so, .bytecodelib and, if --with-ghci given, .o installLib :: Verbosity -> LocalBuildInfo @@ -949,12 +948,14 @@ -> FilePath -- ^ install location for dynamic libraries -> FilePath + -- ^ install location for bytecode libraries + -> FilePath -- ^ Build location -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO () -installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do +installLib verbosity lbi targetDir dynlibTargetDir bytecodeTargetDir _builtDir pkg lib clbi = do let (wantedLibWays, _, _) = buildWays lbi isIndef = componentIsIndefinite clbi @@ -963,7 +964,7 @@ info verbosity ("Wanted install ways: " ++ show libWays) -- copy .hi files over: - forM_ (wantedLibWays isIndef) $ \w -> case w of + forM_ (wantedLibWays isIndef) $ \case StaticWay -> copyModuleFiles (Suffix "hi") DynWay -> copyModuleFiles (Suffix "dyn_hi") ProfWay -> copyModuleFiles (Suffix "p_hi") @@ -974,7 +975,11 @@ -- copy the built library files over: when (has_code && hasLib) $ do - forM_ libWays $ \w -> case w of + -- Bytecode libraries are installed in bytecodelibdir and are copied + -- without stripping; see doc/internal/bytecode-libraries.md. + whenBytecodeLib $ installOrdinaryNoStrip builtDir bytecodeTargetDir bytecodeLibName + + forM_ libWays $ \case StaticWay -> do sequence_ [ installOrdinary @@ -984,7 +989,7 @@ | l <- getHSLibraryName (componentUnitId clbi) - : (extraBundledLibs (libBuildInfo lib)) + : extraBundledLibs (libBuildInfo lib) , f <- "" : extraLibFlavours (libBuildInfo lib) ] whenGHCi $ installOrdinary builtDir targetDir ghciLibName @@ -1023,7 +1028,7 @@ ] sequence_ [ do - files <- getDirectoryContents (i builtDir) + files <- listDirectory (i builtDir) let l' = mkGenericSharedBundledLibName platform @@ -1047,7 +1052,7 @@ builtDir = componentBuildDir lbi clbi mbWorkDir = mbWorkDirLBI lbi - install isShared srcDir dstDir name = do + install isShared shouldStrip srcDir dstDir name = do let src = i $ srcDir makeRelativePathEx name dst = dstDir name @@ -1057,15 +1062,16 @@ then installExecutableFile verbosity src dst else installOrdinaryFile verbosity src dst - when (stripLibs lbi) $ + when (shouldStrip && stripLibs lbi) $ Strip.stripLib verbosity platform (withPrograms lbi) dst - installOrdinary = install False - installShared = install True + installOrdinary = install False True + installOrdinaryNoStrip = install False False + installShared = install True True copyModuleFiles ext = do files <- findModuleFilesCwd verbosity mbWorkDir [builtDir] [ext] (allLibModules lib clbi) @@ -1083,6 +1089,7 @@ platform = hostPlatform lbi uid = componentUnitId clbi profileLibName = mkProfLibName uid + bytecodeLibName = mkBytecodeLibName compiler_id uid ghciLibName = Internal.mkGHCiLibName uid ghciProfLibName = Internal.mkGHCiProfLibName uid @@ -1099,27 +1106,14 @@ _ -> False has_code = not (componentIsIndefinite clbi) whenGHCi = when (hasLib && withGHCiLib lbi && has_code) + whenBytecodeLib = when (hasLib && withBytecodeLib lbi && has_code) -- ----------------------------------------------------------------------------- -- Registering -hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo +hcPkgInfo :: ProgramDb -> HcPkg.ConfiguredProgram hcPkgInfo progdb = - HcPkg.HcPkgInfo - { HcPkg.hcPkgProgram = ghcPkgProg - , HcPkg.noPkgDbStack = v < [6, 9] - , HcPkg.noVerboseFlag = v < [6, 11] - , HcPkg.flagPackageConf = v < [7, 5] - , HcPkg.supportsDirDbs = v >= [6, 8] - , HcPkg.requiresDirDbs = v >= [7, 10] - , HcPkg.nativeMultiInstance = v >= [7, 10] - , HcPkg.recacheMultiInstance = v >= [6, 12] - , HcPkg.suppressFilesCheck = v >= [6, 6] - } - where - v = versionNumbers ver - ghcPkgProg = fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb - ver = fromMaybe (error "GHC.hcPkgInfo: no ghc version") $ programVersion ghcPkgProg + fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb registerPackage :: Verbosity diff --git a/src/Distribution/Simple/GHC/Build.hs b/src/Distribution/Simple/GHC/Build.hs --- a/src/Distribution/Simple/GHC/Build.hs +++ b/src/Distribution/Simple/GHC/Build.hs @@ -5,7 +5,8 @@ import Distribution.Compat.Prelude import Prelude () -import Control.Monad.IO.Class +import qualified Distribution.Compat.Graph as Graph + import Distribution.PackageDescription as PD hiding (buildInfo) import Distribution.Simple.Build.Inputs import Distribution.Simple.Flag (Flag) @@ -24,6 +25,9 @@ import Distribution.Utils.NubList (fromNubListR) import Distribution.Utils.Path +import Distribution.Verbosity (VerbosityHandles, mkVerbosity, verbosityHandles) + +import Control.Monad.IO.Class import System.FilePath (splitDirectories) {- Note [Build Target Dir vs Target Dir] @@ -64,16 +68,17 @@ -- Includes building Haskell modules, extra build sources, and linking. build :: Flag ParStrat + -> VerbosityHandles -> PackageDescription -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO () -build numJobs pkg_descr pbci = do +build numJobs verbHandles pkg_descr pbci = do let - verbosity = buildVerbosity pbci + verbosity = mkVerbosity verbHandles $ buildVerbosity pbci isLib = buildIsLib pbci lbi = localBuildInfo pbci - bi = buildBI pbci + comp = buildComponent pbci clbi = buildCLBI pbci isIndef = componentIsIndefinite clbi mbWorkDir = mbWorkDirLBI lbi @@ -116,9 +121,35 @@ let wantedWays@(wantedLibWays, wantedFLibWay, wantedExeWay) = buildWays lbi -- Ways which are needed due to the compiler configuration - let doingTH = usesTemplateHaskellOrQQ bi + let doingTH = + -- Does this component, or another component that (transitively) depends + -- on this component, use TemplateHaskell or QuasiQuotes? + -- + -- Ticket #7684 showed that we need to take into account intra-package + -- dependencies. + any usesTemplateHaskellOrQQ thisCompAndReverseDepsBuildInfos + + -- The BuildInfos for this component and all of the components that + -- transitively depend on it (its reverse dependencies). + thisCompAndReverseDepsBuildInfos = + [ componentBuildInfo revDepComp + | let compUnitId = componentUnitId clbi + , -- 'revClosure' retrieves components that depend on this component. + revDepCLBI <- fromMaybe [clbi] $ Graph.revClosure (componentGraph lbi) [compUnitId] + , -- Use 'lookupComponent' here; don't use any function that goes via + -- 'getComponent' (e.g. mkTargetInfo or unitIdTarget'), as that will + -- tiresomely cause an error for 'detailed-0.9' test-suites because + -- 'testSuiteLibV09AsLibAndExe' creates a stub PackageDescription with + -- most components zeroed out. + -- + -- The implementation below means we will get 'Nothing' when the + -- current component is a 'detailed-0.9' test-suite, which is fine + -- as nothing can depend on a test-suite. + Just revDepComp <- [lookupComponent pkg_descr $ componentLocalName revDepCLBI] + ] + defaultGhcWay = compilerBuildWay (buildCompiler pbci) - wantedModBuildWays = case buildComponent pbci of + wantedModBuildWays = case comp of CLib _ -> wantedLibWays isIndef CFLib fl -> [wantedFLibWay (withDynFLib fl)] CExe _ -> [wantedExeWay] @@ -127,14 +158,14 @@ finalModBuildWays = wantedModBuildWays ++ [defaultGhcWay | doingTH && defaultGhcWay `notElem` wantedModBuildWays] - compNameStr = showComponentName $ componentName $ buildComponent pbci + compNameStr = showComponentName $ componentName comp liftIO $ info verbosity ("Wanted module build ways(" ++ compNameStr ++ "): " ++ show wantedModBuildWays) liftIO $ info verbosity ("Final module build ways(" ++ compNameStr ++ "): " ++ show finalModBuildWays) -- We need a separate build and link phase, and C sources must be compiled -- after Haskell modules, because C sources may depend on stub headers -- generated from compiling Haskell modules (#842, #3294). - (mbMainFile, inputModules) <- componentInputs buildTargetDir pkg_descr pbci + (mbMainFile, inputModules) <- componentInputs buildTargetDir verbHandles pkg_descr pbci let (hsMainFile, nonHsMainFile) = case mbMainFile of Just mainFile @@ -144,10 +175,11 @@ | otherwise -> (Nothing, Just mainFile) Nothing -> (Nothing, Nothing) - buildOpts <- buildHaskellModules numJobs ghcProg hsMainFile inputModules buildTargetDir finalModBuildWays pbci - extraSources <- buildAllExtraSources nonHsMainFile ghcProg buildTargetDir wantedWays pbci + buildOpts <- buildHaskellModules numJobs ghcProg hsMainFile inputModules buildTargetDir finalModBuildWays verbHandles pbci + extraSources <- buildAllExtraSources nonHsMainFile ghcProg buildTargetDir wantedWays verbHandles pbci linkOrLoadComponent ghcProg + (verbosityHandles verbosity) pkg_descr (fromNubListR extraSources) (buildTargetDir, targetDir) 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 @@ -10,6 +10,7 @@ import Data.Foldable import Distribution.Simple.Flag import qualified Distribution.Simple.GHC.Internal as Internal +import Distribution.Simple.Program import Distribution.Simple.Program.GHC import Distribution.Simple.Utils import Distribution.Utils.NubList @@ -19,15 +20,14 @@ import Distribution.Types.TargetInfo import Distribution.Simple.Build.Inputs -import Distribution.Simple.GHC.Build.Modules +import Distribution.Simple.BuildWay 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 -import Distribution.Verbosity (Verbosity) +import Distribution.Verbosity (VerbosityHandles, VerbosityLevel, mkVerbosity, verbosityLevel) -- | An action that builds all the extra build sources of a component, i.e. C, -- C++, Js, Asm, C-- sources. @@ -40,6 +40,8 @@ -- ^ The build directory for this target -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay) -- ^ Needed build ways + -> VerbosityHandles + -- ^ Logging handles -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO (NubListR (SymbolicPath Pkg File)) @@ -66,6 +68,8 @@ -- ^ The build directory for this target -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay) -- ^ Needed build ways + -> VerbosityHandles + -- ^ Logging handles -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO (NubListR (SymbolicPath Pkg File)) @@ -73,7 +77,7 @@ buildCSources mbMainFile = buildExtraSources "C Sources" - Internal.componentCcGhcOptions + (Internal.splitCandCxxOptions Internal.CcProgram) ( \c -> do let cFiles = cSources (componentBuildInfo c) case c of @@ -86,7 +90,7 @@ buildCxxSources mbMainFile = buildExtraSources "C++ Sources" - Internal.componentCxxGhcOptions + (Internal.splitCandCxxOptions Internal.CxxProgram) ( \c -> do let cxxFiles = cxxSources (componentBuildInfo c) case c of @@ -96,12 +100,12 @@ cxxFiles ++ [main] _otherwise -> cxxFiles ) -buildJsSources _mbMainFile ghcProg buildTargetDir neededWays = do +buildJsSources _mbMainFile ghcProg buildTargetDir neededWays verbHandles = do Platform hostArch _ <- hostPlatform <$> localBuildInfo let hasJsSupport = hostArch == JavaScript buildExtraSources "JS Sources" - Internal.componentJsGhcOptions + Internal.sourcesGhcOptions ( \c -> if hasJsSupport then -- JS files are C-like with GHC's JS backend: they are @@ -114,15 +118,16 @@ ghcProg buildTargetDir neededWays + verbHandles buildAsmSources _mbMainFile = buildExtraSources "Assembler Sources" - Internal.componentAsmGhcOptions + Internal.sourcesGhcOptions (asmSources . componentBuildInfo) buildCmmSources _mbMainFile = buildExtraSources "C-- Sources" - Internal.componentCmmGhcOptions + Internal.sourcesGhcOptions (cmmSources . componentBuildInfo) -- | Create 'PreBuildComponentRules' for a given type of extra build sources @@ -131,7 +136,7 @@ buildExtraSources :: String -- ^ String describing the extra sources being built, for printing. - -> ( Verbosity + -> ( VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -140,9 +145,7 @@ -> GhcOptions ) -- ^ Function to determine the @'GhcOptions'@ for the - -- invocation of GHC when compiling these extra sources (e.g. - -- @'Internal.componentCxxGhcOptions'@, - -- @'Internal.componentCmmGhcOptions'@) + -- invocation of GHC when compiling these extra sources -> (Component -> [SymbolicPath Pkg File]) -- ^ View the extra sources of a component, typically from -- the build info (e.g. @'asmSources'@, @'cSources'@). @@ -155,6 +158,8 @@ -- ^ The build directory for this target -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay) -- ^ Needed build ways + -> VerbosityHandles + -- ^ Handles for logging -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO (NubListR (SymbolicPath Pkg File)) @@ -165,11 +170,12 @@ viewSources ghcProg buildTargetDir - (neededLibWays, neededFLibWay, neededExeWay) = + (neededLibWays, neededFLibWay, neededExeWay) + verbHandles = \PreBuildComponentInputs{buildingWhat, localBuildInfo = lbi, targetInfo} -> do let bi = componentBuildInfo (targetComponent targetInfo) - verbosity = buildingWhatVerbosity buildingWhat + verbosity = mkVerbosity verbHandles $ buildingWhatVerbosity buildingWhat clbi = targetCLBI targetInfo isIndef = componentIsIndefinite clbi mbWorkDir = mbWorkDirLBI lbi @@ -193,7 +199,7 @@ buildAction sourceFile = do let baseSrcOpts = componentSourceGhcOptions - verbosity + (verbosityLevel verbosity) lbi bi clbi @@ -264,7 +270,7 @@ ProfDynWay -> compileIfNeeded profSharedSrcOpts -- build any sources - if (null sources || componentIsIndefinite clbi) + if null sources || componentIsIndefinite clbi then return mempty else do info verbosity ("Building " ++ description ++ "...") 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 @@ -17,7 +17,6 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import qualified Distribution.ModuleName as ModuleName import Distribution.Package import Distribution.PackageDescription as PD import Distribution.PackageDescription.Utils (cabalBug) @@ -27,12 +26,17 @@ 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.Build.Utils + ( exeTargetName + , flibBuildName + , flibTargetName + , objectFilePath + , withDynFLib + ) import Distribution.Simple.GHC.ImplInfo import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.Simple.LocalBuildInfo import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PreProcess.Types import Distribution.Simple.Program import qualified Distribution.Simple.Program.Ar as Ar import Distribution.Simple.Program.GHC @@ -51,13 +55,10 @@ import System.Directory ( createDirectoryIfMissing , doesDirectoryExist - , doesFileExist - , removeFile , renameFile ) import System.FilePath ( isRelative - , replaceExtension ) -- | Links together the object files of the Haskell modules and extra sources @@ -67,6 +68,8 @@ linkOrLoadComponent :: ConfiguredProgram -- ^ The configured GHC program that will be used for linking + -> VerbosityHandles + -- ^ Handles used for logging -> PackageDescription -- ^ The package description containing the component being built -> [SymbolicPath Pkg File] @@ -85,13 +88,14 @@ -> IO () linkOrLoadComponent ghcProg + verbHandles pkg_descr extraSources (buildTargetDir, targetDir) ((wantedLibWays, wantedFLibWay, wantedExeWay), buildOpts) pbci = do let - verbosity = buildVerbosity pbci + verbosity = mkVerbosity verbHandles $ buildVerbosity pbci target = targetInfo pbci component = buildComponent pbci what = buildingWhat pbci @@ -110,9 +114,9 @@ cleanedExtraLibDirsStatic <- liftIO $ filterM (doesDirectoryExist . i) (extraLibDirsStatic bi) let - extraSourcesObjs :: [RelativePath Artifacts File] + extraSourcesObjs :: [SymbolicPath Pkg File] extraSourcesObjs = - [ makeRelativePathEx $ getSymbolicPath src `replaceExtension` objExtension + [ objectFilePath buildTargetDir objExtension src | src <- extraSources ] @@ -121,10 +125,9 @@ linkerOpts rpaths = mempty { ghcOptLinkOptions = - PD.ldOptions bi - ++ [ "-static" - | withFullyStaticExe lbi - ] + [ "-static" + | withFullyStaticExe lbi + ] -- Pass extra `ld-options` given -- through to GHC's linker. ++ maybe @@ -142,11 +145,7 @@ else cleanedExtraLibDirs , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks bi , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs bi - , ghcOptInputFiles = - toNubListR - [ coerceSymbolicPath $ buildTargetDir obj - | obj <- extraSourcesObjs - ] + , ghcOptInputFiles = toNubListR extraSourcesObjs , ghcOptNoLink = Flag False , ghcOptRPaths = rpaths } @@ -193,6 +192,7 @@ warn verbosity "No exposed modules" runReplOrWriteFlags ghcProg + verbHandles lbi replFlags replOpts_final @@ -215,7 +215,7 @@ get_rpaths ways = if DynWay `Set.member` ways then getRPaths pbci else return (toNubListR []) in - when (not $ componentIsIndefinite clbi) $ do + unless (componentIsIndefinite clbi) $ do -- If not building dynamically, we don't pass any runtime paths. liftIO $ do info verbosity "Linking..." @@ -226,7 +226,7 @@ CLib lib -> do let libWays = wantedLibWays isIndef rpaths <- get_rpaths (Set.fromList libWays) - linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths libWays + linkLibrary buildTargetDir cleanedExtraLibDirs verbosity runGhcProg lib lbi clbi extraSources rpaths libWays CFLib flib -> do let flib_way = wantedFLibWay (withDynFLib flib) rpaths <- get_rpaths (Set.singleton flib_way) @@ -241,8 +241,6 @@ -- ^ The library target build directory -> [SymbolicPath Pkg (Dir Lib)] -- ^ The list of extra lib dirs that exist (aka "cleaned") - -> PackageDescription - -- ^ The package description containing this library -> Verbosity -> (GhcOptions -> IO ()) -- ^ Run the configured Ghc program @@ -256,18 +254,13 @@ -> [BuildWay] -- ^ Wanted build ways and corresponding build options -> IO () -linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWays = do +linkLibrary buildTargetDir cleanedExtraLibDirs verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWays = do let - common = configCommonFlags $ configFlags lbi - mbWorkDir = flagToMaybe $ setupWorkingDir common - compiler_id = compilerId comp comp = compiler lbi - ghcVersion = compilerVersion comp implInfo = getImplInfo comp uid = componentUnitId clbi libBi = libBuildInfo lib - Platform _hostArch hostOS = hostPlatform lbi vanillaLibFilePath = buildTargetDir makeRelativePathEx (mkLibName uid) profileLibFilePath = buildTargetDir makeRelativePathEx (mkProfLibName uid) sharedLibFilePath = @@ -279,24 +272,20 @@ staticLibFilePath = buildTargetDir makeRelativePathEx (mkStaticLibName (hostPlatform lbi) compiler_id uid) + bytecodeLibFilePath = + buildTargetDir + makeRelativePathEx (mkBytecodeLibName compiler_id uid) ghciLibFilePath = buildTargetDir makeRelativePathEx (Internal.mkGHCiLibName uid) ghciProfLibFilePath = buildTargetDir makeRelativePathEx (Internal.mkGHCiProfLibName uid) - libInstallPath = - libdir $ - absoluteComponentInstallDirs - pkg_descr - lbi - uid - NoCopyDest - sharedLibInstallPath = - libInstallPath - mkSharedLibName (hostPlatform lbi) compiler_id uid - profSharedLibInstallPath = - libInstallPath - mkProfSharedLibName (hostPlatform lbi) compiler_id uid - getObjFiles :: BuildWay -> IO [SymbolicPath Pkg File] - getObjFiles way = + getObjWayFiles :: BuildWay -> IO [SymbolicPath Pkg File] + getObjWayFiles w = getObjFiles (buildWayObjectExtension objExtension w) (buildWayObjectExtension objExtension w) + + getObjBytecodeWayFiles :: BuildWay -> IO [SymbolicPath Pkg File] + getObjBytecodeWayFiles companion_way = getObjFiles "gbc" (buildWayObjectExtension objExtension companion_way) + + getObjFiles :: String -> String -> IO [SymbolicPath Pkg File] + getObjFiles hs_ext obj_ext = mconcat [ Internal.getHaskellObjects implInfo @@ -304,36 +293,11 @@ lbi clbi buildTargetDir - (buildWayPrefix way ++ objExtension) + hs_ext True - , pure $ map (srcObjPath way) extraSources - , catMaybes - <$> sequenceA - [ findFileCwdWithExtension - mbWorkDir - [Suffix $ buildWayPrefix way ++ objExtension] - [buildTargetDir] - xPath - | ghcVersion < mkVersion [7, 2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi - , let xPath :: RelativePath Artifacts File - xPath = makeRelativePathEx $ ModuleName.toFilePath x ++ "_stub" - ] + , pure $ map (objectFilePath buildTargetDir obj_ext) extraSources ] - -- Get the @.o@ path from a source path (e.g. @.hs@), - -- in the library target build directory. - srcObjPath :: BuildWay -> SymbolicPath Pkg File -> SymbolicPath Pkg File - srcObjPath way srcPath = - case symbolicPathRelative_maybe objPath of - -- Absolute path: should already be in the target build directory - -- (e.g. a preprocessed file) - -- TODO: assert this? - Nothing -> objPath - Just objRelPath -> coerceSymbolicPath buildTargetDir objRelPath - where - objPath = srcPath `replaceExtensionSymbolicPath` (buildWayPrefix way ++ objExtension) - -- I'm fairly certain that, just like the executable, we can keep just the -- module input list, and point to the right sources dir (as is already -- done), and GHC will pick up the right suffix (p_ for profile, dyn_ when @@ -343,37 +307,13 @@ -- we could more easily merge the two. -- -- Right now, instead, we pass the path to each object file. + ghcBaseLinkArgs :: GhcOptions ghcBaseLinkArgs = - mempty - { -- TODO: This basically duplicates componentGhcOptions. - -- I think we want to do the same as we do for executables: re-use the - -- base options, and link by module names, not object paths. - ghcOptExtra = hcStaticOptions GHC libBi - , ghcOptHideAllPackages = toFlag True - , ghcOptNoAutoLinkPackages = toFlag True - , ghcOptPackageDBs = withPackageDB lbi - , ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> - toFlag pk - _ -> mempty - , ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts - } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty - , ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts - } -> - insts - _ -> [] - , ghcOptPackages = - toNubListR $ - Internal.mkGhcOptPackages mempty clbi - } + Internal.linkGhcOptions (verbosityLevel verbosity) lbi libBi clbi + <> mempty + { ghcOptExtra = hcStaticOptions GHC libBi + , ghcOptNoAutoLinkPackages = toFlag True + } -- After the relocation lib is created we invoke ghc -shared -- with the dependencies spelled out as -package arguments @@ -385,16 +325,9 @@ , ghcOptDynLinkMode = toFlag GhcDynamicOnly , ghcOptInputFiles = toNubListR $ map coerceSymbolicPath dynObjectFiles , ghcOptOutputFile = toFlag sharedLibFilePath - , -- For dynamic libs, Mac OS/X needs to know the install location - -- at build time. This only applies to GHC < 7.8 - see the - -- discussion in #1660. - ghcOptDylibName = - if hostOS == OSX - && ghcVersion < mkVersion [7, 8] - then toFlag sharedLibInstallPath - else mempty + , ghcOptDylibName = mempty , ghcOptLinkLibs = extraLibs libBi - , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs + , ghcOptLinkLibPath = toNubListR cleanedExtraLibDirs , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs libBi @@ -411,16 +344,9 @@ , ghcOptDynLinkMode = toFlag GhcDynamicOnly , ghcOptInputFiles = toNubListR pdynObjectFiles , ghcOptOutputFile = toFlag profSharedLibFilePath - , -- For dynamic libs, Mac OS/X needs to know the install location - -- at build time. This only applies to GHC < 7.8 - see the - -- discussion in #1660. - ghcOptDylibName = - if hostOS == OSX - && ghcVersion < mkVersion [7, 8] - then toFlag profSharedLibInstallPath - else mempty + , ghcOptDylibName = mempty , ghcOptLinkLibs = extraLibs libBi - , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs + , ghcOptLinkLibPath = toNubListR cleanedExtraLibDirs , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs libBi @@ -433,14 +359,22 @@ , ghcOptOutputFile = toFlag staticLibFilePath , ghcOptLinkLibs = extraLibs libBi , -- TODO: Shouldn't this use cleanedExtraLibDirsStatic instead? - ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs + ghcOptLinkLibPath = toNubListR cleanedExtraLibDirs } + ghcBytecodeLinkArgs objectFiles = + (ghcSharedLinkArgs objectFiles) + { ghcOptBytecodeLib = toFlag True + , ghcOptInputFiles = toNubListR $ map coerceSymbolicPath objectFiles + , ghcOptOutputFile = toFlag bytecodeLibFilePath + } - staticObjectFiles <- getObjFiles StaticWay - profObjectFiles <- getObjFiles ProfWay - dynamicObjectFiles <- getObjFiles DynWay - profDynamicObjectFiles <- getObjFiles ProfDynWay + staticObjectFiles <- getObjWayFiles StaticWay + profObjectFiles <- getObjWayFiles ProfWay + dynamicObjectFiles <- getObjWayFiles DynWay + profDynamicObjectFiles <- getObjWayFiles ProfDynWay + -- See doc/internal/bytecode-libraries.md for how the chosen companion + -- way determines which .gbc files get packed into the .bytecodelib. let linkWay = \case ProfWay -> do @@ -457,6 +391,10 @@ runGhcProg $ ghcProfSharedLinkArgs profDynamicObjectFiles DynWay -> do runGhcProg $ ghcSharedLinkArgs dynamicObjectFiles + -- The .gbc files were built with DynWay if both are enabled. + when (withBytecodeLib lbi) $ do + bytecodeObjectFiles <- getObjBytecodeWayFiles DynWay + runGhcProg $ ghcBytecodeLinkArgs bytecodeObjectFiles StaticWay -> do when (withVanillaLib lbi) $ do Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles @@ -470,19 +408,32 @@ staticObjectFiles when (withStaticLib lbi) $ do runGhcProg $ ghcStaticLinkArgs staticObjectFiles + -- The .gbc files were built with `DynWay` if `DynWay` is enabled. Otherwise (this case), + -- the files are produced alongside `StaticWay`. + when (withBytecodeLib lbi && (DynWay `notElem` wantedWays)) $ do + bytecodeObjectFiles <- getObjBytecodeWayFiles StaticWay + runGhcProg $ ghcBytecodeLinkArgs bytecodeObjectFiles -- ROMES: Why exactly branch on staticObjectFiles, rather than any other build -- kind that we might have wanted instead? -- This would be simpler by not adding every object to the invocation, and -- rather using module names. unless (null staticObjectFiles) $ do - info verbosity (show (ghcOptPackages (Internal.componentGhcOptions verbosity lbi libBi clbi buildTargetDir))) + info verbosity $ + show $ + ghcOptPackages $ + Internal.componentGhcOptions + (verbosityLevel verbosity) + lbi + libBi + clbi + buildTargetDir traverse_ linkWay wantedWays -- | Link the executable resulting from building this component, be it an -- executable, test, or benchmark component. linkExecutable - :: (GhcOptions) + :: GhcOptions -- ^ The linker-specific GHC options -> (BuildWay, BuildWay -> GhcOptions) -- ^ The wanted build ways and corresponding GhcOptions that were @@ -506,16 +457,11 @@ -- assume there is a main function in another non-haskell object ghcOptLinkNoHsMain = toFlag (ghcOptInputFiles baseOpts == mempty && ghcOptInputScripts baseOpts == mempty) } - comp = compiler lbi -- Work around old GHCs not relinking in this -- situation, see #3294 let target = targetDir makeRelativePathEx (exeTargetName (hostPlatform lbi) targetName) - when (compilerVersion comp < mkVersion [7, 7]) $ do - let targetPath = interpretSymbolicPathLBI lbi target - e <- doesFileExist targetPath - when e (removeFile targetPath) runGhcProg linkOpts{ghcOptOutputFile = toFlag target} -- | Link a foreign library component @@ -523,7 +469,7 @@ :: ForeignLib -> BuildInfo -> LocalBuildInfo - -> (GhcOptions) + -> GhcOptions -- ^ The linker-specific GHC options -> (BuildWay, BuildWay -> GhcOptions) -- ^ The wanted build ways and corresponding GhcOptions that were @@ -569,7 +515,7 @@ linkOpts :: GhcOptions linkOpts = case foreignLibType flib of ForeignLibNativeShared -> - (buildOpts way) + buildOpts way `mappend` linkerOpts `mappend` rtsLinkOpts `mappend` mempty @@ -622,7 +568,7 @@ supportRPaths OSX = True supportRPaths FreeBSD = case compid of - CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True + CompilerId GHC _ -> True _ -> False supportRPaths OpenBSD = False supportRPaths NetBSD = False @@ -726,7 +672,7 @@ -- threaded RTS. This is used to determine which RTS to link against when -- building a foreign library with a GHC without support for @-flink-rts@. hasThreaded :: BuildInfo -> Bool -hasThreaded bi = elem "-threaded" ghc +hasThreaded bi = "-threaded" `elem` ghc where PerCompilerFlavor ghc _ = options bi @@ -734,13 +680,14 @@ -- GHCi with the GHC options Cabal elaborated to load the component interactively. runReplOrWriteFlags :: ConfiguredProgram + -> VerbosityHandles -> LocalBuildInfo -> ReplFlags -> GhcOptions -> PackageName -> TargetInfo -> IO () -runReplOrWriteFlags ghcProg lbi rflags ghcOpts pkg_name target = +runReplOrWriteFlags ghcProg verbHandles lbi rflags ghcOpts pkg_name target = let bi = componentBuildInfo $ targetComponent target clbi = targetCLBI target cname = componentName (targetComponent target) @@ -748,7 +695,7 @@ platform = hostPlatform lbi common = configCommonFlags $ configFlags lbi mbWorkDir = mbWorkDirLBI lbi - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) tempFileOptions = commonSetupTempFileOptions common in case replOptionsFlagOutput (replReplOptions rflags) of NoFlag -> do 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 @@ -6,7 +6,7 @@ module Distribution.Simple.GHC.Build.Modules ( buildHaskellModules , BuildWay (..) - , buildWayPrefix + , buildWayObjectExtension , componentInputs ) where @@ -22,6 +22,7 @@ import Distribution.Simple.Build.Inputs import Distribution.Simple.BuildWay import Distribution.Simple.Compiler +import Distribution.Simple.Errors (CabalException (StandaloneBytecodeNotSupportedYet)) import Distribution.Simple.GHC.Build.Utils import qualified Distribution.Simple.GHC.Internal as Internal import qualified Distribution.Simple.Hpc as Hpc @@ -41,6 +42,7 @@ import Distribution.Types.TestSuiteInterface import Distribution.Utils.NubList import Distribution.Utils.Path +import Distribution.Verbosity (VerbosityHandles, mkVerbosity, verbosityLevel) import System.FilePath () {- @@ -52,7 +54,7 @@ * The dynamic/shared way (-dynamic) * The profiled way (-prof) -For libraries, we may /want/ to build modules in all three ways, or in any combination, depending on user options. +For libraries, we may /want/ to build modules in all ways, or in any combination, depending on user options. For executables, we just /want/ to build the executable in the requested way. In practice, however, we may /need/ to build modules in additional ways beyonds the ones that were requested. @@ -110,6 +112,8 @@ -- has already been created. -> [BuildWay] -- ^ The set of needed build ways according to user options + -> VerbosityHandles + -- ^ Logging handles -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO (BuildWay -> GhcOptions) @@ -117,11 +121,11 @@ -- invocation used to compile the component in that 'BuildWay'. -- This can be useful in, eg, a linker invocation, in which we want to use the -- same options and list the same inputs as those used for building. -buildHaskellModules numJobs ghcProg mbMainFile inputModules buildTargetDir neededLibWays pbci = do +buildHaskellModules numJobs ghcProg mbMainFile inputModules buildTargetDir neededLibWays verbHandles pbci = do -- See Note [Building Haskell Modules accounting for TH] let - verbosity = buildVerbosity pbci + verbosity = mkVerbosity verbHandles $ buildVerbosity pbci isLib = buildIsLib pbci clbi = buildCLBI pbci lbi = localBuildInfo pbci @@ -129,7 +133,10 @@ what = buildingWhat pbci comp = buildCompiler pbci i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + neededLibWaysSet = Set.fromList neededLibWays + withBytecode = withBytecodeLib lbi + -- If this component will be loaded into a repl, we don't compile the modules at all. forRepl | BuildRepl{} <- what = True @@ -166,7 +173,7 @@ -- We define the base opts which are shared across different build ways in -- 'buildHaskellModules' baseOpts way = - (Internal.componentGhcOptions verbosity lbi bi clbi buildTargetDir) + Internal.componentGhcOptions (verbosityLevel verbosity) lbi bi clbi buildTargetDir `mappend` mempty { ghcOptMode = toFlag GhcModeMake , -- Previously we didn't pass -no-link when building libs, @@ -179,23 +186,33 @@ , ghcOptInputFiles = toNubListR hsMains , ghcOptInputScripts = toNubListR scriptMains , ghcOptExtra = buildWayExtraHcOptions way GHC bi - , ghcOptHiSuffix = optSuffixFlag (buildWayPrefix way) "hi" - , ghcOptObjSuffix = optSuffixFlag (buildWayPrefix way) "o" + , ghcOptHiSuffix = needsWaySuffixFlag (buildWayInterfaceExtension way) "hi" + , ghcOptObjSuffix = needsWaySuffixFlag (buildWayObjectExtension "o" way) "o" , ghcOptHPCDir = hpcdir (buildWayHpcWay way) -- maybe this should not be passed for vanilla? } where - optSuffixFlag "" _ = NoFlag - optSuffixFlag pre x = toFlag (pre ++ x) + needsWaySuffixFlag x y = if x == y then NoFlag else toFlag x + -- Bytecode objects are attached to an existing native way; see + -- doc/internal/bytecode-libraries.md for the companion-way rules. + bytecodeToo p = if p then toFlag GhcByteCodeAndObjectCode else NoFlag + + hasWay way = way `Set.member` neededLibWaysSet + -- For libs we don't pass -static when building static, leaving it -- implicit. We should just always pass -static, but we don't want to -- change behaviour when doing the refactor. - staticOpts = (baseOpts StaticWay){ghcOptDynLinkMode = if isLib then NoFlag else toFlag GhcStaticOnly} + staticOpts = + (baseOpts StaticWay) + { ghcOptDynLinkMode = if isLib then NoFlag else toFlag GhcStaticOnly + , ghcOptObjectMode = bytecodeToo (withBytecode && not (hasWay DynWay)) + } dynOpts = (baseOpts DynWay) { ghcOptDynLinkMode = toFlag GhcDynamicOnly -- use -dynamic , -- TODO: Does it hurt to set -fPIC for executables? ghcOptFPic = toFlag True -- use -fPIC + , ghcOptObjectMode = bytecodeToo withBytecode } profOpts = (baseOpts ProfWay) @@ -222,9 +239,10 @@ dynTooOpts = (baseOpts StaticWay) { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic -- use -dynamic-too - , ghcOptDynHiSuffix = toFlag (buildWayPrefix DynWay ++ "hi") - , ghcOptDynObjSuffix = toFlag (buildWayPrefix DynWay ++ "o") + , ghcOptDynHiSuffix = toFlag (buildWayInterfaceExtension DynWay) + , ghcOptDynObjSuffix = toFlag (buildWayObjectExtension "o" DynWay) , ghcOptHPCDir = hpcdir Hpc.Dyn + , ghcOptObjectMode = bytecodeToo withBytecode -- Should we pass hcSharedOpts in the -dynamic-too ghc invocation? -- (Note that `baseOtps StaticWay = hcStaticOptions`, not hcSharedOpts) } @@ -239,8 +257,8 @@ Internal.profDetailLevelFlag (if isLib then True else False) ((if isLib then withProfLibDetail else withProfExeDetail) lbi) - , ghcOptDynHiSuffix = toFlag (buildWayPrefix ProfDynWay ++ "hi") - , ghcOptDynObjSuffix = toFlag (buildWayPrefix ProfDynWay ++ "o") + , ghcOptDynHiSuffix = toFlag (buildWayInterfaceExtension ProfDynWay) + , ghcOptDynObjSuffix = toFlag (buildWayObjectExtension "o" ProfDynWay) , ghcOptHPCDir = hpcdir Hpc.ProfDyn -- Should we pass hcSharedOpts in the -dynamic-too ghc invocation? -- (Note that `baseOtps StaticWay = hcStaticOptions`, not hcSharedOpts) @@ -254,12 +272,16 @@ ProfWay -> profOpts ProfDynWay -> profDynOpts + when + ( withBytecode + && not (hasWay StaticWay || hasWay DynWay) + ) + $ dieWithException verbosity StandaloneBytecodeNotSupportedYet + -- If there aren't modules, or if we're loading the modules in repl, don't build. unless (forRepl || (isNothing mbMainFile && null inputModules)) $ liftIO $ do -- See Note [Building Haskell Modules accounting for TH] let - neededLibWaysSet = Set.fromList neededLibWays - -- If we need both static and dynamic, use dynamic-too instead of -- compiling twice (if we support it) useDynamicToo = @@ -364,12 +386,14 @@ componentInputs :: SymbolicPath Pkg (Dir Artifacts) -- ^ Target build dir + -> VerbosityHandles + -- ^ Logging handles -> PD.PackageDescription -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO (Maybe (SymbolicPath Pkg File), [ModuleName]) -- ^ The main input file, and the Haskell modules -componentInputs buildTargetDir pkg_descr pbci = +componentInputs buildTargetDir verbHandles pkg_descr pbci = case component of CLib lib -> pure (Nothing, allLibModules lib clbi) @@ -384,7 +408,7 @@ CTest TestSuite{} -> error "testSuiteExeV10AsExe: wrong kind" CBench Benchmark{} -> error "benchmarkExeV10asExe: wrong kind" where - verbosity = buildVerbosity pbci + verbosity = mkVerbosity verbHandles $ buildVerbosity pbci component = buildComponent pbci clbi = buildCLBI pbci mbWorkDir = mbWorkDirLBI $ localBuildInfo pbci diff --git a/src/Distribution/Simple/GHC/Build/Utils.hs b/src/Distribution/Simple/GHC/Build/Utils.hs --- a/src/Distribution/Simple/GHC/Build/Utils.hs +++ b/src/Distribution/Simple/GHC/Build/Utils.hs @@ -26,8 +26,7 @@ import Distribution.Utils.Path import Distribution.Verbosity import System.FilePath - ( replaceExtension - , takeExtension + ( takeExtension ) -- | Find the path to the entry point of an executable (typically specified in @@ -74,17 +73,21 @@ ForeignLibTypeUnknown -> cabalBug "unknown foreign lib type" +-- | Is the extension of the file in the list of extensions? +extensionIn :: [String] -> FilePath -> Bool +extensionIn exts fp = takeExtension fp `elem` exts + -- | Is this file a C++ source file, i.e. ends with .cpp, .cxx, or .c++? isCxx :: FilePath -> Bool -isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] +isCxx = extensionIn [".cpp", ".cxx", ".c++"] -- | Is this a C source file, i.e. ends with .c? isC :: FilePath -> Bool -isC fp = elem (takeExtension fp) [".c"] +isC = extensionIn [".c"] -- | FilePath has a Haskell extension: .hs or .lhs isHaskell :: FilePath -> Bool -isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] +isHaskell = extensionIn [".hs", ".lhs"] -- | Returns True if the modification date of the given source file is newer than -- the object file we last compiled for it, or if no object file exists yet. @@ -102,17 +105,44 @@ -- | Finds the object file name of the given source file getObjectFileName :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Package directory -> SymbolicPath Pkg File + -- ^ Symbolic path to the source file -> GhcOptions + -- ^ GHC compilation options -> FilePath + -- ^ Path to the object file getObjectFileName mbWorkDir filename opts = oname where i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path - odir = i $ fromFlag (ghcOptObjDir opts) + odir = fromFlag (ghcOptObjDir opts) oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) -- NB: the filepath might be absolute, e.g. if it is the path to -- an autogenerated .hs file. - oname = odir replaceExtension (getSymbolicPath filename) oext + oname = i $ objectFilePath odir oext filename + +-- | Given the path to a source file (Haskell, C, JS...), return the corresponding +-- object file path (input to the linker). +objectFilePath + :: SymbolicPath Pkg (Dir Artifacts) + -- ^ Objects build directory (@-odir@) + -> String + -- ^ Object file extension + -> SymbolicPath Pkg File + -- ^ Source file path (relative or absolute) + -> SymbolicPath Pkg File + -- ^ Resulting object file path +objectFilePath buildTargetDir objExt src = + case symbolicPathRelative_maybe objPath of + Just relObjPath -> + -- For a relative input file, the output object file is placed under the -odir. + coerceSymbolicPath buildTargetDir relObjPath + Nothing -> + -- For an absolute input file, the object file is placed next to the input file + -- and not within -odir. + objPath + where + objPath = src `replaceExtensionSymbolicPath` objExt -- | Target name for a foreign library (the actual file name) -- 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 @@ -3,6 +3,7 @@ module Distribution.Simple.GHC.EnvironmentParser (parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc (..)) where +import Data.Functor (($>)) import Distribution.Compat.Prelude import Prelude () @@ -25,7 +26,7 @@ GhcEnvFileComment <$> comment <|> GhcEnvFilePackageId <$> unitId <|> GhcEnvFilePackageDb <$> packageDb - <|> pure GhcEnvFileClearPackageDbStack <* clearDb + <|> GhcEnvFileClearPackageDbStack <$ clearDb where comment = P.string "--" *> P.many (P.noneOf "\r\n") unitId = @@ -34,8 +35,8 @@ *> P.spaces *> (mkUnitId <$> P.many1 (P.satisfy $ \c -> isAlphaNum c || c `elem` "-_.+")) packageDb = - (P.string "global-package-db" *> pure GlobalPackageDB) - <|> (P.string "user-package-db" *> pure UserPackageDB) + (P.string "global-package-db" $> GlobalPackageDB) + <|> (P.string "user-package-db" $> UserPackageDB) <|> (P.string "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine)) clearDb = P.string "clear-package-db" diff --git a/src/Distribution/Simple/GHC/ImplInfo.hs b/src/Distribution/Simple/GHC/ImplInfo.hs --- a/src/Distribution/Simple/GHC/ImplInfo.hs +++ b/src/Distribution/Simple/GHC/ImplInfo.hs @@ -20,7 +20,13 @@ import Prelude () import Distribution.Simple.Compiler -import Distribution.Version + ( Compiler + , CompilerFlavor (..) + , compilerCompatVersion + , compilerFlavor + , compilerVersion + ) +import Distribution.Types.Version (Version, versionNumbers) -- | -- Information about features and quirks of a GHC-based implementation. @@ -34,30 +40,14 @@ -- module) should use implementation info rather than version numbers -- to test for supported features. data GhcImplInfo = GhcImplInfo - { supportsHaskell2010 :: Bool - -- ^ -XHaskell2010 and -XHaskell98 flags - , supportsGHC2021 :: Bool + { supportsGHC2021 :: Bool -- ^ -XGHC2021 flag , supportsGHC2024 :: Bool -- ^ -XGHC2024 flag - , reportsNoExt :: Bool - -- ^ --supported-languages gives Ext and NoExt - , alwaysNondecIndent :: Bool - -- ^ NondecreasingIndentation is always on - , flagGhciScript :: Bool - -- ^ -ghci-script flag supported - , flagProfAuto :: Bool - -- ^ new style -fprof-auto* flags , flagProfLate :: Bool -- ^ fprof-late flag - , flagPackageConf :: Bool - -- ^ use package-conf instead of package-db - , flagDebugInfo :: Bool - -- ^ -g flag supported , flagHie :: Bool -- ^ -hiedir flag supported - , supportsDebugLevels :: Bool - -- ^ supports numeric @-g@ levels , supportsPkgEnvFiles :: Bool -- ^ picks up @.ghc.environment@ files , flagWarnMissingHomeModules :: Bool @@ -88,18 +78,10 @@ ghcVersionImplInfo :: Version -> GhcImplInfo ghcVersionImplInfo ver = GhcImplInfo - { supportsHaskell2010 = v >= [7] - , supportsGHC2021 = v >= [9, 1] + { supportsGHC2021 = v >= [9, 1] , supportsGHC2024 = v >= [9, 9] - , reportsNoExt = v >= [7] - , alwaysNondecIndent = v < [7, 1] - , flagGhciScript = v >= [7, 2] - , flagProfAuto = v >= [7, 4] , flagProfLate = v >= [9, 4] - , flagPackageConf = v < [7, 5] - , flagDebugInfo = v >= [7, 10] , flagHie = v >= [8, 8] - , supportsDebugLevels = v >= [8, 0] , supportsPkgEnvFiles = v >= [8, 0, 1, 20160901] -- broken in 8.0.1, fixed in 8.0.2 , flagWarnMissingHomeModules = v >= [8, 2] , unitIdForExes = v >= [9, 2] @@ -115,18 +97,10 @@ -> GhcImplInfo ghcjsVersionImplInfo _ghcjsver ghcver = GhcImplInfo - { supportsHaskell2010 = True - , supportsGHC2021 = True + { supportsGHC2021 = ghcv >= [9, 1] , supportsGHC2024 = ghcv >= [9, 9] - , reportsNoExt = True - , alwaysNondecIndent = False - , flagGhciScript = True - , flagProfAuto = True - , flagProfLate = True - , flagPackageConf = False - , flagDebugInfo = False + , flagProfLate = ghcv >= [9, 4] , flagHie = ghcv >= [8, 8] - , supportsDebugLevels = ghcv >= [8, 0] , supportsPkgEnvFiles = ghcv >= [8, 0, 2] -- TODO: check this works in ghcjs , flagWarnMissingHomeModules = ghcv >= [8, 2] , unitIdForExes = ghcv >= [9, 2] 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,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -20,12 +19,8 @@ , getExtensions , targetPlatform , getGhcInfo - , componentCcGhcOptions - , componentCmmGhcOptions - , componentCxxGhcOptions - , componentAsmGhcOptions - , componentJsGhcOptions , componentGhcOptions + , sourcesGhcOptions , mkGHCiLibName , mkGHCiProfLibName , filterGhciFlags @@ -35,6 +30,11 @@ , substTopDir , checkPackageDbEnvVar , profDetailLevelFlag + , ghcOptionsSince + , linkGhcOptions + , optimizationCFlags + , splitCandCxxOptions + , SplitSource (..) -- * GHC platform and version strings , ghcArchString @@ -59,16 +59,14 @@ import qualified Data.Set as Set import Distribution.Backpack import Distribution.Compat.Stack -import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Lex import qualified Distribution.ModuleName as ModuleName -import Distribution.PackageDescription import Distribution.Parsec (simpleParsec) import Distribution.Pretty (prettyShow) import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.Errors -import Distribution.Simple.Flag (Flag, maybeToFlag, toFlag, pattern NoFlag) +import Distribution.Simple.Flag import Distribution.Simple.GHC.ImplInfo import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program @@ -76,17 +74,22 @@ import Distribution.Simple.Setup.Common (extraCompilationArtifacts) import Distribution.Simple.Utils import Distribution.System +import Distribution.Types.BuildInfo import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.GivenComponent +import qualified Distribution.Types.InstalledPackageInfo as IPI +import Distribution.Types.Library import Distribution.Types.LocalBuildInfo +import Distribution.Types.ModuleRenaming +import Distribution.Types.PackageName import Distribution.Types.TargetInfo import Distribution.Types.UnitId +import Distribution.Types.Version import Distribution.Utils.NubList (NubListR, toNubListR) import Distribution.Utils.Path import Distribution.Verbosity -import Distribution.Version (Version) import Language.Haskell.Extension -import System.Directory (getDirectoryContents) +import System.Directory (listDirectory) import System.Environment (getEnv) import System.FilePath ( takeDirectory @@ -180,7 +183,7 @@ findProg progName extraPath v searchpath = findProgramOnSearchPath v searchpath' progName where - searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath + searchpath' = map ProgramSearchPathDir extraPath ++ searchpath -- Read tool locations from the 'ghc --info' output. Useful when -- cross-compiling. @@ -192,10 +195,8 @@ 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" - ldLinkerFlags = getFlags "Ld Linker flags" ++ getFlags "ld flags" + gccLinkerFlags = getFlags "C compiler link flags" + ldLinkerFlags = getFlags "ld flags" -- It appears that GHC 7.6 and earlier encode the tokenized flags as a -- [String] in these settings whereas later versions just encode the flags as @@ -271,11 +272,9 @@ else return ldProg getLanguages - :: Verbosity - -> GhcImplInfo - -> ConfiguredProgram + :: GhcImplInfo -> IO [(Language, String)] -getLanguages _ implInfo _ +getLanguages implInfo -- TODO: should be using --supported-languages rather than hard coding | supportsGHC2024 implInfo = return @@ -290,12 +289,11 @@ , (Haskell2010, "-XHaskell2010") , (Haskell98, "-XHaskell98") ] - | supportsHaskell2010 implInfo = + | otherwise = return [ (Haskell98, "-XHaskell98") , (Haskell2010, "-XHaskell2010") ] - | otherwise = return [(Haskell98, "")] getGhcInfo :: Verbosity @@ -317,45 +315,18 @@ getExtensions :: Verbosity - -> GhcImplInfo -> ConfiguredProgram -> IO [(Extension, Maybe String)] -getExtensions verbosity implInfo ghcProg = do +getExtensions verbosity ghcProg = do str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg) ["--supported-languages"] - let extStrs = - if reportsNoExt implInfo - then lines str - else -- Older GHCs only gave us either Foo or NoFoo, - -- so we have to work out the other one ourselves - - [ extStr'' - | extStr <- lines str - , let extStr' = case extStr of - 'N' : 'o' : xs -> xs - _ -> "No" ++ extStr - , extStr'' <- [extStr, extStr'] - ] - let extensions0 = - [ (ext, Just $ "-X" ++ prettyShow ext) - | Just ext <- map simpleParsec extStrs - ] - extensions1 = - if alwaysNondecIndent implInfo - then -- ghc-7.2 split NondecreasingIndentation off - -- into a proper extension. Before that it - -- was always on. - -- Since it was not a proper extension, it could - -- not be turned off, hence we omit a - -- DisableExtension entry here. - - (EnableExtension NondecreasingIndentation, Nothing) - : extensions0 - else extensions0 - return extensions1 + return + [ (ext, Just $ "-X" ++ prettyShow ext) + | Just ext <- map simpleParsec $ lines str + ] includePaths :: LocalBuildInfo @@ -377,156 +348,199 @@ | dir <- mapMaybe (symbolicPathRelative_maybe . unsafeCoerceSymbolicPath) $ includeDirs bi ] -componentCcGhcOptions - :: Verbosity - -> LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> SymbolicPath Pkg (Dir Artifacts) - -> SymbolicPath Pkg File - -> GhcOptions -componentCcGhcOptions verbosity lbi bi clbi odir filename = - mempty - { -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal) - , ghcOptMode = toFlag GhcModeCompile - , ghcOptInputFiles = toNubListR [filename] - , ghcOptCppIncludePath = includePaths lbi bi clbi odir - , ghcOptHideAllPackages = toFlag True - , ghcOptPackageDBs = withPackageDB lbi - , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi - , ghcOptCcOptions = - ( case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"] - ) - ++ ( case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"] - ) - ++ ccOptions bi - , ghcOptCcProgram = - maybeToFlag $ - programPath - <$> lookupProgram gccProgram (withPrograms lbi) - , ghcOptObjDir = toFlag odir - , ghcOptExtra = hcOptions GHC bi - } +data SplitSource = CcProgram | CxxProgram -componentCxxGhcOptions - :: Verbosity +splitCandCxxOptions + :: SplitSource + -> VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Artifacts) -> SymbolicPath Pkg File -> GhcOptions -componentCxxGhcOptions verbosity lbi bi clbi odir filename = - mempty - { -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal) - , ghcOptMode = toFlag GhcModeCompile - , ghcOptInputFiles = toNubListR [filename] - , ghcOptCppIncludePath = includePaths lbi bi clbi odir - , ghcOptHideAllPackages = toFlag True - , ghcOptPackageDBs = withPackageDB lbi - , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi - , ghcOptCxxOptions = - ( case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"] - ) - ++ ( case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"] - ) - ++ cxxOptions bi - , ghcOptCcProgram = - maybeToFlag $ - programPath - <$> lookupProgram gccProgram (withPrograms lbi) - , ghcOptObjDir = toFlag odir - , ghcOptExtra = hcOptions GHC bi - } +splitCandCxxOptions source verbosity lbi bi clbi odir filename = case source of + CxxProgram -> + -- For C++ sources: reset ccOptions for GHC < 8.10, because on those + -- old GHCs there's no -optcxx flag — all options go through -optc. + -- Without this reset, C-specific flags (ccOptions) would leak into + -- C++ compilation via -optc, which is wrong. + setGppProgram $ setCcOptions $ sourcesGhcOptions verbosity lbi bi clbi odir filename + CcProgram -> + -- For C sources: reset cxxOptions for GHC < 8.10, because on those + -- old GHCs there's no -optcxx flag — all options go through -optc. + -- Without this reset, C++-specific flags (cxxOptions) would leak into + -- C compilation via -optc, which is wrong. + setCcProgram $ setCxxOptions $ sourcesGhcOptions verbosity lbi bi clbi odir filename + where + setCcOptions xxx = + xxx + { -- C compiler options: GHC >= 8.10 requires -optcxx, older requires -optc + -- we want to be able to support cxx-options and cc-options separately + -- https://gitlab.haskell.org/ghc/ghc/-/issues/16477 + -- see example in cabal-testsuite/PackageTests/FFI/ForeignOptsCxx + ghcOptCcOptions = + ghcOptionsSince + (mkVersion [8, 10]) + (compiler lbi) + (optimizationCFlags lbi ++ ccOptions bi) + } + setCxxOptions xxx = + xxx + { -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc + -- we want to be able to support cxx-options and cc-options separately + -- https://gitlab.haskell.org/ghc/ghc/-/issues/16477 + -- see example in cabal-testsuite/PackageTests/FFI/ForeignOptsC + ghcOptCxxOptions = + ghcOptionsSince + (mkVersion [8, 10]) + (compiler lbi) + (optimizationCFlags lbi ++ cxxOptions bi) + } + setCcProgram xxx = + xxx + { -- We pass -pgmc to ensure that GHC respects cc-options and ld-options (#4435, #9801). + -- However, we deliberately restrict this flag ONLY to C and C++ source files. + -- We do not pass it globally (e.g., during linking or ordinary Haskell compilation) + -- for two reasons: + -- 1. Status quo: This preserves Cabal's historical behavior. + -- 2. GHC < 9.4 bug (https://gitlab.haskell.org/ghc/ghc/-/issues/15319): Before GHC 9.4, + -- passing a custom C compiler via -pgmc caused GHC to automatically disable the + -- -no-pie flag (which is critical during linking on auto-hardened toolchains). + -- Passing -pgmc globally would therefore break linking on older GHCs. + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6949 fixed this by moving + -- the -no-pie check to -pgml, but scoping -pgmc exclusively to C/C++ compilation + -- protects older GHC versions from this link-time breakage. + -- see example in cabal-testsuite/PackageTests/FFI/ForeignOptsPgmc + ghcOptCcProgram = maybeToFlag $ programPath <$> lookupProgram gccProgram (withPrograms lbi) + } + setGppProgram xxx = + xxx + { -- We explicitly pass the C++ compiler via -pgmcxx because GHC >= 9.4 + -- does not automatically detect it from the toolchain. Without this GHC + -- falls back to a gcc as a C++ compiler. + -- Related: #11805 + ghcOptGppProgram = + ghcOptionsSince + (mkVersion [9, 4]) + (compiler lbi) + (maybeToFlag $ programPath <$> lookupProgram gppProgram (withPrograms lbi)) + , -- For GHC < 9.4, which does not support -pgmcxx, we fall back to + -- passing the C++ compiler via -pgmc. This ensures C++ sources are + -- compiled with the correct compiler even on older GHCs. + -- Note: we use gppProgram (C++ compiler), NOT gccProgram (C compiler), + -- because this path is specifically for C++ source files. + -- Related: #11805 + ghcOptCcProgram = + ghcOptionsBefore + (mkVersion [9, 4]) + (compiler lbi) + (maybeToFlag $ programPath <$> lookupProgram gppProgram (withPrograms lbi)) + } -componentAsmGhcOptions - :: Verbosity +sourcesGhcOptions + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Artifacts) -> SymbolicPath Pkg File -> GhcOptions -componentAsmGhcOptions verbosity lbi bi clbi odir filename = - mempty - { -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal) +sourcesGhcOptions verbosity lbi bi clbi odir filename = + (componentGhcOptions verbosity lbi bi clbi odir) + { ghcOptVerbosity = toFlag (min verbosity Normal) , ghcOptMode = toFlag GhcModeCompile , ghcOptInputFiles = toNubListR [filename] - , ghcOptCppIncludePath = includePaths lbi bi clbi odir - , ghcOptHideAllPackages = toFlag True - , ghcOptPackageDBs = withPackageDB lbi - , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi - , ghcOptAsmOptions = - ( case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"] - ) - ++ ( case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"] - ) - ++ asmOptions bi , ghcOptObjDir = toFlag odir - , ghcOptExtra = hcOptions GHC bi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , -- cpp-options apply only to .hs files; GHC ignores -optP for non-Haskell + -- files (and since 9.10 this behavior is explicit/enforced) + ghcOptCppOptions = [] } -componentJsGhcOptions - :: Verbosity +optimizationCFlags :: LocalBuildInfo -> [String] +optimizationCFlags lbi = + ( case withOptimization lbi of + -- see --disable-optimization + NoOptimisation -> [] + -- '*-options: -O[n]' is generally not needed. When building with + -- optimisations Cabal automatically adds '-O2' for * code. Setting it + -- yourself interferes with the --disable-optimization flag. + -- see https://github.com/haskell/cabal/pull/8250 + NormalOptimisation -> ["-O2"] + -- see --enable-optimization + MaximumOptimisation -> ["-O2"] + ) + ++ ( case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"] + ) + +-- Applies options only if the GHC version is greater than or +-- equal to the given one. +ghcOptionsSince :: Monoid a => Version -> Compiler -> a -> a +ghcOptionsSince ver comp defOptions = + case compilerCompatVersion GHC comp of + Just v + | v >= ver -> defOptions + | otherwise -> mempty + Nothing -> mempty + +-- Applies options only if the GHC version is less than the given one. +ghcOptionsBefore :: Monoid a => Version -> Compiler -> a -> a +ghcOptionsBefore ver comp defOptions = + case compilerCompatVersion GHC comp of + Just v + | v < ver -> defOptions + | otherwise -> mempty + Nothing -> mempty + +componentGhcOptions + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> SymbolicPath Pkg (Dir Artifacts) - -> SymbolicPath Pkg File + -> SymbolicPath Pkg (Dir build) -> GhcOptions -componentJsGhcOptions verbosity lbi bi clbi odir filename = - mempty - { -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal) - , ghcOptMode = toFlag GhcModeCompile - , ghcOptInputFiles = toNubListR [filename] - , 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 verbosity lbi bi clbi odir = + let implInfo = getImplInfo $ compiler lbi + in (linkGhcOptions verbosity lbi bi clbi) + { ghcOptSourcePath = + toNubListR $ + hsSourceDirs bi + ++ [coerceSymbolicPath odir] + ++ [autogenComponentModulesDir lbi clbi] + ++ [autogenPackageModulesDir lbi] + , ghcOptCppIncludePath = includePaths lbi bi clbi odir + , ghcOptObjDir = toFlag $ coerceSymbolicPath odir + , ghcOptHiDir = toFlag $ coerceSymbolicPath odir + , ghcOptHieDir = bool NoFlag (toFlag $ coerceSymbolicPath odir (extraCompilationArtifacts makeRelativePathEx "hie")) $ flagHie implInfo + , ghcOptStubDir = toFlag $ coerceSymbolicPath odir + , ghcOptOutputDir = toFlag $ coerceSymbolicPath odir + , ghcOptBytecodeDir = toFlag $ coerceSymbolicPath odir + } -componentGhcOptions - :: Verbosity +linkGhcOptions + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> SymbolicPath Pkg (Dir build) -> GhcOptions -componentGhcOptions verbosity lbi bi clbi odir = +linkGhcOptions verbosity lbi bi clbi = let implInfo = getImplInfo $ compiler lbi in mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal) + ghcOptVerbosity = toFlag (min verbosity Normal) + , ghcOptCcOptions = ccOptions bi + , ghcOptCxxOptions = cxxOptions bi + , ghcOptAsmOptions = asmOptions bi + , ghcOptLinkOptions = ldOptions bi + , ghcOptCppOptions = cppOptions bi + , ghcOptJSppOptions = jsppOptions bi + , ghcOptExtra = hcOptions GHC bi <> cmmOptions bi , ghcOptCabal = toFlag True , ghcOptThisUnitId = case clbi of LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> @@ -561,32 +575,32 @@ , ghcOptSplitSections = toFlag (splitSections lbi) , ghcOptSplitObjs = toFlag (splitObjs lbi) , ghcOptSourcePathClear = toFlag True - , ghcOptSourcePath = - toNubListR $ - (hsSourceDirs bi) - ++ [coerceSymbolicPath odir] - ++ [autogenComponentModulesDir lbi clbi] - ++ [autogenPackageModulesDir lbi] - , ghcOptCppIncludePath = includePaths lbi bi clbi odir - , ghcOptCppOptions = cppOptions bi - , ghcOptJSppOptions = jsppOptions bi , ghcOptCppIncludes = - toNubListR $ - [coerceSymbolicPath (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] + toNubListR [coerceSymbolicPath (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] , ghcOptFfiIncludes = toNubListR $ map getSymbolicPath $ includes bi - , ghcOptObjDir = toFlag $ coerceSymbolicPath odir - , ghcOptHiDir = toFlag $ coerceSymbolicPath odir - , ghcOptHieDir = bool NoFlag (toFlag $ coerceSymbolicPath odir (extraCompilationArtifacts makeRelativePathEx "hie")) $ flagHie implInfo - , ghcOptStubDir = toFlag $ coerceSymbolicPath odir - , ghcOptOutputDir = toFlag $ coerceSymbolicPath odir , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) , ghcOptDebugInfo = toFlag (withDebugInfo lbi) - , ghcOptExtra = hcOptions GHC bi , ghcOptExtraPath = toNubListR exe_paths , ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)) , -- Unsupported extensions have already been checked by configure ghcOptExtensions = toNubListR $ usedExtensions bi - , ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi) + , ghcOptExtensionMap = Map.fromList . compilerExtensions $ compiler lbi + , -- Use -pgmc to ensure that Cabal always passes cc-options, ld-options to GHC (#4435, #9801) + -- We can only do this on GHC >= 9.4, as we need https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6949 + -- Without that GHC MR, this change would cause GHC to never pass -no-pie when linking, + -- which can cause breakage depending on the C toolchain use. We would have to appropriately + -- pass -pgmc-supports-no-pie as appropriate to avoid this regression. + ghcOptCcProgram = + ghcOptionsSince + (mkVersion [9, 4]) + (compiler lbi) + (maybeToFlag $ programPath <$> lookupProgram gccProgram (withPrograms lbi)) + , -- The assumption that the C++ compiler is part of the toolchain is only since ghc-9.4. + ghcOptGppProgram = + ghcOptionsSince + (mkVersion [9, 4]) + (compiler lbi) + (maybeToFlag $ programPath <$> lookupProgram gppProgram (withPrograms lbi)) } where exe_paths = @@ -601,35 +615,6 @@ toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation -componentCmmGhcOptions - :: Verbosity - -> LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> SymbolicPath Pkg (Dir Artifacts) - -> SymbolicPath Pkg File - -> GhcOptions -componentCmmGhcOptions verbosity lbi bi clbi odir filename = - mempty - { -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal) - , ghcOptMode = toFlag GhcModeCompile - , ghcOptInputFiles = toNubListR [filename] - , ghcOptCppIncludePath = includePaths lbi bi clbi odir - , ghcOptCppOptions = cppOptions bi - , ghcOptCppIncludes = - toNubListR $ - [autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName] - , ghcOptHideAllPackages = toFlag True - , ghcOptPackageDBs = withPackageDB lbi - , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi - , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) - , ghcOptDebugInfo = toFlag (withDebugInfo lbi) - , ghcOptExtra = hcOptions GHC bi <> cmmOptions bi - , ghcOptObjDir = toFlag odir - } - -- | Strip out flags that are not supported in ghci filterGhciFlags :: [String] -> [String] filterGhciFlags = filter supported @@ -673,7 +658,7 @@ [ pref makeRelativePathEx (ModuleName.toFilePath x ++ splitSuffix) | x <- allLibModules lib clbi ] - objss <- traverse (getDirectoryContents . i) dirs + objss <- traverse (listDirectory . i) dirs let objs = [ dir makeRelativePathEx obj | (objs', dir) <- zip objss dirs 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 @@ -24,7 +24,6 @@ , hcPkgInfo , registerPackage , componentGhcOptions - , Internal.componentCcGhcOptions , getLibDir , isDynamic , getGlobalPackageDB @@ -62,6 +61,8 @@ import Distribution.Simple.Compiler import Distribution.Simple.Errors import Distribution.Simple.Flag +import Distribution.Simple.GHC.Build.Link (hasThreaded) +import Distribution.Simple.GHC.Build.Utils (isCxx, isHaskell) import Distribution.Simple.GHC.EnvironmentParser import Distribution.Simple.GHC.ImplInfo import qualified Distribution.Simple.GHC.Internal as Internal @@ -82,7 +83,7 @@ import Distribution.Types.ParStrat import Distribution.Utils.NubList import Distribution.Utils.Path -import Distribution.Verbosity (Verbosity) +import Distribution.Verbosity (Verbosity (..), VerbosityLevel, verbosityLevel) import Distribution.Version import Control.Arrow ((***)) @@ -95,7 +96,6 @@ , createDirectoryIfMissing , doesFileExist , getAppUserDataDirectory - , removeFile , renameFile ) import System.FilePath @@ -152,8 +152,8 @@ let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion - languages <- Internal.getLanguages verbosity implInfo ghcjsProg - extensions <- Internal.getExtensions verbosity implInfo ghcjsProg + languages <- Internal.getLanguages implInfo + extensions <- Internal.getExtensions verbosity ghcjsProg ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg let ghcInfoMap = Map.fromList ghcjsInfo @@ -168,6 +168,7 @@ , compilerLanguages = languages , compilerExtensions = extensions , compilerProperties = ghcInfoMap + , compilerWiredInUnitIds = Nothing } compPlatform = Internal.targetPlatform ghcjsInfo return (comp, compPlatform, progdb1) @@ -240,8 +241,7 @@ progdb3 = addKnownProgram haddockProgram' $ addKnownProgram hsc2hsProgram' $ - addKnownProgram hpcProgram' $ - {- addKnownProgram runghcProgram' -} progdb2 + addKnownProgram hpcProgram' {- addKnownProgram runghcProgram' -} progdb2 return progdb3 @@ -385,7 +385,7 @@ [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) | (_, pkgs) <- pkgss ] - return $! (mconcat indices) + return $! mconcat indices where ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb @@ -537,7 +537,7 @@ whenStaticLib forceStatic = when (forceStatic || withStaticLib lbi) -- whenGHCiLib = when (withGHCiLib lbi) - forRepl = maybe False (const True) mReplFlags + forRepl = isJust mReplFlags -- ifReplLib = when forRepl comp = compiler lbi implInfo = getImplInfo comp @@ -576,8 +576,8 @@ -- modules? let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) jsSrcs = jsSources libBi - cObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cLikeFiles - baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir + cObjs = map (`replaceExtensionSymbolicPath` objExtension) cLikeFiles + baseOpts = componentGhcOptions (verbosityLevel verbosity) lbi libBi clbi libTargetDir linkJsLibOpts = mempty { ghcOptExtra = @@ -740,7 +740,7 @@ info verbosity "Linking..." let cSharedObjs = map - ((`replaceExtensionSymbolicPath` ("dyn_" ++ objExtension))) + (`replaceExtensionSymbolicPath` ("dyn_" ++ objExtension)) (cSources libBi ++ cxxSources libBi) compiler_id = compilerId (compiler lbi) sharedLibFilePath = libTargetDir makeRelativePathEx (mkSharedLibName (hostPlatform lbi) compiler_id uid) @@ -749,23 +749,6 @@ let stubObjs = [] stubSharedObjs = [] - {- - stubObjs <- catMaybes <$> sequenceA - [ findFileWithExtension [objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubProfObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubSharedObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - -} hObjs <- Internal.getHaskellObjects implInfo @@ -809,15 +792,7 @@ , ghcOptInputFiles = toNubListR dynamicObjectFiles , ghcOptOutputFile = toFlag sharedLibFilePath , ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi - , -- For dynamic libs, Mac OS/X needs to know the install location - -- at build time. This only applies to GHC < 7.8 - see the - -- discussion in #1660. - {- - ghcOptDylibName = if hostOS == OSX - && ghcVersion < mkVersion [7,8] - then toFlag sharedLibInstallPath - else mempty, -} - ghcOptHideAllPackages = toFlag True + , ghcOptHideAllPackages = toFlag True , ghcOptNoAutoLinkPackages = toFlag True , ghcOptPackageDBs = withPackageDB lbi , ghcOptThisUnitId = case clbi of @@ -1242,13 +1217,6 @@ , inputSourceModules = foreignLibModules flib } - isCxx :: FilePath -> Bool - isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] - --- | FilePath has a Haskell extension: .hs or .lhs -isHaskell :: FilePath -> Bool -isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] - -- | Generic build function. See comment for 'GBuildMode'. gbuild :: Verbosity @@ -1305,8 +1273,8 @@ inputModules = inputSourceModules buildSources isGhcDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp - cObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cSrcs - cxxObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cxxSrcs + cObjs = map (`replaceExtensionSymbolicPath` objExtension) cSrcs + cxxObjs = map (`replaceExtensionSymbolicPath` objExtension) cxxSrcs needDynamic = gbuildNeedDynamic lbi bm needProfiling = withProfExe lbi @@ -1318,7 +1286,7 @@ TestComponentLocalBuildInfo{} -> True BenchComponentLocalBuildInfo{} -> True baseOpts = - (componentGhcOptions verbosity lbi bnfo clbi tmpDir) + componentGhcOptions (verbosityLevel verbosity) lbi bnfo clbi tmpDir `mappend` mempty { ghcOptMode = toFlag GhcModeMake , ghcOptInputFiles = @@ -1474,13 +1442,7 @@ sequence_ [ do let baseCxxOpts = - Internal.componentCxxGhcOptions - verbosity - lbi - bnfo - clbi - tmpDir - filename + Internal.splitCandCxxOptions Internal.CxxProgram (verbosityLevel verbosity) lbi bnfo clbi odir filename vanillaCxxOpts = if isGhcDynamic then -- Dynamic GHC requires C++ sources to be built @@ -1520,13 +1482,7 @@ sequence_ [ do let baseCcOpts = - Internal.componentCcGhcOptions - verbosity - lbi - bnfo - clbi - tmpDir - filename + Internal.splitCandCxxOptions Internal.CcProgram (verbosityLevel verbosity) lbi bnfo clbi tmpDir filename vanillaCcOpts = if isGhcDynamic then -- Dynamic GHC requires C sources to be built @@ -1575,10 +1531,6 @@ -- Work around old GHCs not relinking in this -- situation, see #3294 let target = targetDir makeRelativePathEx targetName - when (compilerVersion comp < mkVersion [7, 7]) $ do - let targetPath = i target - e <- doesFileExist targetPath - when e (removeFile targetPath) runGhcProg linkOpts{ghcOptOutputFile = toFlag target} GBuildFLib flib -> do let rtsInfo = extractRtsInfo lbi @@ -1747,7 +1699,7 @@ supportRPaths OSX = True supportRPaths FreeBSD = case compid of - CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True + CompilerId GHC _ -> True _ -> False supportRPaths OpenBSD = False supportRPaths NetBSD = False @@ -1776,7 +1728,7 @@ popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) popThreadedFlag bi = ( bi{options = filterHcOptions (/= "-threaded") (options bi)} - , hasThreaded (options bi) + , hasThreaded bi ) where filterHcOptions @@ -1786,9 +1738,6 @@ filterHcOptions p (PerCompilerFlavor ghc ghcjs) = PerCompilerFlavor (filter p ghc) ghcjs - hasThreaded :: PerCompilerFlavor [String] -> Bool - hasThreaded (PerCompilerFlavor ghc _) = elem "-threaded" ghc - -- | Extracts a String representing a hash of the ABI of a built -- library. It can fail if the library has not yet been built. libAbiHash @@ -1805,7 +1754,7 @@ platform = hostPlatform lbi mbWorkDir = mbWorkDirLBI lbi vanillaArgs = - (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + componentGhcOptions (verbosityLevel verbosity) lbi libBi clbi (componentBuildDir lbi clbi) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash , ghcOptInputModules = toNubListR $ exposedModules lib @@ -1845,7 +1794,7 @@ return (takeWhile (not . isSpace) hash) componentGhcOptions - :: Verbosity + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -1930,12 +1879,14 @@ -> FilePath -- ^ install location for dynamic libraries -> FilePath + -- ^ install location for bytecode libraries + -> FilePath -- ^ Build location -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO () -installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do +installLib verbosity lbi targetDir dynlibTargetDir _bytecodeTargetDir _builtDir _pkg lib clbi = do whenVanilla $ copyModuleFiles $ Suffix "js_hi" whenProf $ copyModuleFiles $ Suffix "js_p_hi" whenShared $ copyModuleFiles $ Suffix "js_dyn_hi" @@ -1948,7 +1899,7 @@ whenVanilla $ do sequence_ [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f)) - | l <- getHSLibraryName (componentUnitId clbi) : (extraBundledLibs (libBuildInfo lib)) + | l <- getHSLibraryName (componentUnitId clbi) : extraBundledLibs (libBuildInfo lib) , f <- "" : extraLibFlavours (libBuildInfo lib) ] -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName) @@ -2041,23 +1992,9 @@ -- ----------------------------------------------------------------------------- -- Registering -hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo +hcPkgInfo :: ProgramDb -> HcPkg.ConfiguredProgram hcPkgInfo progdb = - HcPkg.HcPkgInfo - { HcPkg.hcPkgProgram = ghcjsPkgProg - , HcPkg.noPkgDbStack = False - , HcPkg.noVerboseFlag = False - , HcPkg.flagPackageConf = False - , HcPkg.supportsDirDbs = True - , HcPkg.requiresDirDbs = ver >= v7_10 - , HcPkg.nativeMultiInstance = ver >= v7_10 - , HcPkg.recacheMultiInstance = True - , HcPkg.suppressFilesCheck = True - } - where - v7_10 = mkVersion [7, 10] - ghcjsPkgProg = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb - ver = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg + fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb registerPackage :: Verbosity 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 @@ -59,6 +59,8 @@ import Distribution.Utils.Path import Distribution.Verbosity ( Verbosity + , defaultVerbosityHandles + , mkVerbosity , silent ) @@ -88,7 +90,7 @@ GlobMatchesDirectory a -> Just a GlobMissingDirectory{} -> Nothing ) - <$> runDirFileGlob silent Nothing root glob + <$> runDirFileGlob (mkVerbosity defaultVerbosityHandles silent) Nothing root glob -- | Match a globbing pattern against a file path component matchGlobPieces :: GlobPieces -> String -> Bool @@ -387,7 +389,7 @@ Nothing -> if matchGlobPieces glob str then Just (GlobMatch ()) else Nothing go (GlobFile glob) dir = do - entries <- getDirectoryContents (root dir) + entries <- listDirectory (root dir) catMaybes <$> mapM ( \s -> do @@ -418,7 +420,7 @@ ) entries go (GlobDir glob globPath) dir = do - entries <- getDirectoryContents (root dir) + entries <- listDirectory (root dir) subdirs <- filterM ( \subdir -> @@ -438,10 +440,7 @@ then pure [GlobMatchesDirectory filepath] else do exist <- doesFileExist (root filepath) - pure $ - if exist - then [GlobMatch filepath] - else [] + pure [GlobMatch filepath | exist] Right variablePattern -> do debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'." directoryExists <- doesDirectoryExist (root joinedPrefix) 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 @@ -31,6 +31,9 @@ GlobDir !GlobPieces !Glob | -- | @**/@, where @**@ denotes recursively traversing -- all directories and matching filenames on . + -- + -- Note that the @@ portion can only match on filenames, not paths, + -- so for example @**/foo/*.txt@ is not supported. GlobDirRecursive !GlobPieces | -- | A file glob. GlobFile !GlobPieces @@ -74,22 +77,26 @@ instance Parsec Glob where parsec = parsecPath where - parsecPath :: CabalParsing m => m Glob - parsecPath = do - glob <- parsecGlob - dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob) - -- We could support parsing recursive directory search syntax - -- @**@ here too, rather than just in 'parseFileGlob' - dirSep :: CabalParsing m => m () dirSep = - () <$ P.char '/' + void (P.char '/') <|> P.try ( do _ <- P.char '\\' -- check this isn't an escape code P.notFollowedBy (P.satisfy isGlobEscapedChar) ) + + parsecPath :: CabalParsing m => m Glob + parsecPath = + P.choice + [ do + P.try (P.string "**" *> dirSep) + GlobDirRecursive <$> parsecGlob + , do + glob <- parsecGlob + dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob) + ] parsecGlob :: CabalParsing m => m GlobPieces parsecGlob = some parsecPiece 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 @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -40,9 +41,9 @@ -- local +import Data.Semigroup (All (..), Any (..)) import Distribution.Backpack (OpenModule) import Distribution.Backpack.DescribeUnitId -import Distribution.Compat.Semigroup (All (..), Any (..)) import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import qualified Distribution.ModuleName as ModuleName @@ -55,6 +56,9 @@ import Distribution.Simple.BuildTarget import Distribution.Simple.Compiler import Distribution.Simple.Errors +import Distribution.Simple.FileMonitor.Types + ( MonitorFilePath + ) import Distribution.Simple.Flag import Distribution.Simple.Glob (matchDirFileGlob) import Distribution.Simple.InstallDirs @@ -67,12 +71,9 @@ import Distribution.Simple.Program.ResponseFile import Distribution.Simple.Register import Distribution.Simple.Setup -import Distribution.Simple.SetupHooks.Internal - ( BuildHooks (..) - , noBuildHooks - ) import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks -import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks + ( PreBuildComponentInputs (..) + ) import Distribution.Simple.Utils import Distribution.System import Distribution.Types.ComponentLocalBuildInfo @@ -87,9 +88,8 @@ import Distribution.Verbosity import Distribution.Version -import Control.Monad import Data.Bool (bool) -import Data.Either (rights) +import Data.Either (lefts, rights) import System.Directory (doesDirectoryExist, doesFileExist) import System.FilePath (isAbsolute, normalise) import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) @@ -227,17 +227,28 @@ -> [PPSuffixHandler] -> HaddockFlags -> IO () -haddock = haddock_setupHooks noBuildHooks +haddock pkg lbi suffixHandlers flags = + void $ + haddock_setupHooks + (const $ return []) + defaultVerbosityHandles + pkg + lbi + suffixHandlers + flags haddock_setupHooks - :: BuildHooks + :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath]) + -- ^ pre-build hook + -> VerbosityHandles -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags - -> IO () + -> IO [MonitorFilePath] haddock_setupHooks _ + verbHandles pkg_descr _ _ @@ -246,18 +257,22 @@ && not (fromFlag $ haddockExecutables haddockFlags) && not (fromFlag $ haddockTestSuites haddockFlags) && not (fromFlag $ haddockBenchmarks haddockFlags) - && not (fromFlag $ haddockForeignLibs haddockFlags) = - warn (fromFlag $ setupVerbosity $ haddockCommonFlags haddockFlags) $ + && not (fromFlag $ haddockForeignLibs haddockFlags) = do + warn verb $ "No documentation was generated as this package does not contain " ++ "a library. Perhaps you want to use the --executables, --tests," ++ " --benchmarks or --foreign-libraries flags." + return [] + where + verb = mkVerbosity verbHandles $ fromFlag $ haddockVerbosity haddockFlags haddock_setupHooks - (BuildHooks{preBuildComponentRules = mbPbcRules}) + preBuildHook + verbHandles pkg_descr lbi suffixes flags' = do - let verbosity = fromFlag $ haddockVerbosity flags + let verbosity = mkVerbosity verbHandles (fromFlag $ haddockVerbosity flags) mbWorkDir = flagToMaybe $ haddockWorkingDir flags comp = compiler lbi platform = hostPlatform lbi @@ -307,17 +322,19 @@ -- support '--hyperlinked-sources'. let using_hscolour = flag haddockLinkedSource && version < mkVersion [2, 17] when using_hscolour $ - hscolour' - noBuildHooks - -- NB: we are not passing the user BuildHooks here, - -- because we are already running the pre/post build hooks - -- for Haddock. - (warn verbosity) - haddockTarget - pkg_descr - lbi - suffixes - (defaultHscolourFlags `mappend` haddockToHscolour flags) + void $ + hscolour' + (const $ return []) + -- NB: we are not passing the user BuildHooks here, + -- because we are already running the pre/post build hooks + -- for Haddock. + verbHandles + (warn verbosity) + haddockTarget + pkg_descr + lbi + suffixes + (defaultHscolourFlags `mappend` haddockToHscolour flags) targets <- readTargetInfos verbosity pkg_descr lbi (haddockTargets flags) @@ -330,7 +347,7 @@ internalPackageDB <- createInternalPackageDB verbosity lbi (flag $ setupDistPref . haddockCommonFlags) - (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do + (mons, _mbIPI) <- (\f -> foldM f ([], installedPkgs lbi) targets') $ \(monsAcc, index) target -> do curDir <- absoluteWorkingDirLBI lbi let component = targetComponent target @@ -345,24 +362,14 @@ , installedPkgs = index } - runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () - runPreBuildHooks lbi2 tgt = - let inputs = - SetupHooks.PreBuildComponentInputs - { SetupHooks.buildingWhat = BuildHaddock flags - , SetupHooks.localBuildInfo = lbi2 - , SetupHooks.targetInfo = tgt - } - in for_ mbPbcRules $ \pbcRules -> do - (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules - SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + pbci = SetupHooks.PreBuildComponentInputs (BuildHaddock flags) lbi' target -- See Note [Hi Haddock Recompilation Avoidance] reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version $ \haddockArtifactsDirs -> do - preBuildComponent runPreBuildHooks verbosity lbi' target + mons <- preBuildComponent (preBuildHook pbci) verbosity lbi' target preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes let - doExe com = case (compToExe com) of + doExe com = case compToExe com of Just exe -> do exeArgs <- fromExecutable @@ -438,7 +445,7 @@ debug verbosity $ "Registering inplace:\n" - ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) + ++ InstalledPackageInfo.showInstalledPackageInfo ipi registerPackage verbosity @@ -529,7 +536,7 @@ benchArgs return index - return ipi + return (monsAcc ++ mons, ipi) for_ (extraDocFiles pkg_descr) $ \fpath -> do files <- matchDirFileGlob verbosity (specVersion pkg_descr) mbWorkDir fpath @@ -537,6 +544,8 @@ for_ files $ copyFileToCwd verbosity mbWorkDir (unDir targetDir) + return mons + -- | Execute 'Haddock' configured with 'HaddocksFlags'. It is used to build -- index and contents for documentation of multiple packages. createHaddockIndex @@ -550,7 +559,7 @@ createHaddockIndex verbosity programDb comp platform mbWorkDir flags = do let args = fromHaddockProjectFlags flags tmpFileOpts = - commonSetupTempFileOptions $ haddockProjectCommonFlags $ flags + commonSetupTempFileOptions $ haddockProjectCommonFlags flags (haddockProg, _version) <- getHaddockProg verbosity programDb comp args (Flag True) runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg False args @@ -591,7 +600,7 @@ , argBaseUrl = haddockBaseUrl flags , argResourcesDir = haddockResourcesDir flags , argVerbose = - maybe mempty (Any . (>= deafening)) + maybe mempty (Any . (>= Deafening) . vLevel) . flagToMaybe $ setupVerbosity commonFlags , argOutput = @@ -625,7 +634,7 @@ fromPackageDescription _haddockTarget pkg_descr = mempty { argInterfaceFile = Flag $ haddockPath pkg_descr - , argPackageName = Flag $ packageId $ pkg_descr + , argPackageName = Flag $ packageId pkg_descr , argOutputDir = Dir $ "doc" "html" , argPrologue = Flag $ @@ -643,7 +652,7 @@ | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr) componentGhcOptions - :: Verbosity + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -706,7 +715,7 @@ mkHaddockArgs verbosity (tmpObjDir, tmpHiDir, tmpStubDir) lbi clbi htmlTemplate inFiles bi = do let vanillaOpts' = - componentGhcOptions normal lbi bi clbi (buildDir lbi) + componentGhcOptions Normal lbi bi clbi (buildDir lbi) vanillaOpts = vanillaOpts' { -- See Note [Hi Haddock Recompilation Avoidance] @@ -1018,7 +1027,7 @@ -> IO HaddockArgs getInterfaces verbosity lbi clbi htmlTemplate = do (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate - traverse_ (warn (verboseUnmarkOutput verbosity)) warnings + traverse_ (warn (modifyVerbosityFlags verboseUnmarkOutput verbosity)) warnings return $ mempty { argInterfaces = packageFlags @@ -1064,12 +1073,12 @@ -> IO r reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version act | version >= mkVersion [2, 28, 0] = do - withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-objs" $ \tmpObjDir -> - withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-his" $ \tmpHiDir -> do + withTempDirectoryCwdEx tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-objs" $ \tmpObjDir -> + withTempDirectoryCwdEx tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-his" $ \tmpHiDir -> do -- Re-use ghc's interface and obj files, but first copy them to -- somewhere where it is safe if haddock overwrites them let - vanillaOpts = componentGhcOptions normal lbi bi clbi (buildDir lbi) + vanillaOpts = componentGhcOptions Normal lbi bi clbi (buildDir lbi) i = interpretSymbolicPath mbWorkDir copyDir getGhcDir tmpDir = do let ghcDir = i $ fromFlag $ getGhcDir vanillaOpts @@ -1084,7 +1093,7 @@ act (tmpObjDir, tmpHiDir, fromFlag $ ghcOptHiDir vanillaOpts) | otherwise = do - withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "tmp" $ + withTempDirectoryCwdEx tmpFileOpts mbWorkDir (distPrefLBI lbi) "tmp" $ \tmpFallback -> act (tmpFallback, tmpFallback, tmpFallback) -- ------------------------------------------------------------------------------ @@ -1236,9 +1245,7 @@ [ "--source-module=" ++ m , "--source-entity=" ++ e ] - ++ if isVersion 2 14 - then ["--source-entity-line=" ++ l] - else [] + ++ ["--source-entity-line=" ++ l | isVersion 2 14] ) . flagToMaybe . argLinkSource @@ -1250,7 +1257,7 @@ , bool [] ["--gen-index"] . fromFlagOrDefault False . argGenIndex $ args , maybe [] ((: []) . ("--base-url=" ++)) . flagToMaybe . argBaseUrl $ args , bool [verbosityFlag] [] . getAny . argVerbose $ args - , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") + , map (\case Hoogle -> "--hoogle"; Html -> "--html") . fromFlagOrDefault [] . argOutput $ args @@ -1260,11 +1267,10 @@ [] ( (: []) . ("--title=" ++) - . ( bool - id - (++ " (internal documentation)") - (getAny $ argIgnoreExports args) - ) + . bool + id + (++ " (internal documentation)") + (getAny $ argIgnoreExports args) ) . flagToMaybe . argTitle @@ -1275,10 +1281,10 @@ flagToMaybe (argGhcLibDir args) -- error if Nothing? , -- https://github.com/haskell/haddock/pull/547 [ "--reexport=" ++ prettyShow r - | r <- argReexports args - , isVersion 2 19 + | isVersion 2 19 + , r <- argReexports args ] - , argTargets $ args + , argTargets args , maybe [] ((: []) . (resourcesDirFlag ++)) . flagToMaybe . argResourcesDir $ args , -- Do not re-direct compilation output to a temporary directory (--no-tmp-comp-dir) -- We pass this option by default to haddock to avoid recompilation @@ -1312,13 +1318,7 @@ | otherwise -> "" ] - , if haddockSupportsVisibility - then - [ case visibility of - Visible -> "visible" - Hidden -> "hidden" - ] - else [] + , [case visibility of Visible -> "visible"; Hidden -> "hidden" | haddockSupportsVisibility] , [i] ] ) @@ -1369,7 +1369,7 @@ Just htmlPath -> do let hypSrcPath = htmlPath defaultHyperlinkedSourceDirectory hypSrcExists <- doesDirectoryExist hypSrcPath - return $ + return ( Just (fixFileUrl htmlPath) , if hypSrcExists then Just (fixFileUrl hypSrcPath) @@ -1386,7 +1386,7 @@ , pkgName pkgid `notElem` noHaddockWhitelist ] - let missing = [pkgid | Left pkgid <- interfaces] + let missing = lefts interfaces warning = "The following packages have no Haddock documentation " ++ "installed. No links will be generated to these packages: " @@ -1396,7 +1396,7 @@ return (flags, if null missing then Nothing else Just warning) where -- Don't warn about missing documentation for these packages. See #1231. - noHaddockWhitelist = map mkPackageName ["rts"] + noHaddockWhitelist = [mkPackageName "rts"] -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'. interfaceAndHtmlPath @@ -1475,20 +1475,32 @@ -> [PPSuffixHandler] -> HscolourFlags -> IO () -hscolour = hscolour_setupHooks noBuildHooks +hscolour pkg lbi pps flags = + void $ + hscolour_setupHooks + (const $ return []) + defaultVerbosityHandles + pkg + lbi + pps + flags hscolour_setupHooks - :: BuildHooks + :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath]) + -- ^ pre-build hook + -> VerbosityHandles -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags - -> IO () -hscolour_setupHooks setupHooks = - hscolour' setupHooks dieNoVerbosity ForDevelopment + -> IO [MonitorFilePath] +hscolour_setupHooks preBuildHook verbHandles = + hscolour' preBuildHook verbHandles dieNoVerbosity ForDevelopment hscolour' - :: BuildHooks + :: (SetupHooks.PreBuildComponentInputs -> IO [MonitorFilePath]) + -- ^ pre-build hook + -> VerbosityHandles -> (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. -> HaddockTarget @@ -1496,31 +1508,35 @@ -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags - -> IO () + -> IO [MonitorFilePath] hscolour' - (BuildHooks{preBuildComponentRules = mbPbcRules}) + preBuildHook + verbHandles onNoHsColour haddockTarget pkg_descr lbi suffixes flags = - either (\excep -> onNoHsColour $ exceptionMessage excep) (\(hscolourProg, _, _) -> go hscolourProg) + either noHsColourPath (\(hscolourProg, _, _) -> go hscolourProg) =<< lookupProgramVersion verbosity hscolourProgram (orLaterVersion (mkVersion [1, 8])) (withPrograms lbi) where + noHsColourPath excep = do + onNoHsColour $ exceptionMessage excep + return [] common = hscolourCommonFlags flags - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) distPref = fromFlag $ setupDistPref common mbWorkDir = mbWorkDirLBI lbi i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path u :: SymbolicPath Pkg to -> FilePath u = interpretSymbolicPathCWD - go :: ConfiguredProgram -> IO () + go :: ConfiguredProgram -> IO [MonitorFilePath] go hscolourProg = do warn verbosity $ "the 'cabal hscolour' command is deprecated in favour of 'cabal " @@ -1532,23 +1548,22 @@ i $ hscolourPref haddockTarget distPref pkg_descr - withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do - let tgt = TargetInfo clbi comp - runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () - runPreBuildHooks lbi2 target = - let inputs = - SetupHooks.PreBuildComponentInputs - { SetupHooks.buildingWhat = BuildHscolour flags - , SetupHooks.localBuildInfo = lbi2 - , SetupHooks.targetInfo = target - } - in for_ mbPbcRules $ \pbcRules -> do - (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules - SetupHooks.executeRules verbosity lbi2 tgt ruleFromId - preBuildComponent runPreBuildHooks verbosity lbi tgt + let targets = allTargetsInBuildOrder' pkg_descr lbi + + -- 'foldM' with arguments flipped for readability + forFoldM acc xs f = foldM f acc xs + + forFoldM [] targets $ \monsAcc target -> do + let + comp = targetComponent target + clbi = targetCLBI target + pbci = SetupHooks.PreBuildComponentInputs (BuildHscolour flags) lbi target + + mons <- preBuildComponent (preBuildHook pbci) verbosity lbi target preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + let - doExe com = case (compToExe com) of + doExe com = case compToExe com of Just exe -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr @@ -1557,6 +1572,8 @@ Nothing -> do warn verbosity "Unsupported component, skipping..." return () + + -- Execute the component-specific hscolour actions case comp of CLib lib -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr makeRelativePathEx "src" @@ -1572,6 +1589,8 @@ CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp + + return (monsAcc <> mons) stylesheet = flagToMaybe (hscolourCSS flags) 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 @@ -104,10 +104,11 @@ -> CopyFlags -- ^ flags sent to copy or install -> IO () -install = install_setupHooks SetupHooks.noInstallHooks +install = install_setupHooks SetupHooks.noInstallHooks defaultVerbosityHandles install_setupHooks :: InstallHooks + -> VerbosityHandles -> PackageDescription -- ^ information from the .cabal file -> LocalBuildInfo @@ -117,6 +118,7 @@ -> IO () install_setupHooks (InstallHooks{installComponentHook}) + verbHandles pkg_descr lbi flags = do @@ -141,7 +143,7 @@ where common = copyCommonFlags flags distPref = fromFlag $ setupDistPref common - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) copydest = fromFlag (copyDest flags) checkHasLibsOrExes = @@ -232,6 +234,7 @@ let InstallDirs { libdir = libPref , dynlibdir = dynlibPref + , bytecodelibdir = bytecodeLibPref , includedir = incPref } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest buildPref = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi @@ -245,9 +248,9 @@ installIncludeFiles verbosity (libBuildInfo lib) lbi buildPref incPref case compilerFlavor (compiler lbi) of - 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 + GHC -> GHC.installLib verbosity lbi libPref dynlibPref bytecodeLibPref buildPref pkg_descr lib clbi + GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref bytecodeLibPref buildPref pkg_descr lib clbi + UHC -> UHC.installLib verbosity lbi libPref dynlibPref bytecodeLibPref buildPref pkg_descr lib clbi _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do @@ -285,7 +288,7 @@ ++ binPref ) inPath <- isInSearchPath binPref - when (not inPath) $ + unless inPath $ warn verbosity ( "The directory " @@ -365,8 +368,10 @@ ] where baseDir lbi' = packageRoot $ configCommonFlags $ configFlags lbi' - findInc [] file = dieWithException verbosity $ CantFindIncludeFile file - findInc (dir : dirs) file = do - let path = dir file - exists <- doesFileExist path - if exists then return (file, path) else findInc dirs file + findInc fs f = go fs + where + go [] = dieWithException verbosity $ CantFindIncludeFile f fs + go (d : ds) = do + let path = d f + b <- doesFileExist path + if b then return (f, path) else go ds 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 @@ -1,7 +1,9 @@ +{-# LANGUAGE CApiFFI #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -44,6 +46,7 @@ , compilerTemplateEnv , packageTemplateEnv , abiTemplateEnv + , installDirsGrammar , installDirsTemplateEnv ) where @@ -51,9 +54,13 @@ import Prelude () import Distribution.Compat.Environment (lookupEnv) +import Distribution.Compat.Lens (Lens') import Distribution.Compiler +import Distribution.FieldGrammar import Distribution.Package +import Distribution.Parsec import Distribution.Pretty +import Distribution.Simple.Flag import Distribution.Simple.InstallDirs.Internal import Distribution.System @@ -87,6 +94,7 @@ , libdir :: dir , libsubdir :: dir , dynlibdir :: dir + , bytecodelibdir :: dir , flibdir :: dir -- ^ foreign libraries , libexecdir :: dir @@ -103,9 +111,10 @@ deriving (Eq, Read, Show, Functor, Generic) instance Binary dir => Binary (InstallDirs dir) +instance NFData dir => NFData (InstallDirs dir) instance Structured dir => Structured (InstallDirs dir) -instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where +instance Monoid dir => Monoid (InstallDirs dir) where mempty = gmempty mappend = (<>) @@ -124,6 +133,7 @@ , libdir = libdir a `combine` libdir b , libsubdir = libsubdir a `combine` libsubdir b , dynlibdir = dynlibdir a `combine` dynlibdir b + , bytecodelibdir = bytecodelibdir a `combine` bytecodelibdir b , flibdir = flibdir a `combine` flibdir b , libexecdir = libexecdir a `combine` libexecdir b , libexecsubdir = libexecsubdir a `combine` libexecsubdir b @@ -222,6 +232,7 @@ "$libdir" case comp of UHC -> "$pkgid" _other -> "$abi" + , bytecodelibdir = "$libdir" "$libsubdir" , libexecsubdir = "$abi" "$pkgid" , flibdir = "$libdir" , libexecdir = case buildOS of @@ -277,6 +288,8 @@ , libdir = subst libdir [prefixVar, bindirVar] , libsubdir = subst libsubdir [] , dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar] + , bytecodelibdir = + subst bytecodelibdir [prefixVar, bindirVar, libdirVar, libsubdirVar] , flibdir = subst flibdir [prefixVar, bindirVar, libdirVar] , libexecdir = subst libexecdir prefixBinLibVars , libexecsubdir = subst libexecsubdir [] @@ -391,6 +404,7 @@ deriving (Eq, Ord, Generic) instance Binary PathTemplate +instance NFData PathTemplate instance Structured PathTemplate type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] @@ -481,6 +495,7 @@ , (LibdirVar, libdir dirs) , (LibsubdirVar, libsubdir dirs) , (DynlibdirVar, dynlibdir dirs) + , (BytecodelibdirVar, bytecodelibdir dirs) , (DatadirVar, datadir dirs) , (DatasubdirVar, datasubdir dirs) , (DocdirVar, docdir dirs) @@ -506,6 +521,12 @@ , (template, "") <- reads path ] +instance Parsec PathTemplate where + parsec = parsecPathTemplate + +parsecPathTemplate :: CabalParsing m => m PathTemplate +parsecPathTemplate = toPathTemplate <$> parsecFilePath + -- --------------------------------------------------------------------------- -- Internal utilities @@ -536,14 +557,7 @@ -- csidl_PROGRAM_FILES_COMMON :: CInt -- csidl_PROGRAM_FILES_COMMON = 0x002b -{- FOURMOLU_DISABLE -} -#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) -#define CALLCONV ccall -#else -#define CALLCONV stdcall -#endif - -foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW" +foreign import capi unsafe "shlobj.h SHGetFolderPathW" c_SHGetFolderPath :: Ptr () -> CInt -> Ptr () @@ -551,4 +565,86 @@ -> CWString -> Prelude.IO CInt #endif -{- FOURMOLU_ENABLE -} + +-- --------------------------------------------------------------------------- +-- FieldGrammar + +installDirsGrammar :: ParsecFieldGrammar' (InstallDirs (Flag PathTemplate)) +installDirsGrammar = + InstallDirs + <$> optionalFieldDef "prefix" installDirsPrefixLens mempty + <*> optionalFieldDef "bindir" installDirsBindirLens mempty + <*> optionalFieldDef "libdir" installDirsLibdirLens mempty + <*> optionalFieldDef "libsubdir" installDirsLibsubdirLens mempty + <*> optionalFieldDef "dynlibdir" installDirsDynlibdirLens mempty + <*> optionalFieldDef "bytecodelibdir" installDirsBytecodelibdirLens mempty + <*> pure NoFlag -- flibdir + <*> optionalFieldDef "libexecdir" installDirsLibexecdirLens mempty + <*> optionalFieldDef "libexecsubdir" installDirsLibexecsubdirLens mempty + <*> pure NoFlag -- includedir + <*> optionalFieldDef "datadir" installDirsDatadirLens mempty + <*> optionalFieldDef "datasubdir" installDirsDatasubdirLens mempty + <*> optionalFieldDef "docdir" installDirsDocdirLens mempty + <*> pure NoFlag -- mandir + <*> optionalFieldDef "htmldir" installDirsHtmldirLens mempty + <*> optionalFieldDef "haddockdir" installDirsHaddockdirLens mempty + <*> optionalFieldDef "sysconfdir" installDirsSysconfdirLens mempty + +-- --------------------------------------------------------------------------- +-- Lenses + +installDirsPrefixLens :: Lens' (InstallDirs a) a +installDirsPrefixLens f c = fmap (\x -> c{prefix = x}) (f (prefix c)) +{-# INLINEABLE installDirsPrefixLens #-} + +installDirsBindirLens :: Lens' (InstallDirs a) a +installDirsBindirLens f c = fmap (\x -> c{bindir = x}) (f (bindir c)) +{-# INLINEABLE installDirsBindirLens #-} + +installDirsLibdirLens :: Lens' (InstallDirs a) a +installDirsLibdirLens f c = fmap (\x -> c{libdir = x}) (f (libdir c)) +{-# INLINEABLE installDirsLibdirLens #-} + +installDirsLibsubdirLens :: Lens' (InstallDirs a) a +installDirsLibsubdirLens f c = fmap (\x -> c{libsubdir = x}) (f (libsubdir c)) +{-# INLINEABLE installDirsLibsubdirLens #-} + +installDirsDynlibdirLens :: Lens' (InstallDirs a) a +installDirsDynlibdirLens f c = fmap (\x -> c{dynlibdir = x}) (f (dynlibdir c)) +{-# INLINEABLE installDirsDynlibdirLens #-} + +installDirsBytecodelibdirLens :: Lens' (InstallDirs a) a +installDirsBytecodelibdirLens f c = fmap (\x -> c{bytecodelibdir = x}) (f (bytecodelibdir c)) +{-# INLINEABLE installDirsBytecodelibdirLens #-} + +installDirsLibexecdirLens :: Lens' (InstallDirs a) a +installDirsLibexecdirLens f c = fmap (\x -> c{libexecdir = x}) (f (libexecdir c)) +{-# INLINEABLE installDirsLibexecdirLens #-} + +installDirsLibexecsubdirLens :: Lens' (InstallDirs a) a +installDirsLibexecsubdirLens f c = fmap (\x -> c{libexecsubdir = x}) (f (libexecsubdir c)) +{-# INLINEABLE installDirsLibexecsubdirLens #-} + +installDirsDatadirLens :: Lens' (InstallDirs a) a +installDirsDatadirLens f c = fmap (\x -> c{datadir = x}) (f (datadir c)) +{-# INLINEABLE installDirsDatadirLens #-} + +installDirsDatasubdirLens :: Lens' (InstallDirs a) a +installDirsDatasubdirLens f c = fmap (\x -> c{datasubdir = x}) (f (datasubdir c)) +{-# INLINEABLE installDirsDatasubdirLens #-} + +installDirsDocdirLens :: Lens' (InstallDirs a) a +installDirsDocdirLens f c = fmap (\x -> c{docdir = x}) (f (docdir c)) +{-# INLINEABLE installDirsDocdirLens #-} + +installDirsHtmldirLens :: Lens' (InstallDirs a) a +installDirsHtmldirLens f c = fmap (\x -> c{htmldir = x}) (f (htmldir c)) +{-# INLINEABLE installDirsHtmldirLens #-} + +installDirsHaddockdirLens :: Lens' (InstallDirs a) a +installDirsHaddockdirLens f c = fmap (\x -> c{haddockdir = x}) (f (haddockdir c)) +{-# INLINEABLE installDirsHaddockdirLens #-} + +installDirsSysconfdirLens :: Lens' (InstallDirs a) a +installDirsSysconfdirLens f c = fmap (\x -> c{sysconfdir = x}) (f (sysconfdir c)) +{-# INLINEABLE installDirsSysconfdirLens #-} diff --git a/src/Distribution/Simple/InstallDirs/Internal.hs b/src/Distribution/Simple/InstallDirs/Internal.hs --- a/src/Distribution/Simple/InstallDirs/Internal.hs +++ b/src/Distribution/Simple/InstallDirs/Internal.hs @@ -14,6 +14,7 @@ deriving (Eq, Ord, Generic) instance Binary PathComponent +instance NFData PathComponent instance Structured PathComponent data PathTemplateVariable @@ -27,6 +28,8 @@ LibsubdirVar | -- | The @$dynlibdir@ path variable DynlibdirVar + | -- | The @$bytecodelibdir@ path variable + BytecodelibdirVar | -- | The @$datadir@ path variable DatadirVar | -- | The @$datasubdir@ path variable @@ -67,6 +70,7 @@ deriving (Eq, Ord, Generic) instance Binary PathTemplateVariable +instance NFData PathTemplateVariable instance Structured PathTemplateVariable instance Show PathTemplateVariable where @@ -76,6 +80,7 @@ show LibdirVar = "libdir" show LibsubdirVar = "libsubdir" show DynlibdirVar = "dynlibdir" + show BytecodelibdirVar = "bytecodelibdir" show DatadirVar = "datadir" show DatasubdirVar = "datasubdir" show DocdirVar = "docdir" @@ -109,6 +114,7 @@ , ("libdir", LibdirVar) , ("libsubdir", LibsubdirVar) , ("dynlibdir", DynlibdirVar) + , ("bytecodelibdir", BytecodelibdirVar) , ("datadir", DatadirVar) , ("datasubdir", DatasubdirVar) , ("docdir", DocdirVar) 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 @@ -286,7 +286,7 @@ | (uid, _) <- componentPackageDeps clbi , -- Test that it's internal sub_target <- allTargetsInBuildOrder' pkgDescr lbi - , componentUnitId (targetCLBI (sub_target)) == uid + , componentUnitId (targetCLBI sub_target) == uid ] internalLibs = [ getLibDir (targetCLBI sub_target) @@ -320,7 +320,7 @@ -- because you never have any internal libraries in this case; -- they're all external. let external_ipkgs = filter is_external (allPackages installed) - is_external ipkg = not (installedUnitId ipkg `elem` internalDeps) + is_external ipkg = installedUnitId ipkg `notElem` internalDeps -- First look for dynamic libraries in `dynamic-library-dirs`, and use -- `library-dirs` as a fall back. getDynDir pkg = case Installed.libraryDynDirs pkg of @@ -473,7 +473,7 @@ (LocalBuildInfo{compiler = comp, hostPlatform = plat}) uid = fromPathTemplate - . (InstallDirs.substPathTemplate env) + . InstallDirs.substPathTemplate env where env = initialPathTemplateEnv diff --git a/src/Distribution/Simple/PackageDescription.hs b/src/Distribution/Simple/PackageDescription.hs --- a/src/Distribution/Simple/PackageDescription.hs +++ b/src/Distribution/Simple/PackageDescription.hs @@ -18,6 +18,8 @@ -- * Utility Parsing function , parseString + , readAndParseFile + , flattenDups ) where import Distribution.Compat.Prelude @@ -31,23 +33,23 @@ ( parseGenericPackageDescription , parseHookedBuildInfo ) -import Distribution.Parsec.Error (showPError) +import Distribution.Parsec.Error (showPErrorWithSource) +import Distribution.Parsec.Source import Distribution.Parsec.Warning ( PWarnType (PWTExperimental) , PWarning (..) - , showPWarning + , PWarningWithSource (..) + , showPWarningWithSource ) import Distribution.Simple.Errors import Distribution.Simple.Utils (dieWithException, equating, warn) import Distribution.Utils.Path -import Distribution.Verbosity (Verbosity, normal) -import GHC.Stack +import Distribution.Verbosity (Verbosity, VerbosityLevel (..), verbosityLevel) import System.Directory (doesFileExist) import Text.Printf (printf) readGenericPackageDescription - :: HasCallStack - => Verbosity + :: Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> SymbolicPath Pkg File -> IO GenericPackageDescription @@ -70,7 +72,7 @@ -- -- Argument order is chosen to encourage partial application. readAndParseFile - :: (BS.ByteString -> ParseResult a) + :: (BS.ByteString -> ParseResult CabalFileSource a) -- ^ File contents to final value parser -> Verbosity -- ^ Verbosity level @@ -90,7 +92,7 @@ parseString parser verbosity upath bs parseString - :: (BS.ByteString -> ParseResult a) + :: (BS.ByteString -> ParseResult CabalFileSource a) -- ^ File contents to final value parser -> Verbosity -- ^ Verbosity level @@ -99,38 +101,41 @@ -> BS.ByteString -> IO a parseString parser verbosity name bs = do - let (warnings, result) = runParseResult (parser bs) - traverse_ (warn verbosity . showPWarning name) (flattenDups verbosity warnings) + let (warnings, result) = runParseResult $ withSource (PCabalFile (name, bs)) (parser bs) + traverse_ (warn verbosity . showPWarningWithSource . fmap renderCabalFileSource) (flattenDups verbosity warnings) case result of Right x -> return x Left (_, errors) -> do - traverse_ (warn verbosity . showPError name) errors + traverse_ (warn verbosity . showPErrorWithSource . fmap renderCabalFileSource) errors dieWithException verbosity $ FailedParsing name -- | Collapse duplicate experimental feature warnings into single warning, with -- a count of further sites -flattenDups :: Verbosity -> [PWarning] -> [PWarning] +flattenDups :: Verbosity -> [PWarningWithSource src] -> [PWarningWithSource src] flattenDups verbosity ws - | verbosity <= normal = rest ++ experimentals + | verbosityLevel verbosity <= Normal = rest ++ experimentals | otherwise = ws -- show all instances where - (exps, rest) = partition (\(PWarning w _ _) -> w == PWTExperimental) ws + (exps, rest) = partition (\(PWarningWithSource _ (PWarning w _ _)) -> w == PWTExperimental) ws experimentals = concatMap flatCount - . groupBy (equating warningStr) - . sortBy (comparing warningStr) + . groupBy (equating (warningStr . pwarning)) + . sortBy (comparing (warningStr . pwarning)) $ exps warningStr (PWarning _ _ w) = w -- flatten if we have 3 or more examples - flatCount :: [PWarning] -> [PWarning] + flatCount :: [PWarningWithSource src] -> [PWarningWithSource src] flatCount w@[] = w flatCount w@[_] = w flatCount w@[_, _] = w - flatCount (PWarning t pos w : xs) = - [ PWarning - t - pos - (w <> printf " (and %d more occurrences)" (length xs)) + flatCount (PWarningWithSource source (PWarning t pos w) : xs) = + [ PWarningWithSource + source + ( PWarning + t + pos + (w <> printf " (and %d more occurrences)" (length xs)) + ) ] 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 @@ -184,7 +184,7 @@ all (\g -> length g == 1) (groupBy (equating installedUnitId) pinsts') - , pinst <- assert pinstsOk $ pinsts' + , pinst <- assert pinstsOk pinsts' , let pinstOk = packageName pinst == pname && packageVersion pinst == pver @@ -369,8 +369,8 @@ -- | Removes all packages satisfying this dependency from the index. -- deleteDependency :: Dependency -> PackageIndex -> PackageIndex -deleteDependency (Dependency name verstionRange) = - delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange) +deleteDependency (Dependency name versionRange) = + delete' name (\pkg -> packageVersion pkg `withinRange` versionRange) -} -- @@ -459,9 +459,7 @@ -- Do not lookup internal libraries case Map.lookup (packageName pkgid, LMainLibName) (packageIdIndex index) of Nothing -> [] - Just pvers -> case Map.lookup (packageVersion pkgid) pvers of - Nothing -> [] - Just pkgs -> pkgs -- in preference order + Just pvers -> fromMaybe [] (Map.lookup (packageVersion pkgid) pvers) -- in preference order -- | Convenient alias of 'lookupSourcePackageId', but assuming only -- one package per package ID. @@ -489,9 +487,7 @@ -> LibraryName -> [(Version, [a])] lookupInternalPackageName index name library = - case Map.lookup (name, library) (packageIdIndex index) of - Nothing -> [] - Just pvers -> Map.toList pvers + maybe [] Map.toList (Map.lookup (name, library) (packageIdIndex index)) -- | Does a lookup by source package name and a range of versions. -- @@ -667,7 +663,7 @@ :: InstalledPackageIndex -> [UnitId] -> Either - (InstalledPackageIndex) + InstalledPackageIndex [(IPI.InstalledPackageInfo, [UnitId])] dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of (completed, []) -> Left completed @@ -734,7 +730,7 @@ graph = Array.listArray bounds - [ [v | Just v <- map id_to_vertex (installedDepends pkg)] + [ mapMaybe id_to_vertex (installedDepends pkg) | pkg <- pkgs ] 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 @@ -257,7 +257,7 @@ (coerceSymbolicPath outputDir : hsSourceDirs bi) outputDir isSrcDist - (dropExtensionsSymbolicPath $ exePath) + (dropExtensionsSymbolicPath exePath) verbosity builtinSuffixes biHandlers @@ -345,7 +345,7 @@ createDirectoryIfMissingVerbose verbosity True destDir runPreProcessorWithHsBootHack pp - (psrcLoc, getSymbolicPath $ psrcRelFile) + (psrcLoc, getSymbolicPath psrcRelFile) (buildLoc, srcStem <.> "hs") where i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path @@ -367,8 +367,8 @@ -- Hence the use of 'getSymbolicPath' here. runPreProcessor pp - (getSymbolicPath $ inBaseDir, inRelativeFile) - (getSymbolicPath $ outBaseDir, outRelativeFile) + (getSymbolicPath inBaseDir, inRelativeFile) + (getSymbolicPath outBaseDir, outRelativeFile) verbosity -- Here we interact directly with the file system, so we must @@ -465,10 +465,7 @@ : inFile : "--noline" : "--strip" - : ( if cpphsVersion >= mkVersion [1, 6] - then ["--include=" ++ u (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] - else [] - ) + : ["--include=" ++ u (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName) | cpphsVersion >= mkVersion [1, 6]] ++ extraArgs } where @@ -518,101 +515,104 @@ -- directly, or via a response file. genPureArgs :: Version -> ConfiguredProgram -> String -> String -> [String] genPureArgs hsc2hsVersion gccProg inFile outFile = - -- Additional gcc options - [ "--cflag=" ++ opt - | opt <- - programDefaultArgs gccProg - ++ programOverrideArgs gccProg - ] - ++ [ "--lflag=" ++ opt - | opt <- - programDefaultArgs gccProg - ++ programOverrideArgs gccProg - ] - -- OSX frameworks: - ++ [ what ++ "=-F" ++ opt - | isOSX - , opt <- nub (concatMap Installed.frameworkDirs pkgs) - , what <- ["--cflag", "--lflag"] - ] - ++ [ "--lflag=" ++ arg - | isOSX - , opt <- map getSymbolicPath (PD.frameworks bi) ++ concatMap Installed.frameworks pkgs - , arg <- ["-framework", opt] - ] - -- Note that on ELF systems, wherever we use -L, we must also use -R - -- because presumably that -L dir is not on the normal path for the - -- system's dynamic linker. This is needed because hsc2hs works by - -- compiling a C program and then running it. - - ++ ["--cflag=" ++ opt | opt <- platformDefines lbi] - -- Options from the current package: - ++ ["--cflag=-I" ++ u dir | dir <- PD.includeDirs bi] - ++ [ "--cflag=-I" ++ u (buildDir lbi unsafeCoerceSymbolicPath relDir) - | relDir <- mapMaybe symbolicPathRelative_maybe $ PD.includeDirs bi - ] - ++ [ "--cflag=" ++ opt - | opt <- - PD.ccOptions bi - ++ PD.cppOptions bi - -- hsc2hs uses the C ABI - -- We assume that there are only C sources - -- and C++ functions are exported via a C - -- interface and wrapped in a C source file. - -- Therefore we do not supply C++ flags - -- because there will not be C++ sources. - -- - -- DO NOT add PD.cxxOptions unless this changes! - ] - ++ [ "--cflag=" ++ opt - | opt <- - [ "-I" ++ u (autogenComponentModulesDir lbi clbi) - , "-I" ++ u (autogenPackageModulesDir lbi) - , "-include" - , u $ autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName - ] - ] - ++ [ "--lflag=-L" ++ u opt - | opt <- - if withFullyStaticExe lbi - then PD.extraLibDirsStatic bi - else PD.extraLibDirs bi - ] - ++ [ "--lflag=-Wl,-R," ++ u opt - | isELF - , opt <- - if withFullyStaticExe lbi - then PD.extraLibDirsStatic bi - else PD.extraLibDirs bi - ] - ++ ["--lflag=-l" ++ opt | opt <- PD.extraLibs bi] - ++ ["--lflag=" ++ opt | opt <- PD.ldOptions bi] - -- Options from dependent packages - ++ [ "--cflag=" ++ opt - | pkg <- pkgs - , opt <- - ["-I" ++ opt | opt <- Installed.includeDirs pkg] - ++ Installed.ccOptions pkg - ] - ++ [ "--lflag=" ++ opt - | pkg <- pkgs - , opt <- - ["-L" ++ opt | opt <- Installed.libraryDirs pkg] - ++ [ "-Wl,-R," ++ opt | isELF, opt <- Installed.libraryDirs pkg - ] - ++ [ "-l" ++ opt - | opt <- - if withFullyStaticExe lbi - then Installed.extraLibrariesStatic pkg - else Installed.extraLibraries pkg - ] - ++ Installed.ldOptions pkg - ] + cflags + ++ ldflags ++ preccldFlags ++ hsc2hsOptions bi ++ postccldFlags ++ ["-o", outFile, inFile] where + ldflags = + map ("--lflag=" ++) $ + ordNub $ + concat + [ programDefaultArgs gccProg ++ programOverrideArgs gccProg + , osxFrameworkDirs + , [ arg + | isOSX + , opt <- map getSymbolicPath (PD.frameworks bi) ++ concatMap Installed.frameworks pkgs + , arg <- ["-framework", opt] + ] + , -- Note that on ELF systems, wherever we use -L, we must also use -R + -- because presumably that -L dir is not on the normal path for the + -- system's dynamic linker. This is needed because hsc2hs works by + -- compiling a C program and then running it. + + -- Options from the current package: + [ "-L" ++ u opt + | opt <- + if withFullyStaticExe lbi + then PD.extraLibDirsStatic bi + else PD.extraLibDirs bi + ] + , [ "-Wl,-R," ++ u opt + | isELF + , opt <- + if withFullyStaticExe lbi + then PD.extraLibDirsStatic bi + else PD.extraLibDirs bi + ] + , ["-l" ++ opt | opt <- PD.extraLibs bi] + , PD.ldOptions bi + , -- Options from dependent packages + [ opt + | pkg <- pkgs + , opt <- + ["-L" ++ opt | opt <- Installed.libraryDirs pkg] + ++ [ "-Wl,-R," ++ opt | isELF, opt <- Installed.libraryDirs pkg + ] + ++ [ "-l" ++ opt + | opt <- + if withFullyStaticExe lbi + then Installed.extraLibrariesStatic pkg + else Installed.extraLibraries pkg + ] + ++ Installed.ldOptions pkg + ] + ] + + cflags = + map ("--cflag=" ++) $ + ordNub $ + concat + [ programDefaultArgs gccProg ++ programOverrideArgs gccProg + , osxFrameworkDirs + , platformDefines lbi + , -- Options from the current package: + ["-I" ++ u dir | dir <- PD.includeDirs bi] + , [ "-I" ++ u (buildDir lbi unsafeCoerceSymbolicPath relDir) + | relDir <- mapMaybe symbolicPathRelative_maybe $ PD.includeDirs bi + ] + , -- hsc2hs uses the C ABI + -- We assume that there are only C sources + -- and C++ functions are exported via a C + -- interface and wrapped in a C source file. + -- Therefore we do not supply C++ flags + -- because there will not be C++ sources. + -- + -- DO NOT add PD.cxxOptions unless this changes! + PD.ccOptions bi ++ PD.cppOptions bi + , + [ "-I" ++ u (autogenComponentModulesDir lbi clbi) + , "-I" ++ u (autogenPackageModulesDir lbi) + , "-include" + , u $ autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName + ] + , -- Options from dependent packages + [ opt + | pkg <- pkgs + , opt <- + ["-I" ++ opt | opt <- Installed.includeDirs pkg] + ++ Installed.ccOptions pkg + ] + ] + + osxFrameworkDirs = + [ "-F" ++ opt + | isOSX + , opt <- ordNub (concatMap Installed.frameworkDirs pkgs) + ] + -- hsc2hs flag parsing was wrong -- (see -- https://github.com/haskell/hsc2hs/issues/35) -- so we need to put -- --cc/--ld *after* hsc2hsOptions, @@ -794,7 +794,7 @@ Android -> ["android"] Ghcjs -> ["ghcjs"] Wasi -> ["wasi"] - Hurd -> ["hurd"] + Hurd -> ["gnu"] Haiku -> ["haiku"] OtherOS _ -> [] archStr = case hostArch of 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 @@ -57,8 +57,8 @@ import Distribution.Utils.Path import Distribution.Verbosity ( Verbosity - , deafening - , verbose + , VerbosityLevel (..) + , verbosityLevel ) import System.Directory (doesFileExist, renameFile) @@ -90,7 +90,7 @@ i = interpretSymbolicPath mbWorkDir u :: SymbolicPath Pkg to -> FilePath u = interpretSymbolicPathCWD - withTempDirectoryCwd verbosity mbWorkDir targetDir "objs" $ \tmpDir -> do + withTempDirectoryCwd mbWorkDir targetDir "objs" $ \tmpDir -> do let tmpPath = tmpDir targetName -- The args to use with "ar" are actually rather subtle and system-dependent. @@ -142,7 +142,7 @@ invokeWithResponseFile :: FilePath -> ProgramInvocation invokeWithResponseFile atFile = - (ar $ simpleArgs ++ extraArgs ++ ['@' : atFile]) + ar $ simpleArgs ++ extraArgs ++ ['@' : atFile] if oldVersionManualOverride || responseArgumentsNotSupported then @@ -168,8 +168,8 @@ progDb = withPrograms lbi Platform hostArch hostOS = hostPlatform lbi verbosityOpts v - | v >= deafening = ["-v"] - | v >= verbose = [] + | verbosityLevel v >= Deafening = ["-v"] + | verbosityLevel v >= Verbose = [] | otherwise = ["-c"] -- Do not warn if library had to be created. -- | @ar@ by default includes various metadata for each object file in their 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 @@ -61,6 +61,9 @@ -- ------------------------------------------------------------ +-- NOTE: if you modify the list of builtin programs below, also update documentation in +-- the Cabal manual: option `--with-PROG` described in doc/setup-commands.rst + -- | The default list of programs. -- These programs are typically used internally to Cabal. builtinPrograms :: [Program] @@ -102,20 +105,7 @@ } 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]) + let ignorePackageEnv prog = prog{programDefaultArgs = "-package-env=-" : programDefaultArgs prog} canIgnorePackageEnv = orLaterVersion $ mkVersion [8, 4, 4] @@ -125,14 +115,9 @@ maybe ghcProg ( \v -> - -- By default, ignore GHC_ENVIRONMENT variable of any package environmnet + -- By default, ignore GHC_ENVIRONMENT variable of any package environment -- 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 + applyWhen (withinRange v canIgnorePackageEnv) ignorePackageEnv ghcProg ) (programVersion ghcProg) @@ -244,7 +229,10 @@ stripProgram = (simpleProgram "strip") { programFindVersion = \verbosity -> - findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity) + findProgramVersion + "--version" + stripExtractVersion + (modifyVerbosityFlags lessVerbose verbosity) } hsc2hsProgram :: Program @@ -364,7 +352,7 @@ -- Some versions of tar don't support '--help'. `catchIO` (\_ -> return "") let k = "Supports --format" - v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO" + v = if "--format" `isInfixOf` tarHelpOutput then "YES" else "NO" m = Map.insert k v (programProperties tarProg) return $ tarProg{programProperties = m} } diff --git a/src/Distribution/Simple/Program/Db.hs b/src/Distribution/Simple/Program/Db.hs --- a/src/Distribution/Simple/Program/Db.hs +++ b/src/Distribution/Simple/Program/Db.hs @@ -33,6 +33,7 @@ -- ** Query and manipulate the program db , addKnownProgram , addKnownPrograms + , clearUnconfiguredPrograms , prependProgramSearchPath , prependProgramSearchPathNoLogging , lookupKnownProgram @@ -67,8 +68,11 @@ , ConfiguredProgs , updateUnconfiguredProgs , updateConfiguredProgs + , updatePathProgDb ) where +import Control.Monad ((<=<)) +import Data.Functor ((<&>)) import Distribution.Compat.Prelude import Prelude () @@ -200,6 +204,14 @@ addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb addKnownPrograms progs progdb = foldl' (flip addKnownProgram) progdb progs +-- | Drop all unconfigured programs from a 'ProgramDb', retaining only +-- configured programs, the search path, and environment overrides. +-- +-- This mirrors round-tripping via the @'Binary' 'ProgramDb'@ instance, which +-- drops unconfigured programs. +clearUnconfiguredPrograms :: ProgramDb -> ProgramDb +clearUnconfiguredPrograms progdb = progdb{unconfiguredProgs = Map.empty} + lookupKnownProgram :: String -> ProgramDb -> Maybe Program lookupKnownProgram name = fmap (\(p, _, _) -> p) . Map.lookup name . unconfiguredProgs @@ -257,8 +269,14 @@ -> ProgramDb -> ProgramDb prependProgramSearchPathNoLogging extraPaths extraEnv db = - let db' = modifyProgramSearchPath (nub . (map ProgramSearchPathDir extraPaths ++)) db - db'' = db'{progOverrideEnv = extraEnv ++ progOverrideEnv db'} + let db' = + if null extraPaths + then db -- skip work if nothing to do + else modifyProgramSearchPath (nub . (map ProgramSearchPathDir extraPaths ++)) db + db'' = + if null extraEnv + then db' -- skip work if nothing to do + else db'{progOverrideEnv = extraEnv ++ progOverrideEnv db'} in db'' -- | User-specify this path. Basically override any path information @@ -328,7 +346,7 @@ -- | Get the path that has been previously specified for a program, if any. userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath userSpecifiedPath prog = - join . fmap (\(_, p, _) -> p) . Map.lookup (programName prog) . unconfiguredProgs + (\(_, p, _) -> p) <=< (Map.lookup (programName prog) . unconfiguredProgs) -- | Get any extra args that have been previously specified for a program. userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] @@ -406,7 +424,7 @@ maybeLocation <- case userSpecifiedPath prog progdb of Nothing -> programFindLocation prog verbosity (progSearchPath progdb) - >>= return . fmap (swap . fmap FoundOnSystem . swap) + <&> fmap (swap . fmap FoundOnSystem . swap) Just path -> do absolute <- doesExecutableExist path if absolute @@ -483,6 +501,45 @@ where progs = catMaybes [lookupKnownProgram name progdb | (name, _) <- paths] +-- | Update the PATH and environment variables of already-configured programs +-- in the program database. +-- +-- This is a somewhat sketchy operation, but it handles the following situation: +-- +-- - we add a build-tool-depends executable to the program database, with its +-- associated data directory environment variables; +-- - we want invocations of GHC (an already configured program) to be able to +-- find this program (e.g. if the build-tool-depends executable is used +-- in a Template Haskell splice). +-- +-- In this case, we want to add the build tool to the PATH of GHC, even though +-- GHC is already configured which in theory means we shouldn't touch it any +-- more. +updatePathProgDb :: Verbosity -> ProgramDb -> IO ProgramDb +updatePathProgDb verbosity progdb = + updatePathProgs verbosity progs progdb + where + progs = Map.elems $ configuredProgs progdb + +-- | See 'updatePathProgDb' +updatePathProgs :: Verbosity -> [ConfiguredProgram] -> ProgramDb -> IO ProgramDb +updatePathProgs verbosity progs progdb = + foldM (flip (updatePathProg verbosity)) progdb progs + +-- | See 'updatePathProgDb'. +updatePathProg :: Verbosity -> ConfiguredProgram -> ProgramDb -> IO ProgramDb +updatePathProg _verbosity prog progdb = do + newPath <- programSearchPathAsPATHVar (progSearchPath progdb) + let envOverrides = progOverrideEnv progdb + progOverrides = programOverrideEnv prog + prog' = + prog + { programOverrideEnv = + [("PATH", Just newPath)] + ++ filter ((/= "PATH") . fst) (envOverrides ++ progOverrides) + } + return $ updateProgram prog' progdb + -- | Check that a program is configured and available to be run. -- -- It raises an exception if the program could not be configured, otherwise @@ -561,6 +618,5 @@ -> ProgramDb -> IO (ConfiguredProgram, Version, ProgramDb) requireProgramVersion verbosity prog range programDb = - join $ - either (dieWithException verbosity) return - `fmap` lookupProgramVersion verbosity prog range programDb + either (dieWithException verbosity) return + =<< lookupProgramVersion verbosity prog range programDb 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 @@ -46,7 +46,7 @@ import Distribution.System import Distribution.Verbosity -import qualified System.Directory as Directory +import System.Directory ( findExecutable ) import System.FilePath as FilePath @@ -204,29 +204,6 @@ return path #else FilePath.getSearchPath -#endif - -#ifdef MIN_VERSION_directory -#if MIN_VERSION_directory(1,2,1) -#define HAVE_directory_121 -#endif -#endif - -findExecutable :: FilePath -> IO (Maybe FilePath) -#ifdef HAVE_directory_121 -findExecutable = Directory.findExecutable -#else -findExecutable prog = do - -- With directory < 1.2.1 'findExecutable' doesn't check that the path - -- really refers to an executable. - mExe <- Directory.findExecutable prog - case mExe of - Just exe -> do - exeExists <- doesExecutableExist exe - if exeExists - then return mExe - else return Nothing - _ -> return mExe #endif -- | Make a simple named program. 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 @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -11,6 +12,7 @@ , GhcMode (..) , GhcOptimisation (..) , GhcDynLinkMode (..) + , GhcObjectMode (..) , GhcProfAuto (..) , ghcInvocation , renderGhcOptions @@ -24,8 +26,8 @@ import Distribution.Compat.Prelude import Prelude () +import Data.Semigroup (First (..), Last (..)) import Distribution.Backpack -import Distribution.Compat.Semigroup (First' (..), Last' (..), Option' (..)) import Distribution.ModuleName import Distribution.PackageDescription import Distribution.Pretty @@ -146,15 +148,18 @@ flagArgumentFilter :: [String] -> [String] -> [String] flagArgumentFilter flags = go where - makeFilter :: String -> String -> Option' (First' ([String] -> [String])) - makeFilter flag arg = Option' $ First' . filterRest <$> stripPrefix flag arg + makeFilter :: String -> String -> Maybe (First ([String] -> [String])) + makeFilter flag arg = First . filterRest <$> stripPrefix flag arg where + -- Drop the next argument, whether it comes after a `=` or + -- is stand-alone. + filterRest :: String -> [String] -> [String] filterRest leftOver = case dropEq leftOver of [] -> drop 1 _ -> id checkFilter :: String -> Maybe ([String] -> [String]) - checkFilter = fmap getFirst' . getOption' . foldMap makeFilter flags + checkFilter = fmap getFirst . foldMap makeFilter flags go :: [String] -> [String] go [] = [] @@ -162,15 +167,24 @@ Just f -> go (f args) Nothing -> arg : go args + -- Options that take parameters and do not modify the generated artifacts + -- are filtered out. argumentFilters :: [String] -> [String] argumentFilters = flagArgumentFilter - ["-ghci-script", "-H", "-interactive-print"] + [ "-ghci-script" + , "-H" + , "-interactive-print" + , "-fghci-browser-assets-dir" + ] -- \| Remove RTS arguments from a list. filterRtsArgs :: [String] -> [String] filterRtsArgs = snd . splitRTSArgs + -- Simple options (i.e. that do not take parameters, or just + -- take int parameters) which do *not* change generated artifacts + -- are filtered out. simpleFilters :: String -> Bool simpleFilters = not @@ -181,7 +195,8 @@ , Any . isPrefixOf "-dsuppress-" , Any . isPrefixOf "-dno-suppress-" , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"] - , flagIn . invertibleFlagSet "-f" . mconcat $ + , -- -f-something -f-no-something options. + flagIn . invertibleFlagSet "-f" . mconcat $ [ [ "reverse-errors" , "warn-unused-binds" @@ -364,12 +379,12 @@ safeToFilterHoles :: Bool safeToFilterHoles = getAll . checkGhcFlags $ - All . fromMaybe True . fmap getLast' . getOption' . foldMap notDeferred + All . maybe True getLast . foldMap notDeferred where - notDeferred :: String -> Option' (Last' Bool) - notDeferred "-fdefer-typed-holes" = Option' . Just . Last' $ False - notDeferred "-fno-defer-typed-holes" = Option' . Just . Last' $ True - notDeferred _ = Option' Nothing + notDeferred :: String -> Maybe (Last Bool) + notDeferred "-fdefer-typed-holes" = Just . Last $ False + notDeferred "-fno-defer-typed-holes" = Just . Last $ True + notDeferred _ = Nothing isTypedHoleFlag :: String -> Any isTypedHoleFlag = @@ -517,7 +532,9 @@ , ghcOptFfiIncludes :: NubListR FilePath -- ^ Extra header files to include for old-style FFI; the @ghc -#include@ flag. , ghcOptCcProgram :: Flag FilePath - -- ^ Program to use for the C and C++ compiler; the @ghc -pgmc@ flag. + -- ^ Program to use for the C compiler; the @ghc -pgmc@ flag. + , ghcOptGppProgram :: Flag FilePath + -- ^ Program to use for the C++ compiler; the @ghc -pgmcxx@ flag. , ---------------------------- -- Language and extensions @@ -566,19 +583,22 @@ , ghcOptObjDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) , ghcOptOutputDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) , ghcOptStubDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) + , ghcOptBytecodeDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) , -------------------- -- Creating libraries ghcOptDynLinkMode :: Flag GhcDynLinkMode + , ghcOptObjectMode :: Flag GhcObjectMode , ghcOptStaticLib :: Flag Bool , ghcOptShared :: Flag Bool + , ghcOptBytecodeLib :: Flag Bool , ghcOptFPic :: Flag Bool , ghcOptDylibName :: Flag String , ghcOptRPaths :: NubListR FilePath , --------------- -- Misc flags - ghcOptVerbosity :: Flag Verbosity + ghcOptVerbosity :: Flag VerbosityLevel -- ^ Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. , ghcOptExtraPath :: NubListR (SymbolicPath Pkg (Dir Build)) -- ^ Put the extra folders in the PATH environment variable we invoke @@ -624,6 +644,15 @@ GhcStaticAndDynamic deriving (Show, Eq) +data GhcObjectMode + = -- | -fobject-code + GhcObjectCode + | -- | -fbyte-code + GhcByteCode + | -- | -fbyte-code-and-object-code + GhcByteCodeAndObjectCode + deriving (Show, Eq) + data GhcProfAuto = -- | @-fprof-auto@ GhcProfAutoAll @@ -692,22 +721,6 @@ 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 @@ -720,23 +733,11 @@ -> Maybe (SymbolicPath CWD (Dir Pkg)) -> GhcOptions -> IO () -runReplProgram withReplProg _tempFileOptions verbosity ghcProg comp platform mbWorkDir ghcOpts = +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' + in runGHCWithResponseFile "ghci.rsp" Nothing tempFileOptions verbosity replProg comp platform mbWorkDir ghcOpts ghcInvocation :: Verbosity @@ -811,18 +812,12 @@ | not (flagBool ghcOptProfilingMode) -> [] Nothing -> [] - Just GhcProfAutoAll - | flagProfAuto implInfo -> ["-fprof-auto"] - | otherwise -> ["-auto-all"] -- not the same, but close + Just GhcProfAutoAll -> ["-fprof-auto"] Just GhcProfLate | flagProfLate implInfo -> ["-fprof-late"] | otherwise -> ["-fprof-auto-top"] -- not the same, not very close, but what we have. - Just GhcProfAutoToplevel - | flagProfAuto implInfo -> ["-fprof-auto-top"] - | otherwise -> ["-auto-all"] - Just GhcProfAutoExported - | flagProfAuto implInfo -> ["-fprof-auto-exported"] - | otherwise -> ["-auto"] + Just GhcProfAutoToplevel -> ["-fprof-auto-top"] + Just GhcProfAutoExported -> ["-fprof-auto-exported"] , ["-split-sections" | flagBool ghcOptSplitSections] , case compilerCompatVersion GHC comp of -- the -split-objs flag was removed in GHC 9.8 @@ -835,10 +830,7 @@ then case ghcOptNumJobs opts of NoFlag -> [] Flag Serial -> [] - Flag (UseSem name) -> - if jsemSupported comp - then ["-jsem " ++ name] - else [] + Flag (UseSem name) -> ["-jsem " ++ name | jsemSupported comp] Flag (NumJobs n) -> ["-j" ++ maybe "" show n] else [] , -------------------- @@ -846,11 +838,17 @@ ["-staticlib" | flagBool ghcOptStaticLib] , ["-shared" | flagBool ghcOptShared] + , ["-bytecodelib" | flagBool ghcOptBytecodeLib] , case flagToMaybe (ghcOptDynLinkMode opts) of Nothing -> [] Just GhcStaticOnly -> ["-static"] Just GhcDynamicOnly -> ["-dynamic"] Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"] + , case flagToMaybe (ghcOptObjectMode opts) of + Nothing -> [] + Just GhcObjectCode -> ["-fobject-code"] + Just GhcByteCode -> ["-fbyte-code", "-fwrite-interface", "-fwrite-byte-code"] + Just GhcByteCodeAndObjectCode -> ["-fbyte-code-and-object-code"] , ["-fPIC" | flagBool ghcOptFPic] , concat [["-dylib-install-name", libname] | libname <- flag ghcOptDylibName] , ------------------------ @@ -864,6 +862,7 @@ , concat [["-odir", u dir] | dir <- flag ghcOptObjDir] , concat [["-hidir", u dir] | dir <- flag ghcOptHiDir] , concat [["-hiedir", u dir] | dir <- flag ghcOptHieDir] + , concat [["-gbcdir", u dir] | bytecodeArtifactsSupported comp, dir <- flag ghcOptBytecodeDir] , concat [["-stubdir", u dir] | dir <- flag ghcOptStubDir] , ----------------------- -- Source search path @@ -884,12 +883,14 @@ ] , ["-optc" ++ opt | opt <- ghcOptCcOptions opts] , -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc + -- https://gitlab.haskell.org/ghc/ghc/-/issues/16477 let cxxflag = case compilerCompatVersion GHC comp of Just v | v >= mkVersion [8, 10] -> "-optcxx" _ -> "-optc" in [cxxflag ++ opt | opt <- ghcOptCxxOptions opts] , ["-opta" ++ opt | opt <- ghcOptAsmOptions opts] , concat [["-pgmc", cc] | cc <- flag ghcOptCcProgram] + , concat [["-pgmcxx", cxx] | cxx <- flag ghcOptGppProgram] , ----------------- -- Linker stuff @@ -933,8 +934,8 @@ , if null (ghcOptInstantiatedWith opts) then [] else - "-instantiated-with" - : intercalate + [ "-instantiated-with" + , intercalate "," ( map ( \(n, m) -> @@ -944,12 +945,12 @@ ) (ghcOptInstantiatedWith opts) ) - : [] + ] , concat [["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode] , ["-hide-all-packages" | flagBool ghcOptHideAllPackages] , ["-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules] , ["-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages] - , packageDbArgs implInfo (interpretPackageDBStack Nothing (ghcOptPackageDBs opts)) + , packageDbArgsDb (interpretPackageDBStack Nothing (ghcOptPackageDBs opts)) , concat $ let space "" = "" space xs = ' ' : xs @@ -959,9 +960,7 @@ , ---------------------------- -- Language and extensions - if supportsHaskell2010 implInfo - then ["-X" ++ prettyShow lang | lang <- flag ghcOptLanguage] - else [] + ["-X" ++ prettyShow lang | lang <- flag ghcOptLanguage] , [ ext' | ext <- flags ghcOptExtensions , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of @@ -977,7 +976,7 @@ -- GHCi concat - [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts, flagGhciScript implInfo + [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts ] , --------------- -- Inputs @@ -1006,33 +1005,15 @@ flags flg = fromNubListR . flg $ opts flagBool flg = fromFlagOrDefault False (flg opts) -verbosityOpts :: Verbosity -> [String] +verbosityOpts :: VerbosityLevel -> [String] verbosityOpts verbosity - | verbosity >= deafening = ["-v"] - | verbosity >= normal = [] + | verbosity >= Deafening = ["-v"] + | verbosity >= Normal = [] | otherwise = ["-w", "-v0"] --- | GHC <7.6 uses '-package-conf' instead of '-package-db'. -packageDbArgsConf :: PackageDBStackCWD -> [String] -packageDbArgsConf dbstack = case dbstack of - (GlobalPackageDB : UserPackageDB : dbs) -> concatMap specific dbs - (GlobalPackageDB : dbs) -> - ("-no-user-package-conf") - : concatMap specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = ["-package-conf", db] - specific _ = ierror - ierror = - error $ - "internal error: unexpected package db stack: " - ++ show dbstack - --- | GHC >= 7.6 uses the '-package-db' flag. See --- https://gitlab.haskell.org/ghc/ghc/-/issues/5977. packageDbArgsDb :: PackageDBStackCWD -> [String] -- special cases to make arguments prettier in common scenarios -packageDbArgsDb dbstack = case dbstack of +packageDbArgsDb = \case (GlobalPackageDB : UserPackageDB : dbs) | all isSpecific dbs -> concatMap single dbs (GlobalPackageDB : dbs) @@ -1048,11 +1029,6 @@ single UserPackageDB = ["-user-package-db"] isSpecific (SpecificPackageDB _) = True isSpecific _ = False - -packageDbArgs :: GhcImplInfo -> PackageDBStackCWD -> [String] -packageDbArgs implInfo - | flagPackageConf implInfo = packageDbArgsConf - | otherwise = packageDbArgsDb -- | Split a list of command-line arguments into RTS arguments and non-RTS -- arguments. diff --git a/src/Distribution/Simple/Program/HcPkg.hs b/src/Distribution/Simple/Program/HcPkg.hs --- a/src/Distribution/Simple/Program/HcPkg.hs +++ b/src/Distribution/Simple/Program/HcPkg.hs @@ -1,11 +1,8 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------ - -- | -- Module : Distribution.Simple.Program.HcPkg -- Copyright : Duncan Coutts 2009, 2013 @@ -17,7 +14,7 @@ -- Currently only GHC and GHCJS have hc-pkg programs. module Distribution.Simple.Program.HcPkg ( -- * Types - HcPkgInfo (..) + ConfiguredProgram (..) , RegisterOptions (..) , defaultRegisterOptions @@ -48,19 +45,44 @@ import Distribution.Compat.Prelude hiding (init) import Prelude () -import Distribution.InstalledPackageInfo -import Distribution.Parsec -import Distribution.Pretty +import Distribution.InstalledPackageInfo (InstalledPackageInfo (..), parseInstalledPackageInfo, showInstalledPackageInfo) +import Distribution.Parsec (simpleParsec) +import Distribution.Pretty (prettyShow) import Distribution.Simple.Compiler -import Distribution.Simple.Errors + ( PackageDB + , PackageDBS + , PackageDBStack + , PackageDBStackS + , PackageDBX (..) + , registrationPackageDB + ) +import Distribution.Simple.Errors (CabalException (..)) import Distribution.Simple.Program.Run -import Distribution.Simple.Program.Types -import Distribution.Simple.Utils -import Distribution.Types.ComponentId -import Distribution.Types.PackageId -import Distribution.Types.UnitId + ( IOEncoding (..) + , ProgramInvocation (..) + , getProgramInvocationLBS + , getProgramInvocationOutput + , programInvocation + , programInvocationCwd + , runProgramInvocation + ) +import Distribution.Simple.Program.Types (ConfiguredProgram (..)) +import Distribution.Simple.Utils (IOData (..), dieWithException, writeUTF8File) +import Distribution.Types.ComponentId (mkComponentId) +import Distribution.Types.PackageId (PackageId) +import Distribution.Types.UnitId (mkLegacyUnitId, unUnitId) import Distribution.Utils.Path -import Distribution.Verbosity + ( CWD + , FileLike ((<.>)) + , FileOrDir (Dir) + , PathLike (()) + , Pkg + , PkgDB + , SymbolicPath + , interpretSymbolicPath + , interpretSymbolicPathCWD + ) +import Distribution.Verbosity (Verbosity, VerbosityLevel (..), verbosityLevel) import Data.List (stripPrefix) import System.FilePath as FilePath @@ -75,53 +97,27 @@ import qualified Data.List.NonEmpty as NE import qualified System.FilePath.Posix as FilePath.Posix --- | Information about the features and capabilities of an @hc-pkg@ --- program. -data HcPkgInfo = HcPkgInfo - { hcPkgProgram :: ConfiguredProgram - , noPkgDbStack :: Bool - -- ^ no package DB stack supported - , noVerboseFlag :: Bool - -- ^ hc-pkg does not support verbosity flags - , flagPackageConf :: Bool - -- ^ use package-conf option instead of package-db - , supportsDirDbs :: Bool - -- ^ supports directory style package databases - , requiresDirDbs :: Bool - -- ^ requires directory style package databases - , nativeMultiInstance :: Bool - -- ^ supports --enable-multi-instance flag - , recacheMultiInstance :: Bool - -- ^ supports multi-instance via recache - , suppressFilesCheck :: Bool - -- ^ supports --force-files or equivalent - } - -- | Call @hc-pkg@ to initialise a package database at the location {path}. -- -- > hc-pkg init {path} -init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO () -init hpi verbosity preferCompat path - | not (supportsDirDbs hpi) - || (not (requiresDirDbs hpi) && preferCompat) = - writeFile path "[]" - | otherwise = - runProgramInvocation verbosity (initInvocation hpi verbosity path) +init :: ConfiguredProgram -> Verbosity -> FilePath -> IO () +init hpi verbosity path = + runProgramInvocation verbosity (initInvocation hpi verbosity path) -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. invoke - :: HcPkgInfo + :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDBStack -> [String] -> IO () -invoke hpi verbosity mbWorkDir dbStack extraArgs = +invoke ghcProg verbosity mbWorkDir dbStack extraArgs = runProgramInvocation verbosity invocation where - args = packageDbStackOpts hpi dbStack ++ extraArgs - invocation = programInvocationCwd mbWorkDir (hcPkgProgram hpi) args + args = packageDbStackOpts dbStack ++ extraArgs + invocation = programInvocationCwd mbWorkDir ghcProg args -- | Additional variations in the behaviour for 'register'. data RegisterOptions = RegisterOptions @@ -129,9 +125,7 @@ -- ^ Allows re-registering \/ overwriting an existing package , registerMultiInstance :: Bool -- ^ Insist on the ability to register multiple instances of a - -- single version of a single package. This will fail if the @hc-pkg@ - -- does not support it, see 'nativeMultiInstance' and - -- 'recacheMultiInstance'. + -- single version of a single package. , registerSuppressFilesCheck :: Bool -- ^ Require that no checks are performed on the existence of package -- files mentioned in the registration info. This must be used if @@ -152,7 +146,7 @@ -- -- > hc-pkg register {filename | -} [--user | --global | --package-db] register - :: HcPkgInfo + :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBStackS from @@ -160,74 +154,55 @@ -> RegisterOptions -> IO () register hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions - | registerMultiInstance registerOptions - , not (nativeMultiInstance hpi || recacheMultiInstance hpi) = - dieWithException verbosity RegMultipleInstancePkg - | registerSuppressFilesCheck registerOptions - , not (suppressFilesCheck hpi) = - dieWithException verbosity SuppressingChecksOnFile - -- This is a trick. Older versions of GHC do not support the - -- --enable-multi-instance flag for ghc-pkg register but it turns out that - -- the same ability is available by using ghc-pkg recache. The recache - -- command is there to support distro package managers that like to work - -- by just installing files and running update commands, rather than - -- special add/remove commands. So the way to register by this method is - -- to write the package registration file directly into the package db and - -- then call hc-pkg recache. - -- - | registerMultiInstance registerOptions - , recacheMultiInstance hpi = + | registerMultiInstance registerOptions = do let pkgdb = registrationPackageDB packagedbs - writeRegistrationFileDirectly verbosity hpi mbWorkDir pkgdb pkgInfo + writeRegistrationFileDirectly verbosity mbWorkDir pkgdb pkgInfo recache hpi verbosity mbWorkDir pkgdb | otherwise = runProgramInvocation verbosity - (registerInvocation hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions) + (registerInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedbs pkgInfo registerOptions) writeRegistrationFileDirectly :: Verbosity - -> HcPkgInfo -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> InstalledPackageInfo -> IO () -writeRegistrationFileDirectly verbosity hpi mbWorkDir (SpecificPackageDB dir) pkgInfo - | supportsDirDbs hpi = - do - let pkgfile = interpretSymbolicPath mbWorkDir dir prettyShow (installedUnitId pkgInfo) <.> "conf" - writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) - | otherwise = - dieWithException verbosity NoSupportDirStylePackageDb -writeRegistrationFileDirectly verbosity _ _ _ _ = - -- We don't know here what the dir for the global or user dbs are, - -- if that's needed it'll require a bit more plumbing to support. - dieWithException verbosity OnlySupportSpecificPackageDb +writeRegistrationFileDirectly verbosity mbWorkDir package pkgInfo = + case package of + (SpecificPackageDB dir) -> do + let pkgfile = interpretSymbolicPath mbWorkDir dir prettyShow (installedUnitId pkgInfo) <.> "conf" + writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) + _ -> do + -- We don't know here what the dir for the global or user dbs are, + -- if that's needed it'll require a bit more plumbing to support. + dieWithException verbosity OnlySupportSpecificPackageDb -- | Call @hc-pkg@ to unregister a package -- -- > hc-pkg unregister [pkgid] [--user | --global | --package-db] -unregister :: HcPkgInfo -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> IO () +unregister :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> IO () unregister hpi verbosity mbWorkDir packagedb pkgid = runProgramInvocation verbosity - (unregisterInvocation hpi verbosity mbWorkDir packagedb pkgid) + (unregisterInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb pkgid) -- | Call @hc-pkg@ to recache the registered packages. -- -- > hc-pkg recache [--user | --global | --package-db] -recache :: HcPkgInfo -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> IO () +recache :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> IO () recache hpi verbosity mbWorkDir packagedb = runProgramInvocation verbosity - (recacheInvocation hpi verbosity mbWorkDir packagedb) + (recacheInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb) -- | Call @hc-pkg@ to expose a package. -- -- > hc-pkg expose [pkgid] [--user | --global | --package-db] expose - :: HcPkgInfo + :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB @@ -236,34 +211,34 @@ expose hpi verbosity mbWorkDir packagedb pkgid = runProgramInvocation verbosity - (exposeInvocation hpi verbosity mbWorkDir packagedb pkgid) + (exposeInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb pkgid) -- | Call @hc-pkg@ to retrieve a specific package -- -- > hc-pkg describe [pkgid] [--user | --global | --package-db] describe - :: HcPkgInfo + :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo] -describe hpi verbosity mbWorkDir packagedb pid = do +describe ghcProg verbosity mbWorkDir packagedb pid = do output <- getProgramInvocationLBS verbosity - (describeInvocation hpi verbosity mbWorkDir packagedb pid) + (describeInvocation ghcProg (verbosityLevel verbosity) mbWorkDir packagedb pid) `catchIO` \_ -> return mempty case parsePackages output of Left ok -> return ok - _ -> dieWithException verbosity $ FailedToParseOutputDescribe (programId (hcPkgProgram hpi)) pid + _ -> dieWithException verbosity $ FailedToParseOutputDescribe (programId ghcProg) pid -- | Call @hc-pkg@ to hide a package. -- -- > hc-pkg hide [pkgid] [--user | --global | --package-db] hide - :: HcPkgInfo + :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB @@ -272,27 +247,27 @@ hide hpi verbosity mbWorkDir packagedb pkgid = runProgramInvocation verbosity - (hideInvocation hpi verbosity mbWorkDir packagedb pkgid) + (hideInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb pkgid) -- | Call @hc-pkg@ to get all the details of all the packages in the given -- package database. dump - :: HcPkgInfo + :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBX (SymbolicPath from (Dir PkgDB)) -> IO [InstalledPackageInfo] -dump hpi verbosity mbWorkDir packagedb = do +dump ghcProg verbosity mbWorkDir packagedb = do output <- getProgramInvocationLBS verbosity - (dumpInvocation hpi verbosity mbWorkDir packagedb) + (dumpInvocation ghcProg (verbosityLevel verbosity) mbWorkDir packagedb) `catchIO` \e -> - dieWithException verbosity $ DumpFailed (programId (hcPkgProgram hpi)) (displayException e) + dieWithException verbosity $ DumpFailed (programId ghcProg) (displayException e) case parsePackages output of Left ok -> return ok - _ -> dieWithException verbosity $ FailedToParseOutputDump (programId (hcPkgProgram hpi)) + _ -> dieWithException verbosity $ FailedToParseOutputDump (programId ghcProg) parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String] parsePackages lbs0 = @@ -321,22 +296,13 @@ go [] = [LBS.toStrict lbs] go (idx : idxs) = let (pfx, sfx) = LBS.splitAt idx lbs - in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of + in case foldr ((<|>) . (`LBS.stripPrefix` sfx)) Nothing separators of Just sfx' -> LBS.toStrict pfx : doSplit sfx' Nothing -> go idxs separators :: [LBS.ByteString] separators = ["\n---\n", "\r\n---\r\n", "\r---\r"] -lbsStripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString -#if MIN_VERSION_bytestring(0,10,8) -lbsStripPrefix pfx lbs = LBS.stripPrefix pfx lbs -#else -lbsStripPrefix pfx lbs - | LBS.isPrefixOf pfx lbs = Just (LBS.drop (LBS.length pfx) lbs) - | otherwise = Nothing -#endif - mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) @@ -351,7 +317,7 @@ , libraryDynDirs = mungePaths (libraryDynDirs pkginfo) , frameworkDirs = mungePaths (frameworkDirs pkginfo) , haddockInterfaces = mungePaths (haddockInterfaces pkginfo) - , haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) + , haddockHTMLs = mungePaths (mungeUrls (haddockHTMLs pkginfo)) } where mungePaths = map mungePath @@ -400,21 +366,21 @@ -- Note in particular that it does not include the 'UnitId', just -- the source 'PackageId' which is not necessarily unique in any package db. list - :: HcPkgInfo + :: ConfiguredProgram -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> IO [PackageId] -list hpi verbosity mbWorkDir packagedb = do +list ghcProg verbosity mbWorkDir packagedb = do output <- getProgramInvocationOutput verbosity - (listInvocation hpi verbosity mbWorkDir packagedb) - `catchIO` \_ -> dieWithException verbosity $ ListFailed (programId (hcPkgProgram hpi)) + (listInvocation ghcProg (verbosityLevel verbosity) mbWorkDir packagedb) + `catchIO` \_ -> dieWithException verbosity $ ListFailed (programId ghcProg) case parsePackageIds output of Just ok -> return ok - _ -> dieWithException verbosity $ FailedToParseOutputList (programId (hcPkgProgram hpi)) + _ -> dieWithException verbosity $ FailedToParseOutputList (programId ghcProg) where parsePackageIds = traverse simpleParsec . words @@ -422,24 +388,24 @@ -- The program invocations -- -initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation -initInvocation hpi verbosity path = - programInvocation (hcPkgProgram hpi) args +initInvocation :: ConfiguredProgram -> Verbosity -> FilePath -> ProgramInvocation +initInvocation ghcProg verbosity path = + programInvocation ghcProg args where args = ["init", path] - ++ verbosityOpts hpi verbosity + ++ verbosityOpts (verbosityLevel verbosity) registerInvocation - :: HcPkgInfo - -> Verbosity + :: ConfiguredProgram + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBStackS from -> InstalledPackageInfo -> RegisterOptions -> ProgramInvocation -registerInvocation hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions = - (programInvocationCwd mbWorkDir (hcPkgProgram hpi) (args "-")) +registerInvocation ghcProg verbosity mbWorkDir packagedbs pkgInfo registerOptions = + (programInvocationCwd mbWorkDir ghcProg (args "-")) { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo , progInvokeInputEncoding = IOEncodingUTF8 } @@ -451,146 +417,135 @@ args file = [cmdname, file] - ++ packageDbStackOpts hpi packagedbs + ++ packageDbStackOpts packagedbs ++ [ "--enable-multi-instance" | registerMultiInstance registerOptions ] ++ [ "--force-files" | registerSuppressFilesCheck registerOptions ] - ++ verbosityOpts hpi verbosity + ++ verbosityOpts verbosity unregisterInvocation - :: HcPkgInfo - -> Verbosity + :: ConfiguredProgram + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> ProgramInvocation -unregisterInvocation hpi verbosity mbWorkDir packagedb pkgid = - programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ - ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity +unregisterInvocation ghcProg verbosity mbWorkDir packagedb pkgid = + programInvocationCwd mbWorkDir ghcProg $ + ["unregister", packageDbOpts packagedb, prettyShow pkgid] + ++ verbosityOpts verbosity recacheInvocation - :: HcPkgInfo - -> Verbosity + :: ConfiguredProgram + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> ProgramInvocation -recacheInvocation hpi verbosity mbWorkDir packagedb = - programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ - ["recache", packageDbOpts hpi packagedb] - ++ verbosityOpts hpi verbosity +recacheInvocation ghcProg verbosity mbWorkDir packagedb = + programInvocationCwd mbWorkDir ghcProg $ + ["recache", packageDbOpts packagedb] + ++ verbosityOpts verbosity exposeInvocation - :: HcPkgInfo - -> Verbosity + :: ConfiguredProgram + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> ProgramInvocation -exposeInvocation hpi verbosity mbWorkDir packagedb pkgid = - programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ - ["expose", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity +exposeInvocation ghcProg verbosity mbWorkDir packagedb pkgid = + programInvocationCwd mbWorkDir ghcProg $ + ["expose", packageDbOpts packagedb, prettyShow pkgid] + ++ verbosityOpts verbosity describeInvocation - :: HcPkgInfo - -> Verbosity + :: ConfiguredProgram + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDBStack -> PackageId -> ProgramInvocation -describeInvocation hpi verbosity mbWorkDir packagedbs pkgid = - programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ +describeInvocation ghcProg verbosity mbWorkDir packagedbs pkgid = + programInvocationCwd mbWorkDir ghcProg $ ["describe", prettyShow pkgid] - ++ packageDbStackOpts hpi packagedbs - ++ verbosityOpts hpi verbosity + ++ packageDbStackOpts packagedbs + ++ verbosityOpts verbosity hideInvocation - :: HcPkgInfo - -> Verbosity + :: ConfiguredProgram + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> ProgramInvocation -hideInvocation hpi verbosity mbWorkDir packagedb pkgid = - programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ - ["hide", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity +hideInvocation ghcProg verbosity mbWorkDir packagedb pkgid = + programInvocationCwd mbWorkDir ghcProg $ + ["hide", packageDbOpts packagedb, prettyShow pkgid] + ++ verbosityOpts verbosity dumpInvocation - :: HcPkgInfo - -> Verbosity + :: ConfiguredProgram + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBX (SymbolicPath from (Dir PkgDB)) -> ProgramInvocation -dumpInvocation hpi _verbosity mbWorkDir packagedb = - (programInvocationCwd mbWorkDir (hcPkgProgram hpi) args) +dumpInvocation ghcProg _verbosity mbWorkDir packagedb = + (programInvocationCwd mbWorkDir ghcProg args) { progInvokeOutputEncoding = IOEncodingUTF8 } where args = - ["dump", packageDbOpts hpi packagedb] - ++ verbosityOpts hpi silent + ["dump", packageDbOpts packagedb] + ++ verbosityOpts Silent --- We use verbosity level 'silent' because it is important that we +-- We use verbosity level 'Silent' because it is important that we -- do not contaminate the output with info/debug messages. listInvocation - :: HcPkgInfo - -> Verbosity + :: ConfiguredProgram + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> ProgramInvocation -listInvocation hpi _verbosity mbWorkDir packagedb = - (programInvocationCwd mbWorkDir (hcPkgProgram hpi) args) +listInvocation ghcProg _verbosity mbWorkDir packagedb = + (programInvocationCwd mbWorkDir ghcProg args) { progInvokeOutputEncoding = IOEncodingUTF8 } where args = - ["list", "--simple-output", packageDbOpts hpi packagedb] - ++ verbosityOpts hpi silent + ["list", "--simple-output", packageDbOpts packagedb] + ++ verbosityOpts Silent --- We use verbosity level 'silent' because it is important that we +-- We use verbosity level 'Silent' because it is important that we -- do not contaminate the output with info/debug messages. -packageDbStackOpts :: HcPkgInfo -> PackageDBStackS from -> [String] -packageDbStackOpts hpi dbstack - | noPkgDbStack hpi = [packageDbOpts hpi (registrationPackageDB dbstack)] - | otherwise = case dbstack of - (GlobalPackageDB : UserPackageDB : dbs) -> - "--global" - : "--user" - : map specific dbs - (GlobalPackageDB : dbs) -> - "--global" - : ("--no-user-" ++ packageDbFlag hpi) - : map specific dbs - _ -> ierror +packageDbStackOpts :: PackageDBStackS from -> [String] +packageDbStackOpts dbstack = case dbstack of + (GlobalPackageDB : UserPackageDB : dbs) -> + "--global" + : "--user" + : map specific dbs + (GlobalPackageDB : dbs) -> + "--global" + : "--no-user-package-db" + : map specific dbs + _ -> ierror where - specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ interpretSymbolicPathCWD db + specific (SpecificPackageDB db) = "--package-db=" ++ interpretSymbolicPathCWD db specific _ = ierror ierror :: a ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) -packageDbFlag :: HcPkgInfo -> String -packageDbFlag hpi - | flagPackageConf hpi = - "package-conf" - | otherwise = - "package-db" - -packageDbOpts :: HcPkgInfo -> PackageDBX (SymbolicPath from (Dir PkgDB)) -> String -packageDbOpts _ GlobalPackageDB = "--global" -packageDbOpts _ UserPackageDB = "--user" -packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ interpretSymbolicPathCWD db +packageDbOpts :: PackageDBX (SymbolicPath from (Dir PkgDB)) -> String +packageDbOpts GlobalPackageDB = "--global" +packageDbOpts UserPackageDB = "--user" +packageDbOpts (SpecificPackageDB db) = "--package-db=" ++ interpretSymbolicPathCWD db -verbosityOpts :: HcPkgInfo -> Verbosity -> [String] -verbosityOpts hpi v - | noVerboseFlag hpi = - [] - | v >= deafening = ["-v2"] - | v == silent = ["-v0"] +verbosityOpts :: VerbosityLevel -> [String] +verbosityOpts v + | v >= Deafening = ["-v2"] + | v == Silent = ["-v0"] | otherwise = [] 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 @@ -37,7 +37,7 @@ filterPar' :: Int -> [String] -> [String] filterPar' _ [] = [] filterPar' n (x : xs) - | n >= 0 && "(" `isPrefixOf` x = filterPar' (n + 1) ((safeTail x) : xs) + | n >= 0 && "(" `isPrefixOf` x = filterPar' (n + 1) (safeTail x : 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/ResponseFile.hs b/src/Distribution/Simple/Program/ResponseFile.hs --- a/src/Distribution/Simple/Program/ResponseFile.hs +++ b/src/Distribution/Simple/Program/ResponseFile.hs @@ -40,8 +40,7 @@ traverse_ (hSetEncoding hf) encoding let responseContents = unlines $ - map escapeResponseFileArg $ - arguments + map escapeResponseFileArg arguments hPutStr hf responseContents hClose hf debug verbosity $ responseFileName ++ " contents: <<<" 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 @@ -130,8 +130,7 @@ , progInvokeEnv = [] , progInvokeCwd = Nothing , progInvokeInput = Nothing - } = - rawSystemExit verbosity Nothing path args + } = rawSystemExit verbosity Nothing path args runProgramInvocation verbosity ProgramInvocation @@ -262,9 +261,7 @@ -> IO [(String, String)] getFullEnvironment overrides = do menv <- getEffectiveEnvironment overrides - case menv of - Just env -> return env - Nothing -> getEnvironment + maybe getEnvironment return menv -- | Like the unix xargs program. Useful for when we've got very long command -- lines that might overflow an OS limit on command line length and so you diff --git a/src/Distribution/Simple/Program/Script.hs b/src/Distribution/Simple/Program/Script.hs --- a/src/Distribution/Simple/Program/Script.hs +++ b/src/Distribution/Simple/Program/Script.hs @@ -82,7 +82,7 @@ ++ ["cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd] ++ case minput of Nothing -> - [path ++ concatMap (' ' :) args] + [unwords (path : args)] Just input -> ["("] ++ ["echo " ++ escape line | line <- lines $ iodataToText input] diff --git a/src/Distribution/Simple/Program/Strip.hs b/src/Distribution/Simple/Program/Strip.hs --- a/src/Distribution/Simple/Program/Strip.hs +++ b/src/Distribution/Simple/Program/Strip.hs @@ -34,7 +34,7 @@ -- have the strip program anyway. warn verbosity $ "Unable to strip executable or library '" - ++ (takeBaseName path) + ++ takeBaseName path ++ "' (missing the 'strip' program)" stripExe :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () @@ -79,7 +79,7 @@ _ -> warn verbosity $ "Unable to strip library '" - ++ (takeBaseName path) + ++ takeBaseName path ++ "' (version of 'strip' too old; " ++ "requires >= 2.18 on 32-bit Linux)" _ -> runStrip verbosity progdb path args 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 @@ -29,7 +29,9 @@ -- generation and the unregister feature are not well used or tested. module Distribution.Simple.Register ( register + , registerWithHandles , unregister + , unregisterWithHandles , internalPackageDBPath , initPackageDB , doesPackageDBExist @@ -77,6 +79,7 @@ import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Program.Script import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Haddock (HaddockTarget (ForDevelopment)) import Distribution.Simple.Setup.Register import Distribution.Simple.Utils import Distribution.System @@ -98,12 +101,21 @@ -> RegisterFlags -- ^ Install in the user's database?; verbose -> IO () -register pkg_descr lbi0 flags = do +register = registerWithHandles defaultVerbosityHandles + +registerWithHandles + :: VerbosityHandles + -> PackageDescription + -> LocalBuildInfo + -> RegisterFlags + -- ^ Install in the user's database?; verbose + -> IO () +registerWithHandles verbHandles pkg_descr lbi0 flags = do -- Duncan originally asked for us to not register/install files -- when there was no public library. But with per-component -- configure, we legitimately need to install internal libraries -- so that we can get them. So just unconditionally install. - let verbosity = fromFlag $ registerVerbosity flags + let verbosity = mkVerbosity verbHandles (fromFlag $ registerVerbosity flags) targets <- readTargetInfos verbosity pkg_descr lbi0 $ registerTargets flags -- It's important to register in build order, because ghc-pkg @@ -117,20 +129,21 @@ CLib lib -> do let clbi = targetCLBI tgt lbi = lbi0{installedPkgs = index} - ipi <- generateOne pkg_descr lib lbi clbi flags + ipi <- generateOne verbHandles pkg_descr lib lbi clbi flags return (Index.insert ipi index, Just ipi) _ -> return (index, Nothing) - registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs) + registerAll verbHandles pkg_descr lbi0 flags (catMaybes ipi_mbs) generateOne - :: PackageDescription + :: VerbosityHandles + -> PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo -> RegisterFlags -> IO InstalledPackageInfo -generateOne pkg lib lbi clbi regFlags = +generateOne verbHandles pkg lib lbi clbi regFlags = do absPackageDBs <- absolutePackageDBPaths mbWorkDir packageDbs installedPkgInfo <- @@ -154,29 +167,31 @@ -- registering into a totally different db stack can -- fail if dependencies cannot be satisfied. packageDbs = - nub $ + ordNub $ withPackageDB lbi ++ maybeToList (flagToMaybe (regPackageDB regFlags)) distPref = fromFlag $ setupDistPref common - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) mbWorkDir = flagToMaybe $ setupWorkingDir common registerAll - :: PackageDescription + :: VerbosityHandles + -> PackageDescription -> LocalBuildInfo -> RegisterFlags -> [InstalledPackageInfo] -> IO () -registerAll pkg lbi regFlags ipis = +registerAll verbHandles pkg lbi regFlags ipis = do - when (fromFlag (regPrintId regFlags)) $ do + when (Just True == flagToMaybe (regPrintId regFlags)) $ do for_ ipis $ \installedPkgInfo -> -- Only print the public library's IPI when ( packageId installedPkgInfo == packageId pkg && IPI.sourceLibName installedPkgInfo == LMainLibName ) - $ putStrLn (prettyShow (IPI.installedUnitId installedPkgInfo)) + $ notice verbosity + $ prettyShow (IPI.installedUnitId installedPkgInfo) -- Three different modes: case () of @@ -213,11 +228,11 @@ -- registering into a totally different db stack can -- fail if dependencies cannot be satisfied. packageDbs = - nub $ + ordNub $ withPackageDB lbi ++ maybeToList (flagToMaybe (regPackageDB regFlags)) common = registerCommonFlags regFlags - verbosity = fromFlag (setupVerbosity common) + verbosity = mkVerbosity verbHandles (fromFlag (setupVerbosity common)) mbWorkDir = mbWorkDirLBI lbi writeRegistrationFileOrDirectory = do @@ -339,7 +354,7 @@ -> PackageDB -> IO InstalledPackageInfo relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb = - case (compilerFlavor (compiler lbi)) of + case compilerFlavor (compiler lbi) of GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb return @@ -355,20 +370,19 @@ initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO () initPackageDB verbosity comp progdb dbPath = - createPackageDB verbosity comp progdb False dbPath + createPackageDB verbosity comp progdb dbPath -- | Create an empty package DB at the specified location. createPackageDB :: Verbosity -> Compiler -> ProgramDb - -> Bool -> FilePath -> IO () -createPackageDB verbosity comp progdb preferCompat dbPath = +createPackageDB verbosity comp progdb dbPath = case compilerFlavor comp of - GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath - GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath + GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity dbPath + GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity dbPath UHC -> return () _ -> dieWithException verbosity CreatePackageDB @@ -381,14 +395,9 @@ else doesFileExist dbPath deletePackageDB :: FilePath -> IO () -deletePackageDB dbPath = do +deletePackageDB = -- currently one impl for all compiler flavours, but could change if needed - dir_exists <- doesDirectoryExist dbPath - if dir_exists - then removeDirectoryRecursive dbPath - else do - file_exists <- doesFileExist dbPath - when file_exists $ removeFile dbPath + removePathForcibly -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. @@ -413,7 +422,7 @@ -> String -> Compiler -> ProgramDb - -> (HcPkg.HcPkgInfo -> IO a) + -> (HcPkg.ConfiguredProgram -> IO a) -> IO a withHcPkg verbosity name comp progdb f = case compilerFlavor comp of @@ -445,14 +454,14 @@ -> Maybe (SymbolicPath CWD (Dir Pkg)) -> [InstalledPackageInfo] -> PackageDBStack - -> HcPkg.HcPkgInfo + -> HcPkg.ConfiguredProgram -> IO () writeHcPkgRegisterScript verbosity mbWorkDir ipis packageDbs hpi = do let genScript installedPkgInfo = let invocation = HcPkg.registerInvocation hpi - Verbosity.normal + Verbosity.Normal mbWorkDir packageDbs installedPkgInfo @@ -517,19 +526,18 @@ 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) + ++ map (`IPI.ExposedModule` Nothing) (virtualModules bi) , IPI.hiddenModules = otherModules bi , IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo , IPI.importDirs = [libdir installDirs | hasModules] , IPI.libraryDirs = libdirs , IPI.libraryDirsStatic = libdirsStatic , IPI.libraryDynDirs = dynlibdirs + , IPI.libraryBytecodeDirs = + [bytecodelibdir installDirs | hasLibrary && withBytecodeLib lbi] , IPI.dataDir = datadir installDirs , IPI.hsLibraries = - ( if hasLibrary - then [getHSLibraryName (componentUnitId clbi)] - else [] - ) + [getHSLibraryName (componentUnitId clbi) | hasLibrary] ++ extraBundledLibs bi , IPI.extraLibraries = extraLibs bi , IPI.extraLibrariesStatic = extraLibsStatic bi @@ -545,7 +553,8 @@ , IPI.ldOptions = ldOptions bi , IPI.frameworks = map getSymbolicPath $ frameworks bi , IPI.frameworkDirs = map getSymbolicPath $ extraFrameworkDirs bi - , IPI.haddockInterfaces = [haddockdir installDirs haddockLibraryPath pkg lib | hasModules] + , IPI.haddockInterfaces = + [haddockdir installDirs haddockLibraryPath pkg lib | hasModules] , IPI.haddockHTMLs = [htmldir installDirs | hasModules] , IPI.pkgRoot = Nothing , IPI.libVisibility = libVisibility lib @@ -598,7 +607,7 @@ | otherwise = (libdir installDirs : dynlibdir installDirs : extraLibDirs', []) expectLibraryComponent (Just attribute) = attribute - expectLibraryComponent Nothing = (error "generalInstalledPackageInfo: Expected a library component, got something else.") + 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 @@ -637,6 +646,7 @@ (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) { libdir = i libTargetDir , dynlibdir = i libTargetDir + , bytecodelibdir = i libTargetDir , datadir = let rawDataDir = dataDir pkg in if null $ getSymbolicPath rawDataDir @@ -647,7 +657,10 @@ , haddockdir = inplaceHtmldir } inplaceDocdir = distPref makeRelativePathEx "doc" - inplaceHtmldir = i $ inplaceDocdir makeRelativePathEx ("html" prettyShow (packageName pkg)) + inplaceHtmldir = + i $ + (inplaceDocdir makeRelativePathEx "html") + makeRelativePathEx (haddockLibraryDirPath ForDevelopment pkg lib) -- | Construct 'InstalledPackageInfo' for the final install location of a -- library package. @@ -711,11 +724,14 @@ -- Unregistration unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () -unregister pkg lbi regFlags = do +unregister = unregisterWithHandles defaultVerbosityHandles + +unregisterWithHandles :: VerbosityHandles -> PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () +unregisterWithHandles verbHandles pkg lbi regFlags = do let pkgid = packageId pkg common = registerCommonFlags regFlags genScript = fromFlag (regGenScript regFlags) - verbosity = fromFlag (setupVerbosity common) + verbosity = mkVerbosity verbHandles (fromFlag (setupVerbosity common)) packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) @@ -725,7 +741,7 @@ let invocation = HcPkg.unregisterInvocation hpi - Verbosity.normal + Verbosity.Normal mbWorkDir packageDb pkgid 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 @@ -170,7 +170,7 @@ import Distribution.Simple.Setup.Test import Distribution.Utils.Path -import Distribution.Verbosity (Verbosity) +import Distribution.Verbosity (VerbosityFlags) -- | What kind of build phase are we doing/hooking into? -- @@ -194,7 +194,7 @@ BuildHaddock flags -> haddockCommonFlags flags BuildHscolour flags -> hscolourCommonFlags flags -buildingWhatVerbosity :: BuildingWhat -> Verbosity +buildingWhatVerbosity :: BuildingWhat -> VerbosityFlags buildingWhatVerbosity = fromFlag . setupVerbosity . buildingWhatCommonFlags buildingWhatWorkingDir :: BuildingWhat -> Maybe (SymbolicPath CWD (Dir Pkg)) 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 @@ -55,7 +55,7 @@ deriving (Show, Generic) pattern BenchmarkCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) diff --git a/src/Distribution/Simple/Setup/Build.hs b/src/Distribution/Simple/Setup/Build.hs --- a/src/Distribution/Simple/Setup/Build.hs +++ b/src/Distribution/Simple/Setup/Build.hs @@ -61,7 +61,7 @@ deriving (Read, Show, Generic) pattern BuildCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) @@ -128,7 +128,8 @@ -- ++ " " ++ pname ++ " build foo:Foo.Bar\n" -- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n" commandUsage = - usageAlternatives "build" $ + usageAlternatives + "build" [ "[FLAGS]" , "COMPONENTS [FLAGS]" ] @@ -145,18 +146,17 @@ buildCommonFlags (\c f -> f{buildCommonFlags = c}) showOrParseArgs - ( [ optionNumJobs - buildNumJobs - (\v flags -> flags{buildNumJobs = v}) - , option - [] - ["semaphore"] - "semaphore" - buildUseSemaphore - (\v flags -> flags{buildUseSemaphore = v}) - (reqArg' "SEMAPHORE" Flag flagToList) - ] - ) + [ optionNumJobs + buildNumJobs + (\v flags -> flags{buildNumJobs = v}) + , option + [] + ["semaphore"] + "Use the specified semaphore identifier so GHC can compile components in parallel" + buildUseSemaphore + (\v flags -> flags{buildUseSemaphore = v}) + (reqArg' "SEMAPHORE" Flag flagToList) + ] ++ programDbPaths progDb showOrParseArgs diff --git a/src/Distribution/Simple/Setup/Clean.hs b/src/Distribution/Simple/Setup/Clean.hs --- a/src/Distribution/Simple/Setup/Clean.hs +++ b/src/Distribution/Simple/Setup/Clean.hs @@ -53,7 +53,7 @@ deriving (Show, Generic) pattern CleanCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) 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 @@ -71,7 +71,7 @@ -- | A datatype that stores common flags for different invocations -- of a @Setup@ executable, e.g. configure, build, install. data CommonSetupFlags = CommonSetupFlags - { setupVerbosity :: !(Flag Verbosity) + { setupVerbosity :: !(Flag VerbosityFlags) -- ^ Verbosity , setupWorkingDir :: !(Flag (SymbolicPath CWD (Dir Pkg))) -- ^ Working directory (optional) @@ -142,8 +142,7 @@ , option "" ["keep-temp-files"] - ( "Keep temporary files." - ) + "Keep temporary files." setupKeepTempFiles (\keepTempFiles flags -> flags{setupKeepTempFiles = keepTempFiles}) trueArg @@ -396,8 +395,8 @@ (set . fmap makeSymbolicPath) optionVerbosity - :: (flags -> Flag Verbosity) - -> (Flag Verbosity -> flags -> flags) + :: (flags -> Flag VerbosityFlags) + -> (Flag VerbosityFlags -> flags -> flags) -> OptionField flags optionVerbosity get set = option 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 @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} @@ -45,8 +46,8 @@ import Distribution.Compat.Prelude hiding (get) import Prelude () +import Data.Semigroup (Last (..)) import qualified Distribution.Compat.CharParsing as P -import Distribution.Compat.Semigroup (Last' (..), Option' (..)) import Distribution.Compat.Stack import Distribution.Compiler import Distribution.ModuleName @@ -90,7 +91,7 @@ -- because the type of configure is constrained by the UserHooks. -- when we change UserHooks next we should pass the initial -- ProgramDb directly and not via ConfigFlags - configPrograms_ :: Option' (Last' ProgramDb) + configPrograms_ :: Maybe (Last ProgramDb) -- ^ All programs that -- @cabal@ may run , configProgramPaths :: [(String, FilePath)] @@ -114,6 +115,8 @@ -- ^ Build shared library , configStaticLib :: Flag Bool -- ^ Build static library + , configBytecodeLib :: Flag Bool + -- ^ Build bytecode library , configDynExe :: Flag Bool -- ^ Enable dynamic linking of the -- executables. @@ -237,7 +240,7 @@ deriving (Generic, Read, Show) pattern ConfigCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) @@ -267,10 +270,7 @@ -- 'error' if internal invariant is violated. configPrograms :: WithCallStack (ConfigFlags -> ProgramDb) configPrograms = - fromMaybe (error "FIXME: remove configPrograms") - . fmap getLast' - . getOption' - . configPrograms_ + maybe (error "FIXME: remove configPrograms") getLast . configPrograms_ instance Eq ConfigFlags where (==) a b = @@ -286,6 +286,7 @@ && equal configProfLib && equal configSharedLib && equal configStaticLib + && equal configBytecodeLib && equal configDynExe && equal configFullyStaticExe && equal configProfExe @@ -336,12 +337,13 @@ defaultConfigFlags progDb = emptyConfigFlags { configCommonFlags = defaultCommonSetupFlags - , configPrograms_ = Option' (Just (Last' progDb)) + , configPrograms_ = Just (Last progDb) , configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor , configVanillaLib = Flag True , configProfLib = NoFlag , configSharedLib = NoFlag , configStaticLib = NoFlag + , configBytecodeLib = NoFlag , configDynExe = Flag False , configFullyStaticExe = Flag False , configProfExe = NoFlag @@ -500,6 +502,13 @@ (boolOpt [] []) , option "" + ["library-bytecode"] + "Bytecode library" + configBytecodeLib + (\v flags -> flags{configBytecodeLib = v}) + (boolOpt [] []) + , option + "" ["executable-dynamic"] "Executable dynamic linking" configDynExe @@ -564,7 +573,7 @@ [ optArgDef' "n" (show NoOptimisation, Flag . flagToOptimisationLevel) - ( \f -> case f of + ( \case Flag NoOptimisation -> [] Flag NormalOptimisation -> [Nothing] Flag MaximumOptimisation -> [Just "2"] @@ -586,7 +595,7 @@ [ optArg' "n" (Flag . flagToDebugInfoLevel) - ( \f -> case f of + ( \case Flag NoDebugInfo -> [] Flag MinimalDebugInfo -> [Just "1"] Flag NormalDebugInfo -> [Nothing] @@ -890,15 +899,6 @@ readPackageDbList :: String -> [Maybe PackageDB] readPackageDbList str = [readPackageDb str] --- | Parse a PackageDB stack entry --- --- @since 3.7.0.0 -readPackageDb :: String -> Maybe PackageDB -readPackageDb "clear" = Nothing -readPackageDb "global" = Just GlobalPackageDB -readPackageDb "user" = Just UserPackageDB -readPackageDb other = Just (SpecificPackageDB (makeSymbolicPath other)) - showPackageDbList :: [Maybe PackageDB] -> [String] showPackageDbList = map showPackageDb @@ -997,6 +997,13 @@ "installation directory for dynamic libraries" dynlibdir (\v flags -> flags{dynlibdir = v}) + installDirArg + , option + "" + ["bytecodelibdir"] + "installation directory for bytecode libraries" + bytecodelibdir + (\v flags -> flags{bytecodelibdir = v}) installDirArg , option "" 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,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} @@ -57,7 +58,7 @@ deriving (Show, Generic) pattern CopyCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) @@ -111,12 +112,13 @@ ++ " copy foo " ++ " A component (i.e. lib, exe, test suite)" , commandUsage = - usageAlternatives "copy" $ + usageAlternatives + "copy" [ "[FLAGS]" , "COMPONENTS [FLAGS]" ] , commandDefaultFlags = defaultCopyFlags - , commandOptions = \showOrParseArgs -> case showOrParseArgs of + , commandOptions = \case ShowArgs -> filter ( (`notElem` ["target-package-db"]) @@ -144,7 +146,7 @@ ( reqArg "DIR" (succeedReadE (Flag . CopyTo)) - (\f -> case f of Flag (CopyTo p) -> [p]; _ -> []) + (\case Flag (CopyTo p) -> [p]; _ -> []) ) , option "" @@ -159,7 +161,7 @@ ( reqArg "DATABASE" (succeedReadE (Flag . CopyToDb)) - (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> []) + (\case Flag (CopyToDb p) -> [p]; _ -> []) ) ] diff --git a/src/Distribution/Simple/Setup/Global.hs b/src/Distribution/Simple/Setup/Global.hs --- a/src/Distribution/Simple/Setup/Global.hs +++ b/src/Distribution/Simple/Setup/Global.hs @@ -44,6 +44,7 @@ -- | Flags that apply at the top level, not to any sub-command. data GlobalFlags = GlobalFlags { globalVersion :: Flag Bool + , globalFullVersion :: Flag Bool , globalNumericVersion :: Flag Bool , globalWorkingDir :: Flag (SymbolicPath CWD (Dir Pkg)) } @@ -53,6 +54,7 @@ defaultGlobalFlags = GlobalFlags { globalVersion = Flag False + , globalFullVersion = Flag False , globalNumericVersion = Flag False , globalWorkingDir = NoFlag } @@ -100,6 +102,13 @@ "Print version information" globalVersion (\v flags -> flags{globalVersion = v}) + trueArg + , option + [] + ["full-version"] + "Print the version, Git revision if available, and compiler information" + globalFullVersion + (\v flags -> flags{globalFullVersion = v}) trueArg , option [] 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 @@ -75,6 +75,7 @@ data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic) instance Binary HaddockTarget +instance NFData HaddockTarget instance Structured HaddockTarget instance Pretty HaddockTarget where @@ -115,7 +116,7 @@ deriving (Show, Generic) pattern HaddockCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) @@ -177,7 +178,8 @@ "Requires the program haddock, version 2.x.\n" , commandNotes = Nothing , commandUsage = - usageAlternatives "haddock" $ + usageAlternatives + "haddock" [ "[FLAGS]" , "COMPONENTS [FLAGS]" ] @@ -203,8 +205,7 @@ where progDb = addKnownProgram haddockProgram $ - addKnownProgram ghcProgram $ - emptyProgramDb + addKnownProgram ghcProgram emptyProgramDb haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] haddockOptions showOrParseArgs = @@ -472,7 +473,8 @@ "Requires the program haddock, version 2.26.\n" , commandNotes = Nothing , commandUsage = - usageAlternatives "haddock-project" $ + usageAlternatives + "haddock-project" [ "[FLAGS]" , "COMPONENTS [FLAGS]" ] @@ -498,8 +500,7 @@ where progDb = addKnownProgram haddockProgram $ - addKnownProgram ghcProgram $ - emptyProgramDb + addKnownProgram ghcProgram emptyProgramDb haddockProjectOptions :: ShowOrParseArgs -> [OptionField HaddockProjectFlags] haddockProjectOptions showOrParseArgs = @@ -510,10 +511,7 @@ [ option "" ["hackage"] - ( concat - [ "A short-cut option to build documentation linked to hackage." - ] - ) + "A short-cut option to build documentation linked to hackage." haddockProjectHackage (\v flags -> flags{haddockProjectHackage = v}) trueArg diff --git a/src/Distribution/Simple/Setup/Hscolour.hs b/src/Distribution/Simple/Setup/Hscolour.hs --- a/src/Distribution/Simple/Setup/Hscolour.hs +++ b/src/Distribution/Simple/Setup/Hscolour.hs @@ -57,7 +57,7 @@ deriving (Show, Generic) pattern HscolourCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) @@ -112,7 +112,7 @@ "Generate HsColour colourised code, in HTML format." , commandDescription = Just (\_ -> "Requires the hscolour program.\n") , commandNotes = Just $ \_ -> - "Deprecated in favour of 'cabal haddock --hyperlink-source'." + "Deprecated in favour of 'cabal haddock --hyperlink-source'.\n" , commandUsage = \pname -> "Usage: " ++ pname ++ " hscolour [FLAGS]\n" , commandDefaultFlags = defaultHscolourFlags 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,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} @@ -61,7 +62,7 @@ deriving (Show, Generic) pattern InstallCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) @@ -168,7 +169,7 @@ ( reqArg "DATABASE" (succeedReadE (Flag . CopyToDb)) - (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> []) + (\case Flag (CopyToDb p) -> [p]; _ -> []) ) ] diff --git a/src/Distribution/Simple/Setup/Register.hs b/src/Distribution/Simple/Setup/Register.hs --- a/src/Distribution/Simple/Setup/Register.hs +++ b/src/Distribution/Simple/Setup/Register.hs @@ -61,7 +61,7 @@ deriving (Show, Generic) pattern RegisterCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) @@ -111,54 +111,54 @@ registerCommonFlags (\c f -> f{registerCommonFlags = c}) showOrParseArgs - $ [ option - "" - ["packageDB"] - "" - regPackageDB - (\v flags -> flags{regPackageDB = v}) - ( choiceOpt - [ - ( Flag UserPackageDB - , ([], ["user"]) - , "upon registration, register this package in the user's local package database" - ) - , - ( Flag GlobalPackageDB - , ([], ["global"]) - , "(default)upon registration, register this package in the system-wide package database" - ) - ] - ) - , option - "" - ["inplace"] - "register the package in the build location, so it can be used without being installed" - regInPlace - (\v flags -> flags{regInPlace = v}) - trueArg - , option - "" - ["gen-script"] - "instead of registering, generate a script to register later" - regGenScript - (\v flags -> flags{regGenScript = v}) - trueArg - , option - "" - ["gen-pkg-config"] - "instead of registering, generate a package registration file/directory" - regGenPkgConf - (\v flags -> flags{regGenPkgConf = v}) - (optArg' "PKG" (Flag . fmap makeSymbolicPath) (flagToList . fmap (fmap getSymbolicPath))) - , option - "" - ["print-ipid"] - "print the installed package ID calculated for this package" - regPrintId - (\v flags -> flags{regPrintId = v}) - trueArg - ] + [ option + "" + ["packageDB"] + "" + regPackageDB + (\v flags -> flags{regPackageDB = v}) + ( choiceOpt + [ + ( Flag UserPackageDB + , ([], ["user"]) + , "upon registration, register this package in the user's local package database" + ) + , + ( Flag GlobalPackageDB + , ([], ["global"]) + , "(default)upon registration, register this package in the system-wide package database" + ) + ] + ) + , option + "" + ["inplace"] + "register the package in the build location, so it can be used without being installed" + regInPlace + (\v flags -> flags{regInPlace = v}) + trueArg + , option + "" + ["gen-script"] + "instead of registering, generate a script to register later" + regGenScript + (\v flags -> flags{regGenScript = v}) + trueArg + , option + "" + ["gen-pkg-config"] + "instead of registering, generate a package registration file/directory" + regGenPkgConf + (\v flags -> flags{regGenPkgConf = v}) + (optArg' "PKG" (Flag . fmap makeSymbolicPath) (flagToList . fmap (fmap getSymbolicPath))) + , option + "" + ["print-ipid"] + "print the installed package ID calculated for this package" + regPrintId + (\v flags -> flags{regPrintId = v}) + trueArg + ] } unregisterCommand :: CommandUI RegisterFlags @@ -177,33 +177,33 @@ registerCommonFlags (\c f -> f{registerCommonFlags = c}) showOrParseArgs - $ [ option - "" - ["user"] - "" - regPackageDB - (\v flags -> flags{regPackageDB = v}) - ( choiceOpt - [ - ( Flag UserPackageDB - , ([], ["user"]) - , "unregister this package in the user's local package database" - ) - , - ( Flag GlobalPackageDB - , ([], ["global"]) - , "(default) unregister this package in the system-wide package database" - ) - ] - ) - , option - "" - ["gen-script"] - "Instead of performing the unregister command, generate a script to unregister later" - regGenScript - (\v flags -> flags{regGenScript = v}) - trueArg - ] + [ option + "" + ["user"] + "" + regPackageDB + (\v flags -> flags{regPackageDB = v}) + ( choiceOpt + [ + ( Flag UserPackageDB + , ([], ["user"]) + , "unregister this package in the user's local package database" + ) + , + ( Flag GlobalPackageDB + , ([], ["global"]) + , "(default) unregister this package in the system-wide package database" + ) + ] + ) + , option + "" + ["gen-script"] + "Instead of performing the unregister command, generate a script to unregister later" + regGenScript + (\v flags -> flags{regGenScript = v}) + trueArg + ] } emptyRegisterFlags :: RegisterFlags 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 @@ -59,7 +59,7 @@ deriving (Show, Generic) pattern ReplCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) diff --git a/src/Distribution/Simple/Setup/SDist.hs b/src/Distribution/Simple/Setup/SDist.hs --- a/src/Distribution/Simple/Setup/SDist.hs +++ b/src/Distribution/Simple/Setup/SDist.hs @@ -56,7 +56,7 @@ deriving (Show, Generic) pattern SDistCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) 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 @@ -60,6 +60,7 @@ deriving (Eq, Ord, Enum, Bounded, Generic, Show) instance Binary TestShowDetails +instance NFData TestShowDetails instance Structured TestShowDetails knownTestShowDetails :: [TestShowDetails] @@ -85,7 +86,7 @@ mappend = (<>) instance Semigroup TestShowDetails where - a <> b = if a < b then b else a + a <> b = max a b data TestFlags = TestFlags { testCommonFlags :: !CommonSetupFlags @@ -101,7 +102,7 @@ deriving (Show, Generic) pattern TestCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) @@ -131,8 +132,8 @@ defaultTestFlags = TestFlags { testCommonFlags = defaultCommonSetupFlags - , testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log" - , testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log" + , testHumanLog = toFlag $ toPathTemplate "$pkgid-$test-suite.log" + , testMachineLog = toFlag $ toPathTemplate "$pkgid.log" , testShowDetails = toFlag Direct , testKeepTix = toFlag False , testWrapper = NoFlag @@ -237,7 +238,7 @@ , option [] ["fail-when-no-test-suites"] - ("Exit with failure when no test suites are found.") + "Exit with failure when no test suites are found." testFailWhenNoTestSuites (\v flags -> flags{testFailWhenNoTestSuites = v}) trueArg diff --git a/src/Distribution/Simple/SetupHooks/Errors.hs b/src/Distribution/Simple/SetupHooks/Errors.hs --- a/src/Distribution/Simple/SetupHooks/Errors.hs +++ b/src/Distribution/Simple/SetupHooks/Errors.hs @@ -28,9 +28,6 @@ import Distribution.Types.Component import qualified Data.Graph as Graph -import Data.List - ( intercalate - ) import qualified Data.List.NonEmpty as NE import qualified Data.Tree as Tree @@ -129,7 +126,7 @@ showCycle (r, rs) = unlines . map (" " ++) . lines $ Tree.drawTree $ - fmap showRule $ + fmap show $ Tree.Node r rs CantFindSourceForRuleDependencies _r deps -> unlines $ @@ -170,24 +167,11 @@ "The index is too large." plural = if nbOutputs == 1 then "" else "s" DuplicateRuleId rId r1 r2 -> - unlines $ + unlines [ "Duplicate pre-build rule (" <> show rId <> ")" - , " - " <> showRule (ruleBinary r1) - , " - " <> showRule (ruleBinary r2) + , " - " <> show (ruleBinary r1) + , " - " <> show (ruleBinary r2) ] - where - showRule :: RuleBinary -> String - showRule (Rule{staticDependencies = deps, results = reslts}) = - "Rule: " ++ showDeps deps ++ " --> " ++ show (NE.toList reslts) - -showDeps :: [Rule.Dependency] -> String -showDeps deps = "[" ++ intercalate ", " (map showDep deps) ++ "]" - -showDep :: Rule.Dependency -> String -showDep = \case - RuleDependency (RuleOutput{outputOfRule = rId, outputIndex = i}) -> - "(" ++ show rId ++ ")[" ++ show i ++ "]" - FileDependency loc -> show loc cannotApplyComponentDiffCode :: CannotApplyComponentDiffReason -> Int cannotApplyComponentDiffCode = \case diff --git a/src/Distribution/Simple/SetupHooks/HooksMain.hs b/src/Distribution/Simple/SetupHooks/HooksMain.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/SetupHooks/HooksMain.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} + +-- | Implementation of hooks executables for @build-type: Hooks@ packages. +-- +-- A hooks executable is a small program compiled from the @SetupHooks.hs@ +-- module of a package with @build-type: Hooks@. Its @main@ function is: +-- +-- > import Distribution.Simple.SetupHooks.HooksMain (hooksMain) +-- > import SetupHooks (setupHooks) +-- > main = hooksMain setupHooks +-- +-- @cabal-install@ communicates with the external hooks executable to implement +-- the hooks in a package with @build-type: Hooks@. +module Distribution.Simple.SetupHooks.HooksMain + ( -- * Main entry point for hooks executables + hooksMain + + -- * Hooks version handshake + , HooksVersion (..) + , hooksVersion + , CabalABI (..) + , HooksABI (..) + ) where + +-- base +import Control.Monad + ( (>=>) + ) +import Control.Monad.IO.Class + ( liftIO + ) +import GHC.Exception +import System.Environment + ( getArgs + ) +import System.IO + ( Handle + , hClose + , hFlush + ) + +-- bytestring +import Data.ByteString.Lazy as LBS + ( ByteString + , hGetContents + , hPutStr + , null + ) + +-- containers +import qualified Data.Map as Map + +-- process +import System.Process.CommunicationHandle + ( openCommunicationHandleRead + , openCommunicationHandleWrite + ) + +-- transformers +import Control.Monad.Trans.Except + ( ExceptT + , runExceptT + , throwE + ) + +-- Cabal-syntax +import qualified Distribution.Compat.Binary as Binary + ( decodeOrFail + , encode + ) +import Distribution.Types.Version + ( Version + ) +import Distribution.Utils.Structured + ( MD5 + , structureHash + ) + +-- Cabal +import Distribution.Compat.Prelude +import Distribution.Simple.SetupHooks.Internal +import Distribution.Simple.SetupHooks.Rule +import Distribution.Simple.Utils + ( VerboseException (..) + , cabalVersion + , dieWithException + , exceptionWithMetadata + , withOutputMarker + ) +import Distribution.Types.Component + ( componentName + ) +import qualified Distribution.Types.LocalBuildConfig as LBC +import Distribution.Types.LocalBuildInfo + ( LocalBuildInfo + ) +import Distribution.Verbosity + ( Verbosity + , defaultVerbosityHandles + , mkVerbosity + ) +import qualified Distribution.Verbosity as Verbosity + ( normal + ) + +-------------------------------------------------------------------------------- +-- Hooks version + +-- | The version of the Hooks API in use. +-- +-- Used for handshake before beginning inter-process communication. +data HooksVersion = HooksVersion + { hooksAPIVersion :: !Version + , cabalABIHash :: !MD5 + , hooksABIHash :: !MD5 + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (Binary) + +-- | The version of the Hooks API built into this version of the Cabal library. +-- +-- Used for handshake before beginning inter-process communication. +hooksVersion :: HooksVersion +hooksVersion = + HooksVersion + { hooksAPIVersion = cabalVersion + , cabalABIHash = structureHash $ Proxy @CabalABI + , hooksABIHash = structureHash $ Proxy @HooksABI + } + +-- | Tracks the parts of the Cabal API relevant to its binary interface. +data CabalABI = CabalABI + { cabalLocalBuildInfo :: LocalBuildInfo + } + deriving stock (Generic) + +deriving anyclass instance Structured CabalABI + +-- | Tracks the parts of the Hooks API relevant to its binary interface. +data HooksABI = HooksABI + { confHooks + :: ( (PreConfPackageInputs, PreConfPackageOutputs) + , PostConfPackageInputs + , (PreConfComponentInputs, PreConfComponentOutputs) + ) + , buildHooks + :: ( PreBuildComponentInputs + , (RuleId, Rule, RuleBinary) + , PostBuildComponentInputs + ) + , installHooks :: InstallComponentInputs + } + deriving stock (Generic) + +deriving anyclass instance Structured HooksABI + +-------------------------------------------------------------------------------- +-- Error types (internal) + +data SetupHooksExeException + = -- | Missing hook type argument. + NoHookType + | -- | Could not parse a communication handle argument. + NoHandle (Maybe String) + | -- | Incorrect arguments passed to the hooks executable. + BadHooksExeArgs + String + -- ^ hook name + BadHooksExecutableArgs + deriving (Show) + +-- | An error describing an invalid argument passed to a hooks executable. +data BadHooksExecutableArgs + = -- | Unknown hook type was requested. + UnknownHookType + {knownHookTypes :: [String]} + | -- | Failed to decode the binary input to a hook. + CouldNotDecodeInput + ByteString + -- ^ hook input that failed to decode + Int64 + -- ^ byte offset at which decoding failed + String + -- ^ decoding error message + | -- | The rule does not have a dynamic dependency computation. + NoDynDepsCmd RuleId + deriving (Show) + +setupHooksExeExceptionCode :: SetupHooksExeException -> Int +setupHooksExeExceptionCode = \case + NoHookType -> 7982 + NoHandle{} -> 8811 + BadHooksExeArgs _ rea -> badHooksExeArgsCode rea + +setupHooksExeExceptionMessage :: SetupHooksExeException -> String +setupHooksExeExceptionMessage = \case + NoHookType -> + "Missing argument to Hooks executable.\n\ + \Expected two arguments: communication handle and hook type." + NoHandle Nothing -> + "Missing argument to Hooks executable.\n\ + \Expected two arguments: communication handle and hook type." + NoHandle (Just h) -> + "Invalid handle reference passed to Hooks executable: '" ++ h ++ "'." + BadHooksExeArgs hookName reason -> + badHooksExeArgsMessage hookName reason + +badHooksExeArgsCode :: BadHooksExecutableArgs -> Int +badHooksExeArgsCode = \case + UnknownHookType{} -> 4229 + CouldNotDecodeInput{} -> 9121 + NoDynDepsCmd{} -> 3231 + +badHooksExeArgsMessage :: String -> BadHooksExecutableArgs -> String +badHooksExeArgsMessage hookName = \case + UnknownHookType knownHookNames -> + "Unknown hook type " + ++ hookName + ++ ".\n\ + \Known hook types are: " + ++ show knownHookNames + ++ "." + CouldNotDecodeInput _bytes offset err -> + "Failed to decode the input to the " + ++ hookName + ++ " hook.\n\ + \Decoding failed at position " + ++ show offset + ++ " with error: " + ++ err + ++ ".\n\ + \This could be due to a mismatch between the Cabal version of cabal-install\ + \ and of the hooks executable." + NoDynDepsCmd rId -> + unlines + [ "Unexpected rule " <> show rId <> " in the " <> hookName <> " hook." + , "The rule does not have an associated dynamic dependency computation." + ] + +instance Exception (VerboseException SetupHooksExeException) where + displayException :: VerboseException SetupHooksExeException -> String + displayException (VerboseException stack timestamp verb err) = + withOutputMarker + verb + ( concat + [ "Error: [Cabal-" + , show (setupHooksExeExceptionCode err) + , "]\n" + ] + ) + ++ exceptionWithMetadata stack timestamp verb (setupHooksExeExceptionMessage err) + +-- | The verbosity used inside the hooks executable. +-- +-- The hooks executable is always invoked as a separate process, so stdout +-- and stderr are available for verbosity output and can be redirected via +-- the @System.Process@ API. +hooksExeVerbosity :: Verbosity +hooksExeVerbosity = mkVerbosity defaultVerbosityHandles Verbosity.normal + +-------------------------------------------------------------------------------- +-- Main entry point + +-- | Create a hooks executable @main@ given the package's 'SetupHooks'. +-- +-- The executable expects three command-line arguments: +-- +-- 1. A reference to an input communication handle (to read hook inputs from). +-- 2. A reference to an output communication handle (to write hook outputs to). +-- 3. The hook type to run. +-- +-- The hook reads binary-encoded data from the input handle, runs the +-- requested hook, and writes the binary-encoded result to the output handle. +hooksMain :: SetupHooks -> IO () +hooksMain setupHooks = runHooksM $ do + ((hRead, hWrite), hookName) <- getHooksMainArgs + case lookup hookName allHookHandlers of + Just handleAction -> + handleAction (hRead, hWrite) setupHooks + Nothing -> + throwE $ + BadHooksExeArgs hookName $ + UnknownHookType + { knownHookTypes = map fst allHookHandlers + } + where + allHookHandlers = [(hookName h, hookHandler h) | h <- hookHandlers] + + -- Get the communication handles and the name of the hook to run + getHooksMainArgs :: HooksM ((Handle, Handle), String) + getHooksMainArgs = + liftIO getArgs >>= \case + inputFdRef : outputFdRef : hookNm : _ -> + case (readMaybe inputFdRef, readMaybe outputFdRef) of + (Just readNm, Just writeNm) -> do + hRead <- liftIO $ openCommunicationHandleRead readNm + hWrite <- liftIO $ openCommunicationHandleWrite writeNm + return ((hRead, hWrite), hookNm) + (Nothing, _) -> + throwE $ NoHandle (Just $ "hook input communication handle '" ++ inputFdRef ++ "'") + (_, Nothing) -> + throwE $ NoHandle (Just $ "hook output communication handle '" ++ outputFdRef ++ "'") + _ -> throwE $ NoHandle Nothing + +type HooksM = ExceptT SetupHooksExeException IO + +runHooksM :: HooksM a -> IO a +runHooksM = runExceptT >=> either (dieWithException hooksExeVerbosity) pure + +-- | Run a hook by reading its input from a handle, invoking it, and writing +-- its output to another handle. +runHookHandle + :: forall inputs outputs + . (Binary inputs, Binary outputs) + => (Handle, Handle) + -- ^ Input and output communication handles + -> String + -- ^ Hook name (used in error messages) + -> (inputs -> HooksM outputs) + -- ^ The hook to run + -> HooksM () +runHookHandle (hRead, hWrite) hookName hook = do + inputsData <- liftIO $ LBS.hGetContents hRead + let mb_inputs = Binary.decodeOrFail inputsData + case mb_inputs of + Left (_, offset, err) -> + throwE $ + BadHooksExeArgs hookName $ + CouldNotDecodeInput inputsData offset err + Right (_, _, inputs) -> + hook inputs >>= \output -> liftIO $ do + let outputData = Binary.encode output + unless (LBS.null outputData) $ + LBS.hPutStr hWrite outputData + hFlush hWrite + hClose hWrite + +data HookHandler = HookHandler + { hookName :: !String + , hookHandler :: (Handle, Handle) -> SetupHooks -> HooksM () + } + +hookHandlers :: [HookHandler] +hookHandlers = + [ let hookName = "version" + in HookHandler hookName $ \h _ -> + runHookHandle h hookName $ \() -> + return hooksVersion + , let hookName = "preConfPackage" + noHook (PreConfPackageInputs{localBuildConfig = lbc}) = + return $ + PreConfPackageOutputs + { buildOptions = LBC.withBuildOptions lbc + , extraConfiguredProgs = Map.empty + } + in HookHandler hookName $ \h (SetupHooks{configureHooks = ConfigureHooks{..}}) -> + runHookHandle h hookName $ maybe noHook (liftIO .) preConfPackageHook + , let hookName = "postConfPackage" + noHook _ = return () + in HookHandler hookName $ \h (SetupHooks{configureHooks = ConfigureHooks{..}}) -> + runHookHandle h hookName $ maybe noHook (liftIO .) postConfPackageHook + , let hookName = "preConfComponent" + noHook (PreConfComponentInputs{component = c}) = + return $ PreConfComponentOutputs{componentDiff = emptyComponentDiff $ componentName c} + in HookHandler hookName $ \h (SetupHooks{configureHooks = ConfigureHooks{..}}) -> + runHookHandle h hookName $ maybe noHook (liftIO .) preConfComponentHook + , let hookName = "preBuildRules" + in HookHandler hookName $ \h (SetupHooks{buildHooks = BuildHooks{..}}) -> + runHookHandle h hookName $ \preBuildInputs -> + case preBuildComponentRules of + Nothing -> return (Map.empty, []) + Just pbcRules -> + liftIO $ + computeRules hooksExeVerbosity preBuildInputs pbcRules + , let hookName = "runPreBuildRuleDeps" + in HookHandler hookName $ \h _ -> + runHookHandle h hookName $ \(ruleId, ruleDeps) -> + case runRuleDynDepsCmd ruleDeps of + Nothing -> + throwE $ + BadHooksExeArgs hookName $ + NoDynDepsCmd ruleId + Just getDeps -> liftIO getDeps + , let hookName = "runPreBuildRule" + in HookHandler hookName $ \h _ -> + runHookHandle h hookName $ \(_ruleId :: RuleId, rExecCmd) -> + liftIO $ runRuleExecCmd rExecCmd + , let hookName = "postBuildComponent" + noHook _ = return () + in HookHandler hookName $ \h (SetupHooks{buildHooks = BuildHooks{..}}) -> + runHookHandle h hookName $ maybe noHook (liftIO .) postBuildComponentHook + , let hookName = "installComponent" + noHook _ = return () + in HookHandler hookName $ \h (SetupHooks{installHooks = InstallHooks{..}}) -> + runHookHandle h hookName $ maybe noHook (liftIO .) installComponentHook + ] 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 @@ -2,17 +2,22 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -- | -- Module: Distribution.Simple.SetupHooks.Internal -- --- Internal implementation module. +-- Internal implementation module for 'SetupHooks'. +-- -- Users of @build-type: Hooks@ should import "Distribution.Simple.SetupHooks" -- instead. module Distribution.Simple.SetupHooks.Internal @@ -77,6 +82,7 @@ -- ** Executing build rules , executeRules + , executeRulesUserOrSystem -- ** HookedBuildInfo compatibility code , hookedBuildInfoComponents @@ -88,7 +94,9 @@ import Prelude () import Distribution.Compat.Lens ((.~)) +import Distribution.ModuleName (ModuleName) import Distribution.PackageDescription +import Distribution.Pretty (prettyShow) import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler (Compiler (..)) import Distribution.Simple.Errors @@ -109,20 +117,29 @@ import Distribution.Simple.Utils import Distribution.System (Platform (..)) import Distribution.Utils.Path +import Distribution.Utils.Structured + ( structuredDecodeOrFailIO + , structuredEncodeFile + ) import qualified Distribution.Types.BuildInfo.Lens as BI (buildInfo) import Distribution.Types.LocalBuildConfig as LBC import Distribution.Types.TargetInfo import Distribution.Verbosity +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Coerce (coerce) +import Data.Either (fromRight) import qualified Data.Graph as Graph +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map +import Data.Monoid (Ap (..)) import qualified Data.Set as Set -import System.Directory (doesFileExist) +import System.Directory (doesFileExist, getModificationTime) +import qualified System.FilePath as FilePath -------------------------------------------------------------------------------- -- SetupHooks @@ -789,8 +806,8 @@ Just diff -> applyComponentDiff verbosity c diff Nothing -> return c -forComponents_ :: PackageDescription -> (Component -> IO ()) -> IO () -forComponents_ pd f = getConst $ traverseComponents (Const . f) pd +forComponents_ :: Applicative m => PackageDescription -> (Component -> m ()) -> m () +forComponents_ pd f = getAp . getConst $ traverseComponents (Const . Ap . f) pd applyComponentDiff :: Verbosity @@ -849,7 +866,11 @@ -- an external hooks executable. executeRulesUserOrSystem :: forall userOrSystem - . SScope userOrSystem + . ( Binary (RuleData userOrSystem) + , Structured (RuleData userOrSystem) + , Eq (RuleData userOrSystem) + ) + => SScope userOrSystem -> (RuleId -> RuleDynDepsCmd userOrSystem -> IO (Maybe ([Rule.Dependency], LBS.ByteString))) -> (RuleId -> RuleExecCmd userOrSystem -> IO ()) -> Verbosity @@ -858,6 +879,12 @@ -> Map RuleId (RuleData userOrSystem) -> IO () executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo allRules = do + -- Load the rule cache from the previous build. + -- Used to detect when rule definitions have changed. + oldRules <- handleDoesNotExist Map.empty $ do + -- NB: do a strict read to avoid retaining the file handle. + bs <- BS.readFile rulesCacheFile + fromRight Map.empty <$> structuredDecodeOrFailIO (LBS.fromStrict bs) -- Compute all extra dynamic dependency edges. dynDepsEdges <- flip Map.traverseMaybeWithKey allRules $ @@ -869,9 +896,9 @@ let (ruleGraph, ruleFromVertex, vertexFromRuleId) = Graph.graphFromEdges - [ (rule, rId, nub $ mapMaybe directRuleDependencyMaybe allDeps) + [ (rule, rId, ordNub $ mapMaybe directRuleDependencyMaybe allDeps) | (rId, rule) <- Map.toList allRules - , let dynDeps = fromMaybe [] (fst <$> Map.lookup rId dynDepsEdges) + , let dynDeps = maybe [] fst (Map.lookup rId dynDepsEdges) allDeps = staticDependencies rule ++ dynDeps ] @@ -890,20 +917,87 @@ , map (fmap ruleFromVertex) (v : vs) ) - -- Compute demanded rules. + -- Compute demanded rules: anything reachable from the roots, which are: -- - -- SetupHooks TODO: maybe requiring all generated modules to appear - -- in autogen-modules is excessive; we can look through all modules instead. + -- - autogen modules + -- - extra-c-sources, extra-asm-sources, ... that happen to be in the + -- autogen directory (this is the workaround for there being no + -- 'autogen' field for those) + -- - extra-bundled-libs + -- + -- This does not include autogen-includes, because .h files are required + -- during configure time, so not relevant for pre-build rules which are run + -- after configure. + autogenModPaths :: [RelativePath Source File] autogenModPaths = map (\m -> moduleNameSymbolicPath m <.> "hs") $ - autogenModules $ - componentBuildInfo $ - targetComponent tgtInfo - leafRule_maybe (rId, r) = - if any ((r `ruleOutputsLocation`) . (Location compAutogenDir)) autogenModPaths - then vertexFromRuleId rId - else Nothing - leafRules = mapMaybe leafRule_maybe $ Map.toList allRules + autogenModules compBuildInfo + autogenExtraSourcesPaths :: [RelativePath Source File] + autogenExtraSourcesPaths = + concatMap + (mapMaybe relativeToAutogen) + [ cSources compBuildInfo + , cxxSources compBuildInfo + , cmmSources compBuildInfo + , asmSources compBuildInfo + , jsSources compBuildInfo + ] + extraBundledLibsPaths :: [RelativePath Source File] + extraBundledLibsPaths = + map makeRelativePathEx $ + extraBundledLibs compBuildInfo + + -- Is this rule directly demanded (e.g. it generates a Haskell module + -- declared in the autogen-modules field)? If so, return the appropriate + -- demand graph vertex (conceptually a leaf vertex). + isLeafRule + :: (RuleId, RuleData scope) + -> Either (NotDemandedRuleReasons scope) Graph.Vertex + isLeafRule (rId, r@Rule{results = ruleOutputLocs}) + | let + normOuts = fmap normaliseLocation ruleOutputLocs + anyOut f = + any + ( \demandedPath -> + let normDemanded = normaliseLocation $ Location compAutogenDir demandedPath + in any (f normDemanded) normOuts + ) + , -- Autogen modules + anyOut (==) autogenModPaths + -- Extra source files + || anyOut (==) autogenExtraSourcesPaths + -- Extra bundled libraries + -- They may have any extension (.dll, .so.1.2.3, etc) + -- so simply allow all extensions. + || anyOut (\dmdLoc outLoc -> dmdLoc == dropExtensionLocation outLoc) extraBundledLibsPaths = + case vertexFromRuleId rId of + Just v -> Right v + Nothing -> + error $ + unlines + [ "internal error: no graph vertex for rule " ++ show rId + , "Rule: " ++ show rId + ] + | otherwise = + Left $ + NDRR + { nonDemandedRules = Map.singleton rId r + , nonAutogenHaskellModules = + Map.singleton + rId + [ fromString $ intercalate "." $ FilePath.splitDirectories hsPath + | Location _ outPath <- NE.toList (results r) + , (hsPath, ".hs") <- [FilePath.splitExtension (getSymbolicPath outPath)] + ] + , filesNotInAutogenFolders = + Map.singleton + rId + [ unsafeCoerceSymbolicPath fp + | Location base fp <- NE.toList (results r) + , Nothing <- [relativeToAutogen base] + ] + } + (nonDmdReasons, leafRules) = partitionEithers $ map isLeafRule $ Map.toList allRules demandedRuleVerts = Set.fromList $ concatMap (Graph.reachable ruleGraph) leafRules nonDemandedRuleVerts = Set.fromList (Graph.vertices ruleGraph) Set.\\ demandedRuleVerts @@ -922,54 +1016,41 @@ -- Emit a warning if there are non-demanded rules. unless (null nonDemandedRuleVerts) $ warn verbosity $ - unlines $ - "The following rules are not demanded and will not be run:" - : concat - [ [ " - " ++ show rId ++ "," - , " generating " ++ show (NE.toList $ results r) - ] - | v <- Set.toList nonDemandedRuleVerts - , let (r, rId, _) = ruleFromVertex v - ] - ++ [ "Possible reasons for this error:" - , " - Some autogenerated modules were not declared" - , " (in the package description or in the pre-configure hooks)" - , " - The output location for an autogenerated module is incorrect," - , " (e.g. the file extension is incorrect, or" - , " it is not in the appropriate 'autogenComponentModules' directory)" - ] + pprNotDemandedRuleReasons comp compAutogenDir (mconcat nonDmdReasons) - -- Run all the demanded rules, in dependency order. + -- Run all the demanded rules, in dependency order, propagating staleness. + staleRulesRef <- newIORef Set.empty for_ sccs $ \(Graph.Node ruleVertex _) -> -- Don't run a rule unless it is demanded. unless (ruleVertex `Set.member` nonDemandedRuleVerts) $ do - let ( r@Rule - { ruleCommands = cmds - , staticDependencies = staticDeps - , results = reslts - } - , rId - , _staticRuleDepIds - ) = - ruleFromVertex ruleVertex - mbDyn = Map.lookup rId dynDepsEdges - allDeps = staticDeps ++ fromMaybe [] (fst <$> mbDyn) + let (r, rId, _staticRuleDepIds) = ruleFromVertex ruleVertex + Rule{ruleCommands, staticDependencies, results} = r + mbDynDeps = Map.lookup rId dynDepsEdges + allDeps = staticDependencies ++ maybe [] fst mbDynDeps -- Check that the dependencies the rule expects are indeed present. resolvedDeps <- traverse (resolveDependency verbosity rId allRules) allDeps missingRuleDeps <- filterM (missingDep mbWorkDir) resolvedDeps case NE.nonEmpty missingRuleDeps of Just missingDeps -> errorOut $ CantFindSourceForRuleDependencies (toRuleBinary r) missingDeps - -- Dependencies OK: run the associated action. + -- Dependencies OK: check whether the rule is up to date before + -- deciding to run it. Nothing -> do - let execCmd = ruleExecCmd scope cmds (snd <$> mbDyn) - runCmdData rId execCmd - -- Throw an error if running the action did not result in - -- the generation of outputs that we expected it to. - missingRuleResults <- filterM (missingDep mbWorkDir) $ NE.toList reslts - for_ (NE.nonEmpty missingRuleResults) $ \missingResults -> - errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults - return () + let dynDeps = maybe [] fst mbDynDeps + ruleUpToDate mbWorkDir oldRules staleRulesRef rId r dynDeps >>= \case + True -> + info verbosity $ + "Rule " ++ show rId ++ " is up to date; skipping." + False -> do + modifyIORef' staleRulesRef (Set.insert rId) + runCmdData rId $ ruleExecCmd scope ruleCommands (snd <$> mbDynDeps) + -- Throw an error if running the action did not result in + -- the generation of outputs that we expected it to. + missingRuleResults <- filterM (missingDep mbWorkDir) $ NE.toList results + for_ (NE.nonEmpty missingRuleResults) $ \missingResults -> + errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults + -- Save the current rules to the cache for use in the next build. + structuredEncodeFile rulesCacheFile allRules where toRuleBinary :: RuleData userOrSystem -> RuleBinary toRuleBinary = case scope of @@ -977,16 +1058,140 @@ SSystem -> id clbi = targetCLBI tgtInfo mbWorkDir = mbWorkDirLBI lbi + comp = targetComponent tgtInfo compAutogenDir = autogenComponentModulesDir lbi clbi + rulesCacheFile = interpretSymbolicPath mbWorkDir (preBuildRulesCacheFile lbi clbi) + compBuildInfo = componentBuildInfo comp errorOut e = dieWithException verbosity $ SetupHooksException $ RulesException e + relativeToAutogen :: SymbolicPath Pkg to -> Maybe (RelativePath Source to) + relativeToAutogen = relativePathMaybe compAutogenDir + +-- | Collects why certain rules were not demanded (and thus not run), in order +-- to construct an error message to report to the user. +data NotDemandedRuleReasons scope = NDRR + { nonDemandedRules :: Map RuleId (RuleData scope) + -- ^ The rules that were not demanded + , nonAutogenHaskellModules :: Map RuleId [ModuleName] + -- ^ Rules that generate Haskell files that are not declared as + -- autogenerated modules. + , filesNotInAutogenFolders :: Map RuleId [RelativePath Pkg File] + -- ^ Rules that generate files that aren't in the appropriate autogen + -- directory. + } + +instance Semigroup (NotDemandedRuleReasons scope) where + NDRR r1 m1 f1 <> NDRR r2 m2 f2 = NDRR (r1 <> r2) (m1 <> m2) (f1 <> f2) +instance Monoid (NotDemandedRuleReasons scope) where + mempty = NDRR mempty mempty mempty + +pprNotDemandedRuleReasons + :: Component + -> SymbolicPath Pkg (Dir Source) + -> NotDemandedRuleReasons scope + -> String +pprNotDemandedRuleReasons + comp + compAutogenDir + (NDRR non_dmd_verts mods_map miss_files_map) = + unlines $ header ++ mods_lines ++ files_lines + where + mods = tagByRuleId mods_map + miss_files = tagByRuleId miss_files_map + + tagByRuleId xs = concatMap (\(rId, x) -> map (rId,) x) $ Map.toList xs + ppr (rId, x) = " - " ++ prettyShow x ++ " (for rule " ++ show (ruleName rId) ++ ")" + + header :: [String] + header = + "The following rules are not demanded and will not be run:" + : concat + [ [ " - " ++ show rId ++ "," + , " generating " ++ show (NE.toList $ results r) + ] + | (rId, r) <- Map.toList non_dmd_verts + ] + + mods_lines, files_lines :: [String] + mods_lines + | null mods = + [] + | otherwise = + ("Perhaps add the following to the 'autogen-modules' field of the " ++ showComponentName (componentName comp) ++ " component.") + : map ppr mods + files_lines + | null miss_files = + [] + | otherwise = + ("The following autogenerated file" ++ s ++ " for the " ++ showComponentName (componentName comp) ++ " component " ++ isOrAre ++ " misplaced.") + : (itOrThey ++ " should go in " ++ show compAutogenDir ++ "'.") + : map ppr miss_files + where + (s, isOrAre, itOrThey) = + case miss_files of + [_] -> ("", "is", "It") + _ -> ("s", "are", "They") + directRuleDependencyMaybe :: Rule.Dependency -> Maybe RuleId directRuleDependencyMaybe (RuleDependency dep) = Just $ outputOfRule dep directRuleDependencyMaybe (FileDependency{}) = Nothing +-- | Is the rule up to date (so that we can skip re-running it)? +-- +-- As per the SetupHooks documentation, a rule must be re-run if: +-- +-- - [N] the rule is new, or +-- - [S] the rule matches with an old rule, and either: +-- - [S1] an input to the rule has changed (either a file or rule dependency) +-- - [S2] the rule itself has changed +ruleUpToDate + :: Eq (RuleData userOrSystem) + => Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory + -> Map RuleId (RuleData userOrSystem) + -- ^ old rules from the previous build + -> IORef (Set RuleId) + -- ^ rules that have been re-run + -> RuleId + -> RuleData userOrSystem + -> [Rule.Dependency] + -- ^ dynamic dependencies of this rule + -> IO Bool +ruleUpToDate mbWorkDir oldRules staleRulesRef rId rule dynDeps = do + staleRules <- readIORef staleRulesRef + if ruleChanged || any (`Set.member` staleRules) ruleDeps + then return False + else do + let maybeModTime fp = handleDoesNotExist Nothing $ Just <$> getModificationTime fp + outMtimes <- traverse maybeModTime outputPaths + case sequenceA outMtimes of + -- At least one output is missing: must run the rule. + Nothing -> return False + Just outs -> + -- Re-run if an input is more recent than the oldest output. + case inputPaths of + [] -> return True + _ -> do + inMtimes <- traverse getModificationTime inputPaths + return (minimum outs >= maximum inMtimes) + where + i (Location dir file) = interpretSymbolicPath mbWorkDir (dir file) + allDeps = staticDependencies rule ++ dynDeps + ruleDeps = [outputOfRule ro | RuleDependency ro <- allDeps] + fileDeps = [loc | FileDependency loc <- allDeps] + inputPaths = map i fileDeps + outputPaths = fmap i (results rule) + ruleChanged = + case Map.lookup rId oldRules of + Just oldRule -> + -- Use the Eq instance to determine if the rule has changed + -- (as documented in the API). + oldRule /= rule + Nothing -> True + resolveDependency :: Verbosity -> RuleId -> Map RuleId (RuleData scope) -> Rule.Dependency -> IO Location resolveDependency verbosity rId allRules = \case FileDependency l -> return l @@ -994,7 +1199,7 @@ case Map.lookup depId allRules of Nothing -> error $ - unlines $ + unlines [ "Internal error: missing rule dependency." , "Rule: " ++ show rId , "Dependency: " ++ show depId @@ -1012,14 +1217,13 @@ RulesException $ InvalidRuleOutputIndex rId depId os i --- | Does the rule output the given location? -ruleOutputsLocation :: RuleData scope -> Location -> Bool -ruleOutputsLocation (Rule{results = rs}) fp = - any (\out -> normaliseLocation out == normaliseLocation fp) rs - normaliseLocation :: Location -> Location normaliseLocation (Location base rel) = Location (normaliseSymbolicPath base) (normaliseSymbolicPath rel) + +dropExtensionLocation :: Location -> Location +dropExtensionLocation (Location base rel) = + Location base (makeRelativePathEx $ FilePath.dropExtensions $ getSymbolicPath rel) -- | Is the file we depend on missing? missingDep :: Maybe (SymbolicPath CWD (Dir Pkg)) -> Location -> IO Bool 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} @@ -124,11 +123,7 @@ ) import qualified Control.Monad.Trans.Reader as Reader import qualified Control.Monad.Trans.State as State -#if MIN_VERSION_transformers(0,5,6) import qualified Control.Monad.Trans.Writer.CPS as Writer -#else -import qualified Control.Monad.Trans.Writer.Strict as Writer -#endif import qualified Data.ByteString.Lazy as LBS import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map @@ -272,6 +267,8 @@ deriving stock instance Eq (RuleData System) deriving anyclass instance Binary (RuleData User) deriving anyclass instance Binary (RuleData System) +deriving anyclass instance Structured (RuleData User) +deriving anyclass instance Structured (RuleData System) -- | Trimmed down 'Show' instance, mostly for error messages. instance Show RuleBinary where @@ -292,12 +289,17 @@ -- | A rule with static dependencies. -- -- Prefer using this smart constructor instead of v'Rule' whenever possible. +-- +-- See also 'dynamicRule' which adds support for dynamic dependencies. staticRule :: forall arg . Typeable arg => Command arg (IO ()) + -- ^ command to execute the rule -> [Dependency] + -- ^ static dependencies of the rule -> NE.NonEmpty Location + -- ^ rule results -> Rule staticRule cmd dep res = Rule @@ -310,17 +312,32 @@ , results = res } --- | A rule with dynamic dependencies. +-- | A rule with dynamic dependencies, which consists of two parts: -- +-- - a dynamic dependency computation, that returns additional edges to +-- be added to the build graph, together with an additional piece of data, +-- - the command to execute the rule itself, which receives the additional +-- piece of data returned by the dependency computation. +-- -- Prefer using this smart constructor instead of v'Rule' whenever possible. +-- +-- Use 'staticRule' if you do not have any dynamic dependencies. dynamicRule :: forall depsArg depsRes arg . (Typeable depsArg, Typeable depsRes, Typeable arg) => StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes)) + -- ^ evidence that the result of the dynamic dependency command + -- is serialisable -> Command depsArg (IO ([Dependency], depsRes)) + -- ^ dynamic dependency computation, returning dynamic dependencies + -- and an additional piece of data to be consumed by the main rule command -> Command arg (depsRes -> IO ()) + -- ^ main rule command; takes in the piece of data returned by the dyn-deps + -- command -> [Dependency] + -- ^ static dependencies of the rule -> NE.NonEmpty Location + -- ^ rule results -> Rule dynamicRule dict depsCmd action dep res = Rule @@ -627,6 +644,9 @@ -- - for a rule with static dependencies, a single command, -- - for a rule with dynamic dependencies, a command for computing dynamic -- dependencies, and a command for executing the rule. +-- +-- Prefer using 'staticRule' and 'dynamicRule' instead of the (internal) +-- constructors of 'RuleCommands'. data RuleCommands (scope :: Scope) @@ -678,6 +698,10 @@ } -> RuleCommands scope deps ruleCmd +-- NB: whenever you change this datatype, you **must** also update its +-- 'Structured' instance. The structure hash is used as a handshake when +-- communicating with an external hooks executable. + {- Note [Hooks Binary instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Hooks API is strongly typed: users can declare rule commands with varying @@ -824,7 +848,7 @@ Just $ do (deps, dynDeps) <- runCommand depsCmd -- See Note [Hooks Binary instances] - return $ (deps, Binary.encode $ ScopedArgument @User dynDeps) + 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. @@ -1085,6 +1109,35 @@ -- | A token constructor used to define 'Structured' instances on types -- that involve existential quantification. data family Tok (arg :: Symbol) :: k + +instance + (Typeable scope, Typeable ruleCmd, Typeable deps) + => Structured (RuleCommands scope deps ruleCmd) + where + structure _ = + Structure + tr + 0 + (show tr) + [ + ( "StaticRuleCommand" + , + [ nominalStructure $ Proxy @(ruleCmd scope (Tok "arg") (IO ())) + , nominalStructure $ Proxy @(Typeable.TypeRep (Tok "arg" :: Hs.Type)) + ] + ) + , + ( "DynamicRuleCommands" + , + [ nominalStructure $ Proxy @(Static scope (Dict (Binary (Tok "depsRes"), Show (Tok "depsRes"), Eq (Tok "depsRes")))) + , nominalStructure $ Proxy @(deps scope (Tok "depsArg") (Tok "depsRes")) + , nominalStructure $ Proxy @(ruleCmd scope (Tok "arg") (Tok "depsRes" -> IO ())) + , nominalStructure $ Proxy @(Typeable.TypeRep (Tok "depsArg", Tok "depsRes", Tok "arg")) + ] + ) + ] + where + tr = Typeable.SomeTypeRep $ Typeable.typeRep @(RuleCommands scope deps ruleCmd) instance ( forall res. Binary (ruleCmd System LBS.ByteString res) 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 @@ -215,5 +215,5 @@ ghcArgs = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts baseOpts = - GHC.componentGhcOptions normal lbi bi clbi $ + GHC.componentGhcOptions Normal lbi bi clbi $ buildDir lbi diff --git a/src/Distribution/Simple/SrcDist.hs b/src/Distribution/Simple/SrcDist.hs --- a/src/Distribution/Simple/SrcDist.hs +++ b/src/Distribution/Simple/SrcDist.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -73,7 +74,8 @@ -- | Create a source distribution. sdist - :: PackageDescription + :: VerbosityHandles + -> PackageDescription -- ^ information from the tarball -> SDistFlags -- ^ verbosity & snapshot @@ -82,7 +84,7 @@ -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) -> IO () -sdist pkg flags mkTmpDir pps = do +sdist verbHandles pkg flags mkTmpDir pps = do distPref <- findDistPrefOrDefault $ setupDistPref common let targetPref = i distPref tmpTargetDir = mkTmpDir (i distPref) @@ -108,7 +110,7 @@ info verbosity $ "Source directory created: " ++ targetDir Nothing -> do createDirectoryIfMissingVerbose verbosity True tmpTargetDir - withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + withTempDirectory tmpTargetDir "sdist." $ \tmpDir -> do let targetDir = tmpDir tarBallName pkg' generateSourceDir targetDir pkg' targzFile <- createArchive verbosity pkg' tmpDir targetPref @@ -122,7 +124,7 @@ overwriteSnapshotPackageDesc verbosity pkg' targetDir common = sDistCommonFlags flags - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) mbWorkDir = flagToMaybe $ setupWorkingDir common i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path snapshot = fromFlag (sDistSnapshot flags) @@ -310,7 +312,7 @@ -> IO () prepareTree verbosity mbWorkDir pkg_descr0 targetDir pps = do ordinary <- listPackageSources verbosity mbWorkDir pkg_descr pps - installOrdinaryFiles verbosity targetDir (zip (repeat []) $ map i ordinary) + installOrdinaryFiles verbosity targetDir (map (([],) . i) ordinary) maybeCreateDefaultSetupScript targetDir where i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path @@ -397,11 +399,13 @@ -- @f@. Return the name of the file and the full path, or exit with error if -- there's no such file. findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath) -findIncludeFile verbosity _ [] f = dieWithException verbosity $ NoIncludeFileFound f -findIncludeFile verbosity cwd (d : ds) f = do - let path = d f - b <- doesFileExist (cwd path) - if b then return (f, path) else findIncludeFile verbosity cwd ds f +findIncludeFile verbosity cwd fs f = go fs + where + go [] = dieWithException verbosity $ NoIncludeFileFound f fs + go (d : ds) = do + let path = d f + b <- doesFileExist (cwd path) + if b then return (f, path) else go ds -- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' -- and 'other-modules'. @@ -428,7 +432,7 @@ filterFunction bi = \mn -> mn /= pathsModule && mn /= packageInfoModule - && not (mn `elem` autogenModules bi) + && notElem mn (autogenModules bi) -- | Prepare a directory tree of source files for a snapshot version. -- It is expected that the appropriate snapshot version has already been set @@ -512,10 +516,7 @@ let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" (tarProg, _) <- requireProgram verbosity tarProgram defaultProgramDb let formatOptSupported = - maybe False (== "YES") $ - Map.lookup - "Supports --format" - (programProperties tarProg) + Just "YES" == Map.lookup "Supports --format" (programProperties tarProg) runProgram verbosity tarProg $ -- Hmm: I could well be skating on thinner ice here by using the -C option -- (=> seems to be supported at least by GNU and *BSD tar) [The 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 @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- @@ -42,6 +43,7 @@ import qualified Distribution.Types.LocalBuildInfo as LBI import Distribution.Types.UnqualComponentName import Distribution.Utils.Path +import Distribution.Verbosity import Distribution.Simple.Configure (getInstalledPackagesById) import Distribution.Simple.Errors @@ -53,15 +55,14 @@ import Distribution.Types.LocalBuildInfo (LocalBuildInfo (..)) import System.Directory ( createDirectoryIfMissing - , doesFileExist - , getDirectoryContents - , removeFile + , listDirectory ) -- | Perform the \"@.\/setup test@\" action. test :: Args -- ^ positional command-line arguments + -> VerbosityHandles -> PD.PackageDescription -- ^ information from the .cabal file -> LBI.LocalBuildInfo @@ -69,10 +70,10 @@ -> TestFlags -- ^ flags sent to test -> IO () -test args pkg_descr lbi0 flags = do +test args verbHandles pkg_descr lbi0 flags = do curDir <- LBI.absoluteWorkingDirLBI lbi0 let common = testCommonFlags flags - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) distPref = fromFlag $ setupDistPref common i = LBI.interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path machineTemplate = fromFlag $ testMachineLog flags @@ -105,9 +106,9 @@ } case PD.testInterface suite of PD.TestSuiteExeV10 _ _ -> - ExeV10.runTest pkg_descr lbiForTest clbi hpcMarkupInfo flags suite + ExeV10.runTest verbHandles pkg_descr lbiForTest clbi hpcMarkupInfo flags suite PD.TestSuiteLibV09 _ _ -> - LibV09.runTest pkg_descr lbiForTest clbi hpcMarkupInfo flags suite + LibV09.runTest verbHandles pkg_descr lbiForTest clbi hpcMarkupInfo flags suite _ -> return TestSuiteLog @@ -132,7 +133,7 @@ dieWithException verbosity NoTestSuitesEnabled testsToRun <- case testNames of - [] -> return $ zip enabledTests $ repeat Nothing + [] -> return $ map (,Nothing) enabledTests names -> for names $ \tName -> let testMap = zip enabledNames enabledTests enabledNames = map (PD.testName . fst) enabledTests @@ -148,9 +149,8 @@ createDirectoryIfMissing True $ i testLogDir -- Delete ordinary files from test log directory. - getDirectoryContents (i testLogDir) - >>= filterM doesFileExist . map (i testLogDir ) - >>= traverse_ removeFile + listDirectory (i testLogDir) + >>= traverse_ (removeFileForcibly . (i testLogDir )) -- We configured the unit-ids of libraries we should cover in our coverage -- report at configure time into the local build info. At build time, we built @@ -159,7 +159,7 @@ -- Now, we get the path to the HPC artifacts and exposed modules of each -- library by querying the package database keyed by unit-id: let coverageFor = - nub $ + ordNub $ fromFlagOrDefault [] (configCoverageFor (configFlags lbi)) <> extraCoverageFor lbi ipkginfos <- getInstalledPackagesById verbosity lbi MissingCoveredInstalledLibrary coverageFor diff --git a/src/Distribution/Simple/Test/ExeV10.hs b/src/Distribution/Simple/Test/ExeV10.hs --- a/src/Distribution/Simple/Test/ExeV10.hs +++ b/src/Distribution/Simple/Test/ExeV10.hs @@ -20,6 +20,7 @@ , buildDir , depLibraryPaths ) + import Distribution.Simple.Program.Db import Distribution.Simple.Program.Find import Distribution.Simple.Program.Run @@ -27,7 +28,7 @@ import Distribution.Simple.Setup.Test import Distribution.Simple.Test.Log import Distribution.Simple.Utils -import Distribution.System +import Distribution.System (Platform (Platform)) import Distribution.TestSuite import qualified Distribution.Types.LocalBuildInfo as LBI ( LocalBuildInfo (..) @@ -43,22 +44,21 @@ import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI, packageRoot) import System.Directory ( createDirectoryIfMissing - , doesDirectoryExist , doesFileExist - , removeDirectoryRecursive + , removePathForcibly ) -import System.IO (stderr, stdout) import System.Process (createPipe) runTest - :: PD.PackageDescription + :: VerbosityHandles + -> PD.PackageDescription -> LBI.LocalBuildInfo -> LBI.ComponentLocalBuildInfo -> HPCMarkupInfo -> TestFlags -> PD.TestSuite -> IO TestSuiteLog -runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do +runTest verbHandles pkg_descr lbi clbi hpcMarkupInfo flags suite = do let isCoverageEnabled = LBI.testCoverage lbi way = guessWay lbi tixDir_ = i $ tixDir distPref way @@ -74,15 +74,14 @@ Couldn'tFindTestProgram cmd -- Remove old .tix files if appropriate. - unless (fromFlag $ testKeepTix flags) $ do - exists' <- doesDirectoryExist tixDir_ - when exists' $ removeDirectoryRecursive tixDir_ + unless (fromFlag $ testKeepTix flags) $ + removePathForcibly tixDir_ -- Create directory for HPC files. createDirectoryIfMissing True tixDir_ -- Write summary notices indicating start of test suite - notice verbosity $ summarizeSuiteStart $ testName' + notice verbosity $ summarizeSuiteStart testName' -- Run the test executable (with the appropriate environment set) let progDb = LBI.withPrograms lbi @@ -93,7 +92,7 @@ map (testOption pkg_descr lbi suite) (testOptions flags) - tixFile = packageRoot (testCommonFlags flags) getSymbolicPath (tixFilePath distPref way (testName')) + tixFile = packageRoot (testCommonFlags flags) getSymbolicPath (tixFilePath distPref way testName') shellEnv <- getFullEnvironment @@ -113,16 +112,17 @@ -- Output logger (wOut, wErr, getLogText) <- case details of - Direct -> return (stdout, stderr, return LBS.empty) + Direct -> return (Nothing, Nothing, return LBS.empty) _ -> do (rOut, wOut) <- createPipe - return $ (,,) wOut wOut $ do + return $ (,,) (Just wOut) (Just wOut) $ do -- Read test executables' output logText <- LBS.hGetContents rOut -- '--show-details=streaming': print the log output in another thread - when (details == Streaming) $ LBS.putStr logText + when (details == Streaming) $ + LBS.hPutStr (verbosityChosenOutputHandle verbosity) logText -- drain the output. evaluate (force logText) @@ -139,11 +139,10 @@ (cmd : opts) mbWorkDir (Just shellEnv') - getLogText - -- these handles are automatically closed + (\_ _ _ -> getLogText) Nothing - (Just wOut) - (Just wErr) + wOut + wErr NoFlag -> rawSystemIOWithEnvAndAction verbosity @@ -151,11 +150,10 @@ opts mbWorkDir (Just shellEnv') - getLogText - -- these handles are automatically closed + (\_ _ _ -> getLogText) Nothing - (Just wOut) - (Just wErr) + wOut + wErr -- Generate TestSuiteLog from executable exit code and a machine- -- readable test log. @@ -179,9 +177,9 @@ || details == Failures && not (suitePassed $ testLogs suiteLog) ) -- verbosity overrides show-details - && verbosity >= normal + && verbosityLevel verbosity >= Normal whenPrinting $ do - LBS.putStr logText + LBS.hPutStr (verbosityChosenOutputHandle verbosity) logText putChar '\n' -- Write summary notice to terminal indicating end of test suite @@ -206,7 +204,7 @@ testName' = unUnqualComponentName $ PD.testName suite distPref = fromFlag $ setupDistPref commonFlags - verbosity = fromFlag $ setupVerbosity commonFlags + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonFlags) details = fromFlag $ testShowDetails flags testLogDir = distPref makeRelativePathEx "test" diff --git a/src/Distribution/Simple/Test/LibV09.hs b/src/Distribution/Simple/Test/LibV09.hs --- a/src/Distribution/Simple/Test/LibV09.hs +++ b/src/Distribution/Simple/Test/LibV09.hs @@ -46,25 +46,24 @@ import System.Directory ( canonicalizePath , createDirectoryIfMissing - , doesDirectoryExist , doesFileExist , getCurrentDirectory - , removeDirectoryRecursive - , removeFile + , removePathForcibly , setCurrentDirectory ) import System.IO (hClose, hPutStr) import qualified System.Process as Process runTest - :: PD.PackageDescription + :: VerbosityHandles + -> PD.PackageDescription -> LBI.LocalBuildInfo -> LBI.ComponentLocalBuildInfo -> HPCMarkupInfo -> TestFlags -> PD.TestSuite -> IO TestSuiteLog -runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do +runTest verbHandles pkg_descr lbi clbi hpcMarkupInfo flags suite = do let isCoverageEnabled = LBI.testCoverage lbi way = guessWay lbi @@ -82,9 +81,8 @@ Couldn'tFindTestProgLibV09 cmd -- Remove old .tix files if appropriate. - unless (fromFlag $ testKeepTix flags) $ do - exists' <- doesDirectoryExist tDir - when exists' $ removeDirectoryRecursive tDir + unless (fromFlag $ testKeepTix flags) $ + removePathForcibly tDir -- Create directory for HPC files. createDirectoryIfMissing True tDir @@ -92,7 +90,7 @@ -- Write summary notices indicating start of test suite notice verbosity $ summarizeSuiteStart testName' - suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do + suiteLog <- CE.bracket openCabalTemp removeFileForcibly $ \tempLog -> do -- Compute the appropriate environment for running the test suite let progDb = LBI.withPrograms lbi pathVar = progSearchPath progDb @@ -183,9 +181,9 @@ when $ (details > Never) && (not (suitePassed $ testLogs suiteLog) || details == Always) - && verbosity >= normal + && verbosityLevel verbosity >= Normal whenPrinting $ do - LBS.putStr logText + LBS.hPutStr (verbosityChosenOutputHandle verbosity) logText putChar '\n' return suiteLog @@ -210,17 +208,13 @@ common = testCommonFlags flags testName' = unUnqualComponentName $ PD.testName suite - deleteIfExists file = do - exists <- doesFileExist file - when exists $ removeFile file - testLogDir = distPref makeRelativePathEx "test" openCabalTemp = do (f, h) <- openTempFile (i testLogDir) $ "cabal-test-" <.> "log" hClose h >> return f distPref = fromFlag $ setupDistPref common - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path. @@ -312,7 +306,7 @@ where stubRunTests' (Test t) = do l <- run t >>= finish - summarizeTest normal Always l + summarizeTest (mkVerbosity defaultVerbosityHandles normal) Always l return l where finish (Finished result) = @@ -328,7 +322,7 @@ return $ GroupLogs (groupName g) logs stubRunTests' (ExtraOptions _ t) = stubRunTests' t maybeDefaultOption opt = - maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt + (\d -> Just (optionName opt, d)) =<< optionDefault opt defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst -- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling 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 @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -77,6 +78,7 @@ , compilerLanguages = uhcLanguages , compilerExtensions = uhcLanguageExtensions , compilerProperties = Map.empty + , compilerWiredInUnitIds = Nothing } compPlatform = Nothing return (comp, compPlatform, progdb') @@ -120,18 +122,17 @@ let compilerid = compilerId comp systemPkgDir <- getGlobalPackageDir verbosity progdb userPkgDir <- getUserPackageDir - let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir mbWorkDir) packagedbs) + let pkgDirs = ordNub (concatMap (packageDbPaths userPkgDir systemPkgDir mbWorkDir) packagedbs) -- putStrLn $ "pkgdirs: " ++ show pkgDirs pkgs <- - liftM (map addBuiltinVersions . concat) $ - traverse - (\d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d)) + map addBuiltinVersions . concat + <$> traverse + (\d -> listDirectory d >>= filterM (isPkgDir (prettyShow compilerid) d)) pkgDirs -- putStrLn $ "pkgs: " ++ show pkgs let iPkgs = map mkInstalledPackageInfo $ - concatMap parsePackage $ - pkgs + concatMap parsePackage pkgs -- putStrLn $ "installed pkgs: " ++ show iPkgs return (fromList iPkgs) @@ -230,9 +231,7 @@ -- source files -- suboptimal: UHC does not understand module names, so -- we replace periods by path separators - ++ map - (map (\c -> if c == '.' then pathSeparator else c)) - (map prettyShow (allLibModules lib clbi)) + ++ map (map (\c -> if c == '.' then pathSeparator else c) . prettyShow) (allLibModules lib clbi) runUhcProg uhcArgs @@ -265,7 +264,7 @@ -- output file ++ ["--output", u $ buildDir lbi makeRelativePathEx (prettyShow (exeName exe))] -- main source module - ++ [u $ srcMainPath] + ++ [u srcMainPath] runUhcProg uhcArgs constructUHCCmdLine @@ -278,14 +277,7 @@ -> Verbosity -> [String] constructUHCCmdLine user system lbi bi clbi odir verbosity = - -- verbosity - ( if verbosity >= deafening - then ["-v4"] - else - if verbosity >= normal - then [] - else ["-v0"] - ) + vFlags ++ hcOptions UHC bi -- flags for language extensions ++ languageToFlags (compiler lbi) (defaultLanguage bi) @@ -297,7 +289,7 @@ ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi] -- search paths ++ ["-i" ++ u odir] - ++ ["-i" ++ u l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ u l | l <- ordNub (hsSourceDirs bi)] ++ ["-i" ++ u (autogenComponentModulesDir lbi clbi)] ++ ["-i" ++ u (autogenPackageModulesDir lbi)] -- cpp options @@ -312,6 +304,11 @@ ) where u = interpretSymbolicPathCWD -- See Note [Symbolic paths] in Distribution.Utils.Path + vFlags = + if + | verbosityLevel verbosity >= Deafening -> ["-v4"] + | verbosityLevel verbosity < Normal -> ["-v0"] + | otherwise -> [] uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] uhcPackageDbOptions user system db = @@ -328,11 +325,12 @@ -> FilePath -> FilePath -> FilePath + -> FilePath -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO () -installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do +installLib verbosity _lbi targetDir _dynlibTargetDir _bytecodeTargetDir builtDir pkg _library _clbi = do -- putStrLn $ "dest: " ++ targetDir -- putStrLn $ "built: " ++ builtDir installDirectoryContents verbosity (builtDir prettyShow (packageId pkg)) targetDir diff --git a/src/Distribution/Simple/UserHooks.hs b/src/Distribution/Simple/UserHooks.hs --- a/src/Distribution/Simple/UserHooks.hs +++ b/src/Distribution/Simple/UserHooks.hs @@ -13,7 +13,7 @@ -- -- This defines the API that @Setup.hs@ scripts can use to customise the way -- the build works. This module just defines the 'UserHooks' type. The --- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@ +-- predefined sets of hooks that implement the @Simple@ and @Configure@ -- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big -- record of functions. There are 3 for each action, a pre, post and the action -- itself. There are few other miscellaneous hooks, ones to extend the set of @@ -144,7 +144,7 @@ , hookedPreProcessors = [] , hookedPrograms = [] , preConf = rn' - , confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")) + , confHook = \_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.") , postConf = ru , preBuild = rn' , buildHook = ru 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 @@ -3,6 +3,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +#if MIN_VERSION_base(4,21,0) +{-# LANGUAGE ImplicitParams #-} +#endif {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} @@ -30,6 +33,7 @@ module Distribution.Simple.Utils ( cabalVersion , cabalGitInfo + , cabalCompilerInfo -- * logging and errors , dieNoVerbosity @@ -39,6 +43,7 @@ , dieNoWrap , topHandler , topHandlerWith + , isUserException , warn , warnError , notice @@ -92,6 +97,9 @@ , copyFileTo , copyFileToCwd + -- * removing files + , removeFileForcibly + -- * installing files , installOrdinaryFile , installExecutableFile @@ -205,11 +213,11 @@ import Distribution.Compat.Async (waitCatch, withAsyncNF) import Distribution.Compat.CopyFile -import Distribution.Compat.FilePath as FilePath import Distribution.Compat.Internal.TempFile import Distribution.Compat.Lens (Lens', over) import Distribution.Compat.Prelude import Distribution.Compat.Stack +import Distribution.Compat.SysInfo as SIC import Distribution.ModuleName as ModuleName import Distribution.Simple.Errors import Distribution.Simple.PreProcess.Types @@ -239,8 +247,10 @@ ( cast ) +import Control.Concurrent (threadDelay) import qualified Control.Exception as Exception import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) +import qualified Data.Version as DV import Distribution.Compat.Process (proc) import Foreign.C.Error (Errno (..), ePIPE) import qualified GHC.IO.Exception as GHC @@ -251,12 +261,12 @@ , createDirectory , doesDirectoryExist , doesFileExist - , getDirectoryContents , getModificationTime , getPermissions , getTemporaryDirectory - , removeDirectoryRecursive + , listDirectory , removeFile + , removePathForcibly ) import System.Environment ( getProgName @@ -264,11 +274,13 @@ import System.FilePath (takeFileName) import System.FilePath as FilePath ( getSearchPath + , isExtensionOf , joinPath , normalise , searchPathSeparator , splitDirectories , splitExtension + , stripExtension , takeDirectory ) import System.IO @@ -282,12 +294,14 @@ , hSetBinaryMode , hSetBuffering , stderr + , stdin , stdout ) import System.IO.Error import System.IO.Unsafe ( unsafeInterleaveIO ) +import qualified System.Info as SI import qualified System.Process as Process import qualified Text.PrettyPrint as Disp @@ -301,6 +315,10 @@ ) #endif +#if MIN_VERSION_base(4,21,0) +import Control.Exception.Context +#endif + -- We only get our own version number when we're building with ourselves cabalVersion :: Version #if defined(BOOTSTRAPPED_CABAL) @@ -321,20 +339,35 @@ else concat [ "(commit " , giHash' , branchInfo - , ", " - , either (const "") giCommitDate gi' + , either (const "") ((", " ++) . giCommitDate) gi' , ")" ] where gi' = $$tGitInfoCwdTry giHash' = take 7 . either (const "") giHash $ gi' + branch = either id giBranch gi' branchInfo | isLeft gi' = "" - | either id giBranch gi' == "master" = "" - | otherwise = " on " <> either id giBranch gi' + | branch == "master" = "" + | otherwise = " on " <> branch #else cabalGitInfo = "" #endif +-- | +-- `Cabal` compiler information, reported by `--version-full` but otherwise +-- unused. +cabalCompilerInfo :: String +cabalCompilerInfo = + concat + [ SI.compilerName + , " " + , intercalate "." (map show (DV.versionBranch SIC.fullCompilerVersion)) + , " on " + , SI.os + , " " + , SI.arch + ] + -- ---------------------------------------------------------------------------- -- Exception and logging utils @@ -422,19 +455,19 @@ die' verbosity msg = withFrozenCallStack $ do ioError . verbatimUserError =<< annotateErrorString verbosity - =<< pure . wrapTextVerbosity verbosity + =<< pure . wrapTextVerbosity (verbosityFlags verbosity) =<< pure . addErrorPrefix =<< prefixWithProgName msg -- Type which will be a wrapper for cabal -exceptions and cabal-install exceptions -data VerboseException a = VerboseException CallStack POSIXTime Verbosity a +data VerboseException a = VerboseException CallStack POSIXTime VerbosityFlags a deriving (Show) -- Function which will replace the existing die' call sites -dieWithException :: (HasCallStack, Show a1, Typeable a1, Exception (VerboseException a1)) => Verbosity -> a1 -> IO a +dieWithException :: (HasCallStack, Exception (VerboseException a1)) => Verbosity -> a1 -> IO a dieWithException verbosity exception = do ts <- getPOSIXTime - throwIO $ VerboseException callStack ts verbosity exception + throwIO $ VerboseException callStack ts (verbosityFlags verbosity) exception -- Instance for Cabal Exception which will display error code and error message with callStack info instance Exception (VerboseException CabalException) where @@ -483,7 +516,7 @@ annotateErrorString :: Verbosity -> String -> IO String annotateErrorString verbosity msg = do ts <- getPOSIXTime - return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg + return $ withMetadata ts AlwaysMark VerboseTrace (verbosityFlags verbosity) msg -- | Given a block of IO code that may raise an exception, annotate -- it with the metadata from the current scope. Use this as close @@ -495,7 +528,7 @@ ts <- getPOSIXTime flip modifyIOError act $ ioeModifyErrorString $ - withMetadata ts NeverMark VerboseTrace verbosity + withMetadata ts NeverMark VerboseTrace (verbosityFlags verbosity) -- | A semantic editor for the error message inside an 'IOError'. ioeModifyErrorString :: (String -> String) -> IOError -> IOError @@ -505,9 +538,22 @@ ioeErrorString :: Lens' IOError String ioeErrorString f ioe = ioeSetErrorString ioe <$> f (ioeGetErrorString ioe) +-- | Check that the type of the exception matches the given user error type. +isUserException :: forall user_err. Typeable user_err => Proxy user_err -> Exception.SomeException -> Bool +isUserException Proxy (SomeException se) = + case cast se :: Maybe user_err of + Just{} -> True + Nothing -> False + {-# NOINLINE topHandlerWith #-} -topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a -topHandlerWith cont prog = do +topHandlerWith + :: forall a + . (Exception.SomeException -> Bool) + -- ^ Identify when the error is an exception to display to users. + -> (Exception.SomeException -> IO a) + -> IO a + -> IO a +topHandlerWith is_user_exception cont prog = do -- By default, stderr to a terminal device is NoBuffering. But this -- is *really slow* hSetBuffering stderr LineBuffering @@ -535,7 +581,7 @@ cont se message :: String -> Exception.SomeException -> String - message pname (Exception.SomeException se) = + message pname e@(Exception.SomeException se) = case cast se :: Maybe Exception.IOException of Just ioe | ioeGetVerbatim ioe -> @@ -550,21 +596,27 @@ _ -> "" detail = ioeGetErrorString ioe in wrapText $ addErrorPrefix $ pname ++ ": " ++ file ++ detail - _ -> - displaySomeException se ++ "\n" + -- Don't print a call stack for a "user exception" + _ + | is_user_exception e -> displayException e + -- Other errors which have are not intended for user display, print with a callstack. + | otherwise -> displaySomeExceptionWithContext e ++ "\n" -- | BC wrapper around 'Exception.displayException'. -displaySomeException :: Exception.Exception e => e -> String -displaySomeException se = Exception.displayException se - -topHandler :: IO a -> IO a -topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog +displaySomeExceptionWithContext :: SomeException -> String +#if MIN_VERSION_base(4,21,0) +displaySomeExceptionWithContext (SomeException e) = + case displayExceptionContext ?exceptionContext of + "" -> msg + dc -> msg ++ "\n\n" ++ dc + where + msg = displayException e +#else +displaySomeExceptionWithContext e = displayException e +#endif --- | Depending on 'isVerboseStderr', set the output handle to 'stderr' or 'stdout'. -verbosityHandle :: Verbosity -> Handle -verbosityHandle verbosity - | isVerboseStderr verbosity = stderr - | otherwise = stdout +topHandler :: (Exception.SomeException -> Bool) -> IO a -> IO a +topHandler is_user_exception prog = topHandlerWith is_user_exception (const $ exitWith (ExitFailure 1)) prog -- | Non fatal conditions that may be indicative of an error or problem. -- @@ -581,13 +633,17 @@ -- | Warning message, with a custom label. warnMessage :: String -> Verbosity -> String -> IO () warnMessage l verbosity msg = withFrozenCallStack $ do - when ((verbosity >= normal) && not (isVerboseNoWarn verbosity)) $ do + when (verbosityLevel verbosity >= Normal && not (isVerboseNoWarn flags)) $ do ts <- getPOSIXTime - hFlush stdout - hPutStr stderr - . withMetadata ts NormalMark FlagTrace verbosity - . wrapTextVerbosity verbosity + let outHandle = verbosityChosenOutputHandle verbosity + errHandle = verbosityErrorHandle verbosity + hFlush outHandle + hPutStr errHandle + . withMetadata ts NormalMark FlagTrace flags + . wrapTextVerbosity flags $ l ++ ": " ++ msg + where + flags = verbosityFlags verbosity -- | Useful status messages. -- @@ -597,34 +653,35 @@ -- enough information to know that things are working but not floods of detail. notice :: Verbosity -> String -> IO () notice verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - let h = verbosityHandle verbosity + when (verbosityLevel verbosity >= Normal) $ do + let h = verbosityChosenOutputHandle verbosity + flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $ - withMetadata ts NormalMark FlagTrace verbosity $ - wrapTextVerbosity verbosity $ - msg + withMetadata ts NormalMark FlagTrace flags $ + wrapTextVerbosity flags msg -- | Display a message at 'normal' verbosity level, but without -- wrapping. noticeNoWrap :: Verbosity -> String -> IO () noticeNoWrap verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - let h = verbosityHandle verbosity + when (verbosityLevel verbosity >= Normal) $ do + let h = verbosityChosenOutputHandle verbosity + flags = verbosityFlags verbosity ts <- getPOSIXTime - hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ msg + hPutStr h . withMetadata ts NormalMark FlagTrace flags $ msg -- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity -- level. Use this if you need fancy formatting. noticeDoc :: Verbosity -> Disp.Doc -> IO () noticeDoc verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - let h = verbosityHandle verbosity + when (verbosityLevel verbosity >= Normal) $ do + let h = verbosityChosenOutputHandle verbosity + flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $ - withMetadata ts NormalMark FlagTrace verbosity $ - Disp.renderStyle defaultStyle $ - msg + withMetadata ts NormalMark FlagTrace flags $ + Disp.renderStyle defaultStyle msg -- | Display a "setup status message". Prefer using setupMessage' -- if possible. @@ -637,35 +694,35 @@ -- We display these messages when the verbosity level is 'verbose' info :: Verbosity -> String -> IO () info verbosity msg = withFrozenCallStack $ - when (verbosity >= verbose) $ do - let h = verbosityHandle verbosity + when (verbosityLevel verbosity >= Verbose) $ do + let h = verbosityChosenOutputHandle verbosity + flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $ - withMetadata ts NeverMark FlagTrace verbosity $ - wrapTextVerbosity verbosity $ - msg + withMetadata ts NeverMark FlagTrace flags $ + wrapTextVerbosity flags msg infoNoWrap :: Verbosity -> String -> IO () infoNoWrap verbosity msg = withFrozenCallStack $ - when (verbosity >= verbose) $ do - let h = verbosityHandle verbosity + when (verbosityLevel verbosity >= Verbose) $ do + let h = verbosityChosenOutputHandle verbosity + flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $ - withMetadata ts NeverMark FlagTrace verbosity $ - msg + withMetadata ts NeverMark FlagTrace flags msg -- | Detailed internal debugging information -- -- We display these messages when the verbosity level is 'deafening' debug :: Verbosity -> String -> IO () debug verbosity msg = withFrozenCallStack $ - when (verbosity >= deafening) $ do - let h = verbosityHandle verbosity + when (verbosityLevel verbosity >= Deafening) $ do + let h = verbosityChosenOutputHandle verbosity + flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $ - withMetadata ts NeverMark FlagTrace verbosity $ - wrapTextVerbosity verbosity $ - msg + withMetadata ts NeverMark FlagTrace flags $ + wrapTextVerbosity flags msg -- ensure that we don't lose output if we segfault/infinite loop hFlush stdout @@ -673,26 +730,27 @@ -- wrapping. Produces better output in some cases. debugNoWrap :: Verbosity -> String -> IO () debugNoWrap verbosity msg = withFrozenCallStack $ - when (verbosity >= deafening) $ do - let h = verbosityHandle verbosity + when (verbosityLevel verbosity >= Deafening) $ do + let h = verbosityChosenOutputHandle verbosity ts <- getPOSIXTime hPutStr h $ - withMetadata ts NeverMark FlagTrace verbosity $ - msg + withMetadata ts NeverMark FlagTrace (verbosityFlags verbosity) msg -- ensure that we don't lose output if we segfault/infinite loop hFlush stdout -- | Perform an IO action, catching any IO exceptions and printing an error -- if one occurs. chattyTry - :: String + :: Verbosity + -> String -- ^ a description of the action we were attempting -> IO () -- ^ the action itself -> IO () -chattyTry desc action = +chattyTry verbosity desc action = catchIO action $ \exception -> - hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception + hPutStrLn (verbosityErrorHandle verbosity) $ + "Error while " ++ desc ++ ": " ++ show exception -- | Run an IO computation, returning @e@ if it raises a "file -- does not exist" error. @@ -706,7 +764,7 @@ -- Helper functions -- | Wraps text unless the @+nowrap@ verbosity flag is active -wrapTextVerbosity :: Verbosity -> String -> String +wrapTextVerbosity :: VerbosityFlags -> String -> String wrapTextVerbosity verb | isVerboseNoWrap verb = withTrailingNewline | otherwise = withTrailingNewline . wrapText @@ -714,7 +772,7 @@ -- | Prepends a timestamp if @+timestamp@ verbosity flag is set -- -- This is used by 'withMetadata' -withTimestamp :: Verbosity -> POSIXTime -> String -> String +withTimestamp :: VerbosityFlags -> POSIXTime -> String -> String withTimestamp v ts msg | isVerboseTimestamp v = msg' | otherwise = msg -- no-op @@ -740,7 +798,7 @@ -- we don't have the ability to interpose on the output. -- -- This is used by 'withMetadata' -withOutputMarker :: Verbosity -> String -> String +withOutputMarker :: VerbosityFlags -> String -> String withOutputMarker v xs | not (isVerboseMarkOutput v) = xs withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly withOutputMarker _ xs = @@ -759,7 +817,7 @@ go _ "" = "\n" -- | Prepend a call-site and/or call-stack based on Verbosity -withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String) +withCallStackPrefix :: WithCallStack (TraceWhen -> VerbosityFlags -> String -> String) withCallStackPrefix tracer verbosity s = withFrozenCallStack $ ( if isVerboseCallSite verbosity @@ -791,9 +849,9 @@ -- | Determine if we should emit a call stack. -- If we trace, it also emits any prefix we should append. -traceWhen :: Verbosity -> TraceWhen -> Maybe String +traceWhen :: VerbosityFlags -> TraceWhen -> Maybe String traceWhen _ AlwaysTrace = Just "" -traceWhen v VerboseTrace | v >= verbose = Just "" +traceWhen v VerboseTrace | vLevel v >= Verbose = Just "" traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n" traceWhen _ _ = Nothing @@ -803,7 +861,7 @@ data MarkWhen = AlwaysMark | NormalMark | NeverMark -- | Add all necessary metadata to a logging message -withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String) +withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> VerbosityFlags -> String -> String) withMetadata ts marker tracer verbosity x = withFrozenCallStack $ @@ -826,7 +884,7 @@ $ x -- | Add all necessary metadata to a logging message -exceptionWithMetadata :: CallStack -> POSIXTime -> Verbosity -> String -> String +exceptionWithMetadata :: CallStack -> POSIXTime -> VerbosityFlags -> String -> String exceptionWithMetadata stack ts verbosity x = withTrailingNewline . exceptionWithCallStackPrefix stack verbosity @@ -843,7 +901,7 @@ isMarker _ = True -- | Append a call-site and/or call-stack based on Verbosity -exceptionWithCallStackPrefix :: CallStack -> Verbosity -> String -> String +exceptionWithCallStackPrefix :: CallStack -> VerbosityFlags -> String -> String exceptionWithCallStackPrefix stack verbosity s = s ++ withFrozenCallStack @@ -857,7 +915,7 @@ else "" else "" ) - ++ ( if verbosity >= verbose + ++ ( if vLevel verbosity >= Verbose then prettyCallStack stack ++ "\n" else "" ) @@ -909,18 +967,24 @@ -- the command's exit code. rawSystemExitCode :: Verbosity - -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> Maybe (SymbolicPath CWD (Dir to)) -> FilePath -> [String] -> Maybe [(String, String)] -> IO ExitCode rawSystemExitCode verbosity mbWorkDir path args menv = withFrozenCallStack $ - rawSystemProc verbosity $ - (proc path args) - { Process.cwd = fmap getSymbolicPath mbWorkDir - , Process.env = menv - } + fmap fst $ + rawSystemIOWithEnvAndAction + verbosity + path + args + (fmap getSymbolicPath mbWorkDir) + menv + (\_ _ _ -> return ()) + Nothing + Nothing + Nothing -- | Execute the given command with the given arguments, returning -- the command's exit code. @@ -948,7 +1012,7 @@ -> IO (ExitCode, a) rawSystemProcAction verbosity cp action = withFrozenCallStack $ do logCommand verbosity cp - (exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do + (exitcode, a) <- compatWithCreateProcess verbosity cp $ \mStdin mStdout mStderr p -> do a <- action mStdin mStdout mStderr exitcode <- Process.waitForProcess p return (exitcode, a) @@ -959,11 +1023,59 @@ debug verbosity $ cmd ++ " returned " ++ show exitcode return (exitcode, a) +-- | A version of 'Process.withCreateProcess' that is careful to not close +-- the handles stored in 'Verbosity'. +compatWithCreateProcess + :: Verbosity + -> Process.CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> Process.ProcessHandle -> IO a) + -> IO a +compatWithCreateProcess verbosity cp action = + Exception.bracket + create + Process.cleanupProcess + (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) + where + -- The 'process' documentation for 'createProcess'/'withCreateProcess' + -- states: + -- + -- Note that `Handle`s provided for `std_in`, `std_out`, or `std_err` via the + -- `UseHandle` constructor will be closed by calling this function. + -- + -- We don't want that, because we don't want the Verbosity handles being + -- closed if they are passed to the subprocess, which would prevent + -- us from continuing logging. + -- + -- To avoid this, we copy the implementation of 'withCreateProcess' in terms + -- of 'withCreateProcess_', but with special logic to avoid closing the + -- verbosity handles. + create = + Process.createProcess_ "createProcess" cp + `Exception.finally` do + maybeClose (Process.std_in cp) + maybeClose (Process.std_out cp) + maybeClose (Process.std_err cp) + + maybeClose :: Process.StdStream -> IO () + maybeClose (Process.UseHandle hdl) + | hdl + `elem` [ stdin + , stdout + , stderr + , vStdoutHandle (verbosityHandles verbosity) + , vStderrHandle (verbosityHandles verbosity) + ] -- Don't close the verbosity handles! + = + return () + | otherwise = + hClose hdl + maybeClose _ = return () + -- | fromJust for dealing with 'Maybe Handle' values as obtained via -- 'System.Process.CreatePipe'. Creating a pipe using 'CreatePipe' guarantees -- a 'Just' value for the corresponding handle. fromCreatePipe :: Maybe Handle -> Handle -fromCreatePipe = maybe (error "fromCreatePipe: Nothing") id +fromCreatePipe = fromMaybe (error "fromCreatePipe: Nothing") -- | Execute the given command with the given arguments and -- environment, exiting with the same exit code if the command fails. @@ -979,7 +1091,7 @@ -- | Like 'rawSystemExitWithEnv', but setting a working directory. rawSystemExitWithEnvCwd :: Verbosity - -> Maybe (SymbolicPath CWD to) + -> Maybe (SymbolicPath CWD (Dir to)) -> FilePath -> [String] -> [(String, String)] @@ -987,11 +1099,7 @@ rawSystemExitWithEnvCwd verbosity mbWorkDir path args env = withFrozenCallStack $ maybeExit $ - rawSystemProc verbosity $ - (proc path args) - { Process.env = Just env - , Process.cwd = getSymbolicPath <$> mbWorkDir - } + rawSystemExitCode verbosity mbWorkDir path args (Just env) -- | Execute the given command with the given arguments, returning -- the command's exit code. @@ -1021,7 +1129,7 @@ args mcwd menv - action + (\_ _ _ -> action) inp out err @@ -1040,11 +1148,12 @@ :: Verbosity -> FilePath -> [String] + -- ^ arguments -> Maybe FilePath -- ^ New working dir or inherit -> Maybe [(String, String)] -- ^ New environment or inherit - -> IO a + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a) -- ^ action to perform after process is created, but before 'waitForProcess'. -> Maybe Handle -- ^ stdin @@ -1053,20 +1162,31 @@ -> Maybe Handle -- ^ stderr -> IO (ExitCode, a) -rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do - let cp = - (proc path args) - { Process.cwd = mcwd - , Process.env = menv - , Process.std_in = mbToStd inp - , Process.std_out = mbToStd out - , Process.std_err = mbToStd err - } - rawSystemProcAction verbosity cp (\_ _ _ -> action) - where - mbToStd :: Maybe Handle -> Process.StdStream - mbToStd = maybe Process.Inherit Process.UseHandle +rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = + withFrozenCallStack $ do + -- If the output/error handle is Nothing, we need to use the corresponding + -- logging handle stored in 'Verbosity'. + let + outHandle = + case out of + Just h -> h + Nothing -> verbosityChosenOutputHandle verbosity + errHandle = + case err of + Just h -> h + Nothing -> verbosityErrorHandle verbosity + let cp = + (proc path args) + { Process.cwd = mcwd + , Process.env = menv + , Process.std_in = maybe Process.Inherit Process.UseHandle inp + , Process.std_out = Process.UseHandle outHandle + , Process.std_err = Process.UseHandle errHandle + } + + rawSystemProcAction verbosity cp action + -- | Execute the given command with the given arguments, returning -- the command's output. Exits if the command exits with error. -- @@ -1469,7 +1589,7 @@ recurseDirectories :: [FilePath] -> IO [FilePath] recurseDirectories [] = return [] recurseDirectories (dir : dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) + (files, dirs') <- collect [] [] =<< listDirectory (topdir dir) files' <- recurseDirectories (dirs' ++ dirs) return (files ++ files') where @@ -1478,9 +1598,6 @@ ( reverse files , reverse dirs' ) - collect files dirs' (entry : entries) - | ignore entry = - collect files dirs' entries collect files dirs' (entry : entries) = do let dirEntry = dir entry isDirectory <- doesDirectoryExist (topdir dirEntry) @@ -1488,10 +1605,6 @@ then collect files (dirEntry : dirs') entries else collect (dirEntry : files) dirs' entries - ignore ['.'] = True - ignore ['.', '.'] = True - ignore _ = False - ------------------------ -- Environment variables @@ -1561,7 +1674,7 @@ parents = reverse . scanl1 () . splitDirectories . normalise createDirs [] = return () - createDirs (dir : []) = createDir dir throwIO + createDirs [dir] = createDir dir throwIO createDirs (dir : dirs) = createDir dir $ \_ -> do createDirs dirs @@ -1624,7 +1737,7 @@ installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do perms <- getPermissions src - if (executable perms) -- only checks user x bit + if executable perms -- only checks user x bit then installExecutableFile verbosity src dest else installOrdinaryFile verbosity src dest @@ -1703,6 +1816,26 @@ copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs) +-- | A robust helper to remove an existing file, which does not throw +-- an exception if such file never existed, thus akin to removePathForcibly. +removeFileForcibly :: FilePath -> IO () +removeFileForcibly fp = catch (removeFile fp) $ \case + e + -- If the file never existed in the first place, we are golden. + | isDoesNotExistError e -> pure () + -- If we got a permission error, chances are that it's a read-only + -- file on Windows. Removing read-only attribute ourselves requires + -- reaching out for internal API, so instead of it we call 'removePathForcibly', + -- which is a bit of overkill for a single file, but well. + | isPermissionError e -> removePathForcibly fp + -- If device is busy, wait 1ms and give it another go. + -- EBUSY from unlink(2) is mapped to UnsatisfiedConstraints. + | ioeGetErrorType e == GHC.UnsatisfiedConstraints -> do + threadDelay 1000 + removeFile fp + -- Else we give up. + | otherwise -> throwIO e + -- | This is like 'copyFiles' but uses 'installOrdinaryFile'. installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs) @@ -1806,8 +1939,7 @@ hClose handle unless (optKeepTempFiles opts) $ handleDoesNotExist () $ - removeFile $ - name + removeFile name ) (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg tmp fn) h)) where @@ -1826,20 +1958,18 @@ -- Creates a new temporary directory inside the given directory, making use -- of the template. The temp directory is deleted after use. For example: -- --- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... +-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... -- -- The @tmpDir@ will be a new subdirectory of the given directory, e.g. -- @src/sdist.342@. withTempDirectory - :: Verbosity - -> FilePath + :: FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectory verb targetDir template f = +withTempDirectory targetDir template f = withFrozenCallStack $ withTempDirectoryCwd - verb Nothing (makeSymbolicPath targetDir) template @@ -1850,22 +1980,20 @@ -- Creates a new temporary directory inside the given directory, making use -- of the template. The temp directory is deleted after use. For example: -- --- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... +-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... -- -- The @tmpDir@ will be a new subdirectory of the given directory, e.g. -- @src/sdist.342@. withTempDirectoryCwd - :: Verbosity - -> Maybe (SymbolicPath CWD (Dir Pkg)) + :: Maybe (SymbolicPath CWD (Dir Pkg)) -- ^ Working directory -> SymbolicPath Pkg (Dir tmpDir1) -> String -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a) -> IO a -withTempDirectoryCwd verbosity mbWorkDir targetDir template f = +withTempDirectoryCwd mbWorkDir targetDir template f = withFrozenCallStack $ withTempDirectoryCwdEx - verbosity defaultTempFileOptions mbWorkDir targetDir @@ -1875,37 +2003,34 @@ -- | A version of 'withTempDirectory' that additionally takes a -- 'TempFileOptions' argument. withTempDirectoryEx - :: Verbosity - -> TempFileOptions + :: TempFileOptions -> FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectoryEx verbosity opts targetDir template f = +withTempDirectoryEx opts targetDir template f = withFrozenCallStack $ - withTempDirectoryCwdEx verbosity opts Nothing (makeSymbolicPath targetDir) template $ + withTempDirectoryCwdEx opts Nothing (makeSymbolicPath targetDir) template $ \fp -> f (getSymbolicPath fp) -- | A version of 'withTempDirectoryCwd' that additionally takes a -- 'TempFileOptions' argument. withTempDirectoryCwdEx :: forall a tmpDir1 tmpDir2 - . Verbosity - -> TempFileOptions + . TempFileOptions -> Maybe (SymbolicPath CWD (Dir Pkg)) -- ^ Working directory -> SymbolicPath Pkg (Dir tmpDir1) -> String -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a) -> IO a -withTempDirectoryCwdEx _verbosity opts mbWorkDir targetDir template f = +withTempDirectoryCwdEx opts mbWorkDir targetDir template f = withFrozenCallStack $ Exception.bracket (createTempDirectory (i targetDir) template) ( \tmpDirRelPath -> unless (optKeepTempFiles opts) $ - handleDoesNotExist () $ - removeDirectoryRecursive (i targetDir tmpDirRelPath) + removePathForcibly (i targetDir tmpDirRelPath) ) (withLexicalCallStack (\tmpDirRelPath -> f $ targetDir makeRelativePathEx tmpDirRelPath)) where @@ -2011,7 +2136,7 @@ findPackageDesc mbPkgDir = do let pkgDir = maybe "." getSymbolicPath mbPkgDir - files <- getDirectoryContents pkgDir + files <- listDirectory pkgDir -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal -- file we filter to exclude dirs and null base file names: cabalFiles <- @@ -2047,7 +2172,7 @@ -> IO (Maybe (SymbolicPath Pkg File)) -- ^ /dir/@\/@/pkgname/@.buildinfo@, if present findHookedPackageDesc verbosity mbWorkDir dir = do - files <- getDirectoryContents $ interpretSymbolicPath mbWorkDir dir + files <- listDirectory $ interpretSymbolicPath mbWorkDir dir buildInfoFiles <- filterM (doesFileExist . interpretSymbolicPath mbWorkDir) diff --git a/src/Distribution/Types/DumpBuildInfo.hs b/src/Distribution/Types/DumpBuildInfo.hs --- a/src/Distribution/Types/DumpBuildInfo.hs +++ b/src/Distribution/Types/DumpBuildInfo.hs @@ -5,6 +5,7 @@ ) where import Distribution.Compat.Prelude +import Distribution.Parsec data DumpBuildInfo = NoDumpBuildInfo @@ -12,4 +13,14 @@ deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic) instance Binary DumpBuildInfo +instance NFData DumpBuildInfo instance Structured DumpBuildInfo + +instance Parsec DumpBuildInfo where + parsec = parsecDumpBuildInfo + +parsecDumpBuildInfo :: CabalParsing m => m DumpBuildInfo +parsecDumpBuildInfo = boolToDumpBuildInfo <$> parsec + +boolToDumpBuildInfo :: Bool -> DumpBuildInfo +boolToDumpBuildInfo bool = if bool then DumpBuildInfo else NoDumpBuildInfo 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 @@ -156,6 +156,8 @@ -- ^ Whether to build shared versions of libs. , withStaticLib :: Bool -- ^ Whether to build static versions of libs (with all other libs rolled in) + , withBytecodeLib :: Bool + -- ^ Whether to build bytecode versions of libs , withDynExe :: Bool -- ^ Whether to link executables dynamically , withFullyStaticExe :: Bool @@ -203,27 +205,28 @@ buildOptionsConfigFlags :: BuildOptions -> ConfigFlags buildOptionsConfigFlags (BuildOptions{..}) = mempty - { configVanillaLib = toFlag $ withVanillaLib - , configSharedLib = toFlag $ withSharedLib - , configStaticLib = toFlag $ withStaticLib - , configDynExe = toFlag $ withDynExe - , configFullyStaticExe = toFlag $ withFullyStaticExe - , configGHCiLib = toFlag $ withGHCiLib - , configProfExe = toFlag $ withProfExe - , configProfLib = toFlag $ withProfLib - , configProfShared = toFlag $ withProfLibShared + { configVanillaLib = toFlag withVanillaLib + , configSharedLib = toFlag withSharedLib + , configStaticLib = toFlag withStaticLib + , configBytecodeLib = toFlag withBytecodeLib + , configDynExe = toFlag withDynExe + , configFullyStaticExe = toFlag withFullyStaticExe + , configGHCiLib = toFlag withGHCiLib + , configProfExe = toFlag withProfExe + , configProfLib = toFlag withProfLib + , configProfShared = toFlag withProfLibShared , configProf = mempty , -- configProfDetail is for exe+lib, but overridden by configProfLibDetail -- so we specify both so we can specify independently - configProfDetail = toFlag $ withProfExeDetail - , configProfLibDetail = toFlag $ withProfLibDetail - , configCoverage = toFlag $ exeCoverage + configProfDetail = toFlag withProfExeDetail + , configProfLibDetail = toFlag withProfLibDetail + , configCoverage = toFlag exeCoverage , configLibCoverage = mempty - , configRelocatable = toFlag $ relocatable - , configOptimization = toFlag $ withOptimization - , configSplitSections = toFlag $ splitSections - , configSplitObjs = toFlag $ splitObjs - , configStripExes = toFlag $ stripExes - , configStripLibs = toFlag $ stripLibs - , configDebugInfo = toFlag $ withDebugInfo + , configRelocatable = toFlag relocatable + , configOptimization = toFlag withOptimization + , configSplitSections = toFlag splitSections + , configSplitObjs = toFlag splitObjs + , configStripExes = toFlag stripExes + , configStripLibs = toFlag stripLibs + , configDebugInfo = toFlag withDebugInfo } 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 @@ -33,6 +33,7 @@ , withProfExe , withSharedLib , withStaticLib + , withBytecodeLib , withProfLibDetail , withProfExeDetail , withOptimization @@ -173,6 +174,7 @@ -> Bool -> Bool -> Bool + -> Bool -> ProfDetailLevel -> ProfDetailLevel -> OptimisationLevel @@ -208,6 +210,7 @@ , withProfLibShared , withSharedLib , withStaticLib + , withBytecodeLib , withDynExe , withFullyStaticExe , withProfExe @@ -260,6 +263,7 @@ , withProfLibShared , withSharedLib , withStaticLib + , withBytecodeLib , withDynExe , withFullyStaticExe , withProfExe @@ -389,9 +393,7 @@ -- In the presence of Backpack there may be more than one! componentNameCLBIs :: LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo] componentNameCLBIs (LocalBuildInfo{componentNameMap = comps}) cname = - case Map.lookup cname comps of - Just clbis -> clbis - Nothing -> [] + Map.findWithDefault [] cname comps -- TODO: Maybe cache topsort (Graph can do this) diff --git a/src/Distribution/Types/ParStrat.hs b/src/Distribution/Types/ParStrat.hs --- a/src/Distribution/Types/ParStrat.hs +++ b/src/Distribution/Types/ParStrat.hs @@ -1,5 +1,7 @@ module Distribution.Types.ParStrat where +import Distribution.Compat.Prelude + -- | How to control parallelism, e.g. a fixed number of jobs or by using a system semaphore. data ParStratX sem = -- | Compile in parallel with the given number of jobs (`-jN` or `-j`). @@ -9,6 +11,11 @@ | -- | No parallelism (neither `-jN` nor `--semaphore`, but could be `-j1`). Serial deriving (Show) + +instance NFData sem => NFData (ParStratX sem) where + rnf (NumJobs m) = rnf m + rnf (UseSem s) = rnf s + rnf Serial = () -- | Used by Cabal to indicate that we want to use this specific semaphore (created by cabal-install) type ParStrat = ParStratX String 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 @@ -16,10 +16,11 @@ import Distribution.Simple.Utils import Distribution.Utils.Progress import Distribution.Verbosity +import System.IO (hFlush, hPutStr, hPutStrLn) import Text.PrettyPrint type CtxMsg = Doc -type LogMsg = Doc +data LogMsg = WarnMsg Doc | InfoMsg Doc type ErrMsg = Doc data LogEnv = LogEnv @@ -54,25 +55,36 @@ , le_context = [] } step_fn :: LogMsg -> IO a -> IO a - step_fn doc go = do - putStrLn (render doc) + step_fn (WarnMsg doc) go = do + -- Log the warning to the stderr handle, but flush the stdout handle first, + -- to prevent interleaving (see Distribution.Simple.Utils.warnMessage). + let h = verbosityErrorHandle verbosity + flags = verbosityFlags verbosity + hFlush (verbosityChosenOutputHandle verbosity) + hPutStr h $ withOutputMarker flags (render doc ++ "\n") go - fail_fn :: Doc -> IO a + step_fn (InfoMsg doc) go = do + -- Don't mark 'infoProgress' messages (mostly Backpack internals) + hPutStrLn (verbosityChosenOutputHandle verbosity) (render doc) + go + fail_fn :: ErrMsg -> IO a fail_fn doc = do dieNoWrap verbosity (render doc) -- | Output a warning trace message in 'LogProgress'. warnProgress :: Doc -> LogProgress () warnProgress s = LogProgress $ \env -> - when (le_verbosity env >= normal) $ + when (verbosityLevel (le_verbosity env) >= Normal) $ stepProgress $ - hang (text "Warning:") 4 (formatMsg (le_context env) s) + WarnMsg $ + hang (text "Warning:") 4 (formatMsg (le_context env) s) -- | Output an informational trace message in 'LogProgress'. infoProgress :: Doc -> LogProgress () infoProgress s = LogProgress $ \env -> - when (le_verbosity env >= verbose) $ - stepProgress s + when (verbosityLevel (le_verbosity env) >= Verbose) $ + stepProgress $ + InfoMsg s -- | Fail the computation with an error message. dieProgress :: Doc -> LogProgress a diff --git a/src/Distribution/Utils/MapAccum.hs b/src/Distribution/Utils/MapAccum.hs --- a/src/Distribution/Utils/MapAccum.hs +++ b/src/Distribution/Utils/MapAccum.hs @@ -1,5 +1,6 @@ module Distribution.Utils.MapAccum (mapAccumM) where +import Data.Bifunctor (second) import Distribution.Compat.Prelude import Prelude () @@ -7,7 +8,7 @@ newtype StateM s m a = StateM {runStateM :: s -> m (s, a)} instance Functor m => Functor (StateM s m) where - fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s) + fmap f (StateM x) = StateM $ \s -> fmap (second f) (x s) instance Monad m => Applicative (StateM s m) where pure x = StateM $ \s -> return (s, x) @@ -23,4 +24,4 @@ -> a -> t b -> m (a, t c) -mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' x)) t) s +mapAccumM f s t = runStateM (traverse (\x -> StateM (`f` x)) t) s diff --git a/src/Distribution/Utils/NubList.hs b/src/Distribution/Utils/NubList.hs --- a/src/Distribution/Utils/NubList.hs +++ b/src/Distribution/Utils/NubList.hs @@ -75,6 +75,9 @@ instance Structured a => Structured (NubList a) +instance NFData a => NFData (NubList a) where + rnf (NubList xs) = rnf xs + -- | NubListR : A right-biased version of 'NubList'. That is @toNubListR -- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@, -- unlike the normal 'NubList', which is left-biased. Built on top of diff --git a/src/Distribution/Utils/Progress.hs b/src/Distribution/Utils/Progress.hs --- a/src/Distribution/Utils/Progress.hs +++ b/src/Distribution/Utils/Progress.hs @@ -62,7 +62,7 @@ instance Applicative (Progress step fail) where pure a = Done a - p <*> x = foldProgress Step Fail (flip fmap x) p + p <*> x = foldProgress Step Fail (`fmap` x) p instance Monoid fail => Alternative (Progress step fail) where empty = Fail Mon.mempty diff --git a/src/Distribution/Utils/UnionFind.hs b/src/Distribution/Utils/UnionFind.hs --- a/src/Distribution/Utils/UnionFind.hs +++ b/src/Distribution/Utils/UnionFind.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NondecreasingIndentation #-} -- | A simple mutable union-find data structure. @@ -50,14 +51,13 @@ -- which points directly to the canonical representation. repr :: Point s a -> ST s (Point s a) repr point = - readPoint point >>= \r -> - case r of - Link point' -> do - point'' <- repr point' - when (point'' /= point') $ do - writePoint point =<< readPoint point' - return point'' - Info _ _ -> return point + readPoint point >>= \case + Link point' -> do + point'' <- repr point' + when (point'' /= point') $ do + writePoint point =<< readPoint point' + return point'' + Info _ _ -> return point -- | Return the canonical element of an equivalence -- class 'Point'. @@ -65,14 +65,12 @@ find point = -- Optimize length 0 and 1 case at expense of -- general case - readPoint point >>= \r -> - case r of - Info _ d_ref -> readSTRef d_ref - Link point' -> - readPoint point' >>= \r' -> - case r' of - Info _ d_ref -> readSTRef d_ref - Link _ -> repr point >>= find + readPoint point >>= \case + Info _ d_ref -> readSTRef d_ref + Link point' -> + readPoint point' >>= \case + Info _ d_ref -> readSTRef d_ref + Link _ -> repr point >>= find -- | Unify two equivalence classes, so that they share -- a canonical element. Keeps the descriptor of point2. diff --git a/src/Distribution/Verbosity.hs b/src/Distribution/Verbosity.hs --- a/src/Distribution/Verbosity.hs +++ b/src/Distribution/Verbosity.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -24,8 +25,22 @@ -- are interested in.) It's important to note that the instances -- for 'Verbosity' assume that this does not exist. module Distribution.Verbosity - ( -- * Verbosity - Verbosity + ( -- * Rich verbosity + Verbosity (..) + , VerbosityHandles (..) + , defaultVerbosityHandles + , VerbosityLevel (..) + , verbosityLevel + , verbosityChosenOutputHandle + , verbosityErrorHandle + , modifyVerbosityFlags + , mkVerbosity + , setVerbosityHandles + + -- * Verbosity flags + , VerbosityFlags (vLevel) + , mkVerbosityFlags + , makeVerbose , silent , normal , verbose @@ -39,7 +54,6 @@ , showForGHC , verboseNoFlags , verboseHasFlags - , modifyVerbosity -- * Call stacks , verboseCallSite @@ -47,7 +61,7 @@ , isVerboseCallSite , isVerboseCallStack - -- * Output markets + -- * Output markers , verboseMarkOutput , isVerboseMarkOutput , verboseUnmarkOutput @@ -84,54 +98,121 @@ import qualified Data.Set as Set import qualified Distribution.Compat.CharParsing as P +import Distribution.Utils.Structured +import System.IO (Handle, stderr, stdout) import qualified Text.PrettyPrint as PP +import qualified Type.Reflection as Typeable +-- | Rich verbosity, used for the Cabal library interface. data Verbosity = Verbosity + { verbosityFlags :: VerbosityFlags + , verbosityHandles :: VerbosityHandles + } + deriving (Generic) + +-- | Handles to use for logging (e.g. log to stdout, or log to a file). +data VerbosityHandles = VerbosityHandles + { vStdoutHandle :: Handle + , vStderrHandle :: Handle + } + +defaultVerbosityHandles :: VerbosityHandles +defaultVerbosityHandles = + VerbosityHandles + { vStdoutHandle = stdout + , vStderrHandle = stderr + } + +-- | Verbosity information which can be passed by the CLI. +data VerbosityFlags = VerbosityFlags { vLevel :: VerbosityLevel , vFlags :: Set VerbosityFlag , vQuiet :: Bool } - deriving (Generic, Show, Read) + deriving (Generic, Show, Read, Eq) -mkVerbosity :: VerbosityLevel -> Verbosity -mkVerbosity l = Verbosity{vLevel = l, vFlags = Set.empty, vQuiet = False} +verbosityLevel :: Verbosity -> VerbosityLevel +verbosityLevel = vLevel . verbosityFlags -instance Eq Verbosity where - x == y = vLevel x == vLevel y +-- | The handle used for normal output. +-- +-- With the @+stderr@ verbosity flag, this is the error handle. +verbosityChosenOutputHandle :: Verbosity -> Handle +verbosityChosenOutputHandle verb = + if isVerboseStderr (verbosityFlags verb) + then vStderrHandle $ verbosityHandles verb + else vStdoutHandle $ verbosityHandles verb -instance Ord Verbosity where - compare x y = compare (vLevel x) (vLevel y) +-- | The verbosity handle used for error output. +verbosityErrorHandle :: Verbosity -> Handle +verbosityErrorHandle = vStderrHandle . verbosityHandles -instance Enum Verbosity where - toEnum = mkVerbosity . toEnum - fromEnum = fromEnum . vLevel +setVerbosityHandles :: Maybe Handle -> Verbosity -> Verbosity +setVerbosityHandles Nothing v = v +setVerbosityHandles (Just h) v = + v{verbosityHandles = VerbosityHandles{vStdoutHandle = h, vStderrHandle = h}} -instance Bounded Verbosity where - minBound = mkVerbosity minBound - maxBound = mkVerbosity maxBound +mkVerbosity :: VerbosityHandles -> VerbosityFlags -> Verbosity +mkVerbosity handles flags = + Verbosity + { verbosityFlags = flags + , verbosityHandles = handles + } -instance Binary Verbosity +modifyVerbosityFlags :: (VerbosityFlags -> VerbosityFlags) -> Verbosity -> Verbosity +modifyVerbosityFlags f v@(Verbosity{verbosityFlags = flags}) = + v{verbosityFlags = f flags} + +mkVerbosityFlags :: VerbosityLevel -> VerbosityFlags +mkVerbosityFlags l = VerbosityFlags{vLevel = l, vFlags = Set.empty, vQuiet = False} + +instance Binary VerbosityFlags +instance NFData VerbosityFlags +instance Structured VerbosityFlags + +-- Hand-written instances, because there are no NFData/Structured instances +-- for Handle. +instance NFData VerbosityHandles where + rnf (VerbosityHandles o e) = o `seq` e `seq` () +instance Structured VerbosityHandles where + structure _ = + Structure + tr + 0 + (show tr) + [ + ( "VerbosityHandles" + , + [ nominalStructure $ Proxy @Handle + , nominalStructure $ Proxy @Handle + ] + ) + ] + where + tr = Typeable.SomeTypeRep $ Typeable.typeRep @VerbosityHandles + +instance NFData Verbosity instance Structured Verbosity -- | In 'silent' mode, we should not print /anything/ unless an error occurs. -silent :: Verbosity -silent = mkVerbosity Silent +silent :: VerbosityFlags +silent = mkVerbosityFlags Silent -- | Print stuff we want to see by default. -normal :: Verbosity -normal = mkVerbosity Normal +normal :: VerbosityFlags +normal = mkVerbosityFlags Normal -- | Be more verbose about what's going on. -verbose :: Verbosity -verbose = mkVerbosity Verbose +verbose :: VerbosityFlags +verbose = mkVerbosityFlags Verbose -- | Not only are we verbose ourselves (perhaps even noisier than when -- being 'verbose'), but we tell everything we run to be verbose too. -deafening :: Verbosity -deafening = mkVerbosity Deafening +deafening :: VerbosityFlags +deafening = mkVerbosityFlags Deafening -- | Increase verbosity level, but stay 'silent' if we are. -moreVerbose :: Verbosity -> Verbosity +moreVerbose :: VerbosityFlags -> VerbosityFlags moreVerbose v = case vLevel v of Silent -> v -- silent should stay silent @@ -139,8 +220,18 @@ Verbose -> v{vLevel = Deafening} Deafening -> v +-- | Make sure the verbosity level is at least 'verbose', +-- but stay 'silent' if we are. +makeVerbose :: VerbosityFlags -> VerbosityFlags +makeVerbose v = + case vLevel v of + Silent -> v -- silent should stay silent + Normal -> v{vLevel = Verbose} + Verbose -> v + Deafening -> v + -- | Decrease verbosity level, but stay 'deafening' if we are. -lessVerbose :: Verbosity -> Verbosity +lessVerbose :: VerbosityFlags -> VerbosityFlags lessVerbose v = verboseQuiet $ case vLevel v of @@ -149,56 +240,42 @@ Normal -> v{vLevel = Silent} Silent -> v --- | Combinator for transforming verbosity level while retaining the --- original hidden state. --- --- For instance, the following property holds --- --- prop> isVerboseNoWrap (modifyVerbosity (max verbose) v) == isVerboseNoWrap v --- --- __Note__: you can use @modifyVerbosity (const v1) v0@ to overwrite --- @v1@'s flags with @v0@'s flags. --- --- @since 2.0.1.0 -modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity -modifyVerbosity f v = v{vLevel = vLevel (f v)} - -- | Numeric verbosity level @0..3@: @0@ is 'silent', @3@ is 'deafening'. -intToVerbosity :: Int -> Maybe Verbosity -intToVerbosity 0 = Just (mkVerbosity Silent) -intToVerbosity 1 = Just (mkVerbosity Normal) -intToVerbosity 2 = Just (mkVerbosity Verbose) -intToVerbosity 3 = Just (mkVerbosity Deafening) +intToVerbosity :: Int -> Maybe VerbosityFlags +intToVerbosity 0 = Just (mkVerbosityFlags Silent) +intToVerbosity 1 = Just (mkVerbosityFlags Normal) +intToVerbosity 2 = Just (mkVerbosityFlags Verbose) +intToVerbosity 3 = Just (mkVerbosityFlags Deafening) intToVerbosity _ = Nothing -- | Parser verbosity -- -- >>> explicitEitherParsec parsecVerbosity "normal" --- Right (Verbosity {vLevel = Normal, vFlags = fromList [], vQuiet = False}) +-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "normal+nowrap " --- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap], vQuiet = False}) +-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [VNoWrap], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "normal+nowrap +markoutput" --- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) +-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "normal +nowrap +markoutput" --- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) +-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "normal+nowrap+markoutput" --- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) +-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "deafening+nowrap+stdout+stderr+callsite+callstack" --- Right (Verbosity {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False}) +-- Right (VerbosityFlags {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False}) -- -- /Note:/ this parser will eat trailing spaces. -instance Parsec Verbosity where +instance Parsec VerbosityFlags where parsec = parsecVerbosity -instance Pretty Verbosity where +instance Pretty VerbosityFlags where pretty = PP.text . showForCabal -parsecVerbosity :: CabalParsing m => m Verbosity +parsecVerbosity :: CabalParsing m => m VerbosityFlags parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity where parseIntVerbosity = do @@ -211,7 +288,7 @@ level <- parseVerbosityLevel _ <- P.spaces flags <- many (parseFlag <* P.spaces) - return $ foldl' (flip ($)) (mkVerbosity level) flags + return $ foldl' (flip ($)) (mkVerbosityFlags level) flags parseVerbosityLevel = do token <- P.munch1 isAsciiAlpha @@ -236,18 +313,18 @@ "nowarn" -> return verboseNoWarn _ -> P.unexpected $ "Bad verbosity flag: " ++ token -flagToVerbosity :: ReadE Verbosity +flagToVerbosity :: ReadE VerbosityFlags flagToVerbosity = parsecToReadE id parsecVerbosity -showForCabal :: Verbosity -> String -showForCabal v - | Set.null (vFlags v) = +showForCabal :: VerbosityFlags -> String +showForCabal (VerbosityFlags{vLevel = lvl, vFlags = flags}) + | Set.null flags = maybe (error "unknown verbosity") show $ - elemIndex v [silent, normal, verbose, deafening] + elemIndex lvl [Silent, Normal, Verbose, Deafening] | otherwise = unwords $ - showLevel (vLevel v) - : concatMap showFlag (Set.toList (vFlags v)) + showLevel lvl + : concatMap showFlag (Set.toList flags) where showLevel Silent = "silent" showLevel Normal = "normal" @@ -262,116 +339,116 @@ showFlag VStderr = ["+stderr"] showFlag VNoWarn = ["+nowarn"] -showForGHC :: Verbosity -> String +showForGHC :: VerbosityFlags -> String showForGHC v = maybe (error "unknown verbosity") show $ - elemIndex v [silent, normal, __, verbose, deafening] + elemIndex (vLevel v) [Silent, Normal, __, Verbose, Deafening] where - __ = silent -- this will be always ignored by elemIndex + __ = Silent -- this will be always ignored by elemIndex -- | Turn on verbose call-site printing when we log. -verboseCallSite :: Verbosity -> Verbosity +verboseCallSite :: VerbosityFlags -> VerbosityFlags verboseCallSite = verboseFlag VCallSite -- | Turn on verbose call-stack printing when we log. -verboseCallStack :: Verbosity -> Verbosity +verboseCallStack :: VerbosityFlags -> VerbosityFlags verboseCallStack = verboseFlag VCallStack -- | Turn on @-----BEGIN CABAL OUTPUT-----@ markers for output -- from Cabal (as opposed to GHC, or system dependent). -verboseMarkOutput :: Verbosity -> Verbosity +verboseMarkOutput :: VerbosityFlags -> VerbosityFlags verboseMarkOutput = verboseFlag VMarkOutput -- | Turn off marking; useful for suppressing nondeterministic output. -verboseUnmarkOutput :: Verbosity -> Verbosity +verboseUnmarkOutput :: VerbosityFlags -> VerbosityFlags verboseUnmarkOutput = verboseNoFlag VMarkOutput -- | Disable line-wrapping for log messages. -verboseNoWrap :: Verbosity -> Verbosity +verboseNoWrap :: VerbosityFlags -> VerbosityFlags verboseNoWrap = verboseFlag VNoWrap -- | Mark the verbosity as quiet. -verboseQuiet :: Verbosity -> Verbosity +verboseQuiet :: VerbosityFlags -> VerbosityFlags verboseQuiet v = v{vQuiet = True} -- | Turn on timestamps for log messages. -verboseTimestamp :: Verbosity -> Verbosity +verboseTimestamp :: VerbosityFlags -> VerbosityFlags verboseTimestamp = verboseFlag VTimestamp -- | Turn off timestamps for log messages. -verboseNoTimestamp :: Verbosity -> Verbosity +verboseNoTimestamp :: VerbosityFlags -> VerbosityFlags verboseNoTimestamp = verboseNoFlag VTimestamp -- | Switch logging to 'stderr'. -- -- @since 3.4.0.0 -verboseStderr :: Verbosity -> Verbosity +verboseStderr :: VerbosityFlags -> VerbosityFlags verboseStderr = verboseFlag VStderr -- | Switch logging to 'stdout'. -- -- @since 3.4.0.0 -verboseNoStderr :: Verbosity -> Verbosity +verboseNoStderr :: VerbosityFlags -> VerbosityFlags verboseNoStderr = verboseNoFlag VStderr -- | Turn off warnings for log messages. -verboseNoWarn :: Verbosity -> Verbosity +verboseNoWarn :: VerbosityFlags -> VerbosityFlags verboseNoWarn = verboseFlag VNoWarn -- | Helper function for flag enabling functions. -verboseFlag :: VerbosityFlag -> (Verbosity -> Verbosity) -verboseFlag flag v = v{vFlags = Set.insert flag (vFlags v)} +verboseFlag :: VerbosityFlag -> (VerbosityFlags -> VerbosityFlags) +verboseFlag flag v@(VerbosityFlags{vFlags = flags}) = v{vFlags = Set.insert flag flags} -- | Helper function for flag disabling functions. -verboseNoFlag :: VerbosityFlag -> (Verbosity -> Verbosity) -verboseNoFlag flag v = v{vFlags = Set.delete flag (vFlags v)} +verboseNoFlag :: VerbosityFlag -> (VerbosityFlags -> VerbosityFlags) +verboseNoFlag flag v@(VerbosityFlags{vFlags = flags}) = v{vFlags = Set.delete flag flags} -- | Turn off all flags. -verboseNoFlags :: Verbosity -> Verbosity +verboseNoFlags :: VerbosityFlags -> VerbosityFlags verboseNoFlags v = v{vFlags = Set.empty} -verboseHasFlags :: Verbosity -> Bool -verboseHasFlags = not . Set.null . vFlags +verboseHasFlags :: VerbosityFlags -> Bool +verboseHasFlags (VerbosityFlags{vFlags = flags}) = not $ Set.null flags -- | Test if we should output call sites when we log. -isVerboseCallSite :: Verbosity -> Bool +isVerboseCallSite :: VerbosityFlags -> Bool isVerboseCallSite = isVerboseFlag VCallSite -- | Test if we should output call stacks when we log. -isVerboseCallStack :: Verbosity -> Bool +isVerboseCallStack :: VerbosityFlags -> Bool isVerboseCallStack = isVerboseFlag VCallStack --- | Test if we should output markets. -isVerboseMarkOutput :: Verbosity -> Bool +-- | Test if we should output markers. +isVerboseMarkOutput :: VerbosityFlags -> Bool isVerboseMarkOutput = isVerboseFlag VMarkOutput -- | Test if line-wrapping is disabled for log messages. -isVerboseNoWrap :: Verbosity -> Bool +isVerboseNoWrap :: VerbosityFlags -> Bool isVerboseNoWrap = isVerboseFlag VNoWrap -- | Test if we had called 'lessVerbose' on the verbosity. -isVerboseQuiet :: Verbosity -> Bool +isVerboseQuiet :: VerbosityFlags -> Bool isVerboseQuiet = vQuiet -- | Test if we should output timestamps when we log. -isVerboseTimestamp :: Verbosity -> Bool +isVerboseTimestamp :: VerbosityFlags -> Bool isVerboseTimestamp = isVerboseFlag VTimestamp -- | Test if we should output to 'stderr' when we log. -- -- @since 3.4.0.0 -isVerboseStderr :: Verbosity -> Bool +isVerboseStderr :: VerbosityFlags -> Bool isVerboseStderr = isVerboseFlag VStderr -- | Test if we should output warnings when we log. -isVerboseNoWarn :: Verbosity -> Bool +isVerboseNoWarn :: VerbosityFlags -> Bool isVerboseNoWarn = isVerboseFlag VNoWarn -- | Helper function for flag testing functions. -isVerboseFlag :: VerbosityFlag -> Verbosity -> Bool -isVerboseFlag flag = (Set.member flag) . vFlags +isVerboseFlag :: VerbosityFlag -> VerbosityFlags -> Bool +isVerboseFlag flag v = flag `Set.member` vFlags v -- $setup -- >>> import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum) -- >>> instance Arbitrary VerbosityLevel where arbitrary = arbitraryBoundedEnum --- >>> instance Arbitrary Verbosity where arbitrary = fmap mkVerbosity arbitrary +-- >>> instance Arbitrary VerbosityFlags where arbitrary = fmap mkVerbosityFlags arbitrary diff --git a/src/Distribution/Verbosity/Internal.hs b/src/Distribution/Verbosity/Internal.hs --- a/src/Distribution/Verbosity/Internal.hs +++ b/src/Distribution/Verbosity/Internal.hs @@ -12,6 +12,7 @@ deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) instance Binary VerbosityLevel +instance NFData VerbosityLevel instance Structured VerbosityLevel data VerbosityFlag @@ -26,4 +27,5 @@ deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) instance Binary VerbosityFlag +instance NFData VerbosityFlag instance Structured VerbosityFlag diff --git a/src/Distribution/ZinzaPrelude.hs b/src/Distribution/ZinzaPrelude.hs --- a/src/Distribution/ZinzaPrelude.hs +++ b/src/Distribution/ZinzaPrelude.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TupleSections #-} + -- | A small prelude used in @zinza@ generated -- template modules. module Distribution.ZinzaPrelude @@ -27,7 +29,7 @@ fmap = liftM instance Applicative Writer where - pure x = W $ \ss -> (ss, x) + pure x = W (,x) (<*>) = ap instance Monad Writer where