diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,7 +1,7 @@ -cabal-version: 3.0 +cabal-version: 3.8 name: Cabal -version: 3.14.2.0 -copyright: 2003-2024, 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 @@ -29,35 +29,51 @@ location: https://github.com/haskell/cabal/ subdir: Cabal +flag git-rev + description: include Git revision hash in version + default: False + manual: True + library default-language: Haskell2010 hs-source-dirs: src build-depends: - Cabal-syntax ^>= 3.14, - array >= 0.4.0.1 && < 0.6, - base >= 4.13 && < 5, - bytestring >= 0.10.0.0 && < 0.13, - containers >= 0.5.0.0 && < 0.8, - deepseq >= 1.3.0.1 && < 1.6, - directory >= 1.2 && < 1.4, - filepath >= 1.3.0.1 && < 1.6, - pretty >= 1.1.1 && < 1.2, - process >= 1.2.1.0 && < 1.7, - time >= 1.4.0.1 && < 1.15 + , Cabal-syntax ^>= 3.18 + , array >= 0.4.0.1 && < 0.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.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 + build-depends: + , Win32 >= 2.4.0.0 && < 2.15 else - build-depends: unix >= 2.8.6.0 && < 2.9 + 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 + cpp-options: -DGIT_REV + ghc-options: -Wall -fno-ignore-asserts - -fwarn-tabs - -fwarn-incomplete-uni-patterns - -fwarn-incomplete-record-updates - -fno-warn-unticked-promoted-constructors + -Wtabs + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wno-unticked-promoted-constructors if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances @@ -65,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 @@ -79,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 @@ -114,7 +131,6 @@ Distribution.Simple.Haddock Distribution.Simple.Glob Distribution.Simple.Glob.Internal - Distribution.Simple.HaskellSuite Distribution.Simple.Hpc Distribution.Simple.Install Distribution.Simple.InstallDirs @@ -151,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 @@ -183,7 +200,6 @@ Distribution.Compat.Exception, Distribution.Compat.Graph, Distribution.Compat.Lens, - Distribution.Compat.MonadFail, Distribution.Compat.Newtype, Distribution.Compat.NonEmptySet, Distribution.Compat.Parsing, @@ -248,6 +264,7 @@ Distribution.Types.ConfVar, Distribution.Types.Dependency, Distribution.Types.DependencyMap, + Distribution.Types.DependencySatisfaction, Distribution.Types.ExeDependency, Distribution.Types.Executable, Distribution.Types.Executable.Lens, @@ -271,6 +288,8 @@ Distribution.Types.Library.Lens, Distribution.Types.LibraryName, Distribution.Types.LibraryVisibility, + Distribution.Types.MissingDependency, + Distribution.Types.MissingDependencyReason, Distribution.Types.Mixin, Distribution.Types.Module, Distribution.Types.ModuleReexport, @@ -314,11 +333,9 @@ -- 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), - mtl >= 2.1 && < 2.4, - parsec >= 3.1.13.0 && < 3.2 + , transformers >= 0.5.6 && < 0.7 + , mtl >= 2.1 && < 2.4 + , parsec >= 3.1.13.0 && < 3.2 other-modules: Distribution.Backpack.PreExistingComponent @@ -331,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,12 @@ +# 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 + +# 3.16.0.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) July 2025 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.16.0.0.md + # 3.14.2.0 [Mikolaj Konarski](mailto:mikolaj@well-typed.com) April 2025 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.14.2.0.md @@ -583,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 @@ -776,7 +785,7 @@ * Many checks added for common mistakes * New `--package-db=` option for specific package databases * Many internal changes to support cabal-install - * Stricter parsing for version strings, eg dissalows "1.05" + * Stricter parsing for version strings, eg disallows "1.05" * Improved user guide introduction * Programatica support removed * New options `--program-prefix/suffix` allows eg versioned programs diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2024, Cabal Development Team. +Copyright (c) 2003-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 @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-} @@ -33,11 +31,12 @@ import Distribution.InstalledPackageInfo ( InstalledPackageInfo , emptyInstalledPackageInfo + , requiredSignatures ) import qualified Distribution.InstalledPackageInfo as Installed import Distribution.ModuleName import Distribution.Package -import Distribution.PackageDescription +import Distribution.PackageDescription (FlagAssignment, PackageDescription (..), libName) import Distribution.Simple.Compiler import Distribution.Simple.Flag import Distribution.Simple.LocalBuildInfo @@ -263,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 @@ -272,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 @@ -340,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. -- @@ -355,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 @@ -1,5 +1,3 @@ -{-# LANGUAGE PatternGuards #-} - -- | See module Distribution.Backpack.ConfiguredComponent ( ConfiguredComponent (..) @@ -85,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/Id.hs b/src/Distribution/Backpack/Id.hs --- a/src/Distribution/Backpack/Id.hs +++ b/src/Distribution/Backpack/Id.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -- | See @@ -13,7 +14,7 @@ import Distribution.PackageDescription import Distribution.Simple.Compiler -import Distribution.Simple.Flag (Flag (..)) +import Distribution.Simple.Flag (Flag, pattern Flag, pattern NoFlag) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo import Distribution.Types.ComponentId diff --git a/src/Distribution/Backpack/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/ModuleScope.hs b/src/Distribution/Backpack/ModuleScope.hs --- a/src/Distribution/Backpack/ModuleScope.hs +++ b/src/Distribution/Backpack/ModuleScope.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} -- | See diff --git a/src/Distribution/Backpack/PreModuleShape.hs b/src/Distribution/Backpack/PreModuleShape.hs --- a/src/Distribution/Backpack/PreModuleShape.hs +++ b/src/Distribution/Backpack/PreModuleShape.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Backpack.PreModuleShape diff --git a/src/Distribution/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) -# 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 -fno-warn-unused-imports #-} - -module Distribution.Compat.FilePath - ( isExtensionOf - , stripExtension - ) where - -import Data.List (isSuffixOf, stripPrefix) -import System.FilePath - -#if !MIN_VERSION_filepath(1,4,2) -isExtensionOf :: String -> FilePath -> Bool -isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions -isExtensionOf ext = isSuffixOf ('.':ext) . takeExtensions -#endif - -#if !MIN_VERSION_filepath(1,4,1) -stripExtension :: String -> FilePath -> Maybe FilePath -stripExtension [] path = Just path -stripExtension ext@(x:_) path = stripSuffix dotExt path - where - dotExt = if isExtSeparator x then ext else '.':ext - stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] - stripSuffix xs ys = fmap reverse $ stripPrefix (reverse xs) (reverse ys) -#endif diff --git a/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 -} -#ifdef x86_64_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,22 +10,12 @@ import Distribution.Compat.Exception +import GHC.IORef (IORef, atomicModifyIORef'_, newIORef) import System.FilePath (()) - -import System.IO (Handle, openBinaryTempFile, openTempFile) -#if defined(__IO_MANAGER_WINIO__) -import System.IO (openBinaryTempFileWithDefaultPermissions) -import System.Posix.Internals (c_getpid) -#else -import Control.Exception (onException) -import Data.Bits ((.|.)) -import Foreign.C (CInt, eEXIST, getErrno, errnoToIOError) -import GHC.IO.Handle.FD (fdToHandle) -import System.Posix.Internals (c_getpid, c_open, c_close, o_EXCL, o_BINARY, withFilePath, - o_CREAT, o_RDWR, o_NONBLOCK, o_NOCTTY) -#endif - +import System.IO (Handle, openBinaryTempFile, openBinaryTempFileWithDefaultPermissions, openTempFile) import System.IO.Error (isAlreadyExistsError) +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Internals (c_getpid) #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) import System.Directory ( createDirectory ) @@ -33,107 +23,27 @@ import qualified System.Posix #endif --- ------------------------------------------------------------ - --- * temporary files - --- ------------------------------------------------------------ - --- This is here for Haskell implementations that do not come with --- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. --- TODO: This file should probably be removed. - --- This is a copy/paste of the openBinaryTempFile definition, but --- it uses 666 rather than 600 for the permissions. Newer versions --- of base have a new function with this behavior which we use on --- Windows when the new IO manager is used. openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) -openNewBinaryFile dir template = do - --- This method can't be used under WINIO. Also the current implementation has --- thread safety issues depending on which GHC is used. On newer GHC's let's --- use the built in one. -#if defined(__IO_MANAGER_WINIO__) - openBinaryTempFileWithDefaultPermissions dir template -#else - pid <- c_getpid - findTempName pid - where - -- We split off the last extension, so we can use .foo.ext files - -- for temporary files (hidden on Unix OSes). Unfortunately we're - -- below file path in the hierarchy here. - (prefix,suffix) = - case break (== '.') $ reverse template of - -- First case: template contains no '.'s. Just re-reverse it. - (rev_suffix, "") -> (reverse rev_suffix, "") - -- Second case: template contains at least one '.'. Strip the - -- dot from the prefix and prepend it to the suffix (if we don't - -- do this, the unique number will get added after the '.' and - -- thus be part of the extension, which is wrong.) - (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) - -- Otherwise, something is wrong, because (break (== '.')) should - -- always return a pair with either the empty string or a string - -- beginning with '.' as the second component. - _ -> error "bug in System.IO.openTempFile" - - oflags = rw_flags .|. o_EXCL .|. o_BINARY - - findTempName x = do - fd <- withFilePath filepath $ \ f -> - c_open f oflags 0o666 - if fd < 0 - then do - errno <- getErrno - if errno == eEXIST - then findTempName (x+1) - else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) - else do - -- TODO: We want to tell fdToHandle what the file path is, - -- as any exceptions etc will only be able to report the - -- FD currently - h <- fdToHandle fd `onException` c_close fd - return (filepath, h) - where - filename = prefix ++ show x ++ suffix - filepath = dir `combine` filename - - -- FIXME: bits copied from System.FilePath - combine a b - | null b = a - | null a = b - | last a == pathSeparator = a ++ b - | otherwise = a ++ [pathSeparator] ++ b - --- FIXME: Copied from GHC.Handle -std_flags, output_flags, rw_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -rw_flags = output_flags .|. o_RDWR - --- FIXME: Should use System.FilePath library -pathSeparator :: Char -#ifdef mingw32_HOST_OS -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif --- /* __IO_MANAGER_WINIO__ */ -#endif +openNewBinaryFile = openBinaryTempFileWithDefaultPermissions createTempDirectory :: FilePath -> String -> IO FilePath createTempDirectory dir template = do 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 -} -#ifdef x86_64_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 @@ -134,11 +134,11 @@ -- | Pretty printing of short options. -- * With required arguments can be given as: -- @-w PATH or -wPATH (but not -w=PATH)@ --- This is dislayed as: +-- This is displayed as: -- @-w PATH or -wPATH@ -- * With optional but default arguments can be given as: -- @-j or -jNUM (but not -j=NUM or -j NUM)@ --- This is dislayed as: +-- This is displayed as: -- @-j[NUM]@ fmtShort :: ArgDescr a -> Char -> String fmtShort (NoArg _) so = "-" ++ [so] @@ -152,11 +152,11 @@ -- | Pretty printing of long options. -- * With required arguments can be given as: -- @--with-compiler=PATH (but not --with-compiler PATH)@ --- This is dislayed as: +-- This is displayed as: -- @--with-compiler=PATH@ -- * With optional but default arguments can be given as: -- @--jobs or --jobs=NUM (but not --jobs NUM)@ --- This is dislayed as: +-- This is displayed as: -- @--jobs[=NUM]@ fmtLong :: ArgDescr a -> String -> String fmtLong (NoArg _) lo = "--" ++ lo @@ -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_ @@ -268,8 +274,6 @@ checkP (not . null $ dups names) (PackageBuildImpossible $ DuplicateSections dupes) - -- PackageDescription checks. - checkPackageDescription packageDescription_ -- Flag names. mapM_ checkFlagName genPackageFlags_ @@ -350,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 () @@ -425,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. @@ -453,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_ @@ -509,7 +539,7 @@ ( isNothing setupBuildInfo_ && buildTypeRaw_ == Just Custom ) - (PackageDistSuspiciousWarn CVExpliticDepsCustomSetup) + (PackageDistSuspiciousWarn CVExplicitDepsCustomSetup) checkP (isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2) (PackageBuildWarning NoBuildType) @@ -559,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 @@ -588,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 @@ -631,7 +673,7 @@ -- licenses so don't need license files. nullLicFiles ) - $ (PackageDistSuspicious NoLicenseFile) + (PackageDistSuspicious NoLicenseFile) case unknownLicenseVersion lic of Just knownVersions -> tellP @@ -708,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) @@ -756,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 <- @@ -835,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) @@ -884,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 = @@ -938,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 @@ -981,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 @@ -992,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 @@ -1024,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. @@ -1062,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? @@ -1077,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 - inNam = nub $ map fst fads :: [UnqualComponentName] + inName = ordNub $ map fst fads :: [UnqualComponentName] -- the dependencies of such targets inDep = concatMap snd fads :: [Dependency] @@ -97,7 +98,7 @@ -- text, ← no warning, inherited -- monadacme ← warning! let fFun d = - notElem (unqualName d) inNam + notElem (unqualName d) inName && notElem (unqualName d) (map unqualName inDep) diff --git a/src/Distribution/PackageDescription/Check/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 @@ -242,7 +242,7 @@ -- There are some errors which, even though severe, will -- be allowed by Hackage *if* under a non-default flag. isErrAllowable :: PackageCheck -> Bool - isErrAllowable c = case extractCheckExplantion c of + isErrAllowable c = case extractCheckExplanation c of (WErrorUnneeded _) -> True (JUnneeded _) -> True (FDeferTypeErrorsUnneeded _) -> True @@ -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/Paths.hs b/src/Distribution/PackageDescription/Check/Paths.hs --- a/src/Distribution/PackageDescription/Check/Paths.hs +++ b/src/Distribution/PackageDescription/Check/Paths.hs @@ -10,6 +10,7 @@ module Distribution.PackageDescription.Check.Paths ( checkGlob , checkPath + , checkPackageFileNamesWithGlob , fileExtensionSupportedLanguage , isGoodRelativeDirectoryPath , isGoodRelativeFilePath diff --git a/src/Distribution/PackageDescription/Check/Target.hs b/src/Distribution/PackageDescription/Check/Target.hs --- a/src/Distribution/PackageDescription/Check/Target.hs +++ b/src/Distribution/PackageDescription/Check/Target.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + -- | -- Module : Distribution.PackageDescription.Check.Target -- Copyright : Lennart Kolmodin 2008, Francesco Ariis 2023 @@ -77,7 +79,7 @@ checkP ( not $ all - (flip elem (explicitLibModules lib)) + (`elem` explicitLibModules lib) (libModulesAutogen lib) ) (PackageBuildImpossible AutogenNotExposed) @@ -89,7 +91,7 @@ (flip elem (allExplicitIncludes lib) . getSymbolicPath) (view L.autogenIncludes lib) ) - $ (PackageBuildImpossible AutogenIncludesNotIncluded) + (PackageBuildImpossible AutogenIncludesNotIncluded) -- § Build infos. checkBuildInfo @@ -153,7 +155,7 @@ checkP ( pid /= fakePackageId && not (null modulePath_) - && not (fileExtensionSupportedLanguage $ modulePath_) + && not (fileExtensionSupportedLanguage modulePath_) ) (PackageBuildImpossible NoHsLhsMain) @@ -168,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 $ @@ -211,7 +213,7 @@ checkP ( not $ all - (flip elem (testModules ts)) + (`elem` testModules ts) (testModulesAutogen ts) ) (PackageBuildImpossible $ AutogenNoOther cet) @@ -271,7 +273,7 @@ checkP ( not $ all - (flip elem (benchmarkModules bm)) + (`elem` benchmarkModules bm) (benchmarkModulesAutogen bm) ) (PackageBuildImpossible $ AutogenNoOther cet) @@ -381,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 () @@ -526,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 @@ -558,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 @@ -641,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 @@ -678,7 +677,7 @@ -- PackageBuildImpossible and not merely PackageDistInexcusable. checkSpecVer CabalSpecV3_12 - (elem autoInfoModuleName allModsForAuto) + (autoInfoModuleName `elem` allModsForAuto) (PackageBuildImpossible CVAutogenPackageInfoGuard) where allModsForAuto :: [ModuleName] @@ -800,6 +799,7 @@ checkCLikeOptions LangC "cc-options" (ccOptions bi) ldOpts checkCLikeOptions LangCPlusPlus "cxx-options" (cxxOptions bi) ldOpts checkCPPOptions (cppOptions bi) + checkJSPOptions (jsppOptions bi) -- | Checks GHC options for commonly misused or non-portable flags. checkGHCOptions @@ -892,6 +892,12 @@ ) checkAlternatives title + "jspp-options" + ( [(flag, flag) | flag@('-' : 'D' : _) <- ghcNoRts] + ++ [(flag, flag) | flag@('-' : 'U' : _) <- ghcNoRts] + ) + checkAlternatives + title "include-dirs" [(flag, dir) | flag@('-' : 'I' : dir) <- ghcNoRts] checkAlternatives @@ -949,7 +955,7 @@ ) (PackageDistInexcusable . DynamicUnneeded) checkFlagsP - ( \opt -> case opt of + ( \case "-j" -> True ('-' : 'j' : d : _) -> isDigit d _ -> False @@ -1077,5 +1083,22 @@ checkP (not $ any (`isPrefixOf` opt) ["-D", "-U", "-I"]) (PackageBuildWarning (COptCPP opt)) + ) + opts + +checkJSPOptions + :: Monad m + => [String] -- Options in String form. + -> CheckM m () +checkJSPOptions opts = do + checkAlternatives + "jspp-options" + "include-dirs" + [(flag, dir) | flag@('-' : 'I' : dir) <- opts] + mapM_ + ( \opt -> + checkP + (not $ any (`isPrefixOf` opt) ["-D", "-U", "-I"]) + (PackageBuildWarning (OptJSPP opt)) ) opts diff --git a/src/Distribution/PackageDescription/Check/Warning.hs b/src/Distribution/PackageDescription/Check/Warning.hs --- a/src/Distribution/PackageDescription/Check/Warning.hs +++ b/src/Distribution/PackageDescription/Check/Warning.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -25,7 +24,7 @@ , ppPackageCheck , ppCheckExplanationId , isHackageDistError - , extractCheckExplantion + , extractCheckExplanation , filterPackageChecksById , filterPackageChecksByIdString ) where @@ -124,7 +123,7 @@ ff c = flip notElem is . checkExplanationId - . extractCheckExplantion + . extractCheckExplanation $ c -- | Filter Package Check by Check explanation /string/. @@ -171,6 +170,7 @@ | UnknownExtensions [String] | LanguagesAsExtension [String] | DeprecatedExtensions [(Extension, Maybe Extension)] + | FreeTextDotline String | MissingFieldCategory | MissingFieldMaintainer | MissingFieldSynopsis @@ -215,6 +215,7 @@ | OptWithRts String | COptONumber String WarnLang | COptCPP String + | OptJSPP String | OptAlternatives String String [(String, String)] | RelativeOutside String FilePath | AbsolutePath String FilePath @@ -244,7 +245,7 @@ | CVSourceRepository | CVExtensions CabalSpecVersion [Extension] | CVCustomSetup - | CVExpliticDepsCustomSetup + | CVExplicitDepsCustomSetup | CVAutogenPaths | CVAutogenPackageInfo | CVAutogenPackageInfoGuard @@ -296,14 +297,14 @@ -- to be a ad hoc monoid. -- Convenience. -extractCheckExplantion :: PackageCheck -> CheckExplanation -extractCheckExplantion (PackageBuildImpossible e) = e -extractCheckExplantion (PackageBuildWarning e) = e -extractCheckExplantion (PackageDistSuspicious e) = e -extractCheckExplantion (PackageDistSuspiciousWarn e) = e -extractCheckExplantion (PackageDistInexcusable e) = e +extractCheckExplanation :: PackageCheck -> CheckExplanation +extractCheckExplanation (PackageBuildImpossible e) = e +extractCheckExplanation (PackageBuildWarning e) = e +extractCheckExplanation (PackageDistSuspicious e) = e +extractCheckExplanation (PackageDistSuspiciousWarn e) = e +extractCheckExplanation (PackageDistInexcusable e) = e --- | Identifier for the speficic 'CheckExplanation'. This ensures `--ignore` +-- | Identifier for the specific 'CheckExplanation'. This ensures `--ignore` -- can output a warning on unrecognised values. -- ☞ N.B.: should be kept in sync with 'CheckExplanation'. data CheckExplanationID @@ -337,6 +338,7 @@ | CIUnknownExtensions | CILanguagesAsExtension | CIDeprecatedExtensions + | CIFreeTextDotline | CIMissingFieldCategory | CIMissingFieldMaintainer | CIMissingFieldSynopsis @@ -381,6 +383,7 @@ | CIOptWithRts | CICOptONumber | CICOptCPP + | CIOptJSPP | CIOptAlternatives | CIRelativeOutside | CIAbsolutePath @@ -410,7 +413,7 @@ | CICVSourceRepository | CICVExtensions | CICVCustomSetup - | CICVExpliticDepsCustomSetup + | CICVExplicitDepsCustomSetup | CICVAutogenPaths | CICVAutogenPackageInfo | CICVAutogenPackageInfoGuard @@ -482,6 +485,7 @@ checkExplanationId (UnknownExtensions{}) = CIUnknownExtensions checkExplanationId (LanguagesAsExtension{}) = CILanguagesAsExtension checkExplanationId (DeprecatedExtensions{}) = CIDeprecatedExtensions +checkExplanationId (FreeTextDotline{}) = CIFreeTextDotline checkExplanationId (MissingFieldCategory{}) = CIMissingFieldCategory checkExplanationId (MissingFieldMaintainer{}) = CIMissingFieldMaintainer checkExplanationId (MissingFieldSynopsis{}) = CIMissingFieldSynopsis @@ -526,6 +530,7 @@ checkExplanationId (OptWithRts{}) = CIOptWithRts checkExplanationId (COptONumber{}) = CICOptONumber checkExplanationId (COptCPP{}) = CICOptCPP +checkExplanationId (OptJSPP{}) = CIOptJSPP checkExplanationId (OptAlternatives{}) = CIOptAlternatives checkExplanationId (RelativeOutside{}) = CIRelativeOutside checkExplanationId (AbsolutePath{}) = CIAbsolutePath @@ -555,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 @@ -634,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" @@ -678,6 +684,7 @@ ppCheckExplanationId CIOptWithRts = "option-with-rtsopts" ppCheckExplanationId CICOptONumber = "option-opt-c" ppCheckExplanationId CICOptCPP = "cpp-options" +ppCheckExplanationId CIOptJSPP = "jspp-options" ppCheckExplanationId CIOptAlternatives = "misplaced-c-opt" ppCheckExplanationId CIRelativeOutside = "relative-path-outside" ppCheckExplanationId CIAbsolutePath = "absolute-path" @@ -707,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" @@ -907,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." @@ -923,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) @@ -1087,6 +1100,8 @@ ++ " --disable-optimization flag." ppExplanation (COptCPP opt) = "'cpp-options: " ++ opt ++ "' is not a portable C-preprocessor flag." +ppExplanation (OptJSPP opt) = + "'jspp-options: " ++ opt ++ "' is not a portable JavaScript-preprocessor flag." ppExplanation (OptAlternatives badField goodField flags) = "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) @@ -1243,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' " @@ -1458,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 @@ -1,12 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- {- Work around this warning: @@ -15,7 +13,7 @@ (imported from Distribution.Simple.UserHooks): Deprecated: "Please use the new testing interface instead!" -} -{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Distribution.Simple @@ -40,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 @@ -53,6 +50,7 @@ , defaultMain , defaultMainNoRead , defaultMainArgs + , defaultMainArgsWithHandles -- * Customization , UserHooks (..) @@ -66,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) @@ -119,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 @@ -138,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 @@ -155,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 @@ -170,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 @@ -186,6 +214,7 @@ setup_copyHook pkg_descr lbi _hooks flags = install_setupHooks (SetupHooks.installHooks setupHooks) + verbHandles pkg_descr lbi flags @@ -199,6 +228,7 @@ setup_installHook = defaultInstallHook_setupHooks (SetupHooks.installHooks setupHooks) + verbHandles setup_replHook :: PackageDescription @@ -208,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 @@ -223,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 @@ -237,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 () @@ -283,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 @@ -343,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' = @@ -358,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' @@ -406,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 @@ -429,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 <- @@ -453,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 @@ -481,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' @@ -499,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 <- @@ -523,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' = @@ -571,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 @@ -588,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 @@ -606,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 @@ -632,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 @@ -649,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 @@ -666,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 @@ -760,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' @@ -828,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 @@ -853,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 @@ -877,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': -- @@ -935,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) @@ -955,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 @@ -968,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 @@ -1012,7 +1072,7 @@ , LBC.hostPlatform = plat } } - ) = runConfigureScript cfg flags progs plat + ) = runConfigureScript defaultVerbosityHandles cfg flags progs plat pre_conf_comp :: SetupHooks.PreConfComponentInputs @@ -1027,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 @@ -1048,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 @@ -1097,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 @@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -25,7 +24,7 @@ import qualified Distribution.PackageDescription as PD import Distribution.Pretty -import Distribution.Simple.Build (addInternalBuildToolsFixed) +import Distribution.Simple.Build (addInternalBuildTools) import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.Errors @@ -42,6 +41,7 @@ import Distribution.Types.Benchmark (Benchmark (benchmarkBuildInfo)) import Distribution.Types.UnqualComponentName import Distribution.Utils.Path +import Distribution.Verbosity import System.Directory (doesFileExist) @@ -49,6 +49,7 @@ bench :: Args -- ^ positional command-line arguments + -> VerbosityHandles -> PD.PackageDescription -- ^ information from the .cabal file -> LBI.LocalBuildInfo @@ -56,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 @@ -72,8 +73,8 @@ lbi { -- Include any build-tool-depends on build tools internal to the current package. LBI.withPrograms = - addInternalBuildToolsFixed - (Just curDir) + addInternalBuildTools + curDir pkg_descr lbi (benchmarkBuildInfo bm) diff --git a/src/Distribution/Simple/Build.hs b/src/Distribution/Simple/Build.hs --- a/src/Distribution/Simple/Build.hs +++ b/src/Distribution/Simple/Build.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} @@ -26,6 +26,7 @@ ( -- * Build build , build_setupHooks + , buildComponent -- * Repl , repl @@ -34,6 +35,8 @@ -- * Build preparation , preBuildComponent + , runPreBuildHooks + , builtinPreBuildHooks , AutogenFile (..) , AutogenFileContents , writeBuiltinAutogenFiles @@ -48,7 +51,6 @@ -- * Handling of internal build tools , addInternalBuildTools - , addInternalBuildToolsFixed ) where import Distribution.Compat.Prelude @@ -74,7 +76,6 @@ import Distribution.Package import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.HaskellSuite as HaskellSuite import qualified Distribution.Simple.PackageIndex as Index import qualified Distribution.Simple.UHC as UHC @@ -94,11 +95,11 @@ 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 import Distribution.Simple.Program -import Distribution.Simple.Program.Builtin (haskellSuiteProgram) import Distribution.Simple.Program.Db import qualified Distribution.Simple.Program.GHC as GHC import Distribution.Simple.Program.Types @@ -108,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 @@ -130,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) -- ----------------------------------------------------------------------------- @@ -147,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 @@ -159,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: " @@ -192,36 +203,26 @@ 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 -- Include any build-tool-depends on build tools internal to the current package. - progs' = addInternalBuildToolsFixed (Just curDir) pkg_descr lbi bi (withPrograms lbi) + progs' = addInternalBuildTools curDir pkg_descr lbi bi (withPrograms lbi) lbi' = lbi { withPrograms = progs' , 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 @@ -229,6 +230,7 @@ NoFlag -> Serial mb_ipi <- buildComponent + verbHandles flags par_strat pkg_descr @@ -243,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. @@ -305,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 @@ -320,7 +318,6 @@ flavorToProgram GHCJS = Just ghcjsProgram flavorToProgram UHC = Just uhcProgram flavorToProgram JHC = Just jhcProgram - flavorToProgram HaskellSuite{} = Just haskellSuiteProgram flavorToProgram _ = Nothing repl @@ -334,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 @@ -348,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: " @@ -386,34 +394,26 @@ { withPackageDB = withPackageDB lbi' ++ [internalPackageDB] , withPrograms = -- Include any build-tool-depends on build tools internal to the current package. - addInternalBuildToolsFixed - (Just curDir) + addInternalBuildTools + curDir pkg_descr lbi' (componentBuildInfo comp) (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' @@ -421,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 @@ -446,7 +451,8 @@ _ -> dieWithException verbosity REPLNotSupported buildComponent - :: BuildFlags + :: VerbosityHandles + -> BuildFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo @@ -455,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 @@ -478,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 @@ -492,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. @@ -514,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 @@ -523,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' @@ -542,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. @@ -571,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) @@ -620,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 @@ -630,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 @@ -640,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) ) ) @@ -724,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 @@ -735,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" @@ -879,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 @@ -914,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 @@ -931,18 +939,14 @@ -- directory environment variable for the current package to the current -- 'progOverrideEnv', so that any programs configured from now on will be -- able to invoke these build tools. --- --- NB: This function will be removed in the next Cabal major version --- (use addInternalBuildTools instead). This function is introduced solely for --- backporting in a PVP compliant way. -addInternalBuildToolsFixed - :: Maybe (AbsolutePath (Dir Pkg)) +addInternalBuildTools + :: AbsolutePath (Dir Pkg) -> PackageDescription -> LocalBuildInfo -> BuildInfo -> ProgramDb -> ProgramDb -addInternalBuildToolsFixed mpwd pkg lbi bi progs = +addInternalBuildTools pwd pkg lbi bi progs = prependProgramSearchPathNoLogging internalToolPaths [pkgDataDirVar] @@ -962,44 +966,28 @@ makeRelativePathEx (toolName' toolName' <.> exeExtension (hostPlatform lbi)) ] + -- This is an absolute path, so if a process changes directory, it can still + -- find the datadir (#10717) dataDirPath :: FilePath - dataDirPath = - case mpwd of - -- This is an absolute path, so if a process changes directory, it can still - -- find the datadir (#10717) - Just pwd -> interpretSymbolicPathAbsolute pwd (dataDir pkg) - -- This is just wrong, but implemented for PVP compliance.. - Nothing -> interpretSymbolicPathCWD (dataDir pkg) - -{-# WARNING addInternalBuildTools "This function is broken, use addInternalBuildToolsFixed instead" #-} - --- | A backwards compatible (broken) version of `addInternalBuildTools`, do not --- use this function. Use 'addInternalBuildToolsFixed' instead. -addInternalBuildTools - :: PackageDescription - -> LocalBuildInfo - -> BuildInfo - -> ProgramDb - -> ProgramDb -addInternalBuildTools = addInternalBuildToolsFixed Nothing + dataDirPath = interpretSymbolicPathAbsolute pwd (dataDir pkg) -- TODO: build separate libs in separate dirs so that we can build -- multiple libs, e.g. for 'LibTest' library-style test suites 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 - HaskellSuite{} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi _ -> dieWithException verbosity BuildingNotSupportedWithCompiler -- | Build a foreign library @@ -1035,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) @@ -1074,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. @@ -1144,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 @@ -1199,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 @@ -1,7 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} - module Distribution.Simple.Build.Inputs ( -- * Inputs of actions for building components PreBuildComponentInputs (..) @@ -48,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/Macros.hs b/src/Distribution/Simple/Build/Macros.hs --- a/src/Distribution/Simple/Build/Macros.hs +++ b/src/Distribution/Simple/Build/Macros.hs @@ -58,7 +58,7 @@ , let (major1, major2, minor) = majorMinor ver ] , Z.zPackageKey = case clbi of - LibComponentLocalBuildInfo{} -> componentCompatPackageKey clbi + LibComponentLocalBuildInfo{componentCompatPackageKey = compatPackageKey} -> compatPackageKey _ -> "" , Z.zComponentId = prettyShow (componentComponentId clbi) , Z.zPackageVersion = pkgVersion (package pkg_descr) diff --git a/src/Distribution/Simple/Build/PackageInfoModule.hs b/src/Distribution/Simple/Build/PackageInfoModule.hs --- a/src/Distribution/Simple/Build/PackageInfoModule.hs +++ b/src/Distribution/Simple/Build/PackageInfoModule.hs @@ -10,7 +10,7 @@ -- Generating the PackageInfo_pkgname module. -- -- This is a module that Cabal generates for the benefit of packages. It --- enables them to find their package informations. +-- enables them to find their package information. module Distribution.Simple.Build.PackageInfoModule ( generatePackageInfoModule ) where @@ -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,20 +10,30 @@ , 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 -fno-warn-missing-import-lists #-}\n" + tell "{-# LANGUAGE NoRebindableSyntax #-}\n" tell "{-# OPTIONS_GHC -w #-}\n" + tell "\n" + tell "{-|\n" + tell "Module : PackageInfo_" + tell (zPackageName z_root) + tell "\n" + tell "Description : Contents of some of the package's Cabal file's fields.\n" + tell "\n" + tell "WARNING: This module was generated by Cabal. Any modifications will be\n" + tell "overwritten if the module is regenerated.\n" + tell "\n" + tell "This module exports values that record information from some of the fields of\n" + tell "the package's Cabal package description file (Cabal file).\n" + tell "\n" + tell "For further information about the fields in a Cabal file, see the Cabal User\n" + tell "Guide.\n" + tell "-}\n" + tell "\n" tell "module PackageInfo_" tell (zPackageName z_root) tell " (\n" @@ -37,23 +47,29 @@ tell "import Data.Version (Version(..))\n" tell "import Prelude\n" tell "\n" + tell "-- |The content of the @name@ field of the package's Cabal file, but with any\n" + tell "-- hyphen characters replaced by underscore characters.\n" tell "name :: String\n" tell "name = " tell (show $ zPackageName z_root) tell "\n" + tell "-- |The content of the @version@ field of the package's Cabal file.\n" tell "version :: Version\n" tell "version = Version " tell (zVersionDigits z_root) tell " []\n" tell "\n" + tell "-- |The content of the @synopsis@ field of the package's Cabal file.\n" tell "synopsis :: String\n" tell "synopsis = " tell (show $ zSynopsis z_root) tell "\n" + tell "-- |The content of the @copyright@ field of the package's Cabal file.\n" tell "copyright :: String\n" tell "copyright = " tell (show $ zCopyright z_root) tell "\n" + tell "-- |The content of the @homepage@ field of the package's Cabal file.\n" tell "homepage :: String\n" tell "homepage = " tell (show $ zHomepage z_root) diff --git a/src/Distribution/Simple/Build/PathsModule.hs b/src/Distribution/Simple/Build/PathsModule.hs --- a/src/Distribution/Simple/Build/PathsModule.hs +++ b/src/Distribution/Simple/Build/PathsModule.hs @@ -44,13 +44,12 @@ 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 , Z.zIsI386 = buildArch == I386 , Z.zIsX8664 = buildArch == X86_64 + , Z.zIsAArch64 = buildArch == AArch64 , Z.zNot = not , Z.zManglePkgName = showPkgName , Z.zPrefix = show flat_prefix @@ -62,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,13 +5,12 @@ data Z = Z {zPackageName :: PackageName, zVersionDigits :: String, - zSupportsCpp :: Bool, - zSupportsNoRebindableSyntax :: Bool, zAbsolute :: Bool, zRelocatable :: Bool, zIsWindows :: Bool, zIsI386 :: Bool, zIsX8664 :: Bool, + zIsAArch64 :: Bool, zPrefix :: FilePath, zBindir :: FilePath, zLibdir :: FilePath, @@ -24,34 +23,34 @@ 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 -fno-warn-missing-import-lists #-}\n" tell "{-# OPTIONS_GHC -w #-}\n" + tell "\n" + tell "{-|\n" + tell "Module : Paths_" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "\n" + tell "Description : Data file location, and package version and installation\n" + tell " directories.\n" + tell "\n" + tell "WARNING: This module was generated by Cabal. Any modifications will be\n" + tell "overwritten if the module is regenerated.\n" + tell "\n" + tell "This module exports a function to locate data files, and values that record\n" + tell "the version of the package and some directories which the package has been\n" + tell "configured to be installed into.\n" + tell "\n" + tell "For further information about Cabal's options for its configuration step, and\n" + tell "their default values, see the Cabal User Guide.\n" + tell "-}\n" + tell "\n" tell "module Paths_" tell (zManglePkgName z_root (zPackageName z_root)) tell " (\n" @@ -69,7 +68,6 @@ return () tell "\n" tell "import qualified Control.Exception as Exception\n" - tell "import qualified Data.List as List\n" tell "import Data.Version (Version(..))\n" tell "import System.Environment (getEnv)\n" tell "import Prelude\n" @@ -81,38 +79,67 @@ 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" tell "version = Version " tell (zVersionDigits z_root) tell " []\n" tell "\n" + tell "-- |If the argument is a filename, the result is the name of a corresponding\n" + tell "-- file on the system on which the program is running, if the file were listed\n" + tell "-- in the @data-files@ field of the package's Cabal package description file.\n" + tell "-- No check is performed that the given filename is listed in that field.\n" tell "getDataFileName :: FilePath -> IO FilePath\n" tell "getDataFileName name = do\n" tell " dir <- getDataDir\n" tell " return (dir `joinFileName` name)\n" tell "\n" - tell "getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n" + tell "-- |The location of the directory specified by Cabal's @--bindir@ option (where\n" + tell "-- executables that the user might invoke are installed). This can be overridden\n" + tell "-- at runtime using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_bindir.\n" + tell "getBinDir :: IO FilePath\n" tell "\n" + tell "-- |The location of the directory specified by Cabal's @--libdir@ option (where\n" + tell "-- object libraries are installed). This can be overridden at runtime using the\n" + tell "-- environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libdir.\n" + tell "getLibDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--dynlibdir@ option\n" + tell "-- (where dynamic libraries are installed). This can be overridden at runtime\n" + tell "-- using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_dynlibdir.\n" + tell "getDynLibDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--datadir@ option (where\n" + tell "-- architecture-independent data files are installed). This can be overridden at\n" + tell "-- runtime using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_datadir.\n" + tell "getDataDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--libexedir@ option\n" + tell "-- (where executables that are not expected to be invoked directly by the user\n" + tell "-- are installed). This can be overridden at runtime using the environment\n" + tell "-- variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libexedir.\n" + tell "getLibexecDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--sysconfdir@ option\n" + tell "-- (where configuration files are installed). This can be overridden at runtime\n" + tell "-- using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_sysconfdir.\n" + tell "getSysconfDir :: IO FilePath\n" + tell "\n" let z_var0_function_defs = do tell "minusFileName :: FilePath -> String -> FilePath\n" @@ -285,9 +312,16 @@ tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" return () else do - tell "-- win32 supported only with I386, X86_64\n" - tell "c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" - tell "c_GetModuleFileName = _\n" + if (zIsAArch64 z_root) + then do + tell "foreign import ccall unsafe \"windows.h GetModuleFileNameW\"\n" + tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + return () + else do + tell "-- win32 supported only with I386, X86_64, AArch64\n" + tell "c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + tell "c_GetModuleFileName = _\n" + return () return () return () tell "\n" @@ -306,9 +340,14 @@ tell "joinFileName \"\" fname = fname\n" tell "joinFileName \".\" fname = fname\n" tell "joinFileName dir \"\" = dir\n" - tell "joinFileName dir fname\n" - tell " | isPathSeparator (List.last dir) = dir ++ fname\n" + tell "joinFileName dir@(c:cs) fname\n" + tell " | isPathSeparator (lastChar c cs) = dir ++ fname\n" tell " | otherwise = dir ++ pathSeparator : fname\n" + tell " where\n" + tell " -- We do not use Data.List.NonEmpty.last, as that would limit the module to\n" + tell " -- base >= 4.9.0.0 (GHC >= 8.0.1).\n" + tell " lastChar x [] = x\n" + tell " lastChar _ (x:xs) = lastChar x xs\n" tell "\n" tell "pathSeparator :: Char\n" if (zIsWindows z_root) diff --git a/src/Distribution/Simple/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 @@ -2,8 +2,9 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -41,6 +42,7 @@ , reportBuildTargetProblems ) where +import Data.Bifunctor (second) import Distribution.Compat.Prelude import Prelude () @@ -131,6 +133,9 @@ BuildTargetFile ComponentName FilePath deriving (Eq, Show, Generic) +-- | @since 3.18 +deriving instance Ord BuildTarget + instance Binary BuildTarget buildTargetComponentName :: BuildTarget -> ComponentName @@ -229,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 @@ -327,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] @@ -354,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 @@ -408,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 () @@ -418,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 @@ -653,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) @@ -854,6 +859,9 @@ | MatchErrorNoSuch String String deriving (Show, Eq) +-- | @since 3.18 +deriving instance Ord MatchError + instance Alternative Match where empty = mzero (<|>) = mplus @@ -906,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 @@ -942,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 @@ -969,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' @@ -1017,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/BuildToolDepends.hs b/src/Distribution/Simple/BuildToolDepends.hs --- a/src/Distribution/Simple/BuildToolDepends.hs +++ b/src/Distribution/Simple/BuildToolDepends.hs @@ -13,7 +13,7 @@ import Distribution.Package import Distribution.PackageDescription --- | Same as 'desugarBuildTool', but requires atomic informations (package +-- | Same as 'desugarBuildTool', but requires atomic information (package -- name, executable names) instead of a whole 'PackageDescription'. desugarBuildToolSimple :: PackageName @@ -34,7 +34,6 @@ , "hsc2hs" , "c2hs" , "cpphs" - , "greencard" , "hspec-discover" ] allowMap = Map.fromList $ flip map allowlist $ \n -> diff --git a/src/Distribution/Simple/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 @@ -624,8 +625,8 @@ -- | Mark command as hidden. Hidden commands don't show up in the 'progname -- help' or 'progname --help' output. hiddenCommand :: Command action -> Command action -hiddenCommand (Command name synopsys f _cmdType) = - Command name synopsys f HiddenCommand +hiddenCommand (Command name synopsis f _cmdType) = + Command name synopsis f HiddenCommand commandAddAction :: CommandUI flags @@ -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 @@ -1,6 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} @@ -52,6 +50,7 @@ , interpretPackageDBStack , coercePackageDB , coercePackageDBStack + , readPackageDb -- * Support for optimisation levels , OptimisationLevel (..) @@ -80,12 +79,15 @@ , profilingVanillaSupported , profilingVanillaSupportedOrUnknown , dynamicSupported + , bytecodeArtifactsSupported , backpackSupported , arResponseFilesSupported , arDashLSupported , libraryDynDirSupported , libraryVisibilitySupported , jsemSupported + , jsemVersion + , reexportedAsSupported -- * Support for profiling detail levels , ProfDetailLevel (..) @@ -94,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) @@ -121,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 @@ -179,6 +193,7 @@ (Just . compilerCompat $ c) (Just . map fst . compilerLanguages $ c) (Just . map fst . compilerExtensions $ c) + (compilerWiredInUnitIds c) -- ------------------------------------------------------------ @@ -202,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: @@ -293,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 @@ -326,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 @@ -356,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 @@ -376,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. @@ -434,19 +481,29 @@ 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 + GHC -> v >= mkVersion [9, 12] + _ -> False + where + v = compilerVersion comp + -- | Does this compiler support a package database entry with: -- "dynamic-library-dirs"? libraryDynDirSupported :: Compiler -> Bool 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). @@ -481,7 +538,7 @@ waySupported way comp = case compilerFlavor comp of GHC -> - -- Infomation about compiler ways is only accurately reported after + -- Information about compiler ways is only accurately reported after -- 9.10.1. Which is useful as this is before profiling dynamic support -- was introduced. (See GHC #24881) if compilerVersion comp >= mkVersion [9, 10, 1] @@ -502,11 +559,13 @@ -- | Is the compiler distributed with profiling dynamic libraries profilingDynamicSupported :: Compiler -> Maybe Bool -profilingDynamicSupported comp = - -- Certainly not before this version, as it was not implemented yet. - if compilerVersion comp <= mkVersion [9, 11, 0] - then Just False - else waySupported "p_dyn" comp +profilingDynamicSupported comp + | GHC <- compilerFlavor comp + , -- Certainly not before 9.11, as prof+dyn was not implemented yet. + compilerVersion comp <= mkVersion [9, 11, 0] = + Just False + | otherwise = + waySupported "p_dyn" comp -- | Either profiling dynamic is definitely supported or we don't know (so assume -- it is) @@ -518,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 @@ -563,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,2855 +5,3093 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} - ------------------------------------------------------------------------------ - --- | --- Module : Distribution.Simple.Configure --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This deals with the /configure/ phase. It provides the 'configure' action --- which is given the package description and configure flags. It then tries --- to: configure the compiler; resolves any conditionals in the package --- description; resolve the package dependencies; check if all the extensions --- used by this package are supported by the compiler; check that all the build --- tools are available (including version checks if appropriate); checks for --- any required @pkg-config@ packages (updating the 'BuildInfo' with the --- results) --- --- Then based on all this it saves the info in the 'LocalBuildInfo' and writes --- it out to the @dist\/setup-config@ file. It also displays various details to --- the user, the amount of information displayed depending on the verbosity --- level. -module Distribution.Simple.Configure - ( configure - , configure_setupHooks - , writePersistBuildConfig - , getConfigStateFile - , getPersistBuildConfig - , checkPersistBuildConfigOutdated - , tryGetPersistBuildConfig - , maybeGetPersistBuildConfig - , findDistPref - , findDistPrefOrDefault - , getInternalLibraries - , computeComponentId - , computeCompatPackageKey - , localBuildInfoFile - , getInstalledPackages - , getInstalledPackagesMonitorFiles - , getInstalledPackagesById - , getPackageDBContents - , configCompilerEx - , configCompilerAuxEx - , computeEffectiveProfiling - , ccLdOptionsBuildInfo - , checkForeignDeps - , interpretPackageDbFlags - , ConfigStateFileError (..) - , tryGetConfigStateFile - , platformDefines - ) where - -import Control.Monad -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack.Configure -import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour) -import Distribution.Backpack.DescribeUnitId -import Distribution.Backpack.Id -import Distribution.Backpack.PreExistingComponent -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Stack -import Distribution.Compiler -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Package -import Distribution.PackageDescription -import Distribution.PackageDescription.Check hiding (doesFileExist) -import Distribution.PackageDescription.Configuration -import Distribution.PackageDescription.PrettyPrint -import Distribution.Simple.BuildTarget -import Distribution.Simple.BuildToolDepends -import Distribution.Simple.BuildWay -import Distribution.Simple.Compiler -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.PackageIndex (InstalledPackageIndex, lookupUnitId) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PreProcess -import Distribution.Simple.Program -import Distribution.Simple.Program.Db - ( ProgramDb (..) - , lookupProgramByName - , modifyProgramSearchPath - , prependProgramSearchPath - , updateConfiguredProgs - ) -import Distribution.Simple.Setup.Common as Setup -import Distribution.Simple.Setup.Config as Setup -import Distribution.Simple.SetupHooks.Internal - ( ConfigureHooks (..) - , applyComponentDiffs - , noConfigureHooks - ) -import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.GivenComponent -import qualified Distribution.Types.LocalBuildConfig as LBC -import Distribution.Types.LocalBuildInfo -import Distribution.Types.PackageVersionConstraint -import Distribution.Utils.LogProgress -import Distribution.Utils.NubList -import Distribution.Verbosity -import Distribution.Version - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.HaskellSuite as HaskellSuite -import qualified Distribution.Simple.UHC as UHC - -import Control.Exception - ( try - ) -import qualified Data.ByteString as BS -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy.Char8 as BLC8 -import Data.List - ( intersect - , stripPrefix - , (\\) - ) -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 - ) -import Distribution.Pretty - ( defaultStyle - , pretty - , prettyShow - ) -import Distribution.Simple.Errors -import Distribution.Types.AnnotatedId -import Distribution.Utils.Path -import Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncode) -import System.Directory - ( canonicalizePath - , createDirectoryIfMissing - , doesFileExist - , getTemporaryDirectory - , removeFile - ) -import System.FilePath - ( isAbsolute - ) -import System.IO - ( hClose - , hPutStrLn - ) -import qualified System.Info - ( compilerName - , compilerVersion - ) -import Text.PrettyPrint - ( Doc - , char - , hsep - , quotes - , renderStyle - , text - , ($+$) - ) - -import qualified Data.Maybe as M -import qualified Data.Set as Set -import qualified Distribution.Compat.NonEmptySet as NES - -type UseExternalInternalDeps = Bool - --- | The errors that can be thrown when reading the @setup-config@ file. -data ConfigStateFileError - = -- | No header found. - ConfigStateFileNoHeader - | -- | Incorrect header. - ConfigStateFileBadHeader - | -- | Cannot parse file contents. - ConfigStateFileNoParse - | -- | No file! - ConfigStateFileMissing - { cfgStateFileErrorCwd :: Maybe (SymbolicPath CWD (Dir Pkg)) - , cfgStateFileErrorFile :: SymbolicPath Pkg File - } - | -- | Mismatched version. - ConfigStateFileBadVersion - PackageIdentifier - PackageIdentifier - (Either ConfigStateFileError LocalBuildInfo) - --- | Format a 'ConfigStateFileError' as a user-facing error message. -dispConfigStateFileError :: ConfigStateFileError -> Doc -dispConfigStateFileError ConfigStateFileNoHeader = - text "Saved package config file header is missing." - <+> text "Re-run the 'Setup configure' command." -dispConfigStateFileError ConfigStateFileBadHeader = - text "Saved package config file header is corrupt." - <+> text "Re-run the 'Setup configure' command." -dispConfigStateFileError ConfigStateFileNoParse = - text "Saved package config file is corrupt." - <+> text "Re-run the 'Setup configure' command." -dispConfigStateFileError ConfigStateFileMissing{} = - text "Run the 'Setup configure' command first." -dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) = - text "Saved package config file is outdated:" - $+$ badCabal - $+$ badCompiler - $+$ text "Re-run the 'Setup configure' command." - where - badCabal = - text "• the Cabal version changed from" - <+> pretty oldCabal - <+> "to" - <+> pretty currentCabalId - badCompiler - | oldCompiler == currentCompilerId = mempty - | otherwise = - text "• the compiler changed from" - <+> pretty oldCompiler - <+> "to" - <+> pretty currentCompilerId - -instance Show ConfigStateFileError where - show = renderStyle defaultStyle . dispConfigStateFileError - -instance Exception ConfigStateFileError - --- | Read the 'localBuildInfoFile'. Throw an exception if the file is --- missing, if the file cannot be read, or if the file was created by an older --- version of Cabal. -getConfigStateFile - :: Maybe (SymbolicPath CWD (Dir Pkg)) - -> SymbolicPath Pkg File - -- ^ The file path of the @setup-config@ file. - -> IO LocalBuildInfo -getConfigStateFile mbWorkDir setupConfigFile = do - let filename = interpretSymbolicPath mbWorkDir setupConfigFile - exists <- doesFileExist filename - unless exists $ throwIO $ ConfigStateFileMissing mbWorkDir setupConfigFile - -- Read the config file into a strict ByteString to avoid problems with - -- lazy I/O, then convert to lazy because the binary package needs that. - contents <- BS.readFile filename - let (header, body) = BLC8.span (/= '\n') (BLC8.fromChunks [contents]) - - (cabalId, compId) <- parseHeader header - - let getStoredValue = do - result <- structuredDecodeOrFailIO (BLC8.tail body) - case result of - Left _ -> throwIO ConfigStateFileNoParse - Right x -> return x - deferErrorIfBadVersion act - | cabalId /= currentCabalId = do - eResult <- try act - throwIO $ ConfigStateFileBadVersion cabalId compId eResult - | otherwise = act - deferErrorIfBadVersion getStoredValue - where - _ = callStack -- TODO: attach call stack to exception - --- | Read the 'localBuildInfoFile', returning either an error or the local build --- info. -tryGetConfigStateFile - :: Maybe (SymbolicPath CWD (Dir Pkg)) - -- ^ Working directory. - -> SymbolicPath Pkg File - -- ^ The file path of the @setup-config@ file. - -> IO (Either ConfigStateFileError LocalBuildInfo) -tryGetConfigStateFile mbWorkDir = try . getConfigStateFile mbWorkDir - --- | Try to read the 'localBuildInfoFile'. -tryGetPersistBuildConfig - :: Maybe (SymbolicPath CWD (Dir Pkg)) - -- ^ Working directory. - -> SymbolicPath Pkg (Dir Dist) - -- ^ The @dist@ directory path. - -> IO (Either ConfigStateFileError LocalBuildInfo) -tryGetPersistBuildConfig mbWorkDir = try . getPersistBuildConfig mbWorkDir - --- | Read the 'localBuildInfoFile'. Throw an exception if the file is --- missing, if the file cannot be read, or if the file was created by an older --- version of Cabal. -getPersistBuildConfig - :: Maybe (SymbolicPath CWD (Dir Pkg)) - -- ^ Working directory. - -> SymbolicPath Pkg (Dir Dist) - -- ^ The @dist@ directory path. - -> IO LocalBuildInfo -getPersistBuildConfig mbWorkDir distPref = - getConfigStateFile mbWorkDir $ localBuildInfoFile distPref - --- | Try to read the 'localBuildInfoFile'. -maybeGetPersistBuildConfig - :: Maybe (SymbolicPath CWD (Dir Pkg)) - -- ^ Working directory. - -> SymbolicPath Pkg (Dir Dist) - -- ^ The @dist@ directory path. - -> IO (Maybe LocalBuildInfo) -maybeGetPersistBuildConfig mbWorkDir = - liftM (either (const Nothing) Just) . tryGetPersistBuildConfig mbWorkDir - --- | After running configure, output the 'LocalBuildInfo' to the --- 'localBuildInfoFile'. -writePersistBuildConfig - :: Maybe (SymbolicPath CWD (Dir Pkg)) - -- ^ Working directory - -> SymbolicPath Pkg (Dir Dist) - -- ^ The @dist@ directory path. - -> LocalBuildInfo - -- ^ The 'LocalBuildInfo' to write. - -> IO () -writePersistBuildConfig mbWorkDir distPref lbi = do - createDirectoryIfMissing False (i distPref) - writeFileAtomic (i $ localBuildInfoFile distPref) $ - BLC8.unlines [showHeader pkgId, structuredEncode lbi] - where - i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path - pkgId = localPackage lbi - --- | Identifier of the current Cabal package. -currentCabalId :: PackageIdentifier -currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion - --- | Identifier of the current compiler package. -currentCompilerId :: PackageIdentifier -currentCompilerId = - PackageIdentifier - (mkPackageName System.Info.compilerName) - (mkVersion' System.Info.compilerVersion) - --- | Parse the @setup-config@ file header, returning the package identifiers --- for Cabal and the compiler. -parseHeader - :: ByteString - -- ^ The file contents. - -> IO (PackageIdentifier, PackageIdentifier) -parseHeader header = case BLC8.words header of - [ "Saved" - , "package" - , "config" - , "for" - , pkgId - , "written" - , "by" - , cabalId - , "using" - , compId - ] -> - maybe (throwIO ConfigStateFileBadHeader) return $ do - _ <- simpleParsec (fromUTF8LBS pkgId) :: Maybe PackageIdentifier - cabalId' <- simpleParsec (BLC8.unpack cabalId) - compId' <- simpleParsec (BLC8.unpack compId) - return (cabalId', compId') - _ -> throwIO ConfigStateFileNoHeader - --- | Generate the @setup-config@ file header. -showHeader - :: PackageIdentifier - -- ^ The processed package. - -> ByteString -showHeader pkgId = - BLC8.unwords - [ "Saved" - , "package" - , "config" - , "for" - , toUTF8LBS $ prettyShow pkgId - , "written" - , "by" - , BLC8.pack $ prettyShow currentCabalId - , "using" - , BLC8.pack $ prettyShow currentCompilerId - ] - --- | Check that localBuildInfoFile is up-to-date with respect to the --- .cabal file. -checkPersistBuildConfigOutdated - :: Maybe (SymbolicPath CWD (Dir Pkg)) - -> SymbolicPath Pkg (Dir Dist) - -> SymbolicPath Pkg File - -> IO Bool -checkPersistBuildConfigOutdated mbWorkDir distPref pkg_descr_file = - i pkg_descr_file `moreRecentFile` i (localBuildInfoFile distPref) - where - i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path - --- | Get the path of @dist\/setup-config@. -localBuildInfoFile - :: SymbolicPath Pkg (Dir Dist) - -- ^ The @dist@ directory path. - -> SymbolicPath Pkg File -localBuildInfoFile distPref = distPref makeRelativePathEx "setup-config" - --- ----------------------------------------------------------------------------- - --- * Configuration - --- ----------------------------------------------------------------------------- - --- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken --- from (in order of highest to lowest preference) the override prefix, the --- \"CABAL_BUILDDIR\" environment variable, or the default prefix. -findDistPref - :: SymbolicPath Pkg (Dir Dist) - -- ^ default \"dist\" prefix - -> Setup.Flag (SymbolicPath Pkg (Dir Dist)) - -- ^ override \"dist\" prefix - -> IO (SymbolicPath Pkg (Dir Dist)) -findDistPref defDistPref overrideDistPref = do - envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR") - return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref) - where - parseEnvDistPref env = - case env of - Just distPref | not (null distPref) -> toFlag $ makeSymbolicPath distPref - _ -> NoFlag - --- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken --- from (in order of highest to lowest preference) the override prefix, the --- \"CABAL_BUILDDIR\" environment variable, or 'defaultDistPref' is used. Call --- this function to resolve a @*DistPref@ flag whenever it is not known to be --- set. (The @*DistPref@ flags are always set to a definite value before --- invoking 'UserHooks'.) -findDistPrefOrDefault - :: Setup.Flag (SymbolicPath Pkg (Dir Dist)) - -- ^ override \"dist\" prefix - -> IO (SymbolicPath Pkg (Dir Dist)) -findDistPrefOrDefault = findDistPref defaultDistPref - --- | Perform the \"@.\/setup configure@\" action. --- Returns the @.setup-config@ file. -configure - :: (GenericPackageDescription, HookedBuildInfo) - -> ConfigFlags - -> IO LocalBuildInfo -configure = configure_setupHooks noConfigureHooks - -configure_setupHooks - :: ConfigureHooks - -> (GenericPackageDescription, HookedBuildInfo) - -> ConfigFlags - -> IO LocalBuildInfo -configure_setupHooks - (ConfigureHooks{preConfPackageHook, postConfPackageHook, preConfComponentHook}) - (g_pkg_descr, hookedBuildInfo) - 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 - - -- 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 - } - - -- Cabal package-wide configure - (lbc2, pbd2, pkg_info) <- - finalizeAndConfigurePackage cfg lbc1 g_pkg_descr comp platform enabledComps - - -- Package-wide post-configure hook - for_ postConfPackageHook $ \postConfPkg -> do - let input = - SetupHooks.PostConfPackageInputs - { SetupHooks.localBuildConfig = lbc2 - , SetupHooks.packageBuildDescr = pbd2 - } - postConfPkg input - - -- 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} - - -- Cabal per-component configure - externalPkgDeps <- finalCheckPackage g_pkg_descr pbd3 hookedBuildInfo pkg_info - lbi <- configureComponents lbc2 pbd3 pkg_info externalPkgDeps - - writePersistBuildConfig mbWorkDir distPref lbi - - return lbi - -preConfigurePackage - :: ConfigFlags - -> GenericPackageDescription - -> IO (LBC.LocalBuildConfig, Compiler, Platform, ComponentRequestedSpec) -preConfigurePackage cfg g_pkg_descr = do - let verbosity = 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 - -- the package since at this point, we're not really sure what - -- components we *can* configure. @Nothing@ means that we should - -- configure everything (the old behavior). - (mb_cname :: Maybe ComponentName) <- do - let flat_pkg_descr = flattenPackageDescription g_pkg_descr - targets0 = configTargets cfg - targets <- readBuildTargets verbosity flat_pkg_descr targets0 - -- TODO: bleat if you use the module/file syntax - let targets' = [cname | BuildTargetComponent cname <- targets] - case targets' of - _ | null targets0 -> return Nothing - [cname] -> return (Just cname) - [] -> dieWithException verbosity NoValidComponent - _ -> dieWithException verbosity ConfigureEitherSingleOrAll - - case mb_cname of - Nothing -> setupMessage verbosity "Configuring" (packageId g_pkg_descr) - Just cname -> - setupMessage' - verbosity - "Configuring" - (packageId g_pkg_descr) - cname - (Just (configInstantiateWith cfg)) - - -- configCID is only valid for per-component configure - when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ - dieWithException verbosity ConfigCIDValidForPreComponent - - -- Make a data structure describing what components are enabled. - let enabled :: ComponentRequestedSpec - enabled = case mb_cname of - Just cname -> OneComponentRequestedSpec cname - Nothing -> - ComponentRequestedSpec - { -- The flag name (@--enable-tests@) is a - -- little bit of a misnomer, because - -- just passing this flag won't - -- "enable", in our internal - -- nomenclature; it's just a request; a - -- @buildable: False@ might make it - -- not possible to enable. - testsRequested = fromFlag (configTests cfg) - , benchmarksRequested = - fromFlag (configBenchmarks cfg) - } - -- Some sanity checks related to enabling components. - when - ( isJust mb_cname - && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg)) - ) - $ dieWithException verbosity SanityCheckForEnableComponents - - checkDeprecatedFlags verbosity cfg - checkExactConfiguration verbosity g_pkg_descr cfg - - programDbPre <- mkProgramDb 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 - -- building with - ( comp :: Compiler - , compPlatform :: Platform - , programDb00 :: ProgramDb - ) <- - configCompilerEx - (flagToMaybe (configHcFlavor cfg)) - (flagToMaybe (configHcPath cfg)) - (flagToMaybe (configHcPkg cfg)) - programDbPre - (lessVerbose verbosity) - - -- Where to build the package - let builddir :: SymbolicPath Pkg (Dir Build) -- e.g. dist/build - builddir = setupFlagsBuildDir $ configCommonFlags cfg - mbWorkDir = flagToMaybe $ configWorkingDir cfg - -- 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 $ - interpretSymbolicPath mbWorkDir builddir - - lbc <- computeLocalBuildConfig cfg comp programDb00 - return (lbc, comp, compPlatform, enabled) - -computeLocalBuildConfig - :: ConfigFlags - -> Compiler - -> ProgramDb - -> IO LBC.LocalBuildConfig -computeLocalBuildConfig 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 - - -- 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 - let ghciLibByDefault = - case compilerId comp of - CompilerId GHC _ -> - -- If ghc is non-dynamic, then ghci needs object files, - -- so we build one by default. - -- - -- Technically, archive files should be sufficient for ghci, - -- but because of GHC bug #8942, it has never been safe to - -- 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]) - 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 - -- executables are requested - True - | otherwise = case compilerId comp of - CompilerId GHC _ -> - -- if ghc is dynamic, then ghci needs a shared - -- library, so we build one by default. - GHC.compilerBuildWay comp == DynWay - CompilerId GHCJS _ -> - GHCJS.isDynamic comp - _ -> False - withSharedLib_ = - -- build shared libraries if required by GHC or by the - -- executable linking mode, but allow the user to force - -- building only static library archives with - -- --disable-shared. - fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg - - withStaticLib_ = - -- build a static library (all dependent libraries rolled - -- into a huge .a archive) via GHCs -staticlib flag. - fromFlagOrDefault False $ configStaticLib cfg - - withDynExe_ = fromFlag $ configDynExe cfg - - withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg - - setProfiling <- configureProfiling verbosity cfg comp - - setCoverage <- configureCoverage verbosity cfg comp - - -- Turn off library and executable stripping when `debug-info` is set - -- to anything other than zero. - let - strip_libexe s f = - let defaultStrip = fromFlagOrDefault True (f cfg) - in case fromFlag (configDebugInfo cfg) of - NoDebugInfo -> return defaultStrip - _ -> case f cfg of - Flag True -> do - warn verbosity $ - "Setting debug-info implies " - ++ s - ++ "-stripping: False" - return False - _ -> return False - - 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 - } - - -- 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." - - -- 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." - - return $ - LBC.LocalBuildConfig - { extraConfigArgs = [] -- Currently configure does not - -- take extra args, but if it - -- did they would go here. - , withPrograms = programDb - , withBuildOptions = buildOptions - } - -data PackageInfo = PackageInfo - { internalPackageSet :: Set LibraryName - , promisedDepsSet :: Map (PackageName, ComponentName) PromisedComponent - , installedPackageSet :: InstalledPackageIndex - , requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo - } - -configurePackage - :: 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 - let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common - - -- add extra include/lib dirs as specified in cfg - pkg_descr0 = addExtraIncludeLibDirsFromConfigFlags pkg_descr00 cfg - -- TODO: it is not clear whether this adding these dirs is necessary - -- when we are directly stating from a PackageDescription (e.g. when - -- cabal-install has determined a PackageDescription, instead of rediscovering - -- when working with a GenericPackageDescription). - -- Could this function call be moved to the end of finalizeAndConfigurePackage - -- right before calling configurePackage? - - -- Configure certain external build tools, see below for which ones. - let requiredBuildTools - -- If --ignore-build-tools is set, no build tool is required: - | fromFlagOrDefault False $ configIgnoreBuildTools cfg = - [] - | otherwise = do - bi <- enabledBuildInfos pkg_descr0 enabled - -- First, we collect any tool dep that we know is external. This is, - -- in practice: - -- - -- 1. `build-tools` entries on the whitelist - -- - -- 2. `build-tool-depends` that aren't from the current package. - let externBuildToolDeps = - [ LegacyExeDependency (unUnqualComponentName eName) versionRange - | buildTool@(ExeDependency _ eName versionRange) <- - getAllToolDependencies pkg_descr0 bi - , not $ isInternal pkg_descr0 buildTool - ] - -- Second, we collect any build-tools entry we don't know how to - -- desugar. We'll never have any idea how to build them, so we just - -- hope they are already on the PATH. - let unknownBuildTools = - [ buildTool - | buildTool <- buildTools bi - , Nothing == desugarBuildTool pkg_descr0 buildTool - ] - externBuildToolDeps ++ unknownBuildTools - - programDb1 <- - configureAllKnownPrograms (lessVerbose verbosity) programDb0 - >>= configureRequiredPrograms verbosity requiredBuildTools - - (pkg_descr2, programDb2) <- - configurePkgconfigPackages verbosity pkg_descr0 programDb1 enabled - - let use_external_internal_deps = - case enabled of - OneComponentRequestedSpec{} -> True - ComponentRequestedSpec{} -> False - - -- Compute installation directory templates, based on user - -- configuration. - -- - -- TODO: Move this into a helper function. - defaultDirs :: InstallDirTemplates <- - defaultInstallDirs' - use_external_internal_deps - (compilerFlavor comp) - (fromFlag (configUserInstall cfg)) - (hasLibs pkg_descr2) - let - installDirs = - combineInstallDirs - fromFlagOrDefault - defaultDirs - (configInstallDirs cfg) - lbc = lbc0{LBC.withPrograms = programDb2} - pbd = - LBC.PackageBuildDescr - { configFlags = cfg - , flagAssignment = flags - , componentEnabledSpec = enabled - , compiler = comp - , hostPlatform = platform - , localPkgDescr = pkg_descr2 - , installDirTemplates = installDirs - , withPackageDB = packageDbs - , pkgDescrFile = Nothing - , extraCoverageFor = [] - } - - debug verbosity $ - "Finalized package description:\n" - ++ showPackageDescription pkg_descr2 - - return (lbc, pbd) - -finalizeAndConfigurePackage - :: ConfigFlags - -> LBC.LocalBuildConfig - -> GenericPackageDescription - -> Compiler - -> Platform - -> ComponentRequestedSpec - -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr, PackageInfo) -finalizeAndConfigurePackage cfg lbc0 g_pkg_descr comp platform enabled = do - let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common - mbWorkDir = flagToMaybe $ setupWorkingDir common - - let programDb0 = LBC.withPrograms lbc0 - -- What package database(s) to use - packageDbs :: PackageDBStack - packageDbs = - interpretPackageDbFlags - (fromFlag (configUserInstall cfg)) - (configPackageDBs cfg) - - -- The InstalledPackageIndex of all installed packages - installedPackageSet :: InstalledPackageIndex <- - getInstalledPackages - (lessVerbose verbosity) - comp - mbWorkDir - packageDbs - programDb0 - - -- The set of package names which are "shadowed" by internal - -- packages, and which component they map to - let internalPackageSet :: Set LibraryName - internalPackageSet = getInternalLibraries g_pkg_descr - - -- Some sanity checks related to dynamic/static linking. - when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $ - dieWithException verbosity SanityCheckForDynamicStaticLinking - - -- allConstraints: The set of all 'Dependency's we have. Used ONLY - -- to 'configureFinalizedPackage'. - -- requiredDepsMap: A map from 'PackageName' to the specifically - -- required 'InstalledPackageInfo', due to --dependency - -- - -- NB: These constraints are to be applied to ALL components of - -- a package. Thus, it's not an error if allConstraints contains - -- more constraints than is necessary for a component (another - -- component might need it.) - -- - -- NB: The fact that we bundle all the constraints together means - -- that is not possible to configure a test-suite to use one - -- version of a dependency, and the executable to use another. - ( allConstraints :: [PackageVersionConstraint] - , requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo - ) <- - either (dieWithException verbosity) return $ - combinedConstraints - (configConstraints cfg) - (configDependencies cfg) - installedPackageSet - - let - promisedDepsSet = mkPromisedDepsSet (configPromisedDependencies cfg) - pkg_info = - PackageInfo - { internalPackageSet - , promisedDepsSet - , installedPackageSet - , requiredDepsMap - } - - -- 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 - -- simple naive algorithm, or having them be passed to - -- us by 'configConfigurationsFlags') - -- flags: The 'FlagAssignment' that the conditionals were - -- resolved with. - -- - -- NB: Why doesn't finalizing a package also tell us what the - -- dependencies are (e.g. when we run the naive algorithm, - -- we are checking if dependencies are satisfiable)? The - -- primary reason is that we may NOT have done any solving: - -- if the flags are all chosen for us, this step is a simple - -- matter of flattening according to that assignment. It's - -- cleaner to then configure the dependencies afterwards. - let use_external_internal_deps = case enabled of - OneComponentRequestedSpec{} -> True - ComponentRequestedSpec{} -> False - ( pkg_descr0 :: PackageDescription - , flags :: FlagAssignment - ) <- - configureFinalizedPackage - verbosity - cfg - enabled - allConstraints - ( dependencySatisfiable - use_external_internal_deps - (fromFlagOrDefault False (configExactConfiguration cfg)) - (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg)) - (packageName g_pkg_descr) - installedPackageSet - internalPackageSet - promisedDepsSet - requiredDepsMap - ) - comp - platform - g_pkg_descr - - (lbc, pbd) <- - configurePackage - cfg - lbc0 - pkg_descr0 - flags - enabled - comp - platform - programDb0 - packageDbs - return (lbc, pbd, pkg_info) - -addExtraIncludeLibDirsFromConfigFlags - :: PackageDescription -> ConfigFlags -> PackageDescription -addExtraIncludeLibDirsFromConfigFlags pkg_descr cfg = - let extraBi = - mempty - { extraLibDirs = configExtraLibDirs cfg - , extraLibDirsStatic = configExtraLibDirsStatic cfg - , extraFrameworkDirs = configExtraFrameworkDirs cfg - , includeDirs = configExtraIncludeDirs cfg - } - modifyLib l = - l - { libBuildInfo = - libBuildInfo l - `mappend` extraBi - } - modifyExecutable e = - e - { buildInfo = - buildInfo e - `mappend` extraBi - } - modifyForeignLib f = - f - { foreignLibBuildInfo = - foreignLibBuildInfo f - `mappend` extraBi - } - modifyTestsuite t = - t - { testBuildInfo = - testBuildInfo t - `mappend` extraBi - } - modifyBenchmark b = - b - { benchmarkBuildInfo = - benchmarkBuildInfo b - `mappend` extraBi - } - in pkg_descr - { library = modifyLib `fmap` library pkg_descr - , subLibraries = modifyLib `map` subLibraries pkg_descr - , executables = modifyExecutable `map` executables pkg_descr - , foreignLibs = modifyForeignLib `map` foreignLibs pkg_descr - , testSuites = modifyTestsuite `map` testSuites pkg_descr - , benchmarks = modifyBenchmark `map` benchmarks pkg_descr - } - -finalCheckPackage - :: GenericPackageDescription - -> LBC.PackageBuildDescr - -> HookedBuildInfo - -> PackageInfo - -> IO ([PreExistingComponent], [ConfiguredPromisedComponent]) -finalCheckPackage - g_pkg_descr - ( LBC.PackageBuildDescr - { configFlags = cfg - , localPkgDescr = pkg_descr - , compiler = comp - , hostPlatform = compPlatform - , componentEnabledSpec = enabled - } - ) - hookedBuildInfo - (PackageInfo{internalPackageSet, promisedDepsSet, installedPackageSet, requiredDepsMap}) = - do - let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common - cabalFileDir = packageRoot common - use_external_internal_deps = - case enabled of - OneComponentRequestedSpec{} -> True - ComponentRequestedSpec{} -> False - - checkCompilerProblems verbosity comp pkg_descr enabled - checkPackageProblems - verbosity - cabalFileDir - g_pkg_descr - (updatePackageDescription hookedBuildInfo pkg_descr) - -- NB: we apply the HookedBuildInfo to check it is valid, - -- but we don't propagate it. - -- Other UserHooks must separately return it again, and we - -- will re-apply it each time. - - -- Check languages and extensions - -- TODO: Move this into a helper function. - let langlist = - nub $ - catMaybes $ - map - defaultLanguage - (enabledBuildInfos pkg_descr enabled) - let langs = unsupportedLanguages comp langlist - when (not (null langs)) $ - dieWithException verbosity $ - UnsupportedLanguages (packageId g_pkg_descr) (compilerId comp) (map prettyShow langs) - let extlist = - nub $ - concatMap - allExtensions - (enabledBuildInfos pkg_descr enabled) - let exts = unsupportedExtensions comp extlist - when (not (null exts)) $ - dieWithException verbosity $ - UnsupportedLanguageExtension (packageId g_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)) $ - 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 - -> LBC.PackageBuildDescr - -> PackageInfo - -> ([PreExistingComponent], [ConfiguredPromisedComponent]) - -> IO LocalBuildInfo -configureComponents - lbc@(LBC.LocalBuildConfig{withPrograms = programDb}) - pbd0@( LBC.PackageBuildDescr - { configFlags = cfg - , localPkgDescr = pkg_descr - , compiler = comp - , componentEnabledSpec = enabled - } - ) - (PackageInfo{promisedDepsSet, installedPackageSet}) - externalPkgDeps = - do - let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common - use_external_internal_deps = - case enabled of - OneComponentRequestedSpec{} -> True - ComponentRequestedSpec{} -> False - - -- Compute internal component graph - -- - -- The general idea is that we take a look at all the source level - -- components (which may build-depends on each other) and form a graph. - -- From there, we build a ComponentLocalBuildInfo for each of the - -- components, which lets us actually build each component. - ( buildComponents :: [ComponentLocalBuildInfo] - , packageDependsIndex :: InstalledPackageIndex - ) <- - runLogProgress verbosity $ - configureComponentLocalBuildInfos - verbosity - use_external_internal_deps - enabled - (fromFlagOrDefault False (configDeterministic cfg)) - (configIPID cfg) - (configCID cfg) - pkg_descr - externalPkgDeps - (configConfigurationsFlags cfg) - (configInstantiateWith cfg) - installedPackageSet - comp - - let buildComponentsMap = - foldl' - ( \m clbi -> - Map.insertWith - (++) - (componentLocalName clbi) - [clbi] - m - ) - Map.empty - buildComponents - - let cbd = - LBC.ComponentBuildDescr - { componentGraph = Graph.fromDistinctList buildComponents - , componentNameMap = buildComponentsMap - , promisedPkgs = promisedDepsSet - , installedPkgs = packageDependsIndex - } - - -- For whole-package configure, we determine the - -- extraCoverageFor of the main lib and sub libs here. - extraCoverageUnitIds = case enabled of - -- Whole package configure, add package libs - ComponentRequestedSpec{} -> mapMaybe mbCompUnitId buildComponents - -- Component configure, no need to do anything since - -- extra-coverage-for will be passed for all other components that - -- should be covered. - OneComponentRequestedSpec{} -> [] - mbCompUnitId LibComponentLocalBuildInfo{componentUnitId} = Just componentUnitId - mbCompUnitId _ = Nothing - - pbd = - pbd0 - { LBC.extraCoverageFor = extraCoverageUnitIds - } - - lbd = - LBC.LocalBuildDescr - { packageBuildDescr = pbd - , componentBuildDescr = cbd - } - - lbi = - NewLocalBuildInfo - { localBuildDescr = lbd - , localBuildConfig = lbc - } - - when (LBC.relocatable $ LBC.withBuildOptions lbc) $ - checkRelocatable verbosity pkg_descr lbi - - when (LBC.withDynExe $ LBC.withBuildOptions lbc) $ - checkSharedExes verbosity lbi - - -- TODO: This is not entirely correct, because the dirs may vary - -- across libraries/executables - let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest - relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi - - -- PKGROOT: allowing ${pkgroot} to be passed as --prefix to - -- cabal configure, is only a hidden option. It allows packages - -- to be relocatable with their package database. This however - -- breaks when the Paths_* or other includes are used that - -- contain hard coded paths. This is still an open TODO. - -- - -- Allowing ${pkgroot} here, however requires less custom hooks - -- in scripts that *really* want ${pkgroot}. See haskell/cabal/#4872 - unless - ( isAbsolute (prefix dirs) - || "${pkgroot}" `isPrefixOf` prefix dirs - ) - $ dieWithException verbosity - $ ExpectedAbsoluteDirectory (prefix dirs) - - when ("${pkgroot}" `isPrefixOf` prefix dirs) $ - warn verbosity $ - "Using ${pkgroot} in prefix " - ++ prefix dirs - ++ " will not work if you rely on the Path_* module " - ++ " or other hard coded paths. Cabal does not yet " - ++ " support fully relocatable builds! " - ++ " See #462 #2302 #2994 #3305 #3473 #3586 #3909" - ++ " #4097 #4291 #4872" - - info verbosity $ - "Using " - ++ prettyShow currentCabalId - ++ " compiled by " - ++ prettyShow currentCompilerId - info verbosity $ "Using compiler: " ++ showCompilerId comp - info verbosity $ "Using install prefix: " ++ prefix dirs - - let dirinfo name dir isPrefixRelative = - info verbosity $ name ++ " installed in: " ++ dir ++ relNote - where - relNote = case buildOS of - Windows - | not (hasLibs pkg_descr) - && isNothing isPrefixRelative -> - " (fixed location)" - _ -> "" - - dirinfo "Executables" (bindir dirs) (bindir relative) - dirinfo "Libraries" (libdir dirs) (libdir relative) - dirinfo "Dynamic Libraries" (dynlibdir dirs) (dynlibdir relative) - dirinfo "Private executables" (libexecdir dirs) (libexecdir relative) - dirinfo "Data files" (datadir dirs) (datadir relative) - dirinfo "Documentation" (docdir dirs) (docdir relative) - dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative) - - sequence_ - [ reportProgram verbosity prog configuredProg - | (prog, configuredProg) <- knownPrograms programDb - ] - - return lbi - -mkPromisedDepsSet :: [PromisedComponent] -> Map (PackageName, ComponentName) PromisedComponent -mkPromisedDepsSet comps = Map.fromList [((packageName pn, CLibName ln), p) | p@(PromisedComponent pn ln _) <- comps] - --- | 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 - 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 - pure - . userSpecifyArgss (configProgramArgs cfg) - . userSpecifyPaths (configProgramPaths cfg) - $ programDb - where - searchpath = fromNubList (configProgramPathExtra cfg) - --- Note. We try as much as possible to _prepend_ rather than postpend the extra-prog-path --- so that we can override the system path. However, in a v2-build, at this point, the "system" path --- has already been extended by both the built-tools-depends paths, as well as the program-path-extra --- so for v2 builds adding it again is entirely unnecessary. However, it needs to get added again _anyway_ --- so as to take effect for v1 builds or standalone calls to Setup.hs --- In this instance, the lesser evil is to not allow it to override the system path. - --- ----------------------------------------------------------------------------- --- Helper functions for configure - --- | Check if the user used any deprecated flags. -checkDeprecatedFlags :: Verbosity -> ConfigFlags -> IO () -checkDeprecatedFlags verbosity cfg = do - unless (configProfExe cfg == NoFlag) $ do - let enable - | fromFlag (configProfExe cfg) = "enable" - | otherwise = "disable" - warn - verbosity - ( "The flag --" - ++ enable - ++ "-executable-profiling is deprecated. " - ++ "Please use --" - ++ enable - ++ "-profiling instead." - ) - - unless (configLibCoverage cfg == NoFlag) $ do - let enable - | fromFlag (configLibCoverage cfg) = "enable" - | otherwise = "disable" - warn - verbosity - ( "The flag --" - ++ enable - ++ "-library-coverage is deprecated. " - ++ "Please use --" - ++ enable - ++ "-coverage instead." - ) - --- | Sanity check: if '--exact-configuration' was given, ensure that the --- complete flag assignment was specified on the command line. -checkExactConfiguration - :: Verbosity -> GenericPackageDescription -> ConfigFlags -> IO () -checkExactConfiguration verbosity pkg_descr0 cfg = - when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do - let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg)) - allFlags = map flagName . genPackageFlags $ pkg_descr0 - diffFlags = allFlags \\ cmdlineFlags - when (not . null $ diffFlags) $ - dieWithException verbosity $ - FlagsNotSpecified diffFlags - --- | Create a PackageIndex that makes *any libraries that might be* --- defined internally to this package look like installed packages, in --- case an executable should refer to any of them as dependencies. --- --- It must be *any libraries that might be* defined rather than the --- actual definitions, because these depend on conditionals in the .cabal --- file, and we haven't resolved them yet. finalizePD --- does the resolution of conditionals, and it takes internalPackageSet --- as part of its input. -getInternalLibraries - :: GenericPackageDescription - -> Set LibraryName -getInternalLibraries pkg_descr0 = - -- TODO: some day, executables will be fair game here too! - let pkg_descr = flattenPackageDescription pkg_descr0 - in Set.fromList (map libName (allLibraries pkg_descr)) - --- | Returns true if a dependency is satisfiable. This function may --- report a dependency satisfiable even when it is not, but not vice --- versa. This is to be passed to finalize -dependencySatisfiable - :: Bool - -- ^ use external internal deps? - -> Bool - -- ^ exact configuration? - -> Bool - -- ^ allow depending on private libs? - -> PackageName - -> InstalledPackageIndex - -- ^ installed set - -> Set LibraryName - -- ^ library components - -> Map (PackageName, ComponentName) PromisedComponent - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ required dependencies - -> (Dependency -> Bool) -dependencySatisfiable - use_external_internal_deps - exact_config - allow_private_deps - pn - installedPackageSet - packageLibraries - promisedDeps - requiredDepsMap - (Dependency depName vr sublibs) - | exact_config = - -- When we're given '--exact-configuration', we assume that all - -- dependencies and flags are exactly specified on the command - -- line. Thus we only consult the 'requiredDepsMap'. Note that - -- we're not doing the version range check, so if there's some - -- dependency that wasn't specified on the command line, - -- 'finalizePD' will fail. - -- TODO: mention '--exact-configuration' in the error message - -- when this fails? - if isInternalDep && not use_external_internal_deps - then -- Except for internal deps, when we're NOT per-component mode; - -- those are just True. - internalDepSatisfiable - else -- Backward compatibility for the old sublibrary syntax - - ( sublibs == mainLibSet - && Map.member - ( pn - , CLibName $ - LSubLibName $ - packageNameToUnqualComponentName depName - ) - requiredDepsMap - ) - || all visible sublibs - | isInternalDep = - if use_external_internal_deps - then -- When we are doing per-component configure, we now need to - -- test if the internal dependency is in the index. This has - -- DIFFERENT semantics from normal dependency satisfiability. - internalDepSatisfiableExternally - else -- If a 'PackageName' is defined by an internal component, the dep is - -- satisfiable (we're going to build it ourselves) - internalDepSatisfiable - | otherwise = - depSatisfiable - where - -- Internal dependency is when dependency is the same as package. - isInternalDep = pn == depName - - depSatisfiable = - not . null $ PackageIndex.lookupDependency installedPackageSet depName vr - - internalDepSatisfiable = - Set.isSubsetOf (NES.toSet sublibs) packageLibraries - internalDepSatisfiableExternally = - all (\ln -> not $ null $ PackageIndex.lookupInternalDependency installedPackageSet pn vr ln) sublibs - - -- Check whether a library exists and is visible. - -- We don't disambiguate between dependency on non-existent or private - -- library yet, so we just return a bool and later report a generic error. - visible lib = - maybe - False -- Does not even exist (wasn't in the depsMap) - ( \ipi -> - IPI.libVisibility ipi == LibraryVisibilityPublic - -- If the override is enabled, the visibility does - -- not matter (it's handled externally) - || allow_private_deps - -- If it's a library of the same package then it's - -- always visible. - -- This is only triggered when passing a component - -- of the same package as --dependency, such as in: - -- cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs - || pkgName (IPI.sourcePackageId ipi) == pn - ) - maybeIPI - -- Don't check if it's visible, we promise to build it before we need it. - || promised - where - maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap - promised = isJust $ Map.lookup (depName, CLibName lib) promisedDeps - --- | Finalize a generic package description. --- --- The workhorse is 'finalizePD'. -configureFinalizedPackage - :: Verbosity - -> ConfigFlags - -> ComponentRequestedSpec - -> [PackageVersionConstraint] - -> (Dependency -> Bool) - -- ^ tests if a dependency is satisfiable. - -- Might say it's satisfiable even when not. - -> Compiler - -> Platform - -> GenericPackageDescription - -> IO (PackageDescription, FlagAssignment) -configureFinalizedPackage - verbosity - cfg - enabled - allConstraints - satisfies - comp - compPlatform - pkg_descr0 = do - (pkg_descr, flags) <- - case finalizePD - (configConfigurationsFlags cfg) - enabled - satisfies - compPlatform - (compilerInfo comp) - allConstraints - pkg_descr0 of - Right r -> return r - Left missing -> - dieWithException verbosity $ EncounteredMissingDependency missing - - unless (nullFlagAssignment flags) $ - info verbosity $ - "Flags chosen: " - ++ intercalate - ", " - [ unFlagName fn ++ "=" ++ prettyShow value - | (fn, value) <- unFlagAssignment flags - ] - - return (pkg_descr, flags) - --- | Check for use of Cabal features which require compiler support -checkCompilerProblems - :: Verbosity -> Compiler -> PackageDescription -> ComponentRequestedSpec -> IO () -checkCompilerProblems verbosity comp pkg_descr enabled = do - unless - ( renamingPackageFlagsSupported comp - || all - (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins) - (enabledBuildInfos pkg_descr enabled) - ) - $ dieWithException verbosity CompilerDoesn'tSupportThinning - when - ( any (not . null . reexportedModules) (allLibraries pkg_descr) - && not (reexportedModulesSupported comp) - ) - $ dieWithException verbosity CompilerDoesn'tSupportReexports - when - ( any (not . null . signatures) (allLibraries pkg_descr) - && not (backpackSupported comp) - ) - $ dieWithException verbosity CompilerDoesn'tSupportBackpack - --- | Select dependencies for the package. -configureDependencies - :: Verbosity - -> UseExternalInternalDeps - -> Set LibraryName - -> Map (PackageName, ComponentName) PromisedComponent - -> InstalledPackageIndex - -- ^ installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ required deps - -> PackageDescription - -> ComponentRequestedSpec - -> IO ([PreExistingComponent], [ConfiguredPromisedComponent]) -configureDependencies - verbosity - use_external_internal_deps - packageLibraries - promisedDeps - installedPackageSet - requiredDepsMap - pkg_descr - enableSpec = do - let failedDeps :: [FailedDependency] - allPkgDeps :: [ResolvedDependency] - (failedDeps, allPkgDeps) = - partitionEithers $ - concat - [ fmap (\s -> (dep, s)) <$> status - | dep <- enabledBuildDepends pkg_descr enableSpec - , let status = - selectDependency - (package pkg_descr) - packageLibraries - promisedDeps - installedPackageSet - requiredDepsMap - use_external_internal_deps - dep - ] - - internalPkgDeps = - [ pkgid - | (_, InternalDependency pkgid) <- allPkgDeps - ] - -- NB: we have to SAVE the package name, because this is the only - -- way we can be able to resolve package names in the package - -- description. - externalPkgDeps = - [ pec - | (_, ExternalDependency pec) <- allPkgDeps - ] - - promisedPkgDeps = - [ fpec - | (_, PromisedDependency fpec) <- allPkgDeps - ] - - when - ( not (null internalPkgDeps) - && not (newPackageDepsBehaviour pkg_descr) - ) - $ dieWithException verbosity - $ LibraryWithinSamePackage internalPkgDeps - reportFailedDependencies verbosity failedDeps - reportSelectedDependencies verbosity allPkgDeps - - return (externalPkgDeps, promisedPkgDeps) - --- | Select and apply coverage settings for the build based on the --- 'ConfigFlags' and 'Compiler'. -configureCoverage - :: Verbosity - -> ConfigFlags - -> Compiler - -> IO (LBC.BuildOptions -> LBC.BuildOptions) -configureCoverage verbosity cfg comp = do - let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg) - tryLibCoverage = - fromFlagOrDefault - tryExeCoverage - (mappend (configCoverage cfg) (configLibCoverage cfg)) - -- TODO: Should we also enforce something here on that --coverage-for cannot - -- include indefinite components or instantiations? - if coverageSupported comp - then do - let apply buildOptions = - buildOptions - { LBC.libCoverage = tryLibCoverage - , LBC.exeCoverage = tryExeCoverage - } - return apply - else do - let apply buildOptions = - buildOptions - { LBC.libCoverage = False - , LBC.exeCoverage = False - } - when (tryExeCoverage || tryLibCoverage) $ - warn - verbosity - ( "The compiler " - ++ showCompilerId comp - ++ " does not support " - ++ "program coverage. Program coverage has been disabled." - ) - return apply - --- | Compute the effective value of the profiling flags --- @--enable-library-profiling@ and @--enable-executable-profiling@ --- from the specified 'ConfigFlags'. This may be useful for --- external Cabal tools which need to interact with Setup in --- a backwards-compatible way: the most predictable mechanism --- for enabling profiling across many legacy versions is to --- NOT use @--enable-profiling@ and use those two flags instead. --- --- Note that @--enable-executable-profiling@ also affects profiling --- of benchmarks and (non-detailed) test suites. -computeEffectiveProfiling :: ConfigFlags -> (Bool {- lib vanilla-}, Bool {- lib shared -}, Bool {- exe -}) -computeEffectiveProfiling cfg = - -- The --profiling flag sets the default for both libs and exes, - -- but can be overridden by --library-profiling, or the old deprecated - -- --executable-profiling flag. - -- - -- The --profiling-detail and --library-profiling-detail flags behave - -- similarly - let dynamicExe = fromFlagOrDefault False (configDynExe cfg) - tryExeProfiling = - fromFlagOrDefault - False - (mappend (configProf cfg) (configProfExe cfg)) - tryLibProfiling = - fromFlagOrDefault - (tryExeProfiling && not dynamicExe) - (configProfLib cfg) - tryLibProfilingShared = - fromFlagOrDefault - (tryExeProfiling && dynamicExe) - (configProfShared cfg) - in (tryLibProfiling, tryLibProfilingShared, tryExeProfiling) - --- | Select and apply profiling settings for the build based on the --- 'ConfigFlags' and 'Compiler'. -configureProfiling - :: Verbosity - -> ConfigFlags - -> Compiler - -> IO (LBC.BuildOptions -> LBC.BuildOptions) -configureProfiling verbosity cfg comp = do - let (tryLibProfiling, tryLibProfilingShared, tryExeProfiling) = computeEffectiveProfiling cfg - - tryExeProfileLevel = - fromFlagOrDefault - ProfDetailDefault - (configProfDetail cfg) - tryLibProfileLevel = - fromFlagOrDefault - ProfDetailDefault - ( mappend - (configProfDetail cfg) - (configProfLibDetail cfg) - ) - - checkProfileLevel (ProfDetailOther other) = do - warn - verbosity - ( "Unknown profiling detail level '" - ++ other - ++ "', using default.\nThe profiling detail levels are: " - ++ intercalate - ", " - [name | (name, _, _) <- knownProfDetailLevels] - ) - return ProfDetailDefault - checkProfileLevel other = return other - - applyProfiling <- - if profilingSupported comp && (profilingVanillaSupportedOrUnknown comp || profilingDynamicSupportedOrUnknown comp) - then do - exeLevel <- checkProfileLevel tryExeProfileLevel - libLevel <- checkProfileLevel tryLibProfileLevel - let apply buildOptions = - buildOptions - { LBC.withProfLib = tryLibProfiling - , LBC.withProfLibDetail = libLevel - , LBC.withProfExe = tryExeProfiling - , LBC.withProfExeDetail = exeLevel - } - let compilerSupportsProfilingDynamic = profilingDynamicSupportedOrUnknown comp - apply2 <- - if compilerSupportsProfilingDynamic - then -- Case 1: We support profiled shared libraries so turn on shared profiling - -- libraries if the user asked for it. - return $ \buildOptions -> apply buildOptions{LBC.withProfLibShared = tryLibProfilingShared} - else -- Case 2: Compiler doesn't support profiling shared so turn them off - do - -- If we wanted to enable profiling shared libraries.. tell the - -- user we couldn't. - when (profilingVanillaSupportedOrUnknown comp && tryLibProfilingShared) $ - warn - verbosity - ( "The compiler " - ++ showCompilerId comp - ++ " does not support " - ++ "profiling shared objects. Static profiled objects " - ++ "will be built." - ) - return $ \buildOptions -> - let original_options = apply buildOptions - in original_options - { LBC.withProfLibShared = False - , LBC.withProfLib = profilingVanillaSupportedOrUnknown comp && (tryLibProfilingShared || LBC.withProfLib original_options) - , LBC.withDynExe = if LBC.withProfExe original_options then False else LBC.withDynExe original_options - } - - when (tryExeProfiling && not (tryLibProfiling || tryLibProfilingShared)) $ do - warn - verbosity - ( "Executables will be built with profiling, but library " - ++ "profiling is disabled. Linking will fail if any executables " - ++ "depend on the library." - ) - return apply2 - else do - let apply buildOptions = - buildOptions - { LBC.withProfLib = False - , LBC.withProfLibShared = False - , LBC.withProfLibDetail = ProfDetailNone - , LBC.withProfExe = False - , LBC.withProfExeDetail = ProfDetailNone - } - when (tryExeProfiling || tryLibProfiling) $ - warn - verbosity - ( "The compiler " - ++ showCompilerId comp - ++ " does not support " - ++ "profiling. Profiling has been disabled." - ) - return apply - - return applyProfiling - --- ----------------------------------------------------------------------------- --- Configuring package dependencies - -reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () -reportProgram verbosity prog Nothing = - info verbosity $ "No " ++ programName prog ++ " found" -reportProgram verbosity prog (Just configuredProg) = - info verbosity $ "Using " ++ programName prog ++ version ++ location - where - location = case programLocation configuredProg of - FoundOnSystem p -> " found on system at: " ++ p - UserSpecified p -> " given by user at: " ++ p - version = case programVersion configuredProg of - Nothing -> "" - Just v -> " version " ++ prettyShow v - -hackageUrl :: String -hackageUrl = "http://hackage.haskell.org/package/" - -type ResolvedDependency = (Dependency, DependencyResolution) - -data DependencyResolution - = -- | An external dependency from the package database, OR an - -- internal dependency which we are getting from the package - -- database. - ExternalDependency PreExistingComponent - | -- | A promised dependency, which doesn't yet exist, but should be provided - -- at the build time. - -- - -- We have these such that we can configure components without actually - -- building its dependencies, if these dependencies need to be built later - -- again. For example, when launching a multi-repl, - -- we need to build packages in the interactive ghci session, no matter - -- whether they have been built before. - -- Building them in the configure phase is then redundant and costs time. - PromisedDependency ConfiguredPromisedComponent - | -- | An internal dependency ('PackageId' should be a library name) - -- which we are going to have to build. (The - -- 'PackageId' here is a hack to get a modest amount of - -- polymorphism out of the Pkg' typeclass.) - InternalDependency PackageId - --- | Test for a package dependency and record the version we have installed. -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 - -> UseExternalInternalDeps - -- ^ Are we configuring a - -- single component? - -> Dependency - -> [Either FailedDependency DependencyResolution] -selectDependency - pkgid - internalIndex - promisedIndex - installedIndex - requiredDepsMap - use_external_internal_deps - (Dependency dep_pkgname vr libs) = - -- If the dependency specification matches anything in the internal package - -- index, then we prefer that match to anything in the second. - -- For example: - -- - -- Name: MyLibrary - -- Version: 0.1 - -- Library - -- .. - -- Executable my-exec - -- build-depends: MyLibrary - -- - -- We want "build-depends: MyLibrary" always to match the internal library - -- even if there is a newer installed library "MyLibrary-0.2". - if dep_pkgname == pn - then - if use_external_internal_deps - then do_external_internal <$> NES.toList libs - else do_internal <$> NES.toList libs - else do_external_external <$> NES.toList libs - where - pn = packageName pkgid - - -- It's an internal library, and we're not per-component build - do_internal lib - | Set.member lib internalIndex = - Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid - | otherwise = - Left $ DependencyMissingInternal dep_pkgname lib - - -- We have to look it up externally - do_external_external :: LibraryName -> Either FailedDependency DependencyResolution - do_external_external lib - | Just pc <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = - return $ PromisedDependency (ConfiguredPromisedComponent dep_pkgname (AnnotatedId (promisedComponentPackage pc) (CLibName lib) (promisedComponentId pc))) - do_external_external lib = do - ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of - -- If we know the exact pkg to use, then use it. - Just pkginstance -> Right pkginstance - -- Otherwise we just pick an arbitrary instance of the latest version. - Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex dep_pkgname vr lib of - Nothing -> Left (DependencyNotExists dep_pkgname) - Just pkg -> Right pkg - return $ ExternalDependency $ ipiToPreExistingComponent ipi - - do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution - do_external_internal lib - | Just pc <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = - return $ PromisedDependency (ConfiguredPromisedComponent dep_pkgname (AnnotatedId (promisedComponentPackage pc) (CLibName lib) (promisedComponentId pc))) - do_external_internal lib = do - ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of - -- If we know the exact pkg to use, then use it. - Just pkginstance -> Right pkginstance - Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex pn vr lib of - -- It's an internal library, being looked up externally - Nothing -> Left (DependencyMissingInternal dep_pkgname lib) - Just pkg -> Right pkg - return $ ExternalDependency $ ipiToPreExistingComponent ipi - - pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo - pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs - -reportSelectedDependencies - :: Verbosity - -> [ResolvedDependency] - -> IO () -reportSelectedDependencies verbosity deps = - info verbosity $ - unlines - [ "Dependency " - ++ prettyShow (simplifyDependency dep) - ++ ": using " - ++ prettyShow pkgid - | (dep, resolution) <- deps - , let pkgid = case resolution of - ExternalDependency pkg' -> packageId pkg' - InternalDependency pkgid' -> pkgid' - PromisedDependency promisedComp -> packageId promisedComp - ] - -reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO () -reportFailedDependencies _ [] = return () -reportFailedDependencies verbosity failed = - dieWithException verbosity $ ReportFailedDependencies failed hackageUrl - --- | List all installed packages in the given package databases. --- Non-existent package databases do not cause errors, they just get skipped --- with a warning and treated as empty ones, since technically they do not --- contain any package. -getInstalledPackages - :: Verbosity - -> Compiler - -> Maybe (SymbolicPath CWD (Dir from)) - -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) - -- ^ The stack of package databases. - -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity comp mbWorkDir packageDBs progdb = do - when (null packageDBs) $ - dieWithException verbosity NoPackageDatabaseSpecified - - info verbosity "Reading installed packages..." - -- 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 - GHCJS -> GHCJS.getInstalledPackages verbosity mbWorkDir packageDBs' progdb - UHC -> UHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb - HaskellSuite{} -> - HaskellSuite.getInstalledPackages verbosity packageDBs' progdb - flv -> - dieWithException verbosity $ HowToFindInstalledPackages flv - where - packageDBExists (SpecificPackageDB path0) = do - let path = interpretSymbolicPath mbWorkDir path0 - exists <- doesPathExist path - unless exists $ - warn verbosity $ - "Package db " <> path <> " does not exist yet" - return exists - -- Checking the user and global package dbs is more complicated and needs - -- way more data. Also ghc-pkg won't error out unless the user/global - -- pkgdb is overridden with an empty one, so we just don't check for them. - packageDBExists UserPackageDB = pure True - packageDBExists GlobalPackageDB = pure True - --- | Like 'getInstalledPackages', but for a single package DB. --- --- NB: Why isn't this always a fall through to 'getInstalledPackages'? --- That is because 'getInstalledPackages' performs some sanity checks --- on the package database stack in question. However, when sandboxes --- are involved these sanity checks are not desirable. -getPackageDBContents - :: Verbosity - -> Compiler - -> Maybe (SymbolicPath CWD (Dir Pkg)) - -> PackageDB - -> ProgramDb - -> IO InstalledPackageIndex -getPackageDBContents verbosity comp mbWorkDir packageDB progdb = do - info verbosity "Reading installed packages..." - case compilerFlavor comp of - GHC -> GHC.getPackageDBContents verbosity mbWorkDir packageDB progdb - GHCJS -> GHCJS.getPackageDBContents verbosity mbWorkDir packageDB progdb - -- For other compilers, try to fall back on 'getInstalledPackages'. - _ -> getInstalledPackages verbosity comp mbWorkDir [packageDB] progdb - --- | A set of files (or directories) that can be monitored to detect when --- there might have been a change in the installed packages. -getInstalledPackagesMonitorFiles - :: Verbosity - -> Compiler - -> Maybe (SymbolicPath CWD ('Dir from)) - -> PackageDBStackS from - -> ProgramDb - -> Platform - -> IO [FilePath] -getInstalledPackagesMonitorFiles verbosity comp mbWorkDir packageDBs progdb platform = - case compilerFlavor comp of - GHC -> - GHC.getInstalledPackagesMonitorFiles - verbosity - mbWorkDir - platform - progdb - packageDBs - other -> do - warn verbosity $ - "don't know how to find change monitoring files for " - ++ "the installed package databases for " - ++ prettyShow other - return [] - --- | Looks up the 'InstalledPackageInfo' of the given 'UnitId's from the --- 'PackageDBStack' in the 'LocalBuildInfo'. -getInstalledPackagesById - :: (Exception (VerboseException exception), Show exception, Typeable exception) - => Verbosity - -> LocalBuildInfo - -> (UnitId -> exception) - -- ^ Construct an exception that is thrown if a - -- unit-id is not found in the installed packages, - -- from the unit-id that is missing. - -> [UnitId] - -- ^ The unit ids to lookup in the installed packages - -> IO [InstalledPackageInfo] -getInstalledPackagesById verbosity lbi@LocalBuildInfo{compiler = comp, withPackageDB = pkgDb, withPrograms = progDb} mkException unitids = do - let mbWorkDir = mbWorkDirLBI lbi - ipindex <- getInstalledPackages verbosity comp mbWorkDir pkgDb progDb - mapM - ( \uid -> case lookupUnitId ipindex uid of - Nothing -> dieWithException verbosity (mkException uid) - Just ipkg -> return ipkg - ) - unitids - --- | The user interface specifies the package dbs to use with a combination of --- @--global@, @--user@ and @--package-db=global|user|clear|$file@. --- This function combines the global/user flag and interprets the package-db --- flag into a single package db stack. -interpretPackageDbFlags :: Bool -> [Maybe (PackageDBX fp)] -> PackageDBStackX fp -interpretPackageDbFlags userInstall specificDBs = - extra initialStack specificDBs - where - initialStack - | userInstall = [GlobalPackageDB, UserPackageDB] - | otherwise = [GlobalPackageDB] - - extra dbs' [] = dbs' - extra _ (Nothing : dbs) = extra [] dbs - extra dbs' (Just db : dbs) = extra (dbs' ++ [db]) dbs - --- We are given both --constraint="foo < 2.0" style constraints and also --- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581". --- --- When finalising the package we have to take into account the specific --- installed deps we've been given, and the finalise function expects --- constraints, so we have to translate these deps into version constraints. --- --- But after finalising we then have to make sure we pick the right specific --- deps in the end. So we still need to remember which installed packages to --- pick. -combinedConstraints - :: [PackageVersionConstraint] - -> [GivenComponent] - -- ^ installed dependencies - -> InstalledPackageIndex - -> Either - CabalException - ( [PackageVersionConstraint] - , Map (PackageName, ComponentName) InstalledPackageInfo - ) -combinedConstraints constraints dependencies installedPackages = do - when (not (null badComponentIds)) $ - Left $ - CombinedConstraints (dispDependencies badComponentIds) - - -- TODO: we don't check that all dependencies are used! - - return (allConstraints, idConstraintMap) - where - allConstraints :: [PackageVersionConstraint] - allConstraints = - constraints - ++ [ thisPackageVersionConstraint (packageId pkg) - | (_, _, _, Just pkg) <- dependenciesPkgInfo - ] - - idConstraintMap :: Map (PackageName, ComponentName) InstalledPackageInfo - idConstraintMap = - Map.fromList - -- NB: do NOT use the packageName from - -- dependenciesPkgInfo! - [ ((pn, cname), pkg) - | (pn, cname, _, Just pkg) <- dependenciesPkgInfo - ] - - -- The dependencies along with the installed package info, if it exists - dependenciesPkgInfo :: [(PackageName, ComponentName, ComponentId, Maybe InstalledPackageInfo)] - dependenciesPkgInfo = - [ (pkgname, CLibName lname, cid, mpkg) - | GivenComponent pkgname lname cid <- dependencies - , let mpkg = - PackageIndex.lookupComponentId - installedPackages - cid - ] - - -- If we looked up a package specified by an installed package id - -- (i.e. someone has written a hash) and didn't find it then it's - -- an error. - badComponentIds = - [ (pkgname, cname, cid) - | (pkgname, cname, cid, Nothing) <- dependenciesPkgInfo - ] - - dispDependencies deps = - hsep - [ text "--dependency=" - <<>> quotes - ( pretty pkgname - <<>> case cname of - CLibName LMainLibName -> "" - CLibName (LSubLibName n) -> ":" <<>> pretty n - _ -> ":" <<>> pretty cname - <<>> char '=' - <<>> pretty cid - ) - | (pkgname, cname, cid) <- deps - ] - --- ----------------------------------------------------------------------------- --- Configuring program dependencies - -configureRequiredPrograms - :: Verbosity - -> [LegacyExeDependency] - -> ProgramDb - -> IO ProgramDb -configureRequiredPrograms verbosity deps progdb = - foldM (configureRequiredProgram verbosity) progdb deps - --- | Configure a required program, ensuring that it exists in the PATH --- (or where the user has specified the program must live) and making it --- available for use via the 'ProgramDb' interface. If the program is --- known (exists in the input 'ProgramDb'), we will make sure that the --- program matches the required version; otherwise we will accept --- any version of the program and assume that it is a simpleProgram. -configureRequiredProgram - :: Verbosity - -> ProgramDb - -> LegacyExeDependency - -> IO ProgramDb -configureRequiredProgram - verbosity - progdb - (LegacyExeDependency progName verRange) = - case lookupProgramByName progName progdb of - Just prog -> - -- If the program has already been configured, use it - -- (as long as the version is compatible). - -- - -- Not doing so means falling back to the "simpleProgram" path below, - -- which might fail if the program has custom logic to find a version - -- (such as hsc2hs). - let loc = locationPath $ programLocation prog - in case programVersion prog of - Nothing - | verRange == anyVersion -> - return progdb - | otherwise -> - dieWithException verbosity $! - UnknownVersionDb (programId prog) verRange loc - Just version - | withinRange version verRange -> - return progdb - | otherwise -> - dieWithException verbosity $! - BadVersionDb (programId prog) version verRange loc - Nothing -> - -- Otherwise, try to configure it as a 'simpleProgram' automatically - case lookupKnownProgram progName progdb of - Nothing -> - -- There's a bit of a story behind this line. In old versions - -- of Cabal, there were only internal build-tools dependencies. So the - -- behavior in this case was: - -- - -- - If a build-tool dependency was internal, don't do - -- any checking. - -- - -- - If it was external, call 'configureRequiredProgram' to - -- "configure" the executable. In particular, if - -- the program was not "known" (present in 'ProgramDb'), - -- then we would just error. This was fine, because - -- the only way a program could be executed from 'ProgramDb' - -- is if some library code from Cabal actually called it, - -- and the pre-existing Cabal code only calls known - -- programs from 'defaultProgramDb', and so if it - -- is calling something else, you have a Custom setup - -- script, and in that case you are expected to register - -- the program you want to call in the ProgramDb. - -- - -- OK, so that was fine, until I (ezyang, in 2016) refactored - -- Cabal to support per-component builds. In this case, what - -- was previously an internal build-tool dependency now became - -- an external one, and now previously "internal" dependencies - -- are now external. But these are permitted to exist even - -- when they are not previously configured (something that - -- can only occur by a Custom script.) - -- - -- So, I decided, "Fine, let's just accept these in any - -- case." Thus this line. The alternative would have been to - -- somehow detect when a build-tools dependency was "internal" (by - -- looking at the unflattened package description) but this - -- would also be incompatible with future work to support - -- external executable dependencies: we definitely cannot - -- assume they will be preinitialized in the 'ProgramDb'. - configureProgram verbosity (simpleProgram progName) progdb - Just prog - -- requireProgramVersion always requires the program have a version - -- but if the user says "build-depends: foo" ie no version constraint - -- then we should not fail if we cannot discover the program version. - | verRange == anyVersion -> do - (_, progdb') <- requireProgram verbosity prog progdb - return progdb' - | otherwise -> do - (_, _, progdb') <- requireProgramVersion verbosity prog verRange progdb - return progdb' - --- ----------------------------------------------------------------------------- --- Configuring pkg-config package dependencies - -configurePkgconfigPackages - :: Verbosity - -> PackageDescription - -> ProgramDb - -> ComponentRequestedSpec - -> IO (PackageDescription, ProgramDb) -configurePkgconfigPackages verbosity pkg_descr progdb enabled - | null allpkgs = return (pkg_descr, progdb) - | otherwise = do - (_, _, progdb') <- - requireProgramVersion - (lessVerbose verbosity) - pkgConfigProgram - (orLaterVersion $ mkVersion [0, 9, 0]) - progdb - traverse_ requirePkg allpkgs - mlib' <- traverse addPkgConfigBILib (library pkg_descr) - libs' <- traverse addPkgConfigBILib (subLibraries pkg_descr) - exes' <- traverse addPkgConfigBIExe (executables pkg_descr) - tests' <- traverse addPkgConfigBITest (testSuites pkg_descr) - benches' <- traverse addPkgConfigBIBench (benchmarks pkg_descr) - let pkg_descr' = - pkg_descr - { library = mlib' - , subLibraries = libs' - , executables = exes' - , testSuites = tests' - , benchmarks = benches' - } - return (pkg_descr', progdb') - where - allpkgs = concatMap pkgconfigDepends (enabledBuildInfos pkg_descr enabled) - pkgconfig = - getDbProgramOutput - (lessVerbose verbosity) - pkgConfigProgram - progdb - - requirePkg dep@(PkgconfigDependency pkgn range) = do - version <- - pkgconfig ["--modversion", pkg] - `catchIO` (\_ -> dieWithException verbosity $ PkgConfigNotFound pkg versionRequirement) - `catchExit` (\_ -> dieWithException verbosity $ PkgConfigNotFound pkg versionRequirement) - let trim = dropWhile isSpace . dropWhileEnd isSpace - let v = PkgconfigVersion (toUTF8BS $ trim version) - if not (withinPkgconfigVersionRange v range) - then dieWithException verbosity $ BadVersion pkg versionRequirement v - else info verbosity (depSatisfied v) - where - depSatisfied v = - "Dependency " - ++ prettyShow dep - ++ ": using version " - ++ prettyShow v - - versionRequirement - | isAnyPkgconfigVersion range = "" - | otherwise = " version " ++ prettyShow range - - pkg = unPkgconfigName pkgn - - -- Adds pkgconfig dependencies to the build info for a component - addPkgConfigBI compBI setCompBI comp = do - bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp)) - return $ setCompBI comp (compBI comp `mappend` bi) - - -- Adds pkgconfig dependencies to the build info for a library - addPkgConfigBILib = addPkgConfigBI libBuildInfo $ - \lib bi -> lib{libBuildInfo = bi} - - -- Adds pkgconfig dependencies to the build info for an executable - addPkgConfigBIExe = addPkgConfigBI buildInfo $ - \exe bi -> exe{buildInfo = bi} - - -- Adds pkgconfig dependencies to the build info for a test suite - addPkgConfigBITest = addPkgConfigBI testBuildInfo $ - \test bi -> test{testBuildInfo = bi} - - -- Adds pkgconfig dependencies to the build info for a benchmark - addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $ - \bench bi -> bench{benchmarkBuildInfo = bi} - - pkgconfigBuildInfo :: [PkgconfigDependency] -> IO BuildInfo - pkgconfigBuildInfo [] = return mempty - pkgconfigBuildInfo pkgdeps = do - let pkgs = nub [prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps] - ccflags <- pkgconfig ("--cflags" : pkgs) - ldflags <- pkgconfig ("--libs" : pkgs) - ldflags_static <- pkgconfig ("--libs" : "--static" : pkgs) - return (ccLdOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static)) - --- | Makes a 'BuildInfo' from C compiler and linker flags. --- --- This can be used with the output from configuration programs like pkg-config --- and similar package-specific programs like mysql-config, freealut-config etc. --- For example: --- --- > ccflags <- getDbProgramOutput verbosity prog progdb ["--cflags"] --- > ldflags <- getDbProgramOutput verbosity prog progdb ["--libs"] --- > ldflags_static <- getDbProgramOutput verbosity prog progdb ["--libs", "--static"] --- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static)) -ccLdOptionsBuildInfo :: [String] -> [String] -> [String] -> BuildInfo -ccLdOptionsBuildInfo cflags ldflags ldflags_static = - 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 - in mempty - { includeDirs = map (makeSymbolicPath . drop 2) includeDirs' - , extraLibs = map (drop 2) extraLibs' - , extraLibDirs = map (makeSymbolicPath . drop 2) extraLibDirs' - , extraLibsStatic = map (drop 2) extraLibsStatic' - , extraLibDirsStatic = map (makeSymbolicPath . drop 2) extraLibDirsStatic' - , ccOptions = cflags' - , ldOptions = ldflags'' - } - --- ----------------------------------------------------------------------------- --- Determining the compiler details - -configCompilerAuxEx - :: ConfigFlags - -> IO (Compiler, Platform, ProgramDb) -configCompilerAuxEx cfg = do - programDb <- mkProgramDb cfg defaultProgramDb - let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common - configCompilerEx - (flagToMaybe $ configHcFlavor cfg) - (flagToMaybe $ configHcPath cfg) - (flagToMaybe $ configHcPkg cfg) - programDb - verbosity - -configCompilerEx - :: Maybe CompilerFlavor - -> Maybe FilePath - -> Maybe FilePath - -> ProgramDb - -> Verbosity - -> IO (Compiler, Platform, ProgramDb) -configCompilerEx Nothing _ _ _ verbosity = dieWithException verbosity UnknownCompilerException -configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do - (comp, maybePlatform, programDb) <- case hcFlavor of - GHC -> GHC.configure verbosity hcPath hcPkg progdb - GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb - UHC -> UHC.configure verbosity hcPath hcPkg progdb - HaskellSuite{} -> HaskellSuite.configure verbosity hcPath hcPkg progdb - _ -> dieWithException verbosity UnknownCompilerException - return (comp, fromMaybe buildPlatform maybePlatform, programDb) - --- ----------------------------------------------------------------------------- --- Testing C lib and header dependencies - --- Try to build a test C program which includes every header and links every --- lib. If that fails, try to narrow it down by preprocessing (only) and linking --- with individual headers and libs. If none is the obvious culprit then give a --- generic error message. --- TODO: produce a log file from the compiler errors, if any. -checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () -checkForeignDeps pkg lbi verbosity = - ifBuildsWith - allHeaders - (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling lucky - (return ()) - ( do - missingLibs <- findMissingLibs - missingHdr <- findOffendingHdr - explainErrors missingHdr missingLibs - ) - where - allHeaders = collectField (fmap getSymbolicPath . includes) - allLibs = - collectField $ - if withFullyStaticExe lbi - then extraLibsStatic - else extraLibs - - ifBuildsWith headers args success failure = do - checkDuplicateHeaders - ok <- builds (makeProgram headers) args - if ok then success else failure - - -- Ensure that there is only one header with a given name - -- 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. - -- - -- 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" - genHeaders <- for relIncDirs $ \dir -> - fmap (dir ) . filter isHeader - <$> listDirectory (i (buildDir lbi) dir) `catchIO` (\_ -> return []) - srcHeaders <- for relIncDirs $ \dir -> - fmap (dir ) . filter isHeader - <$> listDirectory (baseDir dir) `catchIO` (\_ -> return []) - let commonHeaders = concat genHeaders `intersect` concat srcHeaders - for_ commonHeaders $ \hdr -> do - warn verbosity $ - "Duplicate header found in " - ++ (getSymbolicPath (buildDir lbi) hdr) - ++ " and " - ++ (baseDir hdr) - ++ "; removing " - ++ (baseDir hdr) - removeFile (baseDir hdr) - - findOffendingHdr = - ifBuildsWith - allHeaders - ccArgs - (return Nothing) - (go . tail . NEL.inits $ allHeaders) - where - go [] = return Nothing -- cannot happen - go (hdrs : hdrsInits) = - -- Try just preprocessing first - ifBuildsWith - hdrs - cppArgs - -- If that works, try compiling too - ( ifBuildsWith - hdrs - ccArgs - (go hdrsInits) - (return . fmap Right . safeLast $ hdrs) - ) - (return . fmap Left . safeLast $ hdrs) - - cppArgs = "-E" : commonCppArgs -- preprocess only - ccArgs = "-c" : commonCcArgs -- don't try to link - findMissingLibs = - ifBuildsWith - [] - (makeLdArgs allLibs) - (return []) - (filterM (fmap not . libExists) allLibs) - - libExists lib = builds (makeProgram []) (makeLdArgs [lib]) - - common = configCommonFlags $ configFlags lbi - baseDir = packageRoot common - - -- See Note [Symbolic paths] in Distribution.Utils.Path - i = interpretSymbolicPathLBI lbi - mbWorkDir = mbWorkDirLBI lbi - - commonCppArgs = - platformDefines lbi - -- TODO: This is a massive hack, to work around the - -- fact that the test performed here should be - -- PER-component (c.f. the "I'm Feeling Lucky"; we - -- should NOT be glomming everything together.) - ++ ["-I" ++ i (buildDir lbi makeRelativePathEx "autogen")] - -- `configure' may generate headers in the build directory - ++ [ "-I" ++ i (buildDir lbi unsafeCoerceSymbolicPath dir) - | dir <- mapMaybe symbolicPathRelative_maybe $ ordNub (collectField includeDirs) - ] - -- we might also reference headers from the - -- packages directory. - ++ [ "-I" ++ baseDir getSymbolicPath dir - | dir <- mapMaybe symbolicPathRelative_maybe $ ordNub (collectField includeDirs) - ] - ++ [ "-I" ++ dir - | dir <- ordNub (collectField (fmap getSymbolicPath . includeDirs)) - , isAbsolute dir - ] - ++ ["-I" ++ baseDir] - ++ collectField cppOptions - ++ collectField ccOptions - ++ [ "-I" ++ dir - | dir <- - ordNub - [ dir - | dep <- deps - , dir <- IPI.includeDirs dep - ] - -- dedupe include dirs of dependencies - -- to prevent quadratic blow-up - ] - ++ [ opt - | dep <- deps - , opt <- IPI.ccOptions dep - ] - - commonCcArgs = - commonCppArgs - ++ collectField ccOptions - ++ [ opt - | dep <- deps - , opt <- IPI.ccOptions dep - ] - - commonLdArgs = - [ "-L" ++ getSymbolicPath dir - | dir <- - ordNub $ - collectField - ( if withFullyStaticExe lbi - then extraLibDirsStatic - else extraLibDirs - ) - ] - ++ collectField ldOptions - ++ [ "-L" ++ dir - | dir <- - ordNub - [ dir - | dep <- deps - , dir <- - if withFullyStaticExe lbi - then IPI.libraryDirsStatic dep - else IPI.libraryDirs dep - ] - ] - -- TODO: do we also need dependent packages' ld options? - makeLdArgs libs = ["-l" ++ lib | lib <- libs] ++ commonLdArgs - - makeProgram hdrs = - unlines $ - ["#include \"" ++ hdr ++ "\"" | hdr <- hdrs] - ++ ["int main(int argc, char** argv) { return 0; }"] - - collectField f = concatMap f allBi - allBi = enabledBuildInfos pkg (componentEnabledSpec lbi) - deps = PackageIndex.topologicalOrder (installedPkgs lbi) - - builds :: String -> [ProgArg] -> IO Bool - builds program args = - do - tempDir <- makeSymbolicPath <$> getTemporaryDirectory - withTempFileCwd mbWorkDir tempDir ".c" $ \cName cHnd -> - withTempFileCwd mbWorkDir tempDir "" $ \oNname oHnd -> do - hPutStrLn cHnd program - hClose cHnd - hClose oHnd - _ <- - getDbProgramOutputCwd - verbosity - mbWorkDir - gccProgram - (withPrograms lbi) - (getSymbolicPath cName : "-o" : getSymbolicPath oNname : args) - return True - `catchIO` (\_ -> return False) - `catchExit` (\_ -> return False) - - explainErrors Nothing [] = return () -- should be impossible! - explainErrors _ _ - | isNothing . lookupProgram gccProgram . withPrograms $ lbi = - dieWithException verbosity NoWorkingGcc - explainErrors hdr libs = - dieWithException verbosity $ ExplainErrors hdr libs - --- | Output package check warnings and errors. Exit if any errors. -checkPackageProblems - :: Verbosity - -> FilePath - -- ^ Path to the @.cabal@ file's directory - -> GenericPackageDescription - -> PackageDescription - -> IO () -checkPackageProblems verbosity dir gpkg pkg = do - ioChecks <- checkPackageFiles verbosity pkg dir - let pureChecks = checkPackage gpkg - (errors, warnings) = - partitionEithers (M.mapMaybe classEW $ pureChecks ++ ioChecks) - if null errors - then traverse_ (warn verbosity) (map ppPackageCheck warnings) - else dieWithException verbosity $ CheckPackageProblems (map ppPackageCheck errors) - where - -- Classify error/warnings. Left: error, Right: warning. - classEW :: PackageCheck -> Maybe (Either PackageCheck PackageCheck) - classEW e@(PackageBuildImpossible _) = Just (Left e) - classEW w@(PackageBuildWarning _) = Just (Right w) - classEW (PackageDistSuspicious _) = Nothing - classEW (PackageDistSuspiciousWarn _) = Nothing - classEW (PackageDistInexcusable _) = Nothing - --- | Perform checks if a shared executable can be built -checkSharedExes - :: Verbosity - -> LocalBuildInfo - -> IO () -checkSharedExes verbosity lbi = - when (os == Windows) $ - dieWithException verbosity $ - NoOSSupport os "shared executables" - where - (Platform _ os) = hostPlatform lbi - --- | Preform checks if a relocatable build is allowed -checkRelocatable - :: Verbosity - -> PackageDescription - -> LocalBuildInfo - -> IO () -checkRelocatable verbosity pkg lbi = - sequence_ - [ checkOS - , checkCompiler - , packagePrefixRelative - , depsPrefixRelative - ] - where - -- Check if the OS support relocatable builds. - -- - -- If you add new OS' to this list, and your OS supports dynamic libraries - -- and RPATH, make sure you add your OS to RPATH-support list of: - -- Distribution.Simple.GHC.getRPaths - checkOS = - unless (os `elem` [OSX, Linux]) $ - dieWithException verbosity $ - NoOSSupport os "relocatable builds" - where - (Platform _ os) = hostPlatform lbi - - -- Check if the Compiler support relocatable builds - checkCompiler = - unless (compilerFlavor comp `elem` [GHC]) $ - dieWithException verbosity $ - NoCompilerSupport (show comp) - where - comp = compiler lbi - - -- Check if all the install dirs are relative to same prefix - packagePrefixRelative = - unless (relativeInstallDirs installDirs) $ - dieWithException verbosity $ - 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 - -- check for each ComponentId. - installDirs = absoluteInstallDirs pkg lbi NoCopyDest - p = prefix installDirs - relativeInstallDirs (InstallDirs{..}) = - all - isJust - ( fmap - (stripPrefix p) - [ bindir - , libdir - , dynlibdir - , 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 - -- prefix of the package - depsPrefixRelative = do - pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi)) - traverse_ (doCheck $ getSymbolicPath pkgr) ipkgs - where - doCheck pkgr ipkg - | maybe False (== pkgr) (IPI.pkgRoot ipkg) = - for_ (IPI.libraryDirs ipkg) $ \libdir -> do - -- When @prefix@ is not under @pkgroot@, - -- @shortRelativePath prefix pkgroot@ will return a path with - -- @..@s and following check will fail without @canonicalizePath@. - canonicalized <- canonicalizePath libdir - -- The @prefix@ itself must also be canonicalized because - -- canonicalizing @libdir@ may expand symlinks which would make - -- @prefix@ no longer being a prefix of @canonical libdir@, - -- while @canonical p@ could be a prefix of @canonical libdir@ - p' <- canonicalizePath p - unless (p' `isPrefixOf` canonicalized) $ - dieWithException verbosity $ - LibDirDepsPrefixNotRelative libdir p - | otherwise = - return () - -- NB: should be good enough to check this against the default - -- component ID, but if we wanted to be strictly correct we'd - -- check for each ComponentId. - installDirs = absoluteInstallDirs pkg lbi NoCopyDest - p = prefix installDirs - ipkgs = PackageIndex.allPackages (installedPkgs lbi) - --- ----------------------------------------------------------------------------- --- Testing foreign library requirements - -unsupportedForeignLibs :: Compiler -> Platform -> [ForeignLib] -> [String] -unsupportedForeignLibs comp platform = - mapMaybe (checkForeignLibSupported comp platform) - -checkForeignLibSupported :: Compiler -> Platform -> ForeignLib -> Maybe String -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 _ = - unsupported - [ "Building foreign libraries is currently only supported with ghc" - ] - - goGhcPlatform :: Platform -> Maybe String - goGhcPlatform (Platform _ OSX) = goGhcOsx (foreignLibType flib) - goGhcPlatform (Platform _ Linux) = goGhcLinux (foreignLibType flib) +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Configure +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This deals with the /configure/ phase. It provides the 'configure' action +-- which is given the package description and configure flags. It then tries +-- to: configure the compiler; resolves any conditionals in the package +-- description; resolve the package dependencies; check if all the extensions +-- used by this package are supported by the compiler; check that all the build +-- tools are available (including version checks if appropriate); checks for +-- any required @pkg-config@ packages (updating the 'BuildInfo' with the +-- results) +-- +-- Then based on all this it saves the info in the 'LocalBuildInfo' and writes +-- it out to the @dist\/setup-config@ file. It also displays various details to +-- the user, the amount of information displayed depending on the verbosity +-- level. +module Distribution.Simple.Configure + ( configure + , configure_setupHooks + , computePackageInfo + , computePackageInfoFromIndex + , configureFinal + , runPreConfPackageHook + , runPostConfPackageHook + , runPreConfComponentHook + , configurePackage + , PackageInfo (..) + , mkProgramDb + , finalCheckPackage + , configureComponents + , mkPromisedDepsSet + , combinedConstraints + , writePersistBuildConfig + , getConfigStateFile + , getPersistBuildConfig + , checkPersistBuildConfigOutdated + , tryGetPersistBuildConfig + , maybeGetPersistBuildConfig + , findDistPref + , findDistPrefOrDefault + , getInternalLibraries + , computeComponentId + , computeCompatPackageKey + , localBuildInfoFile + , getInstalledPackages + , getInstalledPackagesMonitorFiles + , getInstalledPackagesById + , getPackageDBContents + , configCompiler + , configCompilerEx + , configCompilerAuxEx + , configCompilerProgDb + , computeEffectiveProfiling + , adjustBuildOptions + , buildOptionsAdjustmentWarnings + , adjustBuildOptionsAndWarn + , ccLdOptionsBuildInfo + , checkForeignDeps + , interpretPackageDbFlags + , ConfigStateFileError (..) + , tryGetConfigStateFile + , platformDefines + ) where + +import Control.Monad +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Backpack.Configure +import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour) +import Distribution.Backpack.DescribeUnitId +import Distribution.Backpack.Id +import Distribution.Backpack.PreExistingComponent +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Stack +import Distribution.Compiler +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Check hiding (doesFileExist, listDirectory) +import Distribution.PackageDescription.Configuration +import Distribution.PackageDescription.PrettyPrint +import Distribution.Simple.BuildTarget +import Distribution.Simple.BuildToolDepends +import Distribution.Simple.BuildWay +import Distribution.Simple.Compiler +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex, lookupUnitId) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Program.Db + ( ProgramDb (..) + , lookupProgramByName + , modifyProgramSearchPath + , prependProgramSearchPath + , updateConfiguredProgs + ) +import Distribution.Simple.Setup.Common as Setup +import Distribution.Simple.Setup.Config as Setup +import Distribution.Simple.SetupHooks.Internal + ( ConfigureHooks (..) + , applyComponentDiffs + , noConfigureHooks + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.DependencySatisfaction (DependencySatisfaction (..)) +import Distribution.Types.GivenComponent +import qualified Distribution.Types.LocalBuildConfig as LBC +import Distribution.Types.LocalBuildInfo +import Distribution.Types.MissingDependencyReason (MissingDependencyReason (..)) +import Distribution.Types.PackageVersionConstraint +import Distribution.Utils.LogProgress +import Distribution.Utils.NubList +import Distribution.Utils.String (trim) +import Distribution.Verbosity +import Distribution.Version + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS +import qualified Distribution.Simple.UHC as UHC + +import Control.Exception + ( try + ) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as BLC8 +import Data.List + ( intersect + , stripPrefix + , (\\) + ) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as Map +import Distribution.Compat.Environment (lookupEnv) +import Distribution.Parsec + ( simpleParsec + ) +import Distribution.Pretty + ( defaultStyle + , pretty + , prettyShow + ) +import Distribution.Simple.Errors +import Distribution.Types.AnnotatedId +import Distribution.Utils.Path +import Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncode) +import System.Directory + ( canonicalizePath + , createDirectoryIfMissing + , doesFileExist + , doesPathExist + , listDirectory + ) +import System.FilePath + ( isAbsolute + ) +import System.IO + ( hClose + , hPutStrLn + ) +import qualified System.Info + ( compilerName + , compilerVersion + ) +import Text.PrettyPrint + ( Doc + , char + , hsep + , quotes + , renderStyle + , text + , ($+$) + ) + +import qualified Data.Maybe as M +import qualified Data.Set as Set +import qualified Distribution.Compat.NonEmptySet as NES + +type UseExternalInternalDeps = Bool + +-- | The errors that can be thrown when reading the @setup-config@ file. +data ConfigStateFileError + = -- | No header found. + ConfigStateFileNoHeader + | -- | Incorrect header. + ConfigStateFileBadHeader + | -- | Cannot parse file contents. + ConfigStateFileNoParse + | -- | No file! + ConfigStateFileMissing + { cfgStateFileErrorCwd :: Maybe (SymbolicPath CWD (Dir Pkg)) + , cfgStateFileErrorFile :: SymbolicPath Pkg File + } + | -- | Mismatched version. + ConfigStateFileBadVersion + PackageIdentifier + PackageIdentifier + (Either ConfigStateFileError LocalBuildInfo) + +-- | Format a 'ConfigStateFileError' as a user-facing error message. +dispConfigStateFileError :: ConfigStateFileError -> Doc +dispConfigStateFileError ConfigStateFileNoHeader = + text "Saved package config file header is missing." + <+> text "Re-run the 'Setup configure' command." +dispConfigStateFileError ConfigStateFileBadHeader = + text "Saved package config file header is corrupt." + <+> text "Re-run the 'Setup configure' command." +dispConfigStateFileError ConfigStateFileNoParse = + text "Saved package config file is corrupt." + <+> text "Re-run the 'Setup configure' command." +dispConfigStateFileError ConfigStateFileMissing{} = + text "Run the 'Setup configure' command first." +dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) = + text "Saved package config file is outdated:" + $+$ badCabal + $+$ badCompiler + $+$ text "Re-run the 'Setup configure' command." + where + badCabal = + text "• the Cabal version changed from" + <+> pretty oldCabal + <+> "to" + <+> pretty currentCabalId + badCompiler + | oldCompiler == currentCompilerId = mempty + | otherwise = + text "• the compiler changed from" + <+> pretty oldCompiler + <+> "to" + <+> pretty currentCompilerId + +instance Show ConfigStateFileError where + show = renderStyle defaultStyle . dispConfigStateFileError + +instance Exception ConfigStateFileError + +-- | Read the 'localBuildInfoFile'. Throw an exception if the file is +-- missing, if the file cannot be read, or if the file was created by an older +-- version of Cabal. +getConfigStateFile + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg File + -- ^ The file path of the @setup-config@ file. + -> IO LocalBuildInfo +getConfigStateFile mbWorkDir setupConfigFile = do + let filename = interpretSymbolicPath mbWorkDir setupConfigFile + exists <- doesFileExist filename + unless exists $ throwIO $ ConfigStateFileMissing mbWorkDir setupConfigFile + -- Read the config file into a strict ByteString to avoid problems with + -- lazy I/O, then convert to lazy because the binary package needs that. + contents <- BS.readFile filename + let (header, body) = BLC8.span (/= '\n') (BLC8.fromChunks [contents]) + + (cabalId, compId) <- parseHeader header + + let getStoredValue = do + result <- structuredDecodeOrFailIO (BLC8.tail body) + case result of + Left _ -> throwIO ConfigStateFileNoParse + Right x -> return x + deferErrorIfBadVersion act + | cabalId /= currentCabalId = do + eResult <- try act + throwIO $ ConfigStateFileBadVersion cabalId compId eResult + | otherwise = act + deferErrorIfBadVersion getStoredValue + where + _ = callStack -- TODO: attach call stack to exception + +-- | Read the 'localBuildInfoFile', returning either an error or the local build +-- info. +tryGetConfigStateFile + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory. + -> SymbolicPath Pkg File + -- ^ The file path of the @setup-config@ file. + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetConfigStateFile mbWorkDir = try . getConfigStateFile mbWorkDir + +-- | Try to read the 'localBuildInfoFile'. +tryGetPersistBuildConfig + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory. + -> SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetPersistBuildConfig mbWorkDir = try . getPersistBuildConfig mbWorkDir + +-- | Read the 'localBuildInfoFile'. Throw an exception if the file is +-- missing, if the file cannot be read, or if the file was created by an older +-- version of Cabal. +getPersistBuildConfig + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory. + -> SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> IO LocalBuildInfo +getPersistBuildConfig mbWorkDir distPref = + getConfigStateFile mbWorkDir $ localBuildInfoFile distPref + +-- | Try to read the 'localBuildInfoFile'. +maybeGetPersistBuildConfig + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory. + -> SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> IO (Maybe LocalBuildInfo) +maybeGetPersistBuildConfig mbWorkDir = + fmap (either (const Nothing) Just) . tryGetPersistBuildConfig mbWorkDir + +-- | After running configure, output the 'LocalBuildInfo' to the +-- 'localBuildInfoFile'. +writePersistBuildConfig + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory + -> SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> LocalBuildInfo + -- ^ The 'LocalBuildInfo' to write. + -> IO () +writePersistBuildConfig mbWorkDir distPref lbi = do + createDirectoryIfMissing False (i distPref) + writeFileAtomic (i $ localBuildInfoFile distPref) $ + BLC8.unlines [showHeader pkgId, structuredEncode lbi] + where + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + pkgId = localPackage lbi + +-- | Identifier of the current Cabal package. +currentCabalId :: PackageIdentifier +currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion + +-- | Identifier of the current compiler package. +currentCompilerId :: PackageIdentifier +currentCompilerId = + PackageIdentifier + (mkPackageName System.Info.compilerName) + (mkVersion' System.Info.compilerVersion) + +-- | Parse the @setup-config@ file header, returning the package identifiers +-- for Cabal and the compiler. +parseHeader + :: ByteString + -- ^ The file contents. + -> IO (PackageIdentifier, PackageIdentifier) +parseHeader header = case BLC8.words header of + [ "Saved" + , "package" + , "config" + , "for" + , pkgId + , "written" + , "by" + , cabalId + , "using" + , compId + ] -> + maybe (throwIO ConfigStateFileBadHeader) return $ do + _ <- simpleParsec (fromUTF8LBS pkgId) :: Maybe PackageIdentifier + cabalId' <- simpleParsec (BLC8.unpack cabalId) + compId' <- simpleParsec (BLC8.unpack compId) + return (cabalId', compId') + _ -> throwIO ConfigStateFileNoHeader + +-- | Generate the @setup-config@ file header. +showHeader + :: PackageIdentifier + -- ^ The processed package. + -> ByteString +showHeader pkgId = + BLC8.unwords + [ "Saved" + , "package" + , "config" + , "for" + , toUTF8LBS $ prettyShow pkgId + , "written" + , "by" + , BLC8.pack $ prettyShow currentCabalId + , "using" + , BLC8.pack $ prettyShow currentCompilerId + ] + +-- | Check that localBuildInfoFile is up-to-date with respect to the +-- .cabal file. +checkPersistBuildConfigOutdated + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir Dist) + -> SymbolicPath Pkg File + -> IO Bool +checkPersistBuildConfigOutdated mbWorkDir distPref pkg_descr_file = + i pkg_descr_file `moreRecentFile` i (localBuildInfoFile distPref) + where + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + +-- | Get the path of @dist\/setup-config@. +localBuildInfoFile + :: SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> SymbolicPath Pkg File +localBuildInfoFile distPref = distPref makeRelativePathEx "setup-config" + +-- ----------------------------------------------------------------------------- + +-- * Configuration + +-- ----------------------------------------------------------------------------- + +-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken +-- from (in order of highest to lowest preference) the override prefix, the +-- \"CABAL_BUILDDIR\" environment variable, or the default prefix. +findDistPref + :: SymbolicPath Pkg (Dir Dist) + -- ^ default \"dist\" prefix + -> Setup.Flag (SymbolicPath Pkg (Dir Dist)) + -- ^ override \"dist\" prefix + -> IO (SymbolicPath Pkg (Dir Dist)) +findDistPref defDistPref overrideDistPref = do + envDistPref <- parseEnvDistPref <$> lookupEnv "CABAL_BUILDDIR" + return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref) + where + parseEnvDistPref env = + case env of + Just distPref | not (null distPref) -> toFlag $ makeSymbolicPath distPref + _ -> NoFlag + +-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken +-- from (in order of highest to lowest preference) the override prefix, the +-- \"CABAL_BUILDDIR\" environment variable, or 'defaultDistPref' is used. Call +-- this function to resolve a @*DistPref@ flag whenever it is not known to be +-- set. (The @*DistPref@ flags are always set to a definite value before +-- invoking 'UserHooks'.) +findDistPrefOrDefault + :: Setup.Flag (SymbolicPath Pkg (Dir Dist)) + -- ^ override \"dist\" prefix + -> IO (SymbolicPath Pkg (Dir Dist)) +findDistPrefOrDefault = findDistPref defaultDistPref + +-- | Perform the \"@.\/setup configure@\" action. +-- +-- Returns the @LocalBuildInfo@, also writing it to the @setup-config@ file. +configure + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo +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 + confHooks@(ConfigureHooks{preConfPackageHook}) + (g_pkg_descr, hookedBuildInfo) + verbHandles + cfg = do + (lbc0, comp, platform, enabledComps) <- preConfigurePackage verbHandles cfg g_pkg_descr + + -- Package-wide pre-configure hook + lbc1 <- + maybe + (return lbc0) + (runPreConfPackageHook cfg comp platform lbc0) + preConfPackageHook + + -- Cabal package-wide configure + (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 + + configureFinal + verbHandles + confHooks + hookedBuildInfo + cfg + lbc1 + (g_pkg_descr, pkg_descr0) + flags + enabledComps + comp + platform + packageDbs + pkgInfo + +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)) + + -- 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'} + + -- Cabal package-wide configure + (lbc2, pbd2) <- + configurePackage verbHandles cfg lbc1 pkgDescr0 flags enabledComps comp platform packageDbs + + -- Package-wide post-configure hook + for_ postConfPackageHook $ runPostConfPackageHook lbc2 pbd2 + + -- 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 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 + -- the package since at this point, we're not really sure what + -- components we *can* configure. @Nothing@ means that we should + -- configure everything (the old behavior). + (mb_cname :: Maybe ComponentName) <- do + let flat_pkg_descr = flattenPackageDescription g_pkg_descr + targets0 = configTargets cfg + targets <- readBuildTargets verbosity flat_pkg_descr targets0 + -- TODO: bleat if you use the module/file syntax + let targets' = [cname | BuildTargetComponent cname <- targets] + case targets' of + _ | null targets0 -> return Nothing + [cname] -> return (Just cname) + [] -> dieWithException verbosity NoValidComponent + _ -> dieWithException verbosity ConfigureEitherSingleOrAll + + case mb_cname of + Nothing -> setupMessage verbosity "Configuring" (packageId g_pkg_descr) + Just cname -> + setupMessage' + verbosity + "Configuring" + (packageId g_pkg_descr) + cname + (Just (configInstantiateWith cfg)) + + -- configCID is only valid for per-component configure + when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ + dieWithException verbosity ConfigCIDValidForPreComponent + + -- Make a data structure describing what components are enabled. + let enabled :: ComponentRequestedSpec + enabled = + maybe + ComponentRequestedSpec + { -- The flag name (@--enable-tests@) is a + -- little bit of a misnomer, because + -- just passing this flag won't + -- "enable", in our internal + -- nomenclature; it's just a request; a + -- @buildable: False@ might make it + -- not possible to enable. + testsRequested = fromFlag (configTests cfg) + , benchmarksRequested = fromFlag (configBenchmarks cfg) + } + OneComponentRequestedSpec + mb_cname + -- Some sanity checks related to enabling components. + when + ( isJust mb_cname + && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg)) + ) + $ dieWithException verbosity SanityCheckForEnableComponents + + checkDeprecatedFlags verbosity cfg + checkExactConfiguration verbosity g_pkg_descr 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 + -- building with + ( comp :: Compiler + , compPlatform :: Platform + , programDb00 :: ProgramDb + ) <- + configCompilerEx + (flagToMaybe (configHcFlavor cfg)) + (flagToMaybe (configHcPath cfg)) + (flagToMaybe (configHcPkg cfg)) + programDbPre + (modifyVerbosityFlags lessVerbose verbosity) + + -- Where to build the package + let builddir :: SymbolicPath Pkg (Dir Build) -- e.g. dist/build + builddir = setupFlagsBuildDir $ configCommonFlags cfg + mbWorkDir = flagToMaybe $ configWorkingDir cfg + -- 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 (modifyVerbosityFlags lessVerbose verbosity) True $ + interpretSymbolicPath mbWorkDir builddir + + lbc <- computeLocalBuildConfig verbHandles cfg comp programDb00 + return (lbc, comp, compPlatform, enabled) + +computeLocalBuildConfig + :: VerbosityHandles + -> ConfigFlags + -> Compiler + -> ProgramDb + -> IO LBC.LocalBuildConfig +computeLocalBuildConfig verbHandles cfg comp programDb = do + let common = configCommonFlags cfg + 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 + } + +-- | 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 _ -> + -- If ghc is non-dynamic, then ghci needs object files, + -- so we build one by default. + -- + -- Technically, archive files should be sufficient for ghci, + -- but because of GHC bug #8942, it has never been safe to + -- 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). + GHC.compilerBuildWay comp `notElem` [DynWay, ProfDynWay] + CompilerId GHCJS _ -> + not (GHCJS.isDynamic comp) + _ -> False + + let sharedLibsByDefault + | fromFlag (configDynExe cfg) = + -- build a shared library if dynamically-linked + -- executables are requested + True + | otherwise = case compilerId comp of + CompilerId GHC _ -> + -- if ghc is dynamic, then ghci needs a shared + -- library, so we build one by default. + GHC.compilerBuildWay comp == DynWay + CompilerId GHCJS _ -> + GHCJS.isDynamic comp + _ -> False + withSharedLib_ = + -- build shared libraries if required by GHC or by the + -- executable linking mode, but allow the user to force + -- building only static library archives with + -- --disable-shared. + fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg + + withStaticLib_ = + -- build a static library (all dependent libraries rolled + -- into a huge .a archive) via GHCs -staticlib flag. + fromFlagOrDefault False $ configStaticLib cfg + + -- 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 + + setProfiling <- configureProfiling verbosity cfg comp + + setCoverage <- configureCoverage verbosity cfg comp + + -- Turn off library and executable stripping when `debug-info` is set + -- to anything other than zero. + let + strip_libexe s f = + let defaultStrip = fromFlagOrDefault True (f cfg) + in case fromFlag (configDebugInfo cfg) of + NoDebugInfo -> return defaultStrip + _ -> case f cfg of + Flag True -> do + warn verbosity $ + "Setting debug-info implies " + ++ s + ++ "-stripping: False" + return False + _ -> return False + + strip_lib <- strip_libexe "library" configStripLibs + strip_exe <- strip_libexe "executable" configStripExes + + 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 + } + +-- | 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 + + ghciLib + | LBC.withGHCiLib opts + , not (fromMaybe True linkerSupportsRelocations) = + False + | otherwise = LBC.withGHCiLib opts + + 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 + :: VerbosityHandles + -> ConfigFlags + -> LBC.LocalBuildConfig + -> PackageDescription + -> FlagAssignment + -> ComponentRequestedSpec + -> Compiler + -> Platform + -> PackageDBStack + -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr) +configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform packageDbs = do + let common = configCommonFlags cfg + 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 + -- TODO: it is not clear whether this adding these dirs is necessary + -- when we are directly stating from a PackageDescription (e.g. when + -- cabal-install has determined a PackageDescription, instead of rediscovering + -- when working with a GenericPackageDescription). + -- Could this function call be moved to the end of finalizeAndConfigurePackage + -- right before calling configurePackage? + + -- Configure certain external build tools, see below for which ones. + let requiredBuildTools + -- If --ignore-build-tools is set, no build tool is required: + | fromFlagOrDefault False $ configIgnoreBuildTools cfg = + [] + | otherwise = do + bi <- enabledBuildInfos pkg_descr0 enabled + -- First, we collect any tool dep that we know is external. This is, + -- in practice: + -- + -- 1. `build-tools` entries on the whitelist + -- + -- 2. `build-tool-depends` that aren't from the current package. + let externBuildToolDeps = + [ LegacyExeDependency (unUnqualComponentName eName) versionRange + | buildTool@(ExeDependency _ eName versionRange) <- + getAllToolDependencies pkg_descr0 bi + , not $ isInternal pkg_descr0 buildTool + ] + -- Second, we collect any build-tools entry we don't know how to + -- desugar. We'll never have any idea how to build them, so we just + -- hope they are already on the PATH. + let unknownBuildTools = + [ buildTool + | buildTool <- buildTools bi + , isNothing (desugarBuildTool pkg_descr0 buildTool) + ] + externBuildToolDeps ++ unknownBuildTools + + programDb1 <- + configureAllKnownPrograms (modifyVerbosityFlags lessVerbose verbosity) programDb0 + >>= configureRequiredPrograms verbosity requiredBuildTools + + (pkg_descr2, programDb2) <- + configurePkgconfigPackages verbosity pkg_descr0 programDb1 enabled + + let use_external_internal_deps = + case enabled of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + + -- Compute installation directory templates, based on user + -- configuration. + -- + -- TODO: Move this into a helper function. + defaultDirs :: InstallDirTemplates <- + defaultInstallDirs' + use_external_internal_deps + (compilerFlavor comp) + (fromFlagOrDefault True (configUserInstall cfg)) + (hasLibs pkg_descr2) + let + installDirs = + combineInstallDirs + fromFlagOrDefault + defaultDirs + (configInstallDirs cfg) + lbc = lbc0{LBC.withPrograms = programDb2} + pbd = + LBC.PackageBuildDescr + { configFlags = cfg + , flagAssignment = flags + , componentEnabledSpec = enabled + , compiler = comp + , hostPlatform = platform + , localPkgDescr = pkg_descr2 + , installDirTemplates = installDirs + , withPackageDB = packageDbs + , pkgDescrFile = Nothing + , extraCoverageFor = [] + } + + debug verbosity $ + "Finalized package description:\n" + ++ showPackageDescription pkg_descr2 + + return (lbc, pbd) + +computePackageInfo + :: VerbosityHandles + -> ConfigFlags + -> LBC.LocalBuildConfig + -> GenericPackageDescription + -> Compiler + -> IO ([PackageVersionConstraint], PackageInfo) +computePackageInfo verbHandles cfg lbc0 g_pkg_descr comp = do + let common = configCommonFlags cfg + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + mbWorkDir = flagToMaybe $ setupWorkingDir common + + let programDb0 = LBC.withPrograms lbc0 + -- What package database(s) to use + packageDbs :: PackageDBStack + packageDbs = + interpretPackageDbFlags + (fromFlagOrDefault True (configUserInstall cfg)) + (configPackageDBs cfg) + + -- The InstalledPackageIndex of all installed packages + installedPackageSet :: InstalledPackageIndex <- + getInstalledPackages + (modifyVerbosityFlags lessVerbose verbosity) + comp + mbWorkDir + packageDbs + programDb0 + computePackageInfoFromIndex verbHandles cfg g_pkg_descr installedPackageSet + +-- | 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. + when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $ + dieWithException verbosity SanityCheckForDynamicStaticLinking + + -- allConstraints: The set of all 'Dependency's we have. Used ONLY + -- to 'configureFinalizedPackage'. + -- requiredDepsMap: A map from 'PackageName' to the specifically + -- required 'InstalledPackageInfo', due to --dependency + -- + -- NB: These constraints are to be applied to ALL components of + -- a package. Thus, it's not an error if allConstraints contains + -- more constraints than is necessary for a component (another + -- component might need it.) + -- + -- NB: The fact that we bundle all the constraints together means + -- that is not possible to configure a test-suite to use one + -- version of a dependency, and the executable to use another. + ( allConstraints :: [PackageVersionConstraint] + , requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo + ) <- + either (dieWithException verbosity) return $ + combinedConstraints + (configConstraints cfg) + (configDependencies cfg) + installedPackageSet + + let + promisedDepsSet = mkPromisedDepsSet (configPromisedDependencies cfg) + 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 + -- simple naive algorithm, or having them be passed to + -- us by 'configConfigurationsFlags') + -- flags: The 'FlagAssignment' that the conditionals were + -- resolved with. + -- + -- NB: Why doesn't finalizing a package also tell us what the + -- dependencies are (e.g. when we run the naive algorithm, + -- we are checking if dependencies are satisfiable)? The + -- primary reason is that we may NOT have done any solving: + -- if the flags are all chosen for us, this step is a simple + -- matter of flattening according to that assignment. It's + -- cleaner to then configure the dependencies afterwards. + let use_external_internal_deps = case enabled of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + ( pkg_descr0 :: PackageDescription + , flags :: FlagAssignment + ) <- + finalizePackageDescription2 + verbosity + cfg + enabled + allConstraints + ( dependencySatisfiable + use_external_internal_deps + (fromFlagOrDefault False (configExactConfiguration cfg)) + (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg)) + (packageName g_pkg_descr) + pkgInfo + ) + comp + platform + g_pkg_descr + return (packageDbs, pkg_descr0, flags) + +addExtraIncludeLibDirsFromConfigFlags + :: PackageDescription -> ConfigFlags -> PackageDescription +addExtraIncludeLibDirsFromConfigFlags pkg_descr cfg = + let extraBi = + mempty + { extraLibDirs = configExtraLibDirs cfg + , extraLibDirsStatic = configExtraLibDirsStatic cfg + , extraFrameworkDirs = configExtraFrameworkDirs cfg + , includeDirs = configExtraIncludeDirs cfg + } + modifyLib l = + l + { libBuildInfo = + libBuildInfo l + `mappend` extraBi + } + modifyExecutable e = + e + { buildInfo = + buildInfo e + `mappend` extraBi + } + modifyForeignLib f = + f + { foreignLibBuildInfo = + foreignLibBuildInfo f + `mappend` extraBi + } + modifyTestsuite t = + t + { testBuildInfo = + testBuildInfo t + `mappend` extraBi + } + modifyBenchmark b = + b + { benchmarkBuildInfo = + benchmarkBuildInfo b + `mappend` extraBi + } + in pkg_descr + { library = modifyLib `fmap` library pkg_descr + , subLibraries = modifyLib `map` subLibraries pkg_descr + , executables = modifyExecutable `map` executables pkg_descr + , foreignLibs = modifyForeignLib `map` foreignLibs pkg_descr + , testSuites = modifyTestsuite `map` testSuites pkg_descr + , benchmarks = modifyBenchmark `map` benchmarks pkg_descr + } + +finalCheckPackage + :: VerbosityHandles + -> GenericPackageDescription + -> LBC.PackageBuildDescr + -> HookedBuildInfo + -> IO () +finalCheckPackage + verbHandles + g_pkg_descr + ( LBC.PackageBuildDescr + { configFlags = cfg + , localPkgDescr = pkg_descr + , compiler = comp + , hostPlatform = compPlatform + , componentEnabledSpec = enabled + } + ) + hookedBuildInfo = + do + let common = configCommonFlags cfg + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + cabalFileDir = packageRoot common + + checkCompilerProblems verbosity comp pkg_descr enabled + checkPackageProblems + verbosity + cabalFileDir + g_pkg_descr + (updatePackageDescription hookedBuildInfo pkg_descr) + -- NB: we apply the HookedBuildInfo to check it is valid, + -- but we don't propagate it. + -- Other UserHooks must separately return it again, and we + -- will re-apply it each time. + + -- Check languages and extensions + -- TODO: Move this into a helper function. + let langlist = + ordNub $ + mapMaybe defaultLanguage (enabledBuildInfos pkg_descr enabled) + let langs = unsupportedLanguages comp langlist + unless (null langs) $ + dieWithException verbosity $ + UnsupportedLanguages (packageId pkg_descr) (compilerId comp) (map prettyShow langs) + let extlist = + ordNub $ + concatMap + allExtensions + (enabledBuildInfos pkg_descr enabled) + let exts = unsupportedExtensions comp extlist + unless (null exts) $ + dieWithException verbosity $ + 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 + unless (null unsupportedFLibs) $ + dieWithException verbosity $ + CantFindForeignLibraries unsupportedFLibs + +configureComponents + :: VerbosityHandles + -> LBC.LocalBuildConfig + -> LBC.PackageBuildDescr + -> InstalledPackageIndex + -> Map (PackageName, ComponentName) PromisedComponent + -> ([PreExistingComponent], [ConfiguredPromisedComponent]) + -> IO LocalBuildInfo +configureComponents + verbHandles + lbc@(LBC.LocalBuildConfig{withPrograms = programDb}) + pbd0@( LBC.PackageBuildDescr + { configFlags = cfg + , localPkgDescr = pkg_descr + , compiler = comp + , componentEnabledSpec = enabled + } + ) + installedPackageSet + promisedDepsSet + externalPkgDeps = + do + let common = configCommonFlags cfg + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + use_external_internal_deps = + case enabled of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + + -- Compute internal component graph + -- + -- The general idea is that we take a look at all the source level + -- components (which may build-depends on each other) and form a graph. + -- From there, we build a ComponentLocalBuildInfo for each of the + -- components, which lets us actually build each component. + ( buildComponents :: [ComponentLocalBuildInfo] + , packageDependsIndex :: InstalledPackageIndex + ) <- + runLogProgress verbosity $ + configureComponentLocalBuildInfos + verbosity + use_external_internal_deps + enabled + (fromFlagOrDefault False (configDeterministic cfg)) + (configIPID cfg) + (configCID cfg) + pkg_descr + externalPkgDeps + (configConfigurationsFlags cfg) + (configInstantiateWith cfg) + installedPackageSet + comp + + let buildComponentsMap = + foldl' + ( \m clbi -> + Map.insertWith + (++) + (componentLocalName clbi) + [clbi] + m + ) + Map.empty + buildComponents + + let cbd = + LBC.ComponentBuildDescr + { componentGraph = Graph.fromDistinctList buildComponents + , componentNameMap = buildComponentsMap + , promisedPkgs = promisedDepsSet + , installedPkgs = packageDependsIndex + } + + -- For whole-package configure, we determine the + -- extraCoverageFor of the main lib and sub libs here. + extraCoverageUnitIds = case enabled of + -- Whole package configure, add package libs + ComponentRequestedSpec{} -> mapMaybe mbCompUnitId buildComponents + -- Component configure, no need to do anything since + -- extra-coverage-for will be passed for all other components that + -- should be covered. + OneComponentRequestedSpec{} -> [] + mbCompUnitId LibComponentLocalBuildInfo{componentUnitId} = Just componentUnitId + mbCompUnitId _ = Nothing + + pbd = + pbd0 + { LBC.extraCoverageFor = extraCoverageUnitIds + } + + lbd = + LBC.LocalBuildDescr + { packageBuildDescr = pbd + , componentBuildDescr = cbd + } + + lbi = + NewLocalBuildInfo + { localBuildDescr = lbd + , localBuildConfig = lbc + } + + when (LBC.relocatable $ LBC.withBuildOptions lbc) $ + checkRelocatable verbosity pkg_descr lbi + + when (LBC.withDynExe $ LBC.withBuildOptions lbc) $ + checkSharedExes verbosity lbi + + -- TODO: This is not entirely correct, because the dirs may vary + -- across libraries/executables + let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest + relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi + + -- PKGROOT: allowing ${pkgroot} to be passed as --prefix to + -- cabal configure, is only a hidden option. It allows packages + -- to be relocatable with their package database. This however + -- breaks when the Paths_* or other includes are used that + -- contain hard coded paths. This is still an open TODO. + -- + -- Allowing ${pkgroot} here, however requires less custom hooks + -- in scripts that *really* want ${pkgroot}. See haskell/cabal/#4872 + unless + ( isAbsolute (prefix dirs) + || "${pkgroot}" `isPrefixOf` prefix dirs + ) + $ dieWithException verbosity + $ ExpectedAbsoluteDirectory (prefix dirs) + + when ("${pkgroot}" `isPrefixOf` prefix dirs) $ + warn verbosity $ + "Using ${pkgroot} in prefix " + ++ prefix dirs + ++ " will not work if you rely on the Path_* module " + ++ " or other hard coded paths. Cabal does not yet " + ++ " support fully relocatable builds! " + ++ " See #462 #2302 #2994 #3305 #3473 #3586 #3909" + ++ " #4097 #4291 #4872" + + info verbosity $ + "Using " + ++ prettyShow currentCabalId + ++ " compiled by " + ++ prettyShow currentCompilerId + info verbosity $ "Using compiler: " ++ showCompilerId comp + info verbosity $ "Using install prefix: " ++ prefix dirs + + let dirinfo name dir isPrefixRelative = + info verbosity $ name ++ " installed in: " ++ dir ++ relNote + where + relNote = case buildOS of + Windows + | not (hasLibs pkg_descr) + && isNothing isPrefixRelative -> + " (fixed location)" + _ -> "" + + 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) + dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative) + + sequence_ + [ reportProgram verbosity prog configuredProg + | (prog, configuredProg) <- knownPrograms programDb + ] + + return lbi + +mkPromisedDepsSet :: [PromisedComponent] -> Map (PackageName, ComponentName) PromisedComponent +mkPromisedDepsSet comps = Map.fromList [((packageName pn, CLibName ln), p) | p@(PromisedComponent pn ln _) <- comps] + +-- | 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 :: 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 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 +-- so that we can override the system path. However, in a v2-build, at this point, the "system" path +-- has already been extended by both the built-tools-depends paths, as well as the program-path-extra +-- so for v2 builds adding it again is entirely unnecessary. However, it needs to get added again _anyway_ +-- so as to take effect for v1 builds or standalone calls to Setup.hs +-- In this instance, the lesser evil is to not allow it to override the system path. + +-- ----------------------------------------------------------------------------- +-- Helper functions for configure + +-- | Check if the user used any deprecated flags. +checkDeprecatedFlags :: Verbosity -> ConfigFlags -> IO () +checkDeprecatedFlags verbosity cfg = do + unless (configProfExe cfg == NoFlag) $ do + let enable + | fromFlag (configProfExe cfg) = "enable" + | otherwise = "disable" + warn + verbosity + ( "The flag --" + ++ enable + ++ "-executable-profiling is deprecated. " + ++ "Please use --" + ++ enable + ++ "-profiling instead." + ) + + unless (configLibCoverage cfg == NoFlag) $ do + let enable + | fromFlag (configLibCoverage cfg) = "enable" + | otherwise = "disable" + warn + verbosity + ( "The flag --" + ++ enable + ++ "-library-coverage is deprecated. " + ++ "Please use --" + ++ enable + ++ "-coverage instead." + ) + +-- | Sanity check: if '--exact-configuration' was given, ensure that the +-- complete flag assignment was specified on the command line. +checkExactConfiguration + :: Verbosity -> GenericPackageDescription -> ConfigFlags -> IO () +checkExactConfiguration verbosity pkg_descr0 cfg = + when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do + let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg)) + allFlags = map flagName . genPackageFlags $ pkg_descr0 + diffFlags = allFlags \\ cmdlineFlags + unless (null diffFlags) $ + dieWithException verbosity $ + FlagsNotSpecified diffFlags + +-- | Create a PackageIndex that makes *any libraries that might be* +-- defined internally to this package look like installed packages, in +-- case an executable should refer to any of them as dependencies. +-- +-- It must be *any libraries that might be* defined rather than the +-- actual definitions, because these depend on conditionals in the .cabal +-- file, and we haven't resolved them yet. finalizePD +-- does the resolution of conditionals, and it takes internalPackageSet +-- as part of its input. +getInternalLibraries + :: GenericPackageDescription + -> Set LibraryName +getInternalLibraries pkg_descr0 = + -- TODO: some day, executables will be fair game here too! + let pkg_descr = flattenPackageDescription pkg_descr0 + in Set.fromList (map libName (allLibraries pkg_descr)) + +-- | Returns true if a dependency is satisfiable. This function may +-- report a dependency satisfiable even when it is not, but not vice +-- versa. This is to be passed to finalize +dependencySatisfiable + :: Bool + -- ^ use external internal deps? + -> Bool + -- ^ exact configuration? + -> Bool + -- ^ allow depending on private libs? + -> PackageName + -> PackageInfo + -> (Dependency -> DependencySatisfaction) +dependencySatisfiable + use_external_internal_deps + exact_config + allow_private_deps + pn + PackageInfo + { internalPackageSet = packageLibraries + , promisedDepsSet = promisedDeps + , installedPackageSet + , requiredDepsMap + } + (Dependency depName vr sublibs) + | exact_config = + -- When we're given '--exact-configuration', we assume that all + -- dependencies and flags are exactly specified on the command + -- line. Thus we only consult the 'requiredDepsMap'. Note that + -- we're not doing the version range check, so if there's some + -- dependency that wasn't specified on the command line, + -- 'finalizePD' will fail. + -- TODO: mention '--exact-configuration' in the error message + -- when this fails? + if isInternalDep && not use_external_internal_deps + then -- Except for internal deps, when we're NOT per-component mode; + -- those are just True. + internalDepSatisfiable + else -- Backward compatibility for the old sublibrary syntax + + let depComponentName = + CLibName $ LSubLibName $ packageNameToUnqualComponentName depName + invisibleLibraries = NES.filter (not . visible) sublibs + in if sublibs == mainLibSet && Map.member (pn, depComponentName) requiredDepsMap + then Satisfied + else case nonEmpty $ Set.toList invisibleLibraries of + Nothing -> Satisfied + Just invisibleLibraries' -> Unsatisfied $ MissingLibrary invisibleLibraries' + | isInternalDep = + if use_external_internal_deps + then -- When we are doing per-component configure, we now need to + -- test if the internal dependency is in the index. This has + -- DIFFERENT semantics from normal dependency satisfiability. + internalDepSatisfiableExternally + else -- If a 'PackageName' is defined by an internal component, the dep is + -- satisfiable (we're going to build it ourselves) + internalDepSatisfiable + | otherwise = + depSatisfiable + where + -- Internal dependency is when dependency is the same as package. + isInternalDep = pn == depName + + depSatisfiable = + let allVersions = PackageIndex.lookupPackageName installedPackageSet depName + eligibleVersions = + [ version + | (version, _infos) <- PackageIndex.eligibleDependencies allVersions + ] + in if null $ PackageIndex.matchingDependencies vr allVersions + then + if null eligibleVersions + then Unsatisfied MissingPackage + else Unsatisfied $ WrongVersion eligibleVersions + else Satisfied + + internalDepSatisfiable = + let missingLibraries = NES.toSet sublibs `Set.difference` packageLibraries + in case nonEmpty $ Set.toList missingLibraries of + Nothing -> Satisfied + Just missingLibraries' -> Unsatisfied $ MissingLibrary missingLibraries' + + internalDepSatisfiableExternally = + -- TODO: Might need to propagate information on which versions _are_ available, if any... + let missingLibraries = + NES.filter (null . PackageIndex.lookupInternalDependency installedPackageSet pn vr) sublibs + in case nonEmpty $ Set.toList missingLibraries of + Nothing -> Satisfied + Just missingLibraries' -> Unsatisfied $ MissingLibrary missingLibraries' + + -- Check whether a library exists and is visible. + -- We don't disambiguate between dependency on non-existent or private + -- library yet, so we just return a bool and later report a generic error. + visible lib = + maybe + False -- Does not even exist (wasn't in the depsMap) + ( \ipi -> + IPI.libVisibility ipi == LibraryVisibilityPublic + -- If the override is enabled, the visibility does + -- not matter (it's handled externally) + || allow_private_deps + -- If it's a library of the same package then it's + -- always visible. + -- This is only triggered when passing a component + -- of the same package as --dependency, such as in: + -- cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs + || pkgName (IPI.sourcePackageId ipi) == pn + ) + maybeIPI + -- Don't check if it's visible, we promise to build it before we need it. + || promised + where + maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap + promised = isJust $ Map.lookup (depName, CLibName lib) promisedDeps + +-- | Finalize a generic package description. +-- +-- The workhorse is 'finalizePD'. +finalizePackageDescription2 + :: Verbosity + -> ConfigFlags + -> ComponentRequestedSpec + -> [PackageVersionConstraint] + -> (Dependency -> DependencySatisfaction) + -- ^ tests if a dependency is satisfiable. + -- Might say it's satisfiable even when not. + -> Compiler + -> Platform + -> GenericPackageDescription + -> IO (PackageDescription, FlagAssignment) +finalizePackageDescription2 + verbosity + cfg + enabled + allConstraints + satisfies + comp + compPlatform + pkg_descr0 = do + (pkg_descr, flags) <- + case finalizePD + (configConfigurationsFlags cfg) + enabled + satisfies + compPlatform + (compilerInfo comp) + allConstraints + pkg_descr0 of + Right r -> return r + Left missing -> + dieWithException verbosity $ EncounteredMissingDependency missing + + unless (nullFlagAssignment flags) $ + info verbosity $ + "Flags chosen: " + ++ intercalate + ", " + [ unFlagName fn ++ "=" ++ prettyShow value + | (fn, value) <- unFlagAssignment flags + ] + + return (pkg_descr, flags) + +-- | Check for use of Cabal features which require compiler support +checkCompilerProblems + :: Verbosity -> Compiler -> PackageDescription -> ComponentRequestedSpec -> IO () +checkCompilerProblems verbosity comp pkg_descr enabled = do + unless + ( renamingPackageFlagsSupported comp + || all + (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins) + (enabledBuildInfos pkg_descr enabled) + ) + $ dieWithException verbosity CompilerDoesn'tSupportThinning + when + ( any (not . null . reexportedModules) (allLibraries pkg_descr) + && not (reexportedModulesSupported comp) + ) + $ dieWithException verbosity CompilerDoesn'tSupportReexports + when + ( any (not . null . signatures) (allLibraries pkg_descr) + && not (backpackSupported comp) + ) + $ dieWithException verbosity CompilerDoesn'tSupportBackpack + +-- | Select dependencies for the package. +selectDependencies + :: Verbosity + -> UseExternalInternalDeps + -> PackageInfo + -> PackageDescription + -> ComponentRequestedSpec + -> IO ([PreExistingComponent], [ConfiguredPromisedComponent]) +selectDependencies + verbosity + use_external_internal_deps + pkgInfo + pkg_descr + enableSpec = do + let failedDeps :: [FailedDependency] + allPkgDeps :: [ResolvedDependency] + (failedDeps, allPkgDeps) = + partitionEithers $ + concat + [ fmap (dep,) <$> status + | dep <- enabledBuildDepends pkg_descr enableSpec + , let status = + selectDependency + (package pkg_descr) + pkgInfo + use_external_internal_deps + dep + ] + + internalPkgDeps = + [ pkgid + | (_, InternalDependency pkgid) <- allPkgDeps + ] + -- NB: we have to SAVE the package name, because this is the only + -- way we can be able to resolve package names in the package + -- description. + externalPkgDeps = + [ pec + | (_, ExternalDependency pec) <- allPkgDeps + ] + + promisedPkgDeps = + [ fpec + | (_, PromisedDependency fpec) <- allPkgDeps + ] + + when + ( not (null internalPkgDeps) + && not (newPackageDepsBehaviour pkg_descr) + ) + $ dieWithException verbosity + $ LibraryWithinSamePackage internalPkgDeps + reportFailedDependencies verbosity failedDeps + reportSelectedDependencies verbosity allPkgDeps + + return (externalPkgDeps, promisedPkgDeps) + +-- | Select and apply coverage settings for the build based on the +-- 'ConfigFlags' and 'Compiler'. +configureCoverage + :: Verbosity + -> ConfigFlags + -> Compiler + -> IO (LBC.BuildOptions -> LBC.BuildOptions) +configureCoverage verbosity cfg comp = do + let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg) + tryLibCoverage = + fromFlagOrDefault + tryExeCoverage + (mappend (configCoverage cfg) (configLibCoverage cfg)) + -- TODO: Should we also enforce something here on that --coverage-for cannot + -- include indefinite components or instantiations? + if coverageSupported comp + then do + let apply buildOptions = + buildOptions + { LBC.libCoverage = tryLibCoverage + , LBC.exeCoverage = tryExeCoverage + } + return apply + else do + let apply buildOptions = + buildOptions + { LBC.libCoverage = False + , LBC.exeCoverage = False + } + when (tryExeCoverage || tryLibCoverage) $ + warn + verbosity + ( "The compiler " + ++ showCompilerId comp + ++ " does not support " + ++ "program coverage. Program coverage has been disabled." + ) + return apply + +-- | Compute the effective value of the profiling flags +-- @--enable-library-profiling@ and @--enable-executable-profiling@ +-- from the specified 'ConfigFlags'. This may be useful for +-- external Cabal tools which need to interact with Setup in +-- a backwards-compatible way: the most predictable mechanism +-- for enabling profiling across many legacy versions is to +-- NOT use @--enable-profiling@ and use those two flags instead. +-- +-- Note that @--enable-executable-profiling@ also affects profiling +-- of benchmarks and (non-detailed) test suites. +computeEffectiveProfiling :: ConfigFlags -> (Bool {- lib vanilla-}, Bool {- lib shared -}, Bool {- exe -}) +computeEffectiveProfiling cfg = + -- The --profiling flag sets the default for both libs and exes, + -- but can be overridden by --library-profiling, or the old deprecated + -- --executable-profiling flag. + -- + -- The --profiling-detail and --library-profiling-detail flags behave + -- similarly + let dynamicExe = fromFlagOrDefault False (configDynExe cfg) + tryExeProfiling = + fromFlagOrDefault + False + (mappend (configProf cfg) (configProfExe cfg)) + tryLibProfiling = + fromFlagOrDefault + (tryExeProfiling && not dynamicExe) + (configProfLib cfg) + tryLibProfilingShared = + fromFlagOrDefault + (tryExeProfiling && dynamicExe) + (configProfShared cfg) + in (tryLibProfiling, tryLibProfilingShared, tryExeProfiling) + +-- | Select and apply profiling settings for the build based on the +-- 'ConfigFlags' and 'Compiler'. +configureProfiling + :: Verbosity + -> ConfigFlags + -> Compiler + -> IO (LBC.BuildOptions -> LBC.BuildOptions) +configureProfiling verbosity cfg comp = do + let (tryLibProfiling, tryLibProfilingShared, tryExeProfiling) = computeEffectiveProfiling cfg + + tryExeProfileLevel = + fromFlagOrDefault + ProfDetailDefault + (configProfDetail cfg) + tryLibProfileLevel = + fromFlagOrDefault + ProfDetailDefault + ( mappend + (configProfDetail cfg) + (configProfLibDetail cfg) + ) + + checkProfileLevel (ProfDetailOther other) = do + warn + verbosity + ( "Unknown profiling detail level '" + ++ other + ++ "', using default.\nThe profiling detail levels are: " + ++ intercalate + ", " + [name | (name, _, _) <- knownProfDetailLevels] + ) + return ProfDetailDefault + checkProfileLevel other = return other + + applyProfiling <- + if profilingSupported comp && (profilingVanillaSupportedOrUnknown comp || profilingDynamicSupportedOrUnknown comp) + then do + exeLevel <- checkProfileLevel tryExeProfileLevel + libLevel <- checkProfileLevel tryLibProfileLevel + let apply buildOptions = + buildOptions + { LBC.withProfLib = tryLibProfiling + , LBC.withProfLibDetail = libLevel + , LBC.withProfExe = tryExeProfiling + , LBC.withProfExeDetail = exeLevel + } + let compilerSupportsProfilingDynamic = profilingDynamicSupportedOrUnknown comp + apply2 <- + if compilerSupportsProfilingDynamic + then -- Case 1: We support profiled shared libraries so turn on shared profiling + -- libraries if the user asked for it. + return $ \buildOptions -> apply buildOptions{LBC.withProfLibShared = tryLibProfilingShared} + else -- Case 2: Compiler doesn't support profiling shared so turn them off + do + -- If we wanted to enable profiling shared libraries.. tell the + -- user we couldn't. + when (profilingVanillaSupportedOrUnknown comp && tryLibProfilingShared) $ + warn + verbosity + ( "The compiler " + ++ showCompilerId comp + ++ " does not support " + ++ "profiling shared objects. Static profiled objects " + ++ "will be built." + ) + return $ \buildOptions -> + let original_options = apply buildOptions + in original_options + { LBC.withProfLibShared = False + , LBC.withProfLib = profilingVanillaSupportedOrUnknown comp && (tryLibProfilingShared || LBC.withProfLib original_options) + , LBC.withDynExe = if LBC.withProfExe original_options then False else LBC.withDynExe original_options + } + + when (tryExeProfiling && not (tryLibProfiling || tryLibProfilingShared)) $ do + warn + verbosity + ( "Executables will be built with profiling, but library " + ++ "profiling is disabled. Linking will fail if any executables " + ++ "depend on the library." + ) + return apply2 + else do + let apply buildOptions = + buildOptions + { LBC.withProfLib = False + , LBC.withProfLibShared = False + , LBC.withProfLibDetail = ProfDetailNone + , LBC.withProfExe = False + , LBC.withProfExeDetail = ProfDetailNone + } + when (tryExeProfiling || tryLibProfiling) $ + warn + verbosity + ( "The compiler " + ++ showCompilerId comp + ++ " does not support " + ++ "profiling. Profiling has been disabled." + ) + return apply + + return applyProfiling + +-- ----------------------------------------------------------------------------- +-- Configuring package dependencies + +reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () +reportProgram verbosity prog Nothing = + info verbosity $ "No " ++ programName prog ++ " found" +reportProgram verbosity prog (Just configuredProg) = + info verbosity $ "Using " ++ programName prog ++ version ++ location + where + location = case programLocation configuredProg of + FoundOnSystem p -> " found on system at: " ++ p + UserSpecified p -> " given by user at: " ++ p + version = case programVersion configuredProg of + Nothing -> "" + Just v -> " version " ++ prettyShow v + +hackageUrl :: String +hackageUrl = "http://hackage.haskell.org/package/" + +type ResolvedDependency = (Dependency, DependencyResolution) + +data DependencyResolution + = -- | An external dependency from the package database, OR an + -- internal dependency which we are getting from the package + -- database. + ExternalDependency PreExistingComponent + | -- | A promised dependency, which doesn't yet exist, but should be provided + -- at the build time. + -- + -- We have these such that we can configure components without actually + -- building its dependencies, if these dependencies need to be built later + -- again. For example, when launching a multi-repl, + -- we need to build packages in the interactive ghci session, no matter + -- whether they have been built before. + -- Building them in the configure phase is then redundant and costs time. + PromisedDependency ConfiguredPromisedComponent + | -- | An internal dependency ('PackageId' should be a library name) + -- which we are going to have to build. (The + -- 'PackageId' here is a hack to get a modest amount of + -- polymorphism out of the Pkg' typeclass.) + InternalDependency PackageId + +-- | Test for a package dependency and record the version we have installed. +selectDependency + :: PackageId + -- ^ Package id of current package + -> PackageInfo + -> UseExternalInternalDeps + -- ^ Are we configuring a + -- single component? + -> Dependency + -> [Either FailedDependency DependencyResolution] +selectDependency + pkgid + ( 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 + -- index, then we prefer that match to anything in the second. + -- For example: + -- + -- Name: MyLibrary + -- Version: 0.1 + -- Library + -- .. + -- Executable my-exec + -- build-depends: MyLibrary + -- + -- We want "build-depends: MyLibrary" always to match the internal library + -- even if there is a newer installed library "MyLibrary-0.2". + if dep_pkgname == pn + then + if use_external_internal_deps + then do_external_internal <$> NES.toList libs + else do_internal <$> NES.toList libs + else do_external_external <$> NES.toList libs + where + pn = packageName pkgid + + -- It's an internal library, and we're not per-component build + do_internal lib + | Set.member lib internalIndex = + Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid + | otherwise = + Left $ DependencyMissingInternal dep_pkgname lib + + -- We have to look it up externally + do_external_external :: LibraryName -> Either FailedDependency DependencyResolution + do_external_external lib + | Just pc <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = + return $ PromisedDependency (ConfiguredPromisedComponent dep_pkgname (AnnotatedId (promisedComponentPackage pc) (CLibName lib) (promisedComponentId pc))) + do_external_external lib = do + ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of + -- If we know the exact pkg to use, then use it. + Just pkginstance -> Right pkginstance + -- Otherwise we just pick an arbitrary instance of the latest version. + Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex dep_pkgname vr lib of + Nothing -> Left (DependencyNotExists dep_pkgname) + Just pkg -> Right pkg + return $ ExternalDependency $ ipiToPreExistingComponent ipi + + do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution + do_external_internal lib + | Just pc <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = + return $ PromisedDependency (ConfiguredPromisedComponent dep_pkgname (AnnotatedId (promisedComponentPackage pc) (CLibName lib) (promisedComponentId pc))) + do_external_internal lib = do + ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of + -- If we know the exact pkg to use, then use it. + Just pkginstance -> Right pkginstance + Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex pn vr lib of + -- It's an internal library, being looked up externally + Nothing -> Left (DependencyMissingInternal dep_pkgname lib) + Just pkg -> Right pkg + return $ ExternalDependency $ ipiToPreExistingComponent ipi + + pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo + pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs + +reportSelectedDependencies + :: Verbosity + -> [ResolvedDependency] + -> IO () +reportSelectedDependencies verbosity deps = + info verbosity $ + unlines + [ "Dependency " + ++ prettyShow (simplifyDependency dep) + ++ ": using " + ++ prettyShow pkgid + | (dep, resolution) <- deps + , let pkgid = case resolution of + ExternalDependency pkg' -> packageId pkg' + InternalDependency pkgid' -> pkgid' + PromisedDependency promisedComp -> packageId promisedComp + ] + +reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO () +reportFailedDependencies _ [] = return () +reportFailedDependencies verbosity failed = + dieWithException verbosity $ ReportFailedDependencies failed hackageUrl + +-- | List all installed packages in the given package databases. +-- Non-existent package databases do not cause errors, they just get skipped +-- with a warning and treated as empty ones, since technically they do not +-- contain any package. +getInstalledPackages + :: Verbosity + -> Compiler + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) + -- ^ The stack of package databases. + -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp mbWorkDir packageDBs progdb = do + when (null packageDBs) $ + dieWithException verbosity NoPackageDatabaseSpecified + + info verbosity "Reading installed packages..." + -- do not check empty packagedbs (ghc-pkg would error out) + packageDBs' <- filterM packageDBExists packageDBs + case compilerFlavor comp of + GHC -> GHC.getInstalledPackages verbosity mbWorkDir packageDBs' progdb + GHCJS -> GHCJS.getInstalledPackages verbosity mbWorkDir packageDBs' progdb + UHC -> UHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb + flv -> + dieWithException verbosity $ HowToFindInstalledPackages flv + where + packageDBExists (SpecificPackageDB path0) = do + let path = interpretSymbolicPath mbWorkDir path0 + exists <- doesPathExist path + unless exists $ + warn verbosity $ + "Package db " <> path <> " does not exist yet" + return exists + -- Checking the user and global package dbs is more complicated and needs + -- way more data. Also ghc-pkg won't error out unless the user/global + -- pkgdb is overridden with an empty one, so we just don't check for them. + packageDBExists UserPackageDB = pure True + packageDBExists GlobalPackageDB = pure True + +-- | Like 'getInstalledPackages', but for a single package DB. +-- +-- NB: Why isn't this always a fall through to 'getInstalledPackages'? +-- That is because 'getInstalledPackages' performs some sanity checks +-- on the package database stack in question. However, when sandboxes +-- are involved these sanity checks are not desirable. +getPackageDBContents + :: Verbosity + -> Compiler + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> ProgramDb + -> IO InstalledPackageIndex +getPackageDBContents verbosity comp mbWorkDir packageDB progdb = do + info verbosity "Reading installed packages..." + case compilerFlavor comp of + GHC -> GHC.getPackageDBContents verbosity mbWorkDir packageDB progdb + GHCJS -> GHCJS.getPackageDBContents verbosity mbWorkDir packageDB progdb + -- For other compilers, try to fall back on 'getInstalledPackages'. + _ -> getInstalledPackages verbosity comp mbWorkDir [packageDB] progdb + +-- | A set of files (or directories) that can be monitored to detect when +-- there might have been a change in the installed packages. +getInstalledPackagesMonitorFiles + :: Verbosity + -> Compiler + -> Maybe (SymbolicPath CWD ('Dir from)) + -> PackageDBStackS from + -> ProgramDb + -> Platform + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity comp mbWorkDir packageDBs progdb platform = + case compilerFlavor comp of + GHC -> + GHC.getInstalledPackagesMonitorFiles + verbosity + mbWorkDir + platform + progdb + packageDBs + other -> do + warn verbosity $ + "don't know how to find change monitoring files for " + ++ "the installed package databases for " + ++ prettyShow other + return [] + +-- | Looks up the 'InstalledPackageInfo' of the given 'UnitId's from the +-- 'PackageDBStack' in the 'LocalBuildInfo'. +getInstalledPackagesById + :: Exception (VerboseException exception) + => Verbosity + -> LocalBuildInfo + -> (UnitId -> exception) + -- ^ Construct an exception that is thrown if a + -- unit-id is not found in the installed packages, + -- from the unit-id that is missing. + -> [UnitId] + -- ^ The unit ids to lookup in the installed packages + -> IO [InstalledPackageInfo] +getInstalledPackagesById verbosity lbi@LocalBuildInfo{compiler = comp, withPackageDB = pkgDb, withPrograms = progDb} mkException unitids = do + let mbWorkDir = mbWorkDirLBI lbi + ipindex <- getInstalledPackages verbosity comp mbWorkDir pkgDb progDb + mapM + ( \uid -> case lookupUnitId ipindex uid of + Nothing -> dieWithException verbosity (mkException uid) + Just ipkg -> return ipkg + ) + unitids + +-- | The user interface specifies the package dbs to use with a combination of +-- @--global@, @--user@ and @--package-db=global|user|clear|$file@. +-- This function combines the global/user flag and interprets the package-db +-- flag into a single package db stack. +interpretPackageDbFlags :: Bool -> [Maybe (PackageDBX fp)] -> PackageDBStackX fp +interpretPackageDbFlags userInstall specificDBs = + extra initialStack specificDBs + where + initialStack + | userInstall = [GlobalPackageDB, UserPackageDB] + | otherwise = [GlobalPackageDB] + + extra dbs' [] = dbs' + extra _ (Nothing : dbs) = extra [] dbs + extra dbs' (Just db : dbs) = extra (dbs' ++ [db]) dbs + +-- We are given both --constraint="foo < 2.0" style constraints and also +-- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581". +-- +-- When finalising the package we have to take into account the specific +-- installed deps we've been given, and the finalise function expects +-- constraints, so we have to translate these deps into version constraints. +-- +-- But after finalising we then have to make sure we pick the right specific +-- deps in the end. So we still need to remember which installed packages to +-- pick. +combinedConstraints + :: [PackageVersionConstraint] + -> [GivenComponent] + -- ^ installed dependencies + -> InstalledPackageIndex + -> Either + CabalException + ( [PackageVersionConstraint] + , Map (PackageName, ComponentName) InstalledPackageInfo + ) +combinedConstraints constraints dependencies installedPackages = do + unless (null badComponentIds) $ + Left $ + CombinedConstraints (dispDependencies badComponentIds) + + -- TODO: we don't check that all dependencies are used! + + return (allConstraints, idConstraintMap) + where + allConstraints :: [PackageVersionConstraint] + allConstraints = + constraints + ++ [ thisPackageVersionConstraint (packageId pkg) + | (_, _, _, Just pkg) <- dependenciesPkgInfo + ] + + idConstraintMap :: Map (PackageName, ComponentName) InstalledPackageInfo + idConstraintMap = + Map.fromList + -- NB: do NOT use the packageName from + -- dependenciesPkgInfo! + [ ((pn, cname), pkg) + | (pn, cname, _, Just pkg) <- dependenciesPkgInfo + ] + + -- The dependencies along with the installed package info, if it exists + dependenciesPkgInfo :: [(PackageName, ComponentName, ComponentId, Maybe InstalledPackageInfo)] + dependenciesPkgInfo = + [ (pkgname, CLibName lname, cid, mpkg) + | GivenComponent pkgname lname cid <- dependencies + , let mpkg = + PackageIndex.lookupComponentId + installedPackages + cid + ] + + -- If we looked up a package specified by an installed package id + -- (i.e. someone has written a hash) and didn't find it then it's + -- an error. + badComponentIds = + [ (pkgname, cname, cid) + | (pkgname, cname, cid, Nothing) <- dependenciesPkgInfo + ] + + dispDependencies deps = + hsep + [ text "--dependency=" + <<>> quotes + ( pretty pkgname + <<>> case cname of + CLibName LMainLibName -> "" + CLibName (LSubLibName n) -> ":" <<>> pretty n + _ -> ":" <<>> pretty cname + <<>> char '=' + <<>> pretty cid + ) + | (pkgname, cname, cid) <- deps + ] + +-- ----------------------------------------------------------------------------- +-- Configuring program dependencies + +configureRequiredPrograms + :: Verbosity + -> [LegacyExeDependency] + -> ProgramDb + -> IO ProgramDb +configureRequiredPrograms verbosity deps progdb = + foldM (configureRequiredProgram verbosity) progdb deps + +-- | Configure a required program, ensuring that it exists in the PATH +-- (or where the user has specified the program must live) and making it +-- available for use via the 'ProgramDb' interface. If the program is +-- known (exists in the input 'ProgramDb'), we will make sure that the +-- program matches the required version; otherwise we will accept +-- any version of the program and assume that it is a simpleProgram. +configureRequiredProgram + :: Verbosity + -> ProgramDb + -> LegacyExeDependency + -> IO ProgramDb +configureRequiredProgram + verbosity + progdb + (LegacyExeDependency progName verRange) = + case lookupProgramByName progName progdb of + Just prog -> + -- If the program has already been configured, use it + -- (as long as the version is compatible). + -- + -- Not doing so means falling back to the "simpleProgram" path below, + -- which might fail if the program has custom logic to find a version + -- (such as hsc2hs). + let loc = locationPath $ programLocation prog + in case programVersion prog of + Nothing + | verRange == anyVersion -> + return progdb + | otherwise -> + dieWithException verbosity $! + UnknownVersionDb (programId prog) verRange loc + Just version + | withinRange version verRange -> + return progdb + | otherwise -> + dieWithException verbosity $! + BadVersionDb (programId prog) version verRange loc + Nothing -> + -- Otherwise, try to configure it as a 'simpleProgram' automatically + case lookupKnownProgram progName progdb of + Nothing -> + -- There's a bit of a story behind this line. In old versions + -- of Cabal, there were only internal build-tools dependencies. So the + -- behavior in this case was: + -- + -- - If a build-tool dependency was internal, don't do + -- any checking. + -- + -- - If it was external, call 'configureRequiredProgram' to + -- "configure" the executable. In particular, if + -- the program was not "known" (present in 'ProgramDb'), + -- then we would just error. This was fine, because + -- the only way a program could be executed from 'ProgramDb' + -- is if some library code from Cabal actually called it, + -- and the pre-existing Cabal code only calls known + -- programs from 'defaultProgramDb', and so if it + -- is calling something else, you have a Custom setup + -- script, and in that case you are expected to register + -- the program you want to call in the ProgramDb. + -- + -- OK, so that was fine, until I (ezyang, in 2016) refactored + -- Cabal to support per-component builds. In this case, what + -- was previously an internal build-tool dependency now became + -- an external one, and now previously "internal" dependencies + -- are now external. But these are permitted to exist even + -- when they are not previously configured (something that + -- can only occur by a Custom script.) + -- + -- So, I decided, "Fine, let's just accept these in any + -- case." Thus this line. The alternative would have been to + -- somehow detect when a build-tools dependency was "internal" (by + -- looking at the unflattened package description) but this + -- would also be incompatible with future work to support + -- external executable dependencies: we definitely cannot + -- assume they will be preinitialized in the 'ProgramDb'. + configureProgram verbosity (simpleProgram progName) progdb + Just prog + -- requireProgramVersion always requires the program have a version + -- but if the user says "build-depends: foo" ie no version constraint + -- then we should not fail if we cannot discover the program version. + | verRange == anyVersion -> do + (_, progdb') <- requireProgram verbosity prog progdb + return progdb' + | otherwise -> do + (_, _, progdb') <- requireProgramVersion verbosity prog verRange progdb + return progdb' + +-- ----------------------------------------------------------------------------- +-- Configuring pkg-config package dependencies + +configurePkgconfigPackages + :: Verbosity + -> PackageDescription + -> ProgramDb + -> ComponentRequestedSpec + -> IO (PackageDescription, ProgramDb) +configurePkgconfigPackages verbosity pkg_descr progdb enabled + | null allpkgs = return (pkg_descr, progdb) + | otherwise = do + (_, _, progdb') <- + requireProgramVersion + (modifyVerbosityFlags lessVerbose verbosity) + pkgConfigProgram + (orLaterVersion $ mkVersion [0, 9, 0]) + progdb + traverse_ requirePkg allpkgs + mlib' <- traverse addPkgConfigBILib (library pkg_descr) + libs' <- traverse addPkgConfigBILib (subLibraries pkg_descr) + exes' <- traverse addPkgConfigBIExe (executables pkg_descr) + tests' <- traverse addPkgConfigBITest (testSuites pkg_descr) + benches' <- traverse addPkgConfigBIBench (benchmarks pkg_descr) + let pkg_descr' = + pkg_descr + { library = mlib' + , subLibraries = libs' + , executables = exes' + , testSuites = tests' + , benchmarks = benches' + } + return (pkg_descr', progdb') + where + allpkgs = concatMap pkgconfigDepends (enabledBuildInfos pkg_descr enabled) + pkgconfig = + getDbProgramOutput + (modifyVerbosityFlags lessVerbose verbosity) + pkgConfigProgram + progdb + + requirePkg dep@(PkgconfigDependency pkgn range) = do + version <- + pkgconfig ["--modversion", pkg] + `catchIO` (\_ -> dieWithException verbosity $ PkgConfigNotFound pkg versionRequirement) + `catchExit` (\_ -> dieWithException verbosity $ PkgConfigNotFound pkg versionRequirement) + let v = PkgconfigVersion (toUTF8BS $ trim version) + if not (withinPkgconfigVersionRange v range) + then dieWithException verbosity $ BadVersion pkg versionRequirement v + else info verbosity (depSatisfied v) + where + depSatisfied v = + "Dependency " + ++ prettyShow dep + ++ ": using version " + ++ prettyShow v + + versionRequirement + | isAnyPkgconfigVersion range = "" + | otherwise = " version " ++ prettyShow range + + pkg = unPkgconfigName pkgn + + -- Adds pkgconfig dependencies to the build info for a component + addPkgConfigBI compBI setCompBI comp = do + bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp)) + return $ setCompBI comp (compBI comp `mappend` bi) + + -- Adds pkgconfig dependencies to the build info for a library + addPkgConfigBILib = addPkgConfigBI libBuildInfo $ + \lib bi -> lib{libBuildInfo = bi} + + -- Adds pkgconfig dependencies to the build info for an executable + addPkgConfigBIExe = addPkgConfigBI buildInfo $ + \exe bi -> exe{buildInfo = bi} + + -- Adds pkgconfig dependencies to the build info for a test suite + addPkgConfigBITest = addPkgConfigBI testBuildInfo $ + \test bi -> test{testBuildInfo = bi} + + -- Adds pkgconfig dependencies to the build info for a benchmark + addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $ + \bench bi -> bench{benchmarkBuildInfo = bi} + + pkgconfigBuildInfo :: [PkgconfigDependency] -> IO BuildInfo + pkgconfigBuildInfo [] = return mempty + pkgconfigBuildInfo pkgdeps = do + let pkgs = ordNub [prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps] + ccflags <- pkgconfig ("--cflags" : pkgs) + ldflags <- pkgconfig ("--libs" : pkgs) + ldflags_static <- pkgconfig ("--libs" : "--static" : pkgs) + return (ccLdOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static)) + +-- | Makes a 'BuildInfo' from C compiler and linker flags. +-- +-- This can be used with the output from configuration programs like pkg-config +-- and similar package-specific programs like mysql-config, freealut-config etc. +-- For example: +-- +-- > ccflags <- getDbProgramOutput verbosity prog progdb ["--cflags"] +-- > ldflags <- getDbProgramOutput verbosity prog progdb ["--libs"] +-- > ldflags_static <- getDbProgramOutput verbosity prog progdb ["--libs", "--static"] +-- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static)) +ccLdOptionsBuildInfo :: [String] -> [String] -> [String] -> BuildInfo +ccLdOptionsBuildInfo cflags ldflags ldflags_static = + 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 + in mempty + { includeDirs = map (makeSymbolicPath . drop 2) includeDirs' + , extraLibs = map (drop 2) extraLibs' + , extraLibDirs = map (makeSymbolicPath . drop 2) extraLibDirs' + , extraLibsStatic = map (drop 2) extraLibsStatic' + , extraLibDirsStatic = map (makeSymbolicPath . drop 2) extraLibDirsStatic' + , ccOptions = cflags' + , ldOptions = ldflags'' + } + +-- ----------------------------------------------------------------------------- +-- Determining the compiler details + +configCompilerAuxEx + :: VerbosityHandles + -> ConfigFlags + -> IO (Compiler, Platform, ProgramDb) +configCompilerAuxEx verbHandles cfg = do + programDb <- mkProgramDb verbHandles cfg defaultProgramDb + let common = configCommonFlags cfg + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + configCompilerEx + (flagToMaybe $ configHcFlavor cfg) + (flagToMaybe $ configHcPath cfg) + (flagToMaybe $ configHcPkg cfg) + programDb + verbosity + +-- | Configure the compiler and associated programs such as @hc-pkg@, @haddock@ +-- and toolchain program such as @ar@, @ld@. +configCompilerEx + :: Maybe CompilerFlavor + -> Maybe FilePath + -- ^ user-specified @hc@ path (optional) + -> Maybe FilePath + -- ^ user-specified @hc-pkg@ path (optional) + -> ProgramDb + -> Verbosity + -> IO (Compiler, Platform, ProgramDb) +configCompilerEx Nothing _ _ _ verbosity = dieWithException verbosity UnknownCompilerException +configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do + (comp, maybePlatform, programDb) <- case hcFlavor of + GHC -> GHC.configure verbosity hcPath hcPkg progdb + GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb + UHC -> UHC.configure verbosity hcPath progdb + _ -> dieWithException verbosity UnknownCompilerException + return (comp, fromMaybe buildPlatform maybePlatform, programDb) + +-- | Configure the compiler ONLY. +configCompiler + :: Maybe CompilerFlavor + -> Maybe FilePath + -- ^ user-specified @hc@ path (optional) + -> ProgramDb + -> Verbosity + -> IO (Compiler, Platform, ProgramDb) +configCompiler mbFlavor hcPath progdb verbosity = do + (comp, maybePlatform, programDb) <- + case mbFlavor of + Nothing -> dieWithException verbosity UnknownCompilerException + Just hcFlavor -> + case hcFlavor of + GHC -> GHC.configureCompiler verbosity hcPath progdb + GHCJS -> GHCJS.configureCompiler verbosity hcPath progdb + UHC -> UHC.configure verbosity hcPath progdb + _ -> dieWithException verbosity UnknownCompilerException + return (comp, fromMaybe buildPlatform maybePlatform, programDb) + +-- | Configure programs associated to the compiler, such as @hc-pkg@, @haddock@ +-- and toolchain program such as @ar@, @ld@. +configCompilerProgDb + :: Verbosity + -> Compiler + -> ProgramDb + -- ^ program database containing the compiler + -> Maybe FilePath + -- ^ user-specified @hc-pkg@ path (optional) + -> IO ProgramDb +configCompilerProgDb verbosity comp hcProgDb hcPkgPath = do + case compilerFlavor comp of + GHC -> GHC.compilerProgramDb verbosity comp hcProgDb hcPkgPath + GHCJS -> GHCJS.compilerProgramDb verbosity comp hcProgDb hcPkgPath + _ -> return hcProgDb + +-- ----------------------------------------------------------------------------- +-- Testing C lib and header dependencies + +-- Try to build a test C program which includes every header and links every +-- lib. If that fails, try to narrow it down by preprocessing (only) and linking +-- with individual headers and libs. If none is the obvious culprit then give a +-- generic error message. +-- TODO: produce a log file from the compiler errors, if any. +checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () +checkForeignDeps pkg lbi verbosity = + ifBuildsWith + allHeaders + (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling lucky + (return ()) + ( do + missingLibs <- findMissingLibs + missingHdr <- findOffendingHdr + explainErrors missingHdr missingLibs + ) + where + allHeaders = collectField (fmap getSymbolicPath . includes) + allLibs = + collectField $ + if withFullyStaticExe lbi + then extraLibsStatic + else extraLibs + + ifBuildsWith headers args success failure = do + checkDuplicateHeaders + ok <- builds (makeProgram headers) args + if ok then success else failure + + -- Ensure that there is only one header with a given name + -- in either the generated (most likely by `configure`) + -- build directory (e.g. `dist/build`) or in the source directory. + -- + -- 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. + -- + checkDuplicateHeaders = do + let relIncDirs = filter (not . isAbsolute) (collectField (fmap getSymbolicPath . includeDirs)) + isHeader = isSuffixOf ".h" + genHeaders <- for relIncDirs $ \dir -> + fmap (dir ) . filter isHeader + <$> listDirectory (i (buildDir lbi) dir) `catchIO` (\_ -> return []) + srcHeaders <- for relIncDirs $ \dir -> + fmap (dir ) . filter isHeader + <$> listDirectory (baseDir dir) `catchIO` (\_ -> return []) + let commonHeaders = concat genHeaders `intersect` concat srcHeaders + for_ commonHeaders $ \hdr -> do + warn verbosity $ + "Duplicate header found in " + ++ (getSymbolicPath (buildDir lbi) hdr) + ++ " and " + ++ (baseDir hdr) + ++ ". Which one the C compiler will use is unspecified." + + findOffendingHdr = + ifBuildsWith + allHeaders + ccArgs + (return Nothing) + (go . tail . NEL.inits $ allHeaders) + where + go [] = return Nothing -- cannot happen + go (hdrs : hdrsInits) = + -- Try just preprocessing first + ifBuildsWith + hdrs + cppArgs + -- If that works, try compiling too + ( ifBuildsWith + hdrs + ccArgs + (go hdrsInits) + (return . fmap Right . safeLast $ hdrs) + ) + (return . fmap Left . safeLast $ hdrs) + + cppArgs = "-E" : commonCppArgs -- preprocess only + ccArgs = "-c" : commonCcArgs -- don't try to link + findMissingLibs = + ifBuildsWith + [] + (makeLdArgs allLibs) + (return []) + (filterM (fmap not . libExists) allLibs) + + libExists lib = builds (makeProgram []) (makeLdArgs [lib]) + + common = configCommonFlags $ configFlags lbi + baseDir = packageRoot common + + -- See Note [Symbolic paths] in Distribution.Utils.Path + i = interpretSymbolicPathLBI lbi + mbWorkDir = mbWorkDirLBI lbi + + commonCppArgs = + platformDefines lbi + -- TODO: This is a massive hack, to work around the + -- fact that the test performed here should be + -- PER-component (c.f. the "I'm Feeling Lucky"; we + -- should NOT be glomming everything together.) + ++ ["-I" ++ i (buildDir lbi makeRelativePathEx "autogen")] + -- `configure' may generate headers in the build directory + ++ [ "-I" ++ i (buildDir lbi unsafeCoerceSymbolicPath dir) + | dir <- mapMaybe symbolicPathRelative_maybe $ ordNub (collectField includeDirs) + ] + -- we might also reference headers from the + -- packages directory. + ++ [ "-I" ++ baseDir getSymbolicPath dir + | dir <- mapMaybe symbolicPathRelative_maybe $ ordNub (collectField includeDirs) + ] + ++ [ "-I" ++ dir + | dir <- ordNub (collectField (fmap getSymbolicPath . includeDirs)) + , isAbsolute dir + ] + ++ ["-I" ++ baseDir] + ++ collectField cppOptions + ++ collectField ccOptions + ++ [ "-I" ++ dir + | dir <- + ordNub + [ dir + | dep <- deps + , dir <- IPI.includeDirs dep + ] + -- dedupe include dirs of dependencies + -- to prevent quadratic blow-up + ] + ++ [ opt + | dep <- deps + , opt <- IPI.ccOptions dep + ] + + commonCcArgs = + commonCppArgs + ++ collectField ccOptions + ++ [ opt + | dep <- deps + , opt <- IPI.ccOptions dep + ] + + commonLdArgs = + [ "-L" ++ getSymbolicPath dir + | dir <- + ordNub $ + collectField + ( if withFullyStaticExe lbi + then extraLibDirsStatic + else extraLibDirs + ) + ] + ++ collectField ldOptions + ++ [ "-L" ++ dir + | dir <- + ordNub + [ dir + | dep <- deps + , dir <- + if withFullyStaticExe lbi + then IPI.libraryDirsStatic dep + else IPI.libraryDirs dep + ] + ] + -- TODO: do we also need dependent packages' ld options? + makeLdArgs libs = ["-l" ++ lib | lib <- libs] ++ commonLdArgs + + makeProgram hdrs = + unlines $ + ["#include \"" ++ hdr ++ "\"" | hdr <- hdrs] + ++ ["int main(int argc, char** argv) { return 0; }"] + + collectField f = concatMap f allBi + allBi = enabledBuildInfos pkg (componentEnabledSpec lbi) + deps = PackageIndex.topologicalOrder (installedPkgs lbi) + + builds :: String -> [ProgArg] -> IO Bool + builds program args = + withTempFileCwd ".c" $ \cName cHnd -> + withTempFileCwd "" $ \oNname oHnd -> + do + hPutStrLn cHnd program + hClose cHnd + hClose oHnd + _ <- + getDbProgramOutputCwd + verbosity + mbWorkDir + gccProgram + (withPrograms lbi) + (getSymbolicPath cName : "-o" : getSymbolicPath oNname : args) + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + + explainErrors Nothing [] = return () -- should be impossible! + explainErrors _ _ + | isNothing . lookupProgram gccProgram . withPrograms $ lbi = + dieWithException verbosity NoWorkingGcc + explainErrors hdr libs = + dieWithException verbosity $ ExplainErrors hdr libs + +-- | Output package check warnings and errors. Exit if any errors. +checkPackageProblems + :: Verbosity + -> FilePath + -- ^ Path to the @.cabal@ file's directory + -> GenericPackageDescription + -> PackageDescription + -> IO () +checkPackageProblems verbosity dir gpkg pkg = do + ioChecks <- checkPackageFiles verbosity pkg dir + let pureChecks = checkPackage gpkg + (errors, warnings) = + partitionEithers (M.mapMaybe classEW $ pureChecks ++ ioChecks) + if null errors + then traverse_ (warn verbosity . ppPackageCheck) warnings + else dieWithException verbosity $ CheckPackageProblems (map ppPackageCheck errors) + where + -- Classify error/warnings. Left: error, Right: warning. + classEW :: PackageCheck -> Maybe (Either PackageCheck PackageCheck) + classEW e@(PackageBuildImpossible _) = Just (Left e) + classEW w@(PackageBuildWarning _) = Just (Right w) + classEW (PackageDistSuspicious _) = Nothing + classEW (PackageDistSuspiciousWarn _) = Nothing + classEW (PackageDistInexcusable _) = Nothing + +-- | Perform checks if a shared executable can be built +checkSharedExes + :: Verbosity + -> LocalBuildInfo + -> IO () +checkSharedExes verbosity lbi = + when (os == Windows) $ + dieWithException verbosity $ + NoOSSupport os "shared executables" + where + (Platform _ os) = hostPlatform lbi + +-- | Preform checks if a relocatable build is allowed +checkRelocatable + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> IO () +checkRelocatable verbosity pkg lbi = + sequence_ + [ checkOS + , checkCompiler + , packagePrefixRelative + , depsPrefixRelative + ] + where + -- Check if the OS support relocatable builds. + -- + -- If you add new OS' to this list, and your OS supports dynamic libraries + -- and RPATH, make sure you add your OS to RPATH-support list of: + -- Distribution.Simple.GHC.getRPaths + checkOS = + unless (os `elem` [OSX, Linux, FreeBSD]) $ + dieWithException verbosity $ + NoOSSupport os "relocatable builds" + where + (Platform _ os) = hostPlatform lbi + + -- Check if the Compiler support relocatable builds + checkCompiler = + unless (compilerFlavor comp == GHC) $ + dieWithException verbosity $ + NoCompilerSupport (show comp) + where + comp = compiler lbi + + -- Check if all the install dirs are relative to same prefix + packagePrefixRelative = + unless (relativeInstallDirs installDirs) $ + dieWithException verbosity $ + 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 + -- check for each ComponentId. + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + p = prefix installDirs + relativeInstallDirs (InstallDirs{..}) = + all + (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 + -- prefix of the package + depsPrefixRelative = do + pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi)) + traverse_ (doCheck $ getSymbolicPath pkgr) ipkgs + where + doCheck pkgr 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 + -- @..@s and following check will fail without @canonicalizePath@. + canonicalized <- canonicalizePath libdir + -- The @prefix@ itself must also be canonicalized because + -- canonicalizing @libdir@ may expand symlinks which would make + -- @prefix@ no longer being a prefix of @canonical libdir@, + -- while @canonical p@ could be a prefix of @canonical libdir@ + p' <- canonicalizePath p + unless (p' `isPrefixOf` canonicalized) $ + dieWithException verbosity $ + LibDirDepsPrefixNotRelative libdir p + | otherwise = + return () + -- NB: should be good enough to check this against the default + -- component ID, but if we wanted to be strictly correct we'd + -- check for each ComponentId. + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + p = prefix installDirs + ipkgs = PackageIndex.allPackages (installedPkgs lbi) + +-- ----------------------------------------------------------------------------- +-- Testing foreign library requirements + +unsupportedForeignLibs :: Compiler -> Platform -> [ForeignLib] -> [String] +unsupportedForeignLibs comp platform = + mapMaybe (checkForeignLibSupported comp platform) + +checkForeignLibSupported :: Compiler -> Platform -> ForeignLib -> Maybe String +checkForeignLibSupported comp platform flib = go (compilerFlavor comp) + where + go :: CompilerFlavor -> Maybe String + go GHC = goGhcPlatform platform + go _ = + unsupported + [ "Building foreign libraries is currently only supported with ghc" + ] + + goGhcPlatform :: Platform -> Maybe String + goGhcPlatform (Platform _ OSX) = goGhcOsx (foreignLibType flib) + goGhcPlatform (Platform _ Linux) = goGhcLinux (foreignLibType flib) + goGhcPlatform (Platform _ FreeBSD) = goGhcLinux (foreignLibType flib) goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib) goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib) goGhcPlatform _ = diff --git a/src/Distribution/Simple/ConfigureScript.hs b/src/Distribution/Simple/ConfigureScript.hs --- a/src/Distribution/Simple/ConfigureScript.hs +++ b/src/Distribution/Simple/ConfigureScript.hs @@ -5,7 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Distribution.Simple.ConfigureScript @@ -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 @@ -78,6 +78,18 @@ -- We don't try and tell configure which ld to use, as we don't have -- a way to pass its flags too + -- Do not presume the CXX compiler is available, but it always will be after 9.4. + (mcxxProgShort, mcxxFlags) <- do + mprog <- needProgram verbosity gppProgram programDb + case mprog of + Just (p, _) -> do + let pInv = programInvocation p [] + let cxxProg = progInvokePath pInv + let cxxFlags = progInvokeArgs pInv + cxxProgShort <- getShortPathName cxxProg + return (Just cxxProgShort, Just cxxFlags) + Nothing -> return (Nothing, Nothing) + let configureFile' = toUnix configureFile -- autoconf is fussy about filenames, and has a set of forbidden -- characters that can't appear in the build directory, etc: @@ -159,9 +171,7 @@ ) ] let extraPath = fromNubList $ configProgramPathExtra cfg - let cflagsEnv = - maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) $ - lookup "CFLAGS" env + let mkFlagsEnv fs var = maybe (unwords fs) (++ (" " ++ unwords fs)) (lookup var env) spSep = [FilePath.searchPathSeparator] pathEnv = maybe @@ -169,11 +179,17 @@ ((intercalate spSep extraPath ++ spSep) ++) $ lookup "PATH" env overEnv = - ("CFLAGS", Just cflagsEnv) - : [("PATH", Just pathEnv) | not (null extraPath)] + ("CFLAGS", Just (mkFlagsEnv ccFlags "CFLAGS")) + : [("CXXFLAGS", Just (mkFlagsEnv cxxFlags "CXXFLAGS")) | Just cxxFlags <- [mcxxFlags]] + ++ [("PATH", Just pathEnv) | not (null extraPath)] ++ cabalFlagEnv - maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)] - args' = configureFile' : args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag + maybeHostFlag = ["--host=" ++ show (pretty hp) | hp /= buildPlatform] + args' = + configureFile' + : args + ++ ["CC=" ++ ccProgShort] + ++ ["CXX=" ++ cxxProgShort | Just cxxProgShort <- [mcxxProgShort]] + ++ maybeHostFlag shProg = simpleProgram "sh" progDb <- prependProgramSearchPath verbosity extraPath [] emptyProgramDb shConfiguredProg <- diff --git a/src/Distribution/Simple/Errors.hs b/src/Distribution/Simple/Errors.hs --- a/src/Distribution/Simple/Errors.hs +++ b/src/Distribution/Simple/Errors.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} - ----------------------------------------------------------------------------- -- Module : Distribution.Simple.Errors @@ -31,6 +29,7 @@ import Distribution.Simple.PreProcess.Types (Suffix) import Distribution.Simple.SetupHooks.Errors import Distribution.System (OS) +import Distribution.Types.MissingDependency (MissingDependency) import Distribution.Types.VersionRange.Internal () import Distribution.Version import Text.PrettyPrint @@ -50,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 @@ -79,8 +78,6 @@ | NoSupportBuildingTestSuite TestType | NoSupportBuildingBenchMark BenchmarkType | BuildingNotSupportedWithCompiler - | ProvideHaskellSuiteTool String - | CannotDetermineCompilerVersion | PkgDumpFailed | FailedToParseOutput | CantFindSourceModule ModuleName @@ -99,8 +96,7 @@ | AmbiguousBuildTarget [(String, [(String, String)])] | CheckBuildTargets String | VersionMismatchGHC FilePath Version FilePath Version - | CheckPackageDbStackPost76 - | CheckPackageDbStackPre76 + | CheckPackageDbStack | GlobalPackageDbSpecifiedFirst | CantInstallForeignLib | NoSupportForPreProcessingTest TestType @@ -126,7 +122,7 @@ | CantFindForeignLibraries [String] | ExpectedAbsoluteDirectory FilePath | FlagsNotSpecified [FlagName] - | EncounteredMissingDependency [Dependency] + | EncounteredMissingDependency [MissingDependency] | CompilerDoesn'tSupportThinning | CompilerDoesn'tSupportReexports | CompilerDoesn'tSupportBackpack @@ -172,6 +168,8 @@ | UnknownVersionDb String VersionRange FilePath | MissingCoveredInstalledLibrary UnitId | SetupHooksException SetupHooksException + | MultiReplDoesNotSupportComplexReexportedModules PackageName ComponentName + | StandaloneBytecodeNotSupportedYet deriving (Show) exceptionCode :: CabalException -> Int @@ -211,8 +209,8 @@ NoSupportBuildingTestSuite{} -> 4106 NoSupportBuildingBenchMark{} -> 5320 BuildingNotSupportedWithCompiler{} -> 7077 - ProvideHaskellSuiteTool{} -> 7509 - CannotDetermineCompilerVersion{} -> 4519 + -- Retired: ProvideHaskellSuiteTool{} -> 7509 + -- Retired: CannotDetermineCompilerVersion{} -> 4519 PkgDumpFailed{} -> 2291 FailedToParseOutput{} -> 5500 CantFindSourceModule{} -> 8870 @@ -231,8 +229,8 @@ AmbiguousBuildTarget{} -> 7865 CheckBuildTargets{} -> 4733 VersionMismatchGHC{} -> 4000 - CheckPackageDbStackPost76{} -> 3000 - CheckPackageDbStackPre76{} -> 5640 + CheckPackageDbStack{} -> 3000 + -- Retired: CheckPackageDbStackPre76{} -> 5640 GlobalPackageDbSpecifiedFirst{} -> 2345 CantInstallForeignLib{} -> 8221 NoSupportForPreProcessingTest{} -> 3008 @@ -305,6 +303,8 @@ MissingCoveredInstalledLibrary{} -> 9341 SetupHooksException err -> setupHooksExceptionCode err + MultiReplDoesNotSupportComplexReexportedModules{} -> 9355 + StandaloneBytecodeNotSupportedYet -> 9356 versionRequirement :: VersionRange -> String versionRequirement range @@ -319,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 @@ -365,8 +365,6 @@ NoSupportBuildingTestSuite test_type -> "No support for building test suite type " ++ show test_type NoSupportBuildingBenchMark benchMarkType -> "No support for building benchmark type " ++ show benchMarkType BuildingNotSupportedWithCompiler -> "Building is not supported with this compiler." - ProvideHaskellSuiteTool msg -> show msg - CannotDetermineCompilerVersion -> "haskell-suite: couldn't determine compiler version" PkgDumpFailed -> "pkg dump failed" FailedToParseOutput -> "failed to parse output of 'pkg dump'" CantFindSourceModule moduleName -> "can't find source for module " ++ prettyShow moduleName @@ -471,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" @@ -552,7 +546,7 @@ . nest 4 . sep . punctuate comma - . map (pretty . simplifyDependency) + . map pretty $ missing ) CompilerDoesn'tSupportThinning -> @@ -800,3 +794,15 @@ ++ "' in package database stack." SetupHooksException err -> setupHooksExceptionMessage err + MultiReplDoesNotSupportComplexReexportedModules pname cname -> + "When attempting start the repl for " + ++ showComponentName cname + ++ " from package " + ++ prettyShow pname + ++ " a module renaming was found.\n" + ++ "Multi-repl does not work with complicated reexported-modules until GHC-9.12." + 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/Flag.hs b/src/Distribution/Simple/Flag.hs --- a/src/Distribution/Simple/Flag.hs +++ b/src/Distribution/Simple/Flag.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- @@ -20,7 +18,9 @@ -- -- Split off from "Distribution.Simple.Setup" to break import cycles. module Distribution.Simple.Flag - ( Flag (..) + ( Flag + , pattern Flag + , pattern NoFlag , allFlags , toFlag , fromFlag @@ -33,6 +33,7 @@ , BooleanFlag (..) ) where +import Data.Monoid (Last (..)) import Distribution.Compat.Prelude hiding (get) import Distribution.Compat.Stack import Prelude () @@ -62,43 +63,15 @@ -- 'NoFlag' and later flags override earlier ones. -- -- Isomorphic to 'Maybe' a. -data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Foldable, Traversable) - -instance Binary a => Binary (Flag a) -instance Structured a => Structured (Flag a) - -instance Functor Flag where - fmap f (Flag x) = Flag (f x) - fmap _ NoFlag = NoFlag - -instance Applicative Flag where - (Flag x) <*> y = x <$> y - NoFlag <*> _ = NoFlag - pure = Flag - -instance Monoid (Flag a) where - mempty = NoFlag - mappend = (<>) +type Flag = Last -instance Semigroup (Flag a) where - _ <> f@(Flag _) = f - f <> NoFlag = f +pattern Flag :: a -> Last a +pattern Flag a = Last (Just a) -instance Bounded a => Bounded (Flag a) where - minBound = toFlag minBound - maxBound = toFlag maxBound +pattern NoFlag :: Last a +pattern NoFlag = Last Nothing -instance Enum a => Enum (Flag a) where - fromEnum = fromEnum . fromFlag - toEnum = toFlag . toEnum - enumFrom (Flag a) = map toFlag . enumFrom $ a - enumFrom _ = [] - enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b - enumFromThen _ _ = [] - enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b - enumFromTo _ _ = [] - enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c - enumFromThenTo _ _ _ = [] +{-# COMPLETE Flag, NoFlag #-} -- | Wraps a value in 'Flag'. toFlag :: a -> Flag a @@ -111,26 +84,22 @@ -- | Extracts a value from a 'Flag', and returns the default value on 'NoFlag'. fromFlagOrDefault :: a -> Flag a -> a -fromFlagOrDefault _ (Flag x) = x -fromFlagOrDefault def NoFlag = def +fromFlagOrDefault def = fromMaybe def . getLast -- | Converts a 'Flag' value to a 'Maybe' value. flagToMaybe :: Flag a -> Maybe a -flagToMaybe (Flag x) = Just x -flagToMaybe NoFlag = Nothing +flagToMaybe = getLast -- | Pushes a function through a 'Flag' value, and returns a default -- if the 'Flag' value is 'NoFlag'. -- -- @since 3.4.0.0 flagElim :: b -> (a -> b) -> Flag a -> b -flagElim n _ NoFlag = n -flagElim _ f (Flag x) = f x +flagElim n f = maybe n f . getLast -- | Converts a 'Flag' value to a list. flagToList :: Flag a -> [a] -flagToList (Flag x) = [x] -flagToList NoFlag = [] +flagToList = maybeToList . getLast -- | Returns 'True' only if every 'Flag' 'Bool' value is Flag True, else 'False'. allFlags :: [Flag Bool] -> Flag Bool @@ -141,8 +110,7 @@ -- | Converts a 'Maybe' value to a 'Flag' value. maybeToFlag :: Maybe a -> Flag a -maybeToFlag Nothing = NoFlag -maybeToFlag (Just x) = Flag x +maybeToFlag = Last -- | Merge the elements of a list 'Flag' with another list 'Flag'. mergeListFlag :: Flag [a] -> Flag [a] -> Flag [a] diff --git a/src/Distribution/Simple/GHC.hs b/src/Distribution/Simple/GHC.hs --- a/src/Distribution/Simple/GHC.hs +++ b/src/Distribution/Simple/GHC.hs @@ -1,11 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -42,6 +42,8 @@ module Distribution.Simple.GHC ( getGhcInfo , configure + , configureCompiler + , compilerProgramDb , getInstalledPackages , getInstalledPackagesMonitorFiles , getPackageDBContents @@ -59,7 +61,6 @@ , hcPkgInfo , registerPackage , Internal.componentGhcOptions - , Internal.componentCcGhcOptions , getGhcAppDir , getLibDir , compilerBuildWay @@ -86,11 +87,10 @@ import Control.Arrow ((***)) import Control.Monad (forM_) -import Data.List (stripPrefix) import qualified Data.Map as Map +import Data.Maybe (fromJust) import Distribution.CabalSpecVersion import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import Distribution.Package import Distribution.PackageDescription as PD import Distribution.Pretty @@ -98,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 @@ -141,7 +142,7 @@ , doesDirectoryExist , doesFileExist , getAppUserDataDirectory - , getDirectoryContents + , listDirectory #ifndef mingw32_HOST_OS , renameFile #endif @@ -154,83 +155,62 @@ -- ----------------------------------------------------------------------------- -- Configuring +-- | Configure GHC, and then auxiliary programs such as @ghc-pkg@, @haddock@ +-- as well as toolchain programs such as @ar@, @ld. configure :: Verbosity -> Maybe FilePath + -- ^ user-specified @ghc@ path (optional) -> Maybe FilePath + -- ^ user-specified @ghc-pkg@ path (optional) -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) configure verbosity hcPath hcPkgPath conf0 = do + (comp, compPlatform, progdb1) <- configureCompiler verbosity hcPath conf0 + compProgDb <- compilerProgramDb verbosity comp progdb1 hcPkgPath + return (comp, compPlatform, compProgDb) + +-- | Configure GHC. +configureCompiler + :: Verbosity + -> Maybe FilePath + -- ^ user-specified @ghc@ path (optional) + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configureCompiler verbosity hcPath conf0 = do (ghcProg, ghcVersion, progdb1) <- requireProgramVersion verbosity ghcProgram (orLaterVersion (mkVersion [7, 0, 1])) (userMaybeSpecifyPath "ghc" hcPath conf0) - let implInfo = ghcVersionImplInfo ghcVersion - -- Cabal currently supports ghc >= 7.0.1 && < 9.14 - -- ... and the following odd development version - unless (ghcVersion < mkVersion [9, 14]) $ - warn verbosity $ + -- Cabal currently supports GHC less than `maxGhcVersion` + let maxGhcVersion = mkVersion [10, 2] + unless (ghcVersion < maxGhcVersion) $ + info verbosity $ "Unknown/unsupported 'ghc' version detected " ++ "(Cabal " ++ prettyShow cabalVersion - ++ " supports 'ghc' version < 9.14): " + ++ " supports 'ghc' version < " + ++ prettyShow maxGhcVersion + ++ "): " ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion - -- This is slightly tricky, we have to configure ghc first, then we use the - -- location of ghc to help find ghc-pkg in the case that the user did not - -- specify the location of ghc-pkg directly: - (ghcPkgProg, ghcPkgVersion, progdb2) <- - requireProgramVersion - verbosity - ghcPkgProgram - { programFindLocation = guessGhcPkgFromGhcPath ghcProg - } - anyVersion - (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1) - - when (ghcVersion /= ghcPkgVersion) $ - dieWithException verbosity $ - VersionMismatchGHC (programPath ghcProg) ghcVersion (programPath ghcPkgProg) ghcPkgVersion - -- Likewise we try to find the matching hsc2hs and haddock programs. - let hsc2hsProgram' = - hsc2hsProgram - { programFindLocation = guessHsc2hsFromGhcPath ghcProg - } - haddockProgram' = - haddockProgram - { programFindLocation = guessHaddockFromGhcPath ghcProg - } - hpcProgram' = - hpcProgram - { programFindLocation = guessHpcFromGhcPath ghcProg - } - runghcProgram' = - runghcProgram - { programFindLocation = guessRunghcFromGhcPath ghcProg - } - progdb3 = - addKnownProgram haddockProgram' $ - addKnownProgram hsc2hsProgram' $ - addKnownProgram hpcProgram' $ - addKnownProgram runghcProgram' progdb2 - - languages <- Internal.getLanguages verbosity implInfo ghcProg - extensions0 <- Internal.getExtensions verbosity implInfo ghcProg + let implInfo = ghcVersionImplInfo ghcVersion + languages <- Internal.getLanguages implInfo + extensions0 <- Internal.getExtensions verbosity ghcProg ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg + let ghcInfoMap = Map.fromList ghcInfo 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. @@ -247,9 +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 (Map.lookup "Project Unit Id" ghcInfoMap >>= stripPrefix (prettyShow compilerId <> "-")) + compilerAbiTag = + 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 @@ -258,12 +265,87 @@ , compilerLanguages = languages , compilerExtensions = extensions , compilerProperties = ghcInfoMap + , compilerWiredInUnitIds = wiredInUnitIds } compPlatform = Internal.targetPlatform ghcInfo - -- configure gcc and ld - progdb4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap progdb3 - return (comp, compPlatform, progdb4) + return (comp, compPlatform, progdb1) +-- | Given a configured @ghc@ program, configure auxiliary programs such +-- as @ghc-pkg@ or @haddock@, as well as toolchain programs such as @ar@, @ld@, +-- based on: +-- +-- - the location of the @ghc@ executable, +-- - toolchain information in the GHC settings file. +compilerProgramDb + :: Verbosity + -> Compiler + -> ProgramDb + -> Maybe FilePath + -- ^ user-specified @ghc-pkg@ path (optional) + -> IO ProgramDb +compilerProgramDb verbosity comp progdb1 hcPkgPath = do + -- Likewise we try to find the matching hsc2hs and haddock programs. + let hsc2hsProgram' = + hsc2hsProgram + { programFindLocation = guessHsc2hsFromGhcPath ghcProg + } + haddockProgram' = + haddockProgram + { programFindLocation = guessHaddockFromGhcPath ghcProg + } + hpcProgram' = + hpcProgram + { programFindLocation = guessHpcFromGhcPath ghcProg + } + runghcProgram' = + runghcProgram + { programFindLocation = guessRunghcFromGhcPath ghcProg + } + 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 + progdb3 = + Internal.configureToolchain + (ghcVersionImplInfo ghcVersion) + ghcProg + (compilerProperties comp) + 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 -- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking -- for a versioned or unversioned ghc-pkg in the same dir, that is: @@ -411,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 @@ -426,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. @@ -498,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' @@ -585,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 @@ -601,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 @@ -630,8 +687,10 @@ { 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. runGHC verbosity ghcProg comp platform Nothing replOpts -- ----------------------------------------------------------------------------- @@ -647,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 @@ -685,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 @@ -729,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 @@ -741,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 @@ -753,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 @@ -767,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 @@ -856,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'. @@ -868,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) @@ -880,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 @@ -889,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 @@ -903,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") @@ -914,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 @@ -924,7 +989,7 @@ | l <- getHSLibraryName (componentUnitId clbi) - : (extraBundledLibs (libBuildInfo lib)) + : extraBundledLibs (libBuildInfo lib) , f <- "" : extraLibFlavours (libBuildInfo lib) ] whenGHCi $ installOrdinary builtDir targetDir ghciLibName @@ -963,7 +1028,7 @@ ] sequence_ [ do - files <- getDirectoryContents (i builtDir) + files <- listDirectory (i builtDir) let l' = mkGenericSharedBundledLibName platform @@ -987,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 @@ -997,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) @@ -1023,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 @@ -1039,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,14 +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. @@ -39,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)) @@ -65,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)) @@ -72,7 +77,7 @@ buildCSources mbMainFile = buildExtraSources "C Sources" - Internal.componentCcGhcOptions + (Internal.splitCandCxxOptions Internal.CcProgram) ( \c -> do let cFiles = cSources (componentBuildInfo c) case c of @@ -85,7 +90,7 @@ buildCxxSources mbMainFile = buildExtraSources "C++ Sources" - Internal.componentCxxGhcOptions + (Internal.splitCandCxxOptions Internal.CxxProgram) ( \c -> do let cxxFiles = cxxSources (componentBuildInfo c) case c of @@ -95,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 @@ -113,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 @@ -130,7 +136,7 @@ buildExtraSources :: String -- ^ String describing the extra sources being built, for printing. - -> ( Verbosity + -> ( VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -139,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'@). @@ -154,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)) @@ -164,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 @@ -176,13 +183,23 @@ sources = viewSources (targetComponent targetInfo) comp = compiler lbi platform = hostPlatform lbi - runGhcProg = runGHC verbosity ghcProg comp platform + tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags buildingWhat + runGhcProg = + runGHCWithResponseFile + "ghc.rsp" + Nothing + tempFileOptions + verbosity + ghcProg + comp + platform + mbWorkDir buildAction :: SymbolicPath Pkg File -> IO () buildAction sourceFile = do let baseSrcOpts = componentSourceGhcOptions - verbosity + (verbosityLevel verbosity) lbi bi clbi @@ -219,7 +236,7 @@ compileIfNeeded :: GhcOptions -> IO () compileIfNeeded opts = do needsRecomp <- checkNeedsRecompilation mbWorkDir sourceFile opts - when needsRecomp $ runGhcProg mbWorkDir opts + when needsRecomp $ runGhcProg opts createDirectoryIfMissingVerbose verbosity True (i odir) case targetComponent targetInfo of @@ -251,8 +268,9 @@ DynWay -> compileIfNeeded sharedSrcOpts ProfWay -> compileIfNeeded profSrcOpts 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 @@ -1,22 +1,22 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} module Distribution.Simple.GHC.Build.Link where import Distribution.Compat.Prelude import Prelude () +import Control.Monad import Control.Monad.IO.Class import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.Set as Set +import Distribution.Backpack import Distribution.Compat.Binary (encode) import Distribution.Compat.ResponseFile import Distribution.InstalledPackageInfo (InstalledPackageInfo) 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) @@ -24,13 +24,19 @@ import Distribution.Simple.Build.Inputs import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler +import Distribution.Simple.Errors import Distribution.Simple.GHC.Build.Modules -import Distribution.Simple.GHC.Build.Utils (exeTargetName, flibBuildName, flibTargetName, withDynFLib) +import Distribution.Simple.GHC.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 @@ -49,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 @@ -65,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] @@ -83,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 @@ -98,6 +104,7 @@ clbi = buildCLBI pbci isIndef = componentIsIndefinite clbi mbWorkDir = mbWorkDirLBI lbi + tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags what -- See Note [Symbolic paths] in Distribution.Utils.Path i = interpretSymbolicPathLBI lbi @@ -107,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 ] @@ -118,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 @@ -139,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 } @@ -188,16 +190,32 @@ -- exports. when (case component of CLib lib -> null (allLibModules lib clbi); _ -> False) $ warn verbosity "No exposed modules" - runReplOrWriteFlags ghcProg lbi replFlags replOpts_final (pkgName (PD.package pkg_descr)) target + runReplOrWriteFlags + ghcProg + verbHandles + lbi + replFlags + replOpts_final + (pkgName (PD.package pkg_descr)) + target _otherwise -> let - runGhcProg = runGHC verbosity ghcProg comp platform mbWorkDir + runGhcProg = + runGHCWithResponseFile + "ghc.rsp" + Nothing + tempFileOptions + verbosity + ghcProg + comp + platform + mbWorkDir platform = hostPlatform lbi comp = compiler lbi get_rpaths ways = 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..." @@ -208,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) @@ -223,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 @@ -238,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 = @@ -261,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 @@ -286,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 @@ -325,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 @@ -367,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 @@ -393,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 @@ -415,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 @@ -439,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 @@ -452,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 @@ -488,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 @@ -505,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 @@ -551,7 +515,7 @@ linkOpts :: GhcOptions linkOpts = case foreignLibType flib of ForeignLibNativeShared -> - (buildOpts way) + buildOpts way `mappend` linkerOpts `mappend` rtsLinkOpts `mappend` mempty @@ -604,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 @@ -708,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 @@ -716,40 +680,64 @@ -- 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) comp = compiler lbi 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 -> runGHC verbosity ghcProg comp platform mbWorkDir ghcOpts + NoFlag -> do + -- If a specific GHC implementation is specified, use it + runReplProgram + (flagToMaybe $ replWithRepl (replReplOptions rflags)) + tempFileOptions + verbosity + ghcProg + comp + platform + mbWorkDir + ghcOpts Flag out_dir -> do let uid = componentUnitId clbi this_unit = prettyShow uid + getOpenModName (OpenModule _ mn) = Just mn + getOpenModName (OpenModuleVar{}) = Nothing reexported_modules = - [ mn | LibComponentLocalBuildInfo{componentExposedModules = exposed_mods} <- [clbi], IPI.ExposedModule mn (Just{}) <- exposed_mods + [ (from_mn, to_mn) | LibComponentLocalBuildInfo{componentExposedModules = exposed_mods} <- [clbi], IPI.ExposedModule to_mn (Just m) <- exposed_mods, Just from_mn <- [getOpenModName m] ] + renderReexportedModule (from_mn, to_mn) + | reexportedAsSupported comp = + pure $ prettyShow from_mn ++ " as " ++ prettyShow to_mn + | otherwise = + if from_mn == to_mn + then pure $ prettyShow to_mn + else dieWithException verbosity (MultiReplDoesNotSupportComplexReexportedModules pkg_name cname) hidden_modules = otherModules bi - extra_opts = - concat $ - [ ["-this-package-name", prettyShow pkg_name] - , case mbWorkDir of - Nothing -> [] - Just wd -> ["-working-dir", getSymbolicPath wd] - ] - ++ [ ["-reexported-module", prettyShow m] | m <- reexported_modules - ] - ++ [ ["-hidden-module", prettyShow m] | m <- hidden_modules - ] + render_extra_opts = do + rexp_mods <- mapM renderReexportedModule reexported_modules + pure $ + concat $ + [ ["-this-package-name", prettyShow pkg_name] + , case mbWorkDir of + Nothing -> [] + Just wd -> ["-working-dir", getSymbolicPath wd] + ] + ++ [ ["-reexported-module", m] | m <- rexp_mods + ] + ++ [ ["-hidden-module", prettyShow m] | m <- hidden_modules + ] -- Create "paths" subdirectory if it doesn't exist. This is where we write -- information about how the PATH was augmented. createDirectoryIfMissing False (out_dir "paths") @@ -757,6 +745,7 @@ writeFileAtomic (out_dir "paths" this_unit) (encode ghcProg) -- Write out options for this component into a file ready for loading into -- the multi-repl + extra_opts <- render_extra_opts writeFileAtomic (out_dir this_unit) $ BS.pack $ escapeArgs $ diff --git a/src/Distribution/Simple/GHC/Build/Modules.hs b/src/Distribution/Simple/GHC/Build/Modules.hs --- a/src/Distribution/Simple/GHC/Build/Modules.hs +++ b/src/Distribution/Simple/GHC/Build/Modules.hs @@ -1,14 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} module Distribution.Simple.GHC.Build.Modules ( buildHaskellModules , BuildWay (..) - , buildWayPrefix + , buildWayObjectExtension , componentInputs ) where @@ -24,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 @@ -43,6 +42,7 @@ import Distribution.Types.TestSuiteInterface import Distribution.Utils.NubList import Distribution.Utils.Path +import Distribution.Verbosity (VerbosityHandles, mkVerbosity, verbosityLevel) import System.FilePath () {- @@ -54,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. @@ -112,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) @@ -119,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 @@ -131,26 +133,38 @@ 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 | otherwise = False - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? FIX: what about exeName.hi-boot? + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? FIX: what about exeName.hi-boot? - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = if isLib then libCoverage lbi else exeCoverage lbi - hpcdir way - | forRepl = mempty -- HPC is not supported in ghci - | isCoverageEnabled = Flag $ Hpc.mixDir (coerceSymbolicPath $ coerceSymbolicPath buildTargetDir extraCompilationArtifacts) way - | otherwise = mempty + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + isCoverageEnabled = if isLib then libCoverage lbi else exeCoverage lbi + hpcdir way + | forRepl = mempty -- HPC is not supported in ghci + | isCoverageEnabled = Flag $ Hpc.mixDir (coerceSymbolicPath $ coerceSymbolicPath buildTargetDir extraCompilationArtifacts) way + | otherwise = mempty - let mbWorkDir = mbWorkDirLBI lbi - runGhcProg = runGHC verbosity ghcProg comp platform mbWorkDir + tempFileOptions = commonSetupTempFileOptions $ buildingWhatCommonFlags what + runGhcProg = + runGHCWithResponseFile + "ghc.rsp" + Nothing + tempFileOptions + verbosity + ghcProg + comp + platform + mbWorkDir platform = hostPlatform lbi (hsMains, scriptMains) = @@ -159,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, @@ -172,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) @@ -215,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) } @@ -232,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) @@ -247,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 = @@ -357,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) @@ -377,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 @@ -1,11 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} module Distribution.Simple.GHC.EnvironmentParser (parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc (..)) where +import Data.Functor (($>)) import Distribution.Compat.Prelude import Prelude () @@ -28,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 = @@ -37,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 @@ -19,12 +19,8 @@ , getExtensions , targetPlatform , getGhcInfo - , componentCcGhcOptions - , componentCmmGhcOptions - , componentCxxGhcOptions - , componentAsmGhcOptions - , componentJsGhcOptions , componentGhcOptions + , sourcesGhcOptions , mkGHCiLibName , mkGHCiProfLibName , filterGhciFlags @@ -34,6 +30,11 @@ , substTopDir , checkPackageDbEnvVar , profDetailLevelFlag + , ghcOptionsSince + , linkGhcOptions + , optimizationCFlags + , splitCandCxxOptions + , SplitSource (..) -- * GHC platform and version strings , ghcArchString @@ -58,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 (NoFlag), maybeToFlag, toFlag) +import Distribution.Simple.Flag import Distribution.Simple.GHC.ImplInfo import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program @@ -75,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, getTemporaryDirectory) +import System.Directory (listDirectory) import System.Environment (getEnv) import System.FilePath ( takeDirectory @@ -111,6 +115,11 @@ , programPostConf = configureGcc } . addKnownProgram + gppProgram + { programFindLocation = findProg gppProgramName extraGppPath + , programPostConf = configureGpp + } + . addKnownProgram ldProgram { programFindLocation = findProg ldProgramName extraLdPath , programPostConf = \v cp -> @@ -137,6 +146,7 @@ maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName) gccProgramName = maybeName gccProgram mbGccLocation + gppProgramName = maybeName gppProgram mbGppLocation ldProgramName = maybeName ldProgram mbLdLocation arProgramName = maybeName arProgram mbArLocation stripProgramName = maybeName stripProgram mbStripLocation @@ -149,18 +159,20 @@ mbDir = maybeToList . fmap takeDirectory $ mbPath extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir + extraGppPath = mkExtraPath mbGppLocation windowsExtraGppDir extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir extraArPath = mkExtraPath mbArLocation windowsExtraArDir extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir -- on Windows finding and configuring ghc's gcc & binutils is a bit special ( windowsExtraGccDir + , windowsExtraGppDir , windowsExtraLdDir , windowsExtraArDir , windowsExtraStripDir ) = let b = mingwBinDir binPrefix - in (b, b, b, b) + in (b, b, b, b, b) findProg :: String @@ -171,20 +183,20 @@ 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. mbGccLocation = Map.lookup "C compiler command" ghcInfo + mbGppLocation = Map.lookup "C++ compiler command" ghcInfo mbLdLocation = Map.lookup "ld command" ghcInfo mbArLocation = Map.lookup "ar command" ghcInfo mbStripLocation = Map.lookup "strip command" ghcInfo ccFlags = getFlags "C compiler flags" - -- 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" + cxxFlags = getFlags "C++ compiler 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 @@ -210,6 +222,15 @@ ++ gccLinkerFlags } + configureGpp :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureGpp _v gppProg = do + return + gppProg + { programDefaultArgs = + programDefaultArgs gppProg + ++ cxxFlags + } + configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureLd v ldProg = do ldProg' <- configureLd' v ldProg @@ -221,9 +242,8 @@ -- we need to find out if ld supports the -x flag configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram configureLd' verbosity ldProg = do - tempDir <- getTemporaryDirectory - ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> - withTempFile tempDir ".o" $ \testofile testohnd -> do + ldx <- withTempFile ".c" $ \testcfile testchnd -> + withTempFile ".o" $ \testofile testohnd -> do hPutStrLn testchnd "int foo() { return 0; }" hClose testchnd hClose testohnd @@ -236,7 +256,7 @@ , "-o" , testofile ] - withTempFile tempDir ".o" $ \testofile' testohnd' -> + withTempFile ".o" $ \testofile' testohnd' -> do hClose testohnd' _ <- @@ -252,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 @@ -271,12 +289,11 @@ , (Haskell2010, "-XHaskell2010") , (Haskell98, "-XHaskell98") ] - | supportsHaskell2010 implInfo = + | otherwise = return [ (Haskell98, "-XHaskell98") , (Haskell2010, "-XHaskell2010") ] - | otherwise = return [(Haskell98, "")] getGhcInfo :: Verbosity @@ -298,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 @@ -358,153 +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 + , 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] - , ghcOptCppIncludePath = includePaths lbi bi clbi odir - , ghcOptHideAllPackages = toFlag True - , ghcOptPackageDBs = withPackageDB lbi - , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi - , ghcOptObjDir = toFlag odir - } +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} -> @@ -539,31 +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 , 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 = @@ -578,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 = cmmOptions bi - , ghcOptObjDir = toFlag odir - } - -- | Strip out flags that are not supported in ghci filterGhciFlags :: [String] -> [String] filterGhciFlags = filter supported @@ -650,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 @@ -1,11 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} module Distribution.Simple.GHCJS ( getGhcInfo , configure + , configureCompiler + , compilerProgramDb , getInstalledPackages , getInstalledPackagesMonitorFiles , getPackageDBContents @@ -23,7 +24,6 @@ , hcPkgInfo , registerPackage , componentGhcOptions - , Internal.componentCcGhcOptions , getLibDir , isDynamic , getGlobalPackageDB @@ -61,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 @@ -81,19 +83,19 @@ 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 ((***)) import Control.Monad (msum) import Data.Char (isLower) import qualified Data.Map as Map +import Data.Maybe (fromJust) import System.Directory ( canonicalizePath , createDirectoryIfMissing , doesFileExist , getAppUserDataDirectory - , removeFile , renameFile ) import System.FilePath @@ -107,13 +109,29 @@ -- ----------------------------------------------------------------------------- -- Configuring +-- | Configure GHCJS, and then auxiliary programs such as @ghc-pkg@, @haddock@ +-- as well as toolchain programs such as @ar@, @ld. configure :: Verbosity -> Maybe FilePath + -- ^ user-specified @ghcjs@ path (optional) -> Maybe FilePath + -- ^ user-specified @ghcjs-pkg@ path (optional) -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) configure verbosity hcPath hcPkgPath conf0 = do + (comp, compPlatform, progdb1) <- configureCompiler verbosity hcPath conf0 + compProgDb <- compilerProgramDb verbosity comp progdb1 hcPkgPath + return (comp, compPlatform, compProgDb) + +-- | Configure GHCJS. +configureCompiler + :: Verbosity + -> Maybe FilePath + -- ^ user-specified @ghc@ path (optional) + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configureCompiler verbosity hcPath conf0 = do (ghcjsProg, ghcjsVersion, progdb1) <- requireProgramVersion verbosity @@ -134,6 +152,44 @@ let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion + languages <- Internal.getLanguages implInfo + extensions <- Internal.getExtensions verbosity ghcjsProg + + ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg + let ghcInfoMap = Map.fromList ghcjsInfo + + let comp = + Compiler + { compilerId = CompilerId GHCJS ghcjsVersion + , compilerAbiTag = + AbiTag $ + "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion) + , compilerCompat = [CompilerId GHC ghcjsGhcVersion] + , compilerLanguages = languages + , compilerExtensions = extensions + , compilerProperties = ghcInfoMap + , compilerWiredInUnitIds = Nothing + } + compPlatform = Internal.targetPlatform ghcjsInfo + return (comp, compPlatform, progdb1) + +-- | Given a configured @ghcjs@ program, configure auxiliary programs such +-- as @ghcjs-pkg@ or @haddock@, based on the location of the @ghcjs@ executable. +compilerProgramDb + :: Verbosity + -> Compiler + -> ProgramDb + -> Maybe FilePath + -- ^ user-specified @ghc-pkg@ path (optional) + -> IO ProgramDb +compilerProgramDb verbosity comp progdb1 hcPkgPath = do + let + ghcjsProg = fromJust $ lookupProgram ghcjsProgram progdb1 + ghcjsVersion = compilerVersion comp + ghcjsGhcVersion = case compilerCompat comp of + [CompilerId GHC ghcjsGhcVer] -> ghcjsGhcVer + compat -> error $ "could not parse ghcjsGhcVersion:" ++ show compat + -- This is slightly tricky, we have to configure ghc first, then we use the -- location of ghc to help find ghc-pkg in the case that the user did not -- specify the location of ghc-pkg directly: @@ -185,28 +241,9 @@ progdb3 = addKnownProgram haddockProgram' $ addKnownProgram hsc2hsProgram' $ - addKnownProgram hpcProgram' $ - {- addKnownProgram runghcProgram' -} progdb2 - - languages <- Internal.getLanguages verbosity implInfo ghcjsProg - extensions <- Internal.getExtensions verbosity implInfo ghcjsProg - - ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg - let ghcInfoMap = Map.fromList ghcjsInfo + addKnownProgram hpcProgram' {- addKnownProgram runghcProgram' -} progdb2 - let comp = - Compiler - { compilerId = CompilerId GHCJS ghcjsVersion - , compilerAbiTag = - AbiTag $ - "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion) - , compilerCompat = [CompilerId GHC ghcjsGhcVersion] - , compilerLanguages = languages - , compilerExtensions = extensions - , compilerProperties = ghcInfoMap - } - compPlatform = Internal.targetPlatform ghcjsInfo - return (comp, compPlatform, progdb3) + return progdb3 guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram @@ -348,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 @@ -500,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 @@ -539,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 = @@ -703,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) @@ -712,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 @@ -772,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 @@ -1205,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 @@ -1268,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 @@ -1281,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 = @@ -1437,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 @@ -1483,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 @@ -1538,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 @@ -1710,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 @@ -1739,7 +1728,7 @@ popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) popThreadedFlag bi = ( bi{options = filterHcOptions (/= "-threaded") (options bi)} - , hasThreaded (options bi) + , hasThreaded bi ) where filterHcOptions @@ -1749,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 @@ -1768,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 @@ -1808,7 +1794,7 @@ return (takeWhile (not . isSpace) hash) componentGhcOptions - :: Verbosity + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -1893,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" @@ -1911,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) @@ -2004,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 @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} @@ -60,6 +59,8 @@ import Distribution.Utils.Path import Distribution.Verbosity ( Verbosity + , defaultVerbosityHandles + , mkVerbosity , silent ) @@ -89,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 @@ -370,7 +371,6 @@ "Null dir passed to runDirFileGlob; interpreting it " ++ "as '.'. This is probably an internal error." let root = if null rawRoot then "." else rawRoot - debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'." -- This function might be called from the project root with dir as -- ".". Walking the tree starting there involves going into .git/ -- and dist-newstyle/, which is a lot of work for no reward, so @@ -379,7 +379,7 @@ -- the whole directory if *, and just the specific file if it's a -- literal. let - (prefixSegments, variablePattern) = splitConstantPrefix pat + (prefixSegments, pathOrVariablePattern) = splitConstantPrefix pat joinedPrefix = joinPath prefixSegments -- The glob matching function depends on whether we care about the cabal version or not @@ -389,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 @@ -420,7 +420,7 @@ ) entries go (GlobDir glob globPath) dir = do - entries <- getDirectoryContents (root dir) + entries <- listDirectory (root dir) subdirs <- filterM ( \subdir -> @@ -431,17 +431,34 @@ concat <$> traverse (\subdir -> go globPath (dir subdir)) subdirs go GlobDirTrailing dir = return [GlobMatch dir] - directoryExists <- doesDirectoryExist (root joinedPrefix) - if directoryExists - then go variablePattern joinedPrefix - else return [GlobMissingDirectory joinedPrefix] + case pathOrVariablePattern of + Left filename -> do + let filepath = joinedPrefix filename + debug verbosity $ "Treating glob as filepath literal '" ++ filepath ++ "' in directory '" ++ root ++ "'." + directoryExists <- doesDirectoryExist (root filepath) + if directoryExists + then pure [GlobMatchesDirectory filepath] + else do + exist <- doesFileExist (root filepath) + pure [GlobMatch filepath | exist] + Right variablePattern -> do + debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'." + directoryExists <- doesDirectoryExist (root joinedPrefix) + if directoryExists + then go variablePattern joinedPrefix + else return [GlobMissingDirectory joinedPrefix] where -- \| Extract the (possibly null) constant prefix from the pattern. -- This has the property that, if @(pref, final) = splitConstantPrefix pat@, -- then @pat === foldr GlobDir final pref@. - splitConstantPrefix :: Glob -> ([FilePath], Glob) - splitConstantPrefix = unfoldr' step + splitConstantPrefix :: Glob -> ([FilePath], Either FilePath Glob) + splitConstantPrefix = fmap literalize . unfoldr' step where + literalize (GlobFile [Literal filename]) = + Left filename + literalize glob = + Right glob + step (GlobDir [Literal seg] pat') = Right (seg, pat') step pat' = Left pat' diff --git a/src/Distribution/Simple/Glob/Internal.hs b/src/Distribution/Simple/Glob/Internal.hs --- a/src/Distribution/Simple/Glob/Internal.hs +++ b/src/Distribution/Simple/Glob/Internal.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- @@ -33,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 @@ -76,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,10 +2,10 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -41,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 @@ -56,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,16 +70,10 @@ import qualified Distribution.Simple.Program.HcPkg as HcPkg import Distribution.Simple.Program.ResponseFile import Distribution.Simple.Register -import Distribution.Simple.Setup.Common -import Distribution.Simple.Setup.Haddock -import Distribution.Simple.Setup.Hscolour -import Distribution.Simple.SetupHooks.Internal - ( BuildHooks (..) - , BuildingWhat (..) - , noBuildHooks - ) +import Distribution.Simple.Setup 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 @@ -91,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) @@ -231,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 _ _ @@ -250,21 +257,26 @@ && 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 + config = configFlags lbi quickJmpFlag = haddockQuickJump flags' flags = case haddockTarget of @@ -282,9 +294,7 @@ flag f = fromFlag $ f flags tmpFileOpts = - defaultTempFileOptions - { optKeepTempFiles = flag haddockKeepTempFiles - } + commonSetupTempFileOptions $ configCommonFlags config htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags @@ -312,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) @@ -335,14 +347,14 @@ 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 clbi = targetCLBI target bi = componentBuildInfo component -- Include any build-tool-depends on build tools internal to the current package. - progs' = addInternalBuildToolsFixed (Just curDir) pkg_descr lbi bi (withPrograms lbi) + progs' = addInternalBuildTools curDir pkg_descr lbi bi (withPrograms lbi) lbi' = lbi { withPrograms = progs' @@ -350,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 @@ -443,7 +445,7 @@ debug verbosity $ "Registering inplace:\n" - ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) + ++ InstalledPackageInfo.showInstalledPackageInfo ipi registerPackage verbosity @@ -534,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 @@ -542,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 @@ -554,9 +558,11 @@ -> IO () createHaddockIndex verbosity programDb comp platform mbWorkDir flags = do let args = fromHaddockProjectFlags flags + tmpFileOpts = + commonSetupTempFileOptions $ haddockProjectCommonFlags flags (haddockProg, _version) <- getHaddockProg verbosity programDb comp args (Flag True) - runHaddock verbosity mbWorkDir defaultTempFileOptions comp platform haddockProg False args + runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg False args -- ------------------------------------------------------------------------------ -- Contributions to HaddockArgs (see also Doctest.hs for very similar code). @@ -594,7 +600,7 @@ , argBaseUrl = haddockBaseUrl flags , argResourcesDir = haddockResourcesDir flags , argVerbose = - maybe mempty (Any . (>= deafening)) + maybe mempty (Any . (>= Deafening) . vLevel) . flagToMaybe $ setupVerbosity commonFlags , argOutput = @@ -621,13 +627,14 @@ , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags) , argLinkedSource = Flag True , argResourcesDir = haddockProjectResourcesDir flags + , argCssFile = haddockProjectCss flags } fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs 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 $ @@ -645,7 +652,7 @@ | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr) componentGhcOptions - :: Verbosity + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -708,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] @@ -1020,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 @@ -1066,21 +1073,27 @@ -> 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 ghcDir tmpDir = copyDirectoryRecursive verbosity (i $ fromFlag $ ghcDir vanillaOpts) (i tmpDir) + copyDir getGhcDir tmpDir = do + let ghcDir = i $ fromFlag $ getGhcDir vanillaOpts + ghcDirExists <- doesDirectoryExist ghcDir + -- Don't try to copy artifacts if they don't exist, e.g. if + -- we have not yet run the 'build' command. + when ghcDirExists $ + copyDirectoryRecursive verbosity ghcDir (i tmpDir) copyDir ghcOptObjDir tmpObjDir copyDir ghcOptHiDir tmpHiDir -- copyDir ghcOptStubDir tmpStubDir -- (see W.1 in Note [Hi Haddock Recompilation Avoidance]) 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) -- ------------------------------------------------------------------------------ @@ -1134,8 +1147,6 @@ withResponseFile verbosity tmpFileOpts - mbWorkDir - outputDir "haddock-response.txt" (if haddockSupportsUTF8 then Just utf8 else Nothing) renderedArgs @@ -1145,7 +1156,7 @@ (Flag pfile, _) -> withPrologueArgs ["--prologue=" ++ pfile] (_, Flag prologueText) -> - withTempFileEx tmpFileOpts mbWorkDir outputDir "haddock-prologue.txt" $ + withTempFileEx tmpFileOpts "haddock-prologue.txt" $ \prologueFileName h -> do when haddockSupportsUTF8 (hSetEncoding h utf8) hPutStrLn h prologueText @@ -1234,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 @@ -1248,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 @@ -1258,11 +1267,10 @@ [] ( (: []) . ("--title=" ++) - . ( bool - id - (++ " (internal documentation)") - (getAny $ argIgnoreExports args) - ) + . bool + id + (++ " (internal documentation)") + (getAny $ argIgnoreExports args) ) . flagToMaybe . argTitle @@ -1273,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 @@ -1310,13 +1318,7 @@ | otherwise -> "" ] - , if haddockSupportsVisibility - then - [ case visibility of - Visible -> "visible" - Hidden -> "hidden" - ] - else [] + , [case visibility of Visible -> "visible"; Hidden -> "hidden" | haddockSupportsVisibility] , [i] ] ) @@ -1367,7 +1369,7 @@ Just htmlPath -> do let hypSrcPath = htmlPath defaultHyperlinkedSourceDirectory hypSrcExists <- doesDirectoryExist hypSrcPath - return $ + return ( Just (fixFileUrl htmlPath) , if hypSrcExists then Just (fixFileUrl hypSrcPath) @@ -1384,9 +1386,9 @@ , pkgName pkgid `notElem` noHaddockWhitelist ] - let missing = [pkgid | Left pkgid <- interfaces] + let missing = lefts interfaces warning = - "The documentation for the following packages are not " + "The following packages have no Haddock documentation " ++ "installed. No links will be generated to these packages: " ++ intercalate ", " (map prettyShow missing) flags = rights interfaces @@ -1394,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 @@ -1473,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 @@ -1494,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 " @@ -1530,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 @@ -1555,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" @@ -1570,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/HaskellSuite.hs b/src/Distribution/Simple/HaskellSuite.hs deleted file mode 100644 --- a/src/Distribution/Simple/HaskellSuite.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Distribution.Simple.HaskellSuite where - -import Distribution.Compat.Prelude -import Prelude () - -import qualified Data.List.NonEmpty as NE - -import Distribution.InstalledPackageInfo hiding (includeDirs) -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Parsec (simpleParsec) -import Distribution.Pretty -import Distribution.Simple.BuildPaths -import Distribution.Simple.Compiler -import Distribution.Simple.Errors -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.Program -import Distribution.Simple.Program.Builtin -import Distribution.Simple.Utils -import Distribution.System (Platform) -import Distribution.Utils.Path -import Distribution.Verbosity -import Distribution.Version -import Language.Haskell.Extension - -configure - :: Verbosity - -> Maybe FilePath - -> Maybe FilePath - -> ProgramDb - -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity mbHcPath hcPkgPath progdb0 = do - -- We have no idea how a haskell-suite tool is named, so we require at - -- least some information from the user. - hcPath <- - let msg = "You have to provide name or path of a haskell-suite tool (-w PATH)" - in maybe (dieWithException verbosity $ ProvideHaskellSuiteTool msg) return mbHcPath - - when (isJust hcPkgPath) $ - warn verbosity "--with-hc-pkg option is ignored for haskell-suite" - - (comp, confdCompiler, progdb1) <- configureCompiler hcPath progdb0 - - -- Update our pkg tool. It uses the same executable as the compiler, but - -- all command start with "pkg" - (confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb1 - let progdb2 = - updateProgram - confdPkg - { programLocation = programLocation confdCompiler - , programDefaultArgs = ["pkg"] - } - progdb1 - - return (comp, Nothing, progdb2) - where - configureCompiler hcPath progdb0' = do - let - haskellSuiteProgram' = - haskellSuiteProgram - { programFindLocation = \v p -> findProgramOnSearchPath v p hcPath - } - - -- NB: cannot call requireProgram right away — it'd think that - -- the program is already configured and won't reconfigure it again. - -- Instead, call configureProgram directly first. - progdb1 <- configureProgram verbosity haskellSuiteProgram' progdb0' - (confdCompiler, progdb2) <- requireProgram verbosity haskellSuiteProgram' progdb1 - - extensions <- getExtensions verbosity confdCompiler - languages <- getLanguages verbosity confdCompiler - (compName, compVersion) <- - getCompilerVersion verbosity confdCompiler - - let - comp = - Compiler - { compilerId = CompilerId (HaskellSuite compName) compVersion - , compilerAbiTag = NoAbiTag - , compilerCompat = [] - , compilerLanguages = languages - , compilerExtensions = extensions - , compilerProperties = mempty - } - - return (comp, confdCompiler, progdb2) - -hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version) -hstoolVersion = findProgramVersion "--hspkg-version" id - -numericVersion :: Verbosity -> FilePath -> IO (Maybe Version) -numericVersion = findProgramVersion "--compiler-version" (fromMaybe "" . safeLast . words) - -getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version) -getCompilerVersion verbosity prog = do - output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"] - let - parts = words output - name = concat $ safeInit parts -- there shouldn't be any spaces in the name anyway - versionStr = fromMaybe "" $ safeLast parts - version <- - maybe - (dieWithException verbosity CannotDetermineCompilerVersion) - return - $ simpleParsec versionStr - return (name, version) - -getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe CompilerFlag)] -getExtensions verbosity prog = do - extStrs <- - lines - `fmap` rawSystemStdout verbosity (programPath prog) ["--supported-extensions"] - return - [(ext, Just $ "-X" ++ prettyShow ext) | Just ext <- map simpleParsec extStrs] - -getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, CompilerFlag)] -getLanguages verbosity prog = do - langStrs <- - lines - `fmap` rawSystemStdout verbosity (programPath prog) ["--supported-languages"] - return - [(ext, "-G" ++ prettyShow ext) | Just ext <- map simpleParsec langStrs] - --- Other compilers do some kind of a packagedb stack check here. Not sure --- if we need something like that as well. -getInstalledPackages - :: Verbosity - -- Not migrated to work with --working-dir but this is legacy dead code - -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) - -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity packagedbs progdb = - liftM (PackageIndex.fromList . concat) $ for packagedbs $ \packagedb -> - do - str <- - getDbProgramOutput - verbosity - haskellSuitePkgProgram - progdb - ["dump", packageDbOpt packagedb] - `catchExit` \_ -> dieWithException verbosity PkgDumpFailed - - case parsePackages str of - Right ok -> return ok - _ -> dieWithException verbosity FailedToParseOutput - where - parsePackages str = - case partitionEithers $ map (parseInstalledPackageInfo . toUTF8BS) (splitPkgs str) of - ([], ok) -> Right [pkg | (_, pkg) <- ok] - (msgss, _) -> Left (foldMap NE.toList msgss) - - splitPkgs :: String -> [String] - splitPkgs = map unlines . splitWith ("---" ==) . lines - where - splitWith :: (a -> Bool) -> [a] -> [[a]] - splitWith p xs = - ys : case zs of - [] -> [] - _ : ws -> splitWith p ws - where - (ys, zs) = break p xs - -buildLib - :: Verbosity - -> PackageDescription - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO () -buildLib verbosity pkg_descr lbi lib clbi = do - -- In future, there should be a mechanism for the compiler to request any - -- number of the above parameters (or their parts) — in particular, - -- pieces of PackageDescription. - -- - -- For now, we only pass those that we know are used. - - let odir = buildDir lbi - bi = libBuildInfo lib - srcDirs = map u (hsSourceDirs bi) ++ [u odir] - dbStack = withPackageDB lbi - language = fromMaybe Haskell98 (defaultLanguage bi) - progdb = withPrograms lbi - pkgid = packageId pkg_descr - u = interpretSymbolicPathCWD -- See Note [Symbolic paths] in Distribution.Utils.Path - runDbProgramCwd verbosity (mbWorkDirLBI lbi) haskellSuiteProgram progdb $ - ["compile", "--build-dir", u odir] - ++ concat [["-i", d] | d <- srcDirs] - ++ concat - [ ["-I", d] - | d <- - [ u $ autogenComponentModulesDir lbi clbi - , u $ autogenPackageModulesDir lbi - , u odir - ] - ++ map u (includeDirs bi) - ] - ++ [packageDbOpt pkgDb | pkgDb <- dbStack] - ++ ["--package-name", prettyShow pkgid] - ++ concat - [ ["--package-id", prettyShow ipkgid] - | (ipkgid, _) <- componentPackageDeps clbi - ] - ++ ["-G", prettyShow language] - ++ concat [["-X", prettyShow ex] | ex <- usedExtensions bi] - ++ cppOptions (libBuildInfo lib) - ++ [prettyShow modu | modu <- allLibModules lib clbi] - -installLib - :: Verbosity - -> LocalBuildInfo - -> FilePath - -- ^ install location - -> FilePath - -- ^ install location for dynamic libraries - -> FilePath - -- ^ Build location - -> PackageDescription - -> Library - -> ComponentLocalBuildInfo - -> IO () -installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib clbi = do - let progdb = withPrograms lbi - wdir = mbWorkDirLBI lbi - runDbProgramCwd verbosity wdir haskellSuitePkgProgram progdb $ - [ "install-library" - , "--build-dir" - , builtDir - , "--target-dir" - , targetDir - , "--dynlib-target-dir" - , dynlibTargetDir - , "--package-id" - , prettyShow $ packageId pkg - ] - ++ map prettyShow (allLibModules lib clbi) - -registerPackage - :: Verbosity - -> ProgramDb - -> PackageDBStackS from - -> InstalledPackageInfo - -> IO () -registerPackage verbosity progdb packageDbs installedPkgInfo = do - (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb - - runProgramInvocation verbosity $ - ( programInvocation - hspkg - ["update", packageDbOpt $ registrationPackageDB packageDbs] - ) - { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo - } - -initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO () -initPackageDB verbosity progdb dbPath = - runDbProgram - verbosity - haskellSuitePkgProgram - progdb - ["init", dbPath] - -packageDbOpt :: PackageDBX (SymbolicPath from (Dir PkgDB)) -> String -packageDbOpt GlobalPackageDB = "--global" -packageDbOpt UserPackageDB = "--user" -packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ interpretSymbolicPathCWD db diff --git a/src/Distribution/Simple/Install.hs b/src/Distribution/Simple/Install.hs --- a/src/Distribution/Simple/Install.hs +++ b/src/Distribution/Simple/Install.hs @@ -74,7 +74,6 @@ import Distribution.Simple.Errors import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.HaskellSuite as HaskellSuite import Distribution.Simple.Setup.Common import qualified Distribution.Simple.UHC as UHC @@ -105,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 @@ -118,6 +118,7 @@ -> IO () install_setupHooks (InstallHooks{installComponentHook}) + verbHandles pkg_descr lbi flags = do @@ -142,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 = @@ -233,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 @@ -246,19 +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 - HaskellSuite _ -> - HaskellSuite.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 @@ -296,7 +288,7 @@ ++ binPref ) inPath <- isInSearchPath binPref - when (not inPath) $ + unless inPath $ warn verbosity ( "The directory " @@ -307,7 +299,6 @@ GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe UHC -> return () - HaskellSuite{} -> return () _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) @@ -377,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 -} -#ifdef x86_64_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 @@ -1,8 +1,6 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -288,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) @@ -322,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 @@ -475,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 @@ -67,6 +67,7 @@ , lookupSourcePackageId , lookupPackageId , lookupPackageName + , lookupInternalPackageName , lookupDependency , lookupInternalDependency @@ -92,6 +93,10 @@ , dependencyCycles , dependencyGraph , moduleNameIndex + + -- ** Filters on lookup results + , eligibleDependencies + , matchingDependencies ) where import qualified Data.Map.Strict as Map @@ -179,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 @@ -364,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) -} -- @@ -454,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. @@ -473,10 +476,19 @@ -> [(Version, [a])] lookupPackageName index name = -- Do not match internal libraries - case Map.lookup (name, LMainLibName) (packageIdIndex index) of - Nothing -> [] - Just pvers -> Map.toList pvers + lookupInternalPackageName index name LMainLibName +-- | Does a lookup by source package name and library name. +-- +-- Also looks up internal packages. +lookupInternalPackageName + :: PackageIndex a + -> PackageName + -> LibraryName + -> [(Version, [a])] +lookupInternalPackageName index name library = + maybe [] Map.toList (Map.lookup (name, library) (packageIdIndex index)) + -- | Does a lookup by source package name and a range of versions. -- -- We get back any number of versions of the specified package name, all @@ -508,25 +520,48 @@ -> LibraryName -> [(Version, [IPI.InstalledPackageInfo])] lookupInternalDependency index name versionRange libn = - case Map.lookup (name, libn) (packageIdIndex index) of - Nothing -> [] - Just pvers -> - [ (ver, pkgs') - | (ver, pkgs) <- Map.toList pvers - , ver `withinRange` versionRange - , let pkgs' = filter eligible pkgs - , -- Enforce the invariant - not (null pkgs') - ] + matchingDependencies versionRange $ + lookupInternalPackageName index name libn + +-- | Filter a set of installed packages to ones eligible as dependencies. +-- +-- When we select for dependencies, we ONLY want to pick up indefinite +-- packages, or packages with no instantiations. We'll do mix-in linking to +-- improve any such package into an instantiated one later. +-- +-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. +eligibleDependencies + :: [(Version, [IPI.InstalledPackageInfo])] + -> [(Version, [IPI.InstalledPackageInfo])] +eligibleDependencies versions = + [ (ver, pkgs') + | (ver, pkgs) <- versions + , let pkgs' = filter eligible pkgs + , -- Enforce the invariant + not (null pkgs') + ] where - -- When we select for dependencies, we ONLY want to pick up indefinite - -- packages, or packages with no instantiations. We'll do mix-in - -- linking to improve any such package into an instantiated one - -- later. eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg) +-- | Get eligible dependencies from a list of versions. -- +-- This can be used to filter the output of 'lookupPackageName' or +-- 'lookupInternalPackageName'. +-- +-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. +matchingDependencies + :: VersionRange + -> [(Version, [IPI.InstalledPackageInfo])] + -> [(Version, [IPI.InstalledPackageInfo])] +matchingDependencies versionRange versions = + let eligibleVersions = eligibleDependencies versions + in [ (ver, pkgs) + | (ver, pkgs) <- eligibleVersions + , ver `withinRange` versionRange + ] +-- + -- * Case insensitive name lookups -- @@ -628,7 +663,7 @@ :: InstalledPackageIndex -> [UnitId] -> Either - (InstalledPackageIndex) + InstalledPackageIndex [(IPI.InstalledPackageInfo, [UnitId])] dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of (completed, []) -> Left completed @@ -695,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 @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -36,7 +35,6 @@ , runSimplePreProcessor , ppCpp , ppCpp' - , ppGreenCard , ppC2hs , ppHsc2hs , ppHappy @@ -259,7 +257,7 @@ (coerceSymbolicPath outputDir : hsSourceDirs bi) outputDir isSrcDist - (dropExtensionsSymbolicPath $ exePath) + (dropExtensionsSymbolicPath exePath) verbosity builtinSuffixes biHandlers @@ -347,8 +345,8 @@ createDirectoryIfMissingVerbose verbosity True destDir runPreProcessorWithHsBootHack pp - (getSymbolicPath $ psrcLoc, getSymbolicPath $ psrcRelFile) - (getSymbolicPath $ buildLoc, srcStem <.> "hs") + (psrcLoc, getSymbolicPath psrcRelFile) + (buildLoc, srcStem <.> "hs") where i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path buildAsSrcLoc :: SymbolicPath Pkg (Dir Source) @@ -363,20 +361,25 @@ pp (inBaseDir, inRelativeFile) (outBaseDir, outRelativeFile) = do + -- Preprocessors are expected to take into account the working + -- directory, e.g. using runProgramCwd with a working directory + -- computed with mbWorkDirLBI. + -- Hence the use of 'getSymbolicPath' here. runPreProcessor pp - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) + (getSymbolicPath inBaseDir, inRelativeFile) + (getSymbolicPath outBaseDir, outRelativeFile) verbosity - exists <- doesFileExist inBoot - when exists $ copyFileVerbose verbosity inBoot outBoot - where + -- Here we interact directly with the file system, so we must + -- interpret symbolic paths with respect to the working directory. + let + inFile = normalise (i inBaseDir inRelativeFile) + outFile = normalise (i outBaseDir outRelativeFile) inBoot = replaceExtension inFile "hs-boot" outBoot = replaceExtension outFile "hs-boot" - - inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) + exists <- doesFileExist inBoot + when exists $ copyFileVerbose verbosity inBoot outBoot -- ------------------------------------------------------------ @@ -384,20 +387,6 @@ -- ------------------------------------------------------------ -ppGreenCard :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppGreenCard _ lbi _ = - PreProcessor - { platformIndependent = False - , ppOrdering = unsorted - , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - runDbProgramCwd - verbosity - (mbWorkDirLBI lbi) - greencardProgram - (withPrograms lbi) - (["-tffi", "-o" ++ outFile, inFile]) - } - -- This one is useful for preprocessors that can't handle literate source. -- We also need a way to chain preprocessors. ppUnlit :: PreProcessor @@ -476,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 @@ -511,8 +497,6 @@ withResponseFile verbosity defaultTempFileOptions - mbWorkDir - (makeSymbolicPath $ takeDirectory outFile) "hsc2hs-response.txt" Nothing pureArgs @@ -531,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, @@ -763,10 +750,6 @@ ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr - HaskellSuite{} -> - ["-D__HASKELL_SUITE__"] - ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr - ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr _ -> [] where comp = compiler lbi @@ -811,7 +794,7 @@ Android -> ["android"] Ghcjs -> ["ghcjs"] Wasi -> ["wasi"] - Hurd -> ["hurd"] + Hurd -> ["gnu"] Haiku -> ["haiku"] OtherOS _ -> [] archStr = case hostArch of @@ -876,11 +859,10 @@ ppSuffixes :: [PPSuffixHandler] -> [Suffix] ppSuffixes = map fst --- | Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. +-- | Standard preprocessors: c2hs, hsc2hs, happy, alex and cpphs. knownSuffixHandlers :: [PPSuffixHandler] knownSuffixHandlers = - [ (Suffix "gc", ppGreenCard) - , (Suffix "chs", ppC2hs) + [ (Suffix "chs", ppC2hs) , (Suffix "hsc", ppHsc2hs) , (Suffix "x", ppAlex) , (Suffix "y", ppHappy) diff --git a/src/Distribution/Simple/PreProcess/Types.hs b/src/Distribution/Simple/PreProcess/Types.hs --- a/src/Distribution/Simple/PreProcess/Types.hs +++ b/src/Distribution/Simple/PreProcess/Types.hs @@ -44,11 +44,12 @@ -- > ppTestHandler = -- > PreProcessor { -- > platformIndependent = True, +-- > ppOrdering = \_ _ -> return, -- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> -- > do info verbosity (inFile++" has been preprocessed to "++outFile) -- > stuff <- readFile inFile -- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) --- > return ExitSuccess +-- > return () -- -- We split the input and output file names into a base directory and the -- rest of the file name. The input base dir is the path in the list of search diff --git a/src/Distribution/Simple/Program.hs b/src/Distribution/Simple/Program.hs --- a/src/Distribution/Simple/Program.hs +++ b/src/Distribution/Simple/Program.hs @@ -111,10 +111,10 @@ , ghcPkgProgram , ghcjsProgram , ghcjsPkgProgram - , hmakeProgram , jhcProgram , uhcProgram , gccProgram + , gppProgram , arProgram , stripProgram , happyProgram @@ -125,7 +125,6 @@ , hscolourProgram , doctestProgram , haddockProgram - , greencardProgram , ldProgram , tarProgram , cppProgram diff --git a/src/Distribution/Simple/Program/Ar.hs b/src/Distribution/Simple/Program/Ar.hs --- a/src/Distribution/Simple/Program/Ar.hs +++ b/src/Distribution/Simple/Program/Ar.hs @@ -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 @@ -154,7 +154,7 @@ (initial, middle, final) (map getSymbolicPath files) ] - else withResponseFile verbosity defaultTempFileOptions mbWorkDir tmpDir "ar.rsp" Nothing (map getSymbolicPath files) $ + else withResponseFile verbosity defaultTempFileOptions "ar.rsp" Nothing (map getSymbolicPath files) $ \path -> runProgramInvocation verbosity $ invokeWithResponseFile path unless @@ -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 @@ -20,12 +20,10 @@ , runghcProgram , ghcjsProgram , ghcjsPkgProgram - , hmakeProgram , jhcProgram - , haskellSuiteProgram - , haskellSuitePkgProgram , uhcProgram , gccProgram + , gppProgram , arProgram , stripProgram , happyProgram @@ -36,7 +34,6 @@ , hscolourProgram , doctestProgram , haddockProgram - , greencardProgram , ldProgram , tarProgram , cppProgram @@ -64,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] @@ -74,9 +74,6 @@ , ghcPkgProgram , ghcjsProgram , ghcjsPkgProgram - , haskellSuiteProgram - , haskellSuitePkgProgram - , hmakeProgram , jhcProgram , uhcProgram , hpcProgram @@ -89,7 +86,6 @@ , hsc2hsProgram , c2hsProgram , cpphsProgram - , greencardProgram , -- platform toolchain gccProgram , arProgram @@ -104,33 +100,27 @@ ghcProgram = (simpleProgram "ghc") { programFindVersion = findProgramVersion "--numeric-version" id - , -- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/8825 - -- (spurious warning on non-english locales) - programPostConf = \_verbosity ghcProg -> - do - let ghcProg' = - ghcProg - { programOverrideEnv = - ("LANGUAGE", Just "en") - : programOverrideEnv ghcProg - } - -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4. - affectedVersionRange = - intersectVersionRanges - (laterVersion $ mkVersion [7, 8, 0]) - (earlierVersion $ mkVersion [7, 8, 4]) - return $ - maybe - ghcProg - ( \v -> - if withinRange v affectedVersionRange - then ghcProg' - else ghcProg - ) - (programVersion ghcProg) + , programPostConf = ghcPostConf , programNormaliseArgs = normaliseGhcArgs } + where + ghcPostConf _verbosity ghcProg = do + let ignorePackageEnv prog = prog{programDefaultArgs = "-package-env=-" : programDefaultArgs prog} + canIgnorePackageEnv = orLaterVersion $ mkVersion [8, 4, 4] + + applyWhen cond f prog = if cond then f prog else prog + + return $ + maybe + ghcProg + ( \v -> + -- By default, ignore GHC_ENVIRONMENT variable of any package environment + -- files. See #10759 + applyWhen (withinRange v canIgnorePackageEnv) ignorePackageEnv ghcProg + ) + (programVersion ghcProg) + runghcProgram :: Program runghcProgram = (simpleProgram "runghc") @@ -170,17 +160,6 @@ _ -> "" } -hmakeProgram :: Program -hmakeProgram = - (simpleProgram "hmake") - { programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "hmake --version" gives a string line - -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" - case words str of - (_ : ver : _) -> ver - _ -> "" - } - jhcProgram :: Program jhcProgram = (simpleProgram "jhc") @@ -208,32 +187,6 @@ _ -> "" } --- This represents a haskell-suite compiler. Of course, the compiler --- itself probably is not called "haskell-suite", so this is not a real --- program. (But we don't know statically the name of the actual compiler, --- so this is the best we can do.) --- --- Having this Program value serves two purposes: --- --- 1. We can accept options for the compiler in the form of --- --- --haskell-suite-option(s)=... --- --- 2. We can find a program later using this static id (with --- requireProgram). --- --- The path to the real compiler is found and recorded in the ProgramDb --- during the configure phase. -haskellSuiteProgram :: Program -haskellSuiteProgram = - simpleProgram "haskell-suite" - --- This represent a haskell-suite package manager. See the comments for --- haskellSuiteProgram. -haskellSuitePkgProgram :: Program -haskellSuitePkgProgram = - simpleProgram "haskell-suite-pkg" - happyProgram :: Program happyProgram = (simpleProgram "happy") @@ -262,6 +215,13 @@ { programFindVersion = findProgramVersion "-dumpversion" id } +gppProgram :: Program +gppProgram = + (simpleProgram "gpp") + { programFindVersion = findProgramVersion "-dumpversion" id + , programFindLocation = \v p -> findProgramOnSearchPath v p "g++" + } + arProgram :: Program arProgram = simpleProgram "ar" @@ -269,7 +229,10 @@ stripProgram = (simpleProgram "strip") { programFindVersion = \verbosity -> - findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity) + findProgramVersion + "--version" + stripExtractVersion + (modifyVerbosityFlags lessVerbose verbosity) } hsc2hsProgram :: Program @@ -335,9 +298,6 @@ , programNormaliseArgs = \_ _ args -> args } -greencardProgram :: Program -greencardProgram = simpleProgram "greencard" - ldProgram :: Program ldProgram = (simpleProgram "ld") @@ -392,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 @@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -48,7 +46,7 @@ import Distribution.System import Distribution.Verbosity -import qualified System.Directory as Directory +import System.Directory ( findExecutable ) import System.FilePath as FilePath @@ -206,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,21 +1,24 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} module Distribution.Simple.Program.GHC ( GhcOptions (..) , GhcMode (..) , GhcOptimisation (..) , GhcDynLinkMode (..) + , GhcObjectMode (..) , GhcProfAuto (..) , ghcInvocation , renderGhcOptions , runGHC + , runGHCWithResponseFile + , runReplProgram , packageDbArgsDb , normaliseGhcArgs ) where @@ -23,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 @@ -32,8 +35,10 @@ import Distribution.Simple.Flag import Distribution.Simple.GHC.ImplInfo import Distribution.Simple.Program.Find (getExtraPathEnv) +import Distribution.Simple.Program.ResponseFile import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types +import Distribution.Simple.Utils (TempFileOptions, infoNoWrap) import Distribution.System import Distribution.Types.ComponentId import Distribution.Types.ParStrat @@ -42,17 +47,19 @@ import Distribution.Verbosity import Distribution.Version +import GHC.IO.Encoding (TextEncoding) import Language.Haskell.Extension import Data.List (stripPrefix) import qualified Data.Map as Map import Data.Monoid (All (..), Any (..), Endo (..)) import qualified Data.Set as Set +import qualified System.Process as Process normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String] normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs | ghcVersion `withinRange` supportedGHCVersions = - argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs + argumentFilters . filter simpleFilters . filterRtsArgs $ ghcArgs where supportedGHCVersions :: VersionRange supportedGHCVersions = orLaterVersion (mkVersion [8, 0]) @@ -141,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 [] = [] @@ -157,24 +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" + ] - filterRtsOpts :: [String] -> [String] - filterRtsOpts = go False - where - go :: Bool -> [String] -> [String] - go _ [] = [] - go _ ("+RTS" : opts) = go True opts - go _ ("-RTS" : opts) = go False opts - go isRTSopts (opt : opts) = addOpt $ go isRTSopts opts - where - addOpt - | isRTSopts = id - | otherwise = (opt :) + -- \| Remove RTS arguments from a list. + filterRtsArgs :: [String] -> [String] + filterRtsArgs = snd . splitRTSArgs + -- 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 @@ -185,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" @@ -368,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 = @@ -442,6 +453,8 @@ -- the @ghc -i@ flag (@-i@ on its own with no path argument). , ghcOptSourcePath :: NubListR (SymbolicPath Pkg (Dir Source)) -- ^ Search path for Haskell source files; the @ghc -i@ flag. + , ghcOptUnitFiles :: [FilePath] + -- ^ Unit files to load; the @ghc -unit@ flag. , ------------- -- Packages @@ -510,6 +523,8 @@ -- ^ Options to pass through to the Assembler. , ghcOptCppOptions :: [String] -- ^ Options to pass through to CPP; the @ghc -optP@ flag. + , ghcOptJSppOptions :: [String] + -- ^ Options to pass through to CPP; the @ghc -optJSP@ flag. @since 3.16.0.0 , ghcOptCppIncludePath :: NubListR (SymbolicPath Pkg (Dir Include)) -- ^ Search path for CPP includes like header files; the @ghc -I@ flag. , ghcOptCppIncludes :: NubListR (SymbolicPath Pkg File) @@ -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 @@ -647,6 +676,69 @@ runProgramInvocation verbosity =<< ghcInvocation verbosity ghcProg comp platform mbWorkDir opts +runGHCWithResponseFile + :: FilePath + -> Maybe TextEncoding + -> TempFileOptions + -> Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> GhcOptions + -> IO () +runGHCWithResponseFile fileNameTemplate encoding tempFileOptions verbosity ghcProg comp platform maybeWorkDir opts = do + invocation <- ghcInvocation verbosity ghcProg comp platform maybeWorkDir opts + + let compilerSupportsResponseFiles = + case compilerCompatVersion GHC comp of + -- GHC 9.4 is the first version which supports response files. + Just version -> version >= mkVersion [9, 4] + Nothing -> False + + args = progInvokeArgs invocation + + if not compilerSupportsResponseFiles + then runProgramInvocation verbosity invocation + else do + let (rtsArgs, otherArgs) = splitRTSArgs args + + withResponseFile + verbosity + tempFileOptions + fileNameTemplate + encoding + otherArgs + $ \responseFile -> do + let newInvocation = + invocation{progInvokeArgs = ('@' : responseFile) : rtsArgs} + + infoNoWrap verbosity $ + "GHC response file arguments: " + <> case otherArgs of + [] -> "" + arg : args' -> Process.showCommandForUser arg args' + + runProgramInvocation verbosity newInvocation + +-- Start the repl. Either use `ghc`, or the program specified by the --with-repl flag. +runReplProgram + :: Maybe FilePath + -- ^ --with-repl argument + -> TempFileOptions + -> Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> GhcOptions + -> IO () +runReplProgram withReplProg tempFileOptions verbosity ghcProg comp platform mbWorkDir ghcOpts = + let replProg = case withReplProg of + Just path -> ghcProg{programLocation = FoundOnSystem path} + Nothing -> ghcProg + in runGHCWithResponseFile "ghci.rsp" Nothing tempFileOptions verbosity replProg comp platform mbWorkDir ghcOpts + ghcInvocation :: Verbosity -> ConfiguredProgram @@ -720,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 @@ -744,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 [] , -------------------- @@ -755,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] , ------------------------ @@ -773,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 @@ -786,18 +876,21 @@ ["-I" ++ u dir | dir <- flags ghcOptCppIncludePath] , ["-optP" ++ opt | opt <- ghcOptCppOptions opts] + , ["-optJSP" ++ opt | opt <- ghcOptJSppOptions opts] , concat [ ["-optP-include", "-optP" ++ u inc] | inc <- flags ghcOptCppIncludes ] , ["-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 @@ -841,8 +934,8 @@ , if null (ghcOptInstantiatedWith opts) then [] else - "-instantiated-with" - : intercalate + [ "-instantiated-with" + , intercalate "," ( map ( \(n, m) -> @@ -852,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 @@ -867,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 @@ -885,7 +976,7 @@ -- GHCi concat - [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts, flagGhciScript implInfo + [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts ] , --------------- -- Inputs @@ -897,6 +988,8 @@ , [prettyShow modu | modu <- flags ghcOptInputModules] , concat [["-o", u out] | out <- flag ghcOptOutputFile] , concat [["-dyno", out] | out <- flag ghcOptOutputDynFile] + , -- unit files + concat [["-unit", "@" ++ unit] | unit <- ghcOptUnitFiles opts] , --------------- -- Extra @@ -912,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) @@ -955,10 +1030,25 @@ 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. +splitRTSArgs :: [String] -> ([String], [String]) +splitRTSArgs args = + let addRTSArg arg ~(rtsArgs, nonRTSArgs) = (arg : rtsArgs, nonRTSArgs) + addNonRTSArg arg ~(rtsArgs, nonRTSArgs) = (rtsArgs, arg : nonRTSArgs) + + go _ [] = ([], []) + go isRTSArg (arg : rest) = + case arg of + "+RTS" -> addRTSArg arg $ go True rest + "-RTS" -> addRTSArg arg $ go False rest + "--RTS" -> ([arg], rest) + "--" -> ([], arg : rest) + _ -> + if isRTSArg + then addRTSArg arg $ go isRTSArg rest + else addNonRTSArg arg $ go isRTSArg rest + in go False args -- ----------------------------------------------------------------------------- -- Boilerplate Monoid instance for GhcOptions diff --git a/src/Distribution/Simple/Program/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 @@ -17,21 +17,28 @@ -- | Extract the version number from the output of 'strip --version'. -- --- Invoking "strip --version" gives very inconsistent results. We ignore --- everything in parentheses (see #2497), look for the first word that starts --- with a number, and try parsing out the first two components of it. Non-GNU --- 'strip' doesn't appear to have a version flag. +-- Invoking "strip --version" gives very inconsistent results. We +-- ignore everything in parentheses (see #2497), look for the first +-- word that starts with a number, and try parsing out the first two +-- components of it. Non-GNU, non-LLVM 'strip' doesn't appear to have +-- a version flag. stripExtractVersion :: String -> String stripExtractVersion str = let numeric "" = False numeric (x : _) = isDigit x + closingParentheses = + [ ")" + , -- LLVM strip outputs "llvm-strip, compatible with GNU strip\nLLVM (http://llvm.org/):\n..." + "):" + ] + -- Filter out everything in parentheses. filterPar' :: Int -> [String] -> [String] filterPar' _ [] = [] filterPar' n (x : xs) - | n >= 0 && "(" `isPrefixOf` x = filterPar' (n + 1) ((safeTail x) : xs) - | n > 0 && ")" `isSuffixOf` x = filterPar' (n - 1) xs + | n >= 0 && "(" `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/Ld.hs b/src/Distribution/Simple/Program/Ld.hs --- a/src/Distribution/Simple/Program/Ld.hs +++ b/src/Distribution/Simple/Program/Ld.hs @@ -83,8 +83,6 @@ middle = ld middleArgs final = ld finalArgs - targetDir = takeDirectorySymbolicPath target - invokeWithResponseFile :: FilePath -> ProgramInvocation invokeWithResponseFile atFile = ld $ simpleArgs ++ ['@' : atFile] @@ -106,7 +104,7 @@ if oldVersionManualOverride || responseArgumentsNotSupported then run $ multiStageProgramInvocation simple (initial, middle, final) (map getSymbolicPath files) - else withResponseFile verbosity defaultTempFileOptions mbWorkDir targetDir "ld.rsp" Nothing (map getSymbolicPath files) $ + else withResponseFile verbosity defaultTempFileOptions "ld.rsp" Nothing (map getSymbolicPath files) $ \path -> runProgramInvocation verbosity $ invokeWithResponseFile path where tmpfile = target <.> "tmp" -- perhaps should use a proper temp file diff --git a/src/Distribution/Simple/Program/ResponseFile.hs b/src/Distribution/Simple/Program/ResponseFile.hs --- a/src/Distribution/Simple/Program/ResponseFile.hs +++ b/src/Distribution/Simple/Program/ResponseFile.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} ---------------------------------------------------------------------------- @@ -27,10 +26,6 @@ withResponseFile :: Verbosity -> TempFileOptions - -> Maybe (SymbolicPath CWD (Dir Pkg)) - -- ^ Working directory - -> SymbolicPath Pkg (Dir Response) - -- ^ Directory to create response file in. -> String -- ^ Template for response file name. -> Maybe TextEncoding @@ -39,14 +34,13 @@ -- ^ Arguments to put into response file. -> (FilePath -> IO a) -> IO a -withResponseFile verbosity tmpFileOpts mbWorkDir responseDir fileNameTemplate encoding arguments f = - withTempFileEx tmpFileOpts mbWorkDir responseDir fileNameTemplate $ \responsePath hf -> do +withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f = + withTempFileEx tmpFileOpts fileNameTemplate $ \responsePath hf -> do let responseFileName = getSymbolicPath responsePath traverse_ (hSetEncoding hf) encoding let responseContents = 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 @@ -3,7 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -62,6 +61,7 @@ , progInvokeInputEncoding :: IOEncoding -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. , progInvokeOutputEncoding :: IOEncoding + , progInvokeWhen :: IO Bool } data IOEncoding @@ -83,6 +83,7 @@ , progInvokeInput = Nothing , progInvokeInputEncoding = IOEncodingText , progInvokeOutputEncoding = IOEncodingText + , progInvokeWhen = pure True } simpleProgramInvocation @@ -129,8 +130,7 @@ , progInvokeEnv = [] , progInvokeCwd = Nothing , progInvokeInput = Nothing - } = - rawSystemExit verbosity Nothing path args + } = rawSystemExit verbosity Nothing path args runProgramInvocation verbosity ProgramInvocation @@ -261,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/Program/Types.hs b/src/Distribution/Simple/Program/Types.hs --- a/src/Distribution/Simple/Program/Types.hs +++ b/src/Distribution/Simple/Program/Types.hs @@ -142,7 +142,7 @@ , programMonitorFiles :: [FilePath] -- ^ In addition to the 'programLocation' where the program was found, -- these are additional locations that were looked at. The combination - -- of ths found location and these not-found locations can be used to + -- of this found location and these not-found locations can be used to -- monitor to detect when the re-configuring the program might give a -- different result (e.g. found in a different location). } diff --git a/src/Distribution/Simple/Register.hs b/src/Distribution/Simple/Register.hs --- a/src/Distribution/Simple/Register.hs +++ b/src/Distribution/Simple/Register.hs @@ -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 @@ -59,7 +61,6 @@ import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.HaskellSuite as HaskellSuite import qualified Distribution.Simple.PackageIndex as Index import qualified Distribution.Simple.UHC as UHC @@ -78,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 @@ -99,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 @@ -118,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 <- @@ -155,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 @@ -214,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 @@ -340,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 @@ -356,22 +370,20 @@ 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 () - HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath _ -> dieWithException verbosity CreatePackageDB doesPackageDBExist :: FilePath -> IO Bool @@ -383,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. @@ -415,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 @@ -436,8 +443,6 @@ case compilerFlavor comp of GHC -> GHC.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions GHCJS -> GHCJS.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions - HaskellSuite{} -> - HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo _ | HcPkg.registerMultiInstance registerOptions -> dieWithException verbosity RegisMultiplePkgNotSupported @@ -449,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 @@ -497,9 +502,9 @@ { IPI.sourcePackageId = packageId pkg , IPI.installedUnitId = componentUnitId clbi , IPI.installedComponentId_ = componentComponentId clbi - , IPI.instantiatedWith = componentInstantiatedWith clbi + , IPI.instantiatedWith = expectLibraryComponent (maybeComponentInstantiatedWith clbi) , IPI.sourceLibName = libName lib - , IPI.compatPackageKey = componentCompatPackageKey clbi + , IPI.compatPackageKey = expectLibraryComponent (maybeComponentCompatPackageKey clbi) , -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license IPI.license = if ghc84 @@ -518,22 +523,21 @@ , IPI.indefinite = componentIsIndefinite clbi , IPI.exposed = libExposed lib , IPI.exposedModules = - componentExposedModules clbi + expectLibraryComponent (maybeComponentExposedModules clbi) -- add virtual modules into the list of exposed modules for the -- package database as well. - ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi) + ++ 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 @@ -549,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 @@ -601,6 +606,8 @@ ) | otherwise = (libdir installDirs : dynlibdir installDirs : extraLibDirs', []) + expectLibraryComponent (Just attribute) = attribute + expectLibraryComponent Nothing = error "generalInstalledPackageInfo: Expected a library component, got something else." -- the compiler doesn't understand the dynamic-library-dirs field so we -- add the dyn directory to the "normal" list in the library-dirs field @@ -639,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 @@ -649,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. @@ -713,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)) @@ -727,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 @@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -- | @@ -38,6 +38,7 @@ , globalCommand , CommonSetupFlags (..) , defaultCommonSetupFlags + , commonSetupTempFileOptions , ConfigFlags (..) , emptyConfigFlags , defaultConfigFlags @@ -118,7 +119,9 @@ , splitArgs , defaultDistPref , optionDistPref - , Flag (..) + , Flag + , pattern Flag + , pattern NoFlag , toFlag , fromFlag , fromFlagOrDefault @@ -167,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? -- @@ -191,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) @@ -118,7 +118,8 @@ [] ["benchmark-options"] ( "give extra options to benchmark executables " - ++ "(name templates can use $pkgid, $compiler, " + ++ "(split on spaces, use \"\" to prevent splitting; " + ++ "name templates can use $pkgid, $compiler, " ++ "$os, $arch, $benchmark)" ) benchmarkOptions @@ -132,7 +133,7 @@ [] ["benchmark-option"] ( "give extra option to benchmark executables " - ++ "(no need to quote options containing spaces, " + ++ "(passed directly as a single argument; " ++ "name template can use $pkgid, $compiler, " ++ "$os, $arch, $benchmark)" ) diff --git a/src/Distribution/Simple/Setup/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 @@ -1,8 +1,7 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -- | @@ -20,6 +19,7 @@ ( CommonSetupFlags (..) , defaultCommonSetupFlags , withCommonSetupOptions + , commonSetupTempFileOptions , CopyDest (..) , configureCCompiler , configureLinker @@ -33,7 +33,9 @@ , defaultDistPref , extraCompilationArtifacts , optionDistPref - , Flag (..) + , Flag + , pattern Flag + , pattern NoFlag , toFlag , fromFlag , fromFlagOrDefault @@ -69,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) @@ -82,6 +84,13 @@ -- -- TODO: this one should not be here, it's just that the silly -- UserHooks stop us from passing extra info in other ways + , setupKeepTempFiles :: Flag Bool + -- ^ When this flag is set, temporary files will be kept after building. + -- + -- Note: Keeping temporary files is important functionality for HLS, which + -- runs @cabal repl@ with a fake GHC to get CLI arguments. It will need the + -- temporary files (including multi unit repl response files) to stay, even + -- after the @cabal repl@ command exits. } deriving (Eq, Show, Read, Generic) @@ -103,8 +112,17 @@ , setupDistPref = NoFlag , setupCabalFilePath = NoFlag , setupTargets = [] + , setupKeepTempFiles = NoFlag } +-- | Get `TempFileOptions` that respect the `setupKeepTempFiles` flag. +commonSetupTempFileOptions :: CommonSetupFlags -> TempFileOptions +commonSetupTempFileOptions options = + TempFileOptions + { optKeepTempFiles = + fromFlagOrDefault False (setupKeepTempFiles options) + } + commonSetupOptions :: ShowOrParseArgs -> [OptionField CommonSetupFlags] commonSetupOptions showOrParseArgs = [ optionVerbosity @@ -121,6 +139,13 @@ setupCabalFilePath (\v flags -> flags{setupCabalFilePath = v}) (reqSymbolicPathArgFlag "PATH") + , option + "" + ["keep-temp-files"] + "Keep temporary files." + setupKeepTempFiles + (\keepTempFiles flags -> flags{setupKeepTempFiles = keepTempFiles}) + trueArg -- NB: no --working-dir flag, as that value is populated using the -- global flag (see Distribution.Simple.Setup.Global.globalCommand). ] @@ -252,7 +277,9 @@ [prog ++ "-option"] ( "give an extra option to " ++ prog - ++ " (no need to quote options containing spaces)" + ++ " (passed directly to " + ++ prog + ++ " as a single argument)" ) get set @@ -289,7 +316,10 @@ option "" [prog ++ "-options"] - ("give extra options to " ++ prog) + ( "give extra options to " + ++ prog + ++ " (split on spaces, use \"\" to prevent splitting)" + ) get set (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) @@ -365,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 @@ -438,13 +440,6 @@ [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") , (Flag GHCJS, ([], ["ghcjs"]), "compile with GHCJS") , (Flag UHC, ([], ["uhc"]), "compile with UHC") - , -- "haskell-suite" compiler id string will be replaced - -- by a more specific one during the configure stage - - ( Flag (HaskellSuite "haskell-suite") - , ([], ["haskell-suite"]) - , "compile with a haskell-suite compiler" - ) ] ) , option @@ -507,6 +502,13 @@ (boolOpt [] []) , option "" + ["library-bytecode"] + "Bytecode library" + configBytecodeLib + (\v flags -> flags{configBytecodeLib = v}) + (boolOpt [] []) + , option + "" ["executable-dynamic"] "Executable dynamic linking" configDynExe @@ -571,7 +573,7 @@ [ optArgDef' "n" (show NoOptimisation, Flag . flagToOptimisationLevel) - ( \f -> case f of + ( \case Flag NoOptimisation -> [] Flag NormalOptimisation -> [Nothing] Flag MaximumOptimisation -> [Just "2"] @@ -593,7 +595,7 @@ [ optArg' "n" (Flag . flagToDebugInfoLevel) - ( \f -> case f of + ( \case Flag NoDebugInfo -> [] Flag MinimalDebugInfo -> [Just "1"] Flag NormalDebugInfo -> [Nothing] @@ -897,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 @@ -1007,6 +1000,13 @@ installDirArg , option "" + ["bytecodelibdir"] + "installation directory for bytecode libraries" + bytecodelibdir + (\v flags -> flags{bytecodelibdir = v}) + installDirArg + , option + "" ["libexecdir"] "installation directory for program executables" libexecdir @@ -1101,7 +1101,7 @@ (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc] (NoFlag, NoFlag) -> [] hc_flag_name - -- TODO kill off thic bc hack when defaultUserHooks is removed. + -- TODO kill off this bc hack when defaultUserHooks is removed. | bcHack = "--with-hc=" | otherwise = "--with-compiler=" optFlag name config_field = case config_field flags of diff --git a/src/Distribution/Simple/Setup/Copy.hs b/src/Distribution/Simple/Setup/Copy.hs --- a/src/Distribution/Simple/Setup/Copy.hs +++ b/src/Distribution/Simple/Setup/Copy.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} @@ -58,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) @@ -112,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"]) @@ -145,7 +146,7 @@ ( reqArg "DIR" (succeedReadE (Flag . CopyTo)) - (\f -> case f of Flag (CopyTo p) -> [p]; _ -> []) + (\case Flag (CopyTo p) -> [p]; _ -> []) ) , option "" @@ -160,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 @@ -107,7 +108,6 @@ , haddockHscolourCss :: Flag FilePath , haddockContents :: Flag PathTemplate , haddockIndex :: Flag PathTemplate - , haddockKeepTempFiles :: Flag Bool , haddockBaseUrl :: Flag String , haddockResourcesDir :: Flag String , haddockOutputDir :: Flag FilePath @@ -116,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) @@ -162,7 +162,6 @@ , haddockQuickJump = Flag False , haddockHscolourCss = NoFlag , haddockContents = NoFlag - , haddockKeepTempFiles = Flag False , haddockIndex = NoFlag , haddockBaseUrl = NoFlag , haddockResourcesDir = NoFlag @@ -179,7 +178,8 @@ "Requires the program haddock, version 2.x.\n" , commandNotes = Nothing , commandUsage = - usageAlternatives "haddock" $ + usageAlternatives + "haddock" [ "[FLAGS]" , "COMPONENTS [FLAGS]" ] @@ -205,8 +205,7 @@ where progDb = addKnownProgram haddockProgram $ - addKnownProgram ghcProgram $ - emptyProgramDb + addKnownProgram ghcProgram emptyProgramDb haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] haddockOptions showOrParseArgs = @@ -216,13 +215,6 @@ showOrParseArgs [ option "" - ["keep-temp-files"] - "Keep temporary files" - haddockKeepTempFiles - (\b flags -> flags{haddockKeepTempFiles = b}) - trueArg - , option - "" ["hoogle"] "Generate a hoogle database" haddockHoogle @@ -409,7 +401,8 @@ deriving (Eq, Show) data HaddockProjectFlags = HaddockProjectFlags - { haddockProjectHackage :: Flag Bool + { haddockProjectCommonFlags :: !CommonSetupFlags + , haddockProjectHackage :: Flag Bool -- ^ a shortcut option which builds documentation linked to hackage. It implies: -- * `--html-location='https://hackage.haskell.org/package/$prg-$version/docs' -- * `--quickjump` @@ -442,9 +435,7 @@ , -- haddockContent is not supported, a fixed value is provided -- haddockIndex is not supported, a fixed value is provided -- haddockDistPerf is not supported, note: it changes location of the haddocks - haddockProjectKeepTempFiles :: Flag Bool - , haddockProjectVerbosity :: Flag Verbosity - , -- haddockBaseUrl is not supported, a fixed value is provided + -- haddockBaseUrl is not supported, a fixed value is provided haddockProjectResourcesDir :: Flag String , haddockProjectUseUnicode :: Flag Bool } @@ -453,7 +444,8 @@ defaultHaddockProjectFlags :: HaddockProjectFlags defaultHaddockProjectFlags = HaddockProjectFlags - { haddockProjectHackage = Flag False + { haddockProjectCommonFlags = defaultCommonSetupFlags + , haddockProjectHackage = Flag False , haddockProjectDir = Flag "./haddocks" , haddockProjectPrologue = NoFlag , haddockProjectTestSuites = Flag False @@ -467,8 +459,6 @@ , haddockProjectInternal = Flag False , haddockProjectCss = NoFlag , haddockProjectHscolourCss = NoFlag - , haddockProjectKeepTempFiles = Flag False - , haddockProjectVerbosity = Flag normal , haddockProjectResourcesDir = NoFlag , haddockProjectInterfaces = NoFlag , haddockProjectUseUnicode = NoFlag @@ -483,7 +473,8 @@ "Requires the program haddock, version 2.26.\n" , commandNotes = Nothing , commandUsage = - usageAlternatives "haddock-project" $ + usageAlternatives + "haddock-project" [ "[FLAGS]" , "COMPONENTS [FLAGS]" ] @@ -509,144 +500,134 @@ where progDb = addKnownProgram haddockProgram $ - addKnownProgram ghcProgram $ - emptyProgramDb + addKnownProgram ghcProgram emptyProgramDb haddockProjectOptions :: ShowOrParseArgs -> [OptionField HaddockProjectFlags] -haddockProjectOptions _showOrParseArgs = - [ option - "" - ["hackage"] - ( concat - [ "A short-cut option to build documentation linked to hackage." - ] - ) - haddockProjectHackage - (\v flags -> flags{haddockProjectHackage = v}) - trueArg - , option - "" - ["output"] - "Output directory" - haddockProjectDir - (\v flags -> flags{haddockProjectDir = v}) - (optArg' "DIRECTORY" maybeToFlag (fmap Just . flagToList)) - , option - "" - ["prologue"] - "File path to a prologue file in haddock format" - haddockProjectPrologue - (\v flags -> flags{haddockProjectPrologue = v}) - (optArg' "PATH" maybeToFlag (fmap Just . flagToList)) - , option - "" - ["hoogle"] - "Generate a hoogle database" - haddockProjectHoogle - (\v flags -> flags{haddockProjectHoogle = v}) - trueArg - , option - "" - ["html-location"] - "Location of HTML documentation for pre-requisite packages" - haddockProjectHtmlLocation - (\v flags -> flags{haddockProjectHtmlLocation = v}) - (reqArgFlag "URL") - , option - "" - ["executables"] - "Run haddock for Executables targets" - haddockProjectExecutables - (\v flags -> flags{haddockProjectExecutables = v}) - trueArg - , option - "" - ["tests"] - "Run haddock for Test Suite targets" - haddockProjectTestSuites - (\v flags -> flags{haddockProjectTestSuites = v}) - trueArg - , option - "" - ["benchmarks"] - "Run haddock for Benchmark targets" - haddockProjectBenchmarks - (\v flags -> flags{haddockProjectBenchmarks = v}) - trueArg - , option - "" - ["foreign-libraries"] - "Run haddock for Foreign Library targets" - haddockProjectForeignLibs - (\v flags -> flags{haddockProjectForeignLibs = v}) - trueArg - , option - "" - ["all", "haddock-all"] - "Run haddock for all targets" - ( \f -> - allFlags - [ haddockProjectExecutables f - , haddockProjectTestSuites f - , haddockProjectBenchmarks f - , haddockProjectForeignLibs f - ] - ) - ( \v flags -> - flags - { haddockProjectExecutables = v - , haddockProjectTestSuites = v - , haddockProjectBenchmarks = v - , haddockProjectForeignLibs = v - } - ) - trueArg - , option - "" - ["internal"] - "Run haddock for internal modules and include all symbols" - haddockProjectInternal - (\v flags -> flags{haddockProjectInternal = v}) - trueArg - , option - "" - ["css"] - "Use PATH as the haddock stylesheet" - haddockProjectCss - (\v flags -> flags{haddockProjectCss = v}) - (reqArgFlag "PATH") - , option - "" - ["hscolour-css"] - "Use PATH as the HsColour stylesheet" - haddockProjectHscolourCss - (\v flags -> flags{haddockProjectHscolourCss = v}) - (reqArgFlag "PATH") - , option - "" - ["keep-temp-files"] - "Keep temporary files" - haddockProjectKeepTempFiles - (\b flags -> flags{haddockProjectKeepTempFiles = b}) - trueArg - , optionVerbosity - haddockProjectVerbosity - (\v flags -> flags{haddockProjectVerbosity = v}) - , option - "" - ["resources-dir"] - "location of Haddocks static / auxiliary files" - haddockProjectResourcesDir - (\v flags -> flags{haddockProjectResourcesDir = v}) - (reqArgFlag "DIR") - , option - "" - ["use-unicode"] - "Pass --use-unicode option to haddock" - haddockProjectUseUnicode - (\v flags -> flags{haddockProjectUseUnicode = v}) - trueArg - ] +haddockProjectOptions showOrParseArgs = + withCommonSetupOptions + haddockProjectCommonFlags + (\c f -> f{haddockProjectCommonFlags = c}) + showOrParseArgs + [ option + "" + ["hackage"] + "A short-cut option to build documentation linked to hackage." + haddockProjectHackage + (\v flags -> flags{haddockProjectHackage = v}) + trueArg + , option + "" + ["output"] + "Output directory" + haddockProjectDir + (\v flags -> flags{haddockProjectDir = v}) + (optArg' "DIRECTORY" maybeToFlag (fmap Just . flagToList)) + , option + "" + ["prologue"] + "File path to a prologue file in haddock format" + haddockProjectPrologue + (\v flags -> flags{haddockProjectPrologue = v}) + (optArg' "PATH" maybeToFlag (fmap Just . flagToList)) + , option + "" + ["hoogle"] + "Generate a hoogle database" + haddockProjectHoogle + (\v flags -> flags{haddockProjectHoogle = v}) + trueArg + , option + "" + ["html-location"] + "Location of HTML documentation for pre-requisite packages" + haddockProjectHtmlLocation + (\v flags -> flags{haddockProjectHtmlLocation = v}) + (reqArgFlag "URL") + , option + "" + ["executables"] + "Run haddock for Executables targets" + haddockProjectExecutables + (\v flags -> flags{haddockProjectExecutables = v}) + trueArg + , option + "" + ["tests"] + "Run haddock for Test Suite targets" + haddockProjectTestSuites + (\v flags -> flags{haddockProjectTestSuites = v}) + trueArg + , option + "" + ["benchmarks"] + "Run haddock for Benchmark targets" + haddockProjectBenchmarks + (\v flags -> flags{haddockProjectBenchmarks = v}) + trueArg + , option + "" + ["foreign-libraries"] + "Run haddock for Foreign Library targets" + haddockProjectForeignLibs + (\v flags -> flags{haddockProjectForeignLibs = v}) + trueArg + , option + "" + ["all", "haddock-all"] + "Run haddock for all targets" + ( \f -> + allFlags + [ haddockProjectExecutables f + , haddockProjectTestSuites f + , haddockProjectBenchmarks f + , haddockProjectForeignLibs f + ] + ) + ( \v flags -> + flags + { haddockProjectExecutables = v + , haddockProjectTestSuites = v + , haddockProjectBenchmarks = v + , haddockProjectForeignLibs = v + } + ) + trueArg + , option + "" + ["internal"] + "Run haddock for internal modules and include all symbols" + haddockProjectInternal + (\v flags -> flags{haddockProjectInternal = v}) + trueArg + , option + "" + ["css"] + "Use PATH as the haddock stylesheet" + haddockProjectCss + (\v flags -> flags{haddockProjectCss = v}) + (reqArgFlag "PATH") + , option + "" + ["hscolour-css"] + "Use PATH as the HsColour stylesheet" + haddockProjectHscolourCss + (\v flags -> flags{haddockProjectHscolourCss = v}) + (reqArgFlag "PATH") + , option + "" + ["resources-dir"] + "location of Haddocks static / auxiliary files" + haddockProjectResourcesDir + (\v flags -> flags{haddockProjectResourcesDir = v}) + (reqArgFlag "DIR") + , option + "" + ["use-unicode"] + "Pass --use-unicode option to haddock" + haddockProjectUseUnicode + (\v flags -> flags{haddockProjectUseUnicode = v}) + trueArg + ] emptyHaddockProjectFlags :: HaddockProjectFlags emptyHaddockProjectFlags = mempty diff --git a/src/Distribution/Simple/Setup/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,7 +1,7 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} @@ -62,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) @@ -169,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 @@ -54,11 +54,12 @@ { replOptionsFlags :: [String] , replOptionsNoLoad :: Flag Bool , replOptionsFlagOutput :: Flag FilePath + , replWithRepl :: Flag FilePath } deriving (Show, Generic) pattern ReplCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) @@ -85,7 +86,7 @@ instance Structured ReplOptions instance Monoid ReplOptions where - mempty = ReplOptions mempty (Flag False) NoFlag + mempty = ReplOptions mempty (Flag False) NoFlag NoFlag mappend = (<>) instance Semigroup ReplOptions where @@ -229,4 +230,11 @@ replOptionsFlagOutput (\p flags -> flags{replOptionsFlagOutput = p}) (reqArg "DIR" (succeedReadE Flag) flagToList) + , option + [] + ["with-repl"] + "Give the path to a program to use for REPL" + replWithRepl + (\v flags -> flags{replWithRepl = v}) + (reqArgFlag "PATH") ] diff --git a/src/Distribution/Simple/Setup/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 @@ -245,7 +246,8 @@ [] ["test-options"] ( "give extra options to test executables " - ++ "(name templates can use $pkgid, $compiler, " + ++ "(split on spaces, use \"\" to prevent splitting; " + ++ "name templates can use $pkgid, $compiler, " ++ "$os, $arch, $test-suite)" ) testOptions @@ -259,7 +261,7 @@ [] ["test-option"] ( "give extra option to test executables " - ++ "(no need to quote options containing spaces, " + ++ "(passed directly as a single argument; " ++ "name template can use $pkgid, $compiler, " ++ "$os, $arch, $test-suite)" ) diff --git a/src/Distribution/Simple/SetupHooks/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,9 +2,12 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} @@ -13,7 +16,8 @@ -- | -- 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 @@ -78,6 +82,7 @@ -- ** Executing build rules , executeRules + , executeRulesUserOrSystem -- ** HookedBuildInfo compatibility code , hookedBuildInfoComponents @@ -89,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 @@ -110,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 @@ -790,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 @@ -850,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 @@ -859,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 $ @@ -870,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 ] @@ -891,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 @@ -923,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 @@ -978,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 @@ -995,7 +1199,7 @@ case Map.lookup depId allRules of Nothing -> error $ - unlines $ + unlines [ "Internal error: missing rule dependency." , "Rule: " ++ show rId , "Dependency: " ++ show depId @@ -1013,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 #-} @@ -9,10 +8,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} @@ -126,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 @@ -274,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 @@ -294,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 @@ -312,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 @@ -612,9 +627,9 @@ -> StaticPtr (arg -> res) -> arg -> Command arg res -mkCommand dict actionPtr arg = +mkCommand dict action arg = Command - { actionPtr = UserStatic actionPtr + { actionPtr = UserStatic action , actionArg = ScopedArgument arg , cmdInstances = UserStatic dict } @@ -629,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) @@ -680,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 @@ -723,7 +745,7 @@ how much to read in order to reconstruct the associated opaque 'ByteString'. To ensure we always serialise/deserialise including the length of the data, the 'ScopedArgument' newtype is used, with a custom 'Binary' instance that always -incldues the length. We use this newtype: +includes the length. We use this newtype: - in the definition of 'CommandData', for arguments to rules, - in the definition of 'DepsRes', for the result of dynamic dependency computations. @@ -824,9 +846,9 @@ } | Dict <- deRefStaticPtr instsPtr -> Just $ do - (deps, depsRes) <- runCommand depsCmd + (deps, dynDeps) <- runCommand depsCmd -- See Note [Hooks Binary instances] - return $ (deps, Binary.encode $ ScopedArgument @User depsRes) + return (deps, Binary.encode $ ScopedArgument @User dynDeps) -- | Project out the command for running the rule, passing in the result of -- the dependency computation if there was one. @@ -1087,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 @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -- | -- This module defines a simple JSON-based format for exporting basic @@ -216,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 #-} ----------------------------------------------------------------------------- @@ -27,7 +28,7 @@ import qualified Distribution.PackageDescription as PD import Distribution.Pretty -import Distribution.Simple.Build (addInternalBuildToolsFixed) +import Distribution.Simple.Build (addInternalBuildTools) import Distribution.Simple.Compiler import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs @@ -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 @@ -96,8 +97,8 @@ lbi { withPrograms = -- Include any build-tool-depends on build tools internal to the current package. - addInternalBuildToolsFixed - (Just curDir) + addInternalBuildTools + curDir pkg_descr lbi (PD.testBuildInfo suite) @@ -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 #-} ----------------------------------------------------------------------------- @@ -59,10 +60,9 @@ configure :: Verbosity -> Maybe FilePath - -> Maybe FilePath -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity hcPath _hcPkgPath progdb = do +configure verbosity hcPath progdb = do (_uhcProg, uhcVersion, progdb') <- requireProgramVersion verbosity @@ -78,6 +78,7 @@ , compilerLanguages = uhcLanguages , compilerExtensions = uhcLanguageExtensions , compilerProperties = Map.empty + , compilerWiredInUnitIds = Nothing } compPlatform = Nothing return (comp, compPlatform, progdb') @@ -121,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) @@ -231,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 @@ -266,7 +264,7 @@ -- output file ++ ["--output", u $ buildDir lbi makeRelativePathEx (prettyShow (exeName exe))] -- main source module - ++ [u $ srcMainPath] + ++ [u srcMainPath] runUhcProg uhcArgs constructUHCCmdLine @@ -279,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) @@ -298,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 @@ -313,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 = @@ -329,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 @@ -1,14 +1,18 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +#if MIN_VERSION_base(4,21,0) +{-# LANGUAGE ImplicitParams #-} +#endif {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +#ifdef GIT_REV +{-# LANGUAGE TemplateHaskell #-} +#endif ----------------------------------------------------------------------------- @@ -28,6 +32,8 @@ -- various directory and file functions that do extra logging. module Distribution.Simple.Utils ( cabalVersion + , cabalGitInfo + , cabalCompilerInfo -- * logging and errors , dieNoVerbosity @@ -37,6 +43,7 @@ , dieNoWrap , topHandler , topHandlerWith + , isUserException , warn , warnError , notice @@ -90,6 +97,9 @@ , copyFileTo , copyFileToCwd + -- * removing files + , removeFileForcibly + -- * installing files , installOrdinaryFile , installExecutableFile @@ -183,6 +193,7 @@ , listUnion , listUnionRight , ordNub + , sortNub , ordNubBy , ordNubRight , safeHead @@ -192,6 +203,7 @@ , unintersperse , wrapText , wrapLine + , stripCommonPrefix -- * FilePath stuff , isAbsoluteOnAnyPlatform @@ -201,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 @@ -235,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 @@ -247,11 +261,12 @@ , createDirectory , doesDirectoryExist , doesFileExist - , getDirectoryContents , getModificationTime , getPermissions - , removeDirectoryRecursive + , getTemporaryDirectory + , listDirectory , removeFile + , removePathForcibly ) import System.Environment ( getProgName @@ -259,11 +274,13 @@ import System.FilePath (takeFileName) import System.FilePath as FilePath ( getSearchPath + , isExtensionOf , joinPath , normalise , searchPathSeparator , splitDirectories , splitExtension + , stripExtension , takeDirectory ) import System.IO @@ -277,15 +294,31 @@ , 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 +#ifdef GIT_REV +import Data.Either (isLeft) +import GitHash + ( giHash + , giBranch + , giCommitDate + , tGitInfoCwdTry + ) +#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) @@ -296,6 +329,45 @@ cabalVersion = mkVersion [3,0] --used when bootstrapping #endif +-- | +-- `Cabal` Git information. Only filled in if built in a Git tree in +-- development mode and Template Haskell is available. +cabalGitInfo :: String +#ifdef GIT_REV +cabalGitInfo = if giHash' == "" + then "" + else concat [ "(commit " + , giHash' + , branchInfo + , either (const "") ((", " ++) . giCommitDate) gi' + , ")" + ] + where + gi' = $$tGitInfoCwdTry + giHash' = take 7 . either (const "") giHash $ gi' + branch = either id giBranch gi' + branchInfo | isLeft 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 @@ -383,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 -expections and cabal-install exceptions -data VerboseException a = VerboseException CallStack POSIXTime Verbosity a +-- Type which will be a wrapper for cabal -exceptions and cabal-install exceptions +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 @@ -444,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 @@ -456,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 @@ -466,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 @@ -496,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 -> @@ -511,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. -- @@ -533,7 +624,7 @@ warn :: Verbosity -> String -> IO () warn verbosity msg = warnMessage "Warning" verbosity msg --- | Like 'warn', but prepend @Error: …@ instead of @Waring: …@ before the +-- | Like 'warn', but prepend @Error: …@ instead of @Warning: …@ before the -- the message. Useful when you want to highlight the condition is an error -- but do not want to quit the program yet. warnError :: Verbosity -> String -> IO () @@ -542,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. -- @@ -558,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. @@ -598,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 @@ -634,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. @@ -667,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 @@ -675,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 @@ -701,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 = @@ -720,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 @@ -752,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 @@ -764,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 $ @@ -787,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 @@ -804,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 @@ -818,7 +915,7 @@ else "" else "" ) - ++ ( if verbosity >= verbose + ++ ( if vLevel verbosity >= Verbose then prettyCallStack stack ++ "\n" else "" ) @@ -870,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. @@ -909,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) @@ -920,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. @@ -940,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)] @@ -948,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. @@ -982,7 +1129,7 @@ args mcwd menv - action + (\_ _ _ -> action) inp out err @@ -1001,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 @@ -1014,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. -- @@ -1430,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 @@ -1439,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) @@ -1449,10 +1605,6 @@ then collect files (dirEntry : dirs') entries else collect (dirEntry : files) dirs' entries - ignore ['.'] = True - ignore ['.', '.'] = True - ignore _ = False - ------------------------ -- Environment variables @@ -1522,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 @@ -1585,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 @@ -1664,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) @@ -1733,23 +1905,17 @@ -- | Use a temporary filename that doesn't already exist withTempFile - :: FilePath - -- ^ Temp dir to create the file in - -> String + :: String -- ^ File name template. See 'openTempFile'. -> (FilePath -> Handle -> IO a) -> IO a -withTempFile tmpDir template f = withFrozenCallStack $ - withTempFileCwd Nothing (makeSymbolicPath tmpDir) template $ +withTempFile template f = withFrozenCallStack $ + withTempFileCwd template $ \fp h -> f (getSymbolicPath fp) h -- | Use a temporary filename that doesn't already exist. withTempFileCwd - :: Maybe (SymbolicPath CWD (Dir Pkg)) - -- ^ Working directory - -> SymbolicPath Pkg (Dir tmpDir) - -- ^ Temp dir to create the file in - -> String + :: String -- ^ File name template. See 'openTempFile'. -> (SymbolicPath Pkg File -> Handle -> IO a) -> IO a @@ -1758,33 +1924,28 @@ -- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' -- argument. withTempFileEx - :: forall a tmpDir + :: forall a . TempFileOptions - -> Maybe (SymbolicPath CWD (Dir Pkg)) - -- ^ Working directory - -> SymbolicPath Pkg (Dir tmpDir) - -- ^ Temp dir to create the file in -> String -- ^ File name template. See 'openTempFile'. -> (SymbolicPath Pkg File -> Handle -> IO a) -> IO a -withTempFileEx opts mbWorkDir tmpDir template action = +withTempFileEx opts template action = do + tmp <- getTemporaryDirectory withFrozenCallStack $ Exception.bracket - (openTempFile (i tmpDir) template) + (openTempFile tmp template) ( \(name, handle) -> do hClose handle unless (optKeepTempFiles opts) $ handleDoesNotExist () $ - removeFile $ - name + removeFile name ) - (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg fn) h)) + (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg tmp fn) h)) where - i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path - mkRelToPkg :: FilePath -> SymbolicPath Pkg File - mkRelToPkg fp = - tmpDir makeRelativePathEx (takeFileName fp) + mkRelToPkg :: FilePath -> FilePath -> SymbolicPath Pkg File + mkRelToPkg tmp fp = + makeSymbolicPath tmp makeRelativePathEx (takeFileName fp) -- 'openTempFile' returns a path of the form @i tmpDir fn@, but we -- want 'withTempFileEx' to return @tmpDir fn@. So we split off @@ -1797,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 @@ -1821,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 @@ -1846,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 @@ -1982,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 <- @@ -2018,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) @@ -2034,3 +2188,10 @@ buildInfoExt :: String buildInfoExt = ".buildinfo" + +-- | @stripCommonPrefix xs ys@ gives you @ys@ without the common prefix with @xs@. +stripCommonPrefix :: String -> String -> String +stripCommonPrefix (x : xs) (y : ys) + | x == y = stripCommonPrefix xs ys + | otherwise = y : ys +stripCommonPrefix _ ys = ys diff --git a/src/Distribution/Types/ComponentLocalBuildInfo.hs b/src/Distribution/Types/ComponentLocalBuildInfo.hs --- a/src/Distribution/Types/ComponentLocalBuildInfo.hs +++ b/src/Distribution/Types/ComponentLocalBuildInfo.hs @@ -5,6 +5,8 @@ ( ComponentLocalBuildInfo (..) , componentIsIndefinite , maybeComponentInstantiatedWith + , maybeComponentCompatPackageKey + , maybeComponentExposedModules ) where import Distribution.Compat.Prelude @@ -125,3 +127,13 @@ maybeComponentInstantiatedWith LibComponentLocalBuildInfo{componentInstantiatedWith = insts} = Just insts maybeComponentInstantiatedWith _ = Nothing + +maybeComponentCompatPackageKey :: ComponentLocalBuildInfo -> Maybe String +maybeComponentCompatPackageKey + LibComponentLocalBuildInfo{componentCompatPackageKey = key} = Just key +maybeComponentCompatPackageKey _ = Nothing + +maybeComponentExposedModules :: ComponentLocalBuildInfo -> Maybe [Installed.ExposedModule] +maybeComponentExposedModules + LibComponentLocalBuildInfo{componentExposedModules = exposed} = Just exposed +maybeComponentExposedModules _ = Nothing diff --git a/src/Distribution/Types/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 @@ -2,8 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -158,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 @@ -205,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) @@ -446,7 +448,7 @@ let -- enable-library-profiling (enable (static profiling way)) .p_o -- enable-shared (enabled dynamic way) .dyn_o - -- enable-profiling-shared (enable dyanmic profilng way) .p_dyn_o + -- enable-profiling-shared (enable dynamic profilng way) .p_dyn_o -- enable-library-vanilla (enable vanilla way) .o -- -- enable-executable-dynamic => build dynamic executables diff --git a/src/Distribution/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/IOData.hs b/src/Distribution/Utils/IOData.hs --- a/src/Distribution/Utils/IOData.hs +++ b/src/Distribution/Utils/IOData.hs @@ -80,7 +80,7 @@ -- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose' -- --- This is the dual operation ot 'hGetIODataContents', +-- This is the dual operation to 'hGetIODataContents', -- and consequently the handle is closed with `hClose`. -- -- /Note:/ this performs lazy-IO. diff --git a/src/Distribution/Utils/LogProgress.hs b/src/Distribution/Utils/LogProgress.hs --- a/src/Distribution/Utils/LogProgress.hs +++ b/src/Distribution/Utils/LogProgress.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} module Distribution.Utils.LogProgress @@ -17,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 @@ -55,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