diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: Cabal -version: 3.10.3.0 -copyright: 2003-2023, Cabal Development Team (see AUTHORS file) +version: 3.12.0.0 +copyright: 2003-2024, Cabal Development Team (see AUTHORS file) license: BSD-3-Clause license-file: LICENSE author: Cabal Development Team @@ -34,7 +34,7 @@ hs-source-dirs: src build-depends: - Cabal-syntax ^>= 3.10, + Cabal-syntax ^>= 3.12, array >= 0.4.0.1 && < 0.6, base >= 4.9 && < 5, bytestring >= 0.10.0.0 && < 0.13, @@ -44,7 +44,7 @@ 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.13 + time >= 1.4.0.1 && < 1.15 if os(windows) build-depends: Win32 >= 2.3.0.0 && < 2.15 @@ -59,6 +59,9 @@ if impl(ghc >= 8.0) && impl(ghc < 8.8) ghc-options: -Wnoncanonical-monadfail-instances + if impl(ghc >= 8.10) + ghc-options: -Wunused-packages + exposed-modules: Distribution.Backpack.Configure Distribution.Backpack.ComponentsGraph @@ -88,6 +91,7 @@ Distribution.Simple Distribution.Simple.Bench Distribution.Simple.Build + Distribution.Simple.Build.Inputs Distribution.Simple.Build.Macros Distribution.Simple.Build.PackageInfoModule Distribution.Simple.Build.PathsModule @@ -98,11 +102,13 @@ Distribution.Simple.Command Distribution.Simple.Compiler Distribution.Simple.Configure + Distribution.Simple.Errors Distribution.Simple.Flag Distribution.Simple.GHC Distribution.Simple.GHCJS Distribution.Simple.Haddock Distribution.Simple.Glob + Distribution.Simple.Glob.Internal Distribution.Simple.HaskellSuite Distribution.Simple.Hpc Distribution.Simple.Install @@ -112,6 +118,7 @@ Distribution.Simple.PackageDescription Distribution.Simple.PackageIndex Distribution.Simple.PreProcess + Distribution.Simple.PreProcess.Types Distribution.Simple.PreProcess.Unlit Distribution.Simple.Program Distribution.Simple.Program.Ar @@ -145,9 +152,11 @@ Distribution.Types.DumpBuildInfo Distribution.Types.PackageName.Magic Distribution.Types.ComponentLocalBuildInfo + Distribution.Types.LocalBuildConfig Distribution.Types.LocalBuildInfo Distribution.Types.TargetInfo Distribution.Types.GivenComponent + Distribution.Types.ParStrat Distribution.Utils.Json Distribution.Utils.NubList Distribution.Utils.Progress @@ -302,7 +311,6 @@ -- 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, - text (>= 1.2.3.0 && < 1.3) || (>= 2.0 && < 2.2), parsec >= 3.1.13.0 && < 3.2 other-modules: @@ -319,13 +327,38 @@ Distribution.Compat.SnocList Distribution.GetOpt Distribution.Lex + Distribution.PackageDescription.Check.Common + Distribution.PackageDescription.Check.Conditional + Distribution.PackageDescription.Check.Monad + Distribution.PackageDescription.Check.Paths + Distribution.PackageDescription.Check.Target + Distribution.PackageDescription.Check.Warning Distribution.Simple.Build.Macros.Z Distribution.Simple.Build.PackageInfoModule.Z Distribution.Simple.Build.PathsModule.Z + Distribution.Simple.GHC.Build + Distribution.Simple.GHC.Build.ExtraSources + Distribution.Simple.GHC.Build.Link + Distribution.Simple.GHC.Build.Modules + Distribution.Simple.GHC.Build.Utils Distribution.Simple.GHC.EnvironmentParser Distribution.Simple.GHC.Internal Distribution.Simple.GHC.ImplInfo Distribution.Simple.ConfigureScript + Distribution.Simple.Setup.Benchmark + Distribution.Simple.Setup.Build + Distribution.Simple.Setup.Clean + Distribution.Simple.Setup.Common + Distribution.Simple.Setup.Config + Distribution.Simple.Setup.Copy + Distribution.Simple.Setup.Global + Distribution.Simple.Setup.Haddock + Distribution.Simple.Setup.Hscolour + Distribution.Simple.Setup.Install + Distribution.Simple.Setup.Register + Distribution.Simple.Setup.Repl + Distribution.Simple.Setup.SDist + Distribution.Simple.Setup.Test Distribution.ZinzaPrelude Paths_Cabal diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,6 @@ +# 3.12.0.0 [Francesco Ariis](mailto:fa-ml@ariis.it) May 2024 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.12.0.0.md + # 3.10.3.0 [Hécate](mailto:hecate+github@glitchbra.in) January 2024 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.3.0.md diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2023, Cabal Development Team. +Copyright (c) 2003-2024, 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/README.md b/README.md --- a/README.md +++ b/README.md @@ -34,8 +34,8 @@ [Hackage]. You may have a favourite Cabal bug or limitation. Look at Cabal's [bug tracker]. Ensure that the problem is reported there and adequately described. Comment on the issue to report how much of a -problem the bug is for you. Subscribe to the issues's notifications to -discussed requirements and keep informed on progress. For feature +problem the bug is for you. Subscribe to the issue's notifications to +discuss requirements and keep informed on progress. For feature requests, it is helpful if there is a description of how you would expect to interact with the new feature. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,5 @@ import Distribution.Simple + main :: IO () main = defaultMain diff --git a/src/Distribution/Backpack/ComponentsGraph.hs b/src/Distribution/Backpack/ComponentsGraph.hs --- a/src/Distribution/Backpack/ComponentsGraph.hs +++ b/src/Distribution/Backpack/ComponentsGraph.hs @@ -1,24 +1,24 @@ -- | See -module Distribution.Backpack.ComponentsGraph ( - ComponentsGraph, - ComponentsWithDeps, - mkComponentsGraph, - componentsGraphToList, - dispComponentsWithDeps, - componentCycleMsg -) where +module Distribution.Backpack.ComponentsGraph + ( ComponentsGraph + , ComponentsWithDeps + , mkComponentsGraph + , componentsGraphToList + , dispComponentsWithDeps + , componentCycleMsg + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () +import Distribution.Compat.Graph (Graph, Node (..)) +import qualified Distribution.Compat.Graph as Graph +import qualified Distribution.Compat.NonEmptySet as NES import Distribution.Package import Distribution.PackageDescription import Distribution.Simple.BuildToolDepends import Distribution.Simple.LocalBuildInfo import Distribution.Types.ComponentRequestedSpec -import Distribution.Compat.Graph (Graph, Node(..)) -import qualified Distribution.Compat.Graph as Graph -import qualified Distribution.Compat.NonEmptySet as NES import Distribution.Utils.Generic import Distribution.Pretty (pretty) @@ -30,68 +30,76 @@ -- | A graph of source-level components by their source-level -- dependencies --- type ComponentsGraph = Graph (Node ComponentName Component) -- | A list of components associated with the source level -- dependencies between them. --- type ComponentsWithDeps = [(Component, [ComponentName])] -- | Pretty-print 'ComponentsWithDeps'. --- dispComponentsWithDeps :: ComponentsWithDeps -> Doc dispComponentsWithDeps graph = - vcat [ hang (text "component" <+> pretty (componentName c)) 4 - (vcat [ text "dependency" <+> pretty cdep | cdep <- cdeps ]) - | (c, cdeps) <- graph ] + vcat + [ hang + (text "component" <+> pretty (componentName c)) + 4 + (vcat [text "dependency" <+> pretty cdep | cdep <- cdeps]) + | (c, cdeps) <- graph + ] -- | Create a 'Graph' of 'Component', or report a cycle if there is a -- problem. --- -mkComponentsGraph :: ComponentRequestedSpec - -> PackageDescription - -> Either [ComponentName] ComponentsGraph +mkComponentsGraph + :: ComponentRequestedSpec + -> PackageDescription + -> Either [ComponentName] ComponentsGraph mkComponentsGraph enabled pkg_descr = - let g = Graph.fromDistinctList - [ N c (componentName c) (componentDeps c) - | c <- pkgBuildableComponents pkg_descr - , componentEnabled enabled c ] - in case Graph.cycles g of - [] -> Right g - ccycles -> Left [ componentName c | N c _ _ <- concat ccycles ] + let g = + Graph.fromDistinctList + [ N c (componentName c) (componentDeps c) + | c <- pkgBuildableComponents pkg_descr + , componentEnabled enabled c + ] + in case Graph.cycles g of + [] -> Right g + ccycles -> Left [componentName c | N c _ _ <- concat ccycles] where -- The dependencies for the given component componentDeps component = - toolDependencies ++ libDependencies + toolDependencies ++ libDependencies where bi = componentBuildInfo component toolDependencies = CExeName <$> getAllInternalToolDependencies pkg_descr bi libDependencies = do - Dependency pkgname _ lns <- targetBuildDepends bi - guard (pkgname == packageName pkg_descr) + Dependency pkgname _ lns <- targetBuildDepends bi + guard (pkgname == packageName pkg_descr) - ln <- NES.toList lns - return (CLibName ln) + ln <- NES.toList lns + return (CLibName ln) -- | Given the package description and a 'PackageDescription' (used -- to determine if a package name is internal or not), sort the -- components in dependency order (fewest dependencies first). This is -- NOT necessarily the build order (although it is in the absence of -- Backpack.) --- -componentsGraphToList :: ComponentsGraph - -> ComponentsWithDeps +componentsGraphToList + :: ComponentsGraph + -> ComponentsWithDeps componentsGraphToList = - map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort + map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort -- | Error message when there is a cycle; takes the SCC of components. componentCycleMsg :: PackageIdentifier -> [ComponentName] -> Doc componentCycleMsg pn cnames = - text "Components in the package" <+> pretty pn <+> text "depend on each other in a cyclic way:" - $$ - text (intercalate " depends on " - [ "'" ++ showComponentName cname ++ "'" - | cname <- cnames ++ maybeToList (safeHead cnames) ]) + text "Components in the package" + <+> pretty pn + <+> text "depend on each other in a cyclic way:" + $$ text + ( intercalate + " depends on " + [ "'" ++ showComponentName cname ++ "'" + | cname <- cnames ++ maybeToList (safeHead cnames) + ] + ) 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,56 +1,60 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE NondecreasingIndentation #-} -- | See -- -- WARNING: The contents of this module are HIGHLY experimental. -- We may refactor it under you. -module Distribution.Backpack.Configure ( - configureComponentLocalBuildInfos, -) where +module Distribution.Backpack.Configure + ( configureComponentLocalBuildInfos + ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () import Distribution.Backpack -import Distribution.Backpack.FullUnitId -import Distribution.Backpack.PreExistingComponent +import Distribution.Backpack.ComponentsGraph import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.Id import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.PreExistingComponent import Distribution.Backpack.ReadyComponent -import Distribution.Backpack.ComponentsGraph -import Distribution.Backpack.Id -import Distribution.Simple.Compiler -import Distribution.Package +import Distribution.Backpack.ModuleShape +import Distribution.Compat.Graph (Graph, IsNode (..)) +import qualified Distribution.Compat.Graph as Graph +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo + , emptyInstalledPackageInfo + ) import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.InstalledPackageInfo (InstalledPackageInfo - ,emptyInstalledPackageInfo) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.PackageDescription import Distribution.ModuleName -import Distribution.Simple.Setup as Setup +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.Compiler +import Distribution.Simple.Flag import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Types.AnnotatedId -import Distribution.Types.ComponentRequestedSpec import Distribution.Types.ComponentInclude +import Distribution.Types.ComponentRequestedSpec import Distribution.Types.MungedPackageName -import Distribution.Verbosity -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph (Graph, IsNode(..)) import Distribution.Utils.LogProgress +import Distribution.Verbosity import Data.Either - ( lefts ) -import qualified Data.Set as Set + ( lefts + ) import qualified Data.Map as Map +import qualified Data.Set as Set import Distribution.Pretty import Text.PrettyPrint @@ -59,144 +63,233 @@ ------------------------------------------------------------------------------ configureComponentLocalBuildInfos - :: Verbosity - -> Bool -- use_external_internal_deps - -> ComponentRequestedSpec - -> Bool -- deterministic - -> Flag String -- configIPID - -> Flag ComponentId -- configCID - -> PackageDescription - -> [PreExistingComponent] - -> FlagAssignment -- configConfigurationsFlags - -> [(ModuleName, Module)] -- configInstantiateWith - -> InstalledPackageIndex - -> Compiler - -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) + :: Verbosity + -> Bool -- use_external_internal_deps + -> ComponentRequestedSpec + -> Bool -- deterministic + -> Flag String -- configIPID + -> Flag ComponentId -- configCID + -> PackageDescription + -> ([PreExistingComponent], [PromisedComponent]) + -> FlagAssignment -- configConfigurationsFlags + -> [(ModuleName, Module)] -- configInstantiateWith + -> InstalledPackageIndex + -> Compiler + -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) configureComponentLocalBuildInfos - verbosity use_external_internal_deps enabled deterministic ipid_flag cid_flag pkg_descr - prePkgDeps flagAssignment instantiate_with installedPackageSet comp = do + verbosity + use_external_internal_deps + enabled + deterministic + ipid_flag + cid_flag + pkg_descr + (prePkgDeps, promisedPkgDeps) + flags + instantiate_with + installedPackageSet + comp = do -- NB: In single component mode, this returns a *single* component. -- In this graph, the graph is NOT closed. graph0 <- case mkComponentsGraph enabled pkg_descr of - Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle) - Right g -> return (componentsGraphToList g) - infoProgress $ hang (text "Source component graph:") 4 - (dispComponentsWithDeps graph0) + Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle) + Right g -> return (componentsGraphToList g) + infoProgress $ + hang + (text "Source component graph:") + 4 + (dispComponentsWithDeps graph0) - let conf_pkg_map = Map.fromListWith Map.union - [(pc_pkgname pkg, - Map.singleton (pc_compname pkg) - (AnnotatedId { - ann_id = pc_cid pkg, - ann_pid = packageId pkg, - ann_cname = pc_compname pkg - })) - | pkg <- prePkgDeps] - graph1 <- toConfiguredComponents use_external_internal_deps - flagAssignment - deterministic ipid_flag cid_flag pkg_descr - conf_pkg_map (map fst graph0) - infoProgress $ hang (text "Configured component graph:") 4 - (vcat (map dispConfiguredComponent graph1)) + let conf_pkg_map = + Map.fromListWith + Map.union + [ ( pc_pkgname pkg + , Map.singleton + (pc_compname pkg) + ( AnnotatedId + { ann_id = pc_cid pkg + , ann_pid = packageId pkg + , ann_cname = pc_compname pkg + } + ) + ) + | pkg <- prePkgDeps + ] + `Map.union` Map.fromListWith + Map.union + [ (pkg, Map.singleton (ann_cname aid) aid) + | PromisedComponent pkg aid <- promisedPkgDeps + ] + graph1 <- + toConfiguredComponents + use_external_internal_deps + flags + deterministic + ipid_flag + cid_flag + pkg_descr + conf_pkg_map + (map fst graph0) + infoProgress $ + hang + (text "Configured component graph:") + 4 + (vcat (map dispConfiguredComponent graph1)) - let shape_pkg_map = Map.fromList + let shape_pkg_map = + Map.fromList [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg)) - | pkg <- prePkgDeps] + | pkg <- prePkgDeps + ] + `Map.union` Map.fromList + [ ( ann_id aid + , + ( DefiniteUnitId + ( unsafeMkDefUnitId + (mkUnitId (unComponentId (ann_id aid))) + ) + , emptyModuleShape + ) + ) + | PromisedComponent _ aid <- promisedPkgDeps + ] uid_lookup def_uid - | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid - = FullUnitId (Installed.installedComponentId pkg) - (Map.fromList (Installed.instantiatedWith pkg)) - | otherwise = error ("uid_lookup: " ++ prettyShow uid) - where uid = unDefUnitId def_uid - graph2 <- toLinkedComponents verbosity uid_lookup - (package pkg_descr) shape_pkg_map graph1 + | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid = + FullUnitId + (Installed.installedComponentId pkg) + (Map.fromList (Installed.instantiatedWith pkg)) + | otherwise = error ("uid_lookup: " ++ prettyShow uid) + where + uid = unDefUnitId def_uid + graph2 <- + toLinkedComponents + verbosity + (not (null promisedPkgDeps)) + uid_lookup + (package pkg_descr) + shape_pkg_map + graph1 infoProgress $ - hang (text "Linked component graph:") 4 - (vcat (map dispLinkedComponent graph2)) + hang + (text "Linked component graph:") + 4 + (vcat (map dispLinkedComponent graph2)) - let pid_map = Map.fromList $ + let pid_map = + Map.fromList $ [ (pc_uid pkg, pc_munged_id pkg) - | pkg <- prePkgDeps] ++ - [ (Installed.installedUnitId pkg, mungedId pkg) - | (_, Module uid _) <- instantiate_with - , Just pkg <- [PackageIndex.lookupUnitId - installedPackageSet (unDefUnitId uid)] ] + | pkg <- prePkgDeps + ] + ++ [ (Installed.installedUnitId pkg, mungedId pkg) + | (_, Module uid _) <- instantiate_with + , Just pkg <- + [ PackageIndex.lookupUnitId + installedPackageSet + (unDefUnitId uid) + ] + ] subst = Map.fromList instantiate_with graph3 = toReadyComponents pid_map subst graph2 graph4 = Graph.revTopSort (Graph.fromDistinctList graph3) - infoProgress $ hang (text "Ready component graph:") 4 - (vcat (map dispReadyComponent graph4)) + infoProgress $ + hang + (text "Ready component graph:") + 4 + (vcat (map dispReadyComponent graph4)) - toComponentLocalBuildInfos comp installedPackageSet pkg_descr prePkgDeps graph4 + toComponentLocalBuildInfos comp installedPackageSet promisedPkgDeps pkg_descr prePkgDeps graph4 ------------------------------------------------------------------------------ -- ComponentLocalBuildInfo ------------------------------------------------------------------------------ toComponentLocalBuildInfos - :: Compiler - -> InstalledPackageIndex -- FULL set - -> PackageDescription - -> [PreExistingComponent] -- external package deps - -> [ReadyComponent] - -> LogProgress ([ComponentLocalBuildInfo], - InstalledPackageIndex) -- only relevant packages + :: Compiler + -> InstalledPackageIndex -- FULL set + -> [PromisedComponent] + -> PackageDescription + -> [PreExistingComponent] -- external package deps + -> [ReadyComponent] + -> LogProgress + ( [ComponentLocalBuildInfo] + , InstalledPackageIndex -- only relevant packages + ) toComponentLocalBuildInfos - comp installedPackageSet pkg_descr externalPkgDeps graph = do + comp + installedPackageSet + promisedPkgDeps + pkg_descr + externalPkgDeps + graph = do -- Check and make sure that every instantiated component exists. -- We have to do this now, because prior to linking/instantiating -- we don't actually know what the full set of 'UnitId's we need -- are. - let -- TODO: This is actually a bit questionable performance-wise, - -- since we will pay for the ALL installed packages even if - -- they are not related to what we are building. This was true - -- in the old configure code. - external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) - external_graph = Graph.fromDistinctList - . map Left - $ PackageIndex.allPackages installedPackageSet - internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) - internal_graph = Graph.fromDistinctList - . map Right - $ graph - combined_graph = Graph.unionRight external_graph internal_graph - local_graph = fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") - $ Graph.closure combined_graph (map nodeKey graph) - -- The database of transitively reachable installed packages that the - -- external components the package (as a whole) depends on. This will be - -- used in several ways: - -- - -- * We'll use it to do a consistency check so we're not depending - -- on multiple versions of the same package (TODO: someday relax - -- this for private dependencies.) See right below. - -- - -- * We'll pass it on in the LocalBuildInfo, where preprocessors - -- and other things will incorrectly use it to determine what - -- the include paths and everything should be. - -- - packageDependsIndex = PackageIndex.fromList (lefts local_graph) - fullIndex = Graph.fromDistinctList local_graph + let + -- TODO: This is actually a bit questionable performance-wise, + -- since we will pay for the ALL installed packages even if + -- they are not related to what we are building. This was true + -- in the old configure code. + external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + external_graph = + Graph.fromDistinctList + . map Left + $ PackageIndex.allPackages installedPackageSet + internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + internal_graph = + Graph.fromDistinctList + . map Right + $ graph + combined_graph = Graph.unionRight external_graph internal_graph + local_graph = + fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") $ + Graph.closure combined_graph (map nodeKey graph) + -- The database of transitively reachable installed packages that the + -- external components the package (as a whole) depends on. This will be + -- used in several ways: + -- + -- * We'll use it to do a consistency check so we're not depending + -- on multiple versions of the same package (TODO: someday relax + -- this for private dependencies.) See right below. + -- + -- * We'll pass it on in the LocalBuildInfo, where preprocessors + -- and other things will incorrectly use it to determine what + -- the include paths and everything should be. + -- + packageDependsIndex = PackageIndex.fromList (lefts local_graph) + fullIndex = Graph.fromDistinctList local_graph + case Graph.broken fullIndex of - [] -> return () - broken -> - -- 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 ] + [] -> return () + -- If there are promised dependencies, we don't know what the dependencies + -- of these are and that can easily lead to a broken graph. So assume that + -- any promised package is not broken (ie all its dependencies, transitively, + -- will be there). That's a promise. + 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 + ] -- In this section, we'd like to look at the 'packageDependsIndex' -- and see if we've picked multiple versions of the same @@ -213,25 +306,34 @@ -- -- TODO: This is probably wrong for Backpack let pseudoTopPkg :: InstalledPackageInfo - pseudoTopPkg = emptyInstalledPackageInfo { - Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr), - Installed.sourcePackageId = packageId pkg_descr, - Installed.depends = map pc_uid externalPkgDeps - } + pseudoTopPkg = + emptyInstalledPackageInfo + { Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr) + , Installed.sourcePackageId = packageId pkg_descr + , Installed.depends = map pc_uid externalPkgDeps + } case PackageIndex.dependencyInconsistencies - . PackageIndex.insert pseudoTopPkg - $ packageDependsIndex of + . PackageIndex.insert pseudoTopPkg + $ packageDependsIndex of [] -> return () inconsistencies -> warnProgress $ - hang (text "This package indirectly depends on multiple versions of the same" <+> - text "package. This is very likely to cause a compile failure.") 2 - (vcat [ text "package" <+> pretty (packageName user) <+> - parens (pretty (installedUnitId user)) <+> text "requires" <+> - pretty inst - | (_dep_key, insts) <- inconsistencies - , (inst, users) <- insts - , user <- users ]) + hang + ( text "This package indirectly depends on multiple versions of the same" + <+> text "package. This is very likely to cause a compile failure." + ) + 2 + ( vcat + [ text "package" + <+> pretty (packageName user) + <+> parens (pretty (installedUnitId user)) + <+> text "requires" + <+> pretty inst + | (_dep_key, insts) <- inconsistencies + , (inst, users) <- insts + , user <- users + ] + ) let clbis = mkLinkedComponentsLocalBuildInfo comp graph -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps) return (clbis, packageDependsIndex) @@ -241,119 +343,124 @@ -- -- This conversion is lossy; we lose some invariants from ReadyComponent mkLinkedComponentsLocalBuildInfo - :: Compiler - -> [ReadyComponent] - -> [ComponentLocalBuildInfo] + :: Compiler + -> [ReadyComponent] + -> [ComponentLocalBuildInfo] mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs where internalUnits = Set.fromList (map rc_uid rcs) isInternal x = Set.member x internalUnits go rc = case rc_component rc of - CLib lib -> - let convModuleExport (modname', (Module uid modname)) - | this_uid == unDefUnitId uid - , modname' == modname - = Installed.ExposedModule modname' Nothing - | otherwise - = Installed.ExposedModule modname' - (Just (OpenModule (DefiniteUnitId uid) modname)) - convOpenModuleExport (modname', modu@(OpenModule uid modname)) - | uid == this_open_uid - , modname' == modname - = Installed.ExposedModule modname' Nothing - | otherwise - = Installed.ExposedModule modname' (Just modu) - convOpenModuleExport (_, OpenModuleVar _) - = error "convOpenModuleExport: top-level modvar" - exports = + CLib lib -> + let convModuleExport (modname', (Module uid modname)) + | this_uid == unDefUnitId uid + , modname' == modname = + Installed.ExposedModule modname' Nothing + | otherwise = + Installed.ExposedModule + modname' + (Just (OpenModule (DefiniteUnitId uid) modname)) + convOpenModuleExport (modname', modu@(OpenModule uid modname)) + | uid == this_open_uid + , modname' == modname = + Installed.ExposedModule modname' Nothing + | otherwise = + Installed.ExposedModule modname' (Just modu) + convOpenModuleExport (_, OpenModuleVar _) = + error "convOpenModuleExport: top-level modvar" + exports = -- Loses invariants case rc_i rc of - Left indefc -> map convOpenModuleExport - $ Map.toList (indefc_provides indefc) - Right instc -> map convModuleExport - $ Map.toList (instc_provides instc) - insts = + Left indefc -> + map convOpenModuleExport $ + Map.toList (indefc_provides indefc) + Right instc -> + map convModuleExport $ + Map.toList (instc_provides instc) + insts = case rc_i rc of - Left indefc -> [ (m, OpenModuleVar m) | m <- indefc_requires indefc ] - Right instc -> [ (m, OpenModule (DefiniteUnitId uid') m') - | (m, Module uid' m') <- instc_insts instc ] - - compat_name = MungedPackageName (packageName rc) (libName lib) - compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid + Left indefc -> [(m, OpenModuleVar m) | m <- indefc_requires indefc] + Right instc -> + [ (m, OpenModule (DefiniteUnitId uid') m') + | (m, Module uid' m') <- instc_insts instc + ] - in LibComponentLocalBuildInfo { - componentPackageDeps = cpds, - componentUnitId = this_uid, - componentComponentId = this_cid, - componentInstantiatedWith = insts, - componentIsIndefinite_ = is_indefinite, - componentLocalName = cname, - componentInternalDeps = internal_deps, - componentExeDeps = exe_deps, - componentIncludes = includes, - componentExposedModules = exports, - componentIsPublic = rc_public rc, - componentCompatPackageKey = compat_key, - componentCompatPackageName = compat_name - } - CFLib _ -> - FLibComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - CExe _ -> - ExeComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - CTest _ -> - TestComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - CBench _ -> - BenchComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - where - this_uid = rc_uid rc - this_open_uid = rc_open_uid rc - this_cid = rc_cid rc - cname = componentName (rc_component rc) - cpds = rc_depends rc - exe_deps = map ann_id $ rc_exe_deps rc - is_indefinite = - case rc_i rc of + compat_name = MungedPackageName (packageName rc) (libName lib) + compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid + in LibComponentLocalBuildInfo + { componentPackageDeps = cpds + , componentUnitId = this_uid + , componentComponentId = this_cid + , componentInstantiatedWith = insts + , componentIsIndefinite_ = is_indefinite + , componentLocalName = cname + , componentInternalDeps = internal_deps + , componentExeDeps = exe_deps + , componentIncludes = includes + , componentExposedModules = exports + , componentIsPublic = rc_public rc + , componentCompatPackageKey = compat_key + , componentCompatPackageName = compat_name + } + CFLib _ -> + FLibComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + CExe _ -> + ExeComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + CTest _ -> + TestComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + CBench _ -> + BenchComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + where + this_uid = rc_uid rc + this_open_uid = rc_open_uid rc + this_cid = rc_cid rc + cname = componentName (rc_component rc) + cpds = rc_depends rc + exe_deps = map ann_id $ rc_exe_deps rc + is_indefinite = + case rc_i rc of Left _ -> True Right _ -> False - includes = - map (\ci -> (ci_id ci, ci_renaming ci)) $ + includes = + map (\ci -> (ci_id ci, ci_renaming ci)) $ case rc_i rc of - Left indefc -> - indefc_includes indefc - Right instc -> - map (\ci -> ci { ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci) }) - (instc_includes instc) - internal_deps = filter isInternal (nodeNeighbors rc) + Left indefc -> + indefc_includes indefc + Right instc -> + map + (\ci -> ci{ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci)}) + (instc_includes instc) + internal_deps = filter isInternal (nodeNeighbors rc) diff --git a/src/Distribution/Backpack/ConfiguredComponent.hs b/src/Distribution/Backpack/ConfiguredComponent.hs --- a/src/Distribution/Backpack/ConfiguredComponent.hs +++ b/src/Distribution/Backpack/ConfiguredComponent.hs @@ -1,80 +1,68 @@ {-# LANGUAGE PatternGuards #-} --- | See -module Distribution.Backpack.ConfiguredComponent ( - ConfiguredComponent(..), - cc_name, - cc_cid, - cc_pkgid, - toConfiguredComponent, - toConfiguredComponents, - dispConfiguredComponent, - ConfiguredComponentMap, - extendConfiguredComponentMap, - - -- TODO: Should go somewhere else - newPackageDepsBehaviour -) where +-- | See +module Distribution.Backpack.ConfiguredComponent + ( ConfiguredComponent (..) + , cc_name + , cc_cid + , cc_pkgid + , toConfiguredComponent + , toConfiguredComponents + , dispConfiguredComponent + , ConfiguredComponentMap + , extendConfiguredComponentMap + -- TODO: Should go somewhere else + , newPackageDepsBehaviour + ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () import Distribution.Backpack.Id import Distribution.CabalSpecVersion -import Distribution.Types.AnnotatedId -import Distribution.Types.Dependency -import Distribution.Types.ExeDependency -import Distribution.Types.IncludeRenaming -import Distribution.Types.ComponentId -import Distribution.Types.PackageId -import Distribution.Types.PackageName -import Distribution.Types.Mixin -import Distribution.Types.ComponentName -import Distribution.Types.LibraryName -import Distribution.Types.ComponentInclude import Distribution.Package import Distribution.PackageDescription import Distribution.Simple.BuildToolDepends -import Distribution.Simple.Setup as Setup +import Distribution.Simple.Flag (Flag) import Distribution.Simple.LocalBuildInfo +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentInclude +import Distribution.Utils.Generic import Distribution.Utils.LogProgress import Distribution.Utils.MapAccum -import Distribution.Utils.Generic import Control.Monad +import qualified Data.Map as Map import qualified Data.Set as Set import qualified Distribution.Compat.NonEmptySet as NonEmptySet -import qualified Data.Map as Map import Distribution.Pretty -import Text.PrettyPrint (Doc, hang, text, vcat, hsep, quotes, ($$)) +import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($$)) import qualified Text.PrettyPrint as PP -- | A configured component, we know exactly what its 'ComponentId' is, -- and the 'ComponentId's of the things it depends on. -data ConfiguredComponent - = ConfiguredComponent { - -- | Unique identifier of component, plus extra useful info. - cc_ann_id :: AnnotatedId ComponentId, - -- | The fragment of syntax from the Cabal file describing this - -- component. - cc_component :: Component, - -- | Is this the public library component of the package? - -- (If we invoke Setup with an instantiation, this is the - -- component the instantiation applies to.) - -- Note that in one-component configure mode, this is - -- always True, because any component is the "public" one.) - cc_public :: Bool, - -- | Dependencies on executables from @build-tools@ and - -- @build-tool-depends@. - cc_exe_deps :: [AnnotatedId ComponentId], - -- | The mixins of this package, including both explicit (from - -- the @mixins@ field) and implicit (from @build-depends@). Not - -- mix-in linked yet; component configuration only looks at - -- 'ComponentId's. - cc_includes :: [ComponentInclude ComponentId IncludeRenaming] - } - +data ConfiguredComponent = ConfiguredComponent + { cc_ann_id :: AnnotatedId ComponentId + -- ^ Unique identifier of component, plus extra useful info. + , cc_component :: Component + -- ^ The fragment of syntax from the Cabal file describing this + -- component. + , cc_public :: Bool + -- ^ Is this the public library component of the package? + -- (If we invoke Setup with an instantiation, this is the + -- component the instantiation applies to.) + -- Note that in one-component configure mode, this is + -- always True, because any component is the "public" one.) + , cc_exe_deps :: [AnnotatedId ComponentId] + -- ^ Dependencies on executables from @build-tools@ and + -- @build-tool-depends@. + , cc_includes :: [ComponentInclude ComponentId IncludeRenaming] + -- ^ The mixins of this package, including both explicit (from + -- the @mixins@ field) and implicit (from @build-depends@). Not + -- mix-in linked yet; component configuration only looks at + -- 'ComponentId's. + } -- | Uniquely identifies a configured component. cc_cid :: ConfiguredComponent -> ComponentId @@ -93,110 +81,132 @@ -- | Pretty-print a 'ConfiguredComponent'. dispConfiguredComponent :: ConfiguredComponent -> Doc dispConfiguredComponent cc = - hang (text "component" <+> pretty (cc_cid cc)) 4 - (vcat [ hsep $ [ text "include" - , pretty (ci_id incl), pretty (ci_renaming incl) ] - | incl <- cc_includes cc - ]) + hang + (text "component" <+> pretty (cc_cid cc)) + 4 + ( vcat + [ hsep $ + [ text "include" + , pretty (ci_id incl) + , pretty (ci_renaming incl) + ] + | incl <- cc_includes cc + ] + ) -- | Construct a 'ConfiguredComponent', given that the 'ComponentId' -- and library/executable dependencies are known. The primary -- work this does is handling implicit @backpack-include@ fields. mkConfiguredComponent - :: PackageDescription - -> ComponentId - -> [AnnotatedId ComponentId] -- lib deps - -> [AnnotatedId ComponentId] -- exe deps - -> Component - -> LogProgress ConfiguredComponent + :: PackageDescription + -> ComponentId + -> [AnnotatedId ComponentId] -- lib deps + -> [AnnotatedId ComponentId] -- exe deps + -> Component + -> LogProgress ConfiguredComponent mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do - -- Resolve each @mixins@ into the actual dependency - -- from @lib_deps@. - explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do - aid <- case Map.lookup (pn, CLibName ln) deps_map of - Nothing -> - dieProgress $ - text "Mix-in refers to non-existent library" <+> - quotes (pretty pn <<>> prettyLN ln) $$ - text "(did you forget to add the package to build-depends?)" - Just r -> return r - return ComponentInclude { - ci_ann_id = aid, - ci_renaming = rns, - ci_implicit = False - } + -- Resolve each @mixins@ into the actual dependency + -- from @lib_deps@. + explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do + aid <- case Map.lookup (pn, CLibName ln) deps_map of + Nothing -> + dieProgress $ + text "Mix-in refers to non-existent library" + <+> quotes (pretty pn <<>> prettyLN ln) + $$ text "(did you forget to add the package to build-depends?)" + Just r -> return r + return + ComponentInclude + { ci_ann_id = aid + , ci_renaming = rns + , ci_implicit = False + } - -- Any @build-depends@ which is not explicitly mentioned in - -- @backpack-include@ is converted into an "implicit" include. - let used_explicitly = Set.fromList (map ci_id explicit_includes) - implicit_includes - = map (\aid -> ComponentInclude { - ci_ann_id = aid, - ci_renaming = defaultIncludeRenaming, - ci_implicit = True - }) - $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps + -- Any @build-depends@ which is not explicitly mentioned in + -- @backpack-include@ is converted into an "implicit" include. + let used_explicitly = Set.fromList (map ci_id explicit_includes) + implicit_includes = + map + ( \aid -> + ComponentInclude + { ci_ann_id = aid + , ci_renaming = defaultIncludeRenaming + , ci_implicit = True + } + ) + $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps - return ConfiguredComponent { - cc_ann_id = AnnotatedId { - ann_id = this_cid, - ann_pid = package pkg_descr, - ann_cname = componentName component - }, - cc_component = component, - cc_public = is_public, - cc_exe_deps = exe_deps, - cc_includes = explicit_includes ++ implicit_includes - } + return + ConfiguredComponent + { cc_ann_id = + AnnotatedId + { ann_id = this_cid + , ann_pid = package pkg_descr + , ann_cname = componentName component + } + , cc_component = component + , cc_public = is_public + , cc_exe_deps = exe_deps + , cc_includes = explicit_includes ++ implicit_includes + } where bi :: BuildInfo bi = componentBuildInfo component prettyLN :: LibraryName -> Doc - prettyLN LMainLibName = PP.empty + prettyLN LMainLibName = PP.empty prettyLN (LSubLibName n) = PP.colon <<>> pretty n deps_map :: Map (PackageName, ComponentName) (AnnotatedId ComponentId) - deps_map = Map.fromList [ ((packageName dep, ann_cname dep), dep) - | dep <- lib_deps ] + deps_map = + Map.fromList + [ ((packageName dep, ann_cname dep), dep) + | dep <- lib_deps + ] is_public = componentName component == CLibName LMainLibName type ConfiguredComponentMap = - Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + Map PackageName (Map ComponentName (AnnotatedId ComponentId)) toConfiguredComponent - :: PackageDescription - -> ComponentId - -> ConfiguredComponentMap - -> ConfiguredComponentMap - -> Component - -> LogProgress ConfiguredComponent + :: PackageDescription + -> ComponentId + -> ConfiguredComponentMap + -> ConfiguredComponentMap + -> Component + -> LogProgress ConfiguredComponent toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do - lib_deps <- - if newPackageDepsBehaviour pkg_descr - then fmap concat $ forM (targetBuildDepends bi) $ - \(Dependency name _ sublibs) -> do - pkg <- case Map.lookup name lib_dep_map of + lib_deps <- + if newPackageDepsBehaviour pkg_descr + then fmap concat $ + forM (targetBuildDepends bi) $ + \(Dependency name _ sublibs) -> do + case Map.lookup name lib_dep_map of + Nothing -> + dieProgress $ + text "Dependency on unbuildable" + <+> text "package" + <+> pretty name + Just pkg -> do + -- Return all library components + forM (NonEmptySet.toList sublibs) $ \lib -> + let comp = CLibName lib + in case Map.lookup comp pkg of Nothing -> - dieProgress $ - text "Dependency on unbuildable" <+> - text "package" <+> pretty name - Just p -> return p - -- Return all library components - forM (NonEmptySet.toList sublibs) $ \lib -> - let comp = CLibName lib in - case Map.lookup comp pkg of - Nothing -> - dieProgress $ - text "Dependency on unbuildable" <+> - text (showLibraryName lib) <+> - text "from" <+> pretty name - Just v -> return v - else return old_style_lib_deps - mkConfiguredComponent - pkg_descr this_cid - lib_deps exe_deps component + dieProgress $ + text "Dependency on unbuildable" + <+> text (showLibraryName lib) + <+> text "from" + <+> pretty name + Just v -> return v + else return old_style_lib_deps + mkConfiguredComponent + pkg_descr + this_cid + lib_deps + exe_deps + component where bi = componentBuildInfo component -- lib_dep_map contains a mix of internal and external deps. @@ -206,62 +216,84 @@ -- this is not supported by old-style deps behavior -- because it would imply a cyclic dependency for the -- library itself. - old_style_lib_deps = [ e - | (pn, comp_map) <- Map.toList lib_dep_map - , pn /= packageName pkg_descr - , (cn, e) <- Map.toList comp_map - , cn == CLibName LMainLibName ] + old_style_lib_deps = + [ e + | (pn, comp_map) <- Map.toList lib_dep_map + , pn /= packageName pkg_descr + , (cn, e) <- Map.toList comp_map + , cn == CLibName LMainLibName + ] -- We have to nub here, because 'getAllToolDependencies' may return -- duplicates (see #4986). (NB: This is not needed for lib_deps, -- since those elaborate into includes, for which there explicitly -- may be multiple instances of a package) - exe_deps = ordNub $ + exe_deps = + ordNub $ [ exe | ExeDependency pn cn _ <- getAllToolDependencies pkg_descr bi - -- The error suppression here is important, because in general + , -- The error suppression here is important, because in general -- we won't know about external dependencies (e.g., 'happy') -- which the package is attempting to use (those deps are only -- fed in when cabal-install uses this codepath.) -- TODO: Let cabal-install request errors here - , Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map] + Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map] ] -- | Also computes the 'ComponentId', and sets cc_public if necessary. -- This is Cabal-only; cabal-install won't use this. toConfiguredComponent' - :: Bool -- use_external_internal_deps - -> FlagAssignment - -> PackageDescription - -> Bool -- deterministic - -> Flag String -- configIPID (todo: remove me) - -> Flag ComponentId -- configCID - -> ConfiguredComponentMap - -> Component - -> LogProgress ConfiguredComponent -toConfiguredComponent' use_external_internal_deps flags - pkg_descr deterministic ipid_flag cid_flag - dep_map component = do - cc <- toConfiguredComponent - pkg_descr this_cid - dep_map dep_map component - return $ if use_external_internal_deps - then cc { cc_public = True } - else cc - where - -- TODO: pass component names to it too! - this_cid = computeComponentId deterministic ipid_flag cid_flag - (package pkg_descr) (componentName component) (Just (deps, flags)) - deps = [ ann_id aid | m <- Map.elems dep_map - , aid <- Map.elems m ] + :: Bool -- use_external_internal_deps + -> FlagAssignment + -> PackageDescription + -> Bool -- deterministic + -> Flag String -- configIPID (todo: remove me) + -> Flag ComponentId -- configCID + -> ConfiguredComponentMap + -> Component + -> LogProgress ConfiguredComponent +toConfiguredComponent' + use_external_internal_deps + flags + pkg_descr + deterministic + ipid_flag + cid_flag + dep_map + component = do + cc <- + toConfiguredComponent + pkg_descr + this_cid + dep_map + dep_map + component + return $ + if use_external_internal_deps + then cc{cc_public = True} + else cc + where + -- TODO: pass component names to it too! + this_cid = + computeComponentId + deterministic + ipid_flag + cid_flag + (package pkg_descr) + (componentName component) + (Just (deps, flags)) + deps = + [ ann_id aid | m <- Map.elems dep_map, aid <- Map.elems m + ] extendConfiguredComponentMap - :: ConfiguredComponent - -> ConfiguredComponentMap - -> ConfiguredComponentMap + :: ConfiguredComponent + -> ConfiguredComponentMap + -> ConfiguredComponentMap extendConfiguredComponentMap cc = - Map.insertWith Map.union - (pkgName (cc_pkgid cc)) - (Map.singleton (cc_name cc) (cc_ann_id cc)) + Map.insertWith + Map.union + (pkgName (cc_pkgid cc)) + (Map.singleton (cc_name cc) (cc_ann_id cc)) -- Compute the 'ComponentId's for a graph of 'Component's. The -- list of internal components must be topologically sorted @@ -273,31 +305,42 @@ -- be used to configure a component that depends on one version of a package for -- a library and another version for a build-tool. toConfiguredComponents - :: Bool -- use_external_internal_deps - -> FlagAssignment - -> Bool -- deterministic - -> Flag String -- configIPID - -> Flag ComponentId -- configCID - -> PackageDescription - -> ConfiguredComponentMap - -> [Component] - -> LogProgress [ConfiguredComponent] + :: Bool -- use_external_internal_deps + -> FlagAssignment + -> Bool -- deterministic + -> Flag String -- configIPID + -> Flag ComponentId -- configCID + -> PackageDescription + -> ConfiguredComponentMap + -> [Component] + -> LogProgress [ConfiguredComponent] toConfiguredComponents - use_external_internal_deps flags deterministic ipid_flag cid_flag pkg_descr - dep_map comps - = fmap snd (mapAccumM go dep_map comps) - where - go m component = do - cc <- toConfiguredComponent' - use_external_internal_deps flags pkg_descr - deterministic ipid_flag cid_flag - m component + use_external_internal_deps + flags + deterministic + ipid_flag + cid_flag + pkg_descr + dep_map + comps = + fmap snd (mapAccumM go dep_map comps) + where + go m component = do + cc <- + toConfiguredComponent' + use_external_internal_deps + flags + pkg_descr + deterministic + ipid_flag + cid_flag + m + component return (extendConfiguredComponentMap cc m, cc) newPackageDepsBehaviourMinVersion :: CabalSpecVersion newPackageDepsBehaviourMinVersion = CabalSpecV1_8 - -- In older cabal versions, there was only one set of package dependencies for -- the whole package. In this version, we can have separate dependencies per -- target, but we only enable this behaviour if the minimum cabal version @@ -305,4 +348,4 @@ -- old behaviour. newPackageDepsBehaviour :: PackageDescription -> Bool newPackageDepsBehaviour pkg = - specVersion pkg >= newPackageDepsBehaviourMinVersion + specVersion pkg >= newPackageDepsBehaviourMinVersion diff --git a/src/Distribution/Backpack/DescribeUnitId.hs b/src/Distribution/Backpack/DescribeUnitId.hs --- a/src/Distribution/Backpack/DescribeUnitId.hs +++ b/src/Distribution/Backpack/DescribeUnitId.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types #-} + module Distribution.Backpack.DescribeUnitId where import Distribution.Compat.Prelude @@ -36,26 +37,36 @@ -- | Print a Setup message stating (1) what operation we are doing, -- for (2) which component (with enough details to uniquely identify -- the build in question.) --- -setupMessage' :: Pretty a => Verbosity - -> String -- ^ Operation being done (capitalized), on: - -> PackageIdentifier -- ^ Package - -> ComponentName -- ^ Component name - -> Maybe [(ModuleName, a)] -- ^ Instantiation, if available. - -- Polymorphic to take - -- 'OpenModule' or 'Module' - -> IO () +setupMessage' + :: Pretty a + => Verbosity + -> String + -- ^ Operation being done (capitalized), on: + -> PackageIdentifier + -- ^ Package + -> ComponentName + -- ^ Component name + -> Maybe [(ModuleName, a)] + -- ^ Instantiation, if available. + -- Polymorphic to take + -- 'OpenModule' or 'Module' + -> IO () setupMessage' verbosity msg pkgid cname mb_insts = withFrozenCallStack $ do - noticeDoc verbosity $ - case mb_insts of - Just insts | not (null insts) -> - hang (msg_doc <+> text "instantiated with") 2 - (vcat [ pretty k <+> text "=" <+> pretty v - | (k,v) <- insts ]) $$ - for_doc - _ -> - msg_doc <+> for_doc - + noticeDoc verbosity $ + case mb_insts of + Just insts + | not (null insts) -> + hang + (msg_doc <+> text "instantiated with") + 2 + ( vcat + [ pretty k <+> text "=" <+> pretty v + | (k, v) <- insts + ] + ) + $$ for_doc + _ -> + msg_doc <+> for_doc where msg_doc = text msg <+> text (showComponentName cname) - for_doc = text "for" <+> pretty pkgid <<>> text ".." + for_doc = text "for" <+> pretty pkgid <<>> text "..." diff --git a/src/Distribution/Backpack/FullUnitId.hs b/src/Distribution/Backpack/FullUnitId.hs --- a/src/Distribution/Backpack/FullUnitId.hs +++ b/src/Distribution/Backpack/FullUnitId.hs @@ -1,26 +1,27 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Backpack.FullUnitId ( - FullUnitId(..), - FullDb, - expandOpenUnitId, - expandUnitId -) where +module Distribution.Backpack.FullUnitId + ( FullUnitId (..) + , FullDb + , expandOpenUnitId + , expandUnitId + ) where + import Distribution.Backpack -import Distribution.Types.ComponentId import Distribution.Compat.Prelude +import Distribution.Types.ComponentId -- Unlike OpenUnitId, which could direct to a UnitId. data FullUnitId = FullUnitId ComponentId OpenModuleSubst - deriving (Show, Generic) + deriving (Show, Generic) type FullDb = DefUnitId -> FullUnitId expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId -expandOpenUnitId _db (IndefFullUnitId cid subst) - = FullUnitId cid subst -expandOpenUnitId db (DefiniteUnitId uid) - = expandUnitId db uid +expandOpenUnitId _db (IndefFullUnitId cid subst) = + FullUnitId cid subst +expandOpenUnitId db (DefiniteUnitId uid) = + expandUnitId db uid expandUnitId :: FullDb -> DefUnitId -> FullUnitId expandUnitId db uid = db uid 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,74 +1,86 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} + -- | See -module Distribution.Backpack.Id( - computeComponentId, - computeCompatPackageKey, -) where +module Distribution.Backpack.Id + ( computeComponentId + , computeCompatPackageKey + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName -import Distribution.Simple.Compiler import Distribution.PackageDescription -import Distribution.Simple.Setup as Setup +import Distribution.Simple.Compiler +import Distribution.Simple.Flag (Flag (..)) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo import Distribution.Types.ComponentId -import Distribution.Types.UnitId import Distribution.Types.MungedPackageName +import Distribution.Types.UnitId import Distribution.Utils.Base62 import Distribution.Version +import Distribution.Parsec (simpleParsec) import Distribution.Pretty - ( prettyShow ) -import Distribution.Parsec ( simpleParsec ) + ( prettyShow + ) -- | This method computes a default, "good enough" 'ComponentId' -- for a package. The intent is that cabal-install (or the user) will -- specify a more detailed IPID via the @--ipid@ flag if necessary. computeComponentId - :: Bool -- deterministic mode - -> Flag String - -> Flag ComponentId - -> PackageIdentifier - -> ComponentName - -- This is used by cabal-install's legacy codepath - -> Maybe ([ComponentId], FlagAssignment) - -> ComponentId + :: Bool -- deterministic mode + -> Flag String + -> Flag ComponentId + -> PackageIdentifier + -> ComponentName + -- This is used by cabal-install's legacy codepath + -> Maybe ([ComponentId], FlagAssignment) + -> ComponentId computeComponentId deterministic mb_ipid mb_cid pid cname mb_details = - -- show is found to be faster than intercalate and then replacement of - -- special character used in intercalating. We cannot simply hash by - -- doubly concatenating list, as it just flatten out the nested list, so - -- different sources can produce same hash - let hash_suffix - | Just (dep_ipids, flags) <- mb_details - = "-" ++ hashToBase62 + -- show is found to be faster than intercalate and then replacement of + -- special character used in intercalating. We cannot simply hash by + -- doubly concatenating list, as it just flatten out the nested list, so + -- different sources can produce same hash + let hash_suffix + | Just (dep_ipids, flags) <- mb_details = + "-" + ++ hashToBase62 -- For safety, include the package + version here -- for GHC 7.10, where just the hash is used as -- the package key - ( prettyShow pid - ++ show dep_ipids - ++ show flags ) - | otherwise = "" - generated_base = prettyShow pid ++ hash_suffix - explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env - (toPathTemplate cid0)) - -- Hack to reuse install dirs machinery - -- NB: no real IPID available at this point - where env = packageTemplateEnv pid (mkUnitId "") - actual_base = case mb_ipid of - Flag ipid0 -> explicit_base ipid0 - NoFlag | deterministic -> prettyShow pid - | otherwise -> generated_base - in case mb_cid of - Flag cid -> cid - NoFlag -> mkComponentId $ actual_base - ++ (case componentNameString cname of - Nothing -> "" - Just s -> "-" ++ unUnqualComponentName s) + ( prettyShow pid + ++ show dep_ipids + ++ show flags + ) + | otherwise = "" + generated_base = prettyShow pid ++ hash_suffix + explicit_base cid0 = + fromPathTemplate + ( InstallDirs.substPathTemplate + env + (toPathTemplate cid0) + ) + where + -- Hack to reuse install dirs machinery + -- NB: no real IPID available at this point + env = packageTemplateEnv pid (mkUnitId "") + actual_base = case mb_ipid of + Flag ipid0 -> explicit_base ipid0 + NoFlag + | deterministic -> prettyShow pid + | otherwise -> generated_base + in case mb_cid of + Flag cid -> cid + NoFlag -> + mkComponentId $ + actual_base + ++ ( case componentNameString cname of + Nothing -> "" + Just s -> "-" ++ unUnqualComponentName s + ) -- | In GHC 8.0, the string we pass to GHC to use for symbol -- names for a package can be an arbitrary, IPID-compatible string. @@ -116,30 +128,29 @@ -- -- * For sub-components, we rehash the IPID into the correct format -- and pass that. --- computeCompatPackageKey - :: Compiler - -> MungedPackageName - -> Version - -> UnitId - -> String + :: Compiler + -> MungedPackageName + -> Version + -> UnitId + -> String computeCompatPackageKey comp pkg_name pkg_version uid - | not (packageKeySupported comp || unitIdSupported comp) - = prettyShow pkg_name ++ "-" ++ prettyShow pkg_version - | not (unifiedIPIDRequired comp) = - let str = unUnitId uid -- assume no Backpack support - mb_verbatim_key - = case simpleParsec str :: Maybe PackageId of - -- Something like 'foo-0.1', use it verbatim. - -- (NB: hash tags look like tags, so they are parsed, - -- so the extra equality check tests if a tag was dropped.) - Just pid0 | prettyShow pid0 == str -> Just str - _ -> Nothing - mb_truncated_key - = let cand = reverse (takeWhile isAlphaNum (reverse str)) - in if length cand == 22 && all isAlphaNum cand - then Just cand - else Nothing - rehashed_key = hashToBase62 str - in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key) - | otherwise = prettyShow uid + | not (packageKeySupported comp || unitIdSupported comp) = + prettyShow pkg_name ++ "-" ++ prettyShow pkg_version + | not (unifiedIPIDRequired comp) = + let str = unUnitId uid -- assume no Backpack support + mb_verbatim_key = + case simpleParsec str :: Maybe PackageId of + -- Something like 'foo-0.1', use it verbatim. + -- (NB: hash tags look like tags, so they are parsed, + -- so the extra equality check tests if a tag was dropped.) + Just pid0 | prettyShow pid0 == str -> Just str + _ -> Nothing + mb_truncated_key = + let cand = reverse (takeWhile isAlphaNum (reverse str)) + in if length cand == 22 && all isAlphaNum cand + then Just cand + else Nothing + rehashed_key = hashToBase62 str + in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key) + | otherwise = prettyShow uid 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 @@ -1,82 +1,76 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} + -- | See -module Distribution.Backpack.LinkedComponent ( - LinkedComponent(..), - lc_insts, - lc_uid, - lc_cid, - lc_pkgid, - toLinkedComponent, - toLinkedComponents, - dispLinkedComponent, - LinkedComponentMap, - extendLinkedComponentMap, -) where +module Distribution.Backpack.LinkedComponent + ( LinkedComponent (..) + , lc_insts + , lc_uid + , lc_cid + , lc_pkgid + , toLinkedComponent + , toLinkedComponents + , dispLinkedComponent + , LinkedComponentMap + , extendLinkedComponentMap + ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () import Distribution.Backpack -import Distribution.Backpack.FullUnitId import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.MixLink +import Distribution.Backpack.ModuleScope import Distribution.Backpack.ModuleShape import Distribution.Backpack.PreModuleShape -import Distribution.Backpack.ModuleScope import Distribution.Backpack.UnifyM -import Distribution.Backpack.MixLink import Distribution.Utils.MapAccum -import Distribution.Types.AnnotatedId -import Distribution.Types.ComponentName -import Distribution.Types.ModuleReexport -import Distribution.Types.ModuleRenaming -import Distribution.Types.IncludeRenaming -import Distribution.Types.ComponentInclude -import Distribution.Types.ComponentId -import Distribution.Types.PackageId +import Distribution.ModuleName import Distribution.Package import Distribution.PackageDescription -import Distribution.ModuleName import Distribution.Simple.LocalBuildInfo -import Distribution.Verbosity +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentInclude import Distribution.Utils.LogProgress +import Distribution.Verbosity -import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.Set as Set import Distribution.Pretty (pretty) -import Text.PrettyPrint (Doc, hang, text, vcat, ($+$), hsep, quotes) +import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($+$)) -- | A linked component is a component that has been mix-in linked, at -- which point we have determined how all the dependencies of the -- component are explicitly instantiated (in the form of an OpenUnitId). -- 'ConfiguredComponent' is mix-in linked into 'LinkedComponent', which -- is then instantiated into 'ReadyComponent'. -data LinkedComponent - = LinkedComponent { - -- | Uniquely identifies linked component - lc_ann_id :: AnnotatedId ComponentId, - -- | Corresponds to 'cc_component'. - lc_component :: Component, - -- | @build-tools@ and @build-tool-depends@ dependencies. - -- Corresponds to 'cc_exe_deps'. - lc_exe_deps :: [AnnotatedId OpenUnitId], - -- | Is this the public library of a package? Corresponds to - -- 'cc_public'. - lc_public :: Bool, - -- | Corresponds to 'cc_includes', but (1) this does not contain - -- includes of signature packages (packages with no exports), - -- and (2) the 'ModuleRenaming' for requirements (stored in - -- 'IncludeRenaming') has been removed, as it is reflected in - -- 'OpenUnitId'.) - lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming], - -- | Like 'lc_includes', but this specifies includes on - -- signature packages which have no exports. - lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming], - -- | The module shape computed by mix-in linking. This is - -- newly computed from 'ConfiguredComponent' - lc_shape :: ModuleShape - } +data LinkedComponent = LinkedComponent + { lc_ann_id :: AnnotatedId ComponentId + -- ^ Uniquely identifies linked component + , lc_component :: Component + -- ^ Corresponds to 'cc_component'. + , lc_exe_deps :: [AnnotatedId OpenUnitId] + -- ^ @build-tools@ and @build-tool-depends@ dependencies. + -- Corresponds to 'cc_exe_deps'. + , lc_public :: Bool + -- ^ Is this the public library of a package? Corresponds to + -- 'cc_public'. + , lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] + -- ^ Corresponds to 'cc_includes', but (1) this does not contain + -- includes of signature packages (packages with no exports), + -- and (2) the 'ModuleRenaming' for requirements (stored in + -- 'IncludeRenaming') has been removed, as it is reflected in + -- 'OpenUnitId'.) + , lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming] + -- ^ Like 'lc_includes', but this specifies includes on + -- signature packages which have no exports. + , lc_shape :: ModuleShape + -- ^ The module shape computed by mix-in linking. This is + -- newly computed from 'ConfiguredComponent' + } -- | Uniquely identifies a 'LinkedComponent'. Corresponds to -- 'cc_cid'. @@ -96,94 +90,125 @@ -- | The instantiation of 'lc_uid'; this always has the invariant -- that it is a mapping from a module name @A@ to @@ (the hole A). lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)] -lc_insts lc = [ (req, OpenModuleVar req) - | req <- Set.toList (modShapeRequires (lc_shape lc)) ] +lc_insts lc = + [ (req, OpenModuleVar req) + | req <- Set.toList (modShapeRequires (lc_shape lc)) + ] dispLinkedComponent :: LinkedComponent -> Doc dispLinkedComponent lc = - hang (text "unit" <+> pretty (lc_uid lc)) 4 $ - vcat [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl) - | incl <- lc_includes lc ] - $+$ - vcat [ text "signature include" <+> pretty (ci_id incl) - | incl <- lc_sig_includes lc ] - $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc)) + hang (text "unit" <+> pretty (lc_uid lc)) 4 $ + vcat + [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl) + | incl <- lc_includes lc + ] + $+$ vcat + [ text "signature include" <+> pretty (ci_id incl) + | incl <- lc_sig_includes lc + ] + $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc)) instance Package LinkedComponent where - packageId = lc_pkgid + packageId = lc_pkgid toLinkedComponent - :: Verbosity - -> FullDb - -> PackageId - -> LinkedComponentMap - -> ConfiguredComponent - -> LogProgress LinkedComponent -toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { - cc_ann_id = aid@AnnotatedId { ann_id = this_cid }, - cc_component = component, - cc_exe_deps = exe_deps, - cc_public = is_public, - cc_includes = cid_includes - } = do + :: Verbosity + -> Bool + -- ^ Whether there are any "promised" package dependencies which we won't find already installed. + -> FullDb + -> PackageId + -> LinkedComponentMap + -> ConfiguredComponent + -> LogProgress LinkedComponent +toLinkedComponent + verbosity + anyPromised + db + this_pid + pkg_map + ConfiguredComponent + { cc_ann_id = aid@AnnotatedId{ann_id = this_cid} + , cc_component = component + , cc_exe_deps = exe_deps + , cc_public = is_public + , cc_includes = cid_includes + } = do let - -- The explicitly specified requirements, provisions and - -- reexports from the Cabal file. These are only non-empty for - -- libraries; everything else is trivial. - (src_reqs :: [ModuleName], - src_provs :: [ModuleName], - src_reexports :: [ModuleReexport]) = - case component of - CLib lib -> (signatures lib, - exposedModules lib, - reexportedModules lib) - _ -> ([], [], []) - src_hidden = otherModules (componentBuildInfo component) + -- The explicitly specified requirements, provisions and + -- reexports from the Cabal file. These are only non-empty for + -- libraries; everything else is trivial. + ( src_reqs :: [ModuleName] + , src_provs :: [ModuleName] + , src_reexports :: [ModuleReexport] + ) = + case component of + CLib lib -> + ( signatures lib + , exposedModules lib + , reexportedModules lib + ) + _ -> ([], [], []) + src_hidden = otherModules (componentBuildInfo component) - -- Take each included ComponentId and resolve it into an - -- *unlinked* unit identity. We will use unification (relying - -- on the ModuleShape) to resolve these into linked identities. - unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming] - unlinked_includes = [ ComponentInclude (fmap lookupUid dep_aid) rns i - | ComponentInclude dep_aid rns i <- cid_includes ] + -- Take each included ComponentId and resolve it into an + -- \*unlinked* unit identity. We will use unification (relying + -- on the ModuleShape) to resolve these into linked identities. + unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming] + unlinked_includes = + [ ComponentInclude (fmap lookupUid dep_aid) rns i + | ComponentInclude dep_aid rns i <- cid_includes + ] - lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) - lookupUid cid = fromMaybe (error "linkComponent: lookupUid") - (Map.lookup cid pkg_map) + lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) + lookupUid cid = + fromMaybe + (error "linkComponent: lookupUid") + (Map.lookup cid pkg_map) let orErr (Right x) = return x orErr (Left [err]) = dieProgress err orErr (Left errs) = do - dieProgress (vcat (intersperse (text "") -- double newline! - [ hang (text "-") 2 err | err <- errs])) + dieProgress + ( vcat + ( intersperse + (text "") -- double newline! + [hang (text "-") 2 err | err <- errs] + ) + ) -- Pre-shaping - let pre_shape = mixLinkPreModuleShape $ - PreModuleShape { - preModShapeProvides = Set.fromList (src_provs ++ src_hidden), - preModShapeRequires = Set.fromList src_reqs - } : [ renamePreModuleShape (toPreModuleShape sh) rns - | ComponentInclude (AnnotatedId { ann_id = (_, sh) }) rns _ <- unlinked_includes ] - reqs = preModShapeRequires pre_shape - insts = [ (req, OpenModuleVar req) - | req <- Set.toList reqs ] + let pre_shape = + mixLinkPreModuleShape $ + PreModuleShape + { preModShapeProvides = Set.fromList (src_provs ++ src_hidden) + , preModShapeRequires = Set.fromList src_reqs + } + : [ renamePreModuleShape (toPreModuleShape sh) rns + | ComponentInclude (AnnotatedId{ann_id = (_, sh)}) rns _ <- unlinked_includes + ] + reqs = preModShapeRequires pre_shape + insts = + [ (req, OpenModuleVar req) + | req <- Set.toList reqs + ] this_uid = IndefFullUnitId this_cid . Map.fromList $ insts -- OK, actually do unification -- TODO: the unification monad might return errors, in which -- case we have to deal. Use monadic bind for now. - (linked_shape0 :: ModuleScope, - linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming], - linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]) - <- orErr $ runUnifyM verbosity this_cid db $ do + ( linked_shape0 :: ModuleScope + , linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming] + , linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming] + ) <- + orErr $ runUnifyM verbosity this_cid db $ do -- The unification monad is implemented using mutable -- references. Thus, we must convert our *pure* data -- structures into mutable ones to perform unification. let convertMod :: (ModuleName -> ModuleSource) -> ModuleName -> UnifyM s (ModuleScopeU s) convertMod from m = do - m_u <- convertModule (OpenModule this_uid m) - return (Map.singleton m [WithSource (from m) m_u], Map.empty) + m_u <- convertModule (OpenModule this_uid m) + return (Map.singleton m [WithSource (from m) m_u], Map.empty) -- Handle 'exposed-modules' exposed_mod_shapes_u <- traverse (convertMod FromExposedModules) src_provs -- Handle 'other-modules' @@ -192,8 +217,8 @@ -- Handle 'signatures' let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s) convertReq req = do - req_u <- convertModule (OpenModuleVar req) - return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u]) + req_u <- convertModule (OpenModuleVar req) + return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u]) req_shapes_u <- traverse convertReq src_reqs -- Handle 'mixins' @@ -201,22 +226,26 @@ failIfErrs -- Prevent error cascade -- Mix-in link everything! mixLink is the real workhorse. - shape_u <- mixLink $ exposed_mod_shapes_u - ++ other_mod_shapes_u - ++ req_shapes_u - ++ incl_shapes_u + shape_u <- + mixLink $ + exposed_mod_shapes_u + ++ other_mod_shapes_u + ++ req_shapes_u + ++ incl_shapes_u -- src_reqs_u <- traverse convertReq src_reqs -- Read out all the final results by converting back -- into a pure representation. let convertIncludeU (ComponentInclude dep_aid rns i) = do - let component_name = pretty $ ann_cname dep_aid - uid <- convertUnitIdU (ann_id dep_aid) component_name - return (ComponentInclude { - ci_ann_id = dep_aid { ann_id = uid }, - ci_renaming = rns, - ci_implicit = i - }) + let component_name = pretty $ ann_cname dep_aid + uid <- convertUnitIdU (ann_id dep_aid) component_name + return + ( ComponentInclude + { ci_ann_id = dep_aid{ann_id = uid} + , ci_renaming = rns + , ci_implicit = i + } + ) shape <- convertModuleScopeU shape_u let (includes_u, sig_includes_u) = partitionEithers all_includes_u @@ -225,23 +254,26 @@ return (shape, incls, sig_incls) let isNotLib (CLib _) = False - isNotLib _ = True + isNotLib _ = True when (not (Set.null reqs) && isNotLib component) $ - dieProgress $ - hang (text "Non-library component has unfilled requirements:") - 4 (vcat [pretty req | req <- Set.toList reqs]) + dieProgress $ + hang + (text "Non-library component has unfilled requirements:") + 4 + (vcat [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 -- an 'InstalledPackageInfo' that violates abstraction.) -- Though, maybe it should be relaxed? let src_hidden_set = Set.fromList src_hidden - linked_shape = linked_shape0 { - modScopeProvides = + linked_shape = + linked_shape0 + { modScopeProvides = -- Would rather use withoutKeys but need BC Map.filterWithKey - (\k _ -> not (k `Set.member` src_hidden_set)) - (modScopeProvides linked_shape0) + (\k _ -> not (k `Set.member` src_hidden_set)) + (modScopeProvides linked_shape0) } -- OK, compute the reexports @@ -250,65 +282,102 @@ -- once. let hdl :: [Either Doc a] -> LogProgress [a] hdl es = - case partitionEithers es of - ([], rs) -> return rs - (ls, _) -> - dieProgress $ - hang (text "Problem with module re-exports:") 2 - (vcat [hang (text "-") 2 l | l <- ls]) + case partitionEithers es of + ([], rs) -> return rs + (ls, _) -> + dieProgress $ + hang + (text "Problem with module re-exports:") + 2 + (vcat [hang (text "-") 2 l | l <- ls]) reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do case Map.lookup from (modScopeProvides linked_shape) of - Just cands@(x0:xs0) -> do + Just cands@(x0 : xs0) -> do -- Make sure there is at least one candidate (x, xs) <- case mb_pn of Just pn -> - let matches_pn (FromMixins pn' _ _) = pn == pn' + let matches_pn (FromMixins pn' _ _) = pn == pn' matches_pn (FromBuildDepends pn' _) = pn == pn' matches_pn (FromExposedModules _) = pn == packageName this_pid - matches_pn (FromOtherModules _) = pn == packageName this_pid - matches_pn (FromSignatures _) = pn == packageName this_pid - in case filter (matches_pn . getSource) cands of - (x1:xs1) -> return (x1, xs1) - _ -> Left (brokenReexportMsg reex) + matches_pn (FromOtherModules _) = pn == packageName this_pid + matches_pn (FromSignatures _) = pn == packageName this_pid + in case filter (matches_pn . getSource) cands of + (x1 : xs1) -> return (x1, xs1) + _ -> Left (brokenReexportMsg reex) Nothing -> return (x0, xs0) -- Test that all the candidates are consistent case filter (\x' -> unWithSource x /= unWithSource x') xs of [] -> return () _ -> Left $ ambiguousReexportMsg reex x xs - return (to, unWithSource x) + return (to, Just (unWithSource x)) _ -> - Left (brokenReexportMsg reex) + -- Can't resolve it right now.. carry on with the assumption it will be resolved + -- dynamically later by an in-memory package which hasn't been installed yet. + if anyPromised + then return (to, Nothing) + else -- But if nothing is promised, eagerly report an error, as we already know everything. + Left (brokenReexportMsg reex) -- TODO: maybe check this earlier; it's syntactically obvious. let build_reexports m (k, v) - | Map.member k m = - dieProgress $ hsep - [ text "Module name ", pretty k, text " is exported multiple times." ] - | otherwise = return (Map.insert k v m) - provs <- foldM build_reexports Map.empty $ - -- TODO: doublecheck we have checked for - -- src_provs duplicates already! - [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++ - reexports_list + | Map.member k m = + dieProgress $ + hsep + [text "Module name ", pretty k, text " is exported multiple times."] + | otherwise = return (Map.insert k v m) + provs <- + foldM build_reexports Map.empty $ + -- 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] + ++ + -- These are reexports, which we managed to resolve to something in an external package. + [(mn_new, om) | (mn_new, Just om) <- reexports_list] + ++ + -- These ones.. we didn't resolve but also we might not have to + -- resolve them because they could come from a promised unit, + -- which we don't know anything about yet. GHC will resolve + -- these itself when it is dealing with the multi-session. + -- These ones will not be built, registered and put + -- into a package database, we only need them to make it as far + -- as generating GHC options where the info will be used to + -- pass the reexported-module option to GHC. + -- We also know that in the case there are promised units that + -- we will not be doing anything to do with backpack like + -- unification etc.. + [ ( mod_name + , OpenModule + ( DefiniteUnitId + ( unsafeMkDefUnitId + (mkUnitId "fake") + ) + ) + mod_name + ) + | (mod_name, Nothing) <- reexports_list + ] + let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape)) -- See Note Note [Signature package special case] let (linked_includes, linked_sig_includes) - | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, []) - | otherwise = (linked_includes0, linked_sig_includes0) + | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, []) + | otherwise = (linked_includes0, linked_sig_includes0) - return $ LinkedComponent { - lc_ann_id = aid, - lc_component = component, - lc_public = is_public, - -- These must be executables - lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps, - lc_shape = final_linked_shape, - lc_includes = linked_includes, - lc_sig_includes = linked_sig_includes - } + return $ + LinkedComponent + { lc_ann_id = aid + , lc_component = component + , lc_public = is_public + , -- These must be executables + lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps + , lc_shape = final_linked_shape + , lc_includes = linked_includes + , lc_sig_includes = linked_sig_includes + } -- Note [Signature package special case] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -336,63 +405,82 @@ -- Handle mix-in linking for components. In the absence of Backpack, -- every ComponentId gets converted into a UnitId by way of SimpleUnitId. toLinkedComponents - :: Verbosity - -> FullDb - -> PackageId - -> LinkedComponentMap - -> [ConfiguredComponent] - -> LogProgress [LinkedComponent] -toLinkedComponents verbosity db this_pid lc_map0 comps - = fmap snd (mapAccumM go lc_map0 comps) - where - go :: Map ComponentId (OpenUnitId, ModuleShape) - -> ConfiguredComponent - -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) - go lc_map cc = do - lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $ - toLinkedComponent verbosity db this_pid lc_map cc - return (extendLinkedComponentMap lc lc_map, lc) + :: Verbosity + -> Bool + -- ^ Whether there are any "promised" package dependencies which we won't + -- find already installed. + -> FullDb + -> PackageId + -> LinkedComponentMap + -> [ConfiguredComponent] + -> LogProgress [LinkedComponent] +toLinkedComponents verbosity anyPromised db this_pid lc_map0 comps = + fmap snd (mapAccumM go lc_map0 comps) + where + go + :: Map ComponentId (OpenUnitId, ModuleShape) + -> ConfiguredComponent + -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) + go lc_map cc = do + lc <- + addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $ + toLinkedComponent verbosity anyPromised db this_pid lc_map cc + return (extendLinkedComponentMap lc lc_map, lc) type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape) -extendLinkedComponentMap :: LinkedComponent - -> LinkedComponentMap - -> LinkedComponentMap +extendLinkedComponentMap + :: LinkedComponent + -> LinkedComponentMap + -> LinkedComponentMap extendLinkedComponentMap lc m = - Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m + Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m brokenReexportMsg :: ModuleReexport -> Doc brokenReexportMsg (ModuleReexport (Just pn) from _to) = - vcat [ text "The package" <+> quotes (pretty pn) - , text "does not export a module" <+> quotes (pretty from) ] + vcat + [ text "The package" <+> quotes (pretty pn) + , text "does not export a module" <+> quotes (pretty from) + ] brokenReexportMsg (ModuleReexport Nothing from _to) = - vcat [ text "The module" <+> quotes (pretty from) - , text "is not exported by any suitable package." - , text "It occurs in neither the 'exposed-modules' of this package," - , text "nor any of its 'build-depends' dependencies." ] + vcat + [ text "The module" <+> quotes (pretty from) + , text "is not exported by any suitable package." + , text "It occurs in neither the 'exposed-modules' of this package," + , text "nor any of its 'build-depends' dependencies." + ] ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc ambiguousReexportMsg (ModuleReexport mb_pn from _to) y1 ys = - vcat [ text "Ambiguous reexport" <+> quotes (pretty from) - , hang (text "It could refer to either:") 2 - (vcat (msg : msgs)) - , help_msg mb_pn ] + vcat + [ text "Ambiguous reexport" <+> quotes (pretty from) + , hang + (text "It could refer to either:") + 2 + (vcat (msg : msgs)) + , help_msg mb_pn + ] where - msg = text " " <+> displayModuleWithSource y1 + msg = text " " <+> displayModuleWithSource y1 msgs = [text "or" <+> displayModuleWithSource y | y <- ys] help_msg Nothing = -- TODO: This advice doesn't help if the ambiguous exports -- come from a package named the same thing - vcat [ text "The ambiguity can be resolved by qualifying the" - , text "re-export with a package name." - , text "The syntax is 'packagename:ModuleName [as NewName]'." ] + vcat + [ text "The ambiguity can be resolved by qualifying the" + , text "re-export with a package name." + , text "The syntax is 'packagename:ModuleName [as NewName]'." + ] -- Qualifying won't help that much. help_msg (Just _) = - vcat [ text "The ambiguity can be resolved by using the" - , text "mixins field to rename one of the module" - , text "names differently." ] - displayModuleWithSource y - = vcat [ quotes (pretty (unWithSource y)) - , text "brought into scope by" <+> - dispModuleSource (getSource y) - ] + vcat + [ text "The ambiguity can be resolved by using the" + , text "mixins field to rename one of the module" + , text "names differently." + ] + displayModuleWithSource y = + vcat + [ quotes (pretty (unWithSource y)) + , text "brought into scope by" + <+> dispModuleSource (getSource y) + ] 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 @@ -1,26 +1,27 @@ {-# LANGUAGE NondecreasingIndentation #-} + -- | See -module Distribution.Backpack.MixLink ( - mixLink, -) where +module Distribution.Backpack.MixLink + ( mixLink + ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod) +import Prelude () import Distribution.Backpack -import Distribution.Backpack.UnifyM import Distribution.Backpack.FullUnitId import Distribution.Backpack.ModuleScope +import Distribution.Backpack.UnifyM -import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.ModuleName import Distribution.Pretty import Distribution.Types.ComponentId +import qualified Distribution.Utils.UnionFind as UnionFind -import Text.PrettyPrint import Control.Monad -import qualified Data.Map as Map import qualified Data.Foldable as F +import qualified Data.Map as Map +import Text.PrettyPrint ----------------------------------------------------------------------- -- Linking @@ -28,78 +29,98 @@ -- | Given to scopes of provisions and requirements, link them together. mixLink :: [ModuleScopeU s] -> UnifyM s (ModuleScopeU s) mixLink scopes = do - let provs = Map.unionsWith (++) (map fst scopes) - -- Invariant: any identically named holes refer to same mutable cell - reqs = Map.unionsWith (++) (map snd scopes) - filled = Map.intersectionWithKey linkProvision provs reqs - F.sequenceA_ filled - let remaining = Map.difference reqs filled - return (provs, remaining) + let provs = Map.unionsWith (++) (map fst scopes) + -- Invariant: any identically named holes refer to same mutable cell + reqs = Map.unionsWith (++) (map snd scopes) + filled = Map.intersectionWithKey linkProvision provs reqs + F.sequenceA_ filled + let remaining = Map.difference reqs filled + return (provs, remaining) -- | Link a list of possibly provided modules to a single -- requirement. This applies a side-condition that all -- of the provided modules at the same name are *actually* -- the same module. -linkProvision :: ModuleName - -> [ModuleWithSourceU s] -- provs - -> [ModuleWithSourceU s] -- reqs - -> UnifyM s [ModuleWithSourceU s] -linkProvision mod_name ret@(prov:provs) (req:reqs) = do - -- TODO: coalesce all the non-unifying modules together - forM_ provs $ \prov' -> do - -- Careful: read it out BEFORE unifying, because the - -- unification algorithm preemptively unifies modules - mod <- convertModuleU (unWithSource prov) - mod' <- convertModuleU (unWithSource prov') - r <- unify prov prov' - case r of - Just () -> return () - Nothing -> do - addErr $ - text "Ambiguous module" <+> quotes (pretty mod_name) $$ - text "It could refer to" <+> - ( text " " <+> (quotes (pretty mod) $$ in_scope_by (getSource prov)) $$ - text "or" <+> (quotes (pretty mod') $$ in_scope_by (getSource prov')) ) $$ - link_doc +linkProvision + :: ModuleName + -> [ModuleWithSourceU s] -- provs + -> [ModuleWithSourceU s] -- reqs + -> UnifyM s [ModuleWithSourceU s] +linkProvision mod_name ret@(prov : provs) (req : reqs) = do + -- TODO: coalesce all the non-unifying modules together + forM_ provs $ \prov' -> do + -- Careful: read it out BEFORE unifying, because the + -- unification algorithm preemptively unifies modules mod <- convertModuleU (unWithSource prov) - req_mod <- convertModuleU (unWithSource req) - self_cid <- fmap unify_self_cid getUnifEnv - case mod of - OpenModule (IndefFullUnitId cid _) _ - | cid == self_cid -> addErr $ - text "Cannot instantiate requirement" <+> quotes (pretty mod_name) <+> - in_scope_by (getSource req) $$ - text "with locally defined module" <+> in_scope_by (getSource prov) $$ - text "as this would create a cyclic dependency, which GHC does not support." $$ - text "Try moving this module to a separate library, e.g.," $$ - text "create a new stanza: library 'sublib'." - _ -> return () - r <- unify prov req + mod' <- convertModuleU (unWithSource prov') + r <- unify prov prov' case r of - Just () -> return () - Nothing -> do - -- TODO: Record and report WHERE the bad constraint came from - addErr $ text "Could not instantiate requirement" <+> quotes (pretty mod_name) $$ - nest 4 (text "Expected:" <+> pretty mod $$ - text "Actual: " <+> pretty req_mod) $$ - parens (text "This can occur if an exposed module of" <+> - text "a libraries shares a name with another module.") $$ - link_doc - return ret + Just () -> return () + Nothing -> do + addErr $ + text "Ambiguous module" + <+> quotes (pretty mod_name) + $$ text "It could refer to" + <+> ( text " " + <+> (quotes (pretty mod) $$ in_scope_by (getSource prov)) + $$ text "or" + <+> (quotes (pretty mod') $$ in_scope_by (getSource prov')) + ) + $$ link_doc + mod <- convertModuleU (unWithSource prov) + req_mod <- convertModuleU (unWithSource req) + self_cid <- fmap unify_self_cid getUnifEnv + case mod of + OpenModule (IndefFullUnitId cid _) _ + | cid == self_cid -> + addErr $ + text "Cannot instantiate requirement" + <+> quotes (pretty mod_name) + <+> in_scope_by (getSource req) + $$ text "with locally defined module" + <+> in_scope_by (getSource prov) + $$ text "as this would create a cyclic dependency, which GHC does not support." + $$ text "Try moving this module to a separate library, e.g.," + $$ text "create a new stanza: library 'sublib'." + _ -> return () + r <- unify prov req + case r of + Just () -> return () + Nothing -> do + -- TODO: Record and report WHERE the bad constraint came from + addErr $ + text "Could not instantiate requirement" + <+> quotes (pretty mod_name) + $$ nest + 4 + ( text "Expected:" + <+> pretty mod + $$ text "Actual: " + <+> pretty req_mod + ) + $$ parens + ( text "This can occur if an exposed module of" + <+> text "a libraries shares a name with another module." + ) + $$ link_doc + return ret where - unify s1 s2 = tryM $ addErrContext short_link_doc - $ unifyModule (unWithSource s1) (unWithSource s2) + unify s1 s2 = + tryM $ + addErrContext short_link_doc $ + unifyModule (unWithSource s1) (unWithSource s2) in_scope_by s = text "brought into scope by" <+> dispModuleSource s short_link_doc = text "While filling requirement" <+> quotes (pretty mod_name) link_doc = text "While filling requirements of" <+> reqs_doc reqs_doc | null reqs = dispModuleSource (getSource req) - | otherwise = ( text " " <+> dispModuleSource (getSource req) $$ - vcat [ text "and" <+> dispModuleSource (getSource r) | r <- reqs]) + | otherwise = + ( text " " + <+> dispModuleSource (getSource req) + $$ vcat [text "and" <+> dispModuleSource (getSource r) | r <- reqs] + ) linkProvision _ _ _ = error "linkProvision" - - ----------------------------------------------------------------------- -- The unification algorithm @@ -108,78 +129,93 @@ unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s () unifyUnitId uid1_u uid2_u - | uid1_u == uid2_u = return () - | otherwise = do - xuid1 <- liftST $ UnionFind.find uid1_u - xuid2 <- liftST $ UnionFind.find uid2_u - case (xuid1, xuid2) of - (UnitIdThunkU u1, UnitIdThunkU u2) - | u1 == u2 -> return () - | otherwise -> - failWith $ hang (text "Couldn't match unit IDs:") 4 - (text " " <+> pretty u1 $$ - text "and" <+> pretty u2) - (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) - -> unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u - (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) - -> unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u - (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2) - -> unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u + | uid1_u == uid2_u = return () + | otherwise = do + xuid1 <- liftST $ UnionFind.find uid1_u + xuid2 <- liftST $ UnionFind.find uid2_u + case (xuid1, xuid2) of + (UnitIdThunkU u1, UnitIdThunkU u2) + | u1 == u2 -> return () + | otherwise -> + failWith $ + hang + (text "Couldn't match unit IDs:") + 4 + ( text " " + <+> pretty u1 + $$ text "and" + <+> pretty u2 + ) + (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) -> + unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u + (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) -> + unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u + (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2) -> + unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u -unifyThunkWith :: ComponentId - -> Map ModuleName (ModuleU s) - -> UnitIdU s - -> DefUnitId - -> UnitIdU s - -> UnifyM s () +unifyThunkWith + :: ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> DefUnitId + -> UnitIdU s + -> UnifyM s () unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do - db <- fmap unify_db getUnifEnv - let FullUnitId cid2 insts2' = expandUnitId db uid2 - insts2 <- convertModuleSubst insts2' - unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u + db <- fmap unify_db getUnifEnv + let FullUnitId cid2 insts2' = expandUnitId db uid2 + insts2 <- convertModuleSubst insts2' + unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u -unifyInner :: ComponentId - -> Map ModuleName (ModuleU s) - -> UnitIdU s - -> ComponentId - -> Map ModuleName (ModuleU s) - -> UnitIdU s - -> UnifyM s () +unifyInner + :: ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> UnifyM s () unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u = do - when (cid1 /= cid2) $ - -- TODO: if we had a package identifier, could be an - -- easier to understand error message. - failWith $ - hang (text "Couldn't match component IDs:") 4 - (text " " <+> pretty cid1 $$ - text "and" <+> pretty cid2) - -- The KEY STEP which makes this a Huet-style unification - -- algorithm. (Also a payoff of using union-find.) - -- We can build infinite unit IDs this way, which is necessary - -- for support mutual recursion. NB: union keeps the SECOND - -- descriptor, so we always arrange for a UnitIdThunkU to live - -- there. - liftST $ UnionFind.union uid1_u uid2_u - F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2 + when (cid1 /= cid2) $ + -- TODO: if we had a package identifier, could be an + -- easier to understand error message. + failWith $ + hang + (text "Couldn't match component IDs:") + 4 + ( text " " + <+> pretty cid1 + $$ text "and" + <+> pretty cid2 + ) + -- The KEY STEP which makes this a Huet-style unification + -- algorithm. (Also a payoff of using union-find.) + -- We can build infinite unit IDs this way, which is necessary + -- for support mutual recursion. NB: union keeps the SECOND + -- descriptor, so we always arrange for a UnitIdThunkU to live + -- there. + liftST $ UnionFind.union uid1_u uid2_u + F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2 -- | Imperatively unify two modules. unifyModule :: ModuleU s -> ModuleU s -> UnifyM s () unifyModule mod1_u mod2_u - | mod1_u == mod2_u = return () - | otherwise = do - mod1 <- liftST $ UnionFind.find mod1_u - mod2 <- liftST $ UnionFind.find mod2_u - case (mod1, mod2) of - (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u - (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u - (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do - when (mod_name1 /= mod_name2) $ - failWith $ - hang (text "Cannot match module names") 4 $ - text " " <+> pretty mod_name1 $$ - text "and" <+> pretty mod_name2 - -- NB: this is not actually necessary (because we'll - -- detect loops eventually in 'unifyUnitId'), but it - -- seems harmless enough - liftST $ UnionFind.union mod1_u mod2_u - unifyUnitId uid1 uid2 + | mod1_u == mod2_u = return () + | otherwise = do + mod1 <- liftST $ UnionFind.find mod1_u + mod2 <- liftST $ UnionFind.find mod2_u + case (mod1, mod2) of + (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u + (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u + (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do + when (mod_name1 /= mod_name2) $ + failWith $ + hang (text "Cannot match module names") 4 $ + text " " + <+> pretty mod_name1 + $$ text "and" + <+> pretty mod_name2 + -- NB: this is not actually necessary (because we'll + -- detect loops eventually in 'unifyUnitId'), but it + -- seems harmless enough + liftST $ UnionFind.union mod1_u mod2_u + unifyUnitId uid1 uid2 diff --git a/src/Distribution/Backpack/ModSubst.hs b/src/Distribution/Backpack/ModSubst.hs --- a/src/Distribution/Backpack/ModSubst.hs +++ b/src/Distribution/Backpack/ModSubst.hs @@ -5,13 +5,12 @@ -- applied to them. -- -- See also - -module Distribution.Backpack.ModSubst ( - ModSubst(..), -) where +module Distribution.Backpack.ModSubst + ( ModSubst (..) + ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod) +import Prelude () import Distribution.Backpack import Distribution.ModuleName @@ -21,32 +20,33 @@ -- | Applying module substitutions to semantic objects. class ModSubst a where - -- In notation, substitution is postfix, which implies - -- putting it on the right hand side, but for partial - -- application it's more convenient to have it on the left - -- hand side. - modSubst :: OpenModuleSubst -> a -> a + -- In notation, substitution is postfix, which implies + -- putting it on the right hand side, but for partial + -- application it's more convenient to have it on the left + -- hand side. + modSubst :: OpenModuleSubst -> a -> a instance ModSubst OpenModule where - modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name - modSubst subst mod@(OpenModuleVar mod_name) - | Just mod' <- Map.lookup mod_name subst = mod' - | otherwise = mod + modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name + modSubst subst mod@(OpenModuleVar mod_name) + | Just mod' <- Map.lookup mod_name subst = mod' + | otherwise = mod instance ModSubst OpenUnitId where - modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts) - modSubst _subst uid = uid + modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts) + modSubst _subst uid = uid instance ModSubst (Set ModuleName) where - modSubst subst reqs - = Set.union (Set.difference reqs (Map.keysSet subst)) - (openModuleSubstFreeHoles subst) + modSubst subst reqs = + Set.union + (Set.difference reqs (Map.keysSet subst)) + (openModuleSubstFreeHoles subst) -- Substitutions are functorial. NB: this means that -- there is an @instance 'ModSubst' 'ModuleSubst'@! instance ModSubst a => ModSubst (Map k a) where - modSubst subst = fmap (modSubst subst) + modSubst subst = fmap (modSubst subst) instance ModSubst a => ModSubst [a] where - modSubst subst = fmap (modSubst subst) + modSubst subst = fmap (modSubst subst) instance ModSubst a => ModSubst (k, a) where - modSubst subst (x,y) = (x, modSubst subst y) + modSubst subst (x, y) = (x, modSubst subst y) 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,30 +1,31 @@ +{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} + -- | See -module Distribution.Backpack.ModuleScope ( - -- * Module scopes - ModuleScope(..), - ModuleProvides, - ModuleRequires, - ModuleSource(..), - dispModuleSource, - WithSource(..), - unWithSource, - getSource, - ModuleWithSource, - emptyModuleScope, -) where +module Distribution.Backpack.ModuleScope + ( -- * Module scopes + ModuleScope (..) + , ModuleProvides + , ModuleRequires + , ModuleSource (..) + , dispModuleSource + , WithSource (..) + , unWithSource + , getSource + , ModuleWithSource + , emptyModuleScope + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.ModuleName -import Distribution.Types.IncludeRenaming -import Distribution.Types.PackageName +import Distribution.Pretty import Distribution.Types.ComponentName +import Distribution.Types.IncludeRenaming import Distribution.Types.LibraryName -import Distribution.Pretty +import Distribution.Types.PackageName import Distribution.Backpack import Distribution.Backpack.ModSubst @@ -32,7 +33,6 @@ import qualified Data.Map as Map import Text.PrettyPrint - ----------------------------------------------------------------------- -- Module scopes @@ -60,17 +60,16 @@ -- Alternate strategy: go ahead and unify, and then if it is revealed -- that some requirements got filled "out-of-thin-air", error. - -- | A 'ModuleScope' describes the modules and requirements that -- are in-scope as we are processing a Cabal package. Unlike -- a 'ModuleShape', there may be multiple modules in scope at -- the same 'ModuleName'; this is only an error if we attempt -- to use those modules to fill a requirement. A 'ModuleScope' -- can influence the 'ModuleShape' via a reexport. -data ModuleScope = ModuleScope { - modScopeProvides :: ModuleProvides, - modScopeRequires :: ModuleRequires - } +data ModuleScope = ModuleScope + { modScopeProvides :: ModuleProvides + , modScopeRequires :: ModuleRequires + } -- | An empty 'ModuleScope'. emptyModuleScope :: ModuleScope @@ -79,49 +78,53 @@ -- | Every 'Module' in scope at a 'ModuleName' is annotated with -- the 'PackageName' it comes from. type ModuleProvides = Map ModuleName [ModuleWithSource] + -- | INVARIANT: entries for ModuleName m, have msrc_module is OpenModuleVar m type ModuleRequires = Map ModuleName [ModuleWithSource] + -- TODO: consider newtping the two types above. -- | Description of where a module participating in mixin linking came -- from. data ModuleSource - = FromMixins PackageName ComponentName IncludeRenaming - | FromBuildDepends PackageName ComponentName - | FromExposedModules ModuleName - | FromOtherModules ModuleName - | FromSignatures ModuleName + = FromMixins PackageName ComponentName IncludeRenaming + | FromBuildDepends PackageName ComponentName + | FromExposedModules ModuleName + | FromOtherModules ModuleName + | FromSignatures ModuleName + -- We don't have line numbers, but if we did, we'd want to record that -- too -- TODO: Deduplicate this with Distribution.Backpack.UnifyM.ci_msg dispModuleSource :: ModuleSource -> Doc -dispModuleSource (FromMixins pn cn incls) - = text "mixins:" <+> dispComponent pn cn <+> pretty incls -dispModuleSource (FromBuildDepends pn cn) - = text "build-depends:" <+> dispComponent pn cn -dispModuleSource (FromExposedModules m) - = text "exposed-modules:" <+> pretty m -dispModuleSource (FromOtherModules m) - = text "other-modules:" <+> pretty m -dispModuleSource (FromSignatures m) - = text "signatures:" <+> pretty m +dispModuleSource (FromMixins pn cn incls) = + text "mixins:" <+> dispComponent pn cn <+> pretty incls +dispModuleSource (FromBuildDepends pn cn) = + text "build-depends:" <+> dispComponent pn cn +dispModuleSource (FromExposedModules m) = + text "exposed-modules:" <+> pretty m +dispModuleSource (FromOtherModules m) = + text "other-modules:" <+> pretty m +dispModuleSource (FromSignatures m) = + text "signatures:" <+> pretty m -- Dependency dispComponent :: PackageName -> ComponentName -> Doc dispComponent pn cn = - -- NB: This syntax isn't quite the source syntax, but it - -- should be clear enough. To do source syntax, we'd - -- need to know what the package we're linking is. - case cn of - CLibName LMainLibName -> pretty pn - CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn - -- Case below shouldn't happen - _ -> pretty pn <+> parens (pretty cn) + -- NB: This syntax isn't quite the source syntax, but it + -- should be clear enough. To do source syntax, we'd + -- need to know what the package we're linking is. + case cn of + CLibName LMainLibName -> pretty pn + CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn + -- Case below shouldn't happen + _ -> pretty pn <+> parens (pretty cn) -- | An 'OpenModule', annotated with where it came from in a Cabal file. data WithSource a = WithSource ModuleSource a - deriving (Functor, Foldable, Traversable) + deriving (Functor, Foldable, Traversable) + unWithSource :: WithSource a -> a unWithSource (WithSource _ x) = x getSource :: WithSource a -> ModuleSource @@ -129,4 +132,4 @@ type ModuleWithSource = WithSource OpenModule instance ModSubst a => ModSubst (WithSource a) where - modSubst subst (WithSource s m) = WithSource s (modSubst subst m) + modSubst subst (WithSource s m) = WithSource s (modSubst subst m) diff --git a/src/Distribution/Backpack/ModuleShape.hs b/src/Distribution/Backpack/ModuleShape.hs --- a/src/Distribution/Backpack/ModuleShape.hs +++ b/src/Distribution/Backpack/ModuleShape.hs @@ -1,21 +1,22 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} + -- | See -module Distribution.Backpack.ModuleShape ( - -- * Module shapes - ModuleShape(..), - emptyModuleShape, - shapeInstalledPackage, -) where +module Distribution.Backpack.ModuleShape + ( -- * Module shapes + ModuleShape (..) + , emptyModuleShape + , shapeInstalledPackage + ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod) +import Prelude () -import Distribution.ModuleName import Distribution.InstalledPackageInfo as IPI +import Distribution.ModuleName -import Distribution.Backpack.ModSubst import Distribution.Backpack +import Distribution.Backpack.ModSubst import qualified Data.Map as Map import qualified Data.Set as Set @@ -26,18 +27,18 @@ -- | A 'ModuleShape' describes the provisions and requirements of -- a library. We can extract a 'ModuleShape' from an -- 'InstalledPackageInfo'. -data ModuleShape = ModuleShape { - modShapeProvides :: OpenModuleSubst, - modShapeRequires :: Set ModuleName - } - deriving (Eq, Show, Generic, Typeable) +data ModuleShape = ModuleShape + { modShapeProvides :: OpenModuleSubst + , modShapeRequires :: Set ModuleName + } + deriving (Eq, Show, Generic, Typeable) instance Binary ModuleShape instance Structured ModuleShape instance ModSubst ModuleShape where - modSubst subst (ModuleShape provs reqs) - = ModuleShape (modSubst subst provs) (modSubst subst reqs) + modSubst subst (ModuleShape provs reqs) = + ModuleShape (modSubst subst provs) (modSubst subst reqs) -- | The default module shape, with no provisions and no requirements. emptyModuleShape :: ModuleShape @@ -78,7 +79,7 @@ uid = installedOpenUnitId ipi provs = map shapeExposedModule (IPI.exposedModules ipi) reqs = requiredSignatures ipi - shapeExposedModule (IPI.ExposedModule mod_name Nothing) - = (mod_name, OpenModule uid mod_name) - shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) - = (mod_name, mod) + shapeExposedModule (IPI.ExposedModule mod_name Nothing) = + (mod_name, OpenModule uid mod_name) + shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) = + (mod_name, mod) diff --git a/src/Distribution/Backpack/PreExistingComponent.hs b/src/Distribution/Backpack/PreExistingComponent.hs --- a/src/Distribution/Backpack/PreExistingComponent.hs +++ b/src/Distribution/Backpack/PreExistingComponent.hs @@ -1,59 +1,70 @@ -- | See -module Distribution.Backpack.PreExistingComponent ( - PreExistingComponent(..), - ipiToPreExistingComponent, -) where +module Distribution.Backpack.PreExistingComponent + ( PreExistingComponent (..) + , PromisedComponent (..) + , ipiToPreExistingComponent + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Backpack.ModuleShape import Distribution.Backpack -import Distribution.Types.ComponentId -import Distribution.Types.MungedPackageId -import Distribution.Types.PackageId -import Distribution.Types.UnitId -import Distribution.Types.ComponentName -import Distribution.Types.PackageName +import Distribution.Backpack.ModuleShape import Distribution.Package +import Distribution.Types.ComponentName +import Distribution.Types.MungedPackageId import qualified Data.Map as Map -import qualified Distribution.InstalledPackageInfo as Installed import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.Types.AnnotatedId +-- | A /promised/ component. +-- +-- These components are promised to @configure@ but are not yet built. +-- +-- In other words this is 'PreExistingComponent' which doesn't yet exist. +data PromisedComponent = PromisedComponent + { pr_pkgname :: PackageName + , pr_cid :: AnnotatedId ComponentId + } + +instance Package PromisedComponent where + packageId = packageId . pr_cid + -- | Stripped down version of 'LinkedComponent' for things -- we don't need to know how to build. -data PreExistingComponent - = PreExistingComponent { - -- | The actual name of the package. This may DISAGREE with 'pc_pkgid' - -- for internal dependencies: e.g., an internal component @lib@ may be - -- munged to @z-pkg-z-lib@, but we still want to use it when we see - -- @lib@ in @build-depends@ - pc_pkgname :: PackageName, - -- | The actual name of the component. - pc_compname :: ComponentName, - pc_munged_id :: MungedPackageId, - pc_uid :: UnitId, - pc_cid :: ComponentId, - pc_open_uid :: OpenUnitId, - pc_shape :: ModuleShape - } +data PreExistingComponent = PreExistingComponent + { pc_pkgname :: PackageName + -- ^ The actual name of the package. This may DISAGREE with 'pc_pkgid' + -- for internal dependencies: e.g., an internal component @lib@ may be + -- munged to @z-pkg-z-lib@, but we still want to use it when we see + -- @lib@ in @build-depends@ + , pc_compname :: ComponentName + -- ^ The actual name of the component. + , pc_munged_id :: MungedPackageId + , pc_uid :: UnitId + , pc_cid :: ComponentId + , pc_open_uid :: OpenUnitId + , pc_shape :: ModuleShape + } -- | Convert an 'InstalledPackageInfo' into a 'PreExistingComponent', -- which was brought into scope under the 'PackageName' (important for -- a package qualified reference.) ipiToPreExistingComponent :: InstalledPackageInfo -> PreExistingComponent ipiToPreExistingComponent ipi = - PreExistingComponent { - pc_pkgname = packageName ipi, - pc_compname = CLibName $ Installed.sourceLibName ipi, - pc_munged_id = mungedId ipi, - pc_uid = Installed.installedUnitId ipi, - pc_cid = Installed.installedComponentId ipi, - pc_open_uid = - IndefFullUnitId (Installed.installedComponentId ipi) - (Map.fromList (Installed.instantiatedWith ipi)), - pc_shape = shapeInstalledPackage ipi + PreExistingComponent + { pc_pkgname = packageName ipi + , pc_compname = CLibName $ Installed.sourceLibName ipi + , pc_munged_id = mungedId ipi + , pc_uid = Installed.installedUnitId ipi + , pc_cid = Installed.installedComponentId ipi + , pc_open_uid = + IndefFullUnitId + (Installed.installedComponentId ipi) + (Map.fromList (Installed.instantiatedWith ipi)) + , pc_shape = shapeInstalledPackage ipi } instance HasMungedPackageId PreExistingComponent where @@ -61,7 +72,8 @@ instance Package PreExistingComponent where packageId pec = PackageIdentifier (pc_pkgname pec) v - where MungedPackageId _ v = pc_munged_id pec + where + MungedPackageId _ v = pc_munged_id pec instance HasUnitId PreExistingComponent where installedUnitId = pc_uid 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,38 +1,38 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Backpack.PreModuleShape ( - PreModuleShape(..), - toPreModuleShape, - renamePreModuleShape, - mixLinkPreModuleShape, -) where +module Distribution.Backpack.PreModuleShape + ( PreModuleShape (..) + , toPreModuleShape + , renamePreModuleShape + , mixLinkPreModuleShape + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.Set as Set import Distribution.Backpack.ModuleShape +import Distribution.ModuleName import Distribution.Types.IncludeRenaming import Distribution.Types.ModuleRenaming -import Distribution.ModuleName -data PreModuleShape = PreModuleShape { - preModShapeProvides :: Set ModuleName, - preModShapeRequires :: Set ModuleName - } - deriving (Eq, Show, Generic) +data PreModuleShape = PreModuleShape + { preModShapeProvides :: Set ModuleName + , preModShapeRequires :: Set ModuleName + } + deriving (Eq, Show, Generic) toPreModuleShape :: ModuleShape -> PreModuleShape toPreModuleShape (ModuleShape provs reqs) = PreModuleShape (Map.keysSet provs) reqs renamePreModuleShape :: PreModuleShape -> IncludeRenaming -> PreModuleShape renamePreModuleShape (PreModuleShape provs reqs) (IncludeRenaming prov_rn req_rn) = - PreModuleShape - (Set.fromList (mapMaybe prov_fn (Set.toList provs))) - (Set.map req_fn reqs) + PreModuleShape + (Set.fromList (mapMaybe prov_fn (Set.toList provs))) + (Set.map req_fn reqs) where prov_fn = interpModuleRenaming prov_rn req_fn k = fromMaybe k (interpModuleRenaming req_rn k) @@ -41,4 +41,4 @@ mixLinkPreModuleShape shapes = PreModuleShape provs (Set.difference reqs provs) where provs = Set.unions (map preModShapeProvides shapes) - reqs = Set.unions (map preModShapeRequires shapes) + reqs = Set.unions (map preModShapeRequires shapes) 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,186 +1,199 @@ -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} + -- | See -module Distribution.Backpack.ReadyComponent ( - ReadyComponent(..), - InstantiatedComponent(..), - IndefiniteComponent(..), - rc_depends, - rc_uid, - rc_pkgid, - dispReadyComponent, - toReadyComponents, -) where +module Distribution.Backpack.ReadyComponent + ( ReadyComponent (..) + , InstantiatedComponent (..) + , IndefiniteComponent (..) + , rc_depends + , rc_uid + , rc_pkgid + , dispReadyComponent + , toReadyComponents + ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () import Distribution.Backpack import Distribution.Backpack.LinkedComponent import Distribution.Backpack.ModuleShape +import Distribution.Compat.Graph (IsNode (..)) import Distribution.Types.AnnotatedId -import Distribution.Types.ModuleRenaming import Distribution.Types.Component -import Distribution.Types.ComponentInclude import Distribution.Types.ComponentId +import Distribution.Types.ComponentInclude import Distribution.Types.ComponentName -import Distribution.Types.PackageId -import Distribution.Types.PackageName.Magic -import Distribution.Types.UnitId -import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Types.Library +import Distribution.Types.LibraryName import Distribution.Types.Module +import Distribution.Types.ModuleRenaming import Distribution.Types.MungedPackageId import Distribution.Types.MungedPackageName -import Distribution.Types.Library -import Distribution.Types.LibraryName +import Distribution.Types.PackageId +import Distribution.Types.PackageName.Magic +import Distribution.Types.UnitId import Distribution.ModuleName import Distribution.Package import Distribution.Simple.Utils import Control.Monad -import Text.PrettyPrint import qualified Data.Map as Map import qualified Data.Set as Set +import Text.PrettyPrint -import Distribution.Version import Distribution.Pretty +import Distribution.Version -- | A 'ReadyComponent' is one that we can actually generate build -- products for. We have a ready component for the typecheck-only -- products of every indefinite package, as well as a ready component -- for every way these packages can be fully instantiated. --- -data ReadyComponent - = ReadyComponent { - rc_ann_id :: AnnotatedId UnitId, - -- | The 'OpenUnitId' for this package. At the moment, this - -- is used in only one case, which is to determine if an - -- export is of a module from this library (indefinite - -- libraries record these exports as 'OpenModule'); - -- 'rc_open_uid' can be conveniently used to test for - -- equality, whereas 'UnitId' cannot always be used in this - -- case. - rc_open_uid :: OpenUnitId, - -- | Corresponds to 'lc_cid'. Invariant: if 'rc_open_uid' - -- records a 'ComponentId', it coincides with this one. - rc_cid :: ComponentId, - -- | Corresponds to 'lc_component'. - rc_component :: Component, - -- | Corresponds to 'lc_exe_deps'. - -- Build-tools don't participate in mix-in linking. - -- (but what if they could?) - rc_exe_deps :: [AnnotatedId UnitId], - -- | Corresponds to 'lc_public'. - rc_public :: Bool, - -- | Extra metadata depending on whether or not this is an - -- indefinite library (typechecked only) or an instantiated - -- component (can be compiled). - rc_i :: Either IndefiniteComponent InstantiatedComponent - } +data ReadyComponent = ReadyComponent + { rc_ann_id :: AnnotatedId UnitId + , rc_open_uid :: OpenUnitId + -- ^ The 'OpenUnitId' for this package. At the moment, this + -- is used in only one case, which is to determine if an + -- export is of a module from this library (indefinite + -- libraries record these exports as 'OpenModule'); + -- 'rc_open_uid' can be conveniently used to test for + -- equality, whereas 'UnitId' cannot always be used in this + -- case. + , rc_cid :: ComponentId + -- ^ Corresponds to 'lc_cid'. Invariant: if 'rc_open_uid' + -- records a 'ComponentId', it coincides with this one. + , rc_component :: Component + -- ^ Corresponds to 'lc_component'. + , rc_exe_deps :: [AnnotatedId UnitId] + -- ^ Corresponds to 'lc_exe_deps'. + -- Build-tools don't participate in mix-in linking. + -- (but what if they could?) + , rc_public :: Bool + -- ^ Corresponds to 'lc_public'. + , rc_i :: Either IndefiniteComponent InstantiatedComponent + -- ^ Extra metadata depending on whether or not this is an + -- indefinite library (typechecked only) or an instantiated + -- component (can be compiled). + } -- | The final, string 'UnitId' that will uniquely identify -- the compilation products of this component. -rc_uid :: ReadyComponent -> UnitId +rc_uid :: ReadyComponent -> UnitId rc_uid = ann_id . rc_ann_id -- | Corresponds to 'lc_pkgid'. -rc_pkgid :: ReadyComponent -> PackageId +rc_pkgid :: ReadyComponent -> PackageId rc_pkgid = ann_pid . rc_ann_id -- | An 'InstantiatedComponent' is a library which is fully instantiated -- (or, possibly, has no requirements at all.) -data InstantiatedComponent - = InstantiatedComponent { - -- | How this library was instantiated. - instc_insts :: [(ModuleName, Module)], - -- | Dependencies induced by 'instc_insts'. These are recorded - -- here because there isn't a convenient way otherwise to get - -- the 'PackageId' we need to fill 'componentPackageDeps' as needed. - instc_insts_deps :: [(UnitId, MungedPackageId)], - -- | The modules exported/reexported by this library. - instc_provides :: Map ModuleName Module, - -- | The dependencies which need to be passed to the compiler - -- to bring modules into scope. These always refer to installed - -- fully instantiated libraries. - instc_includes :: [ComponentInclude DefUnitId ModuleRenaming] - } +data InstantiatedComponent = InstantiatedComponent + { instc_insts :: [(ModuleName, Module)] + -- ^ How this library was instantiated. + , instc_insts_deps :: [(UnitId, MungedPackageId)] + -- ^ Dependencies induced by 'instc_insts'. These are recorded + -- here because there isn't a convenient way otherwise to get + -- the 'PackageId' we need to fill 'componentPackageDeps' as needed. + , instc_provides :: Map ModuleName Module + -- ^ The modules exported/reexported by this library. + , instc_includes :: [ComponentInclude DefUnitId ModuleRenaming] + -- ^ The dependencies which need to be passed to the compiler + -- to bring modules into scope. These always refer to installed + -- fully instantiated libraries. + } -- | An 'IndefiniteComponent' is a library with requirements -- which we will typecheck only. -data IndefiniteComponent - = IndefiniteComponent { - -- | The requirements of the library. - indefc_requires :: [ModuleName], - -- | The modules exported/reexported by this library. - indefc_provides :: Map ModuleName OpenModule, - -- | The dependencies which need to be passed to the compiler - -- to bring modules into scope. These are 'OpenUnitId' because - -- these may refer to partially instantiated libraries. - indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] - } +data IndefiniteComponent = IndefiniteComponent + { indefc_requires :: [ModuleName] + -- ^ The requirements of the library. + , indefc_provides :: Map ModuleName OpenModule + -- ^ The modules exported/reexported by this library. + , indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] + -- ^ The dependencies which need to be passed to the compiler + -- to bring modules into scope. These are 'OpenUnitId' because + -- these may refer to partially instantiated libraries. + } -- | Compute the dependencies of a 'ReadyComponent' that should -- be recorded in the @depends@ field of 'InstalledPackageInfo'. rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)] rc_depends rc = ordNub $ - case rc_i rc of - Left indefc -> - map (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci)) - (indefc_includes indefc) - Right instc -> - map (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci)) - (instc_includes instc) - ++ instc_insts_deps instc + case rc_i rc of + Left indefc -> + map + (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci)) + (indefc_includes indefc) + Right instc -> + map + (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci)) + (instc_includes instc) + ++ instc_insts_deps instc where toMungedPackageId :: Pretty id => ComponentInclude id rn -> MungedPackageId toMungedPackageId ci = - computeCompatPackageId - (ci_pkgid ci) - (case ci_cname ci of - CLibName name -> name - _ -> error $ prettyShow (rc_cid rc) ++ - " depends on non-library " ++ prettyShow (ci_id ci)) + computeCompatPackageId + (ci_pkgid ci) + ( case ci_cname ci of + CLibName name -> name + _ -> + error $ + prettyShow (rc_cid rc) + ++ " depends on non-library " + ++ prettyShow (ci_id ci) + ) -- | Get the 'MungedPackageId' of a 'ReadyComponent' IF it is -- a library. rc_munged_id :: ReadyComponent -> MungedPackageId rc_munged_id rc = - computeCompatPackageId - (rc_pkgid rc) - (case rc_component rc of - CLib lib -> libName lib - _ -> error "rc_munged_id: not library") + computeCompatPackageId + (rc_pkgid rc) + ( case rc_component rc of + CLib lib -> libName lib + _ -> error "rc_munged_id: not library" + ) instance Package ReadyComponent where - packageId = rc_pkgid + packageId = rc_pkgid instance HasUnitId ReadyComponent where - installedUnitId = rc_uid + installedUnitId = rc_uid instance IsNode ReadyComponent where - type Key ReadyComponent = UnitId - nodeKey = rc_uid - nodeNeighbors rc = - (case rc_i rc of - Right inst | [] <- instc_insts inst - -> [] - | otherwise - -> [newSimpleUnitId (rc_cid rc)] - _ -> []) ++ - ordNub (map fst (rc_depends rc)) ++ - map ann_id (rc_exe_deps rc) + type Key ReadyComponent = UnitId + nodeKey = rc_uid + nodeNeighbors rc = + ( case rc_i rc of + Right inst + | [] <- instc_insts inst -> + [] + | otherwise -> + [newSimpleUnitId (rc_cid rc)] + _ -> [] + ) + ++ ordNub (map fst (rc_depends rc)) + ++ map ann_id (rc_exe_deps rc) dispReadyComponent :: ReadyComponent -> Doc dispReadyComponent rc = - hang (text (case rc_i rc of - Left _ -> "indefinite" - Right _ -> "definite") - <+> pretty (nodeKey rc) - {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} ) 4 $ - vcat [ text "depends" <+> pretty uid - | uid <- nodeNeighbors rc ] + hang + ( text + ( case rc_i rc of + Left _ -> "indefinite" + Right _ -> "definite" + ) + <+> pretty (nodeKey rc) + {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} + ) + 4 + $ vcat + [ text "depends" <+> pretty uid + | uid <- nodeNeighbors rc + ] -- | The state of 'InstM'; a mapping from 'UnitId's to their -- ready component, or @Nothing@ if its an external @@ -189,22 +202,25 @@ -- | A state monad for doing instantiations (can't use actual -- State because that would be an extra dependency.) -newtype InstM a = InstM { runInstM :: InstS -> (a, InstS) } +newtype InstM a = InstM {runInstM :: InstS -> (a, InstS)} instance Functor InstM where - fmap f (InstM m) = InstM $ \s -> let (x, s') = m s - in (f x, s') + fmap f (InstM m) = InstM $ \s -> + let (x, s') = m s + in (f x, s') instance Applicative InstM where - pure a = InstM $ \s -> (a, s) - InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s - (x', s'') = x s' - in (f' x', s'') + pure a = InstM $ \s -> (a, s) + InstM f <*> InstM x = InstM $ \s -> + let (f', s') = f s + (x', s'') = x s' + in (f' x', s'') instance Monad InstM where - return = pure - InstM m >>= f = InstM $ \s -> let (x, s') = m s - in runInstM (f x) s' + return = pure + InstM m >>= f = InstM $ \s -> + let (x, s') = m s + in runInstM (f x) s' -- | Given a list of 'LinkedComponent's, expand the module graph -- so that we have an instantiated graph containing all of the @@ -222,27 +238,30 @@ -- -- We also call 'improveUnitId' during this process, so that fully -- instantiated components are given 'HashedUnitId'. --- toReadyComponents - :: Map UnitId MungedPackageId - -> Map ModuleName Module -- subst for the public component - -> [LinkedComponent] - -> [ReadyComponent] -toReadyComponents pid_map subst0 comps - = catMaybes (Map.elems ready_map) + :: Map UnitId MungedPackageId + -> Map ModuleName Module -- subst for the public component + -> [LinkedComponent] + -> [ReadyComponent] +toReadyComponents pid_map subst0 comps = + catMaybes (Map.elems ready_map) where - cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ] + cmap = Map.fromList [(lc_cid lc, lc) | lc <- comps] - instantiateUnitId :: ComponentId -> Map ModuleName Module - -> InstM DefUnitId + instantiateUnitId + :: ComponentId + -> Map ModuleName Module + -> InstM DefUnitId instantiateUnitId cid insts = InstM $ \s -> - case Map.lookup uid s of - Nothing -> - -- Knot tied - let (r, s') = runInstM (instantiateComponent uid cid insts) - (Map.insert uid r s) - in (def_uid, Map.insert uid r s') - Just _ -> (def_uid, s) + case Map.lookup uid s of + Nothing -> + -- Knot tied + let (r, s') = + runInstM + (instantiateComponent uid cid insts) + (Map.insert uid r s) + in (def_uid, Map.insert uid r s') + Just _ -> (def_uid, s) where -- The mkDefUnitId here indicates that we assume -- that Cabal handles unit id hash allocation. @@ -252,125 +271,142 @@ uid = unDefUnitId def_uid instantiateComponent - :: UnitId -> ComponentId -> Map ModuleName Module - -> InstM (Maybe ReadyComponent) + :: UnitId + -> ComponentId + -> Map ModuleName Module + -> InstM (Maybe ReadyComponent) instantiateComponent uid cid insts | Just lc <- Map.lookup cid cmap = do - provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc)) - -- NB: lc_sig_includes is omitted here, because we don't - -- need them to build - includes <- forM (lc_includes lc) $ \ci -> do - uid' <- substUnitId insts (ci_id ci) - return ci { ci_ann_id = fmap (const uid') (ci_ann_id ci) } - exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc) - s <- InstM $ \s -> (s, s) - let getDep (Module dep_def_uid _) - | let dep_uid = unDefUnitId dep_def_uid + provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc)) + -- NB: lc_sig_includes is omitted here, because we don't + -- need them to build + includes <- forM (lc_includes lc) $ \ci -> do + uid' <- substUnitId insts (ci_id ci) + return ci{ci_ann_id = fmap (const uid') (ci_ann_id ci)} + exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc) + s <- InstM $ \s -> (s, s) + let getDep (Module dep_def_uid _) + | let dep_uid = unDefUnitId dep_def_uid = -- Lose DefUnitId invariant for rc_depends - = [(dep_uid, - fromMaybe err_pid $ - Map.lookup dep_uid pid_map <|> - fmap rc_munged_id (join (Map.lookup dep_uid s)))] - where - err_pid = MungedPackageId - (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName) - (mkVersion [0]) - instc = InstantiatedComponent { - instc_insts = Map.toList insts, - instc_insts_deps = concatMap getDep (Map.elems insts), - instc_provides = provides, - instc_includes = includes - -- NB: there is no dependency on the - -- indefinite version of this instantiated package here, - -- as (1) it doesn't go in depends in the - -- IPI: it's not a run time dep, and (2) - -- we don't have to tell GHC about it, it - -- will match up the ComponentId - -- automatically - } - return $ Just ReadyComponent { - rc_ann_id = (lc_ann_id lc) { ann_id = uid }, - rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid), - rc_cid = lc_cid lc, - rc_component = lc_component lc, - rc_exe_deps = exe_deps, - rc_public = lc_public lc, - rc_i = Right instc - } + [ + ( dep_uid + , fromMaybe err_pid $ + Map.lookup dep_uid pid_map + <|> fmap rc_munged_id (join (Map.lookup dep_uid s)) + ) + ] + where + err_pid = + MungedPackageId + (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName) + (mkVersion [0]) + instc = + InstantiatedComponent + { instc_insts = Map.toList insts + , instc_insts_deps = concatMap getDep (Map.elems insts) + , instc_provides = provides + , instc_includes = includes + -- NB: there is no dependency on the + -- indefinite version of this instantiated package here, + -- as (1) it doesn't go in depends in the + -- IPI: it's not a run time dep, and (2) + -- we don't have to tell GHC about it, it + -- will match up the ComponentId + -- automatically + } + return $ + Just + ReadyComponent + { rc_ann_id = (lc_ann_id lc){ann_id = uid} + , rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid) + , rc_cid = lc_cid lc + , rc_component = lc_component lc + , rc_exe_deps = exe_deps + , rc_public = lc_public lc + , rc_i = Right instc + } | otherwise = return Nothing substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId substUnitId _ (DefiniteUnitId uid) = - return uid + return uid substUnitId subst (IndefFullUnitId cid insts) = do - insts' <- substSubst subst insts - instantiateUnitId cid insts' + insts' <- substSubst subst insts + instantiateUnitId cid insts' -- NB: NOT composition - substSubst :: Map ModuleName Module - -> Map ModuleName OpenModule - -> InstM (Map ModuleName Module) + substSubst + :: Map ModuleName Module + -> Map ModuleName OpenModule + -> InstM (Map ModuleName Module) substSubst subst insts = traverse (substModule subst) insts substModule :: Map ModuleName Module -> OpenModule -> InstM Module substModule subst (OpenModuleVar mod_name) - | Just m <- Map.lookup mod_name subst = return m - | otherwise = error "substModule: non-closing substitution" + | Just m <- Map.lookup mod_name subst = return m + | otherwise = error "substModule: non-closing substitution" substModule subst (OpenModule uid mod_name) = do - uid' <- substUnitId subst uid - return (Module uid' mod_name) + uid' <- substUnitId subst uid + return (Module uid' mod_name) - substExeDep :: Map ModuleName Module - -> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId) + substExeDep + :: Map ModuleName Module + -> AnnotatedId OpenUnitId + -> InstM (AnnotatedId UnitId) substExeDep insts exe_aid = do - exe_uid' <- substUnitId insts (ann_id exe_aid) - return exe_aid { ann_id = unDefUnitId exe_uid' } + exe_uid' <- substUnitId insts (ann_id exe_aid) + return exe_aid{ann_id = unDefUnitId exe_uid'} indefiniteUnitId :: ComponentId -> InstM UnitId indefiniteUnitId cid = do - let uid = newSimpleUnitId cid - r <- indefiniteComponent uid cid - InstM $ \s -> (uid, Map.insert uid r s) + let uid = newSimpleUnitId cid + r <- indefiniteComponent uid cid + InstM $ \s -> (uid, Map.insert uid r s) indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent) indefiniteComponent uid cid | Just lc <- Map.lookup cid cmap = do - -- We're going to process includes, in case some of them - -- are fully definite even without any substitution. We - -- want to build those too; see #5634. - inst_includes <- forM (lc_includes lc) $ \ci -> - if Set.null (openUnitIdFreeHoles (ci_id ci)) - then do uid' <- substUnitId Map.empty (ci_id ci) - return $ ci { ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci) } - else return ci - exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc) - let indefc = IndefiniteComponent { - indefc_requires = map fst (lc_insts lc), - indefc_provides = modShapeProvides (lc_shape lc), - indefc_includes = inst_includes ++ lc_sig_includes lc - } - return $ Just ReadyComponent { - rc_ann_id = (lc_ann_id lc) { ann_id = uid }, - rc_cid = lc_cid lc, - rc_open_uid = lc_uid lc, - rc_component = lc_component lc, - -- It's always fully built - rc_exe_deps = exe_deps, - rc_public = lc_public lc, - rc_i = Left indefc + -- We're going to process includes, in case some of them + -- are fully definite even without any substitution. We + -- want to build those too; see #5634. + inst_includes <- forM (lc_includes lc) $ \ci -> + if Set.null (openUnitIdFreeHoles (ci_id ci)) + then do + uid' <- substUnitId Map.empty (ci_id ci) + return $ ci{ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci)} + else return ci + exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc) + let indefc = + IndefiniteComponent + { indefc_requires = map fst (lc_insts lc) + , indefc_provides = modShapeProvides (lc_shape lc) + , indefc_includes = inst_includes ++ lc_sig_includes lc + } + return $ + Just + ReadyComponent + { rc_ann_id = (lc_ann_id lc){ann_id = uid} + , rc_cid = lc_cid lc + , rc_open_uid = lc_uid lc + , rc_component = lc_component lc + , -- It's always fully built + rc_exe_deps = exe_deps + , rc_public = lc_public lc + , rc_i = Left indefc } | otherwise = return Nothing ready_map = snd $ runInstM work Map.empty work - -- Top-level instantiation per subst0 - | not (Map.null subst0) - , [lc] <- filter lc_public (Map.elems cmap) - = do _ <- instantiateUnitId (lc_cid lc) subst0 - return () - | otherwise - = forM_ (Map.elems cmap) $ \lc -> + -- Top-level instantiation per subst0 + | not (Map.null subst0) + , [lc] <- filter lc_public (Map.elems cmap) = + do + _ <- instantiateUnitId (lc_cid lc) subst0 + return () + | 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 instantiateUnitId (lc_cid lc) Map.empty >> return () + else indefiniteUnitId (lc_cid lc) >> return () 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 @@ -1,163 +1,163 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} --- | See -module Distribution.Backpack.UnifyM ( - -- * Unification monad - UnifyM, - runUnifyM, - failWith, - addErr, - failIfErrs, - tryM, - addErrContext, - addErrContextM, - liftST, - UnifEnv(..), - getUnifEnv, +-- | See +module Distribution.Backpack.UnifyM + ( -- * Unification monad + UnifyM + , runUnifyM + , failWith + , addErr + , failIfErrs + , tryM + , addErrContext + , addErrContextM + , liftST + , UnifEnv (..) + , getUnifEnv -- * Modules and unit IDs - ModuleU, - ModuleU'(..), - convertModule, - convertModuleU, - - UnitIdU, - UnitIdU'(..), - convertUnitId, - convertUnitIdU, - - ModuleSubstU, - convertModuleSubstU, - convertModuleSubst, - - ModuleScopeU, - emptyModuleScopeU, - convertModuleScopeU, - - ModuleWithSourceU, - - convertInclude, - convertModuleProvides, - convertModuleProvidesU, - -) where + , ModuleU + , ModuleU' (..) + , convertModule + , convertModuleU + , UnitIdU + , UnitIdU' (..) + , convertUnitId + , convertUnitIdU + , ModuleSubstU + , convertModuleSubstU + , convertModuleSubst + , ModuleScopeU + , emptyModuleScopeU + , convertModuleScopeU + , ModuleWithSourceU + , convertInclude + , convertModuleProvides + , convertModuleProvidesU + ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod) +import Prelude () -import Distribution.Backpack.ModuleShape -import Distribution.Backpack.ModuleScope -import Distribution.Backpack.ModSubst -import Distribution.Backpack.FullUnitId import Distribution.Backpack +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.ModSubst +import Distribution.Backpack.ModuleScope +import Distribution.Backpack.ModuleShape -import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.ModuleName import Distribution.Package import Distribution.PackageDescription import Distribution.Pretty -import Distribution.Types.ComponentInclude import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentInclude +import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.Verbosity -import Data.STRef -import Data.Traversable import Control.Monad.ST -import qualified Data.Map as Map -import qualified Data.Set as Set import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.STRef +import qualified Data.Set as Set +import Data.Traversable import Text.PrettyPrint -- TODO: more detailed trace output on high verbosity would probably -- be appreciated by users debugging unification errors. Collect -- some good examples! -data ErrMsg = ErrMsg { - err_msg :: Doc, - err_ctx :: [Doc] - } +data ErrMsg = ErrMsg + { err_msg :: Doc + , err_ctx :: [Doc] + } type MsgDoc = Doc renderErrMsg :: ErrMsg -> MsgDoc -renderErrMsg ErrMsg { err_msg = msg, err_ctx = ctx } = - msg $$ vcat ctx +renderErrMsg ErrMsg{err_msg = msg, err_ctx = ctx} = + msg $$ vcat ctx -- | The unification monad, this monad encapsulates imperative -- unification. -newtype UnifyM s a = UnifyM { unUnifyM :: UnifEnv s -> ST s (Maybe a) } +newtype UnifyM s a = UnifyM {unUnifyM :: UnifEnv s -> ST s (Maybe a)} -- | Run a computation in the unification monad. runUnifyM :: Verbosity -> ComponentId -> FullDb -> (forall s. UnifyM s a) -> Either [MsgDoc] a -runUnifyM verbosity self_cid db m - = runST $ do i <- newSTRef 0 - hmap <- newSTRef Map.empty - errs <- newSTRef [] - mb_r <- unUnifyM m UnifEnv { - unify_uniq = i, - unify_reqs = hmap, - unify_self_cid = self_cid, - unify_verbosity = verbosity, - unify_ctx = [], - unify_db = db, - unify_errs = errs } - final_errs <- readSTRef errs - case mb_r of - Just x | null final_errs -> return (Right x) - _ -> return (Left (map renderErrMsg (reverse final_errs))) +runUnifyM verbosity self_cid db m = + runST $ do + i <- newSTRef 0 + hmap <- newSTRef Map.empty + errs <- newSTRef [] + mb_r <- + unUnifyM + m + UnifEnv + { unify_uniq = i + , unify_reqs = hmap + , unify_self_cid = self_cid + , unify_verbosity = verbosity + , unify_ctx = [] + , unify_db = db + , unify_errs = errs + } + final_errs <- readSTRef errs + case mb_r of + Just x | null final_errs -> return (Right x) + _ -> return (Left (map renderErrMsg (reverse final_errs))) + -- NB: GHC 7.6 throws a hissy fit if you pattern match on 'm'. type ErrCtx s = MsgDoc -- | The unification environment. -data UnifEnv s = UnifEnv { - -- | A supply of unique integers to label 'UnitIdU' - -- cells. This is used to determine loops in unit - -- identifiers (which can happen with mutual recursion.) - unify_uniq :: UnifRef s UnitIdUnique, - -- | The set of requirements in scope. When - -- a provision is brought into scope, we unify with - -- the requirement at the same module name to fill it. - -- This mapping grows monotonically. - unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)), - -- | Component id of the unit we're linking. We use this - -- to detect if we fill a requirement with a local module, - -- which in principle should be OK but is not currently - -- supported by GHC. - unify_self_cid :: ComponentId, - -- | How verbose the error message should be - unify_verbosity :: Verbosity, - -- | The error reporting context - unify_ctx :: [ErrCtx s], - -- | The package index for expanding unit identifiers - unify_db :: FullDb, - -- | Accumulated errors - unify_errs :: UnifRef s [ErrMsg] - } +data UnifEnv s = UnifEnv + { unify_uniq :: UnifRef s UnitIdUnique + -- ^ A supply of unique integers to label 'UnitIdU' + -- cells. This is used to determine loops in unit + -- identifiers (which can happen with mutual recursion.) + , unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)) + -- ^ The set of requirements in scope. When + -- a provision is brought into scope, we unify with + -- the requirement at the same module name to fill it. + -- This mapping grows monotonically. + , unify_self_cid :: ComponentId + -- ^ Component id of the unit we're linking. We use this + -- to detect if we fill a requirement with a local module, + -- which in principle should be OK but is not currently + -- supported by GHC. + , unify_verbosity :: Verbosity + -- ^ How verbose the error message should be + , unify_ctx :: [ErrCtx s] + -- ^ The error reporting context + , unify_db :: FullDb + -- ^ The package index for expanding unit identifiers + , unify_errs :: UnifRef s [ErrMsg] + -- ^ Accumulated errors + } instance Functor (UnifyM s) where - fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m) + fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m) instance Applicative (UnifyM s) where - pure = UnifyM . pure . pure . pure - UnifyM f <*> UnifyM x = UnifyM $ \r -> do - f' <- f r - case f' of + pure = UnifyM . pure . pure . pure + UnifyM f <*> UnifyM x = UnifyM $ \r -> do + f' <- f r + case f' of + Nothing -> return Nothing + Just f'' -> do + x' <- x r + case x' of Nothing -> return Nothing - Just f'' -> do - x' <- x r - case x' of - Nothing -> return Nothing - Just x'' -> return (Just (f'' x'')) + Just x'' -> return (Just (f'' x'')) instance Monad (UnifyM s) where - return = pure - UnifyM m >>= f = UnifyM $ \r -> do - x <- m r - case x of - Nothing -> return Nothing - Just x' -> unUnifyM (f x') r + return = pure + UnifyM m >>= f = UnifyM $ \r -> do + x <- m r + case x of + Nothing -> return Nothing + Just x' -> unUnifyM (f x') r -- | Lift a computation from 'ST' monad to 'UnifyM' monad. -- Internal use only. @@ -166,32 +166,35 @@ addErr :: MsgDoc -> UnifyM s () addErr msg = do - env <- getUnifEnv - let err = ErrMsg { - err_msg = msg, - err_ctx = unify_ctx env - } - liftST $ modifySTRef (unify_errs env) (\errs -> err:errs) + env <- getUnifEnv + let err = + ErrMsg + { err_msg = msg + , err_ctx = unify_ctx env + } + liftST $ modifySTRef (unify_errs env) (\errs -> err : errs) failWith :: MsgDoc -> UnifyM s a failWith msg = do - addErr msg - failM + addErr msg + failM failM :: UnifyM s a failM = UnifyM $ \_ -> return Nothing failIfErrs :: UnifyM s () failIfErrs = do - env <- getUnifEnv - errs <- liftST $ readSTRef (unify_errs env) - when (not (null errs)) failM + env <- getUnifEnv + errs <- liftST $ readSTRef (unify_errs env) + when (not (null errs)) failM tryM :: UnifyM s a -> UnifyM s (Maybe a) tryM m = - UnifyM (\env -> do + UnifyM + ( \env -> do mb_r <- unUnifyM m env - return (Just mb_r)) + return (Just mb_r) + ) {- otherFail :: ErrMsg -> UnifyM s a @@ -236,8 +239,7 @@ -- | Add a message to the error context. It may make monadic queries. addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a addErrContextM ctx m = - UnifyM $ \r -> unUnifyM m r { unify_ctx = ctx : unify_ctx r } - + UnifyM $ \r -> unUnifyM m r{unify_ctx = ctx : unify_ctx r} ----------------------------------------------------------------------- -- The "unifiable" variants of the data types @@ -251,13 +253,13 @@ -- | Contents of a mutable 'ModuleU' reference. data ModuleU' s - = ModuleU (UnitIdU s) ModuleName - | ModuleVarU ModuleName + = ModuleU (UnitIdU s) ModuleName + | ModuleVarU ModuleName -- | Contents of a mutable 'UnitIdU' reference. data UnitIdU' s - = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s)) - | UnitIdThunkU DefUnitId + = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s)) + | UnitIdThunkU DefUnitId -- | A mutable version of 'Module' which can be imperatively unified. type ModuleU s = UnionFind.Point s (ModuleU' s) @@ -273,7 +275,6 @@ -- participate in unification! type UnitIdUnique = Int - ----------------------------------------------------------------------- -- Conversion to the unifiable data types @@ -286,7 +287,7 @@ extendMuEnv :: MuEnv s -> UnitIdU s -> MuEnv s extendMuEnv (m, i) x = - (IntMap.insert (i + 1) x m, i + 1) + (IntMap.insert (i + 1) x m, i + 1) {- lookupMuEnv :: MuEnv s -> Int {- de Bruijn index -} -> UnitIdU s @@ -308,37 +309,42 @@ -- @hole:A@ binders. -- * @MuEnv@ - the environment for mu-binders. -convertUnitId' :: MuEnv s - -> OpenUnitId - -> UnifyM s (UnitIdU s) +convertUnitId' + :: MuEnv s + -> OpenUnitId + -> UnifyM s (UnitIdU s) -- TODO: this could be more lazy if we know there are no internal -- references convertUnitId' _ (DefiniteUnitId uid) = - liftST $ UnionFind.fresh (UnitIdThunkU uid) + liftST $ UnionFind.fresh (UnitIdThunkU uid) convertUnitId' stk (IndefFullUnitId cid insts) = do - fs <- fmap unify_uniq getUnifEnv - x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later - insts_u <- for insts $ convertModule' (extendMuEnv stk x) - u <- readUnifRef fs - writeUnifRef fs (u+1) - y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u) - liftST $ UnionFind.union x y - return y + fs <- fmap unify_uniq getUnifEnv + x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later + insts_u <- for insts $ convertModule' (extendMuEnv stk x) + u <- readUnifRef fs + writeUnifRef fs (u + 1) + y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u) + liftST $ UnionFind.union x y + return y + -- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i) -convertModule' :: MuEnv s - -> OpenModule -> UnifyM s (ModuleU s) +convertModule' + :: MuEnv s + -> OpenModule + -> UnifyM s (ModuleU s) convertModule' _stk (OpenModuleVar mod_name) = do - hmap <- fmap unify_reqs getUnifEnv - hm <- readUnifRef hmap - case Map.lookup mod_name hm of - Nothing -> do mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name) - writeUnifRef hmap (Map.insert mod_name mod hm) - return mod - Just mod -> return mod + hmap <- fmap unify_reqs getUnifEnv + hm <- readUnifRef hmap + case Map.lookup mod_name hm of + Nothing -> do + mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name) + writeUnifRef hmap (Map.insert mod_name mod hm) + return mod + Just mod -> return mod convertModule' stk (OpenModule uid mod_name) = do - uid_u <- convertUnitId' stk uid - liftST $ UnionFind.fresh (ModuleU uid_u mod_name) + uid_u <- convertUnitId' stk uid + liftST $ UnionFind.fresh (ModuleU uid_u mod_name) convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s) convertUnitId = convertUnitId' emptyMuEnv @@ -346,8 +352,6 @@ convertModule :: OpenModule -> UnifyM s (ModuleU s) convertModule = convertModule' emptyMuEnv - - ----------------------------------------------------------------------- -- Substitutions @@ -380,9 +384,9 @@ lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int lookupMooEnv (m, i) k = - case IntMap.lookup k m of - Nothing -> Nothing - Just v -> Just (i-v) -- de Bruijn indexize + case IntMap.lookup k m of + Nothing -> Nothing + Just v -> Just (i - v) -- de Bruijn indexize -- The workhorse functions @@ -390,34 +394,36 @@ -- | Otherwise returns a list of signatures instantiated by given `UnitIdU`. convertUnitIdU' :: MooEnv -> UnitIdU s -> Doc -> UnifyM s OpenUnitId convertUnitIdU' stk uid_u required_mod_name = do - x <- liftST $ UnionFind.find uid_u - case x of - UnitIdThunkU uid -> return $ DefiniteUnitId uid - UnitIdU u cid insts_u -> - case lookupMooEnv stk u of - Just _ -> - let mod_names = Map.keys insts_u - in failWithMutuallyRecursiveUnitsError required_mod_name mod_names - Nothing -> do - insts <- for insts_u $ convertModuleU' (extendMooEnv stk u) - return $ IndefFullUnitId cid insts + x <- liftST $ UnionFind.find uid_u + case x of + UnitIdThunkU uid -> return $ DefiniteUnitId uid + UnitIdU u cid insts_u -> + case lookupMooEnv stk u of + Just _ -> + let mod_names = Map.keys insts_u + in failWithMutuallyRecursiveUnitsError required_mod_name mod_names + Nothing -> do + insts <- for insts_u $ convertModuleU' (extendMooEnv stk u) + return $ IndefFullUnitId cid insts convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule convertModuleU' stk mod_u = do - mod <- liftST $ UnionFind.find mod_u - case mod of - ModuleVarU mod_name -> return (OpenModuleVar mod_name) - ModuleU uid_u mod_name -> do - uid <- convertUnitIdU' stk uid_u (pretty mod_name) - return (OpenModule uid mod_name) + mod <- liftST $ UnionFind.find mod_u + case mod of + ModuleVarU mod_name -> return (OpenModuleVar mod_name) + ModuleU uid_u mod_name -> do + uid <- convertUnitIdU' stk uid_u (pretty mod_name) + return (OpenModule uid mod_name) failWithMutuallyRecursiveUnitsError :: Doc -> [ModuleName] -> UnifyM s a failWithMutuallyRecursiveUnitsError required_mod_name mod_names = - let sigsList = hcat $ punctuate (text ", ") $ map (quotes . pretty) mod_names in - failWith $ - text "Cannot instantiate requirement" <+> quotes required_mod_name $$ - text "Ensure \"build-depends:\" doesn't include any library with signatures:" <+> sigsList $$ - text "as this creates a cyclic dependency, which GHC does not support." + let sigsList = hcat $ punctuate (text ", ") $ map (quotes . pretty) mod_names + in failWith $ + text "Cannot instantiate requirement" + <+> quotes required_mod_name + $$ text "Ensure \"build-depends:\" doesn't include any library with signatures:" + <+> sigsList + $$ text "as this creates a cyclic dependency, which GHC does not support." -- Helper functions @@ -431,11 +437,12 @@ emptyModuleScopeU :: ModuleScopeU s emptyModuleScopeU = (Map.empty, Map.empty) - -- | The mutable counterpart of 'ModuleScope'. type ModuleScopeU s = (ModuleProvidesU s, ModuleRequiresU s) + -- | The mutable counterpart of 'ModuleProvides' type ModuleProvidesU s = Map ModuleName [ModuleWithSourceU s] + type ModuleRequiresU s = ModuleProvidesU s type ModuleWithSourceU s = WithSource (ModuleU s) @@ -447,33 +454,41 @@ where pn = pkgName (ci_pkgid ci) pp_pn = - case ci_cname ci of - CLibName LMainLibName -> pretty pn - CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn - -- Shouldn't happen - cn -> pretty pn <+> parens (pretty cn) + case ci_cname ci of + CLibName LMainLibName -> pretty pn + CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn + -- Shouldn't happen + cn -> pretty pn <+> parens (pretty cn) -- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do -- unification on it. convertInclude - :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming - -> UnifyM s (ModuleScopeU s, - Either (ComponentInclude (UnitIdU s) ModuleRenaming) {- normal -} - (ComponentInclude (UnitIdU s) ModuleRenaming) {- sig -}) -convertInclude ci@(ComponentInclude { - ci_ann_id = AnnotatedId { - ann_id = (uid, ModuleShape provs reqs), - ann_pid = pid, - ann_cname = compname - }, - ci_renaming = incl@(IncludeRenaming prov_rns req_rns), - ci_implicit = implicit - }) = addErrContext (text "In" <+> ci_msg ci) $ do + :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming + -> UnifyM + s + ( ModuleScopeU s + , Either + (ComponentInclude (UnitIdU s) ModuleRenaming {- normal -}) + (ComponentInclude (UnitIdU s) ModuleRenaming {- sig -}) + ) +convertInclude + ci@( ComponentInclude + { ci_ann_id = + AnnotatedId + { ann_id = (uid, ModuleShape provs reqs) + , ann_pid = pid + , ann_cname = compname + } + , ci_renaming = incl@(IncludeRenaming prov_rns req_rns) + , ci_implicit = implicit + } + ) = addErrContext (text "In" <+> ci_msg ci) $ do let pn = packageName pid - the_source | implicit - = FromBuildDepends pn compname - | otherwise - = FromMixins pn compname incl + the_source + | implicit = + FromBuildDepends pn compname + | otherwise = + FromMixins pn compname incl source = WithSource the_source -- Suppose our package has two requirements A and B, and @@ -498,27 +513,31 @@ case req_rns of DefaultRenaming -> return [] HidingRenaming _ -> do - -- Not valid here for requires! - addErr $ text "Unsupported syntax" <+> - quotes (text "requires hiding (...)") - return [] + -- Not valid here for requires! + addErr $ + text "Unsupported syntax" + <+> quotes (text "requires hiding (...)") + return [] ModuleRenaming rns -> return rns let req_rename_listmap :: Map ModuleName [ModuleName] req_rename_listmap = - Map.fromListWith (++) [ (k,[v]) | (k,v) <- req_rename_list ] + Map.fromListWith (++) [(k, [v]) | (k, v) <- req_rename_list] req_rename <- sequenceA . flip Map.mapWithKey req_rename_listmap $ \k vs0 -> case vs0 of - [] -> error "req_rename" + [] -> error "req_rename" [v] -> return v - v:vs -> do addErr $ - text "Conflicting renamings of requirement" <+> quotes (pretty k) $$ - text "Renamed to: " <+> vcat (map pretty (v:vs)) - return v + v : vs -> do + addErr $ + text "Conflicting renamings of requirement" + <+> quotes (pretty k) + $$ text "Renamed to: " + <+> vcat (map pretty (v : vs)) + return v let req_rename_fn k = case Map.lookup k req_rename of - Nothing -> k - Just v -> v + Nothing -> k + Just v -> v -- Requirement substitution. -- @@ -533,19 +552,25 @@ -- mappings. -- -- A -> X ==> X -> , B -> - reqs_u <- convertModuleRequires . Map.fromList $ - [ (k, [source (OpenModuleVar k)]) - | k <- map req_rename_fn (Set.toList reqs) - ] + reqs_u <- + convertModuleRequires . Map.fromList $ + [ (k, [source (OpenModuleVar k)]) + | k <- map req_rename_fn (Set.toList reqs) + ] -- Report errors if there were unused renamings let leftover = Map.keysSet req_rename `Set.difference` reqs unless (Set.null leftover) $ - addErr $ - hang (text "The" <+> text (showComponentName compname) <+> - text "from package" <+> quotes (pretty pid) - <+> text "does not require:") 4 - (vcat (map pretty (Set.toList leftover))) + addErr $ + hang + ( text "The" + <+> text (showComponentName compname) + <+> text "from package" + <+> quotes (pretty pid) + <+> text "does not require:" + ) + 4 + (vcat (map pretty (Set.toList leftover))) -- Provision computation is more complex. -- For example, if we have: @@ -569,56 +594,72 @@ -- Importantly, overlapping rename targets get accumulated -- together. It's not an (immediate) error. (pre_prov_scope, prov_rns') <- - case prov_rns of - DefaultRenaming -> return (Map.toList provs, prov_rns) - HidingRenaming hides -> - let hides_set = Set.fromList hides - in let r = [ (k,v) - | (k,v) <- Map.toList provs - , not (k `Set.member` hides_set) ] - -- GHC doesn't understand hiding, so expand it out! - in return (r, ModuleRenaming (map ((\x -> (x,x)).fst) r)) - ModuleRenaming rns -> do - r <- sequence - [ case Map.lookup from provs of - Just m -> return (to, m) - Nothing -> failWith $ - text "Package" <+> quotes (pretty pid) <+> - text "does not expose the module" <+> quotes (pretty from) - | (from, to) <- rns ] - return (r, prov_rns) - let prov_scope = modSubst req_subst - $ Map.fromListWith (++) - [ (k, [source v]) - | (k, v) <- pre_prov_scope ] + case prov_rns of + DefaultRenaming -> return (Map.toList provs, prov_rns) + HidingRenaming hides -> + let hides_set = Set.fromList hides + in let r = + [ (k, v) + | (k, v) <- Map.toList provs + , not (k `Set.member` hides_set) + ] + in -- GHC doesn't understand hiding, so expand it out! + return (r, ModuleRenaming (map ((\x -> (x, x)) . fst) r)) + ModuleRenaming rns -> do + r <- + sequence + [ case Map.lookup from provs of + Just m -> return (to, m) + Nothing -> + failWith $ + text "Package" + <+> quotes (pretty pid) + <+> text "does not expose the module" + <+> quotes (pretty from) + | (from, to) <- rns + ] + return (r, prov_rns) + let prov_scope = + modSubst req_subst $ + Map.fromListWith + (++) + [ (k, [source v]) + | (k, v) <- pre_prov_scope + ] provs_u <- convertModuleProvides prov_scope -- TODO: Assert that provs_u is empty if provs was empty - return ((provs_u, reqs_u), - -- NB: We test that requirements is not null so that - -- users can create packages with zero module exports - -- that cause some C library to linked in, etc. - (if Map.null provs && not (Set.null reqs) - then Right -- is sig - else Left) (ComponentInclude { - ci_ann_id = AnnotatedId { - ann_id = uid_u, - ann_pid = pid, - ann_cname = compname - }, - ci_renaming = prov_rns', - ci_implicit = ci_implicit ci - })) + return + ( (provs_u, reqs_u) + , -- NB: We test that requirements is not null so that + -- users can create packages with zero module exports + -- that cause some C library to linked in, etc. + ( if Map.null provs && not (Set.null reqs) + then Right -- is sig + else Left + ) + ( ComponentInclude + { ci_ann_id = + AnnotatedId + { ann_id = uid_u + , ann_pid = pid + , ann_cname = compname + } + , ci_renaming = prov_rns' + , ci_implicit = ci_implicit ci + } + ) + ) -- | Convert a 'ModuleScopeU' to a 'ModuleScope'. convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope convertModuleScopeU (provs_u, reqs_u) = do - provs <- convertModuleProvidesU provs_u - reqs <- convertModuleRequiresU reqs_u - -- TODO: Test that the requirements are still free. If they - -- are not, they got unified, and that's dodgy at best. - return (ModuleScope provs reqs) + provs <- convertModuleProvidesU provs_u + reqs <- convertModuleRequiresU reqs_u + -- TODO: Test that the requirements are still free. If they + -- are not, they got unified, and that's dodgy at best. + return (ModuleScope provs reqs) -- | Convert a 'ModuleProvides' to a 'ModuleProvidesU' convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s) diff --git a/src/Distribution/Compat/Async.hs b/src/Distribution/Compat/Async.hs --- a/src/Distribution/Compat/Async.hs +++ b/src/Distribution/Compat/Async.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} + -- | 'Async', yet using 'MVar's. -- -- Adopted from @async@ library @@ -7,24 +8,38 @@ -- Licensed under BSD-3-Clause -- -- @since 3.2.0.0 --- -module Distribution.Compat.Async ( - AsyncM, - withAsync, waitCatch, - wait, asyncThreadId, - cancel, uninterruptibleCancel, AsyncCancelled (..), +module Distribution.Compat.Async + ( AsyncM + , withAsync + , waitCatch + , wait + , asyncThreadId + , cancel + , uninterruptibleCancel + , AsyncCancelled (..) + -- * Cabal extras - withAsyncNF, - ) where + , withAsyncNF + ) where -import Control.Concurrent (ThreadId, forkIO) +import Control.Concurrent (ThreadId, forkIO) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) -import Control.DeepSeq (NFData, force) +import Control.DeepSeq (NFData, force) import Control.Exception - (BlockedIndefinitelyOnMVar (..), Exception (..), SomeException (..), catch, evaluate, mask, throwIO, throwTo, try, uninterruptibleMask_) -import Control.Monad (void) -import Data.Typeable (Typeable) -import GHC.Exts (inline) + ( BlockedIndefinitelyOnMVar (..) + , Exception (..) + , SomeException (..) + , catch + , evaluate + , mask + , throwIO + , throwTo + , try + , uninterruptibleMask_ + ) +import Control.Monad (void) +import Data.Typeable (Typeable) +import GHC.Exts (inline) #if MIN_VERSION_base(4,7,0) import Control.Exception (asyncExceptionFromException, asyncExceptionToException) @@ -33,9 +48,9 @@ -- | Async, but based on 'MVar', as we don't depend on @stm@. data AsyncM a = Async { asyncThreadId :: {-# UNPACK #-} !ThreadId - -- ^ Returns the 'ThreadId' of the thread running - -- the given 'Async'. - , _asyncMVar :: MVar (Either SomeException a) + -- ^ Returns the 'ThreadId' of the thread running + -- the given 'Async'. + , _asyncMVar :: MVar (Either SomeException a) } -- | Spawn an asynchronous action in a separate thread, and pass its @@ -52,12 +67,12 @@ -- Note: a reference to the child thread is kept alive until the call -- to `withAsync` returns, so nesting many `withAsync` calls requires -- linear memory. --- withAsync :: IO a -> (AsyncM a -> IO b) -> IO b withAsync = inline withAsyncUsing forkIO withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b -withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) where +withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) + where evaluateNF = evaluate . force withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b @@ -68,7 +83,8 @@ mask $ \restore -> do t <- doFork $ try (restore action) >>= putMVar var let a = Async t var - r <- restore (inner a) `catchAll` \e -> do + r <- + restore (inner a) `catchAll` \e -> do uninterruptibleCancel a throwIO e uninterruptibleCancel a @@ -79,21 +95,19 @@ -- exception is re-thrown by 'wait'. -- -- > wait = atomically . waitSTM --- {-# INLINE wait #-} wait :: AsyncM a -> IO a wait a = do - res <- waitCatch a - case res of - Left (SomeException e) -> throwIO e - Right x -> return x + res <- waitCatch a + case res of + Left (SomeException e) -> throwIO e + Right x -> return x -- | Wait for an asynchronous action to complete, and return either -- @Left e@ if the action raised an exception @e@, or @Right a@ if it -- returned a value @a@. -- -- > waitCatch = atomically . waitCatchSTM --- {-# INLINE waitCatch #-} waitCatch :: AsyncM a -> IO (Either SomeException a) waitCatch (Async _ var) = tryAgain (readMVar var) @@ -123,15 +137,18 @@ {-# INLINE cancel #-} cancel :: AsyncM a -> IO () cancel a@(Async t _) = do - throwTo t AsyncCancelled - void (waitCatch a) + throwTo t AsyncCancelled + void (waitCatch a) -- | The exception thrown by `cancel` to terminate a thread. data AsyncCancelled = AsyncCancelled - deriving (Show, Eq + deriving + ( Show + , Eq , Typeable ) +{- FOURMOLU_DISABLE -} instance Exception AsyncCancelled where #if MIN_VERSION_base(4,7,0) -- wraps in SomeAsyncException @@ -139,6 +156,7 @@ fromException = asyncExceptionFromException toException = asyncExceptionToException #endif +{- FOURMOLU_ENABLE -} -- | Cancel an asynchronous action -- 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,18 +1,19 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.CopyFile ( - copyFile, - copyFileChanged, - filesEqual, - copyOrdinaryFile, - copyExecutableFile, - setFileOrdinary, - setFileExecutable, - setDirOrdinary, + +module Distribution.Compat.CopyFile + ( copyFile + , copyFileChanged + , filesEqual + , copyOrdinaryFile + , copyExecutableFile + , setFileOrdinary + , setFileExecutable + , setDirOrdinary ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () #ifndef mingw32_HOST_OS import Distribution.Compat.Internal.TempFile @@ -66,7 +67,7 @@ #endif /* mingw32_HOST_OS */ copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO () -copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest +copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () @@ -93,7 +94,7 @@ copyFile fromFPath toFPath = copy `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile")) - where + where #ifndef mingw32_HOST_OS copy = withBinaryFile fromFPath ReadMode $ \hFrom -> bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> @@ -239,8 +240,9 @@ filesEqual f1 f2 = do ex1 <- doesFileExist f1 ex2 <- doesFileExist f2 - if not (ex1 && ex2) then return False else - withBinaryFile f1 ReadMode $ \h1 -> + if not (ex1 && ex2) + then return False + else withBinaryFile f1 ReadMode $ \h1 -> withBinaryFile f2 ReadMode $ \h2 -> do s1 <- hFileSize h1 s2 <- hFileSize h2 diff --git a/src/Distribution/Compat/Directory.hs b/src/Distribution/Compat/Directory.hs --- a/src/Distribution/Compat/Directory.hs +++ b/src/Distribution/Compat/Directory.hs @@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} module Distribution.Compat.Directory -( listDirectory -, makeAbsolute -, doesPathExist -) where + ( listDirectory + , makeAbsolute + , doesPathExist + ) where #if MIN_VERSION_directory(1,2,7) import System.Directory as Dir hiding (doesPathExist) @@ -46,4 +46,3 @@ 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 @@ -3,16 +3,15 @@ {-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.Environment - ( getEnvironment, lookupEnv, setEnv, unsetEnv ) - where +module Distribution.Compat.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv) +where +import Distribution.Compat.Prelude import Prelude () import qualified Prelude -import Distribution.Compat.Prelude -import qualified System.Environment as System import System.Environment (lookupEnv, unsetEnv) +import qualified System.Environment as System import Distribution.Compat.Stack @@ -61,6 +60,7 @@ where _ = callStack -- TODO: attach CallStack to exception +{- FOURMOLU_DISABLE -} # if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall # elif defined(x86_64_HOST_ARCH) @@ -83,3 +83,4 @@ foreign import ccall unsafe "setenv" c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt #endif /* mingw32_HOST_OS */ +{- FOURMOLU_ENABLE -} diff --git a/src/Distribution/Compat/FilePath.hs b/src/Distribution/Compat/FilePath.hs --- a/src/Distribution/Compat/FilePath.hs +++ b/src/Distribution/Compat/FilePath.hs @@ -1,13 +1,12 @@ {-# LANGUAGE CPP #-} - {-# OPTIONS_GHC -fno-warn-unused-imports #-} module Distribution.Compat.FilePath -( isExtensionOf -, stripExtension -) where + ( isExtensionOf + , stripExtension + ) where -import Data.List ( isSuffixOf, stripPrefix ) +import Data.List (isSuffixOf, stripPrefix) import System.FilePath #if !MIN_VERSION_filepath(1,4,2) 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,6 +1,7 @@ {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Compat.GetShortPathName -- @@ -8,12 +9,11 @@ -- Portability : Windows-only -- -- Win32 API 'GetShortPathName' function. - -module Distribution.Compat.GetShortPathName ( getShortPathName ) - where +module Distribution.Compat.GetShortPathName (getShortPathName) +where -import Prelude () import Distribution.Compat.Prelude +import Prelude () #ifdef mingw32_HOST_OS @@ -22,6 +22,7 @@ import System.Win32 (LPCTSTR, LPTSTR, DWORD) import Foreign.Marshal.Array (allocaArray) +{- FOURMOLU_DISABLE -} #ifdef x86_64_HOST_ARCH #define WINAPI ccall #else @@ -57,3 +58,4 @@ 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 @@ -1,17 +1,18 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.Internal.TempFile ( - openTempFile, - openBinaryTempFile, - openNewBinaryFile, - createTempDirectory, + +module Distribution.Compat.Internal.TempFile + ( openTempFile + , openBinaryTempFile + , openNewBinaryFile + , createTempDirectory ) where import Distribution.Compat.Exception -import System.FilePath (()) +import System.FilePath (()) -import System.IO (Handle, openTempFile, openBinaryTempFile) +import System.IO (Handle, openBinaryTempFile, openTempFile) #if defined(__IO_MANAGER_WINIO__) import System.IO (openBinaryTempFileWithDefaultPermissions) #else @@ -23,8 +24,8 @@ o_CREAT, o_RDWR, o_NONBLOCK, o_NOCTTY) #endif +import System.IO.Error (isAlreadyExistsError) import System.Posix.Internals (c_getpid) -import System.IO.Error (isAlreadyExistsError) #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) import System.Directory ( createDirectory ) @@ -33,7 +34,9 @@ #endif -- ------------------------------------------------------------ + -- * temporary files + -- ------------------------------------------------------------ -- This is here for Haskell implementations that do not come with @@ -46,9 +49,10 @@ -- 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. + +-- 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 @@ -126,8 +130,9 @@ r <- tryIO $ mkPrivateDir dirpath case r of Right _ -> return dirpath - Left e | isAlreadyExistsError e -> findTempName (x+1) - | otherwise -> ioError e + Left e + | isAlreadyExistsError e -> findTempName (x + 1) + | otherwise -> ioError e mkPrivateDir :: String -> IO () #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) diff --git a/src/Distribution/Compat/Prelude/Internal.hs b/src/Distribution/Compat/Prelude/Internal.hs --- a/src/Distribution/Compat/Prelude/Internal.hs +++ b/src/Distribution/Compat/Prelude/Internal.hs @@ -7,8 +7,8 @@ -- for @Setup.hs@ scripts since its API is /not/ -- stable. module Distribution.Compat.Prelude.Internal - {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-} - ( module Distribution.Compat.Prelude - ) where + {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-} + ( module Distribution.Compat.Prelude + ) where import Distribution.Compat.Prelude diff --git a/src/Distribution/Compat/Process.hs b/src/Distribution/Compat/Process.hs --- a/src/Distribution/Compat/Process.hs +++ b/src/Distribution/Compat/Process.hs @@ -1,12 +1,14 @@ {-# LANGUAGE CPP #-} -module Distribution.Compat.Process ( - -- * Redefined functions - proc, + +module Distribution.Compat.Process + ( -- * Redefined functions + proc + -- * Additions - enableProcessJobs, - ) where + , enableProcessJobs + ) where -import System.Process (CreateProcess) +import System.Process (CreateProcess) import qualified System.Process as Process #if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9) @@ -58,4 +60,4 @@ -- | 'System.Process.proc' with process jobs enabled when appropriate, -- and defaulting 'delegate_ctlc' to 'True'. proc :: FilePath -> [String] -> CreateProcess -proc path args = enableProcessJobs (Process.proc path args) { Process.delegate_ctlc = True } +proc path args = enableProcessJobs (Process.proc path args){Process.delegate_ctlc = True} 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,11 @@ -{-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# 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) where +module Distribution.Compat.ResponseFile (expandResponse, escapeArgs) where import Distribution.Compat.Prelude import Prelude () @@ -13,7 +15,7 @@ import System.IO.Error #if MIN_VERSION_base(4,12,0) -import GHC.ResponseFile (unescapeArgs) +import GHC.ResponseFile (unescapeArgs, escapeArgs) #else unescapeArgs :: String -> [String] @@ -47,8 +49,28 @@ | '"' == c = go cs DblQ False a as | otherwise = go cs NoneQ False (c:a) as +escapeArgs :: [String] -> String +escapeArgs = unlines . map escapeArg + +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs + #endif +-- | 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. expandResponse :: [String] -> IO [String] expandResponse = go recursionLimit "." where @@ -56,11 +78,11 @@ go :: Int -> FilePath -> [String] -> IO [String] go n dir - | n >= 0 = fmap concat . traverse (expand n dir) + | n >= 0 = fmap concat . traverse (expand n dir) | 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 (print "?" >> return [arg]) expand _n _dir x = return [x] readRecursively :: Int -> FilePath -> IO [String] diff --git a/src/Distribution/Compat/SnocList.hs b/src/Distribution/Compat/SnocList.hs --- a/src/Distribution/Compat/SnocList.hs +++ b/src/Distribution/Compat/SnocList.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Compat.SnocList -- License : BSD3 @@ -8,14 +9,14 @@ -- Portability : portable -- -- A very reversed list. Has efficient `snoc` -module Distribution.Compat.SnocList ( - SnocList, - runSnocList, - snoc, -) where +module Distribution.Compat.SnocList + ( SnocList + , runSnocList + , snoc + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () newtype SnocList a = SnocList [a] @@ -26,8 +27,8 @@ runSnocList (SnocList xs) = reverse xs instance Semigroup (SnocList a) where - SnocList xs <> SnocList ys = SnocList (ys <> xs) + SnocList xs <> SnocList ys = SnocList (ys <> xs) instance Monoid (SnocList a) where - mempty = SnocList [] - mappend = (<>) + 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 @@ -1,17 +1,18 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ImplicitParams #-} -module Distribution.Compat.Stack ( - WithCallStack, - CallStack, - annotateCallStackIO, - withFrozenCallStack, - withLexicalCallStack, - callStack, - prettyCallStack, - parentSrcLocPrefix -) where +{-# LANGUAGE RankNTypes #-} +module Distribution.Compat.Stack + ( WithCallStack + , CallStack + , annotateCallStackIO + , withFrozenCallStack + , withLexicalCallStack + , callStack + , prettyCallStack + , parentSrcLocPrefix + ) where + import System.IO.Error #ifdef MIN_VERSION_base @@ -106,8 +107,9 @@ annotateCallStackIO :: WithCallStack (IO a -> IO a) annotateCallStackIO = modifyIOError f where - f ioe = ioeSetErrorString ioe - . wrapCallStack - $ ioeGetErrorString ioe + f ioe = + ioeSetErrorString ioe + . wrapCallStack + $ ioeGetErrorString ioe wrapCallStack s = - prettyCallStack callStack ++ "\n" ++ s + prettyCallStack callStack ++ "\n" ++ s 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,32 +1,33 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Compat.Time - ( ModTime(..) -- Needed for testing - , getModTime, getFileAge, getCurTime - , posixSecondsToModTime - , calibrateMtimeChangeDelay ) - where + ( ModTime (..) -- Needed for testing + , getModTime + , getFileAge + , getCurTime + , posixSecondsToModTime + , calibrateMtimeChangeDelay + ) +where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import System.Directory ( getModificationTime ) +import System.Directory (getModificationTime) -import Distribution.Simple.Utils ( withTempDirectory ) -import Distribution.Verbosity ( silent ) +import Distribution.Simple.Utils (withTempDirectory) +import Distribution.Verbosity (silent) import System.FilePath -import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime ) -import Data.Time ( diffUTCTime, getCurrentTime ) -import Data.Time.Clock.POSIX ( posixDayLength ) - +import Data.Time (diffUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixDayLength) #if defined mingw32_HOST_OS @@ -57,7 +58,7 @@ -- | An opaque type representing a 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, Typeable) + deriving (Binary, Generic, Bounded, Eq, Ord, Typeable) instance Structured ModTime @@ -101,6 +102,7 @@ #endif return $! ModTime (qwTime :: Word64) +{- FOURMOLU_DISABLE -} #ifdef x86_64_HOST_ARCH #define CALLCONV ccall #else @@ -138,9 +140,10 @@ extractFileTime x = posixTimeToModTime (modificationTimeHiRes x) #endif +{- FOURMOLU_ENABLE -} windowsTick, secToUnixEpoch :: Word64 -windowsTick = 10000000 +windowsTick = 10000000 secToUnixEpoch = 11644473600 -- | Convert POSIX seconds to ModTime. @@ -150,8 +153,10 @@ -- | Convert 'POSIXTime' to 'ModTime'. posixTimeToModTime :: POSIXTime -> ModTime -posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision - + (secToUnixEpoch * windowsTick) +posixTimeToModTime p = + ModTime $ + ceiling (p * 1e7) -- 100 ns precision + + (secToUnixEpoch * windowsTick) -- | Return age of given file in days. getFileAge :: FilePath -> IO Double @@ -174,15 +179,15 @@ calibrateMtimeChangeDelay = withTempDirectory silent "." "calibration-" $ \dir -> do let fileName = dir "probe" - mtimes <- for [1..25] $ \(i::Int) -> time $ do + mtimes <- for [1 .. 25] $ \(i :: Int) -> time $ do writeFile fileName $ show i t0 <- getModTime fileName let spin j = do - writeFile fileName $ show (i,j) + writeFile fileName $ show (i, j) t1 <- getModTime fileName unless (t0 < t1) (spin $ j + 1) - spin (0::Int) - let mtimeChange = maximum mtimes + spin (0 :: Int) + let mtimeChange = maximum mtimes mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2 return (mtimeChange, mtimeChange') where diff --git a/src/Distribution/GetOpt.hs b/src/Distribution/GetOpt.hs --- a/src/Distribution/GetOpt.hs +++ b/src/Distribution/GetOpt.hs @@ -1,4 +1,8 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.GetOpt -- Copyright : (c) Sven Panne 2002-2005 @@ -20,78 +24,84 @@ -- * Parsing of option arguments is allowed to fail. -- -- * 'ReturnInOrder' argument order is removed. --- -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NamedFieldPuns #-} -module Distribution.GetOpt ( - -- * GetOpt - getOpt, getOpt', - usageInfo, - ArgOrder(..), - OptDescr(..), - ArgDescr(..), +module Distribution.GetOpt + ( -- * GetOpt + getOpt + , getOpt' + , usageInfo + , ArgOrder (..) + , OptDescr (..) + , ArgDescr (..) - -- * Example - -- | See "System.Console.GetOpt" for examples -) where + -- * Example -import Prelude () + -- | See "System.Console.GetOpt" for examples + ) where + import Distribution.Compat.Prelude +import Prelude () -- | What to do with options following non-options data ArgOrder a - = RequireOrder -- ^ no option processing after first non-option - | Permute -- ^ freely intersperse options and non-options + = -- | no option processing after first non-option + RequireOrder + | -- | freely intersperse options and non-options + Permute -data OptDescr a = -- description of a single options: - Option [Char] -- list of short option characters - [String] -- list of long option strings (without "--") - (ArgDescr a) -- argument descriptor - String -- explanation of option for user +data OptDescr a -- description of a single options: + = Option + [Char] -- list of short option characters + [String] -- list of long option strings (without "--") + (ArgDescr a) -- argument descriptor + String -- explanation of option for user instance Functor OptDescr where - fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c + fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c -- | Describes whether an option takes an argument or not, and if so -- how the argument is parsed to a value of type @a@. -- -- Compared to System.Console.GetOpt, we allow for parse errors. data ArgDescr a - = NoArg a -- ^ no argument expected - | ReqArg (String -> Either String a) String -- ^ option requires argument - | OptArg (Maybe String -> Either String a) String -- ^ optional argument + = -- | no argument expected + NoArg a + | -- | option requires argument + ReqArg (String -> Either String a) String + | -- | optional argument + OptArg String (Maybe String -> Either String a) String instance Functor ArgDescr where - fmap f (NoArg a) = NoArg (f a) - fmap f (ReqArg g s) = ReqArg (fmap f . g) s - fmap f (OptArg g s) = OptArg (fmap f . g) s + fmap f (NoArg a) = NoArg (f a) + fmap f (ReqArg g s) = ReqArg (fmap f . g) s + fmap f (OptArg dv g s) = OptArg dv (fmap f . g) s -data OptKind a -- kind of cmd line arg (internal use only): - = Opt a -- an option - | UnreqOpt String -- an un-recognized option - | NonOpt String -- a non-option - | EndOfOpts -- end-of-options marker (i.e. "--") - | OptErr String -- something went wrong... +data OptKind a -- kind of cmd line arg (internal use only): + = Opt a -- an option + | UnreqOpt String -- an un-recognized option + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... -data OptHelp = OptHelp { - optNames :: String, - optHelp :: String - } +data OptHelp = OptHelp + { optNames :: String + , optHelp :: String + } -- | Return a string describing the usage of a command, derived from -- the header (first argument) and the options described by the -- second argument. -usageInfo :: String -- header - -> [OptDescr a] -- option descriptors - -> String -- nicely formatted description of options +usageInfo + :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted description of options usageInfo header optDescr = unlines (header : table) where options = flip map optDescr $ \(Option sos los ad d) -> OptHelp { optNames = - intercalate ", " $ - map (fmtShort ad) sos ++ - map (fmtLong ad) (take 1 los) + intercalate ", " $ + map (fmtShort ad) sos + ++ map (fmtLong ad) (take 1 los) , optHelp = d } @@ -103,8 +113,9 @@ OptHelp{optNames, optHelp} <- options let wrappedHelp = wrapText descolWidth optHelp if length optNames >= maxOptNameWidth - then [" " ++ optNames] ++ - renderColumns [] wrappedHelp + then + [" " ++ optNames] + ++ renderColumns [] wrappedHelp else renderColumns [optNames] wrappedHelp renderColumns :: [String] -> [String] -> [String] @@ -112,146 +123,179 @@ (x, y) <- zipDefault "" "" xs ys return $ " " ++ padTo maxOptNameWidth x ++ " " ++ y - padTo n x = take n (x ++ repeat ' ') + padTo n x = take n (x ++ repeat ' ') -zipDefault :: a -> b -> [a] -> [b] -> [(a,b)] -zipDefault _ _ [] [] = [] -zipDefault _ bd (a:as) [] = (a,bd) : map (,bd) as -zipDefault ad _ [] (b:bs) = (ad,b) : map (ad,) bs -zipDefault ad bd (a:as) (b:bs) = (a,b) : zipDefault ad bd as bs +zipDefault :: a -> b -> [a] -> [b] -> [(a, b)] +zipDefault _ _ [] [] = [] +zipDefault _ bd (a : as) [] = (a, bd) : map (,bd) as +zipDefault ad _ [] (b : bs) = (ad, b) : map (ad,) bs +zipDefault ad bd (a : as) (b : bs) = (a, b) : zipDefault ad bd as bs +-- | Pretty printing of short options. +-- * With required arguments can be given as: +-- @-w PATH or -wPATH (but not -w=PATH)@ +-- This is dislayed 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: +-- @-j[NUM]@ fmtShort :: ArgDescr a -> Char -> String -fmtShort (NoArg _ ) so = "-" ++ [so] -fmtShort (ReqArg _ _) so = "-" ++ [so] -fmtShort (OptArg _ _) so = "-" ++ [so] - -- unlike upstream GetOpt we omit the arg name for short options +fmtShort (NoArg _) so = "-" ++ [so] +fmtShort (ReqArg _ ad) so = + let opt = "-" ++ [so] + in opt ++ " " ++ ad ++ " or " ++ opt ++ ad +fmtShort (OptArg _ _ ad) so = + let opt = "-" ++ [so] + in opt ++ "[" ++ ad ++ "]" +-- | Pretty printing of long options. +-- * With required arguments can be given as: +-- @--with-compiler=PATH (but not --with-compiler PATH)@ +-- This is dislayed 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: +-- @--jobs[=NUM]@ fmtLong :: ArgDescr a -> String -> String -fmtLong (NoArg _ ) lo = "--" ++ lo -fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad -fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" +fmtLong (NoArg _) lo = "--" ++ lo +fmtLong (ReqArg _ ad) lo = + let opt = "--" ++ lo + in opt ++ "=" ++ ad +fmtLong (OptArg _ _ ad) lo = + let opt = "--" ++ lo + in opt ++ "[=" ++ ad ++ "]" wrapText :: Int -> String -> [String] wrapText width = map unwords . wrap 0 [] . words - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] - -{-| -Process the command-line, and return the list of values that matched -(and those that didn\'t). The arguments are: - -* The order requirements (see 'ArgOrder') - -* The option descriptions (see 'OptDescr') - -* The actual command line arguments (presumably got from - 'System.Environment.getArgs'). + where + wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w : ws) + | length w + 1 > width = + wrap (length w) [w] ws + wrap col line (w : ws) + | col + length w + 1 > width = + reverse line : wrap 0 [] (w : ws) + wrap col line (w : ws) = + let col' = col + length w + 1 + in wrap col' (w : line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] -'getOpt' returns a triple consisting of the option arguments, a list -of non-options, and a list of error messages. --} -getOpt :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String],[String]) -- (options,non-options,error messages) -getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) - where (os,xs,us,es) = getOpt' ordering optDescr args +-- | +-- Process the command-line, and return the list of values that matched +-- (and those that didn\'t). The arguments are: +-- +-- * The order requirements (see 'ArgOrder') +-- +-- * The option descriptions (see 'OptDescr') +-- +-- * The actual command line arguments (presumably got from +-- 'System.Environment.getArgs'). +-- +-- 'getOpt' returns a triple consisting of the option arguments, a list +-- of non-options, and a list of error messages. +getOpt + :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a], [String], [String]) -- (options,non-options,error messages) +getOpt ordering optDescr args = (os, xs, es ++ map errUnrec us) + where + (os, xs, us, es) = getOpt' ordering optDescr args -{-| -This is almost the same as 'getOpt', but returns a quadruple -consisting of the option arguments, a list of non-options, a list of -unrecognized options, and a list of error messages. --} -getOpt' :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) -getOpt' _ _ [] = ([],[],[],[]) -getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering - where procNextOpt (Opt o) _ = (o:os,xs,us,es) - procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) - procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) - procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) - procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) - procNextOpt EndOfOpts Permute = ([],rest,[],[]) - procNextOpt (OptErr e) _ = (os,xs,us,e:es) +-- | +-- This is almost the same as 'getOpt', but returns a quadruple +-- consisting of the option arguments, a list of non-options, a list of +-- unrecognized options, and a list of error messages. +getOpt' + :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a], [String], [String], [String]) -- (options,non-options,unrecognized,error messages) +getOpt' _ _ [] = ([], [], [], []) +getOpt' ordering optDescr (arg : args) = procNextOpt opt ordering + where + procNextOpt (Opt o) _ = (o : os, xs, us, es) + procNextOpt (UnreqOpt u) _ = (os, xs, u : us, es) + procNextOpt (NonOpt x) RequireOrder = ([], x : rest, [], []) + procNextOpt (NonOpt x) Permute = (os, x : xs, us, es) + procNextOpt EndOfOpts RequireOrder = ([], rest, [], []) + procNextOpt EndOfOpts Permute = ([], rest, [], []) + procNextOpt (OptErr e) _ = (os, xs, us, e : es) - (opt,rest) = getNext arg args optDescr - (os,xs,us,es) = getOpt' ordering optDescr rest + (opt, rest) = getNext arg args optDescr + (os, xs, us, es) = getOpt' ordering optDescr rest -- 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 ('-':'-':xs) rest optDescr = longOpt xs rest optDescr -getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr -getNext a rest _ = (NonOpt a,rest) +getNext :: String -> [String] -> [OptDescr a] -> (OptKind a, [String]) +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) -- handle long option -longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a, [String]) longOpt ls rs optDescr = long ads arg rs - where (opt,arg) = break (=='=') ls - getWith p = [ o | o@(Option _ xs _ _) <- optDescr - , isJust (find (p opt) xs)] - exact = getWith (==) - options = if null exact then getWith isPrefixOf else exact - ads = [ ad | Option _ _ ad _ <- options ] - optStr = "--" ++ opt - fromRes = fromParseResult optStr + where + (opt, arg) = break (== '=') ls + getWith p = + [ o | o@(Option _ xs _ _) <- optDescr, isJust (find (p opt) xs) + ] + exact = getWith (==) + options = if null exact then getWith isPrefixOf else exact + ads = [ad | Option _ _ ad _ <- options] + optStr = "--" ++ opt + fromRes = fromParseResult optStr - long (_:_:_) _ rest = (errAmbig options optStr,rest) - long [NoArg a ] [] rest = (Opt a,rest) - long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) - long [ReqArg _ d] [] [] = (errReq d optStr,[]) - long [ReqArg f _] [] (r:rest) = (fromRes (f r),rest) - long [ReqArg f _] ('=':xs) rest = (fromRes (f xs),rest) - long [OptArg f _] [] rest = (fromRes (f Nothing),rest) - long [OptArg f _] ('=':xs) rest = (fromRes (f (Just xs)),rest) - long _ _ rest = (UnreqOpt ("--"++ls),rest) + long (_ : _ : _) _ rest = (errAmbig options optStr, rest) + long [NoArg a] [] rest = (Opt a, rest) + long [NoArg _] ('=' : _) rest = (errNoArg optStr, rest) + long [ReqArg _ d] [] [] = (errReq d optStr, []) + long [ReqArg f _] [] (r : rest) = (fromRes (f r), rest) + long [ReqArg f _] ('=' : xs) rest = (fromRes (f xs), rest) + long [OptArg _ f _] [] rest = (fromRes (f Nothing), rest) + long [OptArg _ f _] ('=' : xs) rest = (fromRes (f (Just xs)), rest) + long _ _ rest = (UnreqOpt ("--" ++ ls), rest) -- handle short option -shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a, [String]) shortOpt y ys rs optDescr = short ads ys rs - where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] - ads = [ ad | Option _ _ ad _ <- options ] - optStr = '-':[y] - fromRes = fromParseResult optStr + where + options = [o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s] + ads = [ad | Option _ _ ad _ <- options] + optStr = '-' : [y] + fromRes = fromParseResult optStr - short (_:_:_) _ rest = (errAmbig options optStr,rest) - short (NoArg a :_) [] rest = (Opt a,rest) - short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) - short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) - short (ReqArg f _:_) [] (r:rest) = (fromRes (f r),rest) - short (ReqArg f _:_) xs rest = (fromRes (f xs),rest) - short (OptArg f _:_) [] rest = (fromRes (f Nothing),rest) - short (OptArg f _:_) xs rest = (fromRes (f (Just xs)),rest) - short [] [] rest = (UnreqOpt optStr,rest) - short [] xs rest = (UnreqOpt (optStr++xs),rest) - -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest) - -- Apparently this was part of the change so that flags that are - -- not recognised as global flags are passed on to the sub-command. - -- But why was no equivalent change required for longOpt? So could - -- this change go upstream? + short (_ : _ : _) _ rest = (errAmbig options optStr, rest) + short (NoArg a : _) [] rest = (Opt a, rest) + short (NoArg a : _) xs rest = (Opt a, ('-' : xs) : rest) + short (ReqArg _ d : _) [] [] = (errReq d optStr, []) + short (ReqArg f _ : _) [] (r : rest) = (fromRes (f r), rest) + short (ReqArg f _ : _) xs rest = (fromRes (f xs), rest) + short (OptArg _ f _ : _) [] rest = (fromRes (f Nothing), rest) + short (OptArg _ f _ : _) xs rest = (fromRes (f (Just xs)), rest) + short [] [] rest = (UnreqOpt optStr, rest) + short [] xs rest = (UnreqOpt (optStr ++ xs), rest) +-- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest) +-- Apparently this was part of the change so that flags that are +-- not recognised as global flags are passed on to the sub-command. +-- But why was no equivalent change required for longOpt? So could +-- this change go upstream? + fromParseResult :: String -> Either String a -> OptKind a fromParseResult optStr res = case res of - Right x -> Opt x - Left err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n") + Right x -> Opt x + Left err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n") -- miscellaneous error formatting errAmbig :: [OptDescr a] -> String -> OptKind b errAmbig ods optStr = OptErr (usageInfo header ods) - where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" + where + header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" errReq :: String -> String -> OptKind a errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") diff --git a/src/Distribution/Lex.hs b/src/Distribution/Lex.hs --- a/src/Distribution/Lex.hs +++ b/src/Distribution/Lex.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Lex -- Copyright : Ben Gamari 2015-2019 @@ -7,34 +8,43 @@ -- Portability : portable -- -- This module contains a simple lexer supporting quoted strings - -module Distribution.Lex ( - tokenizeQuotedWords - ) where +module Distribution.Lex + ( tokenizeQuotedWords + ) where -import Prelude () -import Distribution.Compat.Prelude import Distribution.Compat.DList +import Distribution.Compat.Prelude +import Prelude () +-- | A simple parser supporting quoted strings. +-- +-- Please be aware that this will only split strings when seeing whitespace +-- outside of quotation marks, i.e, @"foo\"bar baz\"qux quux"@ will be +-- converted to @["foobar bazqux", "quux"]@. +-- +-- This behavior can be useful when parsing text like +-- @"ghc-options: -Wl,\"some option with spaces\""@, for instance. tokenizeQuotedWords :: String -> [String] tokenizeQuotedWords = filter (not . null) . go False mempty where - go :: Bool -- ^ in quoted region - -> DList Char -- ^ accumulator - -> String -- ^ string to be parsed - -> [String] -- ^ parse result + go + :: Bool + -- \^ in quoted region + -> DList Char + -- \^ accumulator + -> String + -- \^ string to be parsed + -> [String] + -- \^ parse result go _ accum [] | [] <- accum' = [] - | otherwise = [accum'] - where accum' = runDList accum - - go False accum (c:cs) + | otherwise = [accum'] + where + accum' = runDList accum + go False accum (c : cs) | isSpace c = runDList accum : go False mempty cs - | c == '"' = go True accum cs - - go True accum (c:cs) - | c == '"' = go False accum cs - - go quoted accum (c:cs) - = go quoted (accum `mappend` singleton c) cs - + | c == '"' = go True accum cs + go True accum (c : cs) + | c == '"' = go False accum cs + go quoted accum (c : cs) = + go quoted (accum `mappend` singleton c) cs diff --git a/src/Distribution/Make.hs b/src/Distribution/Make.hs --- a/src/Distribution/Make.hs +++ b/src/Distribution/Make.hs @@ -2,6 +2,11 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + +-- copy : +-- $(MAKE) install prefix=$(destdir)/$(prefix) \ +-- bindir=$(destdir)/$(bindir) \ + -- | -- Module : Distribution.Make -- Copyright : Martin Sjögren 2004 @@ -51,32 +56,28 @@ -- [UnregisterCmd] We assume there is an @unregister@ target. -- -- [HaddockCmd] We assume there is a @docs@ or @doc@ target. - - --- copy : --- $(MAKE) install prefix=$(destdir)/$(prefix) \ --- bindir=$(destdir)/$(bindir) \ - -module Distribution.Make ( - module Distribution.Package, - License(..), Version, - defaultMain, defaultMainArgs +module Distribution.Make + ( module Distribution.Package + , License (..) + , Version + , defaultMain + , defaultMainArgs ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -- local import Distribution.Package +import Distribution.Simple.Command import Distribution.Simple.Program import Distribution.Simple.Setup -import Distribution.Simple.Command import Distribution.Simple.Utils import Distribution.License -import Distribution.Version import Distribution.Pretty +import Distribution.Version import System.Environment (getArgs, getProgName) @@ -87,20 +88,21 @@ defaultMainArgs = defaultMainHelper defaultMainHelper :: [String] -> IO () -defaultMainHelper args = - case commandsRun (globalCommand commands) commands args of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> +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 (globalVersion flags) -> printVersion | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action - + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action where printHelp help = getProgName >>= putStr . help printOptionsList = putStr . unlines @@ -108,20 +110,22 @@ putStr (intercalate "\n" errs) exitWith (ExitFailure 1) printNumericVersion = putStrLn $ prettyShow cabalVersion - printVersion = putStrLn $ "Cabal library version " - ++ 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 + [ 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 () @@ -130,16 +134,17 @@ let verbosity = fromFlag (configVerbosity flags) rawSystemExit verbosity "sh" $ "configure" - : configureArgs backwardsCompatHack flags - where backwardsCompatHack = True + : configureArgs backwardsCompatHack flags + where + backwardsCompatHack = True copyAction :: CopyFlags -> [String] -> IO () copyAction flags args = do noExtraFlags args let destArgs = case fromFlag $ copyDest flags of - NoCopyDest -> ["install"] - CopyTo path -> ["copy", "destdir=" ++ path] - CopyToDb _ -> error "CopyToDb not supported via Make" + NoCopyDest -> ["install"] + CopyTo path -> ["copy", "destdir=" ++ path] + CopyToDb _ -> error "CopyToDb not supported via Make" rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs @@ -154,7 +159,7 @@ noExtraFlags args rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"] `catchIO` \_ -> - rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] + rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] buildAction :: BuildFlags -> [String] -> IO () buildAction flags args = do @@ -172,7 +177,7 @@ rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"] registerAction :: RegisterFlags -> [String] -> IO () -registerAction flags args = do +registerAction flags args = do noExtraFlags args rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"] 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 @@ -1,2939 +1,1084 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.Check --- Copyright : Lennart Kolmodin 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This has code for checking for various problems in packages. There is one --- set of checks that just looks at a 'PackageDescription' in isolation and --- another set of checks that also looks at files in the package. Some of the --- checks are basic sanity checks, others are portability standards that we'd --- like to encourage. There is a 'PackageCheck' type that distinguishes the --- different kinds of checks so we can see which ones are appropriate to report --- in different situations. This code gets used when configuring a package when --- we consider only basic problems. The higher standard is used when --- preparing a source tarball and by Hackage when uploading new packages. The --- reason for this is that we want to hold packages that are expected to be --- distributed to a higher standard than packages that are only ever expected --- to be used on the author's own environment. - -module Distribution.PackageDescription.Check ( - -- * Package Checking - CheckExplanation(..), - PackageCheck(..), - checkPackage, - checkConfiguredPackage, - wrapParseWarning, - ppPackageCheck, - - -- ** Checking package contents - checkPackageFiles, - checkPackageContent, - CheckPackageContentOps(..), - checkPackageFileNames, - ) where - -import Data.Foldable (foldrM) -import Distribution.Compat.Prelude -import Prelude () - -import Data.List (delete, group) -import Distribution.CabalSpecVersion -import Distribution.Compat.Lens -import Distribution.Compiler -import Distribution.License -import Distribution.ModuleName (ModuleName) -import Distribution.Package -import Distribution.PackageDescription -import Distribution.PackageDescription.Configuration -import Distribution.Parsec.Warning (PWarning, showPWarning) -import Distribution.Pretty (prettyShow) -import Distribution.Simple.BuildPaths (autogenPackageInfoModuleName, autogenPathsModuleName) -import Distribution.Simple.BuildToolDepends -import Distribution.Simple.CCompiler -import Distribution.Simple.Glob -import Distribution.Simple.Utils hiding (findPackageDesc, notice) -import Distribution.System -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.PackageName.Magic -import Distribution.Utils.Generic (isAscii) -import Distribution.Verbosity -import Distribution.Version -import Distribution.Utils.Path -import Language.Haskell.Extension -import System.FilePath - ( makeRelative, normalise, splitDirectories, splitExtension, splitPath - , takeExtension, takeFileName, (<.>), ()) - -import qualified Data.ByteString.Lazy as BS -import qualified Data.Map as Map -import qualified Control.Monad as CM -import qualified Distribution.Compat.DList as DList -import qualified Distribution.SPDX as SPDX -import qualified System.Directory as System - -import qualified System.Directory (getDirectoryContents) -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.Types.BuildInfo.Lens as L -import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L - --- $setup --- >>> import Control.Arrow ((&&&)) - --- ------------------------------------------------------------ --- * Warning messages --- ------------------------------------------------------------ - --- | Which stanza does `CheckExplanation` refer to? --- -data CEType = CETLibrary | CETExecutable | CETTest | CETBenchmark - deriving (Eq, Ord, Show) - --- | Pretty printing `CEType`. --- -ppCE :: CEType -> String -ppCE CETLibrary = "library" -ppCE CETExecutable = "executable" -ppCE CETTest = "test suite" -ppCE CETBenchmark = "benchmark" - --- | Which field does `CheckExplanation` refer to? --- -data CEField = CEFCategory | CEFMaintainer | CEFSynopsis - | CEFDescription | CEFSynOrDesc - deriving (Eq, Ord, Show) - --- | Pretty printing `CEField`. --- -ppCEField :: CEField -> String -ppCEField CEFCategory = "category" -ppCEField CEFMaintainer = "maintainer" -ppCEField CEFSynopsis = "synopsis" -ppCEField CEFDescription = "description" -ppCEField CEFSynOrDesc = "synopsis' or 'description" - --- | Explanations of 'PackageCheck`'s errors/warnings. --- -data CheckExplanation = - ParseWarning FilePath PWarning - | NoNameField - | NoVersionField - | NoTarget - | UnnamedInternal - | DuplicateSections [UnqualComponentName] - | IllegalLibraryName PackageDescription - | NoModulesExposed Library - | SignaturesCabal2 - | AutogenNotExposed - | AutogenIncludesNotIncluded - | NoMainIs Executable - | NoHsLhsMain - | MainCCabal1_18 - | AutogenNoOther CEType UnqualComponentName - | AutogenIncludesNotIncludedExe - | TestsuiteTypeNotKnown TestType - | TestsuiteNotSupported TestType - | BenchmarkTypeNotKnown BenchmarkType - | BenchmarkNotSupported BenchmarkType - | NoHsLhsMainBench - | InvalidNameWin PackageDescription - | ZPrefix - | NoBuildType - | NoCustomSetup - | UnknownCompilers [String] - | UnknownLanguages [String] - | UnknownExtensions [String] - | LanguagesAsExtension [String] - | DeprecatedExtensions [(Extension, Maybe Extension)] - | MissingField CEField - | SynopsisTooLong - | ShortDesc - | InvalidTestWith [Dependency] - | ImpossibleInternalDep [Dependency] - | ImpossibleInternalExe [ExeDependency] - | MissingInternalExe [ExeDependency] - | NONELicense - | NoLicense - | AllRightsReservedLicense - | LicenseMessParse PackageDescription - | UnrecognisedLicense String - | UncommonBSD4 - | UnknownLicenseVersion License [Version] - | NoLicenseFile - | UnrecognisedSourceRepo String - | MissingType - | MissingLocation - | MissingModule - | MissingTag - | SubdirRelPath - | SubdirGoodRelPath String - | OptFasm String - | OptViaC String - | OptHpc String - | OptProf String - | OptO String - | OptHide String - | OptMake String - | OptONot String - | OptOOne String - | OptOTwo String - | OptSplitSections String - | OptSplitObjs String - | OptWls String - | OptExts String - | OptRts String - | OptWithRts String - | COptONumber String String - | COptCPP String - | OptAlternatives String String [(String, String)] - | RelativeOutside String FilePath - | AbsolutePath String FilePath - | BadRelativePAth String FilePath String - | DistPoint (Maybe String) FilePath - | GlobSyntaxError String String - | RecursiveGlobInRoot String FilePath - | InvalidOnWin [FilePath] - | FilePathTooLong FilePath - | FilePathNameTooLong FilePath - | FilePathSplitTooLong FilePath - | FilePathEmpty - | CVTestSuite - | CVDefaultLanguage - | CVDefaultLanguageComponent - | CVExtraDocFiles - | CVMultiLib - | CVReexported - | CVMixins - | CVExtraFrameworkDirs - | CVDefaultExtensions - | CVExtensionsDeprecated - | CVSources - | CVExtraDynamic [[String]] - | CVVirtualModules - | CVSourceRepository - | CVExtensions CabalSpecVersion [Extension] - | CVCustomSetup - | CVExpliticDepsCustomSetup - | CVAutogenPaths - | CVAutogenPackageInfo - | CVAutogenPackageInfoGuard - | GlobNoMatch String String - | GlobExactMatch String String FilePath - | GlobNoDir String String FilePath - | UnknownOS [String] - | UnknownArch [String] - | UnknownCompiler [String] - | BaseNoUpperBounds - | MissingUpperBounds [PackageName] - | SuspiciousFlagName [String] - | DeclaredUsedFlags (Set FlagName) (Set FlagName) - | NonASCIICustomField [String] - | RebindableClashPaths - | RebindableClashPackageInfo - | WErrorUnneeded String - | JUnneeded String - | FDeferTypeErrorsUnneeded String - | DynamicUnneeded String - | ProfilingUnneeded String - | UpperBoundSetup String - | DuplicateModule String [ModuleName] - | PotentialDupModule String [ModuleName] - | BOMStart FilePath - | NotPackageName FilePath String - | NoDesc - | MultiDesc [String] - | UnknownFile String (SymbolicPath PackageDir LicenseFile) - | MissingSetupFile - | MissingConfigureScript - | UnknownDirectory String FilePath - | MissingSourceControl - | MissingExpectedDocFiles Bool [FilePath] - | WrongFieldForExpectedDocFiles Bool String [FilePath] - deriving (Eq, Ord, Show) - --- | Wraps `ParseWarning` into `PackageCheck`. --- -wrapParseWarning :: FilePath -> PWarning -> PackageCheck -wrapParseWarning fp pw = PackageDistSuspicious (ParseWarning fp pw) - -- TODO: as Jul 2022 there is no severity indication attached PWarnType. - -- Once that is added, we can output something more appropriate - -- than PackageDistSuspicious for every parse warning. - -- (see: Cabal-syntax/src/Distribution/Parsec/Warning.hs) - --- | Pretty printing `CheckExplanation`. --- -ppExplanation :: CheckExplanation -> String -ppExplanation (ParseWarning fp pp) = showPWarning fp pp -ppExplanation NoNameField = "No 'name' field." -ppExplanation NoVersionField = "No 'version' field." -ppExplanation NoTarget = - "No executables, libraries, tests, or benchmarks found. Nothing to do." -ppExplanation UnnamedInternal = - "Found one or more unnamed internal libraries. Only the non-internal" - ++ " library can have the same name as the package." -ppExplanation (DuplicateSections duplicateNames) = - "Duplicate sections: " - ++ commaSep (map unUnqualComponentName duplicateNames) - ++ ". The name of every library, executable, test suite," - ++ " and benchmark section in the package must be unique." -ppExplanation (IllegalLibraryName pkg) = - "Illegal internal library name " - ++ prettyShow (packageName pkg) - ++ ". Internal libraries cannot have the same name as the package." - ++ " Maybe you wanted a non-internal library?" - ++ " If so, rewrite the section stanza" - ++ " from 'library: '" ++ prettyShow (packageName pkg) - ++ "' to 'library'." -ppExplanation (NoModulesExposed lib) = - showLibraryName (libName lib) ++ " does not expose any modules" -ppExplanation SignaturesCabal2 = - "To use the 'signatures' field the package needs to specify " - ++ "at least 'cabal-version: 2.0'." -ppExplanation AutogenNotExposed = - "An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'." -ppExplanation AutogenIncludesNotIncluded = - "An include in 'autogen-includes' is neither in 'includes' or " - ++ "'install-includes'." -ppExplanation (NoMainIs exe) = - "No 'main-is' field found for executable " ++ prettyShow (exeName exe) -ppExplanation NoHsLhsMain = - "The 'main-is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor), " - ++ "or it may specify a C/C++/obj-C source file." -ppExplanation MainCCabal1_18 = - "The package uses a C/C++/obj-C source file for the 'main-is' field. " - ++ "To use this feature you need to specify 'cabal-version: 1.18' or" - ++ " higher." -ppExplanation (AutogenNoOther ct ucn) = - "On " ++ ppCE ct ++ " '" ++ prettyShow ucn ++ "' an 'autogen-module'" - ++ " is not on 'other-modules'" -ppExplanation AutogenIncludesNotIncludedExe = - "An include in 'autogen-includes' is not in 'includes'." -ppExplanation (TestsuiteTypeNotKnown tt) = - quote (prettyShow tt) ++ " is not a known type of test suite. " - ++ "Either remove the 'type' field or use a known type. " - ++ "The known test suite types are: " - ++ commaSep (map prettyShow knownTestTypes) -ppExplanation (TestsuiteNotSupported tt) = - quote (prettyShow tt) ++ " is not a supported test suite version. " - ++ "Either remove the 'type' field or use a known type. " - ++ "The known test suite types are: " - ++ commaSep (map prettyShow knownTestTypes) -ppExplanation (BenchmarkTypeNotKnown tt) = - quote (prettyShow tt) ++ " is not a known type of benchmark. " - ++ "Either remove the 'type' field or use a known type. " - ++ "The known benchmark types are: " - ++ commaSep (map prettyShow knownBenchmarkTypes) -ppExplanation (BenchmarkNotSupported tt) = - quote (prettyShow tt) ++ " is not a supported benchmark version. " - ++ "Either remove the 'type' field or use a known type. " - ++ "The known benchmark types are: " - ++ commaSep (map prettyShow knownBenchmarkTypes) -ppExplanation NoHsLhsMainBench = - "The 'main-is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor)." -ppExplanation (InvalidNameWin pkg) = - "The package name '" ++ prettyShow (packageName pkg) ++ "' is " - ++ "invalid on Windows. Many tools need to convert package names to " - ++ "file names so using this name would cause problems." -ppExplanation ZPrefix = - "Package names with the prefix 'z-' are reserved by Cabal and " - ++ "cannot be used." -ppExplanation NoBuildType = - "No 'build-type' specified. If you do not need a custom Setup.hs or " - ++ "./configure script then use 'build-type: Simple'." -ppExplanation NoCustomSetup = - "Ignoring the 'custom-setup' section because the 'build-type' is " - ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a " - ++ "custom Setup.hs script." -ppExplanation (UnknownCompilers unknownCompilers) = - "Unknown compiler " ++ commaSep (map quote unknownCompilers) - ++ " in 'tested-with' field." -ppExplanation (UnknownLanguages unknownLanguages) = - "Unknown languages: " ++ commaSep unknownLanguages -ppExplanation (UnknownExtensions unknownExtensions) = - "Unknown extensions: " ++ commaSep unknownExtensions -ppExplanation (LanguagesAsExtension languagesUsedAsExtensions) = - "Languages listed as extensions: " - ++ commaSep languagesUsedAsExtensions - ++ ". Languages must be specified in either the 'default-language' " - ++ " or the 'other-languages' field." -ppExplanation (DeprecatedExtensions ourDeprecatedExtensions) = - "Deprecated extensions: " - ++ commaSep (map (quote . prettyShow . fst) ourDeprecatedExtensions) - ++ ". " ++ unwords - [ "Instead of '" ++ prettyShow ext - ++ "' use '" ++ prettyShow replacement ++ "'." - | (ext, Just replacement) <- ourDeprecatedExtensions ] -ppExplanation (MissingField cef) = - "No '" ++ ppCEField cef ++ "' field." -ppExplanation SynopsisTooLong = - "The 'synopsis' field is rather long (max 80 chars is recommended)." -ppExplanation ShortDesc = - "The 'description' field should be longer than the 'synopsis' field. " - ++ "It's useful to provide an informative 'description' to allow " - ++ "Haskell programmers who have never heard about your package to " - ++ "understand the purpose of your package. " - ++ "The 'description' field content is typically shown by tooling " - ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which " - ++ "serves as a headline. " - ++ "Please refer to for more details." -ppExplanation (InvalidTestWith testedWithImpossibleRanges) = - "Invalid 'tested-with' version range: " - ++ commaSep (map prettyShow testedWithImpossibleRanges) - ++ ". To indicate that you have tested a package with multiple " - ++ "different versions of the same compiler use multiple entries, " - ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " - ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." -ppExplanation (ImpossibleInternalDep depInternalLibWithImpossibleVersion) = - "The package has an impossible version range for a dependency on an " - ++ "internal library: " - ++ commaSep (map prettyShow depInternalLibWithImpossibleVersion) - ++ ". This version range does not include the current package, and must " - ++ "be removed as the current package's library will always be used." -ppExplanation (ImpossibleInternalExe depInternalExecWithImpossibleVersion) = - "The package has an impossible version range for a dependency on an " - ++ "internal executable: " - ++ commaSep (map prettyShow depInternalExecWithImpossibleVersion) - ++ ". This version range does not include the current package, and must " - ++ "be removed as the current package's executable will always be used." -ppExplanation (MissingInternalExe depInternalExeWithImpossibleVersion) = - "The package depends on a missing internal executable: " - ++ commaSep (map prettyShow depInternalExeWithImpossibleVersion) -ppExplanation NONELicense = "The 'license' field is missing or is NONE." -ppExplanation NoLicense = "The 'license' field is missing." -ppExplanation AllRightsReservedLicense = - "The 'license' is AllRightsReserved. Is that really what you want?" -ppExplanation (LicenseMessParse pkg) = - "Unfortunately the license " ++ quote (prettyShow (license pkg)) - ++ " messes up the parser in earlier Cabal versions so you need to " - ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " - ++ "compatibility with earlier Cabal versions then use 'OtherLicense'." -ppExplanation (UnrecognisedLicense l) = - quote ("license: " ++ l) ++ " is not a recognised license. The " - ++ "known licenses are: " ++ commaSep (map prettyShow knownLicenses) -ppExplanation UncommonBSD4 = - "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " - ++ "refers to the old 4-clause BSD license with the advertising " - ++ "clause. 'BSD3' refers the new 3-clause BSD license." -ppExplanation (UnknownLicenseVersion lic known) = - "'license: " ++ prettyShow lic ++ "' is not a known " - ++ "version of that license. The known versions are " - ++ commaSep (map prettyShow known) - ++ ". If this is not a mistake and you think it should be a known " - ++ "version then please file a ticket." -ppExplanation NoLicenseFile = "A 'license-file' is not specified." -ppExplanation (UnrecognisedSourceRepo kind) = - quote kind ++ " is not a recognised kind of source-repository. " - ++ "The repo kind is usually 'head' or 'this'" -ppExplanation MissingType = - "The source-repository 'type' is a required field." -ppExplanation MissingLocation = - "The source-repository 'location' is a required field." -ppExplanation MissingModule = - "For a CVS source-repository, the 'module' is a required field." -ppExplanation MissingTag = - "For the 'this' kind of source-repository, the 'tag' is a required " - ++ "field. It should specify the tag corresponding to this version " - ++ "or release of the package." -ppExplanation SubdirRelPath = - "The 'subdir' field of a source-repository must be a relative path." -ppExplanation (SubdirGoodRelPath err) = - "The 'subdir' field of a source-repository is not a good relative path: " - ++ show err -ppExplanation (OptFasm fieldName) = - "'" ++ fieldName ++ ": -fasm' is unnecessary and will not work on CPU " - ++ "architectures other than x86, x86-64, ppc or sparc." -ppExplanation (OptViaC fieldName) = - "'" ++ fieldName ++": -fvia-C' is usually unnecessary. If your package " - ++ "needs -via-C for correctness rather than performance then it " - ++ "is using the FFI incorrectly and will probably not work with GHC " - ++ "6.10 or later." -ppExplanation (OptHpc fieldName) = - "'" ++ fieldName ++ ": -fhpc' is not necessary. Use the configure flag " - ++ " --enable-coverage instead." -ppExplanation (OptProf fieldName) = - "'" ++ fieldName ++ ": -prof' is not necessary and will lead to problems " - ++ "when used on a library. Use the configure flag " - ++ "--enable-library-profiling and/or --enable-profiling." -ppExplanation (OptO fieldName) = - "'" ++ fieldName ++ ": -o' is not needed. " - ++ "The output files are named automatically." -ppExplanation (OptHide fieldName) = - "'" ++ fieldName ++ ": -hide-package' is never needed. " - ++ "Cabal hides all packages." -ppExplanation (OptMake fieldName) = - "'" ++ fieldName - ++ ": --make' is never needed. Cabal uses this automatically." -ppExplanation (OptONot fieldName) = - "'" ++ fieldName ++ ": -O0' is not needed. " - ++ "Use the --disable-optimization configure flag." -ppExplanation (OptOOne fieldName) = - "'" ++ fieldName ++ ": -O' is not needed. " - ++ "Cabal automatically adds the '-O' flag. " - ++ "Setting it yourself interferes with the --disable-optimization flag." -ppExplanation (OptOTwo fieldName) = - "'" ++ fieldName ++ ": -O2' is rarely needed. " - ++ "Check that it is giving a real benefit " - ++ "and not just imposing longer compile times on your users." -ppExplanation (OptSplitSections fieldName) = - "'" ++ fieldName ++ ": -split-sections' is not needed. " - ++ "Use the --enable-split-sections configure flag." -ppExplanation (OptSplitObjs fieldName) = - "'" ++ fieldName ++ ": -split-objs' is not needed. " - ++ "Use the --enable-split-objs configure flag." -ppExplanation (OptWls fieldName) = - "'" ++ fieldName ++ ": -optl-Wl,-s' is not needed and is not portable to" - ++ " all operating systems. Cabal 1.4 and later automatically strip" - ++ " executables. Cabal also has a flag --disable-executable-stripping" - ++ " which is necessary when building packages for some Linux" - ++ " distributions and using '-optl-Wl,-s' prevents that from working." -ppExplanation (OptExts fieldName) = - "Instead of '" ++ fieldName ++ ": -fglasgow-exts' it is preferable to use " - ++ "the 'extensions' field." -ppExplanation (OptRts fieldName) = - "'" ++ fieldName ++ ": -rtsopts' has no effect for libraries. It should " - ++ "only be used for executables." -ppExplanation (OptWithRts fieldName) = - "'" ++ fieldName ++ ": -with-rtsopts' has no effect for libraries. It " - ++ "should only be used for executables." -ppExplanation (COptONumber prefix label) = - "'" ++ prefix ++": -O[n]' is generally not needed. When building with " - ++ " optimisations Cabal automatically adds '-O2' for " ++ label - ++ " code. Setting it yourself interferes with the" - ++ " --disable-optimization flag." -ppExplanation (COptCPP opt) = - "'cpp-options: " ++ opt ++ "' is not a portable C-preprocessor flag." -ppExplanation (OptAlternatives badField goodField flags) = - "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) - ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags) - where (badFlags, goodFlags) = unzip flags -ppExplanation (RelativeOutside field path) = - quote (field ++ ": " ++ path) - ++ " is a relative path outside of the source tree. " - ++ "This will not work when generating a tarball with 'sdist'." -ppExplanation (AbsolutePath field path) = - quote (field ++ ": " ++ path) ++ " specifies an absolute path, but the " - ++ quote field ++ " field must use relative paths." -ppExplanation (BadRelativePAth field path err) = - quote (field ++ ": " ++ path) - ++ " is not a good relative path: " ++ show err -ppExplanation (DistPoint mfield path) = - incipit ++ " points inside the 'dist' " - ++ "directory. This is not reliable because the location of this " - ++ "directory is configurable by the user (or package manager). In " - ++ "addition the layout of the 'dist' directory is subject to change " - ++ "in future versions of Cabal." - where -- mfiled Nothing -> the path is inside `ghc-options` - incipit = maybe ("'ghc-options' path " ++ quote path) - (\field -> quote (field ++ ": " ++ path)) - mfield -ppExplanation (GlobSyntaxError field expl) = - "In the '" ++ field ++ "' field: " ++ expl -ppExplanation (RecursiveGlobInRoot field glob) = - "In the '" ++ field ++ "': glob '" ++ glob - ++ "' starts at project root directory, this might " - ++ "include `.git/`, ``dist-newstyle/``, or other large directories!" -ppExplanation (InvalidOnWin paths) = - "The " ++ quotes paths ++ " invalid on Windows, which " - ++ "would cause portability problems for this package. Windows file " - ++ "names cannot contain any of the characters \":*?<>|\" and there " - ++ "a few reserved names including \"aux\", \"nul\", \"con\", " - ++ "\"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." - where quotes [failed] = "path " ++ quote failed ++ " is" - quotes failed = "paths " ++ intercalate ", " (map quote failed) - ++ " are" -ppExplanation (FilePathTooLong path) = - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. The maximum length is 255 ASCII characters.\n" - ++ "The file in question is:\n " ++ path -ppExplanation (FilePathNameTooLong path) = - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. The maximum length for the name part (including " - ++ "extension) is 100 ASCII characters. The maximum length for any " - ++ "individual directory component is 155.\n" - ++ "The file in question is:\n " ++ path -ppExplanation (FilePathSplitTooLong path) = - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. While the total length is less than 255 ASCII " - ++ "characters, there are unfortunately further restrictions. It has to " - ++ "be possible to split the file path on a directory separator into " - ++ "two parts such that the first part fits in 155 characters or less " - ++ "and the second part fits in 100 characters or less. Basically you " - ++ "have to make the file name or directory names shorter, or you could " - ++ "split a long directory name into nested subdirectories with shorter " - ++ "names.\nThe file in question is:\n " ++ path -ppExplanation FilePathEmpty = - "Encountered a file with an empty name, something is very wrong! " - ++ "Files with an empty name cannot be stored in a tar archive or in " - ++ "standard file systems." -ppExplanation CVTestSuite = - "The 'test-suite' section is new in Cabal 1.10. " - ++ "Unfortunately it messes up the parser in older Cabal versions " - ++ "so you must specify at least 'cabal-version: >= 1.8', but note " - ++ "that only Cabal 1.10 and later can actually run such test suites." -ppExplanation CVDefaultLanguage = - "To use the 'default-language' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.10'." -ppExplanation CVDefaultLanguageComponent = - "Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' " - ++ "must specify the 'default-language' field for each component (e.g. " - ++ "Haskell98 or Haskell2010). If a component uses different languages " - ++ "in different modules then list the other ones in the " - ++ "'other-languages' field." -ppExplanation CVExtraDocFiles = - "To use the 'extra-doc-files' field the package needs to specify " - ++ "'cabal-version: 1.18' or higher." -ppExplanation CVMultiLib = - "To use multiple 'library' sections or a named library section " - ++ "the package needs to specify at least 'cabal-version: 2.0'." -ppExplanation CVReexported = - "To use the 'reexported-module' field the package needs to specify " - ++ "'cabal-version: 1.22' or higher." -ppExplanation CVMixins = - "To use the 'mixins' field the package needs to specify " - ++ "at least 'cabal-version: 2.0'." -ppExplanation CVExtraFrameworkDirs = - "To use the 'extra-framework-dirs' field the package needs to specify" - ++ " 'cabal-version: 1.24' or higher." -ppExplanation CVDefaultExtensions = - "To use the 'default-extensions' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.10'." -ppExplanation CVExtensionsDeprecated = - "For packages using 'cabal-version: >= 1.10' the 'extensions' " - ++ "field is deprecated. The new 'default-extensions' field lists " - ++ "extensions that are used in all modules in the component, while " - ++ "the 'other-extensions' field lists extensions that are used in " - ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." -ppExplanation CVSources = - "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' " - ++ " and 'extra-library-flavours' requires the package " - ++ " to specify at least 'cabal-version: 3.0'." -ppExplanation (CVExtraDynamic flavs) = - "The use of 'extra-dynamic-library-flavours' requires the package " - ++ " to specify at least 'cabal-version: 3.0'. The flavours are: " - ++ commaSep (concat flavs) -ppExplanation CVVirtualModules = - "The use of 'virtual-modules' requires the package " - ++ " to specify at least 'cabal-version: 2.2'." -ppExplanation CVSourceRepository = - "The 'source-repository' section is new in Cabal 1.6. " - ++ "Unfortunately it messes up the parser in earlier Cabal versions " - ++ "so you need to specify 'cabal-version: >= 1.6'." -ppExplanation (CVExtensions version extCab12) = - "Unfortunately the language extensions " - ++ commaSep (map (quote . prettyShow) extCab12) - ++ " break the parser in earlier Cabal versions so you need to " - ++ "specify 'cabal-version: >= " ++ showCabalSpecVersion version - ++ "'. Alternatively if you require compatibility with earlier " - ++ "Cabal versions then you may be able to use an equivalent " - ++ "compiler-specific flag." -ppExplanation CVCustomSetup = - "Packages using 'cabal-version: 1.24' or higher with 'build-type: Custom' " - ++ "must use a 'custom-setup' section with a 'setup-depends' field " - ++ "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 = - "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' " - ++ "field 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 CVAutogenPaths = - "Packages using 'cabal-version: 2.0' and the autogenerated " - ++ "module Paths_* must include it also on the 'autogen-modules' field " - ++ "besides 'exposed-modules' and 'other-modules'. This specifies that " - ++ "the module does not come with the package and is generated on " - ++ "setup. Modules built with a custom Setup.hs script also go here " - ++ "to ensure that commands like sdist don't fail." -ppExplanation CVAutogenPackageInfo = - "Packages using 'cabal-version: 2.0' and the autogenerated " - ++ "module PackageInfo_* must include it in 'autogen-modules' as well as" - ++ " 'exposed-modules' and 'other-modules'. This specifies that " - ++ "the module does not come with the package and is generated on " - ++ "setup. Modules built with a custom Setup.hs script also go here " - ++ "to ensure that commands like sdist don't fail." -ppExplanation CVAutogenPackageInfoGuard = - "To use the autogenerated module PackageInfo_* you need to specify " - ++ "`cabal-version: 3.12` or higher. This is not possible in `cabal " - ++ "3.10`. To use this feature and be able to upload your package to " - ++ "Hackage, download `cabal 3.12`!" -ppExplanation (GlobNoMatch field glob) = - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not" - ++ " match any files." -ppExplanation (GlobExactMatch field glob file) = - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not" - ++ " match the file '" ++ file ++ "' because the extensions do not" - ++ " exactly match (e.g., foo.en.html does not exactly match *.html)." - ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or" - ++ " higher." -ppExplanation (GlobNoDir field glob dir) = - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' attempts to" - ++ " match files in the directory '" ++ dir ++ "', but there is no" - ++ " directory by that name." -ppExplanation (UnknownOS unknownOSs) = - "Unknown operating system name " ++ commaSep (map quote unknownOSs) -ppExplanation (UnknownArch unknownArches) = - "Unknown architecture name " ++ commaSep (map quote unknownArches) -ppExplanation (UnknownCompiler unknownImpls) = - "Unknown compiler name " ++ commaSep (map quote unknownImpls) -ppExplanation (MissingUpperBounds names) = - let separator = "\n - " - in - "These packages miss upper bounds:" ++ separator - ++ (intercalate separator (unPackageName <$> names)) ++ "\n" - ++ "Please add them, using `cabal gen-bounds` for suggestions." - ++ " For more information see: " - ++ " https://pvp.haskell.org/" -ppExplanation BaseNoUpperBounds = - "The dependency 'build-depends: base' does not specify an upper " - ++ "bound on the version number. Each major release of the 'base' " - ++ "package changes the API in various ways and most packages will " - ++ "need some changes to compile with it. The recommended practice " - ++ "is to specify an upper bound on the version of the 'base' " - ++ "package. This ensures your package will continue to build when a " - ++ "new major version of the 'base' package is released. If you are " - ++ "not sure what upper bound to use then use the next major " - ++ "version. For example if you have tested your package with 'base' " - ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'." -ppExplanation (SuspiciousFlagName invalidFlagNames) = - "Suspicious flag names: " ++ unwords invalidFlagNames ++ ". " - ++ "To avoid ambiguity in command line interfaces, flag shouldn't " - ++ "start with a dash. Also for better compatibility, flag names " - ++ "shouldn't contain non-ascii characters." -ppExplanation (DeclaredUsedFlags declared used) = - "Declared and used flag sets differ: " - ++ s declared ++ " /= " ++ s used ++ ". " - where s :: Set.Set FlagName -> String - s = commaSep . map unFlagName . Set.toList -ppExplanation (NonASCIICustomField nonAsciiXFields) = - "Non ascii custom fields: " ++ unwords nonAsciiXFields ++ ". " - ++ "For better compatibility, custom field names " - ++ "shouldn't contain non-ascii characters." -ppExplanation RebindableClashPaths = - "Packages using RebindableSyntax with OverloadedStrings or" - ++ " OverloadedLists in default-extensions, in conjunction with the" - ++ " autogenerated module Paths_*, are known to cause compile failures" - ++ " with Cabal < 2.2. To use these default-extensions with a Paths_*" - ++ " autogen module, specify at least 'cabal-version: 2.2'." -ppExplanation RebindableClashPackageInfo = - "Packages using RebindableSyntax with OverloadedStrings or" - ++ " OverloadedLists in default-extensions, in conjunction with the" - ++ " autogenerated module PackageInfo_*, are known to cause compile failures" - ++ " with Cabal < 2.2. To use these default-extensions with a PackageInfo_*" - ++ " autogen module, specify at least 'cabal-version: 2.2'." -ppExplanation (WErrorUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -Werror' makes the package easy to " - ++ "break with future GHC versions because new GHC versions often " - ++ "add new warnings." -ppExplanation (JUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -j[N]' can make sense for specific user's setup," - ++ " but it is not appropriate for a distributed package." -ppExplanation (FDeferTypeErrorsUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -fdefer-type-errors' is fine during development " - ++ "but is not appropriate for a distributed package." -ppExplanation (DynamicUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -d*' debug flags are not appropriate " - ++ "for a distributed package." -ppExplanation (ProfilingUnneeded fieldName) = addConditionalExp $ - "'" ++ fieldName ++ ": -fprof*' profiling flags are typically not " - ++ "appropriate for a distributed library package. These flags are " - ++ "useful to profile this package, but when profiling other packages " - ++ "that use this one these flags clutter the profile output with " - ++ "excessive detail. If you think other packages really want to see " - ++ "cost centres from this package then use '-fprof-auto-exported' " - ++ "which puts cost centres only on exported functions." -ppExplanation (UpperBoundSetup nm) = - "The dependency 'setup-depends: '"++nm++"' does not specify an " - ++ "upper bound on the version number. Each major release of the " - ++ "'"++nm++"' package changes the API in various ways and most " - ++ "packages will need some changes to compile with it. If you are " - ++ "not sure what upper bound to use then use the next major " - ++ "version." -ppExplanation (DuplicateModule s dupLibsLax) = - "Duplicate modules in " ++ s ++ ": " - ++ commaSep (map prettyShow dupLibsLax) -ppExplanation (PotentialDupModule s dupLibsStrict) = - "Potential duplicate modules (subject to conditionals) in " ++ s - ++ ": " ++ commaSep (map prettyShow dupLibsStrict) -ppExplanation (BOMStart pdfile) = - pdfile ++ " starts with an Unicode byte order mark (BOM)." - ++ " This may cause problems with older cabal versions." -ppExplanation (NotPackageName pdfile expectedCabalname) = - "The filename " ++ quote pdfile ++ " does not match package name " - ++ "(expected: " ++ quote expectedCabalname ++ ")" -ppExplanation NoDesc = - "No cabal file found.\n" - ++ "Please create a package description file .cabal" -ppExplanation (MultiDesc multiple) = - "Multiple cabal files found while checking.\n" - ++ "Please use only one of: " - ++ intercalate ", " multiple -ppExplanation (UnknownFile fieldname file) = - "The '" ++ fieldname ++ "' field refers to the file " - ++ quote (getSymbolicPath file) ++ " which does not exist." -ppExplanation MissingSetupFile = - "The package is missing a Setup.hs or Setup.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." -ppExplanation (UnknownDirectory kind dir) = - quote (kind ++ ": " ++ dir) - ++ " specifies a directory which does not exist." -ppExplanation MissingSourceControl = - "When distributing packages it is encouraged to specify source " - ++ "control information in the .cabal file using one or more " - ++ "'source-repository' sections. See the Cabal user guide for " - ++ "details." -ppExplanation (MissingExpectedDocFiles extraDocFileSupport paths) = - "Please consider including the " ++ quotes paths - ++ " in the '" ++ targetField ++ "' section of the .cabal file " - ++ "if it contains useful information for users of the package." - where quotes [p] = "file " ++ quote p - quotes ps = "files " ++ intercalate ", " (map quote ps) - targetField = if extraDocFileSupport - then "extra-doc-files" - else "extra-source-files" -ppExplanation (WrongFieldForExpectedDocFiles extraDocFileSupport field paths) = - "Please consider moving the " ++ quotes paths - ++ " from the '" ++ field ++ "' section of the .cabal file " - ++ "to the section '" ++ targetField ++ "'." - where quotes [p] = "file " ++ quote p - quotes ps = "files " ++ intercalate ", " (map quote ps) - targetField = if extraDocFileSupport - then "extra-doc-files" - else "extra-source-files" - - --- | Results of some kind of failed package check. --- --- There are a range of severities, from merely dubious to totally insane. --- All of them come with a human readable explanation. In future we may augment --- them with more machine readable explanations, for example to help an IDE --- suggest automatic corrections. --- -data PackageCheck = - - -- | This package description is no good. There's no way it's going to - -- build sensibly. This should give an error at configure time. - PackageBuildImpossible { explanation :: CheckExplanation } - - -- | A problem that is likely to affect building the package, or an - -- issue that we'd like every package author to be aware of, even if - -- the package is never distributed. - | PackageBuildWarning { explanation :: CheckExplanation } - - -- | An issue that might not be a problem for the package author but - -- might be annoying or detrimental when the package is distributed to - -- users. We should encourage distributed packages to be free from these - -- issues, but occasionally there are justifiable reasons so we cannot - -- ban them entirely. - | PackageDistSuspicious { explanation :: CheckExplanation } - - -- | Like PackageDistSuspicious but will only display warnings - -- rather than causing abnormal exit when you run 'cabal check'. - | PackageDistSuspiciousWarn { explanation :: CheckExplanation } - - -- | An issue that is OK in the author's environment but is almost - -- certain to be a portability problem for other environments. We can - -- quite legitimately refuse to publicly distribute packages with these - -- problems. - | PackageDistInexcusable { explanation :: CheckExplanation } - deriving (Eq, Ord) - --- | Pretty printing 'PackageCheck'. --- -ppPackageCheck :: PackageCheck -> String -ppPackageCheck e = ppExplanation (explanation e) - -instance Show PackageCheck where - show notice = ppPackageCheck notice - -check :: Bool -> PackageCheck -> Maybe PackageCheck -check False _ = Nothing -check True pc = Just pc - -checkSpecVersion :: PackageDescription -> CabalSpecVersion -> Bool -> PackageCheck - -> Maybe PackageCheck -checkSpecVersion pkg specver cond pc - | specVersion pkg >= specver = Nothing - | otherwise = check cond pc - --- ------------------------------------------------------------ --- * Standard checks --- ------------------------------------------------------------ - --- | Check for common mistakes and problems in package descriptions. --- --- This is the standard collection of checks covering all aspects except --- for checks that require looking at files within the package. For those --- see 'checkPackageFiles'. --- --- It requires the 'GenericPackageDescription' and optionally a particular --- configuration of that package. If you pass 'Nothing' then we just check --- a version of the generic description using 'flattenPackageDescription'. --- -checkPackage :: GenericPackageDescription - -> Maybe PackageDescription - -> [PackageCheck] -checkPackage gpkg mpkg = - checkConfiguredPackage pkg - ++ checkConditionals gpkg - ++ checkPackageVersions gpkg - ++ checkDevelopmentOnlyFlags gpkg - ++ checkFlagNames gpkg - ++ checkUnusedFlags gpkg - ++ checkUnicodeXFields gpkg - ++ checkPathsModuleExtensions pkg - ++ checkPackageInfoModuleExtensions pkg - ++ checkSetupVersions gpkg - ++ checkDuplicateModules gpkg - where - pkg = fromMaybe (flattenPackageDescription gpkg) mpkg - ---TODO: make this variant go away --- we should always know the GenericPackageDescription -checkConfiguredPackage :: PackageDescription -> [PackageCheck] -checkConfiguredPackage pkg = - checkSanity pkg - ++ checkFields pkg - ++ checkLicense pkg - ++ checkSourceRepos pkg - ++ checkAllGhcOptions pkg - ++ checkCCOptions pkg - ++ checkCxxOptions pkg - ++ checkCPPOptions pkg - ++ checkPaths pkg - ++ checkCabalVersion pkg - - --- ------------------------------------------------------------ --- * Basic sanity checks --- ------------------------------------------------------------ - --- | Check that this package description is sane. --- -checkSanity :: PackageDescription -> [PackageCheck] -checkSanity pkg = - catMaybes [ - - check (null . unPackageName . packageName $ pkg) $ - PackageBuildImpossible NoNameField - - , check (nullVersion == packageVersion pkg) $ - PackageBuildImpossible NoVersionField - - , check (all ($ pkg) [ null . executables - , null . testSuites - , null . benchmarks - , null . allLibraries - , null . foreignLibs ]) $ - PackageBuildImpossible NoTarget - - , check (any (== LMainLibName) (map libName $ subLibraries pkg)) $ - PackageBuildImpossible UnnamedInternal - - , check (not (null duplicateNames)) $ - PackageBuildImpossible (DuplicateSections duplicateNames) - - -- NB: but it's OK for executables to have the same name! - -- TODO shouldn't need to compare on the string level - , check (any (== prettyShow (packageName pkg)) - (prettyShow <$> subLibNames)) $ - PackageBuildImpossible (IllegalLibraryName pkg) - ] - --TODO: check for name clashes case insensitively: windows file systems cannot - --cope. - - ++ concatMap (checkLibrary pkg) (allLibraries pkg) - ++ concatMap (checkExecutable pkg) (executables pkg) - ++ concatMap (checkTestSuite pkg) (testSuites pkg) - ++ concatMap (checkBenchmark pkg) (benchmarks pkg) - - where - -- The public 'library' gets special dispensation, because it - -- is common practice to export a library and name the executable - -- the same as the package. - subLibNames = mapMaybe (libraryNameString . libName) $ subLibraries pkg - exeNames = map exeName $ executables pkg - testNames = map testName $ testSuites pkg - bmNames = map benchmarkName $ benchmarks pkg - duplicateNames = dups $ subLibNames ++ exeNames ++ testNames ++ bmNames - -checkLibrary :: PackageDescription -> Library -> [PackageCheck] -checkLibrary pkg lib = - catMaybes [ - - -- TODO: This check is bogus if a required-signature was passed through - check (null (explicitLibModules lib) && null (reexportedModules lib)) $ - PackageDistSuspiciousWarn (NoModulesExposed lib) - - -- check use of signatures sections - , checkVersion CabalSpecV2_0 (not (null (signatures lib))) $ - PackageDistInexcusable SignaturesCabal2 - - -- check that all autogen-modules appear on other-modules or exposed-modules - , check - (not $ and $ map (flip elem (explicitLibModules lib)) (libModulesAutogen lib)) $ - PackageBuildImpossible AutogenNotExposed - - -- check that all autogen-includes appear on includes or install-includes - , check - (not $ and $ map (flip elem (allExplicitIncludes lib)) (view L.autogenIncludes lib)) $ - PackageBuildImpossible AutogenIncludesNotIncluded - ] - - where - checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck - checkVersion ver cond pc - | specVersion pkg >= ver = Nothing - | otherwise = check cond pc - -allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath] -allExplicitIncludes x = view L.includes x ++ view L.installIncludes x - -checkExecutable :: PackageDescription -> Executable -> [PackageCheck] -checkExecutable pkg exe = - catMaybes [ - - check (null (modulePath exe)) $ - PackageBuildImpossible (NoMainIs exe) - - -- This check does not apply to scripts. - , check (package pkg /= fakePackageId - && not (null (modulePath exe)) - && not (fileExtensionSupportedLanguage $ modulePath exe)) $ - PackageBuildImpossible NoHsLhsMain - - , checkSpecVersion pkg CabalSpecV1_18 - (fileExtensionSupportedLanguage (modulePath exe) - && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $ - PackageDistInexcusable MainCCabal1_18 - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) $ - PackageBuildImpossible (AutogenNoOther CETExecutable (exeName exe)) - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes exe)) (view L.autogenIncludes exe)) $ - PackageBuildImpossible AutogenIncludesNotIncludedExe - ] - -checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck] -checkTestSuite pkg test = - catMaybes [ - - case testInterface test of - TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $ - PackageBuildWarning (TestsuiteTypeNotKnown tt) - - TestSuiteUnsupported tt -> Just $ - PackageBuildWarning (TestsuiteNotSupported tt) - _ -> Nothing - - , check mainIsWrongExt $ - PackageBuildImpossible NoHsLhsMain - - , checkSpecVersion pkg CabalSpecV1_18 (mainIsNotHsExt && not mainIsWrongExt) $ - PackageDistInexcusable MainCCabal1_18 - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (testModules test)) (testModulesAutogen test)) $ - PackageBuildImpossible (AutogenNoOther CETTest (testName test)) - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes test)) (view L.autogenIncludes test)) $ - PackageBuildImpossible AutogenIncludesNotIncludedExe - ] - where - mainIsWrongExt = case testInterface test of - TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f - _ -> False - - mainIsNotHsExt = case testInterface test of - TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] - _ -> False - -checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck] -checkBenchmark _pkg bm = - catMaybes [ - - case benchmarkInterface bm of - BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $ - PackageBuildWarning (BenchmarkTypeNotKnown tt) - - BenchmarkUnsupported tt -> Just $ - PackageBuildWarning (BenchmarkNotSupported tt) - _ -> Nothing - - , check mainIsWrongExt $ - PackageBuildImpossible NoHsLhsMainBench - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (benchmarkModules bm)) (benchmarkModulesAutogen bm)) $ - PackageBuildImpossible (AutogenNoOther CETBenchmark (benchmarkName bm)) - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes bm)) (view L.autogenIncludes bm)) $ - PackageBuildImpossible AutogenIncludesNotIncludedExe - ] - where - mainIsWrongExt = case benchmarkInterface bm of - BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] - _ -> False - --- ------------------------------------------------------------ --- * Additional pure checks --- ------------------------------------------------------------ - -checkFields :: PackageDescription -> [PackageCheck] -checkFields pkg = - catMaybes [ - - check (not . FilePath.Windows.isValid . prettyShow . packageName $ pkg) $ - PackageDistInexcusable (InvalidNameWin pkg) - - , check (isPrefixOf "z-" . prettyShow . packageName $ pkg) $ - PackageDistInexcusable ZPrefix - - , check (isNothing (buildTypeRaw pkg) && specVersion pkg < CabalSpecV2_2) $ - PackageBuildWarning NoBuildType - - , check (isJust (setupBuildInfo pkg) && buildType pkg /= Custom) $ - PackageBuildWarning NoCustomSetup - - , check (not (null unknownCompilers)) $ - PackageBuildWarning (UnknownCompilers unknownCompilers) - - , check (not (null unknownLanguages)) $ - PackageBuildWarning (UnknownLanguages unknownLanguages) - - , check (not (null unknownExtensions)) $ - PackageBuildWarning (UnknownExtensions unknownExtensions) - - , check (not (null languagesUsedAsExtensions)) $ - PackageBuildWarning (LanguagesAsExtension languagesUsedAsExtensions) - - , check (not (null ourDeprecatedExtensions)) $ - PackageDistSuspicious (DeprecatedExtensions ourDeprecatedExtensions) - - , check (ShortText.null (category pkg)) $ - PackageDistSuspicious (MissingField CEFCategory) - - , check (ShortText.null (maintainer pkg)) $ - PackageDistSuspicious (MissingField CEFMaintainer) - - , check (ShortText.null (synopsis pkg) && ShortText.null (description pkg)) $ - PackageDistInexcusable (MissingField CEFSynOrDesc) - - , check (ShortText.null (description pkg) && not (ShortText.null (synopsis pkg))) $ - PackageDistSuspicious (MissingField CEFDescription) - - , check (ShortText.null (synopsis pkg) && not (ShortText.null (description pkg))) $ - PackageDistSuspicious (MissingField CEFSynopsis) - - --TODO: recommend the bug reports URL, author and homepage fields - --TODO: recommend not using the stability field - --TODO: recommend specifying a source repo - - , check (ShortText.length (synopsis pkg) > 80) $ - PackageDistSuspicious SynopsisTooLong - - -- See also https://github.com/haskell/cabal/pull/3479 - , check (not (ShortText.null (description pkg)) - && ShortText.length (description pkg) <= ShortText.length (synopsis pkg)) $ - PackageDistSuspicious ShortDesc - - -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" - , check (not (null testedWithImpossibleRanges)) $ - PackageDistInexcusable (InvalidTestWith testedWithImpossibleRanges) - - -- for more details on why the following was commented out, - -- check https://github.com/haskell/cabal/pull/7470#issuecomment-875878507 - -- , check (not (null depInternalLibraryWithExtraVersion)) $ - -- PackageBuildWarning $ - -- "The package has an extraneous version range for a dependency on an " - -- ++ "internal library: " - -- ++ commaSep (map prettyShow depInternalLibraryWithExtraVersion) - -- ++ ". This version range includes the current package but isn't needed " - -- ++ "as the current package's library will always be used." - - , check (not (null depInternalLibraryWithImpossibleVersion)) $ - PackageBuildImpossible - (ImpossibleInternalDep depInternalLibraryWithImpossibleVersion) - - -- , check (not (null depInternalExecutableWithExtraVersion)) $ - -- PackageBuildWarning $ - -- "The package has an extraneous version range for a dependency on an " - -- ++ "internal executable: " - -- ++ commaSep (map prettyShow depInternalExecutableWithExtraVersion) - -- ++ ". This version range includes the current package but isn't needed " - -- ++ "as the current package's executable will always be used." - - , check (not (null depInternalExecutableWithImpossibleVersion)) $ - PackageBuildImpossible - (ImpossibleInternalExe depInternalExecutableWithImpossibleVersion) - - , check (not (null depMissingInternalExecutable)) $ - PackageBuildImpossible (MissingInternalExe depMissingInternalExecutable) - ] - where - unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] - unknownLanguages = [ name | bi <- allBuildInfo pkg - , UnknownLanguage name <- allLanguages bi ] - unknownExtensions = filter (/= "TypeAbstractions") - [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- allExtensions bi - , name `notElem` map prettyShow knownLanguages ] - ourDeprecatedExtensions = nub $ catMaybes - [ find ((==ext) . fst) deprecatedExtensions - | bi <- allBuildInfo pkg - , ext <- allExtensions bi ] - languagesUsedAsExtensions = - [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- allExtensions bi - , name `elem` map prettyShow knownLanguages ] - - testedWithImpossibleRanges = - [ Dependency (mkPackageName (prettyShow compiler)) vr mainLibSet - | (compiler, vr) <- testedWith pkg - , isNoVersion vr ] - - internalExecutables = map exeName $ executables pkg - - internalLibDeps = - [ dep - | bi <- allBuildInfo pkg - , dep@(Dependency name _ _) <- targetBuildDepends bi - , name == packageName pkg - ] - - internalExeDeps = - [ dep - | bi <- allBuildInfo pkg - , dep <- getAllToolDependencies pkg bi - , isInternal pkg dep - ] - - -- depInternalLibraryWithExtraVersion = - -- [ dep - -- | dep@(Dependency _ versionRange _) <- internalLibDeps - -- , not $ isAnyVersion versionRange - -- , packageVersion pkg `withinRange` versionRange - -- ] - - depInternalLibraryWithImpossibleVersion = - [ dep - | dep@(Dependency _ versionRange _) <- internalLibDeps - , not $ packageVersion pkg `withinRange` versionRange - ] - - -- depInternalExecutableWithExtraVersion = - -- [ dep - -- | dep@(ExeDependency _ _ versionRange) <- internalExeDeps - -- , not $ isAnyVersion versionRange - -- , packageVersion pkg `withinRange` versionRange - -- ] - - depInternalExecutableWithImpossibleVersion = - [ dep - | dep@(ExeDependency _ _ versionRange) <- internalExeDeps - , not $ packageVersion pkg `withinRange` versionRange - ] - - depMissingInternalExecutable = - [ dep - | dep@(ExeDependency _ eName _) <- internalExeDeps - , not $ eName `elem` internalExecutables - ] - -checkLicense :: PackageDescription -> [PackageCheck] -checkLicense pkg = case licenseRaw pkg of - Right l -> checkOldLicense pkg l - Left l -> checkNewLicense pkg l - -checkNewLicense :: PackageDescription -> SPDX.License -> [PackageCheck] -checkNewLicense _pkg lic = catMaybes - [ check (lic == SPDX.NONE) $ - PackageDistInexcusable NONELicense ] - -checkOldLicense :: PackageDescription -> License -> [PackageCheck] -checkOldLicense pkg lic = catMaybes - [ check (lic == UnspecifiedLicense) $ - PackageDistInexcusable NoLicense - - , check (lic == AllRightsReserved) $ - PackageDistSuspicious AllRightsReservedLicense - - , checkVersion CabalSpecV1_4 (lic `notElem` compatLicenses) $ - PackageDistInexcusable (LicenseMessParse pkg) - - , case lic of - UnknownLicense l -> Just $ PackageBuildWarning (UnrecognisedLicense l) - _ -> Nothing - - , check (lic == BSD4) $ - PackageDistSuspicious UncommonBSD4 - - , case unknownLicenseVersion lic of - Just knownVersions -> Just $ - PackageDistSuspicious (UnknownLicenseVersion lic knownVersions) - _ -> Nothing - - , check (lic `notElem` [ AllRightsReserved - , UnspecifiedLicense, PublicDomain] - -- AllRightsReserved and PublicDomain are not strictly - -- licenses so don't need license files. - && null (licenseFiles pkg)) $ - PackageDistSuspicious NoLicenseFile - ] - where - unknownLicenseVersion (GPL (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | GPL (Just v') <- knownLicenses ] - unknownLicenseVersion (LGPL (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ] - unknownLicenseVersion (AGPL (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ] - unknownLicenseVersion (Apache (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | Apache (Just v') <- knownLicenses ] - unknownLicenseVersion _ = Nothing - - checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck - checkVersion ver cond pc - | specVersion pkg >= ver = Nothing - | otherwise = check cond pc - - compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4 - , PublicDomain, AllRightsReserved - , UnspecifiedLicense, OtherLicense ] - -checkSourceRepos :: PackageDescription -> [PackageCheck] -checkSourceRepos pkg = - catMaybes $ concat [[ - - case repoKind repo of - RepoKindUnknown kind -> Just $ PackageDistInexcusable $ - UnrecognisedSourceRepo kind - _ -> Nothing - - , check (isNothing (repoType repo)) $ - PackageDistInexcusable MissingType - - , check (isNothing (repoLocation repo)) $ - PackageDistInexcusable MissingLocation - - , check (repoType repo == Just (KnownRepoType CVS) && isNothing (repoModule repo)) $ - PackageDistInexcusable MissingModule - - , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $ - PackageDistInexcusable MissingTag - - , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $ - PackageDistInexcusable SubdirRelPath - - , do - subdir <- repoSubdir repo - err <- isGoodRelativeDirectoryPath subdir - return $ PackageDistInexcusable (SubdirGoodRelPath err) - ] - | repo <- sourceRepos pkg ] - ---TODO: check location looks like a URL for some repo types. - --- | Checks GHC options from all ghc-*-options fields in the given --- PackageDescription and reports commonly misused or non-portable flags -checkAllGhcOptions :: PackageDescription -> [PackageCheck] -checkAllGhcOptions pkg = - checkGhcOptions "ghc-options" (hcOptions GHC) pkg - ++ checkGhcOptions "ghc-prof-options" (hcProfOptions GHC) pkg - ++ checkGhcOptions "ghc-shared-options" (hcSharedOptions GHC) pkg - --- | Extracts GHC options belonging to the given field from the given --- PackageDescription using given function and checks them for commonly misused --- or non-portable flags -checkGhcOptions :: String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck] -checkGhcOptions fieldName getOptions pkg = - catMaybes [ - - checkFlags ["-fasm"] $ - PackageDistInexcusable (OptFasm fieldName) - - , checkFlags ["-fvia-C"] $ - PackageDistSuspicious (OptViaC fieldName) - - , checkFlags ["-fhpc"] $ - PackageDistInexcusable (OptHpc fieldName) - - , checkFlags ["-prof"] $ - PackageBuildWarning (OptProf fieldName) - - , unlessScript . checkFlags ["-o"] $ - PackageBuildWarning (OptO fieldName) - - , checkFlags ["-hide-package"] $ - PackageBuildWarning (OptHide fieldName) - - , checkFlags ["--make"] $ - PackageBuildWarning (OptMake fieldName) - - , checkNonTestAndBenchmarkFlags ["-O0", "-Onot"] $ - PackageDistSuspicious (OptONot fieldName) - - , checkTestAndBenchmarkFlags ["-O0", "-Onot"] $ - PackageDistSuspiciousWarn (OptONot fieldName) - - , checkFlags [ "-O", "-O1"] $ - PackageDistInexcusable (OptOOne fieldName) - - , checkFlags ["-O2"] $ - PackageDistSuspiciousWarn (OptOTwo fieldName) - - , checkFlags ["-split-sections"] $ - PackageBuildWarning (OptSplitSections fieldName) - - , checkFlags ["-split-objs"] $ - PackageBuildWarning (OptSplitObjs fieldName) - - , checkFlags ["-optl-Wl,-s", "-optl-s"] $ - PackageDistInexcusable (OptWls fieldName) - - , checkFlags ["-fglasgow-exts"] $ - PackageDistSuspicious (OptExts fieldName) - - , check ("-rtsopts" `elem` lib_ghc_options) $ - PackageBuildWarning (OptRts fieldName) - - , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $ - PackageBuildWarning (OptWithRts fieldName) - - , checkAlternatives fieldName "extensions" - [ (flag, prettyShow extension) | flag <- ghc_options_no_rtsopts - , Just extension <- [ghcExtension flag] ] - - , checkAlternatives fieldName "extensions" - [ (flag, extension) | flag@('-':'X':extension) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "cpp-options" $ - [ (flag, flag) | flag@('-':'D':_) <- ghc_options_no_rtsopts ] - ++ [ (flag, flag) | flag@('-':'U':_) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-libraries-static" - [ (flag, lib) | flag@('-':'l':lib) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "extra-lib-dirs-static" - [ (flag, dir) | flag@('-':'L':dir) <- ghc_options_no_rtsopts ] - - , checkAlternatives fieldName "frameworks" - [ (flag, fmwk) | (flag@"-framework", fmwk) <- - zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) ] - - , checkAlternatives fieldName "extra-framework-dirs" - [ (flag, dir) | (flag@"-framework-path", dir) <- - zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) ] - ] - - where - all_ghc_options = concatMap getOptions (allBuildInfo pkg) - ghc_options_no_rtsopts = rmRtsOpts all_ghc_options - lib_ghc_options = concatMap (getOptions . libBuildInfo) - (allLibraries pkg) - test_ghc_options = concatMap (getOptions . testBuildInfo) - (testSuites pkg) - benchmark_ghc_options = concatMap (getOptions . benchmarkBuildInfo) - (benchmarks pkg) - test_and_benchmark_ghc_options = test_ghc_options ++ - benchmark_ghc_options - non_test_and_benchmark_ghc_options = concatMap getOptions - (allBuildInfo (pkg { testSuites = [] - , benchmarks = [] - })) - - checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkFlags flags = check (any (`elem` flags) all_ghc_options) - - unlessScript :: Maybe PackageCheck -> Maybe PackageCheck - unlessScript pc | packageId pkg == fakePackageId = Nothing - | otherwise = pc - - checkTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkTestAndBenchmarkFlags flags = check (any (`elem` flags) test_and_benchmark_ghc_options) - - checkNonTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkNonTestAndBenchmarkFlags flags = check (any (`elem` flags) non_test_and_benchmark_ghc_options) - - ghcExtension ('-':'f':name) = case name of - "allow-overlapping-instances" -> enable OverlappingInstances - "no-allow-overlapping-instances" -> disable OverlappingInstances - "th" -> enable TemplateHaskell - "no-th" -> disable TemplateHaskell - "ffi" -> enable ForeignFunctionInterface - "no-ffi" -> disable ForeignFunctionInterface - "fi" -> enable ForeignFunctionInterface - "no-fi" -> disable ForeignFunctionInterface - "monomorphism-restriction" -> enable MonomorphismRestriction - "no-monomorphism-restriction" -> disable MonomorphismRestriction - "mono-pat-binds" -> enable MonoPatBinds - "no-mono-pat-binds" -> disable MonoPatBinds - "allow-undecidable-instances" -> enable UndecidableInstances - "no-allow-undecidable-instances" -> disable UndecidableInstances - "allow-incoherent-instances" -> enable IncoherentInstances - "no-allow-incoherent-instances" -> disable IncoherentInstances - "arrows" -> enable Arrows - "no-arrows" -> disable Arrows - "generics" -> enable Generics - "no-generics" -> disable Generics - "implicit-prelude" -> enable ImplicitPrelude - "no-implicit-prelude" -> disable ImplicitPrelude - "implicit-params" -> enable ImplicitParams - "no-implicit-params" -> disable ImplicitParams - "bang-patterns" -> enable BangPatterns - "no-bang-patterns" -> disable BangPatterns - "scoped-type-variables" -> enable ScopedTypeVariables - "no-scoped-type-variables" -> disable ScopedTypeVariables - "extended-default-rules" -> enable ExtendedDefaultRules - "no-extended-default-rules" -> disable ExtendedDefaultRules - _ -> Nothing - ghcExtension "-cpp" = enable CPP - ghcExtension _ = Nothing - - enable e = Just (EnableExtension e) - disable e = Just (DisableExtension e) - - rmRtsOpts :: [String] -> [String] - rmRtsOpts ("-with-rtsopts":_:xs) = rmRtsOpts xs - rmRtsOpts (x:xs) = x : rmRtsOpts xs - rmRtsOpts [] = [] - - -checkCCOptions :: PackageDescription -> [PackageCheck] -checkCCOptions = checkCLikeOptions "C" "cc-options" ccOptions - -checkCxxOptions :: PackageDescription -> [PackageCheck] -checkCxxOptions = checkCLikeOptions "C++" "cxx-options" cxxOptions - -checkCLikeOptions :: String -> String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck] -checkCLikeOptions label prefix accessor pkg = - catMaybes [ - - checkAlternatives prefix "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_cLikeOptions ] - - , checkAlternatives prefix "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_cLikeOptions ] - - , checkAlternatives prefix "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_cLikeOptions ] - - , checkAlternatives "ld-options" "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ] - - , checkAlternatives "ld-options" "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ] - - , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $ - PackageDistSuspicious (COptONumber prefix label) - ] - - where all_cLikeOptions = [ opts | bi <- allBuildInfo pkg - , opts <- accessor bi ] - all_ldOptions = [ opts | bi <- allBuildInfo pkg - , opts <- ldOptions bi ] - - checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkCCFlags flags = check (any (`elem` flags) all_cLikeOptions) - -checkCPPOptions :: PackageDescription -> [PackageCheck] -checkCPPOptions pkg = catMaybes - [ checkAlternatives "cpp-options" "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions ] - ] - ++ - [ PackageBuildWarning (COptCPP opt) - | opt <- all_cppOptions - -- "-I" is handled above, we allow only -DNEWSTUFF and -UOLDSTUFF - , not $ any (`isPrefixOf` opt) ["-D", "-U", "-I" ] - ] - where - all_cppOptions = [ opts | bi <- allBuildInfo pkg, opts <- cppOptions bi ] - -checkAlternatives :: String -> String -> [(String, String)] - -> Maybe PackageCheck -checkAlternatives badField goodField flags = - check (not (null badFlags)) $ - PackageBuildWarning (OptAlternatives badField goodField flags) - where (badFlags, _) = unzip flags - -data PathKind - = PathKindFile - | PathKindDirectory - | PathKindGlob - deriving (Eq) - -checkPaths :: PackageDescription -> [PackageCheck] -checkPaths pkg = - checkPackageFileNamesWithGlob - [ (kind == PathKindGlob, path) - | (path, _, kind) <- relPaths ++ absPaths - ] - ++ - [ PackageBuildWarning (RelativeOutside field path) - | (path, field, _) <- relPaths ++ absPaths - , isOutsideTree path ] - ++ - [ PackageDistInexcusable (AbsolutePath field path) - | (path, field, _) <- relPaths - , isAbsoluteOnAnyPlatform path ] - ++ - [ PackageDistInexcusable (BadRelativePAth field path err) - | (path, field, kind) <- relPaths - -- these are not paths, but globs... - , err <- maybeToList $ case kind of - PathKindFile -> isGoodRelativeFilePath path - PathKindGlob -> isGoodRelativeGlob path - PathKindDirectory -> isGoodRelativeDirectoryPath path - ] - ++ - [ PackageDistInexcusable $ DistPoint (Just field) path - | (path, field, _) <- relPaths ++ absPaths - , isInsideDist path ] - ++ - [ PackageDistInexcusable (DistPoint Nothing path) - | bi <- allBuildInfo pkg - , (GHC, flags) <- perCompilerFlavorToList $ options bi - , path <- flags - , isInsideDist path ] - ++ - [ PackageDistInexcusable $ - GlobSyntaxError "data-files" (explainGlobSyntaxError pat err) - | (Left err, pat) <- zip globsDataFiles $ dataFiles pkg - ] - ++ - [ PackageDistInexcusable - (GlobSyntaxError "extra-source-files" (explainGlobSyntaxError pat err)) - | (Left err, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg - ] - ++ - [ PackageDistInexcusable $ - GlobSyntaxError "extra-doc-files" (explainGlobSyntaxError pat err) - | (Left err, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg - ] - ++ - [ PackageDistSuspiciousWarn $ - RecursiveGlobInRoot "data-files" pat - | (Right glob, pat) <- zip globsDataFiles $ dataFiles pkg - , isRecursiveInRoot glob - ] - ++ - [ PackageDistSuspiciousWarn $ - RecursiveGlobInRoot "extra-source-files" pat - | (Right glob, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg - , isRecursiveInRoot glob - ] - ++ - [ PackageDistSuspiciousWarn $ - RecursiveGlobInRoot "extra-doc-files" pat - | (Right glob, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg - , isRecursiveInRoot glob - ] - where - isOutsideTree path = case splitDirectories path of - "..":_ -> True - ".":"..":_ -> True - _ -> False - isInsideDist path = case map lowercase (splitDirectories path) of - "dist" :_ -> True - ".":"dist":_ -> True - _ -> False - - -- paths that must be relative - relPaths :: [(FilePath, String, PathKind)] - relPaths = - [ (path, "extra-source-files", PathKindGlob) | path <- extraSrcFiles pkg ] ++ - [ (path, "extra-tmp-files", PathKindFile) | path <- extraTmpFiles pkg ] ++ - [ (path, "extra-doc-files", PathKindGlob) | path <- extraDocFiles pkg ] ++ - [ (path, "data-files", PathKindGlob) | path <- dataFiles pkg ] ++ - [ (path, "data-dir", PathKindDirectory) | path <- [dataDir pkg]] ++ - [ (path, "license-file", PathKindFile) | path <- map getSymbolicPath $ licenseFiles pkg ] ++ - concat - [ [ (path, "asm-sources", PathKindFile) | path <- asmSources bi ] ++ - [ (path, "cmm-sources", PathKindFile) | path <- cmmSources bi ] ++ - [ (path, "c-sources", PathKindFile) | path <- cSources bi ] ++ - [ (path, "cxx-sources", PathKindFile) | path <- cxxSources bi ] ++ - [ (path, "js-sources", PathKindFile) | path <- jsSources bi ] ++ - [ (path, "install-includes", PathKindFile) | path <- installIncludes bi ] ++ - [ (path, "hs-source-dirs", PathKindDirectory) | path <- map getSymbolicPath $ hsSourceDirs bi ] - | bi <- allBuildInfo pkg - ] - - -- paths that are allowed to be absolute - absPaths :: [(FilePath, String, PathKind)] - absPaths = concat - [ [ (path, "includes", PathKindFile) | path <- includes bi ] ++ - [ (path, "include-dirs", PathKindDirectory) | path <- includeDirs bi ] ++ - [ (path, "extra-lib-dirs", PathKindDirectory) | path <- extraLibDirs bi ] ++ - [ (path, "extra-lib-dirs-static", PathKindDirectory) | path <- extraLibDirsStatic bi ] - | bi <- allBuildInfo pkg - ] - globsDataFiles :: [Either GlobSyntaxError Glob] - globsDataFiles = parseFileGlob (specVersion pkg) <$> dataFiles pkg - globsExtraSrcFiles :: [Either GlobSyntaxError Glob] - globsExtraSrcFiles = parseFileGlob (specVersion pkg) <$> extraSrcFiles pkg - globsExtraDocFiles :: [Either GlobSyntaxError Glob] - globsExtraDocFiles = parseFileGlob (specVersion pkg) <$> extraDocFiles pkg - ---TODO: check sets of paths that would be interpreted differently between Unix --- and windows, ie case-sensitive or insensitive. Things that might clash, or --- conversely be distinguished. - ---TODO: use the tar path checks on all the above paths - --- | Check that the package declares the version in the @\"cabal-version\"@ --- field correctly. --- -checkCabalVersion :: PackageDescription -> [PackageCheck] -checkCabalVersion pkg = - catMaybes [ - - -- check use of test suite sections - checkVersion CabalSpecV1_8 (not (null $ testSuites pkg)) $ - PackageDistInexcusable CVTestSuite - - -- check use of default-language field - -- note that we do not need to do an equivalent check for the - -- other-language field since that one does not change behaviour - , checkVersion CabalSpecV1_10 (any isJust (buildInfoField defaultLanguage)) $ - PackageBuildWarning CVDefaultLanguage - - , check (specVersion pkg >= CabalSpecV1_10 && specVersion pkg < CabalSpecV3_4 - && any isNothing (buildInfoField defaultLanguage)) $ - PackageBuildWarning CVDefaultLanguageComponent - - , checkVersion CabalSpecV1_18 - (not . null $ extraDocFiles pkg) $ - PackageDistInexcusable CVExtraDocFiles - - , checkVersion CabalSpecV2_0 - (not (null (subLibraries pkg))) $ - PackageDistInexcusable CVMultiLib - - -- check use of reexported-modules sections - , checkVersion CabalSpecV1_22 - (any (not.null.reexportedModules) (allLibraries pkg)) $ - PackageDistInexcusable CVReexported - - -- check use of thinning and renaming - , checkVersion CabalSpecV2_0 usesBackpackIncludes $ - PackageDistInexcusable CVMixins - - -- check use of 'extra-framework-dirs' field - , checkVersion CabalSpecV1_24 (any (not . null) (buildInfoField extraFrameworkDirs)) $ - -- Just a warning, because this won't break on old Cabal versions. - PackageDistSuspiciousWarn CVExtraFrameworkDirs - - -- check use of default-extensions field - -- don't need to do the equivalent check for other-extensions - , checkVersion CabalSpecV1_10 (any (not . null) (buildInfoField defaultExtensions)) $ - PackageBuildWarning CVDefaultExtensions - - -- check use of extensions field - , check (specVersion pkg >= CabalSpecV1_10 - && any (not . null) (buildInfoField oldExtensions)) $ - PackageBuildWarning CVExtensionsDeprecated - - , checkVersion CabalSpecV3_0 (any (not . null) - (concatMap buildInfoField - [ asmSources - , cmmSources - , extraBundledLibs - , extraLibFlavours ])) $ - PackageDistInexcusable CVSources - - , checkVersion CabalSpecV3_0 (any (not . null) $ buildInfoField extraDynLibFlavours) $ - PackageDistInexcusable - (CVExtraDynamic $ buildInfoField extraDynLibFlavours) - - , checkVersion CabalSpecV2_2 (any (not . null) - (buildInfoField virtualModules)) $ - PackageDistInexcusable CVVirtualModules - - -- check use of "source-repository" section - , checkVersion CabalSpecV1_6 (not (null (sourceRepos pkg))) $ - PackageDistInexcusable CVSourceRepository - - -- check for new language extensions - , checkVersion CabalSpecV1_2 (not (null mentionedExtensionsThatNeedCabal12)) $ - PackageDistInexcusable - (CVExtensions CabalSpecV1_2 mentionedExtensionsThatNeedCabal12) - - , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal14)) $ - PackageDistInexcusable - (CVExtensions CabalSpecV1_4 mentionedExtensionsThatNeedCabal14) - - , check (specVersion pkg >= CabalSpecV1_24 - && isNothing (setupBuildInfo pkg) - && buildType pkg == Custom) $ - PackageBuildWarning CVCustomSetup - - , check (specVersion pkg < CabalSpecV1_24 - && isNothing (setupBuildInfo pkg) - && buildType pkg == Custom) $ - PackageDistSuspiciousWarn CVExpliticDepsCustomSetup - - , check (specVersion pkg >= CabalSpecV2_0 - && elem (autogenPathsModuleName pkg) allModuleNames - && not (elem (autogenPathsModuleName pkg) allModuleNamesAutogen) ) $ - PackageDistInexcusable CVAutogenPaths - - , check (specVersion pkg >= CabalSpecV2_0 - && elem (autogenPackageInfoModuleName pkg) allModuleNames - && not (elem (autogenPackageInfoModuleName pkg) allModuleNamesAutogen) ) $ - PackageDistInexcusable CVAutogenPackageInfo - - , check - (elem (autogenPackageInfoModuleName pkg) allModuleNames) - (PackageDistInexcusable CVAutogenPackageInfoGuard) - ] - where - -- Perform a check on packages that use a version of the spec less than - -- the version given. This is for cases where a new Cabal version adds - -- a new feature and we want to check that it is not used prior to that - -- version. - checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck - checkVersion ver cond pc - | specVersion pkg >= ver = Nothing - | otherwise = check cond pc - - buildInfoField field = map field (allBuildInfo pkg) - - usesBackpackIncludes = any (not . null . mixins) (allBuildInfo pkg) - - mentionedExtensions = [ ext | bi <- allBuildInfo pkg - , ext <- allExtensions bi ] - mentionedExtensionsThatNeedCabal12 = - nub (filter (`elem` compatExtensionsExtra) mentionedExtensions) - - -- As of Cabal-1.4 we can add new extensions without worrying about - -- breaking old versions of cabal. - mentionedExtensionsThatNeedCabal14 = - nub (filter (`notElem` compatExtensions) mentionedExtensions) - - -- The known extensions in Cabal-1.2.3 - compatExtensions = - map EnableExtension - [ OverlappingInstances, UndecidableInstances, IncoherentInstances - , RecursiveDo, ParallelListComp, MultiParamTypeClasses - , FunctionalDependencies, Rank2Types - , RankNTypes, PolymorphicComponents, ExistentialQuantification - , ScopedTypeVariables, ImplicitParams, FlexibleContexts - , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns - , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface - , Arrows, Generics, NamedFieldPuns, PatternGuards - , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms - , HereDocuments] ++ - map DisableExtension - [MonomorphismRestriction, ImplicitPrelude] ++ - compatExtensionsExtra - - -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 - -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) - compatExtensionsExtra = - map EnableExtension - [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving - , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms - , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields - , OverloadedStrings, GADTs, RelaxedPolyRec - , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable - , ConstrainedClassMethods - ] ++ - map DisableExtension - [MonoPatBinds] - - allModuleNames = - (case library pkg of - Nothing -> [] - (Just lib) -> explicitLibModules lib - ) - ++ concatMap otherModules (allBuildInfo pkg) - - allModuleNamesAutogen = concatMap autogenModules (allBuildInfo pkg) - --- ------------------------------------------------------------ --- * Checks on the GenericPackageDescription --- ------------------------------------------------------------ - --- | Check the build-depends fields for any weirdness or bad practice. --- -checkPackageVersions :: GenericPackageDescription -> [PackageCheck] -checkPackageVersions pkg = - -- if others is empty, - -- the error will still fire but listing no dependencies. - -- so we have to check - if length others > 0 - then - PackageDistSuspiciousWarn (MissingUpperBounds others) : baseErrors - else - baseErrors - where - baseErrors = PackageDistInexcusable BaseNoUpperBounds <$ bases - deps = toDependencyVersionsMap allNonInternalBuildDepends pkg - -- base gets special treatment (it's more critical) - (bases, others) = partition (("base" ==) . unPackageName) $ - [ name - | (name, vr) <- Map.toList deps - , not (hasUpperBound vr) - ] - - -- Get the combined build-depends entries of all components. - allNonInternalBuildDepends :: PackageDescription -> [Dependency] - allNonInternalBuildDepends = targetBuildDepends CM.<=< allNonInternalBuildInfo - - allNonInternalBuildInfo :: PackageDescription -> [BuildInfo] - allNonInternalBuildInfo pkg_descr = - [bi | lib <- allLibraries pkg_descr, let bi = libBuildInfo lib] - ++ [bi | flib <- foreignLibs pkg_descr, let bi = foreignLibBuildInfo flib] - ++ [bi | exe <- executables pkg_descr, let bi = buildInfo exe] - -checkConditionals :: GenericPackageDescription -> [PackageCheck] -checkConditionals pkg = - catMaybes [ - - check (not $ null unknownOSs) $ - PackageDistInexcusable (UnknownOS unknownOSs) - - , check (not $ null unknownArches) $ - PackageDistInexcusable (UnknownArch unknownArches) - - , check (not $ null unknownImpls) $ - PackageDistInexcusable (UnknownCompiler unknownImpls) - ] - where - unknownOSs = [ os | OS (OtherOS os) <- conditions, os /= "haiku" ] - unknownArches = [ arch | Arch (OtherArch arch) <- conditions ] - unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] - conditions = concatMap fvs (maybeToList (condLibrary pkg)) - ++ concatMap (fvs . snd) (condSubLibraries pkg) - ++ concatMap (fvs . snd) (condForeignLibs pkg) - ++ concatMap (fvs . snd) (condExecutables pkg) - ++ concatMap (fvs . snd) (condTestSuites pkg) - ++ concatMap (fvs . snd) (condBenchmarks pkg) - fvs (CondNode _ _ ifs) = concatMap compfv ifs -- free variables - compfv (CondBranch c ct mct) = condfv c ++ fvs ct ++ maybe [] fvs mct - condfv c = case c of - Var v -> [v] - Lit _ -> [] - CNot c1 -> condfv c1 - COr c1 c2 -> condfv c1 ++ condfv c2 - CAnd c1 c2 -> condfv c1 ++ condfv c2 - -checkFlagNames :: GenericPackageDescription -> [PackageCheck] -checkFlagNames gpd - | null invalidFlagNames = [] - | otherwise = - [ PackageDistInexcusable (SuspiciousFlagName invalidFlagNames) ] - where - invalidFlagNames = - [ fn - | flag <- genPackageFlags gpd - , let fn = unFlagName (flagName flag) - , invalidFlagName fn - ] - -- starts with dash - invalidFlagName ('-':_) = True - -- mon ascii letter - invalidFlagName cs = any (not . isAscii) cs - -checkUnusedFlags :: GenericPackageDescription -> [PackageCheck] -checkUnusedFlags gpd - | declared == used = [] - | otherwise = - [ PackageDistSuspicious (DeclaredUsedFlags declared used) ] - where - declared :: Set.Set FlagName - declared = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd - - used :: Set.Set FlagName - used = mconcat - [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - ] - -checkUnicodeXFields :: GenericPackageDescription -> [PackageCheck] -checkUnicodeXFields gpd - | null nonAsciiXFields = [] - | otherwise = - [ PackageDistInexcusable (NonASCIICustomField nonAsciiXFields) ] - where - nonAsciiXFields :: [String] - nonAsciiXFields = [ n | (n, _) <- xfields, any (not . isAscii) n ] - - xfields :: [(String,String)] - xfields = DList.runDList $ mconcat - [ toDListOf (L.packageDescription . L.customFieldsPD . traverse) gpd - , toDListOf (L.traverseBuildInfos . L.customFieldsBI . traverse) gpd - ] - --- | cabal-version <2.2 + Paths_module + default-extensions: doesn't build. -checkPathsModuleExtensions :: PackageDescription -> [PackageCheck] -checkPathsModuleExtensions = checkAutogenModuleExtensions autogenPathsModuleName RebindableClashPaths - --- | cabal-version <2.2 + PackageInfo_module + default-extensions: doesn't build. -checkPackageInfoModuleExtensions :: PackageDescription -> [PackageCheck] -checkPackageInfoModuleExtensions = checkAutogenModuleExtensions autogenPackageInfoModuleName RebindableClashPackageInfo - --- | cabal-version <2.2 + *_module + default-extensions: doesn't build. -checkAutogenModuleExtensions :: - (PackageDescription -> ModuleName) -> - CheckExplanation -> - PackageDescription -> - [PackageCheck] -checkAutogenModuleExtensions autogenModuleName rebindableClashExplanation pd - | specVersion pd >= CabalSpecV2_2 = [] - | any checkBI (allBuildInfo pd) || any checkLib (allLibraries pd) - = return (PackageBuildImpossible rebindableClashExplanation) - | otherwise = [] - where - mn = autogenModuleName pd - - checkLib :: Library -> Bool - checkLib l = mn `elem` exposedModules l && checkExts (l ^. L.defaultExtensions) - - checkBI :: BuildInfo -> Bool - checkBI bi = - (mn `elem` otherModules bi || mn `elem` autogenModules bi) && - checkExts (bi ^. L.defaultExtensions) - - checkExts exts = rebind `elem` exts && (strings `elem` exts || lists `elem` exts) - where - rebind = EnableExtension RebindableSyntax - strings = EnableExtension OverloadedStrings - lists = EnableExtension OverloadedLists - --- | Checks GHC options from all ghc-*-options fields from the given BuildInfo --- and reports flags that are OK during development process, but are --- unacceptable in a distributed package -checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck] -checkDevelopmentOnlyFlagsBuildInfo bi = - checkDevelopmentOnlyFlagsOptions "ghc-options" (hcOptions GHC bi) - ++ checkDevelopmentOnlyFlagsOptions "ghc-prof-options" (hcProfOptions GHC bi) - ++ checkDevelopmentOnlyFlagsOptions "ghc-shared-options" (hcSharedOptions GHC bi) - --- | Checks the given list of flags belonging to the given field and reports --- flags that are OK during development process, but are unacceptable in a --- distributed package -checkDevelopmentOnlyFlagsOptions :: String -> [String] -> [PackageCheck] -checkDevelopmentOnlyFlagsOptions fieldName ghcOptions = - catMaybes [ - - check has_Werror $ - PackageDistInexcusable (WErrorUnneeded fieldName) - - , check has_J $ - PackageDistInexcusable (JUnneeded fieldName) - - , checkFlags ["-fdefer-type-errors"] $ - PackageDistInexcusable (FDeferTypeErrorsUnneeded fieldName) - - -- -dynamic is not a debug flag - , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic") - ghcOptions) $ - PackageDistInexcusable (DynamicUnneeded fieldName) - - , checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls", - "-fprof-cafs", "-fno-prof-count-entries", - "-auto-all", "-auto", "-caf-all"] $ - PackageDistSuspicious (ProfilingUnneeded fieldName) - ] - where - - has_Werror = "-Werror" `elem` ghcOptions - has_J = any - (\o -> case o of - "-j" -> True - ('-' : 'j' : d : _) -> isDigit d - _ -> False - ) - ghcOptions - checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkFlags flags = check (any (`elem` flags) ghcOptions) - -checkDevelopmentOnlyFlags :: GenericPackageDescription -> [PackageCheck] -checkDevelopmentOnlyFlags pkg = - concatMap checkDevelopmentOnlyFlagsBuildInfo - [ bi - | (conditions, bi) <- allConditionalBuildInfo - , not (any guardedByManualFlag conditions) ] - where - guardedByManualFlag = definitelyFalse - - -- We've basically got three-values logic here: True, False or unknown - -- hence this pattern to propagate the unknown cases properly. - definitelyFalse (Var (PackageFlag n)) = maybe False not (Map.lookup n manualFlags) - definitelyFalse (Var _) = False - definitelyFalse (Lit b) = not b - definitelyFalse (CNot c) = definitelyTrue c - definitelyFalse (COr c1 c2) = definitelyFalse c1 && definitelyFalse c2 - definitelyFalse (CAnd c1 c2) = definitelyFalse c1 || definitelyFalse c2 - - definitelyTrue (Var (PackageFlag n)) = fromMaybe False (Map.lookup n manualFlags) - definitelyTrue (Var _) = False - definitelyTrue (Lit b) = b - definitelyTrue (CNot c) = definitelyFalse c - definitelyTrue (COr c1 c2) = definitelyTrue c1 || definitelyTrue c2 - definitelyTrue (CAnd c1 c2) = definitelyTrue c1 && definitelyTrue c2 - - manualFlags = Map.fromList - [ (flagName flag, flagDefault flag) - | flag <- genPackageFlags pkg - , flagManual flag ] - - allConditionalBuildInfo :: [([Condition ConfVar], BuildInfo)] - allConditionalBuildInfo = - concatMap (collectCondTreePaths libBuildInfo) - (maybeToList (condLibrary pkg)) - - ++ concatMap (collectCondTreePaths libBuildInfo . snd) - (condSubLibraries pkg) - - ++ concatMap (collectCondTreePaths buildInfo . snd) - (condExecutables pkg) - - ++ concatMap (collectCondTreePaths testBuildInfo . snd) - (condTestSuites pkg) - - ++ concatMap (collectCondTreePaths benchmarkBuildInfo . snd) - (condBenchmarks pkg) - - -- get all the leaf BuildInfo, paired up with the path (in the tree sense) - -- of if-conditions that guard it - collectCondTreePaths :: (a -> b) - -> CondTree v c a - -> [([Condition v], b)] - collectCondTreePaths mapData = go [] - where - go conditions condNode = - -- the data at this level in the tree: - (reverse conditions, mapData (condTreeData condNode)) - - : concat - [ go (condition:conditions) ifThen - | (CondBranch condition ifThen _) <- condTreeComponents condNode ] - - ++ concat - [ go (condition:conditions) elseThen - | (CondBranch condition _ (Just elseThen)) <- condTreeComponents condNode ] - - --- ------------------------------------------------------------ --- * Checks involving files in the package --- ------------------------------------------------------------ - --- | Sanity check things that requires IO. It looks at the files in the --- package and expects to find the package unpacked in at the given file path. --- -checkPackageFiles :: Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck] -checkPackageFiles verbosity pkg root = do - contentChecks <- checkPackageContent checkFilesIO pkg - preDistributionChecks <- checkPackageFilesPreDistribution verbosity pkg root - -- Sort because different platforms will provide files from - -- `getDirectoryContents` in different orders, and we'd like to be - -- stable for test output. - return (sort contentChecks ++ sort preDistributionChecks) - where - checkFilesIO = CheckPackageContentOps { - doesFileExist = System.doesFileExist . relative, - doesDirectoryExist = System.doesDirectoryExist . relative, - getDirectoryContents = System.Directory.getDirectoryContents . relative, - getFileContents = BS.readFile . relative - } - relative path = root path - --- | A record of operations needed to check the contents of packages. --- Used by 'checkPackageContent'. --- -data CheckPackageContentOps m = CheckPackageContentOps { - doesFileExist :: FilePath -> m Bool, - doesDirectoryExist :: FilePath -> m Bool, - getDirectoryContents :: FilePath -> m [FilePath], - getFileContents :: FilePath -> m BS.ByteString - } - --- | Sanity check things that requires looking at files in the package. --- This is a generalised version of 'checkPackageFiles' that can work in any --- monad for which you can provide 'CheckPackageContentOps' operations. --- --- The point of this extra generality is to allow doing checks in some virtual --- file system, for example a tarball in memory. --- -checkPackageContent :: (Monad m, Applicative m) - => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkPackageContent ops pkg = do - cabalBomError <- checkCabalFileBOM ops - cabalNameError <- checkCabalFileName ops pkg - licenseErrors <- checkLicensesExist ops pkg - setupError <- checkSetupExists ops pkg - configureError <- checkConfigureExists ops pkg - localPathErrors <- checkLocalPathsExist ops pkg - vcsLocation <- checkMissingVcsInfo ops pkg - - return $ licenseErrors - ++ catMaybes [cabalBomError, cabalNameError, setupError, configureError] - ++ localPathErrors - ++ vcsLocation - -checkCabalFileBOM :: Monad m => CheckPackageContentOps m - -> m (Maybe PackageCheck) -checkCabalFileBOM ops = do - epdfile <- findPackageDesc ops - case epdfile of - -- MASSIVE HACK. If the Cabal file doesn't exist, that is - -- a very strange situation to be in, because the driver code - -- in 'Distribution.Setup' ought to have noticed already! - -- But this can be an issue, see #3552 and also when - -- --cabal-file is specified. So if you can't find the file, - -- just don't bother with this check. - Left _ -> return Nothing - Right pdfile -> (flip check pc . BS.isPrefixOf bomUtf8) - `liftM` getFileContents ops pdfile - where pc = PackageDistInexcusable (BOMStart pdfile) - - where - bomUtf8 :: BS.ByteString - bomUtf8 = BS.pack [0xef,0xbb,0xbf] -- U+FEFF encoded as UTF8 - -checkCabalFileName :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m (Maybe PackageCheck) -checkCabalFileName ops pkg = do - -- findPackageDesc already takes care to detect missing/multiple - -- .cabal files; we don't include this check in 'findPackageDesc' in - -- order not to short-cut other checks which call 'findPackageDesc' - epdfile <- findPackageDesc ops - case epdfile of - -- see "MASSIVE HACK" note in 'checkCabalFileBOM' - Left _ -> return Nothing - Right pdfile - | takeFileName pdfile == expectedCabalname -> return Nothing - | otherwise -> return $ Just $ PackageDistInexcusable - (NotPackageName pdfile expectedCabalname) - where - pkgname = unPackageName . packageName $ pkg - expectedCabalname = pkgname <.> "cabal" - - --- |Find a package description file in the given directory. Looks for --- @.cabal@ files. Like 'Distribution.Simple.Utils.findPackageDesc', --- but generalized over monads. -findPackageDesc :: Monad m => CheckPackageContentOps m - -> m (Either PackageCheck FilePath) -- ^.cabal -findPackageDesc ops - = do let dir = "." - files <- getDirectoryContents 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 <- filterM (doesFileExist ops) - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == ".cabal" ] - case cabalFiles of - [] -> return (Left $ PackageBuildImpossible NoDesc) - [cabalFile] -> return (Right cabalFile) - multiple -> return (Left $ PackageBuildImpossible - (MultiDesc multiple)) - -checkLicensesExist :: (Monad m, Applicative m) - => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkLicensesExist ops pkg = do - exists <- traverse (doesFileExist ops . getSymbolicPath) (licenseFiles pkg) - return - [ PackageBuildWarning (UnknownFile fieldname file) - | (file, False) <- zip (licenseFiles pkg) exists ] - where - fieldname | length (licenseFiles pkg) == 1 = "license-file" - | otherwise = "license-files" - -checkSetupExists :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m (Maybe PackageCheck) -checkSetupExists ops pkg = do - let simpleBuild = buildType pkg == Simple - hsexists <- doesFileExist ops "Setup.hs" - lhsexists <- doesFileExist ops "Setup.lhs" - return $ check (not simpleBuild && not hsexists && not lhsexists) $ - PackageDistInexcusable MissingSetupFile - -checkConfigureExists :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m (Maybe PackageCheck) -checkConfigureExists ops pd - | buildType pd == Configure = do - exists <- doesFileExist ops "configure" - return $ check (not exists) $ - PackageBuildWarning MissingConfigureScript - | otherwise = return Nothing - -checkLocalPathsExist :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkLocalPathsExist ops pkg = do - let dirs = [ (dir, kind) - | bi <- allBuildInfo pkg - , (dir, kind) <- - [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] - ++ [ (dir, "extra-lib-dirs-static") | dir <- extraLibDirsStatic bi ] - ++ [ (dir, "extra-framework-dirs") - | dir <- extraFrameworkDirs bi ] - ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] - ++ [ (getSymbolicPath dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] - , isRelativeOnAnyPlatform dir ] - missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs - return [ PackageBuildWarning (UnknownDirectory kind dir) - | (dir, kind) <- missing ] - -checkMissingVcsInfo :: (Monad m, Applicative m) - => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do - vcsInUse <- liftM or $ traverse (doesDirectoryExist ops) repoDirnames - if vcsInUse - then return [ PackageDistSuspicious MissingSourceControl ] - else return [] - where - repoDirnames = [ dirname | repo <- knownRepoTypes - , dirname <- repoTypeDirname repo] - -checkMissingVcsInfo _ _ = return [] - -repoTypeDirname :: KnownRepoType -> [FilePath] -repoTypeDirname Darcs = ["_darcs"] -repoTypeDirname Git = [".git"] -repoTypeDirname SVN = [".svn"] -repoTypeDirname CVS = ["CVS"] -repoTypeDirname Mercurial = [".hg"] -repoTypeDirname GnuArch = [".arch-params"] -repoTypeDirname Bazaar = [".bzr"] -repoTypeDirname Monotone = ["_MTN"] -repoTypeDirname Pijul = [".pijul"] - --- ------------------------------------------------------------ --- * Checks involving files in the package --- ------------------------------------------------------------ - --- | Check the names of all files in a package for portability problems. This --- should be done for example when creating or validating a package tarball. --- -checkPackageFileNames :: [FilePath] -> [PackageCheck] -checkPackageFileNames = checkPackageFileNamesWithGlob . zip (repeat True) - -checkPackageFileNamesWithGlob :: [(Bool, FilePath)] -> [PackageCheck] -checkPackageFileNamesWithGlob files = - catMaybes $ - checkWindowsPaths files - : - [ checkTarPath file - | (_, file) <- files - ] - -checkWindowsPaths :: [(Bool, FilePath)] -> Maybe PackageCheck -checkWindowsPaths paths = - case filter (not . FilePath.Windows.isValid . escape) paths of - [] -> Nothing - ps -> Just $ - PackageDistInexcusable (InvalidOnWin $ map snd ps) - where - -- force a relative name to catch invalid file names like "f:oo" which - -- otherwise parse as file "oo" in the current directory on the 'f' drive. - escape (isGlob, path) = (".\\" ++) - -- glob paths will be expanded before being dereferenced, so asterisks - -- shouldn't count against them. - $ map (\c -> if c == '*' && isGlob then 'x' else c) path - --- | Check a file name is valid for the portable POSIX tar format. --- --- The POSIX tar format has a restriction on the length of file names. It is --- unfortunately not a simple restriction like a maximum length. The exact --- restriction is that either the whole path be 100 characters or less, or it --- be possible to split the path on a directory separator such that the first --- part is 155 characters or less and the second part 100 characters or less. --- -checkTarPath :: FilePath -> Maybe PackageCheck -checkTarPath path - | length path > 255 = Just longPath - | otherwise = case pack nameMax (reverse (splitPath path)) of - Left err -> Just err - Right [] -> Nothing - Right (h:rest) -> case pack prefixMax remainder of - Left err -> Just err - Right [] -> Nothing - Right (_:_) -> Just noSplit - where - -- drop the '/' between the name and prefix: - remainder = safeInit h : rest - - where - nameMax, prefixMax :: Int - nameMax = 100 - prefixMax = 155 - - pack _ [] = Left emptyName - pack maxLen (c:cs) - | n > maxLen = Left longName - | otherwise = Right (pack' maxLen n cs) - where n = length c - - pack' maxLen n (c:cs) - | n' <= maxLen = pack' maxLen n' cs - where n' = n + length c - pack' _ _ cs = cs - - longPath = PackageDistInexcusable (FilePathTooLong path) - longName = PackageDistInexcusable (FilePathNameTooLong path) - noSplit = PackageDistInexcusable (FilePathSplitTooLong path) - emptyName = PackageDistInexcusable FilePathEmpty - --- -------------------------------------------------------------- --- * Checks for missing content and other pre-distribution checks --- -------------------------------------------------------------- - --- | Similar to 'checkPackageContent', 'checkPackageFilesPreDistribution' --- inspects the files included in the package, but is primarily looking for --- files in the working tree that may have been missed or other similar --- problems that can only be detected pre-distribution. --- --- Because Hackage necessarily checks the uploaded tarball, it is too late to --- check these on the server; these checks only make sense in the development --- and package-creation environment. Hence we can use IO, rather than needing --- to pass a 'CheckPackageContentOps' dictionary around. -checkPackageFilesPreDistribution :: Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck] --- Note: this really shouldn't return any 'Inexcusable' warnings, --- because that will make us say that Hackage would reject the package. --- But, because Hackage doesn't run these tests, that will be a lie! -checkPackageFilesPreDistribution = checkGlobFiles - --- | Discover problems with the package's wildcards. -checkGlobFiles :: Verbosity - -> PackageDescription - -> FilePath - -> IO [PackageCheck] -checkGlobFiles verbosity pkg root = do - -- Get the desirable doc files from package’s directory - rootContents <- System.Directory.getDirectoryContents root - docFiles0 <- filterM System.doesFileExist - [ file - | file <- rootContents - , isDesirableExtraDocFile desirableDocFiles file - ] - -- Check the globs - (warnings, unlisted) <- foldrM checkGlob ([], docFiles0) allGlobs - - return $ if null unlisted - -- No missing desirable file - then warnings - -- Some missing desirable files - else warnings ++ - let unlisted' = (root ) <$> unlisted - in [ PackageDistSuspiciousWarn - (MissingExpectedDocFiles extraDocFilesSupport unlisted') - ] - where - -- `extra-doc-files` is supported only from version 1.18 - extraDocFilesSupport = specVersion pkg >= CabalSpecV1_18 - adjustedDataDir = if null (dataDir pkg) then root else root dataDir pkg - -- Cabal fields with globs - allGlobs :: [(String, Bool, FilePath, FilePath)] - allGlobs = concat - [ (,,,) "extra-source-files" (not extraDocFilesSupport) root <$> - extraSrcFiles pkg - , (,,,) "extra-doc-files" True root <$> extraDocFiles pkg - , (,,,) "data-files" False adjustedDataDir <$> dataFiles pkg - ] - - -- For each field with globs (see allGlobs), look for: - -- • errors (missing directory, no match) - -- • omitted documentation files (changelog) - checkGlob :: (String, Bool, FilePath, FilePath) - -> ([PackageCheck], [FilePath]) - -> IO ([PackageCheck], [FilePath]) - checkGlob (field, isDocField, dir, glob) acc@(warnings, docFiles1) = - -- Note: we just skip over parse errors here; they're reported elsewhere. - case parseFileGlob (specVersion pkg) glob of - Left _ -> return acc - Right parsedGlob -> do - results <- runDirFileGlob verbosity (root dir) parsedGlob - let acc0 = (warnings, True, docFiles1, []) - return $ case foldr checkGlobResult acc0 results of - (individualWarn, noMatchesWarn, docFiles1', wrongPaths) -> - let wrongFieldWarnings = [ PackageDistSuspiciousWarn - (WrongFieldForExpectedDocFiles - extraDocFilesSupport - field wrongPaths) - | not (null wrongPaths) ] - in - ( if noMatchesWarn - then [PackageDistSuspiciousWarn (GlobNoMatch field glob)] ++ - individualWarn ++ - wrongFieldWarnings - else individualWarn ++ wrongFieldWarnings - , docFiles1' - ) - where - checkGlobResult :: GlobResult FilePath - -> ([PackageCheck], Bool, [FilePath], [FilePath]) - -> ([PackageCheck], Bool, [FilePath], [FilePath]) - checkGlobResult result (ws, noMatchesWarn, docFiles2, wrongPaths) = - let noMatchesWarn' = noMatchesWarn && - not (suppressesNoMatchesWarning result) - in case getWarning field glob result of - -- No match: add warning and do no further check - Left w -> - ( w : ws - , noMatchesWarn' - , docFiles2 - , wrongPaths - ) - -- Match: check doc files - Right path -> - let path' = makeRelative root (normalise path) - (docFiles2', wrongPaths') = checkDoc isDocField - path' - docFiles2 - wrongPaths - in - ( ws - , noMatchesWarn' - , docFiles2' - , wrongPaths' - ) - - -- Check whether a path is a desirable doc: if so, check if it is in the - -- field "extra-doc-files". - checkDoc :: Bool -- Is it "extra-doc-files" ? - -> FilePath -- Path to test - -> [FilePath] -- Pending doc files to check - -> [FilePath] -- Previous wrong paths - -> ([FilePath], [FilePath]) -- Updated paths - checkDoc isDocField path docFiles wrongFieldPaths = - if path `elem` docFiles - -- Found desirable doc file - then - ( delete path docFiles - , if isDocField then wrongFieldPaths else path : wrongFieldPaths - ) - -- Not a desirable doc file - else - ( docFiles - , wrongFieldPaths - ) - - -- Predicate for desirable documentation file on Hackage server - isDesirableExtraDocFile :: ([FilePath], [FilePath]) -> FilePath -> Bool - isDesirableExtraDocFile (basenames, extensions) path = - basename `elem` basenames && ext `elem` extensions - where - (basename, ext) = splitExtension (map toLower path) - - -- Changelog patterns (basenames & extensions) - -- Source: hackage-server/src/Distribution/Server/Packages/ChangeLog.hs - desirableChangeLog = - [ "news" - , "changelog" - , "change_log" - , "changes" - ] - desirableChangeLogExtensions = ["", ".txt", ".md", ".markdown", ".rst"] - -- [TODO] Check readme. Observations: - -- • Readme is not necessary if package description is good. - -- • Some readmes exists only for repository browsing. - -- • There is currently no reliable way to check what a good - -- description is; there will be complains if the criterion is - -- based on the length or number of words (can of worms). - -- -- Readme patterns - -- -- Source: hackage-server/src/Distribution/Server/Packages/Readme.hs - -- desirableReadme = ["readme"] - desirableDocFiles = (desirableChangeLog, desirableChangeLogExtensions) - - -- If there's a missing directory in play, since our globs don't - -- (currently) support disjunction, that will always mean there are no - -- matches. The no matches error in this case is strictly less informative - -- than the missing directory error, so sit on it. - suppressesNoMatchesWarning (GlobMatch _) = True - suppressesNoMatchesWarning (GlobWarnMultiDot _) = False - suppressesNoMatchesWarning (GlobMissingDirectory _) = True - - getWarning :: String - -> FilePath - -> GlobResult FilePath - -> Either PackageCheck FilePath - getWarning _ _ (GlobMatch path) = - Right path - -- Before Cabal 2.4, the extensions of globs had to match the file - -- exactly. This has been relaxed in 2.4 to allow matching only the - -- suffix. This warning detects when pre-2.4 package descriptions are - -- omitting files purely because of the stricter check. - getWarning field glob (GlobWarnMultiDot file) = - Left (PackageDistSuspiciousWarn (GlobExactMatch field glob file)) - getWarning field glob (GlobMissingDirectory dir) = - Left (PackageDistSuspiciousWarn (GlobNoDir field glob dir)) - --- | Check that setup dependencies, have proper bounds. --- In particular, @base@ and @Cabal@ upper bounds are mandatory. -checkSetupVersions :: GenericPackageDescription -> [PackageCheck] -checkSetupVersions pkg = - [ emitError nameStr - | (name, vr) <- Map.toList deps - , not (hasUpperBound vr) - , let nameStr = unPackageName name - , nameStr `elem` criticalPkgs - ] - where - criticalPkgs = ["Cabal", "base"] - deps = toDependencyVersionsMap (foldMap setupDepends . setupBuildInfo) pkg - emitError nm = - PackageDistInexcusable (UpperBoundSetup nm) - -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) - 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 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 = foldCondTree Map.empty - (\(_,v) -> Map.fromListWith sumPair . map (\x -> (x,(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 [] - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - -toDependencyVersionsMap :: (PackageDescription -> [Dependency]) -> GenericPackageDescription -> Map PackageName VersionRange -toDependencyVersionsMap selectDependencies pkg = case typicalPkg pkg of - Right (pkgs', _) -> - let - self :: PackageName - self = pkgName $ package pkgs' - in - Map.fromListWith intersectVersionRanges $ - [ (pname, vr) - | Dependency pname vr _ <- selectDependencies pkgs' - , pname /= self - ] - -- Just in case finalizePD fails for any reason, - -- or if the package doesn't depend on the base package at all, - -- no deps is no checks. - _ -> Map.empty - - -quote :: String -> String -quote s = "'" ++ s ++ "'" - -commaSep :: [String] -> String -commaSep = intercalate ", " - -dups :: Ord a => [a] -> [a] -dups xs = [ x | (x:_:_) <- group (sort xs) ] - -fileExtensionSupportedLanguage :: FilePath -> Bool -fileExtensionSupportedLanguage path = - isHaskell || isC - where - extension = takeExtension path - isHaskell = extension `elem` [".hs", ".lhs"] - isC = isJust (filenameCDialect extension) - --- | Whether a path is a good relative path. We aren't worried about perfect --- cross-platform compatibility here; this function just checks the paths in --- the (local) @.cabal@ file, while only Hackage needs the portability. --- --- >>> let test fp = putStrLn $ show (isGoodRelativeDirectoryPath fp) ++ "; " ++ show (isGoodRelativeFilePath fp) --- --- Note that "foo./bar.hs" would be invalid on Windows. --- --- >>> traverse_ test ["foo/bar/quu", "a/b.hs", "foo./bar.hs"] --- Nothing; Nothing --- Nothing; Nothing --- Nothing; Nothing --- --- Trailing slash is not allowed for files, for directories it is ok. --- --- >>> test "foo/" --- Nothing; Just "trailing slash" --- --- Leading @./@ is fine, but @.@ and @./@ are not valid files. --- --- >>> traverse_ test [".", "./", "./foo/bar"] --- Nothing; Just "trailing dot segment" --- Nothing; Just "trailing slash" --- Nothing; Nothing --- --- Lastly, not good file nor directory cases: --- --- >>> traverse_ test ["", "/tmp/src", "foo//bar", "foo/.", "foo/./bar", "foo/../bar"] --- Just "empty path"; Just "empty path" --- Just "posix absolute path"; Just "posix absolute path" --- Just "empty path segment"; Just "empty path segment" --- Just "trailing same directory segment: ."; Just "trailing same directory segment: ." --- Just "same directory segment: ."; Just "same directory segment: ." --- Just "parent directory segment: .."; Just "parent directory segment: .." --- --- For the last case, 'isGoodRelativeGlob' doesn't warn: --- --- >>> traverse_ (print . isGoodRelativeGlob) ["foo/../bar"] --- Just "parent directory segment: .." --- -isGoodRelativeFilePath :: FilePath -> Maybe String -isGoodRelativeFilePath = state0 - where - -- initial state - state0 [] = Just "empty path" - state0 (c:cs) | c == '.' = state1 cs - | c == '/' = Just "posix absolute path" - | otherwise = state5 cs - - -- after initial . - state1 [] = Just "trailing dot segment" - state1 (c:cs) | c == '.' = state4 cs - | c == '/' = state2 cs - | otherwise = state5 cs - - -- after ./ or after / between segments - state2 [] = Just "trailing slash" - state2 (c:cs) | c == '.' = state3 cs - | c == '/' = Just "empty path segment" - | otherwise = state5 cs - - -- after non-first segment's . - state3 [] = Just "trailing same directory segment: ." - state3 (c:cs) | c == '.' = state4 cs - | c == '/' = Just "same directory segment: ." - | otherwise = state5 cs - - -- after .. - state4 [] = Just "trailing parent directory segment: .." - state4 (c:cs) | c == '.' = state5 cs - | c == '/' = Just "parent directory segment: .." - | otherwise = state5 cs - - -- in a segment which is ok. - state5 [] = Nothing - state5 (c:cs) | c == '.' = state5 cs - | c == '/' = state2 cs - | otherwise = state5 cs - --- | See 'isGoodRelativeFilePath'. --- --- This is barebones function. We check whether the glob is a valid file --- by replacing stars @*@ with @x@ses. -isGoodRelativeGlob :: FilePath -> Maybe String -isGoodRelativeGlob = isGoodRelativeFilePath . map f where - f '*' = 'x' - f c = c - --- | See 'isGoodRelativeFilePath'. -isGoodRelativeDirectoryPath :: FilePath -> Maybe String -isGoodRelativeDirectoryPath = state0 - where - -- initial state - state0 [] = Just "empty path" - state0 (c:cs) | c == '.' = state5 cs - | c == '/' = Just "posix absolute path" - | otherwise = state4 cs - - -- after initial ./ or after / between segments - state1 [] = Nothing - state1 (c:cs) | c == '.' = state2 cs - | c == '/' = Just "empty path segment" - | otherwise = state4 cs - - -- after non-first setgment's . - state2 [] = Just "trailing same directory segment: ." - state2 (c:cs) | c == '.' = state3 cs - | c == '/' = Just "same directory segment: ." - | otherwise = state4 cs - - -- after .. - state3 [] = Just "trailing parent directory segment: .." - state3 (c:cs) | c == '.' = state4 cs - | c == '/' = Just "parent directory segment: .." - | otherwise = state4 cs - - -- in a segment which is ok. - state4 [] = Nothing - state4 (c:cs) | c == '.' = state4 cs - | c == '/' = state1 cs - | otherwise = state4 cs - - -- after initial . - state5 [] = Nothing -- "." - state5 (c:cs) | c == '.' = state3 cs - | c == '/' = state1 cs - | otherwise = state4 cs - --- [Note: Good relative paths] --- --- Using @kleene@ we can define an extended regex: --- --- @ --- import Algebra.Lattice --- import Kleene --- import Kleene.ERE (ERE (..), intersections) --- --- data C = CDot | CSlash | CChar --- deriving (Eq, Ord, Enum, Bounded, Show) --- --- reservedR :: ERE C --- reservedR = notChar CSlash --- --- pathPieceR :: ERE C --- pathPieceR = intersections --- [ plus reservedR --- , ERENot (string [CDot]) --- , ERENot (string [CDot,CDot]) --- ] --- --- filePathR :: ERE C --- filePathR = optional (string [CDot, CSlash]) <> pathPieceR <> star (char CSlash <> pathPieceR) --- --- dirPathR :: ERE C --- dirPathR = (char CDot \/ filePathR) <> optional (char CSlash) --- --- plus :: ERE C -> ERE C --- plus r = r <> star r --- --- optional :: ERE C -> ERE C --- optional r = mempty \/ r --- @ --- --- Results in following state machine for @filePathR@ --- --- @ --- 0 -> \x -> if --- | x <= CDot -> 1 --- | otherwise -> 5 --- 1 -> \x -> if --- | x <= CDot -> 4 --- | x <= CSlash -> 2 --- | otherwise -> 5 --- 2 -> \x -> if --- | x <= CDot -> 3 --- | otherwise -> 5 --- 3 -> \x -> if --- | x <= CDot -> 4 --- | otherwise -> 5 --- 4 -> \x -> if --- | x <= CDot -> 5 --- | otherwise -> 5 --- 5+ -> \x -> if --- | x <= CDot -> 5 --- | x <= CSlash -> 2 --- | otherwise -> 5 --- @ --- --- and @dirPathR@: --- --- @ --- 0 -> \x -> if --- | x <= CDot -> 5 --- | otherwise -> 4 --- 1+ -> \x -> if --- | x <= CDot -> 2 --- | otherwise -> 4 --- 2 -> \x -> if --- | x <= CDot -> 3 --- | otherwise -> 4 --- 3 -> \x -> if --- | x <= CDot -> 4 --- | otherwise -> 4 --- 4+ -> \x -> if --- | x <= CDot -> 4 --- | x <= CSlash -> 1 --- | otherwise -> 4 --- 5+ -> \x -> if --- | x <= CDot -> 3 --- | x <= CSlash -> 1 --- | otherwise -> 4 --- @ - --- --- TODO: What we really want to do is test if there exists any --- configuration in which the base version is unbounded above. --- However that's a bit tricky because there are many possible --- configurations. As a cheap easy and safe approximation we will --- pick a single "typical" configuration and check if that has an --- open upper bound. To get a typical configuration we finalise --- using no package index and the current platform. -typicalPkg :: GenericPackageDescription - -> Either [Dependency] (PackageDescription, FlagAssignment) -typicalPkg = finalizePD - mempty defaultComponentRequestedSpec (const True) - buildPlatform - (unknownCompilerInfo - (CompilerId buildCompilerFlavor nullVersion) - NoAbiTag) - [] - -addConditionalExp :: String -> String -addConditionalExp expl = expl ++ - " Alternatively, if you want to use this, make it conditional based " - ++ "on a Cabal configuration flag (with 'manual: True' and 'default: " - ++ "False') and enable that flag during development." +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Distribution.PackageDescription.Check +-- Copyright : Lennart Kolmodin 2008, Francesco Ariis 2022 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This has code for checking for various problems in packages. There is one +-- set of checks that just looks at a 'PackageDescription' in isolation and +-- another set of checks that also looks at files in the package. Some of the +-- checks are basic sanity checks, others are portability standards that we'd +-- like to encourage. There is a 'PackageCheck' type that distinguishes the +-- different kinds of checks so we can see which ones are appropriate to report +-- in different situations. This code gets used when configuring a package when +-- we consider only basic problems. The higher standard is used when +-- preparing a source tarball and by Hackage when uploading new packages. The +-- reason for this is that we want to hold packages that are expected to be +-- distributed to a higher standard than packages that are only ever expected +-- to be used on the author's own environment. +module Distribution.PackageDescription.Check + ( -- * Package Checking + CheckExplanation (..) + , CheckExplanationID + , CheckExplanationIDString + , PackageCheck (..) + , checkPackage + , checkConfiguredPackage + , wrapParseWarning + , ppPackageCheck + , ppCheckExplanationId + , isHackageDistError + , filterPackageChecksById + , filterPackageChecksByIdString + + -- ** Checking package contents + , checkPackageFiles + , checkPackageFilesGPD + , checkPackageContent + , CheckPackageContentOps (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Data.List (group) +import Distribution.CabalSpecVersion +import Distribution.Compat.Lens +import Distribution.Compiler +import Distribution.License +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Check.Common +import Distribution.PackageDescription.Check.Conditional +import Distribution.PackageDescription.Check.Monad +import Distribution.PackageDescription.Check.Paths +import Distribution.PackageDescription.Check.Target +import Distribution.PackageDescription.Check.Warning +import Distribution.Parsec.Warning (PWarning) +import Distribution.Pretty (prettyShow) +import Distribution.Simple.Glob + ( Glob + , GlobResult (..) + , globMatches + , parseFileGlob + , runDirFileGlob + ) +import Distribution.Simple.Utils hiding (findPackageDesc, notice) +import Distribution.Utils.Generic (isAscii) +import Distribution.Utils.Path + ( LicenseFile + , PackageDir + , SymbolicPath + , getSymbolicPath + ) +import Distribution.Verbosity +import Distribution.Version +import System.FilePath (splitExtension, takeFileName, (<.>), ()) + +import qualified Data.ByteString.Lazy as BS +import qualified Distribution.SPDX as SPDX +import qualified System.Directory as System + +import qualified System.Directory (getDirectoryContents) +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.Types.GenericPackageDescription.Lens as L + +import Control.Monad + +-- $setup +-- >>> import Control.Arrow ((&&&)) + +-- ☞ N.B. +-- +-- Part of the tools/scaffold used to perform check is found in +-- Distribution.PackageDescription.Check.Types. Summary of that module (for +-- how we use it here): +-- 1. we work inside a 'CheckM m a' monad (where `m` is an abstraction to +-- run non-pure checks); +-- 2. 'checkP', 'checkPre' functions perform checks (respectively pure and +-- non-pure); +-- 3. 'PackageCheck' and 'CheckExplanation' are types for warning severity +-- and description. + +-- ------------------------------------------------------------ +-- Checking interface +-- ------------------------------------------------------------ + +-- | 'checkPackagePrim' is the most general way to invoke package checks. +-- We pass to it two interfaces (one to check contents of packages, the +-- other to inspect working tree for orphan files) and before that a +-- Boolean to indicate whether we want pure checks or not. Based on these +-- parameters, some checks will be performed, some omitted. +-- Generality over @m@ means we could do non pure checks in monads other +-- than IO (e.g. a virtual filesystem, like a zip file, a VCS filesystem, +-- etc). +checkPackagePrim + :: Monad m + => Bool -- Perform pure checks? + -> Maybe (CheckPackageContentOps m) -- Package content interface. + -> Maybe (CheckPreDistributionOps m) -- Predist checks interface. + -> GenericPackageDescription -- GPD to check. + -> m [PackageCheck] +checkPackagePrim b mco mpdo gpd = do + let cm = checkGenericPackageDescription gpd + ci = CheckInterface b mco mpdo + ctx = pristineCheckCtx ci gpd + execCheckM cm ctx + +-- | Check for common mistakes and problems in package descriptions. +-- +-- This is the standard collection of checks covering all aspects except +-- for checks that require looking at files within the package. For those +-- see 'checkPackageFiles'. +checkPackage :: GenericPackageDescription -> [PackageCheck] +checkPackage gpd = runIdentity $ checkPackagePrim True Nothing Nothing gpd + +-- | This function is an oddity due to the historical +-- GenericPackageDescription/PackageDescription split. It is only maintained +-- not to break interface, use `checkPackage` if possible. +checkConfiguredPackage :: PackageDescription -> [PackageCheck] +checkConfiguredPackage pd = checkPackage (pd2gpd pd) + +-- | Sanity check things that requires looking at files in the package. +-- This is a generalised version of 'checkPackageFiles' that can work in any +-- monad for which you can provide 'CheckPackageContentOps' operations. +-- +-- The point of this extra generality is to allow doing checks in some virtual +-- file system, for example a tarball in memory. +checkPackageContent + :: Monad m + => CheckPackageContentOps m + -> GenericPackageDescription + -> m [PackageCheck] +checkPackageContent pops gpd = checkPackagePrim False (Just pops) Nothing gpd + +-- | Sanity checks that require IO. 'checkPackageFiles' looks at the files +-- in the package and expects to find the package unpacked at the given +-- filepath. +checkPackageFilesGPD + :: Verbosity -- Glob warn message verbosity. + -> GenericPackageDescription + -> FilePath -- Package root. + -> IO [PackageCheck] +checkPackageFilesGPD verbosity gpd root = + checkPackagePrim False (Just checkFilesIO) (Just checkPreIO) gpd + where + checkFilesIO = + CheckPackageContentOps + { doesFileExist = System.doesFileExist . relative + , doesDirectoryExist = System.doesDirectoryExist . relative + , getDirectoryContents = System.Directory.getDirectoryContents . relative + , getFileContents = BS.readFile . relative + } + + checkPreIO = + CheckPreDistributionOps + { runDirFileGlobM = \fp g -> runDirFileGlob verbosity (Just . specVersion $ packageDescription gpd) (root fp) g + , getDirectoryContentsM = System.Directory.getDirectoryContents . relative + } + + relative path = root path + +-- | Same as 'checkPackageFilesGPD', but working with 'PackageDescription'. +-- +-- This function is included for legacy reasons, use 'checkPackageFilesGPD' +-- if you are working with 'GenericPackageDescription'. +checkPackageFiles + :: Verbosity -- Glob warn message verbosity. + -> PackageDescription + -> FilePath -- Package root. + -> IO [PackageCheck] +checkPackageFiles verbosity pd oot = + checkPackageFilesGPD verbosity (pd2gpd pd) oot + +-- ------------------------------------------------------------ +-- Package description +-- ------------------------------------------------------------ + +-- Here lies the meat of the module. Starting from 'GenericPackageDescription', +-- we walk the data while doing a number of checks. +-- +-- Where applicable we do a full pattern match (if the data changes, code will +-- break: a gentle reminder to add more checks). +-- Pattern matching variables convention: matching accessor + underscore. +-- This way it is easier to see which one we are missing if we run into +-- an “GPD should have 20 arguments but has been given only 19” error. + +-- | 'GenericPackageDescription' checks. Remember that for historical quirks +-- in the cabal codebase we have both `GenericPackageDescription` and +-- `PackageDescription` and that PD is both a *field* of GPD and a concept +-- of its own (i.e. a fully realised GPD). +-- In this case we are checking (correctly) GPD, so for target info/checks +-- you should walk condLibrary_ etc. and *not* the (empty) target info in +-- PD. See 'pd2gpd' for a convenient hack when you only have +-- 'PackageDescription'. +checkGenericPackageDescription + :: Monad m + => GenericPackageDescription + -> CheckM m () +checkGenericPackageDescription + gpd@( GenericPackageDescription + packageDescription_ + _gpdScannedVersion_ + genPackageFlags_ + condLibrary_ + condSubLibraries_ + condForeignLibs_ + condExecutables_ + condTestSuites_ + condBenchmarks_ + ) = + do + -- § Description and names. + checkPackageDescription packageDescription_ + -- Targets should be present... + let condAllLibraries = + maybeToList condLibrary_ + ++ (map snd condSubLibraries_) + checkP + ( and + [ null condExecutables_ + , null condTestSuites_ + , null condBenchmarks_ + , null condAllLibraries + , null condForeignLibs_ + ] + ) + (PackageBuildImpossible NoTarget) + -- ... and have unique names (names are not under conditional, it is + -- appropriate to check here. + (nsubs, nexes, ntests, nbenchs) <- + asksCM + ( ( \n -> + ( pnSubLibs n + , pnExecs n + , pnTests n + , pnBenchs n + ) + ) + . ccNames + ) + let names = concat [nsubs, nexes, ntests, nbenchs] + dupes = dups names + checkP + (not . null $ dups names) + (PackageBuildImpossible $ DuplicateSections dupes) + -- PackageDescription checks. + checkPackageDescription packageDescription_ + -- Flag names. + mapM_ checkFlagName genPackageFlags_ + + -- § Feature checks. + checkSpecVer + CabalSpecV2_0 + (not . null $ condSubLibraries_) + (PackageDistInexcusable CVMultiLib) + checkSpecVer + CabalSpecV1_8 + (not . null $ condTestSuites_) + (PackageDistInexcusable CVTestSuite) + + -- § Conditional targets + + -- Extract dependencies from libraries, to be passed along for + -- PVP checks purposes. + pName <- + asksCM + ( packageNameToUnqualComponentName + . pkgName + . pnPackageId + . ccNames + ) + let ads = + maybe [] ((: []) . extractAssocDeps pName) condLibrary_ + ++ map (uncurry extractAssocDeps) condSubLibraries_ + + case condLibrary_ of + Just cl -> + checkCondTarget + genPackageFlags_ + (checkLibrary False ads) + (const id) + (mempty, cl) + Nothing -> return () + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkLibrary False ads) + (\u l -> l{libName = maybeToLibraryName (Just u)}) + ) + condSubLibraries_ + mapM_ + ( checkCondTarget + genPackageFlags_ + checkForeignLib + (const id) + ) + condForeignLibs_ + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkExecutable ads) + (const id) + ) + condExecutables_ + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkTestSuite ads) + (\u l -> l{testName = u}) + ) + condTestSuites_ + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkBenchmark ads) + (\u l -> l{benchmarkName = u}) + ) + condBenchmarks_ + + -- For unused flags it is clearer and more convenient to fold the + -- data rather than walk it, an exception to the rule. + checkP + (decFlags /= usedFlags) + (PackageDistSuspicious $ DeclaredUsedFlags decFlags usedFlags) + + -- Duplicate modules. + mapM_ tellP (checkDuplicateModules gpd) + where + -- todo is this caught at parse time? + checkFlagName :: Monad m => PackageFlag -> CheckM m () + checkFlagName pf = + let fn = unFlagName . flagName $ pf + + invalidFlagName ('-' : _) = True -- starts with dash + invalidFlagName cs = any (not . isAscii) cs -- non ASCII + in checkP + (invalidFlagName fn) + (PackageDistInexcusable $ SuspiciousFlagName [fn]) + + decFlags :: Set.Set FlagName + decFlags = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd + + usedFlags :: Set.Set FlagName + usedFlags = + mconcat + [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + ] + +checkPackageDescription :: Monad m => PackageDescription -> CheckM m () +checkPackageDescription + pkg@( PackageDescription + specVersion_ + package_ + licenseRaw_ + licenseFiles_ + _copyright_ + maintainer_ + _author_ + _stability_ + testedWith_ + _homepage_ + _pkgUrl_ + _bugReports_ + sourceRepos_ + synopsis_ + description_ + category_ + customFieldsPD_ + buildTypeRaw_ + setupBuildInfo_ + _library_ + _subLibraries_ + _executables_ + _foreignLibs_ + _testSuites_ + _benchmarks_ + dataFiles_ + dataDir_ + extraSrcFiles_ + extraTmpFiles_ + extraDocFiles_ + ) = do + -- § Sanity checks. + checkPackageId package_ + -- TODO `name` is caught at parse level, remove this test. + let pn = packageName package_ + checkP + (null . unPackageName $ pn) + (PackageBuildImpossible NoNameField) + -- TODO `version` is caught at parse level, remove this test. + checkP + (nullVersion == packageVersion package_) + (PackageBuildImpossible NoVersionField) + -- But it is OK for executables to have the same name. + nsubs <- asksCM (pnSubLibs . ccNames) + checkP + (any (== prettyShow pn) (prettyShow <$> nsubs)) + (PackageBuildImpossible $ IllegalLibraryName pn) + + -- § Fields check. + checkNull + category_ + (PackageDistSuspicious MissingFieldCategory) + checkNull + maintainer_ + (PackageDistSuspicious MissingFieldMaintainer) + checkP + (ShortText.null synopsis_ && not (ShortText.null description_)) + (PackageDistSuspicious MissingFieldSynopsis) + checkP + (ShortText.null description_ && not (ShortText.null synopsis_)) + (PackageDistSuspicious MissingFieldDescription) + checkP + (all ShortText.null [synopsis_, description_]) + (PackageDistInexcusable MissingFieldSynOrDesc) + checkP + (ShortText.length synopsis_ > 80) + (PackageDistSuspicious SynopsisTooLong) + checkP + ( not (ShortText.null description_) + && ShortText.length description_ <= ShortText.length synopsis_ + ) + (PackageDistSuspicious ShortDesc) + + -- § Paths. + mapM_ (checkPath False "extra-source-files" PathKindGlob) extraSrcFiles_ + mapM_ (checkPath False "extra-tmp-files" PathKindFile) extraTmpFiles_ + mapM_ (checkPath False "extra-doc-files" PathKindGlob) extraDocFiles_ + mapM_ (checkPath False "data-files" PathKindGlob) dataFiles_ + checkPath True "data-dir" PathKindDirectory dataDir_ + let licPaths = map getSymbolicPath licenseFiles_ + mapM_ (checkPath False "license-file" PathKindFile) licPaths + mapM_ checkLicFileExist licenseFiles_ + + -- § Globs. + dataGlobs <- mapM (checkGlob "data-files") dataFiles_ + extraGlobs <- mapM (checkGlob "extra-source-files") extraSrcFiles_ + docGlobs <- mapM (checkGlob "extra-doc-files") extraDocFiles_ + -- We collect globs to feed them to checkMissingDocs. + + -- § Missing documentation. + checkMissingDocs + (catMaybes dataGlobs) + (catMaybes extraGlobs) + (catMaybes docGlobs) + + -- § Datafield checks. + checkSetupBuildInfo setupBuildInfo_ + mapM_ checkTestedWith testedWith_ + either + checkNewLicense + (checkOldLicense $ null licenseFiles_) + licenseRaw_ + checkSourceRepos sourceRepos_ + mapM_ checkCustomField customFieldsPD_ + + -- Feature checks. + checkSpecVer + CabalSpecV1_18 + (not . null $ extraDocFiles_) + (PackageDistInexcusable CVExtraDocFiles) + checkSpecVer + CabalSpecV1_6 + (not . null $ sourceRepos_) + (PackageDistInexcusable CVSourceRepository) + checkP + ( specVersion_ >= CabalSpecV1_24 + && isNothing setupBuildInfo_ + && buildTypeRaw_ == Just Custom + ) + (PackageBuildWarning CVCustomSetup) + checkSpecVer + CabalSpecV1_24 + ( isNothing setupBuildInfo_ + && buildTypeRaw_ == Just Custom + ) + (PackageDistSuspiciousWarn CVExpliticDepsCustomSetup) + checkP + (isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2) + (PackageBuildWarning NoBuildType) + checkP + (isJust setupBuildInfo_ && buildType pkg /= Custom) + (PackageBuildWarning NoCustomSetup) + + -- Contents. + checkConfigureExists (buildType pkg) + checkSetupExists (buildType pkg) + checkCabalFile (packageName pkg) + mapM_ (checkGlobFile specVersion_ "." "extra-source-files") extraSrcFiles_ + mapM_ (checkGlobFile specVersion_ "." "extra-doc-files") extraDocFiles_ + mapM_ (checkGlobFile specVersion_ dataDir_ "data-files") dataFiles_ + where + checkNull + :: Monad m + => ShortText.ShortText + -> PackageCheck + -> CheckM m () + checkNull st c = checkP (ShortText.null st) c + + checkTestedWith + :: Monad m + => (CompilerFlavor, VersionRange) + -> CheckM m () + checkTestedWith (OtherCompiler n, _) = + tellP (PackageBuildWarning $ UnknownCompilers [n]) + checkTestedWith (compiler, versionRange) = + checkVersionRange compiler versionRange + + checkVersionRange + :: Monad m + => CompilerFlavor + -> VersionRange + -> CheckM m () + checkVersionRange cmp vr = + when + (isNoVersion vr) + ( let dep = + [ Dependency + (mkPackageName (prettyShow cmp)) + vr + mainLibSet + ] + in tellP (PackageDistInexcusable (InvalidTestWith dep)) + ) + +checkSetupBuildInfo :: Monad m => Maybe SetupBuildInfo -> CheckM m () +checkSetupBuildInfo Nothing = return () +checkSetupBuildInfo (Just (SetupBuildInfo ds _)) = do + let uqs = map mkUnqualComponentName ["base", "Cabal"] + (is, rs) <- partitionDeps [] uqs ds + let ick = PackageDistInexcusable . UpperBoundSetup + rck = + PackageDistSuspiciousWarn + . MissingUpperBounds CETSetup + checkPVP ick is + checkPVPs rck rs + +checkPackageId :: Monad m => PackageIdentifier -> CheckM m () +checkPackageId (PackageIdentifier pkgName_ _pkgVersion_) = do + checkP + (not . FilePath.Windows.isValid . prettyShow $ pkgName_) + (PackageDistInexcusable $ InvalidNameWin pkgName_) + checkP (isPrefixOf "z-" . prettyShow $ pkgName_) $ + (PackageDistInexcusable ZPrefix) + +checkNewLicense :: Monad m => SPDX.License -> CheckM m () +checkNewLicense lic = do + checkP + (lic == SPDX.NONE) + (PackageDistInexcusable NONELicense) + +checkOldLicense + :: Monad m + => Bool -- Flag: no license file? + -> License + -> CheckM m () +checkOldLicense nullLicFiles lic = do + checkP + (lic == UnspecifiedLicense) + (PackageDistInexcusable NoLicense) + checkP + (lic == AllRightsReserved) + (PackageDistSuspicious AllRightsReservedLicense) + checkSpecVer + CabalSpecV1_4 + (lic `notElem` compatLicenses) + (PackageDistInexcusable (LicenseMessParse lic)) + checkP + (lic == BSD4) + (PackageDistSuspicious UncommonBSD4) + case lic of + UnknownLicense l -> + tellP (PackageBuildWarning (UnrecognisedLicense l)) + _ -> return () + checkP + ( lic + `notElem` [ AllRightsReserved + , UnspecifiedLicense + , PublicDomain + ] + && + -- AllRightsReserved and PublicDomain are not strictly + -- licenses so don't need license files. + nullLicFiles + ) + $ (PackageDistSuspicious NoLicenseFile) + case unknownLicenseVersion lic of + Just knownVersions -> + tellP + (PackageDistSuspicious $ UnknownLicenseVersion lic knownVersions) + _ -> return () + where + compatLicenses = + [ GPL Nothing + , LGPL Nothing + , AGPL Nothing + , BSD3 + , BSD4 + , PublicDomain + , AllRightsReserved + , UnspecifiedLicense + , OtherLicense + ] + + unknownLicenseVersion (GPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | GPL (Just v') <- knownLicenses] + unknownLicenseVersion (LGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | LGPL (Just v') <- knownLicenses] + unknownLicenseVersion (AGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | AGPL (Just v') <- knownLicenses] + unknownLicenseVersion (Apache (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | Apache (Just v') <- knownLicenses] + unknownLicenseVersion _ = Nothing + +checkSourceRepos :: Monad m => [SourceRepo] -> CheckM m () +checkSourceRepos rs = do + mapM_ repoCheck rs + checkMissingVcsInfo rs + where + -- Single repository checks. + repoCheck :: Monad m => SourceRepo -> CheckM m () + repoCheck + ( SourceRepo + repoKind_ + repoType_ + repoLocation_ + repoModule_ + _repoBranch_ + repoTag_ + repoSubdir_ + ) = do + case repoKind_ of + RepoKindUnknown kind -> + tellP + (PackageDistInexcusable $ UnrecognisedSourceRepo kind) + _ -> return () + checkP + (isNothing repoType_) + (PackageDistInexcusable MissingType) + checkP + (isNothing repoLocation_) + (PackageDistInexcusable MissingLocation) + checkP + ( repoType_ == Just (KnownRepoType CVS) + && isNothing repoModule_ + ) + (PackageDistInexcusable MissingModule) + checkP + (repoKind_ == RepoThis && isNothing repoTag_) + (PackageDistInexcusable MissingTag) + checkP + (any isAbsoluteOnAnyPlatform repoSubdir_) + (PackageDistInexcusable SubdirRelPath) + case join . fmap isGoodRelativeDirectoryPath $ repoSubdir_ of + Just err -> + tellP + (PackageDistInexcusable $ SubdirGoodRelPath err) + Nothing -> return () + +checkMissingVcsInfo :: Monad m => [SourceRepo] -> CheckM m () +checkMissingVcsInfo rs = + let rdirs = concatMap repoTypeDirname knownRepoTypes + in checkPkg + ( \ops -> do + us <- or <$> traverse (doesDirectoryExist ops) rdirs + return (null rs && us) + ) + (PackageDistSuspicious MissingSourceControl) + where + repoTypeDirname :: KnownRepoType -> [FilePath] + repoTypeDirname Darcs = ["_darcs"] + repoTypeDirname Git = [".git"] + repoTypeDirname SVN = [".svn"] + repoTypeDirname CVS = ["CVS"] + repoTypeDirname Mercurial = [".hg"] + repoTypeDirname GnuArch = [".arch-params"] + repoTypeDirname Bazaar = [".bzr"] + repoTypeDirname Monotone = ["_MTN"] + repoTypeDirname Pijul = [".pijul"] + +-- ------------------------------------------------------------ +-- Package and distribution checks +-- ------------------------------------------------------------ + +-- | Find a package description file in the given directory. Looks for +-- @.cabal@ files. Like 'Distribution.Simple.Utils.findPackageDesc', +-- but generalized over monads. +findPackageDesc :: Monad m => CheckPackageContentOps m -> m [FilePath] +findPackageDesc ops = do + let dir = "." + files <- getDirectoryContents 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 <- + filterM + (doesFileExist ops) + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == ".cabal" + ] + return cabalFiles + +checkCabalFile :: Monad m => PackageName -> CheckM m () +checkCabalFile pn = do + -- liftInt is a bit more messy than stricter interface, but since + -- each of the following check is exclusive, we can simplify the + -- condition flow. + liftInt + ciPackageOps + ( \ops -> do + -- 1. Get .cabal files. + ds <- findPackageDesc ops + case ds of + [] -> return [PackageBuildImpossible NoDesc] + -- No .cabal file. + [d] -> do + bc <- bomf ops d + return (catMaybes [bc, noMatch d]) + -- BOM + no matching .cabal checks. + _ -> return [PackageBuildImpossible $ MultiDesc ds] + ) + where + -- Multiple .cabal files. + + bomf + :: Monad m + => CheckPackageContentOps m + -> FilePath + -> m (Maybe PackageCheck) + bomf wops wfp = do + b <- BS.isPrefixOf bomUtf8 <$> getFileContents wops wfp + if b + then (return . Just) (PackageDistInexcusable $ BOMStart wfp) + else return Nothing + + bomUtf8 :: BS.ByteString + bomUtf8 = BS.pack [0xef, 0xbb, 0xbf] -- U+FEFF encoded as UTF8 + noMatch :: FilePath -> Maybe PackageCheck + noMatch wd = + let expd = unPackageName pn <.> "cabal" + in if takeFileName wd /= expd + then Just (PackageDistInexcusable $ NotPackageName wd expd) + else Nothing + +checkLicFileExist + :: Monad m + => SymbolicPath PackageDir LicenseFile + -> CheckM m () +checkLicFileExist sp = do + let fp = getSymbolicPath sp + checkPkg + (\ops -> not <$> doesFileExist ops fp) + (PackageBuildWarning $ UnknownFile "license-file" sp) + +checkConfigureExists :: Monad m => BuildType -> CheckM m () +checkConfigureExists Configure = + checkPkg + (\ops -> not <$> doesFileExist ops "configure") + (PackageBuildWarning MissingConfigureScript) +checkConfigureExists _ = return () + +checkSetupExists :: Monad m => BuildType -> CheckM m () +checkSetupExists Simple = return () +checkSetupExists _ = + checkPkg + ( \ops -> do + ba <- doesFileExist ops "Setup.hs" + bb <- doesFileExist ops "Setup.lhs" + return (not $ ba || bb) + ) + (PackageDistInexcusable MissingSetupFile) + +-- The following functions are similar to 'CheckPackageContentOps m' ones, +-- but, as they inspect the files included in the package, but are primarily +-- looking for files in the working tree that may have been missed or other +-- similar problems that can only be detected pre-distribution. +-- +-- Because Hackage necessarily checks the uploaded tarball, it is too late to +-- check these on the server; these checks only make sense in the development +-- and package-creation environment. +-- This most likely means we need to use IO, but a dictionary +-- 'CheckPreDistributionOps m' is provided in case in the future such +-- information can come from somewhere else (e.g. VCS filesystem). +-- +-- Note: this really shouldn't return any 'Inexcusable' warnings, +-- because that will make us say that Hackage would reject the package. +-- But, because Hackage doesn't yet run these tests, that will be a lie! + +checkGlobFile + :: Monad m + => CabalSpecVersion + -> FilePath -- Glob pattern. + -> FilePath -- Folder to check. + -> CabalField -- .cabal field we are checking. + -> CheckM m () +checkGlobFile cv ddir title fp = do + let adjDdir = if null ddir then "." else ddir + dir + | title == "data-files" = adjDdir + | otherwise = "." + + case parseFileGlob cv fp of + -- We just skip over parse errors here; they're reported elsewhere. + Left _ -> return () + Right parsedGlob -> do + liftInt ciPreDistOps $ \po -> do + rs <- runDirFileGlobM po dir parsedGlob + return $ checkGlobResult title fp rs + +-- | Checks for matchless globs and too strict matching (<2.4 spec). +checkGlobResult + :: CabalField -- .cabal field we are checking + -> FilePath -- Glob pattern (to show the user + -- which pattern is the offending + -- one). + -> [GlobResult FilePath] -- List of glob results. + -> [PackageCheck] +checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs) + where + dirCheck + | all (not . withoutNoMatchesWarning) rs = + [PackageDistSuspiciousWarn $ GlobNoMatch title fp] + | otherwise = [] + + -- If there's a missing directory in play, since globs in Cabal packages + -- don't (currently) support disjunction, that will always mean there are + -- no matches. The no matches error in this case is strictly less + -- informative than the missing directory error. + withoutNoMatchesWarning (GlobMatch _) = True + withoutNoMatchesWarning (GlobWarnMultiDot _) = False + withoutNoMatchesWarning (GlobMissingDirectory _) = True + withoutNoMatchesWarning (GlobMatchesDirectory _) = True + + getWarning :: GlobResult FilePath -> Maybe PackageCheck + getWarning (GlobMatch _) = Nothing + -- Before Cabal 2.4, the extensions of globs had to match the file + -- exactly. This has been relaxed in 2.4 to allow matching only the + -- suffix. This warning detects when pre-2.4 package descriptions + -- are omitting files purely because of the stricter check. + getWarning (GlobWarnMultiDot file) = + Just $ PackageDistSuspiciousWarn (GlobExactMatch title fp file) + getWarning (GlobMissingDirectory dir) = + Just $ PackageDistSuspiciousWarn (GlobNoDir title fp dir) + -- GlobMatchesDirectory is handled elsewhere if relevant; + -- we can discard it here. + getWarning (GlobMatchesDirectory _) = Nothing + +-- ------------------------------------------------------------ +-- Other exports +-- ------------------------------------------------------------ + +-- | Wraps `ParseWarning` into `PackageCheck`. +wrapParseWarning :: FilePath -> PWarning -> PackageCheck +wrapParseWarning fp pw = PackageDistSuspicious (ParseWarning fp pw) + +-- TODO: as Jul 2022 there is no severity indication attached PWarnType. +-- Once that is added, we can output something more appropriate +-- than PackageDistSuspicious for every parse warning. +-- (see: Cabal-syntax/src/Distribution/Parsec/Warning.hs) + +-- ------------------------------------------------------------ +-- Ancillaries +-- ------------------------------------------------------------ + +-- Gets a list of dependencies from a Library target to pass to PVP related +-- functions. We are not doing checks here: this is not imprecise, as the +-- library itself *will* be checked for PVP errors. +-- Same for branch merging, +-- each of those branch will be checked one by one. +extractAssocDeps + :: UnqualComponentName -- Name of the target library + -> CondTree ConfVar [Dependency] 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) + +-- | August 2022: this function is an oddity due to the historical +-- GenericPackageDescription/PackageDescription split (check +-- Distribution.Types.PackageDescription for a description of the relationship +-- between GPD and PD. +-- It is only maintained not to break interface, should be deprecated in the +-- future in favour of `checkPackage` when PD and GPD are refactored sensibly. +pd2gpd :: PackageDescription -> GenericPackageDescription +pd2gpd pd = gpd + where + gpd :: GenericPackageDescription + gpd = + emptyGenericPackageDescription + { packageDescription = pd + , condLibrary = fmap t2c (library pd) + , condSubLibraries = map (t2cName ln id) (subLibraries pd) + , condForeignLibs = + map + (t2cName foreignLibName id) + (foreignLibs pd) + , condExecutables = + map + (t2cName exeName id) + (executables pd) + , condTestSuites = + map + (t2cName testName remTest) + (testSuites pd) + , condBenchmarks = + map + (t2cName benchmarkName remBench) + (benchmarks pd) + } + + -- From target to simple, unconditional CondTree. + t2c :: a -> CondTree ConfVar [Dependency] 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 + -- the target. This is needed for 'initTargetAnnotation' to work + -- properly and to contain all the quirks inside 'pd2gpd'. + t2cName + :: (a -> UnqualComponentName) + -> (a -> a) + -> a + -> (UnqualComponentName, CondTree ConfVar [Dependency] a) + t2cName nf mf a = (nf a, t2c . mf $ a) + + ln :: Library -> UnqualComponentName + ln wl = case libName wl of + (LSubLibName u) -> u + LMainLibName -> mkUnqualComponentName "main-library" + + remTest :: TestSuite -> TestSuite + remTest t = t{testName = mempty} + + remBench :: Benchmark -> Benchmark + remBench b = b{benchmarkName = mempty} + +-- checkMissingDocs will check that we don’t have an interesting file +-- (changes.txt, Changelog.md, NEWS, etc.) in our work-tree which is not +-- present in our .cabal file. +checkMissingDocs + :: Monad m + => [Glob] -- data-files globs. + -> [Glob] -- extra-source-files globs. + -> [Glob] -- extra-doc-files globs. + -> CheckM m () +checkMissingDocs dgs esgs edgs = do + extraDocSupport <- (>= CabalSpecV1_18) <$> asksCM ccSpecVersion + + -- Everything in this block uses CheckPreDistributionOps interface. + liftInt + 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. + let des = filter isDesirableExtraDocFile rootContents + + -- 2. Realise Globs. + let realGlob t = + concatMap globMatches + <$> mapM (runDirFileGlobM ops "") t + rgs <- realGlob dgs + res <- realGlob esgs + red <- realGlob edgs + + -- 3. Check if anything in 1. is missing in 2. + let mcs = checkDoc extraDocSupport des (rgs ++ res ++ red) + + -- 4. Check if files are present but in the wrong field. + let pcsData = checkDocMove extraDocSupport "data-files" des rgs + pcsSource = + if extraDocSupport + then + checkDocMove + extraDocSupport + "extra-source-files" + des + res + else [] + pcs = pcsData ++ pcsSource + + return (mcs ++ pcs) + ) + where + checkDoc + :: Bool -- Cabal spec ≥ 1.18? + -> [FilePath] -- Desirables. + -> [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 + ] + + checkDocMove + :: Bool -- Cabal spec ≥ 1.18? + -> CabalField -- Name of the field. + -> [FilePath] -- Desirables. + -> [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 + ] + +-- Predicate for desirable documentation file on Hackage server. +isDesirableExtraDocFile :: FilePath -> Bool +isDesirableExtraDocFile path = + basename `elem` desirableChangeLog + && ext `elem` desirableChangeLogExtensions + where + (basename, ext) = splitExtension (map toLower path) + + -- Changelog patterns (basenames & extensions) + -- Source: hackage-server/src/Distribution/Server/Packages/ChangeLog.hs + desirableChangeLog = ["news", "changelog", "change_log", "changes"] + desirableChangeLogExtensions = ["", ".txt", ".md", ".markdown", ".rst"] + +-- [TODO] Check readme. Observations: +-- • Readme is not necessary if package description is good. +-- • Some readmes exists only for repository browsing. +-- • There is currently no reliable way to check what a good +-- description is; there will be complains if the criterion +-- is based on the length or number of words (can of worms). +-- -- Readme patterns +-- -- Source: hackage-server/src/Distribution/Server/Packages/Readme.hs +-- desirableReadme = ["readme"] + +-- Remove duplicates from list. +dups :: Ord a => [a] -> [a] +dups xs = [x | (x : _ : _) <- group (sort xs)] diff --git a/src/Distribution/PackageDescription/Check/Common.hs b/src/Distribution/PackageDescription/Check/Common.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/PackageDescription/Check/Common.hs @@ -0,0 +1,149 @@ +-- | +-- Module : Distribution.PackageDescription.Check.Common +-- Copyright : Francesco Ariis 2022 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Common types/functions to various check modules which are *no* part of +-- Distribution.PackageDescription.Check.Monad. +module Distribution.PackageDescription.Check.Common + ( AssocDep + , CabalField + , PathKind (..) + , checkCustomField + , partitionDeps + , checkPVP + , checkPVPs + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compat.NonEmptySet (toNonEmpty) +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Check.Monad +import Distribution.Utils.Generic (isAscii) +import Distribution.Version + +import Control.Monad + +-- Type of FilePath. +data PathKind + = PathKindFile + | PathKindDirectory + | PathKindGlob + deriving (Eq) + +-- | .cabal field we are referring to. As now it is just a synonym to help +-- reading the code, in the future it might take advantage of typification +-- in Cabal-syntax. +type CabalField = String + +checkCustomField :: Monad m => (String, String) -> CheckM m () +checkCustomField (n, _) = + checkP + (any (not . isAscii) n) + (PackageDistInexcusable $ NonASCIICustomField [n]) + +-- ------------------------------------------------------------ +-- PVP types/functions +-- ------------------------------------------------------------ + +-- A library name / dependencies association list. Ultimately to be +-- fed to PVP check. +type AssocDep = (UnqualComponentName, [Dependency]) + +-- Convenience function to partition important dependencies by name. To +-- 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 +-- main library will not need to specify upper bounds on shared dependencies, +-- hence we do not return those). +-- +partitionDeps + :: Monad m + => [AssocDep] -- Possibly inherited dependencies, i.e. + -- dependencies from internal/main libs. + -> [UnqualComponentName] -- List of package names ("base", "Cabal"…) + -> [Dependency] -- Dependencies to check. + -> CheckM m ([Dependency], [Dependency]) +partitionDeps ads ns ds = do + -- Shared dependencies from “intra .cabal” libraries. + let + -- names of our dependencies + dqs = map unqualName ds + -- shared targets that match + fads = filter (flip elem dqs . fst) ads + -- the names of such targets + inNam = nub $ map fst fads :: [UnqualComponentName] + -- the dependencies of such targets + inDep = concatMap snd fads :: [Dependency] + + -- We exclude from checks: + -- 1. dependencies which are shared with main library / a + -- sublibrary; and of course + -- 2. the names of main library / sub libraries themselves. + -- + -- So in myPackage.cabal + -- library + -- build-depends: text < 5 + -- ⁝ + -- build-depends: myPackage, ← no warning, internal + -- text, ← no warning, inherited + -- monadacme ← warning! + let fFun d = + notElem (unqualName d) inNam + && notElem + (unqualName d) + (map unqualName inDep) + ds' = filter fFun ds + + return $ partition (flip elem ns . unqualName) ds' + where + -- Return *sublibrary* name if exists (internal), + -- otherwise package name. + unqualName :: Dependency -> UnqualComponentName + unqualName (Dependency n _ nel) = + case head (toNonEmpty nel) of + (LSubLibName ln) -> ln + _ -> packageNameToUnqualComponentName n + +-- PVP dependency check (one warning message per dependency, usually +-- for important dependencies like base). +checkPVP + :: Monad m + => (String -> PackageCheck) -- Warn message dependend on name + -- (e.g. "base", "Cabal"). + -> [Dependency] + -> CheckM m () +checkPVP ckf ds = do + let ods = checkPVPPrim ds + mapM_ (tellP . ckf . unPackageName . depPkgName) ods + +-- PVP dependency check for a list of dependencies. Some code duplication +-- is sadly needed to provide more ergonimic error messages. +checkPVPs + :: Monad m + => ( [String] + -> PackageCheck -- Grouped error message, depends on a + -- set of names. + ) + -> [Dependency] -- Deps to analyse. + -> CheckM m () +checkPVPs cf ds + | null ns = return () + | otherwise = tellP (cf ns) + where + ods = checkPVPPrim ds + ns = map (unPackageName . depPkgName) ods + +-- Returns dependencies without upper bounds. +checkPVPPrim :: [Dependency] -> [Dependency] +checkPVPPrim ds = filter withoutUpper ds + where + withoutUpper :: Dependency -> Bool + withoutUpper (Dependency _ ver _) = not . hasUpperBound $ ver diff --git a/src/Distribution/PackageDescription/Check/Conditional.hs b/src/Distribution/PackageDescription/Check/Conditional.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/PackageDescription/Check/Conditional.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Distribution.PackageDescription.Check.Conditional +-- Copyright : Lennart Kolmodin 2008, Francesco Ariis 2023 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Checks on conditional targets (libraries, executables, etc. that are +-- still inside a CondTree and related checks that can only be performed +-- here (variables, duplicated modules). +module Distribution.PackageDescription.Check.Conditional + ( checkCondTarget + , checkDuplicateModules + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Compiler +import Distribution.ModuleName (ModuleName) +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Check.Monad +import Distribution.System + +import qualified Data.Map as Map + +import Control.Monad + +-- As a prerequisite to some checks, we transform a target CondTree into +-- a CondTree of “target + useful context”. +-- This is slightly clearer, is easier to walk without resorting to +-- list comprehensions, allows us in the future to apply some sensible +-- “optimisations” to checks (exclusive branches, etc.). + +-- | @nf@ function is needed to appropriately name some targets which need +-- to be spoonfed (otherwise name appears as ""). +initTargetAnnotation + :: Monoid a + => (UnqualComponentName -> a -> a) -- Naming function for targets. + -> UnqualComponentName + -> TargetAnnotation a +initTargetAnnotation nf n = TargetAnnotation (nf n mempty) False + +-- | We “build up” target from various slices. +updateTargetAnnotation + :: Monoid a + => a -- A target (lib, exe, test, …) + -> TargetAnnotation a + -> TargetAnnotation a +updateTargetAnnotation t ta = ta{taTarget = taTarget ta <> t} + +-- | Before walking a target 'CondTree', we need to annotate it with +-- information relevant to the checks (read 'TaraAnn' and 'checkCondTarget' +-- doc for more info). +annotateCondTree + :: forall a + . (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) = + let ta' = updateTargetAnnotation a ta + bs' = map (annotateBranch ta') bs + bs'' = crossAnnotateBranches defTrueFlags bs' + in CondNode ta' c bs'' + where + annotateBranch + :: TargetAnnotation a + -> CondBranch ConfVar [Dependency] a + -> CondBranch + ConfVar + [Dependency] + (TargetAnnotation a) + annotateBranch wta (CondBranch k t mf) = + let uf = isPkgFlagCond k + wta' = wta{taPackageFlag = taPackageFlag wta || uf} + atf = annotateCondTree fs + in CondBranch + k + (atf wta' t) + (atf wta <$> mf) + -- Note how we are passing the *old* wta + -- in the `else` branch, since we are not + -- under that flag. + + -- We only want to pick up variables that are flags and that are + -- \*off* by default. + isPkgFlagCond :: Condition ConfVar -> Bool + isPkgFlagCond (Lit _) = False + isPkgFlagCond (Var (PackageFlag f)) = elem f defOffFlags + isPkgFlagCond (Var _) = False + isPkgFlagCond (CNot cn) = not (isPkgFlagCond cn) + isPkgFlagCond (CAnd ca cb) = isPkgFlagCond ca || isPkgFlagCond cb + isPkgFlagCond (COr ca cb) = isPkgFlagCond ca && isPkgFlagCond cb + + -- Package flags that are off by default *and* that are manual. + defOffFlags = + map flagName $ + filter + ( \f -> + not (flagDefault f) + && flagManual f + ) + fs + + defTrueFlags :: [PackageFlag] + defTrueFlags = filter flagDefault fs + +-- Propagate contextual information in CondTree branches. This is +-- needed as CondTree is a rosetree and not a binary tree. +crossAnnotateBranches + :: forall a + . (Eq a, Monoid a) + => [PackageFlag] -- `default: true` flags. + -> [CondBranch ConfVar [Dependency] (TargetAnnotation a)] + -> [CondBranch ConfVar [Dependency] (TargetAnnotation a)] +crossAnnotateBranches fs bs = map crossAnnBranch bs + where + crossAnnBranch + :: CondBranch ConfVar [Dependency] (TargetAnnotation a) + -> CondBranch ConfVar [Dependency] (TargetAnnotation a) + crossAnnBranch wr = + let + rs = filter (/= wr) bs + ts = mapMaybe realiseBranch rs + in + updateTargetAnnBranch (mconcat ts) wr + + realiseBranch :: CondBranch ConfVar [Dependency] (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 + + updateTargetAnnBranch + :: a + -> CondBranch ConfVar [Dependency] (TargetAnnotation a) + -> CondBranch ConfVar [Dependency] (TargetAnnotation a) + updateTargetAnnBranch a (CondBranch k t mt) = + let updateTargetAnnTree (CondNode ka c wbs) = + (CondNode (updateTargetAnnotation a ka) c wbs) + in CondBranch k (updateTargetAnnTree t) (updateTargetAnnTree <$> mt) + +-- | A conditional target is a library, exe, benchmark etc., destructured +-- in a CondTree. Traversing method: we render the branches, pass a +-- relevant context, collect checks. +checkCondTarget + :: forall m a + . (Monad m, Eq a, Monoid a) + => [PackageFlag] -- User flags. + -> (a -> CheckM m ()) -- Check function (a = target). + -> (UnqualComponentName -> a -> a) + -- Naming function (some targets + -- need to have their name + -- spoonfed to them. + -> (UnqualComponentName, CondTree ConfVar [Dependency] a) + -- Target name/condtree. + -> CheckM m () +checkCondTarget fs cf nf (unqualName, ct) = + wTree $ annotateCondTree fs (initTargetAnnotation nf unqualName) ct + where + -- Walking the tree. Remember that CondTree is not a binary + -- tree but a /rose/tree. + wTree + :: CondTree ConfVar [Dependency] (TargetAnnotation a) + -> CheckM m () + 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 + -- cases; a more precise way would be to check incompatibility + -- among simple branches conditions (or introduce a principled + -- `cond` construct in `.cabal` files. + | all isSimple bs = do + localCM (initCheckCtx ta) (cf $ taTarget ta) + mapM_ wBranch bs + -- If there are T/F conditions, there is no need to check + -- the intermediate 'TargetAnnotation' too. + | otherwise = do + mapM_ wBranch bs + + isSimple + :: CondBranch ConfVar [Dependency] (TargetAnnotation a) + -> Bool + isSimple (CondBranch _ _ Nothing) = True + isSimple (CondBranch _ _ (Just _)) = False + + wBranch + :: CondBranch ConfVar [Dependency] (TargetAnnotation a) + -> CheckM m () + wBranch (CondBranch k t mf) = do + checkCondVars k + wTree t + maybe (return ()) wTree mf + +-- | Condvar checking (misspelled OS in if conditions, etc). +checkCondVars :: Monad m => Condition ConfVar -> CheckM m () +checkCondVars cond = + let (_, vs) = simplifyCondition cond (\v -> Left v) + in -- Using simplifyCondition is convenient and correct, + -- if checks become more complex we can always walk + -- 'Condition'. + mapM_ vcheck vs + where + vcheck :: Monad m => ConfVar -> CheckM m () + vcheck (OS (OtherOS os)) = + tellP (PackageDistInexcusable $ UnknownOS [os]) + vcheck (Arch (OtherArch arch)) = + tellP (PackageDistInexcusable $ UnknownArch [arch]) + vcheck (Impl (OtherCompiler os) _) = + tellP (PackageDistInexcusable $ UnknownCompiler [os]) + vcheck _ = return () + +-- Checking duplicated modules cannot unfortunately be done in the +-- “tree checking”. This is because of the monoidal instance in some targets, +-- where e.g. merged dependencies are `nub`’d, hence losing information for +-- this particular check. +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) + 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 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 = + foldCondTree + Map.empty + (\(_, v) -> Map.fromListWith sumPair . map (\x -> (x, (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 [] diff --git a/src/Distribution/PackageDescription/Check/Monad.hs b/src/Distribution/PackageDescription/Check/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/PackageDescription/Check/Monad.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Distribution.PackageDescription.Check.Monad +-- Copyright : Francesco Ariis 2022 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Primitives for package checking: check types and monadic interface. +-- Having these primitives in a different module allows us to appropriately +-- limit/manage the interface to suit checking needs. +module Distribution.PackageDescription.Check.Monad + ( -- * Types and constructors + CheckM (..) + , execCheckM + , CheckInterface (..) + , CheckPackageContentOps (..) + , CheckPreDistributionOps (..) + , TargetAnnotation (..) + , PackageCheck (..) + , CheckExplanation (..) + , CEType (..) + , WarnLang (..) + , CheckCtx (..) + , pristineCheckCtx + , initCheckCtx + , PNames (..) + + -- * Operations + , ppPackageCheck + , isHackageDistError + , asksCM + , localCM + , checkP + , checkPkg + , liftInt + , tellP + , checkSpecVer + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion (CabalSpecVersion) +import Distribution.Package (packageName) +import Distribution.PackageDescription.Check.Warning +import Distribution.Simple.BuildToolDepends (desugarBuildToolSimple) +import Distribution.Simple.Glob (Glob, GlobResult) +import Distribution.Types.ExeDependency (ExeDependency) +import Distribution.Types.GenericPackageDescription +import Distribution.Types.LegacyExeDependency (LegacyExeDependency) +import Distribution.Types.PackageDescription (package, specVersion) +import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.UnqualComponentName + +import qualified Control.Monad.Reader as Reader +import qualified Control.Monad.Trans.Class as Trans +import qualified Control.Monad.Writer as Writer +import qualified Data.ByteString.Lazy as BS +import qualified Data.Set as Set + +import Control.Monad + +-- Monadic interface for for Distribution.PackageDescription.Check. +-- +-- Monadic checking allows us to have a fine grained control on checks +-- (e.g. omitting warning checks in certain situations). + +-- * Interfaces + +-- + +-- | Which interface to we have available/should we use? (to perform: pure +-- checks, package checks, pre-distribution checks.) +data CheckInterface m = CheckInterface + { ciPureChecks :: Bool + , -- Perform pure checks? + ciPackageOps :: Maybe (CheckPackageContentOps m) + , -- If you want to perform package contents + -- checks, provide an interface. + ciPreDistOps :: Maybe (CheckPreDistributionOps m) + -- If you want to work-tree checks, provide + -- an interface. + } + +-- | A record of operations needed to check the contents of packages. +-- Abstracted over `m` to provide flexibility (could be IO, a .tar.gz +-- file, etc). +data CheckPackageContentOps m = CheckPackageContentOps + { doesFileExist :: FilePath -> m Bool + , doesDirectoryExist :: FilePath -> m Bool + , getDirectoryContents :: FilePath -> m [FilePath] + , getFileContents :: FilePath -> m BS.ByteString + } + +-- | A record of operations needed to check contents *of the work tree* +-- (compare it with 'CheckPackageContentOps'). This is still `m` abstracted +-- in case in the future we can obtain the same infos other than from IO +-- (e.g. a VCS work tree). +data CheckPreDistributionOps m = CheckPreDistributionOps + { runDirFileGlobM :: FilePath -> Glob -> m [GlobResult FilePath] + , getDirectoryContentsM :: FilePath -> m [FilePath] + } + +-- | Context to perform checks (will be the Reader part in your monad). +data CheckCtx m = CheckCtx + { ccInterface :: CheckInterface m + , -- Interface for checks. + + -- Contextual infos for checks. + ccFlag :: Bool + , -- Are we under a user flag? + + -- Convenience bits that we prefer to carry + -- in our Reader monad instead of passing it + -- via ->, as they are often useful and often + -- in deeply nested places in the GPD tree. + ccSpecVersion :: CabalSpecVersion + , -- Cabal version. + ccDesugar :: LegacyExeDependency -> Maybe ExeDependency + , -- A desugaring function from + -- Distribution.Simple.BuildToolDepends + -- (desugarBuildToolSimple). Again since it + -- eats PackageName and a list of executable + -- names, it is more convenient to pass it + -- via Reader. + ccNames :: PNames + -- Various names (id, libs, execs, tests, + -- benchs), convenience. + } + +-- | 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 + -> GenericPackageDescription + -> CheckCtx m +pristineCheckCtx ci gpd = + let ens = map fst (condExecutables gpd) + in CheckCtx + ci + False + (specVersion . packageDescription $ gpd) + (desugarBuildToolSimple (packageName gpd) ens) + (initPNames gpd) + +-- | 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 t c = c{ccFlag = taPackageFlag t} + +-- | 'TargetAnnotation' collects contextual information on the target we are +-- realising: a buildup of the various slices of the target (a library, +-- executable, etc. — is a monoid) whether we are under an off-by-default +-- package flag. +data TargetAnnotation a = TargetAnnotation + { taTarget :: a + , -- The target we are building (lib, exe, etc.) + taPackageFlag :: Bool + -- Whether we are under an off-by-default package flag. + } + deriving (Show, Eq, Ord) + +-- | A collection os names, shipping tuples around is annoying. +data PNames = PNames + { pnPackageId :: PackageIdentifier -- Package ID… + -- … and a bunch of lib, exe, test, bench names. + , pnSubLibs :: [UnqualComponentName] + , pnExecs :: [UnqualComponentName] + , pnTests :: [UnqualComponentName] + , pnBenchs :: [UnqualComponentName] + } + +-- | Init names from a GPD. +initPNames :: GenericPackageDescription -> PNames +initPNames gpd = + PNames + (package . packageDescription $ gpd) + (map fst $ condSubLibraries gpd) + (map fst $ condExecutables gpd) + (map fst $ condTestSuites gpd) + (map fst $ condBenchmarks gpd) + +-- | Check monad, carrying a context, collecting 'PackageCheck's. +-- Using Set for writer (automatic sort) is useful for output stability +-- on different platforms. +-- It is nothing more than a monad stack with Reader+Writer. +-- `m` is the monad that could be used to do package/file checks. +newtype CheckM m a + = CheckM + ( Reader.ReaderT + (CheckCtx m) + ( Writer.WriterT + (Set.Set PackageCheck) + m + ) + a + ) + deriving (Functor, Applicative, Monad) + +-- Not autoderiving MonadReader and MonadWriter gives us better +-- control on the interface of CheckM. + +-- | Execute a CheckM monad, leaving `m [PackageCheck]` which can be +-- run in the appropriate `m` environment (IO, pure, …). +execCheckM :: Monad m => CheckM m () -> CheckCtx m -> m [PackageCheck] +execCheckM (CheckM rwm) ctx = + let wm = Reader.runReaderT rwm ctx + m = Writer.execWriterT wm + in Set.toList <$> m + +-- | As 'checkP' but always succeeding. +tellP :: Monad m => PackageCheck -> CheckM m () +tellP = checkP True + +-- | Add a package warning withoutu performing any check. +tellCM :: Monad m => PackageCheck -> CheckM m () +tellCM ck = do + cf <- asksCM ccFlag + unless + (cf && canSkip ck) + -- Do not push this message if the warning is not severe *and* + -- we are under a non-default package flag. + (CheckM . Writer.tell $ Set.singleton ck) + where + -- Check if we can skip this error if we are under a + -- non-default user flag. + canSkip :: PackageCheck -> Bool + canSkip wck = not (isSevereLocal wck) || isErrAllowable wck + + isSevereLocal :: PackageCheck -> Bool + isSevereLocal (PackageBuildImpossible _) = True + isSevereLocal (PackageBuildWarning _) = True + isSevereLocal (PackageDistSuspicious _) = False + isSevereLocal (PackageDistSuspiciousWarn _) = False + isSevereLocal (PackageDistInexcusable _) = True + + -- 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 + (WErrorUnneeded _) -> True + (JUnneeded _) -> True + (FDeferTypeErrorsUnneeded _) -> True + (DynamicUnneeded _) -> True + (ProfilingUnneeded _) -> True + _ -> False + +-- | Lift a monadic computation to CM. +liftCM :: Monad m => m a -> CheckM m a +liftCM ma = CheckM . Trans.lift . Trans.lift $ ma + +-- | Lift a monadic action via an interface. Missing interface, no action. +liftInt + :: forall m i + . Monad m + => (CheckInterface m -> Maybe (i m)) + -- Check interface, may or may not exist. If it does not, + -- the check simply will not be performed. + -> (i m -> m [PackageCheck]) + -- The actual check to perform with the above-mentioned + -- interface. Note the [] around `PackageCheck`, this is + -- meant to perform/collect multiple checks. + -> CheckM m () +liftInt acc f = do + ops <- asksCM (acc . ccInterface) + maybe (return ()) l ops + where + l :: i m -> CheckM m () + l wi = do + cks <- liftCM (f wi) + mapM_ (check True) cks + +-- | Most basic check function. You do not want to export this, rather export +-- “smart” functions (checkP, checkPkg) to enforce relevant properties. +check + :: Monad m + => Bool -- Is there something to warn about? + -> PackageCheck -- Warn message. + -> CheckM m () +check True ck = tellCM ck +check False _ = return () + +-- | Pure check not requiring IO or other interfaces. +checkP + :: Monad m + => Bool -- Is there something to warn about? + -> PackageCheck -- Warn message. + -> CheckM m () +checkP b ck = do + pb <- asksCM (ciPureChecks . ccInterface) + when pb (check b ck) + +-- Check with 'CheckPackageContentOps' operations (i.e. package file checks). +-- +checkPkg + :: forall m + . Monad m + => (CheckPackageContentOps m -> m Bool) + -- Actual check to perform with CPC interface + -> PackageCheck + -- Warn message. + -> CheckM m () +checkPkg f ck = checkInt ciPackageOps f ck + +-- | Generalised version for checks that need an interface. We pass a Reader +-- accessor to such interface ‘i’, a check function. +checkIntDep + :: forall m i + . Monad m + => (CheckInterface m -> Maybe (i m)) + -- Check interface, may or may not exist. If it does not, + -- the check simply will not be performed. + -> (i m -> m (Maybe PackageCheck)) + -- The actual check to perform (single check). + -> CheckM m () +checkIntDep acc mck = do + po <- asksCM (acc . ccInterface) + maybe (return ()) (lc . mck) po + where + lc :: Monad m => m (Maybe PackageCheck) -> CheckM m () + lc wmck = do + b <- liftCM wmck + maybe (return ()) (check True) b + +-- | As 'checkIntDep', but 'PackageCheck' does not depend on the monadic +-- computation. +checkInt + :: forall m i + . Monad m + => (CheckInterface m -> Maybe (i m)) + -- Where to get the interface (if available). + -> (i m -> m Bool) + -- Condition to check + -> PackageCheck + -- Warning message to add (does not depend on `m`). + -> CheckM m () +checkInt acc f ck = + checkIntDep + acc + ( \ops -> do + b <- f ops + if b + then return $ Just ck + else return Nothing + ) + +-- | `local` (from Control.Monad.Reader) for CheckM. +localCM :: Monad m => (CheckCtx m -> CheckCtx m) -> CheckM m () -> CheckM m () +localCM cf (CheckM im) = CheckM $ Reader.local cf im + +-- | `ask` (from Control.Monad.Reader) for CheckM. +asksCM :: Monad m => (CheckCtx m -> a) -> CheckM m a +asksCM f = CheckM $ Reader.asks f + +-- As checkP, but with an additional condition: the check will be performed +-- only if our spec version is < `vc`. +checkSpecVer + :: Monad m + => CabalSpecVersion -- Perform this check only if our + -- spec version is < than this. + -> Bool -- Check condition. + -> PackageCheck -- Check message. + -> CheckM m () +checkSpecVer vc cond c = do + vp <- asksCM ccSpecVersion + unless (vp >= vc) (checkP cond c) diff --git a/src/Distribution/PackageDescription/Check/Paths.hs b/src/Distribution/PackageDescription/Check/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/PackageDescription/Check/Paths.hs @@ -0,0 +1,417 @@ +-- | +-- Module : Distribution.PackageDescription.Check.Paths +-- Copyright : Lennart Kolmodin 2008, Francesco Ariis 2023 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Functions to check filepaths, directories, globs, etc. +module Distribution.PackageDescription.Check.Paths + ( checkGlob + , checkPath + , fileExtensionSupportedLanguage + , isGoodRelativeDirectoryPath + , isGoodRelativeFilePath + , isGoodRelativeGlob + , isInsideDist + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.PackageDescription.Check.Common +import Distribution.PackageDescription.Check.Monad +import Distribution.Simple.CCompiler +import Distribution.Simple.Glob + ( Glob + , explainGlobSyntaxError + , isRecursiveInRoot + , parseFileGlob + ) +import Distribution.Simple.Utils hiding (findPackageDesc, notice) +import System.FilePath (splitDirectories, splitPath, takeExtension) + +import qualified System.FilePath.Windows as FilePath.Windows (isValid) + +fileExtensionSupportedLanguage :: FilePath -> Bool +fileExtensionSupportedLanguage path = + isHaskell || isC + where + extension = takeExtension path + isHaskell = extension `elem` [".hs", ".lhs"] + isC = isJust (filenameCDialect extension) + +-- Boolean: are absolute paths allowed? +checkPath + :: Monad m + => Bool -- Can be absolute path? + -> CabalField -- .cabal field that we are checking. + -> PathKind -- Path type. + -> FilePath -- Path. + -> CheckM m () +checkPath isAbs title kind path = do + checkP + (isOutsideTree path) + (PackageBuildWarning $ RelativeOutside title path) + checkP + (isInsideDist path) + (PackageDistInexcusable $ DistPoint (Just title) path) + checkPackageFileNamesWithGlob kind path + + -- Skip if "can be absolute path". + checkP + (not isAbs && isAbsoluteOnAnyPlatform path) + (PackageDistInexcusable $ AbsolutePath title path) + case grl path kind of + Just e -> + checkP + (not isAbs) + (PackageDistInexcusable $ BadRelativePath title path e) + Nothing -> return () + checkWindowsPath (kind == PathKindGlob) path + where + isOutsideTree wpath = case splitDirectories wpath of + ".." : _ -> True + "." : ".." : _ -> True + _ -> False + + -- These are not paths, but globs... + grl wfp PathKindFile = isGoodRelativeFilePath wfp + grl wfp PathKindGlob = isGoodRelativeGlob wfp + grl wfp PathKindDirectory = isGoodRelativeDirectoryPath wfp + +-- | Is a 'FilePath' inside `dist`, `dist-newstyle` and friends? +isInsideDist :: FilePath -> Bool +isInsideDist path = + case map lowercase (splitDirectories path) of + "dist" : _ -> True + "." : "dist" : _ -> True + "dist-newstyle" : _ -> True + "." : "dist-newstyle" : _ -> True + _ -> False + +checkPackageFileNamesWithGlob + :: Monad m + => PathKind + -> FilePath -- Filepath or possibly a glob pattern. + -> CheckM m () +checkPackageFileNamesWithGlob kind fp = do + checkWindowsPath (kind == PathKindGlob) fp + checkTarPath fp + +checkWindowsPath + :: Monad m + => Bool -- Is it a glob pattern? + -> FilePath -- Path. + -> CheckM m () +checkWindowsPath isGlob path = + checkP + (not . FilePath.Windows.isValid $ escape isGlob path) + (PackageDistInexcusable $ InvalidOnWin [path]) + where + -- Force a relative name to catch invalid file names like "f:oo" which + -- otherwise parse as file "oo" in the current directory on the 'f' drive. + escape :: Bool -> String -> String + escape wisGlob wpath = + (".\\" ++) + -- Glob paths will be expanded before being dereferenced, so asterisks + -- shouldn't count against them. + $ + map (\c -> if c == '*' && wisGlob then 'x' else c) wpath + +-- | Check a file name is valid for the portable POSIX tar format. +-- +-- The POSIX tar format has a restriction on the length of file names. It is +-- unfortunately not a simple restriction like a maximum length. The exact +-- restriction is that either the whole path be 100 characters or less, or it +-- be possible to split the path on a directory separator such that the first +-- part is 155 characters or less and the second part 100 characters or less. +checkTarPath :: Monad m => FilePath -> CheckM m () +checkTarPath path + | length path > 255 = tellP longPath + | otherwise = case pack nameMax (reverse (splitPath path)) of + Left err -> tellP err + Right [] -> return () + Right (h : rest) -> case pack prefixMax remainder of + Left err -> tellP err + Right [] -> return () + Right (_ : _) -> tellP noSplit + where + -- drop the '/' between the name and prefix: + remainder = safeInit h : rest + where + nameMax, prefixMax :: Int + nameMax = 100 + prefixMax = 155 + + pack _ [] = Left emptyName + pack maxLen (c : cs) + | n > maxLen = Left longName + | otherwise = Right (pack' maxLen n cs) + where + n = length c + + pack' maxLen n (c : cs) + | n' <= maxLen = pack' maxLen n' cs + where + n' = n + length c + pack' _ _ cs = cs + + longPath = PackageDistInexcusable (FilePathTooLong path) + longName = PackageDistInexcusable (FilePathNameTooLong path) + noSplit = PackageDistInexcusable (FilePathSplitTooLong path) + emptyName = PackageDistInexcusable FilePathEmpty + +-- `checkGlob` checks glob patterns and returns good ones for further +-- processing. +checkGlob + :: Monad m + => CabalField -- .cabal field we are checking. + -> FilePath -- glob filepath pattern + -> CheckM m (Maybe Glob) +checkGlob title pat = do + ver <- asksCM ccSpecVersion + + -- Glob sanity check. + case parseFileGlob ver pat of + Left e -> do + tellP + ( PackageDistInexcusable $ + GlobSyntaxError title (explainGlobSyntaxError pat e) + ) + return Nothing + Right wglob -> do + -- \* Miscellaneous checks on sane glob. + -- Checks for recursive glob in root. + checkP + (isRecursiveInRoot wglob) + ( PackageDistSuspiciousWarn $ + RecursiveGlobInRoot title pat + ) + return (Just wglob) + +-- | Whether a path is a good relative path. We aren't worried about perfect +-- cross-platform compatibility here; this function just checks the paths in +-- the (local) @.cabal@ file, while only Hackage needs the portability. +-- +-- >>> let test fp = putStrLn $ show (isGoodRelativeDirectoryPath fp) ++ "; " ++ show (isGoodRelativeFilePath fp) +-- +-- Note that "foo./bar.hs" would be invalid on Windows. +-- +-- >>> traverse_ test ["foo/bar/quu", "a/b.hs", "foo./bar.hs"] +-- Nothing; Nothing +-- Nothing; Nothing +-- Nothing; Nothing +-- +-- Trailing slash is not allowed for files, for directories it is ok. +-- +-- >>> test "foo/" +-- Nothing; Just "trailing slash" +-- +-- Leading @./@ is fine, but @.@ and @./@ are not valid files. +-- +-- >>> traverse_ test [".", "./", "./foo/bar"] +-- Nothing; Just "trailing dot segment" +-- Nothing; Just "trailing slash" +-- Nothing; Nothing +-- +-- Lastly, not good file nor directory cases: +-- +-- >>> traverse_ test ["", "/tmp/src", "foo//bar", "foo/.", "foo/./bar", "foo/../bar"] +-- Just "empty path"; Just "empty path" +-- Just "posix absolute path"; Just "posix absolute path" +-- Just "empty path segment"; Just "empty path segment" +-- Just "trailing same directory segment: ."; Just "trailing same directory segment: ." +-- Just "same directory segment: ."; Just "same directory segment: ." +-- Just "parent directory segment: .."; Just "parent directory segment: .." +-- +-- For the last case, 'isGoodRelativeGlob' doesn't warn: +-- +-- >>> traverse_ (print . isGoodRelativeGlob) ["foo/../bar"] +-- Just "parent directory segment: .." +isGoodRelativeFilePath :: FilePath -> Maybe String +isGoodRelativeFilePath = state0 + where + -- initial state + state0 [] = Just "empty path" + state0 (c : cs) + | c == '.' = state1 cs + | c == '/' = Just "posix absolute path" + | otherwise = state5 cs + + -- after initial . + state1 [] = Just "trailing dot segment" + state1 (c : cs) + | c == '.' = state4 cs + | c == '/' = state2 cs + | otherwise = state5 cs + + -- after ./ or after / between segments + state2 [] = Just "trailing slash" + state2 (c : cs) + | c == '.' = state3 cs + | c == '/' = Just "empty path segment" + | otherwise = state5 cs + + -- after non-first segment's . + state3 [] = Just "trailing same directory segment: ." + state3 (c : cs) + | c == '.' = state4 cs + | c == '/' = Just "same directory segment: ." + | otherwise = state5 cs + + -- after .. + state4 [] = Just "trailing parent directory segment: .." + state4 (c : cs) + | c == '.' = state5 cs + | c == '/' = Just "parent directory segment: .." + | otherwise = state5 cs + + -- in a segment which is ok. + state5 [] = Nothing + state5 (c : cs) + | c == '.' = state5 cs + | c == '/' = state2 cs + | otherwise = state5 cs + +-- | See 'isGoodRelativeFilePath'. +-- +-- This is barebones function. We check whether the glob is a valid file +-- by replacing stars @*@ with @x@ses. +isGoodRelativeGlob :: FilePath -> Maybe String +isGoodRelativeGlob = isGoodRelativeFilePath . map f + where + f '*' = 'x' + f c = c + +-- | See 'isGoodRelativeFilePath'. +isGoodRelativeDirectoryPath :: FilePath -> Maybe String +isGoodRelativeDirectoryPath = state0 + where + -- initial state + state0 [] = Just "empty path" + state0 (c : cs) + | c == '.' = state5 cs + | c == '/' = Just "posix absolute path" + | otherwise = state4 cs + + -- after initial ./ or after / between segments + state1 [] = Nothing + state1 (c : cs) + | c == '.' = state2 cs + | c == '/' = Just "empty path segment" + | otherwise = state4 cs + + -- after non-first setgment's . + state2 [] = Just "trailing same directory segment: ." + state2 (c : cs) + | c == '.' = state3 cs + | c == '/' = Just "same directory segment: ." + | otherwise = state4 cs + + -- after .. + state3 [] = Just "trailing parent directory segment: .." + state3 (c : cs) + | c == '.' = state4 cs + | c == '/' = Just "parent directory segment: .." + | otherwise = state4 cs + + -- in a segment which is ok. + state4 [] = Nothing + state4 (c : cs) + | c == '.' = state4 cs + | c == '/' = state1 cs + | otherwise = state4 cs + + -- after initial . + state5 [] = Nothing -- "." + state5 (c : cs) + | c == '.' = state3 cs + | c == '/' = state1 cs + | otherwise = state4 cs + +-- [Note: Good relative paths] +-- +-- Using @kleene@ we can define an extended regex: +-- +-- @ +-- import Algebra.Lattice +-- import Kleene +-- import Kleene.ERE (ERE (..), intersections) +-- +-- data C = CDot | CSlash | CChar +-- deriving (Eq, Ord, Enum, Bounded, Show) +-- +-- reservedR :: ERE C +-- reservedR = notChar CSlash +-- +-- pathPieceR :: ERE C +-- pathPieceR = intersections +-- [ plus reservedR +-- , ERENot (string [CDot]) +-- , ERENot (string [CDot,CDot]) +-- ] +-- +-- filePathR :: ERE C +-- filePathR = optional (string [CDot, CSlash]) <> pathPieceR <> star (char CSlash <> pathPieceR) +-- +-- dirPathR :: ERE C +-- dirPathR = (char CDot \/ filePathR) <> optional (char CSlash) +-- +-- plus :: ERE C -> ERE C +-- plus r = r <> star r +-- +-- optional :: ERE C -> ERE C +-- optional r = mempty \/ r +-- @ +-- +-- Results in following state machine for @filePathR@ +-- +-- @ +-- 0 -> \x -> if +-- | x <= CDot -> 1 +-- | otherwise -> 5 +-- 1 -> \x -> if +-- | x <= CDot -> 4 +-- | x <= CSlash -> 2 +-- | otherwise -> 5 +-- 2 -> \x -> if +-- | x <= CDot -> 3 +-- | otherwise -> 5 +-- 3 -> \x -> if +-- | x <= CDot -> 4 +-- | otherwise -> 5 +-- 4 -> \x -> if +-- | x <= CDot -> 5 +-- | otherwise -> 5 +-- 5+ -> \x -> if +-- | x <= CDot -> 5 +-- | x <= CSlash -> 2 +-- | otherwise -> 5 +-- @ +-- +-- and @dirPathR@: +-- +-- @ +-- 0 -> \x -> if +-- | x <= CDot -> 5 +-- | otherwise -> 4 +-- 1+ -> \x -> if +-- | x <= CDot -> 2 +-- | otherwise -> 4 +-- 2 -> \x -> if +-- | x <= CDot -> 3 +-- | otherwise -> 4 +-- 3 -> \x -> if +-- | x <= CDot -> 4 +-- | otherwise -> 4 +-- 4+ -> \x -> if +-- | x <= CDot -> 4 +-- | x <= CSlash -> 1 +-- | otherwise -> 4 +-- 5+ -> \x -> if +-- | x <= CDot -> 3 +-- | x <= CSlash -> 1 +-- | otherwise -> 4 +-- @ diff --git a/src/Distribution/PackageDescription/Check/Target.hs b/src/Distribution/PackageDescription/Check/Target.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/PackageDescription/Check/Target.hs @@ -0,0 +1,1060 @@ +-- | +-- Module : Distribution.PackageDescription.Check.Target +-- Copyright : Lennart Kolmodin 2008, Francesco Ariis 2023 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Fully-realised target (library, executable, …) checking functions. +module Distribution.PackageDescription.Check.Target + ( checkLibrary + , checkForeignLib + , checkExecutable + , checkTestSuite + , checkBenchmark + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion +import Distribution.Compat.Lens +import Distribution.Compiler +import Distribution.ModuleName (ModuleName) +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Check.Common +import Distribution.PackageDescription.Check.Monad +import Distribution.PackageDescription.Check.Paths +import Distribution.Pretty (prettyShow) +import Distribution.Simple.BuildPaths + ( autogenPackageInfoModuleName + , autogenPathsModuleName + ) +import Distribution.Simple.Utils hiding (findPackageDesc, notice) +import Distribution.Types.PackageName.Magic +import Distribution.Utils.Path +import Distribution.Version +import Language.Haskell.Extension +import System.FilePath (takeExtension) + +import Control.Monad + +import qualified Distribution.Types.BuildInfo.Lens as L + +checkLibrary + :: Monad m + => Bool -- Is this a sublibrary? + -> [AssocDep] -- “Inherited” dependencies for PVP checks. + -> Library + -> CheckM m () +checkLibrary + isSub + ads + lib@( Library + libName_ + _exposedModules_ + reexportedModules_ + signatures_ + _libExposed_ + _libVisibility_ + libBuildInfo_ + ) = do + checkP + (libName_ == LMainLibName && isSub) + (PackageBuildImpossible UnnamedInternal) + -- TODO: bogus if a required-signature was passed through. + checkP + (null (explicitLibModules lib) && null reexportedModules_) + (PackageDistSuspiciousWarn (NoModulesExposed libName_)) + -- TODO parse-caught check, can safely remove. + checkSpecVer + CabalSpecV2_0 + (not . null $ signatures_) + (PackageDistInexcusable SignaturesCabal2) + -- autogen/includes checks. + checkP + ( not $ + all + (flip elem (explicitLibModules lib)) + (libModulesAutogen lib) + ) + (PackageBuildImpossible AutogenNotExposed) + -- check that all autogen-includes appear on includes or + -- install-includes. + checkP + ( not $ + all + (flip elem (allExplicitIncludes lib)) + (view L.autogenIncludes lib) + ) + $ (PackageBuildImpossible AutogenIncludesNotIncluded) + + -- § Build infos. + checkBuildInfo + (CETLibrary libName_) + (explicitLibModules lib) + ads + libBuildInfo_ + + -- Feature checks. + -- check use of reexported-modules sections + checkSpecVer + CabalSpecV1_22 + (not . null $ reexportedModules_) + (PackageDistInexcusable CVReexported) + where + allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath] + allExplicitIncludes x = + view L.includes x + ++ view L.installIncludes x + +checkForeignLib :: Monad m => ForeignLib -> CheckM m () +checkForeignLib + ( ForeignLib + foreignLibName_ + _foreignLibType_ + _foreignLibOptions_ + foreignLibBuildInfo_ + _foreignLibVersionInfo_ + _foreignLibVersionLinux_ + _foreignLibModDefFile_ + ) = do + checkBuildInfo + (CETForeignLibrary foreignLibName_) + [] + [] + foreignLibBuildInfo_ + +checkExecutable + :: Monad m + => [AssocDep] -- “Inherited” dependencies for PVP checks. + -> Executable + -> CheckM m () +checkExecutable + ads + exe@( Executable + exeName_ + modulePath_ + _exeScope_ + buildInfo_ + ) = do + -- Target type/name (exe). + let cet = CETExecutable exeName_ + + -- § Exe specific checks + checkP + (null modulePath_) + (PackageBuildImpossible (NoMainIs exeName_)) + -- This check does not apply to scripts. + pid <- asksCM (pnPackageId . ccNames) + checkP + ( pid /= fakePackageId + && not (null modulePath_) + && not (fileExtensionSupportedLanguage $ modulePath_) + ) + (PackageBuildImpossible NoHsLhsMain) + + -- § Features check + checkSpecVer + CabalSpecV1_18 + ( fileExtensionSupportedLanguage modulePath_ + && takeExtension modulePath_ `notElem` [".hs", ".lhs"] + ) + (PackageDistInexcusable MainCCabal1_18) + + -- Alas exeModules ad exeModulesAutogen (exported from + -- Distribution.Types.Executable) take `Executable` as a parameter. + checkP + (not $ all (flip elem (exeModules exe)) (exeModulesAutogen exe)) + (PackageBuildImpossible $ AutogenNoOther cet) + checkP + ( not $ + all + (flip elem (view L.includes exe)) + (view L.autogenIncludes exe) + ) + (PackageBuildImpossible AutogenIncludesNotIncludedExe) + + -- § Build info checks. + checkBuildInfo cet [] ads buildInfo_ + +checkTestSuite + :: Monad m + => [AssocDep] -- “Inherited” dependencies for PVP checks. + -> TestSuite + -> CheckM m () +checkTestSuite + ads + ts@( TestSuite + testName_ + testInterface_ + testBuildInfo_ + _testCodeGenerators_ + ) = do + -- Target type/name (test). + let cet = CETTest testName_ + + -- § TS specific checks. + -- TODO caught by the parser, can remove safely + case testInterface_ of + TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> + tellP (PackageBuildWarning $ TestsuiteTypeNotKnown tt) + TestSuiteUnsupported tt -> + tellP (PackageBuildWarning $ TestsuiteNotSupported tt) + _ -> return () + checkP + mainIsWrongExt + (PackageBuildImpossible NoHsLhsMain) + checkP + ( not $ + all + (flip elem (testModules ts)) + (testModulesAutogen ts) + ) + (PackageBuildImpossible $ AutogenNoOther cet) + checkP + ( not $ + all + (flip elem (view L.includes ts)) + (view L.autogenIncludes ts) + ) + (PackageBuildImpossible AutogenIncludesNotIncludedExe) + + -- § Feature checks. + checkSpecVer + CabalSpecV1_18 + (mainIsNotHsExt && not mainIsWrongExt) + (PackageDistInexcusable MainCCabal1_18) + + -- § Build info checks. + checkBuildInfo cet [] ads testBuildInfo_ + where + mainIsWrongExt = + case testInterface_ of + TestSuiteExeV10 _ f -> not (fileExtensionSupportedLanguage f) + _ -> False + + mainIsNotHsExt = + case testInterface_ of + TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + +checkBenchmark + :: Monad m + => [AssocDep] -- “Inherited” dependencies for PVP checks. + -> Benchmark + -> CheckM m () +checkBenchmark + ads + bm@( Benchmark + benchmarkName_ + benchmarkInterface_ + benchmarkBuildInfo_ + ) = do + -- Target type/name (benchmark). + let cet = CETBenchmark benchmarkName_ + + -- § Interface & bm specific tests. + case benchmarkInterface_ of + BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> + tellP (PackageBuildWarning $ BenchmarkTypeNotKnown tt) + BenchmarkUnsupported tt -> + tellP (PackageBuildWarning $ BenchmarkNotSupported tt) + _ -> return () + checkP + mainIsWrongExt + (PackageBuildImpossible NoHsLhsMainBench) + + checkP + ( not $ + all + (flip elem (benchmarkModules bm)) + (benchmarkModulesAutogen bm) + ) + (PackageBuildImpossible $ AutogenNoOther cet) + + checkP + ( not $ + all + (flip elem (view L.includes bm)) + (view L.autogenIncludes bm) + ) + (PackageBuildImpossible AutogenIncludesNotIncludedExe) + + -- § BuildInfo checks. + checkBuildInfo cet [] ads benchmarkBuildInfo_ + where + -- Cannot abstract with similar function in checkTestSuite, + -- they are different. + mainIsWrongExt = + case benchmarkInterface_ of + BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + +-- ------------------------------------------------------------ +-- Build info +-- ------------------------------------------------------------ + +-- Check a great deal of things in buildInfo. +-- With 'checkBuildInfo' we cannot follow the usual “pattern match +-- everything” method, for the number of BuildInfo fields (almost 50) +-- but more importantly because accessing options, etc. is done +-- with functions from 'Distribution.Types.BuildInfo' (e.g. 'hcOptions'). +-- Duplicating the effort here means risk of diverging definitions for +-- little gain (most likely if a field is added to BI, the relevant +-- function will be tweaked in Distribution.Types.BuildInfo too). +checkBuildInfo + :: Monad m + => CEType -- Name and type of the target. + -> [ModuleName] -- Additional module names which cannot be + -- extracted from BuildInfo (mainly: exposed + -- library modules). + -> [AssocDep] -- Inherited “internal” (main lib, named + -- internal libs) dependencies. + -> BuildInfo + -> CheckM m () +checkBuildInfo cet ams ads bi = do + -- For the sake of clarity, we split che checks in various + -- (top level) functions, even if we are not actually going + -- deeper in the traversal. + + checkBuildInfoOptions (cet2bit cet) bi + checkBuildInfoPathsContent bi + checkBuildInfoPathsWellFormedness bi + + sv <- asksCM ccSpecVersion + checkBuildInfoFeatures bi sv + + checkAutogenModules ams bi + + -- PVP: we check for base and all other deps. + (ids, rds) <- + partitionDeps + ads + [mkUnqualComponentName "base"] + (mergeDependencies $ targetBuildDepends bi) + let ick = const (PackageDistInexcusable BaseNoUpperBounds) + rck = PackageDistSuspiciousWarn . MissingUpperBounds cet + checkPVP ick ids + unless + (isInternalTarget cet) + (checkPVPs rck rds) + + -- Custom fields well-formedness (ASCII). + mapM_ checkCustomField (customFieldsBI bi) + + -- Content. + mapM_ (checkLocalPathExist "extra-lib-dirs") (extraLibDirs bi) + mapM_ + (checkLocalPathExist "extra-lib-dirs-static") + (extraLibDirsStatic bi) + mapM_ + (checkLocalPathExist "extra-framework-dirs") + (extraFrameworkDirs bi) + mapM_ (checkLocalPathExist "include-dirs") (includeDirs bi) + mapM_ + (checkLocalPathExist "hs-source-dirs" . getSymbolicPath) + (hsSourceDirs bi) + +-- Well formedness of BI contents (no `Haskell2015`, no deprecated +-- extensions etc). +checkBuildInfoPathsContent :: Monad m => BuildInfo -> CheckM m () +checkBuildInfoPathsContent bi = do + mapM_ checkLang (allLanguages bi) + mapM_ checkExt (allExtensions bi) + 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) + mapM_ checkBTDep ds + where + checkLang :: Monad m => Language -> CheckM m () + checkLang (UnknownLanguage n) = + tellP (PackageBuildWarning (UnknownLanguages [n])) + checkLang _ = return () + + checkExt :: Monad m => Extension -> CheckM m () + checkExt (UnknownExtension n) + | n `elem` map prettyShow knownLanguages = + tellP (PackageBuildWarning (LanguagesAsExtension [n])) + | otherwise = + tellP (PackageBuildWarning (UnknownExtensions [n])) + checkExt n = do + let dss = filter (\(a, _) -> a == n) deprecatedExtensions + checkP + (not . null $ dss) + (PackageDistSuspicious $ DeprecatedExtensions dss) + + checkIntDep :: Monad m => Dependency -> CheckM m () + checkIntDep d@(Dependency name vrange _) = do + mpn <- + asksCM + ( packageNameToUnqualComponentName + . pkgName + . pnPackageId + . ccNames + ) + lns <- asksCM (pnSubLibs . ccNames) + pVer <- asksCM (pkgVersion . pnPackageId . ccNames) + let allLibNs = mpn : lns + when + ( mpn == packageNameToUnqualComponentName name + -- Make sure it is not a library with the + -- same name from another package. + && packageNameToUnqualComponentName name `elem` allLibNs + ) + ( checkP + (not $ pVer `withinRange` vrange) + (PackageBuildImpossible $ ImpossibleInternalDep [d]) + ) + + checkBTDep :: Monad m => ExeDependency -> CheckM m () + checkBTDep ed@(ExeDependency n name vrange) = do + exns <- asksCM (pnExecs . ccNames) + pVer <- asksCM (pkgVersion . pnPackageId . ccNames) + pNam <- asksCM (pkgName . pnPackageId . ccNames) + checkP + ( n == pNam + && name `notElem` exns -- internal + -- not present + ) + (PackageBuildImpossible $ MissingInternalExe [ed]) + when + (name `elem` exns) + ( checkP + (not $ pVer `withinRange` vrange) + (PackageBuildImpossible $ ImpossibleInternalExe [ed]) + ) + +-- Paths well-formedness check for BuildInfo. +checkBuildInfoPathsWellFormedness :: Monad m => BuildInfo -> CheckM m () +checkBuildInfoPathsWellFormedness bi = do + mapM_ (checkPath False "asm-sources" PathKindFile) (asmSources bi) + mapM_ (checkPath False "cmm-sources" PathKindFile) (cmmSources bi) + mapM_ (checkPath False "c-sources" PathKindFile) (cSources bi) + mapM_ (checkPath False "cxx-sources" PathKindFile) (cxxSources bi) + mapM_ (checkPath False "js-sources" PathKindFile) (jsSources bi) + mapM_ + (checkPath False "install-includes" PathKindFile) + (installIncludes bi) + mapM_ + (checkPath False "hs-source-dirs" PathKindDirectory . getSymbolicPath) + (hsSourceDirs bi) + -- Possibly absolute paths. + mapM_ (checkPath True "includes" PathKindFile) (includes bi) + mapM_ + (checkPath True "include-dirs" PathKindDirectory) + (includeDirs bi) + mapM_ + (checkPath True "extra-lib-dirs" PathKindDirectory) + (extraLibDirs bi) + mapM_ + (checkPath True "extra-lib-dirs-static" PathKindDirectory) + (extraLibDirsStatic bi) + mapM_ checkOptionPath (perCompilerFlavorToList $ options bi) + where + checkOptionPath + :: Monad m + => (CompilerFlavor, [FilePath]) + -> CheckM m () + checkOptionPath (GHC, paths) = + mapM_ + ( \path -> + checkP + (isInsideDist path) + (PackageDistInexcusable $ DistPoint Nothing path) + ) + paths + checkOptionPath _ = return () + +-- Checks for features that can be present in BuildInfo only with certain +-- CabalSpecVersion. +checkBuildInfoFeatures + :: Monad m + => BuildInfo + -> CabalSpecVersion + -> CheckM m () +checkBuildInfoFeatures bi sv = do + -- Default language can be used only w/ spec ≥ 1.10 + checkSpecVer + CabalSpecV1_10 + (isJust $ defaultLanguage bi) + (PackageBuildWarning CVDefaultLanguage) + -- CheckSpecVer sv. + checkP + ( sv >= CabalSpecV1_10 + && sv < CabalSpecV3_4 + && isNothing (defaultLanguage bi) + ) + (PackageBuildWarning CVDefaultLanguageComponent) + -- Check use of 'extra-framework-dirs' field. + checkSpecVer + CabalSpecV1_24 + (not . null $ extraFrameworkDirs bi) + (PackageDistSuspiciousWarn CVExtraFrameworkDirs) + -- Check use of default-extensions field don't need to do the + -- equivalent check for other-extensions. + checkSpecVer + CabalSpecV1_10 + (not . null $ defaultExtensions bi) + (PackageBuildWarning CVDefaultExtensions) + -- Check use of extensions field + checkP + (sv >= CabalSpecV1_10 && (not . null $ oldExtensions bi)) + (PackageBuildWarning CVExtensionsDeprecated) + + -- asm-sources, cmm-sources and friends only w/ spec ≥ 1.10 + checkCVSources (asmSources bi) + checkCVSources (cmmSources bi) + checkCVSources (extraBundledLibs bi) + checkCVSources (extraLibFlavours bi) + + -- extra-dynamic-library-flavours requires ≥ 3.0 + checkSpecVer + CabalSpecV3_0 + (not . null $ extraDynLibFlavours bi) + (PackageDistInexcusable $ CVExtraDynamic [extraDynLibFlavours bi]) + -- virtual-modules requires ≥ 2.2 + checkSpecVer CabalSpecV2_2 (not . null $ virtualModules bi) $ + (PackageDistInexcusable CVVirtualModules) + -- Check use of thinning and renaming. + checkSpecVer + CabalSpecV2_0 + (not . null $ mixins bi) + (PackageDistInexcusable CVMixins) + + checkBuildInfoExtensions bi + where + checkCVSources :: Monad m => [FilePath] -> CheckM m () + checkCVSources cvs = + checkSpecVer + CabalSpecV3_0 + (not . null $ cvs) + (PackageDistInexcusable CVSources) + +-- Tests for extensions usage which can break Cabal < 1.4. +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 + -- As of Cabal-1.4 we can add new extensions without worrying + -- about breaking old versions of cabal. + checkSpecVer + CabalSpecV1_2 + (not . null $ extCabal1_2) + ( PackageDistInexcusable $ + CVExtensions CabalSpecV1_2 extCabal1_2 + ) + checkSpecVer + CabalSpecV1_4 + (not . null $ extCabal1_4) + ( PackageDistInexcusable $ + CVExtensions CabalSpecV1_4 extCabal1_4 + ) + where + -- The known extensions in Cabal-1.2.3 + compatExtensions :: [Extension] + compatExtensions = + map + EnableExtension + [ OverlappingInstances + , UndecidableInstances + , IncoherentInstances + , RecursiveDo + , ParallelListComp + , MultiParamTypeClasses + , FunctionalDependencies + , Rank2Types + , RankNTypes + , PolymorphicComponents + , ExistentialQuantification + , ScopedTypeVariables + , ImplicitParams + , FlexibleContexts + , FlexibleInstances + , EmptyDataDecls + , CPP + , BangPatterns + , TypeSynonymInstances + , TemplateHaskell + , ForeignFunctionInterface + , Arrows + , Generics + , NamedFieldPuns + , PatternGuards + , GeneralizedNewtypeDeriving + , ExtensibleRecords + , RestrictedTypeSynonyms + , HereDocuments + ] + ++ map + DisableExtension + [MonomorphismRestriction, ImplicitPrelude] + ++ compatExtensionsExtra + + -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 + -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) + compatExtensionsExtra :: [Extension] + compatExtensionsExtra = + map + EnableExtension + [ KindSignatures + , MagicHash + , TypeFamilies + , StandaloneDeriving + , UnicodeSyntax + , PatternSignatures + , UnliftedFFITypes + , LiberalTypeSynonyms + , TypeOperators + , RecordWildCards + , RecordPuns + , DisambiguateRecordFields + , OverloadedStrings + , GADTs + , RelaxedPolyRec + , ExtendedDefaultRules + , UnboxedTuples + , DeriveDataTypeable + , ConstrainedClassMethods + ] + ++ map + DisableExtension + [MonoPatBinds] + +-- Autogenerated modules (Paths_, PackageInfo_) checks. We could pass this +-- function something more specific than the whole BuildInfo, but it would be +-- a tuple of [ModuleName] lists, error prone. +checkAutogenModules + :: Monad m + => [ModuleName] -- Additional modules not present + -- in BuildInfo (e.g. exposed library + -- modules). + -> BuildInfo + -> CheckM m () +checkAutogenModules ams bi = do + pkgId <- asksCM (pnPackageId . ccNames) + let + -- It is an unfortunate reality that autogenPathsModuleName + -- and autogenPackageInfoModuleName work on PackageDescription + -- while not needing it all, but just the `package` bit. + minimalPD = emptyPackageDescription{package = pkgId} + autoPathsName = autogenPathsModuleName minimalPD + autoInfoModuleName = autogenPackageInfoModuleName minimalPD + + -- Autogenerated module + some default extension build failure. + autogenCheck autoPathsName CVAutogenPaths + rebindableClashCheck autoPathsName RebindableClashPaths + + -- Paths_* module + some default extension build failure. + autogenCheck autoInfoModuleName CVAutogenPackageInfo + rebindableClashCheck autoInfoModuleName RebindableClashPackageInfo + + -- PackageInfo_* module + cabal-version < 3.12 + -- See Mikolaj’s comments on #9481 on why this has to be + -- PackageBuildImpossible and not merely PackageDistInexcusable. + checkSpecVer + CabalSpecV3_12 + (elem autoInfoModuleName allModsForAuto) + (PackageBuildImpossible CVAutogenPackageInfoGuard) + where + allModsForAuto :: [ModuleName] + allModsForAuto = ams ++ otherModules bi + + autogenCheck + :: Monad m + => ModuleName + -> CheckExplanation + -> CheckM m () + autogenCheck name warning = do + sv <- asksCM ccSpecVersion + checkP + ( sv >= CabalSpecV2_0 + && elem name allModsForAuto + && notElem name (autogenModules bi) + ) + (PackageDistInexcusable warning) + + rebindableClashCheck + :: Monad m + => ModuleName + -> CheckExplanation + -> CheckM m () + rebindableClashCheck name warning = do + checkSpecVer + CabalSpecV2_2 + ( ( name `elem` otherModules bi + || name `elem` autogenModules bi + ) + && checkExts + ) + (PackageBuildImpossible warning) + + -- Do we have some peculiar extensions active which would interfere + -- (cabal-version <2.2) with Paths_modules? + checkExts :: Bool + checkExts = + let exts = defaultExtensions bi + in rebind `elem` exts + && (strings `elem` exts || lists `elem` exts) + where + rebind = EnableExtension RebindableSyntax + strings = EnableExtension OverloadedStrings + lists = EnableExtension OverloadedLists + +checkLocalPathExist + :: Monad m + => String -- .cabal field where we found the error. + -> FilePath + -> CheckM m () +checkLocalPathExist title dir = + checkPkg + ( \ops -> do + dn <- not <$> doesDirectoryExist ops dir + let rp = not (isAbsoluteOnAnyPlatform dir) + return (rp && dn) + ) + (PackageBuildWarning $ UnknownDirectory title dir) + +-- PVP -- + +-- Sometimes we read (or end up with) “straddle” deps declarations +-- like this: +-- +-- build-depends: base > 3, base < 4 +-- +-- `mergeDependencies` reduces that to base > 3 && < 4, _while_ maintaining +-- dependencies order in the list (better UX). +mergeDependencies :: [Dependency] -> [Dependency] +mergeDependencies [] = [] +mergeDependencies l@(d : _) = + let (sames, diffs) = partition ((== depName d) . depName) l + merged = + Dependency + (depPkgName d) + ( foldl intersectVersionRanges anyVersion $ + map depVerRange sames + ) + (depLibraries d) + in merged : mergeDependencies diffs + where + depName :: Dependency -> String + depName wd = unPackageName . depPkgName $ wd + +-- Is this an internal target? We do not perform PVP checks on those, +-- see https://github.com/haskell/cabal/pull/8361#issuecomment-1577547091 +isInternalTarget :: CEType -> Bool +isInternalTarget (CETLibrary{}) = False +isInternalTarget (CETForeignLibrary{}) = False +isInternalTarget (CETExecutable{}) = False +isInternalTarget (CETTest{}) = True +isInternalTarget (CETBenchmark{}) = True +isInternalTarget (CETSetup{}) = False + +-- ------------------------------------------------------------ +-- Options +-- ------------------------------------------------------------ + +-- Target type for option checking. +data BITarget = BITLib | BITTestBench | BITOther + deriving (Eq, Show) + +cet2bit :: CEType -> BITarget +cet2bit (CETLibrary{}) = BITLib +cet2bit (CETForeignLibrary{}) = BITLib +cet2bit (CETExecutable{}) = BITOther +cet2bit (CETTest{}) = BITTestBench +cet2bit (CETBenchmark{}) = BITTestBench +cet2bit CETSetup = BITOther + +-- General check on all options (ghc, C, C++, …) for common inaccuracies. +checkBuildInfoOptions :: Monad m => BITarget -> BuildInfo -> CheckM m () +checkBuildInfoOptions t bi = do + checkGHCOptions "ghc-options" t (hcOptions GHC bi) + checkGHCOptions "ghc-prof-options" t (hcProfOptions GHC bi) + checkGHCOptions "ghc-shared-options" t (hcSharedOptions GHC bi) + let ldOpts = ldOptions bi + checkCLikeOptions LangC "cc-options" (ccOptions bi) ldOpts + checkCLikeOptions LangCPlusPlus "cxx-options" (cxxOptions bi) ldOpts + checkCPPOptions (cppOptions bi) + +-- | Checks GHC options for commonly misused or non-portable flags. +checkGHCOptions + :: Monad m + => CabalField -- .cabal field name where we found the error. + -> BITarget -- Target type. + -> [String] -- Options (alas in String form). + -> CheckM m () +checkGHCOptions title t opts = do + checkGeneral + case t of + BITLib -> sequence_ [checkLib, checkNonTestBench] + BITTestBench -> checkTestBench + BITOther -> checkNonTestBench + where + checkFlags :: Monad m => [String] -> PackageCheck -> CheckM m () + checkFlags fs ck = checkP (any (`elem` fs) opts) ck + + checkFlagsP + :: Monad m + => (String -> Bool) + -> (String -> PackageCheck) + -> CheckM m () + checkFlagsP p ckc = + case filter p opts of + [] -> return () + (_ : _) -> tellP (ckc title) + + checkGeneral = do + checkFlags + ["-fasm"] + (PackageDistInexcusable $ OptFasm title) + checkFlags + ["-fhpc"] + (PackageDistInexcusable $ OptHpc title) + checkFlags + ["-prof"] + (PackageBuildWarning $ OptProf title) + -- Does not apply to scripts. + -- Why do we need this? See #8963. + pid <- asksCM (pnPackageId . ccNames) + unless (pid == fakePackageId) $ + checkFlags + ["-o"] + (PackageBuildWarning $ OptO title) + checkFlags + ["-hide-package"] + (PackageBuildWarning $ OptHide title) + checkFlags + ["--make"] + (PackageBuildWarning $ OptMake title) + checkFlags + ["-O", "-O1"] + (PackageDistInexcusable $ OptOOne title) + checkFlags + ["-O2"] + (PackageDistSuspiciousWarn $ OptOTwo title) + checkFlags + ["-split-sections"] + (PackageBuildWarning $ OptSplitSections title) + checkFlags + ["-split-objs"] + (PackageBuildWarning $ OptSplitObjs title) + checkFlags + ["-optl-Wl,-s", "-optl-s"] + (PackageDistInexcusable $ OptWls title) + checkFlags + ["-fglasgow-exts"] + (PackageDistSuspicious $ OptExts title) + let ghcNoRts = rmRtsOpts opts + checkAlternatives + title + "extensions" + [ (flag, prettyShow extension) + | flag <- ghcNoRts + , Just extension <- [ghcExtension flag] + ] + checkAlternatives + title + "extensions" + [ (flag, extension) + | flag@('-' : 'X' : extension) <- ghcNoRts + ] + checkAlternatives + title + "cpp-options" + ( [(flag, flag) | flag@('-' : 'D' : _) <- ghcNoRts] + ++ [(flag, flag) | flag@('-' : 'U' : _) <- ghcNoRts] + ) + checkAlternatives + title + "include-dirs" + [(flag, dir) | flag@('-' : 'I' : dir) <- ghcNoRts] + checkAlternatives + title + "extra-libraries" + [(flag, lib) | flag@('-' : 'l' : lib) <- ghcNoRts] + checkAlternatives + title + "extra-libraries-static" + [(flag, lib) | flag@('-' : 'l' : lib) <- ghcNoRts] + checkAlternatives + title + "extra-lib-dirs" + [(flag, dir) | flag@('-' : 'L' : dir) <- ghcNoRts] + checkAlternatives + title + "extra-lib-dirs-static" + [(flag, dir) | flag@('-' : 'L' : dir) <- ghcNoRts] + checkAlternatives + title + "frameworks" + [ (flag, fmwk) + | (flag@"-framework", fmwk) <- + zip ghcNoRts (safeTail ghcNoRts) + ] + checkAlternatives + title + "extra-framework-dirs" + [ (flag, dir) + | (flag@"-framework-path", dir) <- + zip ghcNoRts (safeTail ghcNoRts) + ] + -- Old `checkDevelopmentOnlyFlagsOptions` section + checkFlags + ["-Werror"] + (PackageDistInexcusable $ WErrorUnneeded title) + checkFlags + ["-fdefer-type-errors"] + (PackageDistInexcusable $ FDeferTypeErrorsUnneeded title) + checkFlags + [ "-fprof-auto" + , "-fprof-auto-top" + , "-fprof-auto-calls" + , "-fprof-cafs" + , "-fno-prof-count-entries" + , "-auto-all" + , "-auto" + , "-caf-all" + ] + (PackageDistSuspicious $ ProfilingUnneeded title) + checkFlagsP + ( \opt -> + "-d" `isPrefixOf` opt + && opt /= "-dynamic" + ) + (PackageDistInexcusable . DynamicUnneeded) + checkFlagsP + ( \opt -> case opt of + "-j" -> True + ('-' : 'j' : d : _) -> isDigit d + _ -> False + ) + (PackageDistInexcusable . JUnneeded) + + checkLib = do + checkP + ("-rtsopts" `elem` opts) + (PackageBuildWarning $ OptRts title) + checkP + (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) opts) + (PackageBuildWarning $ OptWithRts title) + + checkTestBench = do + checkFlags + ["-O0", "-Onot"] + (PackageDistSuspiciousWarn $ OptONot title) + + checkNonTestBench = do + checkFlags + ["-O0", "-Onot"] + (PackageDistSuspicious $ OptONot title) + + ghcExtension ('-' : 'f' : name) = case name of + "allow-overlapping-instances" -> enable OverlappingInstances + "no-allow-overlapping-instances" -> disable OverlappingInstances + "th" -> enable TemplateHaskell + "no-th" -> disable TemplateHaskell + "ffi" -> enable ForeignFunctionInterface + "no-ffi" -> disable ForeignFunctionInterface + "fi" -> enable ForeignFunctionInterface + "no-fi" -> disable ForeignFunctionInterface + "monomorphism-restriction" -> enable MonomorphismRestriction + "no-monomorphism-restriction" -> disable MonomorphismRestriction + "mono-pat-binds" -> enable MonoPatBinds + "no-mono-pat-binds" -> disable MonoPatBinds + "allow-undecidable-instances" -> enable UndecidableInstances + "no-allow-undecidable-instances" -> disable UndecidableInstances + "allow-incoherent-instances" -> enable IncoherentInstances + "no-allow-incoherent-instances" -> disable IncoherentInstances + "arrows" -> enable Arrows + "no-arrows" -> disable Arrows + "generics" -> enable Generics + "no-generics" -> disable Generics + "implicit-prelude" -> enable ImplicitPrelude + "no-implicit-prelude" -> disable ImplicitPrelude + "implicit-params" -> enable ImplicitParams + "no-implicit-params" -> disable ImplicitParams + "bang-patterns" -> enable BangPatterns + "no-bang-patterns" -> disable BangPatterns + "scoped-type-variables" -> enable ScopedTypeVariables + "no-scoped-type-variables" -> disable ScopedTypeVariables + "extended-default-rules" -> enable ExtendedDefaultRules + "no-extended-default-rules" -> disable ExtendedDefaultRules + _ -> Nothing + ghcExtension "-cpp" = enable CPP + ghcExtension _ = Nothing + + enable e = Just (EnableExtension e) + disable e = Just (DisableExtension e) + + rmRtsOpts :: [String] -> [String] + rmRtsOpts ("-with-rtsopts" : _ : xs) = rmRtsOpts xs + rmRtsOpts (x : xs) = x : rmRtsOpts xs + rmRtsOpts [] = [] + +checkCLikeOptions + :: Monad m + => WarnLang -- Language we are warning about (C or C++). + -> CabalField -- Field where we found the error. + -> [String] -- Options in string form. + -> [String] -- Link options in String form. + -> CheckM m () +checkCLikeOptions label prefix opts ldOpts = do + checkAlternatives + prefix + "include-dirs" + [(flag, dir) | flag@('-' : 'I' : dir) <- opts] + checkAlternatives + prefix + "extra-libraries" + [(flag, lib) | flag@('-' : 'l' : lib) <- opts] + checkAlternatives + prefix + "extra-lib-dirs" + [(flag, dir) | flag@('-' : 'L' : dir) <- opts] + + checkAlternatives + "ld-options" + "extra-libraries" + [(flag, lib) | flag@('-' : 'l' : lib) <- ldOpts] + checkAlternatives + "ld-options" + "extra-lib-dirs" + [(flag, dir) | flag@('-' : 'L' : dir) <- ldOpts] + + checkP + (any (`elem` ["-O", "-Os", "-O0", "-O1", "-O2", "-O3"]) opts) + (PackageDistSuspicious $ COptONumber prefix label) + +checkAlternatives + :: Monad m + => CabalField -- Wrong field. + -> CabalField -- Appropriate field. + -> [(String, String)] -- List of good and bad flags. + -> CheckM m () +checkAlternatives badField goodField flags = do + let (badFlags, _) = unzip flags + checkP + (not $ null badFlags) + (PackageBuildWarning $ OptAlternatives badField goodField flags) + +checkCPPOptions + :: Monad m + => [String] -- Options in String form. + -> CheckM m () +checkCPPOptions opts = do + checkAlternatives + "cpp-options" + "include-dirs" + [(flag, dir) | flag@('-' : 'I' : dir) <- opts] + mapM_ + ( \opt -> + checkP + (not $ any (`isPrefixOf` opt) ["-D", "-U", "-I"]) + (PackageBuildWarning (COptCPP opt)) + ) + opts diff --git a/src/Distribution/PackageDescription/Check/Warning.hs b/src/Distribution/PackageDescription/Check/Warning.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/PackageDescription/Check/Warning.hs @@ -0,0 +1,1473 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Distribution.PackageDescription.Check.Warning +-- Copyright : Francesco Ariis 2022 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Warning types, messages, severity and associated functions. +module Distribution.PackageDescription.Check.Warning + ( -- * Types and constructors + PackageCheck (..) + , CheckExplanation (..) + , CheckExplanationID + , CheckExplanationIDString + , CEType (..) + , WarnLang (..) + + -- * Operations + , ppPackageCheck + , ppCheckExplanationId + , isHackageDistError + , extractCheckExplantion + , filterPackageChecksById + , filterPackageChecksByIdString + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion (CabalSpecVersion, showCabalSpecVersion) +import Distribution.License (License, knownLicenses) +import Distribution.ModuleName (ModuleName) +import Distribution.Parsec.Warning (PWarning, showPWarning) +import Distribution.Pretty (prettyShow) +import Distribution.Types.BenchmarkType (BenchmarkType, knownBenchmarkTypes) +import Distribution.Types.Dependency (Dependency (..)) +import Distribution.Types.ExeDependency (ExeDependency) +import Distribution.Types.Flag (FlagName, unFlagName) +import Distribution.Types.LibraryName (LibraryName (..), showLibraryName) +import Distribution.Types.PackageName (PackageName) +import Distribution.Types.TestType (TestType, knownTestTypes) +import Distribution.Types.UnqualComponentName +import Distribution.Types.Version (Version) +import Distribution.Utils.Path + ( LicenseFile + , PackageDir + , SymbolicPath + , getSymbolicPath + ) +import Language.Haskell.Extension (Extension) + +import qualified Data.Either as Either +import qualified Data.List as List +import qualified Data.Set as Set + +-- ------------------------------------------------------------ +-- Check types and explanations +-- ------------------------------------------------------------ + +-- | Results of some kind of failed package check. +-- +-- There are a range of severities, from merely dubious to totally insane. +-- All of them come with a human readable explanation. In future we may augment +-- them with more machine readable explanations, for example to help an IDE +-- suggest automatic corrections. +data PackageCheck + = -- | This package description is no good. There's no way it's going to + -- build sensibly. This should give an error at configure time. + PackageBuildImpossible {explanation :: CheckExplanation} + | -- | A problem that is likely to affect building the package, or an + -- issue that we'd like every package author to be aware of, even if + -- the package is never distributed. + PackageBuildWarning {explanation :: CheckExplanation} + | -- | An issue that might not be a problem for the package author but + -- might be annoying or detrimental when the package is distributed to + -- users. We should encourage distributed packages to be free from these + -- issues, but occasionally there are justifiable reasons so we cannot + -- ban them entirely. + PackageDistSuspicious {explanation :: CheckExplanation} + | -- | Like PackageDistSuspicious but will only display warnings + -- rather than causing abnormal exit when you run 'cabal check'. + PackageDistSuspiciousWarn {explanation :: CheckExplanation} + | -- | An issue that is OK in the author's environment but is almost + -- certain to be a portability problem for other environments. We can + -- quite legitimately refuse to publicly distribute packages with these + -- problems. + PackageDistInexcusable {explanation :: CheckExplanation} + deriving (Eq, Ord) + +-- | Pretty printing 'PackageCheck'. +ppPackageCheck :: PackageCheck -> String +ppPackageCheck e = + let ex = explanation e + in "[" + ++ (ppCheckExplanationId . checkExplanationId) ex + ++ "] " + ++ ppExplanation ex + +-- | Broken 'Show' instance (not bijective with Read), alas external packages +-- depend on it. +instance Show PackageCheck where + show notice = ppPackageCheck notice + +-- | Would Hackage refuse a package because of this error? +isHackageDistError :: PackageCheck -> Bool +isHackageDistError = \case + (PackageBuildImpossible{}) -> True + (PackageBuildWarning{}) -> True + (PackageDistInexcusable{}) -> True + (PackageDistSuspicious{}) -> False + (PackageDistSuspiciousWarn{}) -> False + +-- | Filter Package Check by CheckExplanationID. +filterPackageChecksById + :: [PackageCheck] + -- ^ Original checks. + -> [CheckExplanationID] + -- ^ IDs to omit. + -> [PackageCheck] +filterPackageChecksById cs is = filter ff cs + where + ff :: PackageCheck -> Bool + ff c = + flip notElem is + . checkExplanationId + . extractCheckExplantion + $ c + +-- | Filter Package Check by Check explanation /string/. +filterPackageChecksByIdString + :: [PackageCheck] + -- ^ Original checks. + -> [CheckExplanationIDString] + -- ^ IDs to omit, in @String@ format. + -> ([PackageCheck], [CheckExplanationIDString]) +-- Filtered checks plus unrecognised id strings. +filterPackageChecksByIdString cs ss = + let (es, is) = Either.partitionEithers $ map readExplanationID ss + in (filterPackageChecksById cs is, es) + +-- | Explanations of 'PackageCheck`'s errors/warnings. +data CheckExplanation + = ParseWarning FilePath PWarning + | NoNameField + | NoVersionField + | NoTarget + | UnnamedInternal + | DuplicateSections [UnqualComponentName] + | IllegalLibraryName PackageName + | NoModulesExposed LibraryName + | SignaturesCabal2 + | AutogenNotExposed + | AutogenIncludesNotIncluded + | NoMainIs UnqualComponentName + | NoHsLhsMain + | MainCCabal1_18 + | AutogenNoOther CEType + | AutogenIncludesNotIncludedExe + | TestsuiteTypeNotKnown TestType + | TestsuiteNotSupported TestType + | BenchmarkTypeNotKnown BenchmarkType + | BenchmarkNotSupported BenchmarkType + | NoHsLhsMainBench + | InvalidNameWin PackageName + | ZPrefix + | NoBuildType + | NoCustomSetup + | UnknownCompilers [String] + | UnknownLanguages [String] + | UnknownExtensions [String] + | LanguagesAsExtension [String] + | DeprecatedExtensions [(Extension, Maybe Extension)] + | MissingFieldCategory + | MissingFieldMaintainer + | MissingFieldSynopsis + | MissingFieldDescription + | MissingFieldSynOrDesc + | SynopsisTooLong + | ShortDesc + | InvalidTestWith [Dependency] + | ImpossibleInternalDep [Dependency] + | ImpossibleInternalExe [ExeDependency] + | MissingInternalExe [ExeDependency] + | NONELicense + | NoLicense + | AllRightsReservedLicense + | LicenseMessParse License + | UnrecognisedLicense String + | UncommonBSD4 + | UnknownLicenseVersion License [Version] + | NoLicenseFile + | UnrecognisedSourceRepo String + | MissingType + | MissingLocation + | MissingModule + | MissingTag + | SubdirRelPath + | SubdirGoodRelPath String + | OptFasm String + | OptHpc String + | OptProf String + | OptO String + | OptHide String + | OptMake String + | OptONot String + | OptOOne String + | OptOTwo String + | OptSplitSections String + | OptSplitObjs String + | OptWls String + | OptExts String + | OptRts String + | OptWithRts String + | COptONumber String WarnLang + | COptCPP String + | OptAlternatives String String [(String, String)] + | RelativeOutside String FilePath + | AbsolutePath String FilePath + | BadRelativePath String FilePath String + | DistPoint (Maybe String) FilePath + | GlobSyntaxError String String + | RecursiveGlobInRoot String FilePath + | InvalidOnWin [FilePath] + | FilePathTooLong FilePath + | FilePathNameTooLong FilePath + | FilePathSplitTooLong FilePath + | FilePathEmpty + | CVTestSuite + | CVDefaultLanguage + | CVDefaultLanguageComponent + | CVExtraDocFiles + | CVMultiLib + | CVReexported + | CVMixins + | CVExtraFrameworkDirs + | CVDefaultExtensions + | CVExtensionsDeprecated + | CVSources + | CVExtraDynamic [[String]] + | CVVirtualModules + | CVSourceRepository + | CVExtensions CabalSpecVersion [Extension] + | CVCustomSetup + | CVExpliticDepsCustomSetup + | CVAutogenPaths + | CVAutogenPackageInfo + | CVAutogenPackageInfoGuard + | GlobNoMatch String String + | GlobExactMatch String String FilePath + | GlobNoDir String String FilePath + | UnknownOS [String] + | UnknownArch [String] + | UnknownCompiler [String] + | BaseNoUpperBounds + | MissingUpperBounds CEType [String] + | SuspiciousFlagName [String] + | DeclaredUsedFlags (Set.Set FlagName) (Set.Set FlagName) + | NonASCIICustomField [String] + | RebindableClashPaths + | RebindableClashPackageInfo + | WErrorUnneeded String + | JUnneeded String + | FDeferTypeErrorsUnneeded String + | DynamicUnneeded String + | ProfilingUnneeded String + | UpperBoundSetup String + | DuplicateModule String [ModuleName] + | PotentialDupModule String [ModuleName] + | BOMStart FilePath + | NotPackageName FilePath String + | NoDesc + | MultiDesc [String] + | UnknownFile String (SymbolicPath PackageDir LicenseFile) + | MissingSetupFile + | MissingConfigureScript + | UnknownDirectory String FilePath + | MissingSourceControl + | MissingExpectedDocFiles Bool [FilePath] + | WrongFieldForExpectedDocFiles Bool String [FilePath] + deriving (Eq, Ord, Show) + +-- TODO Some checks have a constructor in list form +-- (e.g. `SomeWarn [n]`), CheckM m () correctly catches warnings in +-- different stanzas in different checks (so it is not one soup). +-- +-- Ideally [SomeWar [a], SomeWar [b]] would be translated into +-- SomeWar [a,b] in the few cases where it is appropriate for UX +-- and left separated otherwise. +-- To achieve this the Writer part of CheckM could be modified +-- 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 + +-- | Identifier for the speficic 'CheckExplanation'. This ensures `--ignore` +-- can output a warning on unrecognised values. +-- ☞ N.B.: should be kept in sync with 'CheckExplanation'. +data CheckExplanationID + = CIParseWarning + | CINoNameField + | CINoVersionField + | CINoTarget + | CIUnnamedInternal + | CIDuplicateSections + | CIIllegalLibraryName + | CINoModulesExposed + | CISignaturesCabal2 + | CIAutogenNotExposed + | CIAutogenIncludesNotIncluded + | CINoMainIs + | CINoHsLhsMain + | CIMainCCabal1_18 + | CIAutogenNoOther + | CIAutogenIncludesNotIncludedExe + | CITestsuiteTypeNotKnown + | CITestsuiteNotSupported + | CIBenchmarkTypeNotKnown + | CIBenchmarkNotSupported + | CINoHsLhsMainBench + | CIInvalidNameWin + | CIZPrefix + | CINoBuildType + | CINoCustomSetup + | CIUnknownCompilers + | CIUnknownLanguages + | CIUnknownExtensions + | CILanguagesAsExtension + | CIDeprecatedExtensions + | CIMissingFieldCategory + | CIMissingFieldMaintainer + | CIMissingFieldSynopsis + | CIMissingFieldDescription + | CIMissingFieldSynOrDesc + | CISynopsisTooLong + | CIShortDesc + | CIInvalidTestWith + | CIImpossibleInternalDep + | CIImpossibleInternalExe + | CIMissingInternalExe + | CINONELicense + | CINoLicense + | CIAllRightsReservedLicense + | CILicenseMessParse + | CIUnrecognisedLicense + | CIUncommonBSD4 + | CIUnknownLicenseVersion + | CINoLicenseFile + | CIUnrecognisedSourceRepo + | CIMissingType + | CIMissingLocation + | CIMissingModule + | CIMissingTag + | CISubdirRelPath + | CISubdirGoodRelPath + | CIOptFasm + | CIOptHpc + | CIOptProf + | CIOptO + | CIOptHide + | CIOptMake + | CIOptONot + | CIOptOOne + | CIOptOTwo + | CIOptSplitSections + | CIOptSplitObjs + | CIOptWls + | CIOptExts + | CIOptRts + | CIOptWithRts + | CICOptONumber + | CICOptCPP + | CIOptAlternatives + | CIRelativeOutside + | CIAbsolutePath + | CIBadRelativePath + | CIDistPoint + | CIGlobSyntaxError + | CIRecursiveGlobInRoot + | CIInvalidOnWin + | CIFilePathTooLong + | CIFilePathNameTooLong + | CIFilePathSplitTooLong + | CIFilePathEmpty + | CICVTestSuite + | CICVDefaultLanguage + | CICVDefaultLanguageComponent + | CICVExtraDocFiles + | CICVMultiLib + | CICVReexported + | CICVMixins + | CICVExtraFrameworkDirs + | CICVDefaultExtensions + | CICVExtensionsDeprecated + | CICVSources + | CICVExtraDynamic + | CICVVirtualModules + | CICVSourceRepository + | CICVExtensions + | CICVCustomSetup + | CICVExpliticDepsCustomSetup + | CICVAutogenPaths + | CICVAutogenPackageInfo + | CICVAutogenPackageInfoGuard + | CIGlobNoMatch + | CIGlobExactMatch + | CIGlobNoDir + | CIUnknownOS + | CIUnknownArch + | CIUnknownCompiler + | CIBaseNoUpperBounds + | CIMissingUpperBounds + | CISuspiciousFlagName + | CIDeclaredUsedFlags + | CINonASCIICustomField + | CIRebindableClashPaths + | CIRebindableClashPackageInfo + | CIWErrorUnneeded + | CIJUnneeded + | CIFDeferTypeErrorsUnneeded + | CIDynamicUnneeded + | CIProfilingUnneeded + | CIUpperBoundSetup + | CIDuplicateModule + | CIPotentialDupModule + | CIBOMStart + | CINotPackageName + | CINoDesc + | CIMultiDesc + | CIUnknownFile + | CIMissingSetupFile + | CIMissingConfigureScript + | CIUnknownDirectory + | CIMissingSourceControl + | CIMissingExpectedDocFiles + | CIWrongFieldForExpectedDocFiles + deriving (Eq, Ord, Show, Enum, Bounded) + +checkExplanationId :: CheckExplanation -> CheckExplanationID +checkExplanationId (ParseWarning{}) = CIParseWarning +checkExplanationId (NoNameField{}) = CINoNameField +checkExplanationId (NoVersionField{}) = CINoVersionField +checkExplanationId (NoTarget{}) = CINoTarget +checkExplanationId (UnnamedInternal{}) = CIUnnamedInternal +checkExplanationId (DuplicateSections{}) = CIDuplicateSections +checkExplanationId (IllegalLibraryName{}) = CIIllegalLibraryName +checkExplanationId (NoModulesExposed{}) = CINoModulesExposed +checkExplanationId (SignaturesCabal2{}) = CISignaturesCabal2 +checkExplanationId (AutogenNotExposed{}) = CIAutogenNotExposed +checkExplanationId (AutogenIncludesNotIncluded{}) = CIAutogenIncludesNotIncluded +checkExplanationId (NoMainIs{}) = CINoMainIs +checkExplanationId (NoHsLhsMain{}) = CINoHsLhsMain +checkExplanationId (MainCCabal1_18{}) = CIMainCCabal1_18 +checkExplanationId (AutogenNoOther{}) = CIAutogenNoOther +checkExplanationId (AutogenIncludesNotIncludedExe{}) = CIAutogenIncludesNotIncludedExe +checkExplanationId (TestsuiteTypeNotKnown{}) = CITestsuiteTypeNotKnown +checkExplanationId (TestsuiteNotSupported{}) = CITestsuiteNotSupported +checkExplanationId (BenchmarkTypeNotKnown{}) = CIBenchmarkTypeNotKnown +checkExplanationId (BenchmarkNotSupported{}) = CIBenchmarkNotSupported +checkExplanationId (NoHsLhsMainBench{}) = CINoHsLhsMainBench +checkExplanationId (InvalidNameWin{}) = CIInvalidNameWin +checkExplanationId (ZPrefix{}) = CIZPrefix +checkExplanationId (NoBuildType{}) = CINoBuildType +checkExplanationId (NoCustomSetup{}) = CINoCustomSetup +checkExplanationId (UnknownCompilers{}) = CIUnknownCompilers +checkExplanationId (UnknownLanguages{}) = CIUnknownLanguages +checkExplanationId (UnknownExtensions{}) = CIUnknownExtensions +checkExplanationId (LanguagesAsExtension{}) = CILanguagesAsExtension +checkExplanationId (DeprecatedExtensions{}) = CIDeprecatedExtensions +checkExplanationId (MissingFieldCategory{}) = CIMissingFieldCategory +checkExplanationId (MissingFieldMaintainer{}) = CIMissingFieldMaintainer +checkExplanationId (MissingFieldSynopsis{}) = CIMissingFieldSynopsis +checkExplanationId (MissingFieldDescription{}) = CIMissingFieldDescription +checkExplanationId (MissingFieldSynOrDesc{}) = CIMissingFieldSynOrDesc +checkExplanationId (SynopsisTooLong{}) = CISynopsisTooLong +checkExplanationId (ShortDesc{}) = CIShortDesc +checkExplanationId (InvalidTestWith{}) = CIInvalidTestWith +checkExplanationId (ImpossibleInternalDep{}) = CIImpossibleInternalDep +checkExplanationId (ImpossibleInternalExe{}) = CIImpossibleInternalExe +checkExplanationId (MissingInternalExe{}) = CIMissingInternalExe +checkExplanationId (NONELicense{}) = CINONELicense +checkExplanationId (NoLicense{}) = CINoLicense +checkExplanationId (AllRightsReservedLicense{}) = CIAllRightsReservedLicense +checkExplanationId (LicenseMessParse{}) = CILicenseMessParse +checkExplanationId (UnrecognisedLicense{}) = CIUnrecognisedLicense +checkExplanationId (UncommonBSD4{}) = CIUncommonBSD4 +checkExplanationId (UnknownLicenseVersion{}) = CIUnknownLicenseVersion +checkExplanationId (NoLicenseFile{}) = CINoLicenseFile +checkExplanationId (UnrecognisedSourceRepo{}) = CIUnrecognisedSourceRepo +checkExplanationId (MissingType{}) = CIMissingType +checkExplanationId (MissingLocation{}) = CIMissingLocation +checkExplanationId (MissingModule{}) = CIMissingModule +checkExplanationId (MissingTag{}) = CIMissingTag +checkExplanationId (SubdirRelPath{}) = CISubdirRelPath +checkExplanationId (SubdirGoodRelPath{}) = CISubdirGoodRelPath +checkExplanationId (OptFasm{}) = CIOptFasm +checkExplanationId (OptHpc{}) = CIOptHpc +checkExplanationId (OptProf{}) = CIOptProf +checkExplanationId (OptO{}) = CIOptO +checkExplanationId (OptHide{}) = CIOptHide +checkExplanationId (OptMake{}) = CIOptMake +checkExplanationId (OptONot{}) = CIOptONot +checkExplanationId (OptOOne{}) = CIOptOOne +checkExplanationId (OptOTwo{}) = CIOptOTwo +checkExplanationId (OptSplitSections{}) = CIOptSplitSections +checkExplanationId (OptSplitObjs{}) = CIOptSplitObjs +checkExplanationId (OptWls{}) = CIOptWls +checkExplanationId (OptExts{}) = CIOptExts +checkExplanationId (OptRts{}) = CIOptRts +checkExplanationId (OptWithRts{}) = CIOptWithRts +checkExplanationId (COptONumber{}) = CICOptONumber +checkExplanationId (COptCPP{}) = CICOptCPP +checkExplanationId (OptAlternatives{}) = CIOptAlternatives +checkExplanationId (RelativeOutside{}) = CIRelativeOutside +checkExplanationId (AbsolutePath{}) = CIAbsolutePath +checkExplanationId (BadRelativePath{}) = CIBadRelativePath +checkExplanationId (DistPoint{}) = CIDistPoint +checkExplanationId (GlobSyntaxError{}) = CIGlobSyntaxError +checkExplanationId (RecursiveGlobInRoot{}) = CIRecursiveGlobInRoot +checkExplanationId (InvalidOnWin{}) = CIInvalidOnWin +checkExplanationId (FilePathTooLong{}) = CIFilePathTooLong +checkExplanationId (FilePathNameTooLong{}) = CIFilePathNameTooLong +checkExplanationId (FilePathSplitTooLong{}) = CIFilePathSplitTooLong +checkExplanationId (FilePathEmpty{}) = CIFilePathEmpty +checkExplanationId (CVTestSuite{}) = CICVTestSuite +checkExplanationId (CVDefaultLanguage{}) = CICVDefaultLanguage +checkExplanationId (CVDefaultLanguageComponent{}) = CICVDefaultLanguageComponent +checkExplanationId (CVExtraDocFiles{}) = CICVExtraDocFiles +checkExplanationId (CVMultiLib{}) = CICVMultiLib +checkExplanationId (CVReexported{}) = CICVReexported +checkExplanationId (CVMixins{}) = CICVMixins +checkExplanationId (CVExtraFrameworkDirs{}) = CICVExtraFrameworkDirs +checkExplanationId (CVDefaultExtensions{}) = CICVDefaultExtensions +checkExplanationId (CVExtensionsDeprecated{}) = CICVExtensionsDeprecated +checkExplanationId (CVSources{}) = CICVSources +checkExplanationId (CVExtraDynamic{}) = CICVExtraDynamic +checkExplanationId (CVVirtualModules{}) = CICVVirtualModules +checkExplanationId (CVSourceRepository{}) = CICVSourceRepository +checkExplanationId (CVExtensions{}) = CICVExtensions +checkExplanationId (CVCustomSetup{}) = CICVCustomSetup +checkExplanationId (CVExpliticDepsCustomSetup{}) = CICVExpliticDepsCustomSetup +checkExplanationId (CVAutogenPaths{}) = CICVAutogenPaths +checkExplanationId (CVAutogenPackageInfo{}) = CICVAutogenPackageInfo +checkExplanationId (CVAutogenPackageInfoGuard{}) = CICVAutogenPackageInfoGuard +checkExplanationId (GlobNoMatch{}) = CIGlobNoMatch +checkExplanationId (GlobExactMatch{}) = CIGlobExactMatch +checkExplanationId (GlobNoDir{}) = CIGlobNoDir +checkExplanationId (UnknownOS{}) = CIUnknownOS +checkExplanationId (UnknownArch{}) = CIUnknownArch +checkExplanationId (UnknownCompiler{}) = CIUnknownCompiler +checkExplanationId (BaseNoUpperBounds{}) = CIBaseNoUpperBounds +checkExplanationId (MissingUpperBounds{}) = CIMissingUpperBounds +checkExplanationId (SuspiciousFlagName{}) = CISuspiciousFlagName +checkExplanationId (DeclaredUsedFlags{}) = CIDeclaredUsedFlags +checkExplanationId (NonASCIICustomField{}) = CINonASCIICustomField +checkExplanationId (RebindableClashPaths{}) = CIRebindableClashPaths +checkExplanationId (RebindableClashPackageInfo{}) = CIRebindableClashPackageInfo +checkExplanationId (WErrorUnneeded{}) = CIWErrorUnneeded +checkExplanationId (JUnneeded{}) = CIJUnneeded +checkExplanationId (FDeferTypeErrorsUnneeded{}) = CIFDeferTypeErrorsUnneeded +checkExplanationId (DynamicUnneeded{}) = CIDynamicUnneeded +checkExplanationId (ProfilingUnneeded{}) = CIProfilingUnneeded +checkExplanationId (UpperBoundSetup{}) = CIUpperBoundSetup +checkExplanationId (DuplicateModule{}) = CIDuplicateModule +checkExplanationId (PotentialDupModule{}) = CIPotentialDupModule +checkExplanationId (BOMStart{}) = CIBOMStart +checkExplanationId (NotPackageName{}) = CINotPackageName +checkExplanationId (NoDesc{}) = CINoDesc +checkExplanationId (MultiDesc{}) = CIMultiDesc +checkExplanationId (UnknownFile{}) = CIUnknownFile +checkExplanationId (MissingSetupFile{}) = CIMissingSetupFile +checkExplanationId (MissingConfigureScript{}) = CIMissingConfigureScript +checkExplanationId (UnknownDirectory{}) = CIUnknownDirectory +checkExplanationId (MissingSourceControl{}) = CIMissingSourceControl +checkExplanationId (MissingExpectedDocFiles{}) = CIMissingExpectedDocFiles +checkExplanationId (WrongFieldForExpectedDocFiles{}) = CIWrongFieldForExpectedDocFiles + +type CheckExplanationIDString = String + +-- A one-word identifier for each CheckExplanation +-- +-- ☞ N.B: if you modify anything here, remeber to change the documentation +-- in @doc/cabal-commands.rst@! +ppCheckExplanationId :: CheckExplanationID -> CheckExplanationIDString +ppCheckExplanationId CIParseWarning = "parser-warning" +ppCheckExplanationId CINoNameField = "no-name-field" +ppCheckExplanationId CINoVersionField = "no-version-field" +ppCheckExplanationId CINoTarget = "no-target" +ppCheckExplanationId CIUnnamedInternal = "unnamed-internal-library" +ppCheckExplanationId CIDuplicateSections = "duplicate-sections" +ppCheckExplanationId CIIllegalLibraryName = "illegal-library-name" +ppCheckExplanationId CINoModulesExposed = "no-modules-exposed" +ppCheckExplanationId CISignaturesCabal2 = "signatures" +ppCheckExplanationId CIAutogenNotExposed = "autogen-not-exposed" +ppCheckExplanationId CIAutogenIncludesNotIncluded = "autogen-not-included" +ppCheckExplanationId CINoMainIs = "no-main-is" +ppCheckExplanationId CINoHsLhsMain = "unknown-extension-main" +ppCheckExplanationId CIMainCCabal1_18 = "c-like-main" +ppCheckExplanationId CIAutogenNoOther = "autogen-other-modules" +ppCheckExplanationId CIAutogenIncludesNotIncludedExe = "autogen-exe" +ppCheckExplanationId CITestsuiteTypeNotKnown = "unknown-testsuite-type" +ppCheckExplanationId CITestsuiteNotSupported = "unsupported-testsuite" +ppCheckExplanationId CIBenchmarkTypeNotKnown = "unknown-bench" +ppCheckExplanationId CIBenchmarkNotSupported = "unsupported-bench" +ppCheckExplanationId CINoHsLhsMainBench = "bench-unknown-extension" +ppCheckExplanationId CIInvalidNameWin = "invalid-name-win" +ppCheckExplanationId CIZPrefix = "reserved-z-prefix" +ppCheckExplanationId CINoBuildType = "no-build-type" +ppCheckExplanationId CINoCustomSetup = "undeclared-custom-setup" +ppCheckExplanationId CIUnknownCompilers = "unknown-compiler-tested" +ppCheckExplanationId CIUnknownLanguages = "unknown-languages" +ppCheckExplanationId CIUnknownExtensions = "unknown-extension" +ppCheckExplanationId CILanguagesAsExtension = "languages-as-extensions" +ppCheckExplanationId CIDeprecatedExtensions = "deprecated-extensions" +ppCheckExplanationId CIMissingFieldCategory = "no-category" +ppCheckExplanationId CIMissingFieldMaintainer = "no-maintainer" +ppCheckExplanationId CIMissingFieldSynopsis = "no-synopsis" +ppCheckExplanationId CIMissingFieldDescription = "no-description" +ppCheckExplanationId CIMissingFieldSynOrDesc = "no-syn-desc" +ppCheckExplanationId CISynopsisTooLong = "long-synopsis" +ppCheckExplanationId CIShortDesc = "short-description" +ppCheckExplanationId CIInvalidTestWith = "invalid-range-tested" +ppCheckExplanationId CIImpossibleInternalDep = "impossible-dep" +ppCheckExplanationId CIImpossibleInternalExe = "impossible-dep-exe" +ppCheckExplanationId CIMissingInternalExe = "no-internal-exe" +ppCheckExplanationId CINONELicense = "license-none" +ppCheckExplanationId CINoLicense = "no-license" +ppCheckExplanationId CIAllRightsReservedLicense = "all-rights-reserved" +ppCheckExplanationId CILicenseMessParse = "license-parse" +ppCheckExplanationId CIUnrecognisedLicense = "unknown-license" +ppCheckExplanationId CIUncommonBSD4 = "bsd4-license" +ppCheckExplanationId CIUnknownLicenseVersion = "unknown-license-version" +ppCheckExplanationId CINoLicenseFile = "no-license-file" +ppCheckExplanationId CIUnrecognisedSourceRepo = "unrecognised-repo-type" +ppCheckExplanationId CIMissingType = "repo-no-type" +ppCheckExplanationId CIMissingLocation = "repo-no-location" +ppCheckExplanationId CIMissingModule = "repo-no-module" +ppCheckExplanationId CIMissingTag = "repo-no-tag" +ppCheckExplanationId CISubdirRelPath = "repo-relative-dir" +ppCheckExplanationId CISubdirGoodRelPath = "repo-malformed-subdir" +ppCheckExplanationId CIOptFasm = "option-fasm" +ppCheckExplanationId CIOptHpc = "option-fhpc" +ppCheckExplanationId CIOptProf = "option-prof" +ppCheckExplanationId CIOptO = "option-o" +ppCheckExplanationId CIOptHide = "option-hide-package" +ppCheckExplanationId CIOptMake = "option-make" +ppCheckExplanationId CIOptONot = "option-optimize" +ppCheckExplanationId CIOptOOne = "option-o1" +ppCheckExplanationId CIOptOTwo = "option-o2" +ppCheckExplanationId CIOptSplitSections = "option-split-section" +ppCheckExplanationId CIOptSplitObjs = "option-split-objs" +ppCheckExplanationId CIOptWls = "option-optl-wl" +ppCheckExplanationId CIOptExts = "use-extension" +ppCheckExplanationId CIOptRts = "option-rtsopts" +ppCheckExplanationId CIOptWithRts = "option-with-rtsopts" +ppCheckExplanationId CICOptONumber = "option-opt-c" +ppCheckExplanationId CICOptCPP = "cpp-options" +ppCheckExplanationId CIOptAlternatives = "misplaced-c-opt" +ppCheckExplanationId CIRelativeOutside = "relative-path-outside" +ppCheckExplanationId CIAbsolutePath = "absolute-path" +ppCheckExplanationId CIBadRelativePath = "malformed-relative-path" +ppCheckExplanationId CIDistPoint = "unreliable-dist-path" +ppCheckExplanationId CIGlobSyntaxError = "glob-syntax-error" +ppCheckExplanationId CIRecursiveGlobInRoot = "recursive-glob" +ppCheckExplanationId CIInvalidOnWin = "invalid-path-win" +ppCheckExplanationId CIFilePathTooLong = "long-path" +ppCheckExplanationId CIFilePathNameTooLong = "long-name" +ppCheckExplanationId CIFilePathSplitTooLong = "name-not-portable" +ppCheckExplanationId CIFilePathEmpty = "empty-path" +ppCheckExplanationId CICVTestSuite = "test-cabal-ver" +ppCheckExplanationId CICVDefaultLanguage = "default-language" +ppCheckExplanationId CICVDefaultLanguageComponent = "no-default-language" +ppCheckExplanationId CICVExtraDocFiles = "extra-doc-files" +ppCheckExplanationId CICVMultiLib = "multilib" +ppCheckExplanationId CICVReexported = "reexported-modules" +ppCheckExplanationId CICVMixins = "mixins" +ppCheckExplanationId CICVExtraFrameworkDirs = "extra-framework-dirs" +ppCheckExplanationId CICVDefaultExtensions = "default-extensions" +ppCheckExplanationId CICVExtensionsDeprecated = "extensions-field" +ppCheckExplanationId CICVSources = "unsupported-sources" +ppCheckExplanationId CICVExtraDynamic = "extra-dynamic" +ppCheckExplanationId CICVVirtualModules = "virtual-modules" +ppCheckExplanationId CICVSourceRepository = "source-repository" +ppCheckExplanationId CICVExtensions = "incompatible-extension" +ppCheckExplanationId CICVCustomSetup = "no-setup-depends" +ppCheckExplanationId CICVExpliticDepsCustomSetup = "dependencies-setup" +ppCheckExplanationId CICVAutogenPaths = "no-autogen-paths" +ppCheckExplanationId CICVAutogenPackageInfo = "no-autogen-pinfo" +ppCheckExplanationId CICVAutogenPackageInfoGuard = "autogen-guard" +ppCheckExplanationId CIGlobNoMatch = "no-glob-match" +ppCheckExplanationId CIGlobExactMatch = "glob-no-extension" +ppCheckExplanationId CIGlobNoDir = "glob-missing-dir" +ppCheckExplanationId CIUnknownOS = "unknown-os" +ppCheckExplanationId CIUnknownArch = "unknown-arch" +ppCheckExplanationId CIUnknownCompiler = "unknown-compiler" +ppCheckExplanationId CIBaseNoUpperBounds = "missing-bounds-important" +ppCheckExplanationId CIMissingUpperBounds = "missing-upper-bounds" +ppCheckExplanationId CISuspiciousFlagName = "suspicious-flag" +ppCheckExplanationId CIDeclaredUsedFlags = "unused-flag" +ppCheckExplanationId CINonASCIICustomField = "non-ascii" +ppCheckExplanationId CIRebindableClashPaths = "rebindable-clash-paths" +ppCheckExplanationId CIRebindableClashPackageInfo = "rebindable-clash-info" +ppCheckExplanationId CIWErrorUnneeded = "werror" +ppCheckExplanationId CIJUnneeded = "unneeded-j" +ppCheckExplanationId CIFDeferTypeErrorsUnneeded = "fdefer-type-errors" +ppCheckExplanationId CIDynamicUnneeded = "debug-flag" +ppCheckExplanationId CIProfilingUnneeded = "fprof-flag" +ppCheckExplanationId CIUpperBoundSetup = "missing-bounds-setup" +ppCheckExplanationId CIDuplicateModule = "duplicate-modules" +ppCheckExplanationId CIPotentialDupModule = "maybe-duplicate-modules" +ppCheckExplanationId CIBOMStart = "bom" +ppCheckExplanationId CINotPackageName = "name-no-match" +ppCheckExplanationId CINoDesc = "no-cabal-file" +ppCheckExplanationId CIMultiDesc = "multiple-cabal-file" +ppCheckExplanationId CIUnknownFile = "unknown-file" +ppCheckExplanationId CIMissingSetupFile = "missing-setup" +ppCheckExplanationId CIMissingConfigureScript = "missing-conf-script" +ppCheckExplanationId CIUnknownDirectory = "unknown-directory" +ppCheckExplanationId CIMissingSourceControl = "no-repository" +ppCheckExplanationId CIMissingExpectedDocFiles = "no-docs" +ppCheckExplanationId CIWrongFieldForExpectedDocFiles = "doc-place" + +-- String: the unrecognised 'CheckExplanationIDString' itself. +readExplanationID + :: CheckExplanationIDString + -> Either String CheckExplanationID +readExplanationID s = maybe (Left s) Right (lookup s idsDict) + where + idsDict :: [(CheckExplanationIDString, CheckExplanationID)] + idsDict = map (\i -> (ppCheckExplanationId i, i)) [minBound .. maxBound] + +-- | Which stanza does `CheckExplanation` refer to? +data CEType + = CETLibrary LibraryName + | CETForeignLibrary UnqualComponentName + | CETExecutable UnqualComponentName + | CETTest UnqualComponentName + | CETBenchmark UnqualComponentName + | CETSetup + deriving (Eq, Ord, Show) + +-- | Pretty printing `CEType`. +ppCET :: CEType -> String +ppCET cet = case cet of + CETLibrary ln -> showLibraryName ln + CETForeignLibrary n -> "foreign library" ++ qn n + CETExecutable n -> "executable" ++ qn n + CETTest n -> "test suite" ++ qn n + CETBenchmark n -> "benchmark" ++ qn n + CETSetup -> "custom-setup" + where + qn :: UnqualComponentName -> String + qn wn = (" " ++) . quote . prettyShow $ wn + +-- | Which language are we referring to in our warning message? +data WarnLang = LangC | LangCPlusPlus + deriving (Eq, Ord, Show) + +-- | Pretty printing `WarnLang`. +ppWarnLang :: WarnLang -> String +ppWarnLang LangC = "C" +ppWarnLang LangCPlusPlus = "C++" + +-- | Pretty printing `CheckExplanation`. +ppExplanation :: CheckExplanation -> String +ppExplanation (ParseWarning fp pp) = showPWarning fp pp +ppExplanation NoNameField = "No 'name' field." +ppExplanation NoVersionField = "No 'version' field." +ppExplanation NoTarget = + "No executables, libraries, tests, or benchmarks found. Nothing to do." +ppExplanation UnnamedInternal = + "Found one or more unnamed internal libraries. Only the non-internal" + ++ " library can have the same name as the package." +ppExplanation (DuplicateSections duplicateNames) = + "Duplicate sections: " + ++ commaSep (map unUnqualComponentName duplicateNames) + ++ ". The name of every library, executable, test suite," + ++ " and benchmark section in the package must be unique." +ppExplanation (IllegalLibraryName pname) = + "Illegal internal library name " + ++ prettyShow pname + ++ ". Internal libraries cannot have the same name as the package." + ++ " Maybe you wanted a non-internal library?" + ++ " If so, rewrite the section stanza" + ++ " from 'library: '" + ++ prettyShow pname + ++ "' to 'library'." +ppExplanation (NoModulesExposed lName) = + showLibraryName lName ++ " does not expose any modules" +ppExplanation SignaturesCabal2 = + "To use the 'signatures' field the package needs to specify " + ++ "at least 'cabal-version: 2.0'." +ppExplanation AutogenNotExposed = + "An 'autogen-module' is neither on 'exposed-modules' nor 'other-modules'." +ppExplanation AutogenIncludesNotIncluded = + "An include in 'autogen-includes' is neither in 'includes' nor " + ++ "'install-includes'." +ppExplanation (NoMainIs eName) = + "No 'main-is' field found for executable " ++ prettyShow eName +ppExplanation NoHsLhsMain = + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor), " + ++ "or it may specify a C/C++/obj-C source file." +ppExplanation MainCCabal1_18 = + "The package uses a C/C++/obj-C source file for the 'main-is' field. " + ++ "To use this feature you need to specify 'cabal-version: 1.18' or" + ++ " higher." +ppExplanation (AutogenNoOther ct) = + "On " + ++ ppCET ct + ++ " an 'autogen-module'" + ++ " is not on 'other-modules'" +ppExplanation AutogenIncludesNotIncludedExe = + "An include in 'autogen-includes' is not in 'includes'." +ppExplanation (TestsuiteTypeNotKnown tt) = + quote (prettyShow tt) + ++ " is not a known type of test suite. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known test suite types are: " + ++ commaSep (map prettyShow knownTestTypes) +ppExplanation (TestsuiteNotSupported tt) = + quote (prettyShow tt) + ++ " is not a supported test suite version. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known test suite types are: " + ++ commaSep (map prettyShow knownTestTypes) +ppExplanation (BenchmarkTypeNotKnown tt) = + quote (prettyShow tt) + ++ " is not a known type of benchmark. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known benchmark types are: " + ++ commaSep (map prettyShow knownBenchmarkTypes) +ppExplanation (BenchmarkNotSupported tt) = + quote (prettyShow tt) + ++ " is not a supported benchmark version. " + ++ "Either remove the 'type' field or use a known type. " + ++ "The known benchmark types are: " + ++ commaSep (map prettyShow knownBenchmarkTypes) +ppExplanation NoHsLhsMainBench = + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor)." +ppExplanation (InvalidNameWin pkg) = + "The package name '" + ++ prettyShow pkg + ++ "' is " + ++ "invalid on Windows. Many tools need to convert package names to " + ++ "file names, so using this name would cause problems." +ppExplanation ZPrefix = + "Package names with the prefix 'z-' are reserved by Cabal and " + ++ "cannot be used." +ppExplanation NoBuildType = + "No 'build-type' specified. If you do not need a custom Setup.hs or " + ++ "./configure script then use 'build-type: Simple'." +ppExplanation NoCustomSetup = + "Ignoring the 'custom-setup' section because the 'build-type' is " + ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a " + ++ "custom Setup.hs script." +ppExplanation (UnknownCompilers unknownCompilers) = + "Unknown compiler " + ++ commaSep (map quote unknownCompilers) + ++ " in 'tested-with' field." +ppExplanation (UnknownLanguages unknownLanguages) = + "Unknown languages: " ++ commaSep unknownLanguages +ppExplanation (UnknownExtensions unknownExtensions) = + "Unknown extensions: " ++ commaSep unknownExtensions +ppExplanation (LanguagesAsExtension languagesUsedAsExtensions) = + "Languages listed as extensions: " + ++ commaSep languagesUsedAsExtensions + ++ ". Languages must be specified in either the 'default-language' " + ++ " or the 'other-languages' field." +ppExplanation (DeprecatedExtensions ourDeprecatedExtensions) = + "Deprecated extensions: " + ++ commaSep (map (quote . prettyShow . fst) ourDeprecatedExtensions) + ++ ". " + ++ unwords + [ "Instead of '" + ++ prettyShow ext + ++ "' use '" + ++ prettyShow replacement + ++ "'." + | (ext, Just replacement) <- ourDeprecatedExtensions + ] +ppExplanation MissingFieldCategory = "No 'category' field." +ppExplanation MissingFieldMaintainer = "No 'maintainer' field." +ppExplanation MissingFieldSynopsis = "No 'synopsis' field." +ppExplanation MissingFieldDescription = "No 'description' field." +ppExplanation MissingFieldSynOrDesc = "No 'synopsis' or 'description' field." +ppExplanation SynopsisTooLong = + "The 'synopsis' field is rather long (max 80 chars is recommended)." +ppExplanation ShortDesc = + "The 'description' field should be longer than the 'synopsis' field. " + ++ "It's useful to provide an informative 'description' to allow " + ++ "Haskell programmers who have never heard about your package to " + ++ "understand the purpose of your package. " + ++ "The 'description' field content is typically shown by tooling " + ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which " + ++ "serves as a headline. " + ++ "Please refer to for more details." +ppExplanation (InvalidTestWith testedWithImpossibleRanges) = + "Invalid 'tested-with' version range: " + ++ commaSep (map prettyShow testedWithImpossibleRanges) + ++ ". To indicate that you have tested a package with multiple " + ++ "different versions of the same compiler use multiple entries, " + ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " + ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." +ppExplanation (ImpossibleInternalDep depInternalLibWithImpossibleVersion) = + "The package has an impossible version range for a dependency on an " + ++ "internal library: " + ++ commaSep (map prettyShow depInternalLibWithImpossibleVersion) + ++ ". This version range does not include the current package, and must " + ++ "be removed as the current package's library will always be used." +ppExplanation (ImpossibleInternalExe depInternalExecWithImpossibleVersion) = + "The package has an impossible version range for a dependency on an " + ++ "internal executable: " + ++ commaSep (map prettyShow depInternalExecWithImpossibleVersion) + ++ ". This version range does not include the current package, and must " + ++ "be removed as the current package's executable will always be used." +ppExplanation (MissingInternalExe depInternalExeWithImpossibleVersion) = + "The package depends on a missing internal executable: " + ++ commaSep (map prettyShow depInternalExeWithImpossibleVersion) +ppExplanation NONELicense = "The 'license' field is missing or is NONE." +ppExplanation NoLicense = "The 'license' field is missing." +ppExplanation AllRightsReservedLicense = + "The 'license' is AllRightsReserved. Is that really what you want?" +ppExplanation (LicenseMessParse lic) = + "Unfortunately the license " + ++ quote (prettyShow lic) + ++ " messes up the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " + ++ "compatibility with earlier Cabal versions then use 'OtherLicense'." +ppExplanation (UnrecognisedLicense l) = + quote ("license: " ++ l) + ++ " is not a recognised license. The " + ++ "known licenses are: " + ++ commaSep (map prettyShow knownLicenses) +ppExplanation UncommonBSD4 = + "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " + ++ "refers to the old 4-clause BSD license with the advertising " + ++ "clause. 'BSD3' refers the new 3-clause BSD license." +ppExplanation (UnknownLicenseVersion lic known) = + "'license: " + ++ prettyShow lic + ++ "' is not a known " + ++ "version of that license. The known versions are " + ++ commaSep (map prettyShow known) + ++ ". If this is not a mistake and you think it should be a known " + ++ "version then please file a ticket." +ppExplanation NoLicenseFile = "A 'license-file' is not specified." +ppExplanation (UnrecognisedSourceRepo kind) = + quote kind + ++ " is not a recognised kind of source-repository. " + ++ "The repo kind is usually 'head' or 'this'" +ppExplanation MissingType = + "The source-repository 'type' is a required field." +ppExplanation MissingLocation = + "The source-repository 'location' is a required field." +ppExplanation MissingModule = + "For a CVS source-repository, the 'module' is a required field." +ppExplanation MissingTag = + "For the 'this' kind of source-repository, the 'tag' is a required " + ++ "field. It should specify the tag corresponding to this version " + ++ "or release of the package." +ppExplanation SubdirRelPath = + "The 'subdir' field of a source-repository must be a relative path." +ppExplanation (SubdirGoodRelPath err) = + "The 'subdir' field of a source-repository is not a good relative path: " + ++ show err +ppExplanation (OptFasm fieldName) = + "'" + ++ fieldName + ++ ": -fasm' is unnecessary and will not work on CPU " + ++ "architectures other than x86, x86-64, ppc or sparc." +ppExplanation (OptHpc fieldName) = + "'" + ++ fieldName + ++ ": -fhpc' is not necessary. Use the configure flag " + ++ " --enable-coverage instead." +ppExplanation (OptProf fieldName) = + "'" + ++ fieldName + ++ ": -prof' is not necessary and will lead to problems " + ++ "when used on a library. Use the configure flag " + ++ "--enable-library-profiling and/or --enable-profiling." +ppExplanation (OptO fieldName) = + "'" + ++ fieldName + ++ ": -o' is not needed. " + ++ "The output files are named automatically." +ppExplanation (OptHide fieldName) = + "'" + ++ fieldName + ++ ": -hide-package' is never needed. " + ++ "Cabal hides all packages." +ppExplanation (OptMake fieldName) = + "'" + ++ fieldName + ++ ": --make' is never needed. Cabal uses this automatically." +ppExplanation (OptONot fieldName) = + "'" + ++ fieldName + ++ ": -O0' is not needed. " + ++ "Use the --disable-optimization configure flag." +ppExplanation (OptOOne fieldName) = + "'" + ++ fieldName + ++ ": -O' is not needed. " + ++ "Cabal automatically adds the '-O' flag. " + ++ "Setting it yourself interferes with the --disable-optimization flag." +ppExplanation (OptOTwo fieldName) = + "'" + ++ fieldName + ++ ": -O2' is rarely needed. " + ++ "Check that it is giving a real benefit " + ++ "and not just imposing longer compile times on your users." +ppExplanation (OptSplitSections fieldName) = + "'" + ++ fieldName + ++ ": -split-sections' is not needed. " + ++ "Use the --enable-split-sections configure flag." +ppExplanation (OptSplitObjs fieldName) = + "'" + ++ fieldName + ++ ": -split-objs' is not needed. " + ++ "Use the --enable-split-objs configure flag." +ppExplanation (OptWls fieldName) = + "'" + ++ fieldName + ++ ": -optl-Wl,-s' is not needed and is not portable to" + ++ " all operating systems. Cabal 1.4 and later automatically strip" + ++ " executables. Cabal also has a flag --disable-executable-stripping" + ++ " which is necessary when building packages for some Linux" + ++ " distributions and using '-optl-Wl,-s' prevents that from working." +ppExplanation (OptExts fieldName) = + "Instead of '" + ++ fieldName + ++ ": -fglasgow-exts' it is preferable to use " + ++ "the 'extensions' field." +ppExplanation (OptRts fieldName) = + "'" + ++ fieldName + ++ ": -rtsopts' has no effect for libraries. It should " + ++ "only be used for executables." +ppExplanation (OptWithRts fieldName) = + "'" + ++ fieldName + ++ ": -with-rtsopts' has no effect for libraries. It " + ++ "should only be used for executables." +ppExplanation (COptONumber prefix label) = + "'" + ++ prefix + ++ ": -O[n]' is generally not needed. When building with " + ++ " optimisations Cabal automatically adds '-O2' for " + ++ ppWarnLang label + ++ " code. Setting it yourself interferes with the" + ++ " --disable-optimization flag." +ppExplanation (COptCPP opt) = + "'cpp-options: " ++ opt ++ "' is not a portable C-preprocessor flag." +ppExplanation (OptAlternatives badField goodField flags) = + "Instead of " + ++ quote (badField ++ ": " ++ unwords badFlags) + ++ " use " + ++ quote (goodField ++ ": " ++ unwords goodFlags) + where + (badFlags, goodFlags) = unzip flags +ppExplanation (RelativeOutside field path) = + quote (field ++ ": " ++ path) + ++ " is a relative path outside of the source tree. " + ++ "This will not work when generating a tarball with 'sdist'." +ppExplanation (AbsolutePath field path) = + quote (field ++ ": " ++ path) + ++ " specifies an absolute path, but the " + ++ quote field + ++ " field must use relative paths." +ppExplanation (BadRelativePath field path err) = + quote (field ++ ": " ++ path) + ++ " is not a good relative path: " + ++ show err +ppExplanation (DistPoint mfield path) = + incipit + ++ " points inside the 'dist' " + ++ "directory. This is not reliable because the location of this " + ++ "directory is configurable by the user (or package manager). In " + ++ "addition, the layout of the 'dist' directory is subject to change " + ++ "in future versions of Cabal." + where + -- mfiled Nothing -> the path is inside `ghc-options` + incipit = + maybe + ("'ghc-options' path " ++ quote path) + (\field -> quote (field ++ ": " ++ path)) + mfield +ppExplanation (GlobSyntaxError field expl) = + "In the '" ++ field ++ "' field: " ++ expl +ppExplanation (RecursiveGlobInRoot field glob) = + "In the '" + ++ field + ++ "': glob '" + ++ glob + ++ "' starts at project root directory, this might " + ++ "include `.git/`, ``dist-newstyle/``, or other large directories!" +ppExplanation (InvalidOnWin paths) = + "The " + ++ quotes paths + ++ " invalid on Windows, which " + ++ "would cause portability problems for this package. Windows file " + ++ "names cannot contain any of the characters \":*?<>|\" and there " + ++ "a few reserved names including \"aux\", \"nul\", \"con\", " + ++ "\"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." + where + quotes [failed] = "path " ++ quote failed ++ " is" + quotes failed = + "paths " + ++ commaSep (map quote failed) + ++ " are" +ppExplanation (FilePathTooLong path) = + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length is 255 ASCII characters.\n" + ++ "The file in question is:\n " + ++ path +ppExplanation (FilePathNameTooLong path) = + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length for the name part (including " + ++ "extension) is 100 ASCII characters. The maximum length for any " + ++ "individual directory component is 155.\n" + ++ "The file in question is:\n " + ++ path +ppExplanation (FilePathSplitTooLong path) = + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. While the total length is less than 255 ASCII " + ++ "characters, there are unfortunately further restrictions. It has to " + ++ "be possible to split the file path on a directory separator into " + ++ "two parts such that the first part fits in 155 characters or less " + ++ "and the second part fits in 100 characters or less. Basically you " + ++ "have to make the file name or directory names shorter, or you could " + ++ "split a long directory name into nested subdirectories with shorter " + ++ "names.\nThe file in question is:\n " + ++ path +ppExplanation FilePathEmpty = + "Encountered a file with an empty name, something is very wrong! " + ++ "Files with an empty name cannot be stored in a tar archive or in " + ++ "standard file systems." +ppExplanation CVTestSuite = + "The 'test-suite' section is new in Cabal 1.10. " + ++ "Unfortunately it messes up the parser in older Cabal versions " + ++ "so you must specify at least 'cabal-version: >= 1.8', but note " + ++ "that only Cabal 1.10 and later can actually run such test suites." +ppExplanation CVDefaultLanguage = + "To use the 'default-language' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." +ppExplanation CVDefaultLanguageComponent = + "Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' " + ++ "must specify the 'default-language' field for each component (e.g. " + ++ "Haskell98 or Haskell2010). If a component uses different languages " + ++ "in different modules then list the other ones in the " + ++ "'other-languages' field." +ppExplanation CVExtraDocFiles = + "To use the 'extra-doc-files' field the package needs to specify " + ++ "'cabal-version: 1.18' or higher." +ppExplanation CVMultiLib = + "To use multiple 'library' sections or a named library section " + ++ "the package needs to specify at least 'cabal-version: 2.0'." +ppExplanation CVReexported = + "To use the 'reexported-module' field the package needs to specify " + ++ "'cabal-version: 1.22' or higher." +ppExplanation CVMixins = + "To use the 'mixins' field the package needs to specify " + ++ "at least 'cabal-version: 2.0'." +ppExplanation CVExtraFrameworkDirs = + "To use the 'extra-framework-dirs' field the package needs to specify" + ++ " 'cabal-version: 1.24' or higher." +ppExplanation CVDefaultExtensions = + "To use the 'default-extensions' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." +ppExplanation CVExtensionsDeprecated = + "For packages using 'cabal-version: >= 1.10' the 'extensions' " + ++ "field is deprecated. The new 'default-extensions' field lists " + ++ "extensions that are used in all modules in the component, while " + ++ "the 'other-extensions' field lists extensions that are used in " + ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." +ppExplanation CVSources = + "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' " + ++ " and 'extra-library-flavours' requires the package " + ++ " to specify at least 'cabal-version: 3.0'." +ppExplanation (CVExtraDynamic flavs) = + "The use of 'extra-dynamic-library-flavours' requires the package " + ++ " to specify at least 'cabal-version: 3.0'. The flavours are: " + ++ commaSep (concat flavs) +ppExplanation CVVirtualModules = + "The use of 'virtual-modules' requires the package " + ++ " to specify at least 'cabal-version: 2.2'." +ppExplanation CVSourceRepository = + "The 'source-repository' section is new in Cabal 1.6. " + ++ "Unfortunately it messes up the parser in earlier Cabal versions " + ++ "so you need to specify 'cabal-version: >= 1.6'." +ppExplanation (CVExtensions version extCab12) = + "Unfortunately the language extensions " + ++ commaSep (map (quote . prettyShow) extCab12) + ++ " break the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= " + ++ showCabalSpecVersion version + ++ "'. Alternatively if you require compatibility with earlier " + ++ "Cabal versions then you may be able to use an equivalent " + ++ "compiler-specific flag." +ppExplanation CVCustomSetup = + "Packages using 'cabal-version: 1.24' or higher with 'build-type: Custom' " + ++ "must use a 'custom-setup' section with a 'setup-depends' field " + ++ "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 = + "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' " + ++ "field 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 CVAutogenPaths = + "Packages using 'cabal-version: 2.0' and the autogenerated " + ++ "module Paths_* must include it also on the 'autogen-modules' field " + ++ "besides 'exposed-modules' and 'other-modules'. This specifies that " + ++ "the module does not come with the package and is generated on " + ++ "setup. Modules built with a custom Setup.hs script also go here " + ++ "to ensure that commands like sdist don't fail." +ppExplanation CVAutogenPackageInfo = + "Packages using 'cabal-version: 2.0' and the autogenerated " + ++ "module PackageInfo_* must include it in 'autogen-modules' as well as" + ++ " 'exposed-modules' and 'other-modules'. This specifies that " + ++ "the module does not come with the package and is generated on " + ++ "setup. Modules built with a custom Setup.hs script also go here " + ++ "to ensure that commands like sdist don't fail." +ppExplanation CVAutogenPackageInfoGuard = + "To use the autogenerated module PackageInfo_* you need to specify " + ++ "`cabal-version: 3.12` or higher." +ppExplanation (GlobNoMatch field glob) = + "In '" + ++ field + ++ "': the pattern '" + ++ glob + ++ "' does not" + ++ " match any files." +ppExplanation (GlobExactMatch field glob file) = + "In '" + ++ field + ++ "': the pattern '" + ++ glob + ++ "' does not" + ++ " match the file '" + ++ file + ++ "' because the extensions do not" + ++ " exactly match (e.g., foo.en.html does not exactly match *.html)." + ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or" + ++ " higher." +ppExplanation (GlobNoDir field glob dir) = + "In '" + ++ field + ++ "': the pattern '" + ++ glob + ++ "' attempts to" + ++ " match files in the directory '" + ++ dir + ++ "', but there is no" + ++ " directory by that name." +ppExplanation (UnknownOS unknownOSs) = + "Unknown operating system name " ++ commaSep (map quote unknownOSs) +ppExplanation (UnknownArch unknownArches) = + "Unknown architecture name " ++ commaSep (map quote unknownArches) +ppExplanation (UnknownCompiler unknownImpls) = + "Unknown compiler name " ++ commaSep (map quote unknownImpls) +ppExplanation BaseNoUpperBounds = + "The dependency 'build-depends: base' does not specify an upper " + ++ "bound on the version number. Each major release of the 'base' " + ++ "package changes the API in various ways and most packages will " + ++ "need some changes to compile with it. The recommended practice " + ++ "is to specify an upper bound on the version of the 'base' " + ++ "package. This ensures your package will continue to build when a " + ++ "new major version of the 'base' package is released. If you are " + ++ "not sure what upper bound to use then use the next major " + ++ "version. For example if you have tested your package with 'base' " + ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'." +ppExplanation (MissingUpperBounds ct names) = + let separator = "\n - " + in "On " + ++ ppCET ct + ++ ", " + ++ "these packages miss upper bounds:" + ++ separator + ++ List.intercalate separator names + ++ "\n" + ++ "Please add them. There is more information at https://pvp.haskell.org/" +ppExplanation (SuspiciousFlagName invalidFlagNames) = + "Suspicious flag names: " + ++ unwords invalidFlagNames + ++ ". " + ++ "To avoid ambiguity in command line interfaces, a flag shouldn't " + ++ "start with a dash. Also for better compatibility, flag names " + ++ "shouldn't contain non-ascii characters." +ppExplanation (DeclaredUsedFlags declared used) = + "Declared and used flag sets differ: " + ++ s declared + ++ " /= " + ++ s used + ++ ". " + where + s :: Set.Set FlagName -> String + s = commaSep . map unFlagName . Set.toList +ppExplanation (NonASCIICustomField nonAsciiXFields) = + "Non ascii custom fields: " + ++ unwords nonAsciiXFields + ++ ". " + ++ "For better compatibility, custom field names " + ++ "shouldn't contain non-ascii characters." +ppExplanation RebindableClashPaths = + "Packages using RebindableSyntax with OverloadedStrings or" + ++ " OverloadedLists in default-extensions, in conjunction with the" + ++ " autogenerated module Paths_*, are known to cause compile failures" + ++ " with Cabal < 2.2. To use these default-extensions with a Paths_*" + ++ " autogen module, specify at least 'cabal-version: 2.2'." +ppExplanation RebindableClashPackageInfo = + "Packages using RebindableSyntax with OverloadedStrings or" + ++ " OverloadedLists in default-extensions, in conjunction with the" + ++ " autogenerated module PackageInfo_*, are known to cause compile failures" + ++ " with Cabal < 2.2. To use these default-extensions with a PackageInfo_*" + ++ " autogen module, specify at least 'cabal-version: 2.2'." +ppExplanation (WErrorUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -Werror' makes the package easy to " + ++ "break with future GHC versions because new GHC versions often " + ++ "add new warnings." +ppExplanation (JUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -j[N]' can make sense for a particular user's setup," + ++ " but it is not appropriate for a distributed package." +ppExplanation (FDeferTypeErrorsUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -fdefer-type-errors' is fine during development " + ++ "but is not appropriate for a distributed package." +ppExplanation (DynamicUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -d*' debug flags are not appropriate " + ++ "for a distributed package." +ppExplanation (ProfilingUnneeded fieldName) = + addConditionalExp $ + "'" + ++ fieldName + ++ ": -fprof*' profiling flags are typically not " + ++ "appropriate for a distributed library package. These flags are " + ++ "useful to profile this package, but when profiling other packages " + ++ "that use this one these flags clutter the profile output with " + ++ "excessive detail. If you think other packages really want to see " + ++ "cost centres from this package then use '-fprof-auto-exported' " + ++ "which puts cost centres only on exported functions." +ppExplanation (UpperBoundSetup nm) = + "The dependency 'setup-depends: '" + ++ nm + ++ "' does not specify an " + ++ "upper bound on the version number. Each major release of the " + ++ "'" + ++ nm + ++ "' package changes the API in various ways and most " + ++ "packages will need some changes to compile with it. If you are " + ++ "not sure what upper bound to use then use the next major " + ++ "version." +ppExplanation (DuplicateModule s dupLibsLax) = + "Duplicate modules in " + ++ s + ++ ": " + ++ commaSep (map prettyShow dupLibsLax) +ppExplanation (PotentialDupModule s dupLibsStrict) = + "Potential duplicate modules (subject to conditionals) in " + ++ s + ++ ": " + ++ commaSep (map prettyShow dupLibsStrict) +ppExplanation (BOMStart pdfile) = + pdfile + ++ " starts with an Unicode byte order mark (BOM)." + ++ " This may cause problems with older cabal versions." +ppExplanation (NotPackageName pdfile expectedCabalname) = + "The filename " + ++ quote pdfile + ++ " does not match package name " + ++ "(expected: " + ++ quote expectedCabalname + ++ ")" +ppExplanation NoDesc = + "No cabal file found.\n" + ++ "Please create a package description file .cabal" +ppExplanation (MultiDesc multiple) = + "Multiple cabal files found while checking.\n" + ++ "Please use only one of: " + ++ commaSep multiple +ppExplanation (UnknownFile fieldname file) = + "The '" + ++ fieldname + ++ "' field refers to the file " + ++ quote (getSymbolicPath file) + ++ " which does not exist." +ppExplanation MissingSetupFile = + "The package is missing a Setup.hs or Setup.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." +ppExplanation (UnknownDirectory kind dir) = + quote (kind ++ ": " ++ dir) + ++ " specifies a directory which does not exist." +ppExplanation MissingSourceControl = + "When distributing packages, it is encouraged to specify source " + ++ "control information in the .cabal file using one or more " + ++ "'source-repository' sections. See the Cabal user guide for " + ++ "details." +ppExplanation (MissingExpectedDocFiles extraDocFileSupport paths) = + "Please consider including the " + ++ quotes paths + ++ " in the '" + ++ targetField + ++ "' section of the .cabal file " + ++ "if it contains useful information for users of the package." + where + quotes [p] = "file " ++ quote p + quotes ps = "files " ++ commaSep (map quote ps) + targetField = + if extraDocFileSupport + then "extra-doc-files" + else "extra-source-files" +ppExplanation (WrongFieldForExpectedDocFiles extraDocFileSupport field paths) = + "Please consider moving the " + ++ quotes paths + ++ " from the '" + ++ field + ++ "' section of the .cabal file " + ++ "to the section '" + ++ targetField + ++ "'." + where + quotes [p] = "file " ++ quote p + quotes ps = "files " ++ commaSep (map quote ps) + targetField = + if extraDocFileSupport + then "extra-doc-files" + else "extra-source-files" + +-- * Formatting utilities + +commaSep :: [String] -> String +commaSep = List.intercalate ", " + +quote :: String -> String +quote s = "'" ++ s ++ "'" + +addConditionalExp :: String -> String +addConditionalExp expl = + expl + ++ " Alternatively, if you want to use this, make it conditional based " + ++ "on a Cabal configuration flag (with 'manual: True' and 'default: " + ++ "False') and enable that flag during development." diff --git a/src/Distribution/ReadE.hs b/src/Distribution/ReadE.hs --- a/src/Distribution/ReadE.hs +++ b/src/Distribution/ReadE.hs @@ -1,5 +1,7 @@ {-# LANGUAGE LambdaCase #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.ReadE -- Copyright : Jose Iborra 2008 @@ -9,32 +11,37 @@ -- Portability : portable -- -- Simple parsing with failure +module Distribution.ReadE + ( -- * ReadE + ReadE (..) + , succeedReadE + , failReadE -module Distribution.ReadE ( - -- * ReadE - ReadE(..), succeedReadE, failReadE, - -- * Projections - parsecToReadE, parsecToReadEErr, - -- * Parse Errors - unexpectMsgString, + -- * Projections + , parsecToReadE + , parsecToReadEErr + + -- * Parse Errors + , unexpectMsgString ) where +import qualified Data.Bifunctor as Bi (first) import Distribution.Compat.Prelude import Prelude () -import qualified Data.Bifunctor as Bi (first) import Distribution.Parsec -import qualified Text.Parsec.Error as Parsec import Distribution.Parsec.FieldLineStream +import qualified Text.Parsec.Error as Parsec -- | Parser with simple error reporting newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} -type ErrorMsg = String +type ErrorMsg = String + instance Functor ReadE where fmap f (ReadE p) = ReadE $ \txt -> case p txt of - Right a -> Right (f a) - Left err -> Left err + Right a -> Right (f a) + Left err -> Left err succeedReadE :: (String -> a) -> ReadE a succeedReadE f = ReadE (Right . f) @@ -44,20 +51,21 @@ runParsecFromString :: ParsecParser a -> String -> Either Parsec.ParseError a runParsecFromString p txt = - runParsecParser p "" (fieldLineStreamFromString txt) + runParsecParser p "" (fieldLineStreamFromString txt) parsecToReadE :: (String -> ErrorMsg) -> ParsecParser a -> ReadE a parsecToReadE err p = ReadE $ \txt -> - (const $ err txt) `Bi.first` runParsecFromString p txt + const (err txt) `Bi.first` runParsecFromString p txt parsecToReadEErr :: (Parsec.ParseError -> ErrorMsg) -> ParsecParser a -> ReadE a -parsecToReadEErr err p = ReadE $ +parsecToReadEErr err p = + ReadE $ Bi.first err . runParsecFromString p -- Show only unexpected error messages unexpectMsgString :: Parsec.ParseError -> String -unexpectMsgString = unlines - . map Parsec.messageString - . filter (\case { Parsec.UnExpect _ -> True; _ -> False }) - . Parsec.errorMessages - +unexpectMsgString = + unlines + . map Parsec.messageString + . filter (\case Parsec.UnExpect _ -> True; _ -> False) + . Parsec.errorMessages diff --git a/src/Distribution/Simple.hs b/src/Distribution/Simple.hs --- a/src/Distribution/Simple.hs +++ b/src/Distribution/Simple.hs @@ -1,8 +1,17 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- +{- +Work around this warning: +libraries/Cabal/Distribution/Simple.hs:78:0: + Warning: In the use of `runTests' + (imported from Distribution.Simple.UserHooks): + Deprecated: "Please use the new testing interface instead!" +-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + -- | -- Module : Distribution.Simple -- Copyright : Isaac Jones 2003-2005 @@ -28,79 +37,84 @@ -- 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. +module Distribution.Simple + ( module Distribution.Package + , module Distribution.Version + , module Distribution.License + , module Distribution.Simple.Compiler + , module Language.Haskell.Extension -{- -Work around this warning: -libraries/Cabal/Distribution/Simple.hs:78:0: - Warning: In the use of `runTests' - (imported from Distribution.Simple.UserHooks): - Deprecated: "Please use the new testing interface instead!" --} -{-# OPTIONS_GHC -fno-warn-deprecations #-} + -- * Simple interface + , defaultMain + , defaultMainNoRead + , defaultMainArgs -module Distribution.Simple ( - module Distribution.Package, - module Distribution.Version, - module Distribution.License, - module Distribution.Simple.Compiler, - module Language.Haskell.Extension, - -- * Simple interface - defaultMain, defaultMainNoRead, defaultMainArgs, - -- * Customization - UserHooks(..), Args, - defaultMainWithHooks, defaultMainWithHooksArgs, - defaultMainWithHooksNoRead, defaultMainWithHooksNoReadArgs, - -- ** Standard sets of hooks - simpleUserHooks, - autoconfUserHooks, - emptyUserHooks, + -- * Customization + , UserHooks (..) + , Args + , defaultMainWithHooks + , defaultMainWithHooksArgs + , defaultMainWithHooksNoRead + , defaultMainWithHooksNoReadArgs + + -- ** Standard sets of hooks + , simpleUserHooks + , autoconfUserHooks + , emptyUserHooks ) where import Control.Exception (try) -import Prelude () import Distribution.Compat.Prelude +import Prelude () -- local -import Distribution.Simple.Compiler -import Distribution.Simple.UserHooks + import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Configuration +import Distribution.Simple.Command +import Distribution.Simple.Compiler import Distribution.Simple.PackageDescription -import Distribution.Simple.Program import Distribution.Simple.PreProcess +import Distribution.Simple.Program import Distribution.Simple.Setup -import Distribution.Simple.Command +import Distribution.Simple.UserHooks import Distribution.Simple.Build -import Distribution.Simple.SrcDist import Distribution.Simple.Register +import Distribution.Simple.SrcDist import Distribution.Simple.Configure -import Distribution.Simple.ConfigureScript -import Distribution.Simple.LocalBuildInfo +import Distribution.License +import Distribution.Pretty import Distribution.Simple.Bench import Distribution.Simple.BuildPaths -import Distribution.Simple.Test -import Distribution.Simple.Install +import Distribution.Simple.ConfigureScript +import Distribution.Simple.Errors import Distribution.Simple.Haddock +import Distribution.Simple.Install +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Test import Distribution.Simple.Utils import Distribution.Verbosity -import Language.Haskell.Extension import Distribution.Version -import Distribution.License -import Distribution.Pretty +import Language.Haskell.Extension -- Base -import System.Environment (getArgs, getProgName) -import System.Directory (removeFile, doesFileExist - ,doesDirectoryExist, removeDirectoryRecursive) -import System.FilePath (takeDirectory, ()) + import Distribution.Compat.ResponseFile (expandResponse) +import System.Directory + ( doesDirectoryExist + , doesFileExist + , removeDirectoryRecursive + , removeFile + ) +import System.Environment (getArgs, getProgName) +import System.FilePath (takeDirectory, ()) -import Data.List (unionBy, (\\)) +import Data.List (unionBy, (\\)) -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the @@ -130,8 +144,8 @@ -- | A customizable version of 'defaultMainNoRead'. defaultMainWithHooksNoRead :: UserHooks -> GenericPackageDescription -> IO () defaultMainWithHooksNoRead hooks pkg_descr = - getArgs >>= - defaultMainHelper hooks { readDesc = return (Just pkg_descr) } + getArgs + >>= defaultMainHelper hooks{readDesc = return (Just pkg_descr)} -- | A customizable version of 'defaultMainNoRead' that also takes the -- command line arguments. @@ -139,24 +153,35 @@ -- @since 2.2.0.0 defaultMainWithHooksNoReadArgs :: UserHooks -> GenericPackageDescription -> [String] -> IO () defaultMainWithHooksNoReadArgs hooks pkg_descr = - defaultMainHelper hooks { readDesc = return (Just pkg_descr) } + defaultMainHelper hooks{readDesc = return (Just pkg_descr)} +-- | The central command chooser of the Simple build system, +-- with other defaultMain functions acting as exposed callers, +-- and with 'topHandler' operating as an exceptions handler. +-- +-- This uses 'expandResponse' to read response files, preprocessing +-- response files given by "@" prefixes. +-- +-- Given hooks and args, this runs 'commandsRun' onto the args, +-- 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 - case commandsRun (globalCommand commands) commands args' of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> + 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 (globalVersion flags) -> printVersion | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action - + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action where printHelp help = getProgName >>= putStr . help printOptionsList = putStr . unlines @@ -164,109 +189,135 @@ putStr (intercalate "\n" errs) exitWith (ExitFailure 1) printNumericVersion = putStrLn $ prettyShow cabalVersion - printVersion = putStrLn $ "Cabal library version " - ++ prettyShow cabalVersion + printVersion = + putStrLn $ + "Cabal library version " + ++ prettyShow cabalVersion progs = addKnownPrograms (hookedPrograms hooks) defaultProgramDb commands = - [configureCommand progs `commandAddAction` - \fs as -> configureAction hooks fs as >> return () - ,buildCommand progs `commandAddAction` buildAction hooks - ,replCommand progs `commandAddAction` replAction hooks - ,installCommand `commandAddAction` installAction hooks - ,copyCommand `commandAddAction` copyAction hooks - ,haddockCommand `commandAddAction` haddockAction hooks - ,cleanCommand `commandAddAction` cleanAction hooks - ,sdistCommand `commandAddAction` sdistAction hooks - ,hscolourCommand `commandAddAction` hscolourAction hooks - ,registerCommand `commandAddAction` registerAction hooks - ,unregisterCommand `commandAddAction` unregisterAction hooks - ,testCommand `commandAddAction` testAction hooks - ,benchmarkCommand `commandAddAction` benchAction hooks + [ configureCommand progs + `commandAddAction` \fs as -> configureAction hooks fs as >> return () + , buildCommand progs `commandAddAction` buildAction hooks + , replCommand progs `commandAddAction` replAction hooks + , installCommand `commandAddAction` installAction hooks + , copyCommand `commandAddAction` copyAction hooks + , haddockCommand `commandAddAction` haddockAction hooks + , cleanCommand `commandAddAction` cleanAction hooks + , sdistCommand `commandAddAction` sdistAction hooks + , hscolourCommand `commandAddAction` hscolourAction hooks + , registerCommand `commandAddAction` registerAction hooks + , unregisterCommand `commandAddAction` unregisterAction hooks + , testCommand `commandAddAction` testAction hooks + , benchmarkCommand `commandAddAction` benchAction hooks ] -- | Combine the preprocessors in the given hooks with the -- preprocessors built into cabal. -allSuffixHandlers :: UserHooks - -> [PPSuffixHandler] -allSuffixHandlers hooks - = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers - where - overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] - overridesPP = unionBy (\x y -> fst x == fst y) +allSuffixHandlers + :: UserHooks + -> [PPSuffixHandler] +allSuffixHandlers hooks = + overridesPP (hookedPreProcessors hooks) knownSuffixHandlers + where + overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] + overridesPP = unionBy (\x y -> fst x == fst y) configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo configureAction hooks flags args = do - distPref <- findDistPrefOrDefault (configDistPref flags) - let flags' = flags { configDistPref = toFlag distPref - , configArgs = args } + distPref <- findDistPrefOrDefault (configDistPref flags) + let flags' = + flags + { configDistPref = toFlag distPref + , configArgs = args + } - -- See docs for 'HookedBuildInfo' - pbi <- preConf hooks args flags' + -- See docs for 'HookedBuildInfo' + pbi <- preConf hooks args flags' - (mb_pd_file, pkg_descr0) <- confPkgDescr hooks verbosity - (flagToMaybe (configCabalFilePath flags)) + (mb_pd_file, pkg_descr0) <- + confPkgDescr + hooks + verbosity + (flagToMaybe (configCabalFilePath flags)) - let epkg_descr = (pkg_descr0, pbi) + let epkg_descr = (pkg_descr0, pbi) - localbuildinfo0 <- confHook hooks epkg_descr flags' + localbuildinfo0 <- confHook hooks epkg_descr flags' - -- remember the .cabal filename if we know it - -- and all the extra command line args - let localbuildinfo = localbuildinfo0 { - pkgDescrFile = mb_pd_file, - extraConfigArgs = args - } - writePersistBuildConfig distPref localbuildinfo + -- remember the .cabal filename if we know it + -- and all the extra command line args + let localbuildinfo = + localbuildinfo0 + { pkgDescrFile = mb_pd_file + , extraConfigArgs = args + } + writePersistBuildConfig distPref localbuildinfo - let pkg_descr = localPkgDescr localbuildinfo - postConf hooks args flags' pkg_descr localbuildinfo - return localbuildinfo + let pkg_descr = localPkgDescr localbuildinfo + postConf hooks args flags' pkg_descr localbuildinfo + return localbuildinfo where verbosity = fromFlag (configVerbosity flags) -confPkgDescr :: UserHooks -> Verbosity -> Maybe FilePath - -> IO (Maybe FilePath, GenericPackageDescription) +confPkgDescr + :: UserHooks + -> Verbosity + -> Maybe FilePath + -> IO (Maybe FilePath, GenericPackageDescription) confPkgDescr hooks verbosity mb_path = do mdescr <- readDesc hooks case mdescr of Just descr -> return (Nothing, descr) Nothing -> do - pdfile <- case mb_path of - Nothing -> defaultPackageDesc verbosity - Just path -> return path - info verbosity "Using Parsec parser" - descr <- readGenericPackageDescription verbosity pdfile - return (Just pdfile, descr) + pdfile <- case mb_path of + Nothing -> defaultPackageDesc verbosity + Just path -> return path + info verbosity "Using Parsec parser" + descr <- readGenericPackageDescription verbosity pdfile + return (Just pdfile, descr) buildAction :: UserHooks -> BuildFlags -> Args -> IO () buildAction hooks flags args = do distPref <- findDistPrefOrDefault (buildDistPref flags) let verbosity = fromFlag $ buildVerbosity flags lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { buildDistPref = toFlag distPref - , buildCabalFilePath = maybeToFlag (cabalFilePath lbi)} + let flags' = + flags + { buildDistPref = toFlag distPref + , buildCabalFilePath = maybeToFlag (cabalFilePath lbi) + } - progs <- reconfigurePrograms verbosity - (buildProgramPaths flags') - (buildProgramArgs flags') - (withPrograms lbi) + progs <- + reconfigurePrograms + verbosity + (buildProgramPaths flags') + (buildProgramArgs flags') + (withPrograms lbi) - hookedAction verbosity preBuild buildHook postBuild - (return lbi { withPrograms = progs }) - hooks flags' { buildArgs = args } args + hookedAction + verbosity + preBuild + buildHook + postBuild + (return lbi{withPrograms = progs}) + hooks + flags'{buildArgs = args} + args replAction :: UserHooks -> ReplFlags -> Args -> IO () replAction hooks flags args = do distPref <- findDistPrefOrDefault (replDistPref flags) let verbosity = fromFlag $ replVerbosity flags - flags' = flags { replDistPref = toFlag distPref } + flags' = flags{replDistPref = toFlag distPref} lbi <- getBuildConfig hooks verbosity distPref - progs <- reconfigurePrograms verbosity - (replProgramPaths flags') - (replProgramArgs flags') - (withPrograms lbi) + progs <- + reconfigurePrograms + verbosity + (replProgramPaths flags') + (replProgramArgs flags') + (withPrograms lbi) -- As far as I can tell, the only reason this doesn't use -- 'hookedActionWithArgs' is because the arguments of 'replHook' @@ -275,211 +326,323 @@ let pkg_descr0 = localPkgDescr lbi sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi let pkg_descr = updatePackageDescription pbi pkg_descr0 - lbi' = lbi { withPrograms = progs - , localPkgDescr = pkg_descr } + lbi' = + lbi + { withPrograms = progs + , localPkgDescr = pkg_descr + } replHook hooks pkg_descr lbi' hooks flags' args postRepl hooks args flags' pkg_descr lbi' hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () hscolourAction hooks flags args = do - distPref <- findDistPrefOrDefault (hscolourDistPref flags) - let verbosity = fromFlag $ hscolourVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { hscolourDistPref = toFlag distPref - , hscolourCabalFilePath = maybeToFlag (cabalFilePath lbi)} + distPref <- findDistPrefOrDefault (hscolourDistPref flags) + let verbosity = fromFlag $ hscolourVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = + flags + { hscolourDistPref = toFlag distPref + , hscolourCabalFilePath = maybeToFlag (cabalFilePath lbi) + } - hookedAction verbosity preHscolour hscolourHook postHscolour - (getBuildConfig hooks verbosity distPref) - hooks flags' args + hookedAction + verbosity + preHscolour + hscolourHook + postHscolour + (getBuildConfig hooks verbosity distPref) + hooks + flags' + args haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () haddockAction hooks flags args = do distPref <- findDistPrefOrDefault (haddockDistPref flags) let verbosity = fromFlag $ haddockVerbosity flags lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { haddockDistPref = toFlag distPref - , haddockCabalFilePath = maybeToFlag (cabalFilePath lbi)} + let flags' = + flags + { haddockDistPref = toFlag distPref + , haddockCabalFilePath = maybeToFlag (cabalFilePath lbi) + } - progs <- reconfigurePrograms verbosity - (haddockProgramPaths flags') - (haddockProgramArgs flags') - (withPrograms lbi) + progs <- + reconfigurePrograms + verbosity + (haddockProgramPaths flags') + (haddockProgramArgs flags') + (withPrograms lbi) - hookedAction verbosity preHaddock haddockHook postHaddock - (return lbi { withPrograms = progs }) - hooks flags' { haddockArgs = args } args + hookedAction + verbosity + preHaddock + haddockHook + postHaddock + (return lbi{withPrograms = progs}) + hooks + flags'{haddockArgs = args} + args cleanAction :: UserHooks -> CleanFlags -> Args -> IO () cleanAction hooks flags args = do - distPref <- findDistPrefOrDefault (cleanDistPref flags) + distPref <- findDistPrefOrDefault (cleanDistPref flags) - elbi <- tryGetBuildConfig hooks verbosity distPref - let flags' = flags { cleanDistPref = toFlag distPref - , cleanCabalFilePath = case elbi of - Left _ -> mempty - Right lbi -> maybeToFlag (cabalFilePath lbi)} + elbi <- tryGetBuildConfig hooks verbosity distPref + let flags' = + flags + { cleanDistPref = toFlag distPref + , cleanCabalFilePath = case elbi of + Left _ -> mempty + Right lbi -> maybeToFlag (cabalFilePath lbi) + } - pbi <- preClean hooks args flags' + pbi <- preClean hooks args flags' - (_, ppd) <- confPkgDescr hooks verbosity Nothing - -- It might seem like we are doing something clever here - -- but we're really not: if you look at the implementation - -- of 'clean' in the end all the package description is - -- used for is to clear out @extra-tmp-files@. IMO, - -- the configure script goo should go into @dist@ too! - -- -- ezyang - let pkg_descr0 = flattenPackageDescription ppd - -- We don't sanity check for clean as an error - -- here would prevent cleaning: - --sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi - let pkg_descr = updatePackageDescription pbi pkg_descr0 + (_, ppd) <- confPkgDescr hooks verbosity Nothing + -- It might seem like we are doing something clever here + -- but we're really not: if you look at the implementation + -- of 'clean' in the end all the package description is + -- used for is to clear out @extra-tmp-files@. IMO, + -- the configure script goo should go into @dist@ too! + -- -- ezyang + let pkg_descr0 = flattenPackageDescription ppd + -- We don't sanity check for clean as an error + -- here would prevent cleaning: + -- sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 - cleanHook hooks pkg_descr () hooks flags' - postClean hooks args flags' pkg_descr () + cleanHook hooks pkg_descr () hooks flags' + postClean hooks args flags' pkg_descr () where verbosity = fromFlag (cleanVerbosity flags) copyAction :: UserHooks -> CopyFlags -> Args -> IO () copyAction hooks flags args = do - distPref <- findDistPrefOrDefault (copyDistPref flags) - let verbosity = fromFlag $ copyVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { copyDistPref = toFlag distPref - , copyCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preCopy copyHook postCopy - (getBuildConfig hooks verbosity distPref) - hooks flags' { copyArgs = args } args + distPref <- findDistPrefOrDefault (copyDistPref flags) + let verbosity = fromFlag $ copyVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = + flags + { copyDistPref = toFlag distPref + , copyCabalFilePath = maybeToFlag (cabalFilePath lbi) + } + hookedAction + verbosity + preCopy + copyHook + postCopy + (getBuildConfig hooks verbosity distPref) + hooks + flags'{copyArgs = args} + args installAction :: UserHooks -> InstallFlags -> Args -> IO () installAction hooks flags args = do - distPref <- findDistPrefOrDefault (installDistPref flags) - let verbosity = fromFlag $ installVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { installDistPref = toFlag distPref - , installCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preInst instHook postInst - (getBuildConfig hooks verbosity distPref) - hooks flags' args + distPref <- findDistPrefOrDefault (installDistPref flags) + let verbosity = fromFlag $ installVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = + flags + { installDistPref = toFlag distPref + , installCabalFilePath = maybeToFlag (cabalFilePath lbi) + } + hookedAction + verbosity + preInst + instHook + postInst + (getBuildConfig hooks verbosity distPref) + hooks + flags' + args -- Since Cabal-3.4 UserHooks are completely ignored sdistAction :: UserHooks -> SDistFlags -> Args -> IO () sdistAction _hooks flags _args = do - (_, ppd) <- confPkgDescr emptyUserHooks verbosity Nothing - let pkg_descr = flattenPackageDescription ppd - sdist pkg_descr flags srcPref knownSuffixHandlers + (_, ppd) <- confPkgDescr emptyUserHooks verbosity Nothing + let pkg_descr = flattenPackageDescription ppd + sdist pkg_descr flags srcPref knownSuffixHandlers where verbosity = fromFlag (sDistVerbosity flags) testAction :: UserHooks -> TestFlags -> Args -> IO () testAction hooks flags args = do - distPref <- findDistPrefOrDefault (testDistPref flags) - let verbosity = fromFlag $ testVerbosity flags - flags' = flags { testDistPref = toFlag distPref } + distPref <- findDistPrefOrDefault (testDistPref flags) + let verbosity = fromFlag $ testVerbosity flags + flags' = flags{testDistPref = toFlag distPref} - hookedActionWithArgs verbosity preTest testHook postTest - (getBuildConfig hooks verbosity distPref) - hooks flags' args + hookedActionWithArgs + verbosity + preTest + testHook + postTest + (getBuildConfig hooks verbosity distPref) + hooks + flags' + args benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO () benchAction hooks flags args = do - distPref <- findDistPrefOrDefault (benchmarkDistPref flags) - let verbosity = fromFlag $ benchmarkVerbosity flags - flags' = flags { benchmarkDistPref = toFlag distPref } - hookedActionWithArgs verbosity preBench benchHook postBench - (getBuildConfig hooks verbosity distPref) - hooks flags' args + distPref <- findDistPrefOrDefault (benchmarkDistPref flags) + let verbosity = fromFlag $ benchmarkVerbosity flags + flags' = flags{benchmarkDistPref = toFlag distPref} + hookedActionWithArgs + verbosity + preBench + benchHook + postBench + (getBuildConfig hooks verbosity distPref) + hooks + flags' + args registerAction :: UserHooks -> RegisterFlags -> Args -> IO () registerAction hooks flags args = do - distPref <- findDistPrefOrDefault (regDistPref flags) - let verbosity = fromFlag $ regVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { regDistPref = toFlag distPref - , regCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preReg regHook postReg - (getBuildConfig hooks verbosity distPref) - hooks flags' { regArgs = args } args + distPref <- findDistPrefOrDefault (regDistPref flags) + let verbosity = fromFlag $ regVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = + flags + { regDistPref = toFlag distPref + , regCabalFilePath = maybeToFlag (cabalFilePath lbi) + } + hookedAction + verbosity + preReg + regHook + postReg + (getBuildConfig hooks verbosity distPref) + hooks + flags'{regArgs = args} + args unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () unregisterAction hooks flags args = do - distPref <- findDistPrefOrDefault (regDistPref flags) - let verbosity = fromFlag $ regVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { regDistPref = toFlag distPref - , regCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preUnreg unregHook postUnreg - (getBuildConfig hooks verbosity distPref) - hooks flags' args + distPref <- findDistPrefOrDefault (regDistPref flags) + let verbosity = fromFlag $ regVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = + flags + { regDistPref = toFlag distPref + , regCabalFilePath = maybeToFlag (cabalFilePath lbi) + } + hookedAction + verbosity + preUnreg + unregHook + postUnreg + (getBuildConfig hooks verbosity distPref) + hooks + flags' + args hookedAction :: Verbosity -> (UserHooks -> Args -> flags -> IO HookedBuildInfo) - -> (UserHooks -> PackageDescription -> LocalBuildInfo - -> UserHooks -> flags -> IO ()) - -> (UserHooks -> Args -> flags -> PackageDescription - -> LocalBuildInfo -> IO ()) + -> ( UserHooks + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> flags + -> IO () + ) + -> ( UserHooks + -> Args + -> flags + -> PackageDescription + -> LocalBuildInfo + -> IO () + ) -> IO LocalBuildInfo - -> UserHooks -> flags -> Args -> IO () + -> UserHooks + -> flags + -> Args + -> IO () hookedAction verbosity pre_hook cmd_hook = - hookedActionWithArgs verbosity pre_hook - (\h _ pd lbi uh flags -> - cmd_hook h pd lbi uh flags) + hookedActionWithArgs + verbosity + pre_hook + ( \h _ pd lbi uh flags -> + cmd_hook h pd lbi uh flags + ) hookedActionWithArgs :: Verbosity -> (UserHooks -> Args -> flags -> IO HookedBuildInfo) - -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo - -> UserHooks -> flags -> IO ()) - -> (UserHooks -> Args -> flags -> PackageDescription - -> LocalBuildInfo -> IO ()) + -> ( UserHooks + -> Args + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> flags + -> IO () + ) + -> ( UserHooks + -> Args + -> flags + -> PackageDescription + -> LocalBuildInfo + -> IO () + ) -> IO LocalBuildInfo - -> UserHooks -> flags -> Args -> IO () -hookedActionWithArgs verbosity pre_hook cmd_hook post_hook - get_build_config hooks flags args = do - pbi <- pre_hook hooks args flags - lbi0 <- get_build_config - let pkg_descr0 = localPkgDescr lbi0 - sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi - let pkg_descr = updatePackageDescription pbi pkg_descr0 - lbi = lbi0 { localPkgDescr = pkg_descr } - cmd_hook hooks args pkg_descr lbi hooks flags - post_hook hooks args flags pkg_descr lbi + -> UserHooks + -> flags + -> Args + -> IO () +hookedActionWithArgs + verbosity + pre_hook + cmd_hook + post_hook + get_build_config + hooks + flags + args = do + pbi <- pre_hook hooks args flags + lbi0 <- get_build_config + let pkg_descr0 = localPkgDescr lbi0 + sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + lbi = lbi0{localPkgDescr = pkg_descr} + cmd_hook hooks args pkg_descr lbi hooks flags + post_hook hooks args flags pkg_descr lbi sanityCheckHookedBuildInfo :: Verbosity -> PackageDescription -> HookedBuildInfo -> IO () -sanityCheckHookedBuildInfo verbosity - (PackageDescription { library = Nothing }) (Just _,_) - = die' verbosity $ "The buildinfo contains info for a library, " - ++ "but the package does not have a library." - +sanityCheckHookedBuildInfo + verbosity + (PackageDescription{library = Nothing}) + (Just _, _) = + dieWithException verbosity $ NoLibraryForPackage sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes) - | exe1 : _ <- nonExistant - = die' verbosity $ "The buildinfo contains info for an executable called '" - ++ prettyShow exe1 ++ "' but the package does not have a " - ++ "executable with that name." + | exe1 : _ <- nonExistant = + dieWithException verbosity $ SanityCheckHookedBuildInfo exe1 where - pkgExeNames = nub (map exeName (executables pkg_descr)) + pkgExeNames = nub (map exeName (executables pkg_descr)) hookExeNames = nub (map fst hookExes) - nonExistant = hookExeNames \\ pkgExeNames - + nonExistant = hookExeNames \\ pkgExeNames sanityCheckHookedBuildInfo _ _ _ = return () -- | Try to read the 'localBuildInfoFile' -tryGetBuildConfig :: UserHooks -> Verbosity -> FilePath - -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetBuildConfig + :: UserHooks + -> Verbosity + -> FilePath + -> IO (Either ConfigStateFileError LocalBuildInfo) tryGetBuildConfig u v = try . getBuildConfig u v - -- | Read the 'localBuildInfoFile' or throw an exception. getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo getBuildConfig hooks verbosity distPref = do lbi_wo_programs <- getPersistBuildConfig distPref -- Restore info about unconfigured programs, since it is not serialized - let lbi = lbi_wo_programs { - withPrograms = restoreProgramDb - (builtinPrograms ++ hookedPrograms hooks) - (withPrograms lbi_wo_programs) - } + let lbi = + lbi_wo_programs + { withPrograms = + restoreProgramDb + (builtinPrograms ++ hookedPrograms hooks) + (withPrograms lbi_wo_programs) + } case pkgDescrFile lbi of Nothing -> return lbi @@ -488,60 +651,64 @@ if outdated then reconfigure pkg_descr_file lbi else return lbi - where reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo reconfigure pkg_descr_file lbi = do - notice verbosity $ pkg_descr_file ++ " has been changed. " - ++ "Re-configuring with most recently used options. " - ++ "If this fails, please run configure manually.\n" + notice verbosity $ + pkg_descr_file + ++ " has been changed. " + ++ "Re-configuring with most recently used options. " + ++ "If this fails, please run configure manually.\n" let cFlags = configFlags lbi - let cFlags' = cFlags { - -- Since the list of unconfigured programs is not serialized, - -- restore it to the same value as normally used at the beginning - -- of a configure run: - configPrograms_ = fmap (restoreProgramDb - (builtinPrograms ++ hookedPrograms hooks)) - `fmap` configPrograms_ cFlags, - - -- Use the current, not saved verbosity level: - configVerbosity = Flag verbosity - } + let cFlags' = + cFlags + { -- Since the list of unconfigured programs is not serialized, + -- restore it to the same value as normally used at the beginning + -- of a configure run: + configPrograms_ = + fmap + ( restoreProgramDb + (builtinPrograms ++ hookedPrograms hooks) + ) + `fmap` configPrograms_ cFlags + , -- Use the current, not saved verbosity level: + configVerbosity = Flag verbosity + } configureAction hooks cFlags' (extraConfigArgs lbi) - -- -------------------------------------------------------------------------- -- Cleaning clean :: PackageDescription -> CleanFlags -> IO () clean pkg_descr flags = do - let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags - notice verbosity "cleaning..." - - maybeConfig <- if fromFlag (cleanSaveConf flags) - then maybeGetPersistBuildConfig distPref - else return Nothing + let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags + notice verbosity "cleaning..." - -- remove the whole dist/ directory rather than tracking exactly what files - -- we created in there. - chattyTry "removing dist/" $ do - exists <- doesDirectoryExist distPref - when exists (removeDirectoryRecursive distPref) + maybeConfig <- + if fromFlag (cleanSaveConf flags) + then maybeGetPersistBuildConfig distPref + else return Nothing - -- Any extra files the user wants to remove - traverse_ removeFileOrDirectory (extraTmpFiles pkg_descr) + -- remove the whole dist/ directory rather than tracking exactly what files + -- we created in there. + chattyTry "removing dist/" $ do + exists <- doesDirectoryExist distPref + when exists (removeDirectoryRecursive distPref) - -- If the user wanted to save the config, write it back - traverse_ (writePersistBuildConfig distPref) maybeConfig + -- Any extra files the user wants to remove + traverse_ removeFileOrDirectory (extraTmpFiles pkg_descr) + -- If the user wanted to save the config, write it back + traverse_ (writePersistBuildConfig 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 - verbosity = fromFlag (cleanVerbosity flags) + removeFileOrDirectory :: FilePath -> IO () + removeFileOrDirectory fname = do + isDir <- doesDirectoryExist fname + isFile <- doesFileExist fname + if isDir + then removeDirectoryRecursive fname + else when isFile $ removeFile fname + verbosity = fromFlag (cleanVerbosity flags) -- -------------------------------------------------------------------------- -- Default hooks @@ -550,22 +717,22 @@ -- \"simple\" build system simpleUserHooks :: UserHooks simpleUserHooks = - emptyUserHooks { - confHook = configure, - postConf = finalChecks, - buildHook = defaultBuildHook, - replHook = defaultReplHook, - copyHook = \desc lbi _ f -> install desc lbi f, - -- 'install' has correct 'copy' behavior with params - testHook = defaultTestHook, - benchHook = defaultBenchHook, - instHook = defaultInstallHook, - 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 - } + emptyUserHooks + { confHook = configure + , postConf = finalChecks + , buildHook = defaultBuildHook + , replHook = defaultReplHook + , copyHook = \desc lbi _ f -> install desc lbi f + , -- 'install' has correct 'copy' behavior with params + testHook = defaultTestHook + , benchHook = defaultBenchHook + , instHook = defaultInstallHook + , 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 + } where finalChecks _args flags pkg_descr lbi = checkForeignDeps pkg_descr lbi (lessVerbose verbosity) @@ -581,112 +748,158 @@ -- -- Thus @configure@ can use local system information to generate -- /package/@.buildinfo@ and possibly other files. - autoconfUserHooks :: UserHooks -autoconfUserHooks - = simpleUserHooks - { - postConf = defaultPostConf, - preBuild = readHookWithArgs buildVerbosity buildDistPref, - preRepl = readHookWithArgs replVerbosity replDistPref, - preCopy = readHookWithArgs copyVerbosity copyDistPref, - preClean = readHook cleanVerbosity cleanDistPref, - preInst = readHook installVerbosity installDistPref, - preHscolour = readHook hscolourVerbosity hscolourDistPref, - preHaddock = readHookWithArgs haddockVerbosity haddockDistPref, - preReg = readHook regVerbosity regDistPref, - preUnreg = readHook regVerbosity regDistPref, - preTest = readHookWithArgs testVerbosity testDistPref, - preBench = readHookWithArgs benchmarkVerbosity benchmarkDistPref - } - where defaultPostConf :: Args -> ConfigFlags -> PackageDescription - -> LocalBuildInfo -> IO () - defaultPostConf args flags pkg_descr lbi - = do let verbosity = fromFlag (configVerbosity flags) - baseDir lbi' = fromMaybe "" - (takeDirectory <$> cabalFilePath lbi') - confExists <- doesFileExist $ (baseDir lbi) "configure" - if confExists - then runConfigureScript verbosity - flags lbi - else die' verbosity "configure script not found." +autoconfUserHooks = + simpleUserHooks + { postConf = defaultPostConf + , preBuild = readHookWithArgs buildVerbosity buildDistPref + , preRepl = readHookWithArgs replVerbosity replDistPref + , preCopy = readHookWithArgs copyVerbosity copyDistPref + , preClean = readHook cleanVerbosity cleanDistPref + , preInst = readHook installVerbosity installDistPref + , preHscolour = readHook hscolourVerbosity hscolourDistPref + , preHaddock = readHookWithArgs haddockVerbosity haddockDistPref + , preReg = readHook regVerbosity regDistPref + , preUnreg = readHook regVerbosity regDistPref + , preTest = readHookWithArgs testVerbosity testDistPref + , preBench = readHookWithArgs benchmarkVerbosity benchmarkDistPref + } + where + defaultPostConf + :: Args + -> ConfigFlags + -> PackageDescription + -> LocalBuildInfo + -> IO () + defaultPostConf args flags pkg_descr lbi = + do + let verbosity = fromFlag (configVerbosity flags) + baseDir lbi' = + fromMaybe + "" + (takeDirectory <$> cabalFilePath lbi') + confExists <- doesFileExist $ (baseDir lbi) "configure" + if confExists + then + runConfigureScript + verbosity + flags + lbi + else dieWithException verbosity ConfigureScriptNotFound - pbi <- getHookedBuildInfo verbosity (buildDir lbi) - sanityCheckHookedBuildInfo verbosity pkg_descr pbi - let pkg_descr' = updatePackageDescription pbi pkg_descr - lbi' = lbi { localPkgDescr = pkg_descr' } - postConf simpleUserHooks args flags pkg_descr' lbi' + pbi <- getHookedBuildInfo verbosity (buildDir lbi) + sanityCheckHookedBuildInfo verbosity pkg_descr pbi + let pkg_descr' = updatePackageDescription pbi pkg_descr + lbi' = lbi{localPkgDescr = pkg_descr'} + postConf simpleUserHooks args flags pkg_descr' lbi' - readHookWithArgs :: (a -> Flag Verbosity) - -> (a -> Flag FilePath) - -> Args -> a - -> IO HookedBuildInfo - readHookWithArgs get_verbosity get_dist_pref _ flags = do - dist_dir <- findDistPrefOrDefault (get_dist_pref flags) - getHookedBuildInfo verbosity (dist_dir "build") - where - verbosity = fromFlag (get_verbosity flags) + readHookWithArgs + :: (a -> Flag Verbosity) + -> (a -> Flag FilePath) + -> Args + -> a + -> IO HookedBuildInfo + readHookWithArgs get_verbosity get_dist_pref _ flags = do + dist_dir <- findDistPrefOrDefault (get_dist_pref flags) + getHookedBuildInfo verbosity (dist_dir "build") + where + verbosity = fromFlag (get_verbosity flags) - readHook :: (a -> Flag Verbosity) - -> (a -> Flag FilePath) - -> Args -> a -> IO HookedBuildInfo - readHook get_verbosity get_dist_pref a flags = do - noExtraFlags a - dist_dir <- findDistPrefOrDefault (get_dist_pref flags) - getHookedBuildInfo verbosity (dist_dir "build") - where - verbosity = fromFlag (get_verbosity flags) + readHook + :: (a -> Flag Verbosity) + -> (a -> Flag FilePath) + -> Args + -> a + -> IO HookedBuildInfo + readHook get_verbosity get_dist_pref a flags = do + noExtraFlags a + dist_dir <- findDistPrefOrDefault (get_dist_pref flags) + getHookedBuildInfo verbosity (dist_dir "build") + where + verbosity = fromFlag (get_verbosity flags) getHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo getHookedBuildInfo verbosity build_dir = do maybe_infoFile <- findHookedPackageDesc verbosity build_dir case maybe_infoFile of - Nothing -> return emptyHookedBuildInfo + Nothing -> return emptyHookedBuildInfo Just infoFile -> do info verbosity $ "Reading parameters from " ++ infoFile readHookedBuildInfo verbosity infoFile -defaultTestHook :: Args -> PackageDescription -> LocalBuildInfo - -> UserHooks -> TestFlags -> IO () +defaultTestHook + :: Args + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> TestFlags + -> IO () defaultTestHook args pkg_descr localbuildinfo _ flags = - test args pkg_descr localbuildinfo flags + test args pkg_descr localbuildinfo flags -defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo - -> UserHooks -> BenchmarkFlags -> IO () +defaultBenchHook + :: Args + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BenchmarkFlags + -> IO () defaultBenchHook args pkg_descr localbuildinfo _ flags = - bench args pkg_descr localbuildinfo flags + bench args pkg_descr localbuildinfo flags -defaultInstallHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> InstallFlags -> IO () +defaultInstallHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> InstallFlags + -> IO () defaultInstallHook pkg_descr localbuildinfo _ flags = do - let copyFlags = defaultCopyFlags { - copyDistPref = installDistPref flags, - copyDest = installDest flags, - copyVerbosity = installVerbosity flags - } + let copyFlags = + defaultCopyFlags + { copyDistPref = installDistPref flags + , copyDest = installDest flags + , copyVerbosity = installVerbosity flags + } install pkg_descr localbuildinfo copyFlags - let registerFlags = defaultRegisterFlags { - regDistPref = installDistPref flags, - regInPlace = installInPlace flags, - regPackageDB = installPackageDB flags, - regVerbosity = installVerbosity flags - } + let registerFlags = + defaultRegisterFlags + { regDistPref = installDistPref flags + , regInPlace = installInPlace flags + , regPackageDB = installPackageDB flags + , regVerbosity = installVerbosity flags + } when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags -defaultBuildHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> BuildFlags -> IO () +defaultBuildHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BuildFlags + -> IO () defaultBuildHook pkg_descr localbuildinfo hooks flags = build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) -defaultReplHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> ReplFlags -> [String] -> IO () +defaultReplHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> ReplFlags + -> [String] + -> IO () defaultReplHook pkg_descr localbuildinfo hooks flags args = repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args -defaultRegHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> RegisterFlags -> IO () +defaultRegHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> RegisterFlags + -> IO () defaultRegHook pkg_descr localbuildinfo _ flags = - if hasLibs pkg_descr + if hasLibs pkg_descr then register pkg_descr localbuildinfo flags - else setupMessage (fromFlag (regVerbosity flags)) - "Package contains no library to register:" (packageId pkg_descr) + else + setupMessage + (fromFlag (regVerbosity flags)) + "Package contains no library to register:" + (packageId pkg_descr) 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 @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Bench -- Copyright : Johan Tibell 2011 @@ -13,113 +14,130 @@ -- This is the entry point into running the benchmarks in a built -- package. It performs the \"@.\/setup bench@\" action. It runs -- benchmarks designated in the package description. - module Distribution.Simple.Bench - ( bench - ) where + ( bench + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD +import Distribution.Pretty import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler +import Distribution.Simple.Flag (fromFlag) import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.Setup +import Distribution.Simple.Setup.Benchmark import Distribution.Simple.UserHooks import Distribution.Simple.Utils -import Distribution.Pretty -import System.Directory ( doesFileExist ) -import System.FilePath ( (), (<.>) ) +import Distribution.Types.UnqualComponentName +import Distribution.Simple.Errors +import System.Directory (doesFileExist) +import System.FilePath ((<.>), ()) + -- | Perform the \"@.\/setup bench@\" action. -bench :: Args -- ^positional command-line arguments - -> PD.PackageDescription -- ^information from the .cabal file - -> LBI.LocalBuildInfo -- ^information from the configure step - -> BenchmarkFlags -- ^flags sent to benchmark - -> IO () +bench + :: Args + -- ^ positional command-line arguments + -> PD.PackageDescription + -- ^ information from the .cabal file + -> LBI.LocalBuildInfo + -- ^ information from the configure step + -> BenchmarkFlags + -- ^ flags sent to benchmark + -> IO () bench args pkg_descr lbi flags = do - let verbosity = fromFlag $ benchmarkVerbosity flags - benchmarkNames = args - pkgBenchmarks = PD.benchmarks pkg_descr - enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi) - - -- Run the benchmark - doBench :: PD.Benchmark -> IO ExitCode - doBench bm = - case PD.benchmarkInterface bm of - PD.BenchmarkExeV10 _ _ -> do - let cmd = LBI.buildDir lbi name name <.> exeExtension (LBI.hostPlatform lbi) - options = map (benchOption pkg_descr lbi bm) $ - benchmarkOptions flags - -- Check that the benchmark executable exists. - exists <- doesFileExist cmd - unless exists $ die' verbosity $ - "Could not find benchmark program \"" - ++ cmd ++ "\". Did you build the package first?" + let verbosity = fromFlag $ benchmarkVerbosity flags + benchmarkNames = args + pkgBenchmarks = PD.benchmarks pkg_descr + enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi) - notice verbosity $ startMessage name - -- This will redirect the child process - -- stdout/stderr to the parent process. - exitcode <- rawSystemExitCode verbosity cmd options - notice verbosity $ finishMessage name exitcode - return exitcode + -- Run the benchmark + doBench :: PD.Benchmark -> IO ExitCode + doBench bm = + case PD.benchmarkInterface bm of + PD.BenchmarkExeV10 _ _ -> do + let cmd = LBI.buildDir lbi name name <.> exeExtension (LBI.hostPlatform lbi) + options = + map (benchOption pkg_descr lbi bm) $ + benchmarkOptions flags + -- Check that the benchmark executable exists. + exists <- doesFileExist cmd + unless exists $ + dieWithException verbosity $ + NoBenchMarkProgram cmd - _ -> do - notice verbosity $ "No support for running " - ++ "benchmark " ++ name ++ " of type: " - ++ prettyShow (PD.benchmarkType bm) - exitFailure - where name = unUnqualComponentName $ PD.benchmarkName bm + notice verbosity $ startMessage name + -- This will redirect the child process + -- stdout/stderr to the parent process. + exitcode <- rawSystemExitCode verbosity cmd options + notice verbosity $ finishMessage name exitcode + return exitcode + _ -> do + notice verbosity $ + "No support for running " + ++ "benchmark " + ++ name + ++ " of type: " + ++ prettyShow (PD.benchmarkType bm) + exitFailure + where + name = unUnqualComponentName $ PD.benchmarkName bm - unless (PD.hasBenchmarks pkg_descr) $ do - notice verbosity "Package has no benchmarks." - exitSuccess + unless (PD.hasBenchmarks pkg_descr) $ do + notice verbosity "Package has no benchmarks." + exitSuccess - when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ - die' verbosity $ "No benchmarks enabled. Did you remember to configure with " - ++ "\'--enable-benchmarks\'?" + when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ + dieWithException verbosity EnableBenchMark - bmsToRun <- case benchmarkNames of - [] -> return enabledBenchmarks - names -> for names $ \bmName -> - let benchmarkMap = zip enabledNames enabledBenchmarks - enabledNames = map PD.benchmarkName enabledBenchmarks - allNames = map PD.benchmarkName pkgBenchmarks - in case lookup (mkUnqualComponentName bmName) benchmarkMap of - Just t -> return t - _ | mkUnqualComponentName bmName `elem` allNames -> - die' verbosity $ "Package configured with benchmark " - ++ bmName ++ " disabled." - | otherwise -> die' verbosity $ "no such benchmark: " ++ bmName + bmsToRun <- case benchmarkNames of + [] -> return enabledBenchmarks + names -> for names $ \bmName -> + let benchmarkMap = zip enabledNames enabledBenchmarks + enabledNames = map PD.benchmarkName enabledBenchmarks + allNames = map PD.benchmarkName pkgBenchmarks + in case lookup (mkUnqualComponentName bmName) benchmarkMap of + Just t -> return t + _ + | mkUnqualComponentName bmName `elem` allNames -> + dieWithException verbosity $ BenchMarkNameDisabled bmName + | otherwise -> dieWithException verbosity $ NoBenchMark bmName - let totalBenchmarks = length bmsToRun - notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." - exitcodes <- traverse doBench bmsToRun - let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) - unless allOk exitFailure + let totalBenchmarks = length bmsToRun + notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." + exitcodes <- traverse doBench bmsToRun + let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) + unless allOk exitFailure where startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n" - finishMessage name exitcode = "Benchmark " ++ name ++ ": " - ++ (case exitcode of - ExitSuccess -> "FINISH" - ExitFailure _ -> "ERROR") - + finishMessage name exitcode = + "Benchmark " + ++ name + ++ ": " + ++ ( case exitcode of + ExitSuccess -> "FINISH" + ExitFailure _ -> "ERROR" + ) -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path. -benchOption :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> PD.Benchmark - -> PathTemplate - -> String +benchOption + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.Benchmark + -> PathTemplate + -> String benchOption pkg_descr lbi bm template = - fromPathTemplate $ substPathTemplate env template + fromPathTemplate $ substPathTemplate env template where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)] + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName 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 @@ -1,829 +1,1049 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Build --- Copyright : Isaac Jones 2003-2005, --- Ross Paterson 2006, --- Duncan Coutts 2007-2008, 2012 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the entry point to actually building the modules in a package. It --- doesn't actually do much itself, most of the work is delegated to --- compiler-specific actions. It does do some non-compiler specific bits like --- running pre-processors. --- - -module Distribution.Simple.Build ( - build, repl, - startInterpreter, - - initialBuildSteps, - createInternalPackageDB, - componentInitialBuildSteps, - writeAutogenFiles, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.Generic - -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.Dependency -import Distribution.Types.ExecutableScope -import Distribution.Types.ForeignLib -import Distribution.Types.LibraryVisibility -import Distribution.Types.LocalBuildInfo -import Distribution.Types.MungedPackageId -import Distribution.Types.MungedPackageName -import Distribution.Types.ModuleRenaming -import Distribution.Types.TargetInfo -import Distribution.Utils.Path - -import Distribution.Package -import Distribution.Backpack -import Distribution.Backpack.DescribeUnitId -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC -import qualified Distribution.Simple.HaskellSuite as HaskellSuite -import qualified Distribution.Simple.PackageIndex as Index - -import Distribution.Simple.Build.Macros (generateCabalMacrosHeader) -import Distribution.Simple.Build.PackageInfoModule (generatePackageInfoModule) -import Distribution.Simple.Build.PathsModule (generatePathsModule) -import qualified Distribution.Simple.Program.HcPkg as HcPkg - -import Distribution.Simple.Compiler -import Distribution.PackageDescription -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.ModuleName as ModuleName - -import Distribution.Simple.Setup -import Distribution.Simple.BuildTarget -import Distribution.Simple.BuildToolDepends -import Distribution.Simple.PreProcess -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program -import Distribution.Simple.Program.Builtin (haskellSuiteProgram) -import qualified Distribution.Simple.Program.GHC as GHC -import Distribution.Simple.Program.Types -import Distribution.Simple.ShowBuildInfo -import Distribution.Simple.BuildPaths -import Distribution.Simple.Configure -import Distribution.Simple.Register -import Distribution.Simple.Test.LibV09 -import Distribution.Simple.Utils -import Distribution.Utils.Json - -import Distribution.System -import Distribution.Pretty -import Distribution.Verbosity -import Distribution.Version (thisVersion) - -import Distribution.Compat.Graph (IsNode(..)) - -import Control.Monad -import qualified Data.ByteString.Lazy as LBS -import System.FilePath ( (), (<.>), takeDirectory ) -import System.Directory ( getCurrentDirectory, removeFile, doesFileExist ) - --- ----------------------------------------------------------------------------- --- |Build the libraries and executables in this package. - -build :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build - -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling - -> IO () -build pkg_descr lbi flags suffixes = do - targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags) - let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) - info verbosity $ "Component build order: " - ++ intercalate ", " - (map (showComponentName . componentLocalName . targetCLBI) - componentsToBuild) - - when (null targets) $ - -- Only bother with this message if we're building the whole package - setupMessage verbosity "Building" (packageId pkg_descr) - - internalPackageDB <- createInternalPackageDB verbosity lbi distPref - - -- Before the actual building, dump out build-information. - -- This way, if the actual compilation failed, the options have still been - -- dumped. - dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags lbi)) pkg_descr lbi flags - - -- Now do the actual building - (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do - let comp = targetComponent target - clbi = targetCLBI target - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - let bi = componentBuildInfo comp - progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) - lbi' = lbi { - withPrograms = progs', - withPackageDB = withPackageDB lbi ++ [internalPackageDB], - installedPkgs = index - } - mb_ipi <- buildComponent verbosity (buildNumJobs flags) pkg_descr - lbi' suffixes comp clbi distPref - return (maybe index (Index.insert `flip` index) mb_ipi) - - return () - where - distPref = fromFlag (buildDistPref flags) - verbosity = fromFlag (buildVerbosity flags) - - --- | Write available build information for 'LocalBuildInfo' to disk. --- --- Dumps detailed build information 'build-info.json' to the given directory. --- Build information contains basics such as compiler details, but also --- lists what modules a component contains and how to compile the component, assuming --- lib:Cabal made sure that dependencies are up-to-date. -dumpBuildInfo :: Verbosity - -> FilePath -- ^ To which directory should the build-info be dumped? - -> Flag DumpBuildInfo -- ^ Should we dump detailed build information for this component? - -> PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build - -> IO () -dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do - when shouldDumpBuildInfo $ do - -- Changing this line might break consumers of the dumped build info. - -- Announce changes on mailing lists! - let activeTargets = allTargetsInBuildOrder' pkg_descr lbi - info verbosity $ "Dump build information for: " - ++ intercalate ", " - (map (showComponentName . componentLocalName . targetCLBI) - activeTargets) - pwd <- getCurrentDirectory - - (compilerProg, _) <- case flavorToProgram (compilerFlavor (compiler lbi)) of - Nothing -> die' verbosity $ "dumpBuildInfo: Unknown compiler flavor: " - ++ show (compilerFlavor (compiler lbi)) - Just program -> requireProgram verbosity program (withPrograms lbi) - - let (warns, json) = mkBuildInfo pwd pkg_descr lbi flags (compilerProg, compiler lbi) activeTargets - buildInfoText = renderJson json - unless (null warns) $ - warn verbosity $ "Encountered warnings while dumping build-info:\n" - ++ unlines warns - LBS.writeFile (buildInfoPref distPref) buildInfoText - - when (not shouldDumpBuildInfo) $ do - -- Remove existing build-info.json as it might be outdated now. - exists <- doesFileExist (buildInfoPref distPref) - when exists $ removeFile (buildInfoPref distPref) - where - shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo - - -- | Given the flavor of the compiler, try to find out - -- which program we need. - flavorToProgram :: CompilerFlavor -> Maybe Program - flavorToProgram GHC = Just ghcProgram - flavorToProgram GHCJS = Just ghcjsProgram - flavorToProgram UHC = Just uhcProgram - flavorToProgram JHC = Just jhcProgram - flavorToProgram HaskellSuite {} = Just haskellSuiteProgram - flavorToProgram _ = Nothing - - -repl :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> ReplFlags -- ^ Flags that the user passed to build - -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling - -> [String] - -> IO () -repl pkg_descr lbi flags suffixes args = do - let distPref = fromFlag (replDistPref flags) - verbosity = fromFlag (replVerbosity flags) - - target <- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of - -- This seems DEEPLY questionable. - [] -> case allTargetsInBuildOrder' pkg_descr lbi of - (target:_) -> return target - [] -> die' verbosity $ "Failed to determine target." - [target] -> return target - _ -> die' verbosity $ "The 'repl' command does not support multiple targets at once." - let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] - debug verbosity $ "Component build order: " - ++ intercalate ", " - (map (showComponentName . componentLocalName . targetCLBI) - componentsToBuild) - - internalPackageDB <- createInternalPackageDB verbosity lbi distPref - - let lbiForComponent comp lbi' = - lbi' { - withPackageDB = withPackageDB lbi ++ [internalPackageDB], - withPrograms = addInternalBuildTools pkg_descr lbi' - (componentBuildInfo comp) (withPrograms lbi') - } - - -- build any dependent components - sequence_ - [ do let clbi = targetCLBI subtarget - comp = targetComponent subtarget - lbi' = lbiForComponent comp lbi - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - buildComponent verbosity NoFlag - pkg_descr lbi' suffixes comp clbi distPref - | subtarget <- safeInit componentsToBuild ] - - -- REPL for target components - let clbi = targetCLBI target - comp = targetComponent target - lbi' = lbiForComponent comp lbi - replFlags = replReplOptions flags - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - replComponent replFlags verbosity pkg_descr lbi' suffixes comp clbi distPref - - --- | Start an interpreter without loading any package files. -startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform - -> PackageDBStack -> IO () -startInterpreter verbosity programDb comp platform packageDBs = - case compilerFlavor comp of - GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs - GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs - _ -> die' verbosity "A REPL is not supported with this compiler." - -buildComponent :: Verbosity - -> Flag (Maybe Int) - -> PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> Component - -> ComponentLocalBuildInfo - -> FilePath - -> IO (Maybe InstalledPackageInfo) -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CLib lib) clbi distPref = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = flip addExtraAsmSources extras - $ flip addExtraCmmSources extras - $ flip addExtraCxxSources extras - $ flip addExtraCSources extras - $ flip addExtraJsSources extras - $ libbi - } - - buildLib verbosity 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))) - then do - -- Register the library in-place, so exes can depend - -- on internally defined libraries. - pwd <- getCurrentDirectory - let -- The in place registration uses the "-inplace" suffix, not an ABI hash - installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr - -- NB: Use a fake ABI hash to avoid - -- needing to recompute it every build. - (mkAbiHash "inplace") lib' lbi clbi - - debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo) - registerPackage verbosity (compiler lbi) (withPrograms lbi) - (withPackageDB lbi) installedPkgInfo - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True - } - return (Just installedPkgInfo) - else return Nothing - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CFLib flib) clbi _distPref = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - buildFLib verbosity numJobs pkg_descr lbi flib clbi - return Nothing - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CExe exe) clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } - buildExe verbosity numJobs pkg_descr lbi exe' clbi - return Nothing - - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) - clbi _distPref = do - let exe = testSuiteExeV10AsExe test - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let ebi = buildInfo exe - exe' = exe { buildInfo = addSrcDir (addExtraOtherModules (addExtraCSources ebi extras) generatedExtras) genDir } -- todo extend hssrcdirs - buildExe verbosity numJobs pkg_descr lbi exe' clbi - return Nothing - -buildComponent verbosity numJobs pkg_descr lbi0 suffixes - comp@(CTest - test@TestSuite { testInterface = TestSuiteLibV09{} }) - clbi -- This ComponentLocalBuildInfo corresponds to a detailed - -- test suite and not a real component. It should not - -- be used, except to construct the CLBIs for the - -- library and stub executable that will actually be - -- built. - distPref = do - pwd <- getCurrentDirectory - let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = - testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi -- TODO find cpphs processed files - (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir } - buildLib verbosity numJobs pkg lbi lib' libClbi - -- NB: need to enable multiple instances here, because on 7.10+ - -- the package name is the same as the library, and we still - -- want the registration to go through. - registerPackage verbosity (compiler lbi) (withPrograms lbi) - (withPackageDB lbi) ipi - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True - } - let ebi = buildInfo exe - -- NB: The stub executable is linked against the test-library - -- which already contains all `other-modules`, so we need - -- to remove those from the stub-exe's build-info - exe' = exe { buildInfo = (addExtraCSources ebi extras) { otherModules = [] } } - buildExe verbosity numJobs pkg_descr lbi exe' exeClbi - return Nothing -- Can't depend on test suite - - -buildComponent verbosity _ _ _ _ - (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) - _ _ = - die' verbosity $ "No support for building test suite type " ++ prettyShow tt - - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) - clbi _distPref = do - let exe = benchmarkExeV10asExe bm - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } - buildExe verbosity numJobs pkg_descr lbi exe' clbi - return Nothing - - -buildComponent verbosity _ _ _ _ - (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) - _ _ = - die' verbosity $ "No support for building benchmark type " ++ prettyShow tt - - - -generateCode - :: [String] - -> UnqualComponentName - -> PackageDescription - -> BuildInfo - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Verbosity - -> IO (FilePath, [ModuleName.ModuleName]) -generateCode codeGens nm pdesc bi lbi clbi verbosity = do - when (not . null $ codeGens) $ createDirectoryIfMissingVerbose verbosity True tgtDir - (\x -> (tgtDir,x)) . concat <$> mapM go codeGens - where - allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc) - dependencyLibs = filter (const True) allLibs -- intersect with componentPackageDeps of clbi - srcDirs = concatMap (hsSourceDirs . libBuildInfo) dependencyLibs - nm' = unUnqualComponentName nm - tgtDir = buildDir lbi nm' nm' ++ "-gen" - go :: String -> IO [ModuleName.ModuleName] - go codeGenProg = fmap fromString . lines <$> getDbProgramOutput verbosity (simpleProgram codeGenProg) (withPrograms lbi) - ((tgtDir : map getSymbolicPath srcDirs) ++ - ("--" : - GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbosity lbi bi clbi tgtDir))) - - --- | Add extra C sources generated by preprocessing to build --- information. -addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraCSources bi extras = bi { cSources = new } - where new = ordNub (extras ++ cSources bi) - --- | Add extra C++ sources generated by preprocessing to build --- information. -addExtraCxxSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraCxxSources bi extras = bi { cxxSources = new } - where new = ordNub (extras ++ cxxSources bi) - --- | Add extra C-- sources generated by preprocessing to build --- information. -addExtraCmmSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraCmmSources bi extras = bi { cmmSources = new } - where new = ordNub (extras ++ cmmSources bi) - --- | Add extra ASM sources generated by preprocessing to build --- information. -addExtraAsmSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraAsmSources bi extras = bi { asmSources = new } - where new = ordNub (extras ++ asmSources bi) - --- | Add extra JS sources generated by preprocessing to build --- information. -addExtraJsSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraJsSources bi extras = bi { jsSources = new } - where new = ordNub (extras ++ jsSources bi) - - --- | Add extra HS modules generated by preprocessing to build --- information. -addExtraOtherModules :: BuildInfo -> [ModuleName.ModuleName] -> BuildInfo -addExtraOtherModules bi extras = bi { otherModules = new } - where new = ordNub (extras ++ otherModules bi) - --- | Add extra source dir for generated modules. -addSrcDir :: BuildInfo -> FilePath -> BuildInfo -addSrcDir bi extra = bi { hsSourceDirs = new } - where new = ordNub (unsafeMakeSymbolicPath extra : hsSourceDirs bi) - -replComponent :: ReplOptions - -> Verbosity - -> PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> Component - -> ComponentLocalBuildInfo - -> FilePath - -> IO () -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CLib lib) clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } - replLib replFlags verbosity pkg_descr lbi lib' clbi - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CFLib flib) clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - replFLib replFlags verbosity pkg_descr lbi flib clbi - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CExe exe) clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let ebi = buildInfo exe - exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } - replExe replFlags verbosity pkg_descr lbi exe' clbi - - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) - clbi _distPref = do - let exe = testSuiteExeV10AsExe test - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let ebi = buildInfo exe - exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } - replExe replFlags verbosity pkg_descr lbi exe' clbi - - -replComponent replFlags verbosity pkg_descr lbi0 suffixes - comp@(CTest - test@TestSuite { testInterface = TestSuiteLibV09{} }) - clbi distPref = do - pwd <- getCurrentDirectory - let (pkg, lib, libClbi, lbi, _, _, _) = - testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } - replLib replFlags verbosity pkg lbi lib' libClbi - - -replComponent _ verbosity _ _ _ - (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) - _ _ = - die' verbosity $ "No support for building test suite type " ++ prettyShow tt - - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) - clbi _distPref = do - let exe = benchmarkExeV10asExe bm - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let ebi = buildInfo exe - exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } - replExe replFlags verbosity pkg_descr lbi exe' clbi - - -replComponent _ verbosity _ _ _ - (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) - _ _ = - die' verbosity $ "No support for building benchmark type " ++ prettyShow tt - ----------------------------------------------------- --- Shared code for buildComponent and replComponent --- - --- | Translate a exe-style 'TestSuite' component into an exe for building -testSuiteExeV10AsExe :: TestSuite -> Executable -testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } = - Executable { - exeName = testName test, - modulePath = mainFile, - exeScope = ExecutablePublic, - buildInfo = testBuildInfo test - } -testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind" - --- | Translate a exe-style 'Benchmark' component into an exe for building -benchmarkExeV10asExe :: Benchmark -> Executable -benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ mainFile } = - Executable { - exeName = benchmarkName bm, - modulePath = mainFile, - exeScope = ExecutablePublic, - buildInfo = benchmarkBuildInfo bm - } -benchmarkExeV10asExe Benchmark{} = error "benchmarkExeV10asExe: wrong kind" - --- | Translate a lib-style 'TestSuite' component into a lib + exe for building -testSuiteLibV09AsLibAndExe :: PackageDescription - -> TestSuite - -> ComponentLocalBuildInfo - -> LocalBuildInfo - -> FilePath - -> FilePath - -> (PackageDescription, - Library, ComponentLocalBuildInfo, - LocalBuildInfo, - IPI.InstalledPackageInfo, - Executable, ComponentLocalBuildInfo) -testSuiteLibV09AsLibAndExe pkg_descr - test@TestSuite { testInterface = TestSuiteLibV09 _ m } - clbi lbi distPref pwd = - (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) - where - bi = testBuildInfo test - lib = Library { - libName = LMainLibName, - exposedModules = [ m ], - reexportedModules = [], - signatures = [], - libExposed = True, - libVisibility = LibraryVisibilityPrivate, - libBuildInfo = bi - } - -- This is, like, the one place where we use a CTestName for a library. - -- Should NOT use library name, since that could conflict! - PackageIdentifier pkg_name pkg_ver = package pkg_descr - -- Note: we do make internal library from the test! - compat_name = MungedPackageName pkg_name (LSubLibName (testName test)) - compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi) - libClbi = LibComponentLocalBuildInfo - { componentPackageDeps = componentPackageDeps clbi - , componentInternalDeps = componentInternalDeps clbi - , componentIsIndefinite_ = False - , componentExeDeps = componentExeDeps clbi - , componentLocalName = CLibName $ LSubLibName $ testName test - , componentIsPublic = False - , componentIncludes = componentIncludes clbi - , componentUnitId = componentUnitId clbi - , componentComponentId = componentComponentId clbi - , componentInstantiatedWith = [] - , componentCompatPackageName = compat_name - , componentCompatPackageKey = compat_key - , componentExposedModules = [IPI.ExposedModule m Nothing] - } - pkgName' = mkPackageName $ prettyShow compat_name - pkg = pkg_descr { - package = (package pkg_descr) { pkgName = pkgName' } - , executables = [] - , testSuites = [] - , subLibraries = [lib] - } - ipi = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi - testDir = buildDir lbi stubName test - stubName test ++ "-tmp" - testLibDep = Dependency - pkgName' - (thisVersion $ pkgVersion $ package pkg_descr) - mainLibSet - exe = Executable { - exeName = mkUnqualComponentName $ stubName test, - modulePath = stubFilePath test, - exeScope = ExecutablePublic, - buildInfo = (testBuildInfo test) { - hsSourceDirs = [ unsafeMakeSymbolicPath testDir ], - targetBuildDepends = testLibDep - : (targetBuildDepends $ testBuildInfo test) - } - } - -- | The stub executable needs a new 'ComponentLocalBuildInfo' - -- 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)) - exeClbi = ExeComponentLocalBuildInfo { - -- TODO: this is a hack, but as long as this is unique - -- (doesn't clobber something) we won't run into trouble - componentUnitId = mkUnitId (stubName test), - componentComponentId = mkComponentId (stubName test), - componentInternalDeps = [componentUnitId clbi], - componentExeDeps = [], - componentLocalName = CExeName $ mkUnqualComponentName $ stubName test, - componentPackageDeps = deps, - -- Assert DefUnitId invariant! - -- Executable can't be indefinite, so dependencies must - -- be definite packages. - componentIncludes = zip (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps) - (repeat defaultRenaming) - } -testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" - - --- | Initialize a new package db file for libraries defined --- internally to the package. -createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath - -> IO PackageDB -createInternalPackageDB verbosity lbi distPref = do - existsAlready <- doesPackageDBExist dbPath - when existsAlready $ deletePackageDB dbPath - createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath - return (SpecificPackageDB dbPath) - where - dbPath = internalPackageDBPath lbi distPref - -addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo - -> ProgramDb -> ProgramDb -addInternalBuildTools pkg lbi bi progs = - foldr updateProgram progs internalBuildTools - where - internalBuildTools = - [ simpleConfiguredProgram toolName' (FoundOnSystem toolLocation) - | toolName <- getAllInternalToolDependencies pkg bi - , let toolName' = unUnqualComponentName toolName - , let toolLocation = buildDir lbi toolName' toolName' <.> exeExtension (hostPlatform lbi) ] - - --- TODO: build separate libs in separate dirs so that we can build --- multiple libs, e.g. for 'LibTest' library-style test suites -buildLib :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity numJobs pkg_descr lbi lib clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildLib verbosity 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 - _ -> die' verbosity "Building is not supported with this compiler." - --- | Build a foreign library --- --- NOTE: We assume that we already checked that we can actually build the --- foreign library in configure. -buildFLib :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> ForeignLib -> ComponentLocalBuildInfo -> IO () -buildFLib verbosity numJobs pkg_descr lbi flib clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi - _ -> die' verbosity "Building is not supported with this compiler." - -buildExe :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity numJobs pkg_descr lbi exe clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi - GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi - UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi - _ -> die' verbosity "Building is not supported with this compiler." - -replLib :: ReplOptions -> Verbosity -> PackageDescription - -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo - -> IO () -replLib replFlags verbosity pkg_descr lbi lib clbi = - 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 verbosity NoFlag pkg_descr lbi lib clbi - GHCJS -> GHCJS.replLib (replOptionsFlags replFlags) verbosity NoFlag pkg_descr lbi lib clbi - _ -> die' verbosity "A REPL is not supported for this compiler." - -replExe :: ReplOptions -> Verbosity -> PackageDescription - -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo - -> IO () -replExe replFlags verbosity pkg_descr lbi exe clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi - GHCJS -> GHCJS.replExe (replOptionsFlags replFlags) verbosity NoFlag pkg_descr lbi exe clbi - _ -> die' verbosity "A REPL is not supported for this compiler." - -replFLib :: ReplOptions -> Verbosity -> PackageDescription - -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo - -> IO () -replFLib replFlags verbosity pkg_descr lbi exe clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.replFLib replFlags verbosity NoFlag pkg_descr lbi exe clbi - _ -> die' verbosity "A REPL is not supported for this compiler." - --- | Runs 'componentInitialBuildSteps' on every configured component. -initialBuildSteps :: FilePath -- ^"dist" prefix - -> PackageDescription -- ^mostly information from the .cabal file - -> LocalBuildInfo -- ^Configuration information - -> Verbosity -- ^The verbosity to use - -> IO () -initialBuildSteps distPref pkg_descr lbi verbosity = - withAllComponentsInBuildOrder pkg_descr lbi $ \_comp clbi -> - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - --- | Creates the autogenerated files for a particular configured component. -componentInitialBuildSteps :: FilePath -- ^"dist" prefix - -> PackageDescription -- ^mostly information from the .cabal file - -> LocalBuildInfo -- ^Configuration information - -> ComponentLocalBuildInfo - -> Verbosity -- ^The verbosity to use - -> IO () -componentInitialBuildSteps _distPref pkg_descr lbi clbi verbosity = do - createDirectoryIfMissingVerbose verbosity True (componentBuildDir lbi clbi) - - writeAutogenFiles verbosity pkg_descr lbi clbi - --- | Generate and write out the Paths_.hs, PackageInfo_.hs, and cabal_macros.h files --- -writeAutogenFiles :: Verbosity - -> PackageDescription - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> IO () -writeAutogenFiles verbosity pkg lbi clbi = do - createDirectoryIfMissingVerbose verbosity True (autogenComponentModulesDir lbi clbi) - - let pathsModulePath = autogenComponentModulesDir lbi clbi - ModuleName.toFilePath (autogenPathsModuleName pkg) <.> "hs" - pathsModuleDir = takeDirectory pathsModulePath - -- Ensure that the directory exists! - createDirectoryIfMissingVerbose verbosity True pathsModuleDir - rewriteFileEx verbosity pathsModulePath (generatePathsModule pkg lbi clbi) - - let packageInfoModulePath = autogenComponentModulesDir lbi clbi - ModuleName.toFilePath (autogenPackageInfoModuleName pkg) <.> "hs" - packageInfoModuleDir = takeDirectory packageInfoModulePath - -- Ensure that the directory exists! - createDirectoryIfMissingVerbose verbosity True packageInfoModuleDir - rewriteFileEx verbosity packageInfoModulePath (generatePackageInfoModule pkg lbi) - - --TODO: document what we're doing here, and move it to its own function - case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - -- Write out empty hsig files for all requirements, so that GHC - -- has a source file to look at it when it needs to typecheck - -- a signature. It's harmless to write these out even when - -- there is a real hsig file written by the user, since - -- include path ordering ensures that the real hsig file - -- will always be picked up before the autogenerated one. - for_ (map fst insts) $ \mod_name -> do - let sigPath = autogenComponentModulesDir lbi clbi - ModuleName.toFilePath mod_name <.> "hsig" - createDirectoryIfMissingVerbose verbosity True (takeDirectory sigPath) - rewriteFileEx verbosity sigPath $ - "{-# OPTIONS_GHC -w #-}\n" ++ - "{-# LANGUAGE NoImplicitPrelude #-}\n" ++ - "signature " ++ prettyShow mod_name ++ " where" - _ -> return () - - let cppHeaderPath = autogenComponentModulesDir lbi clbi cppHeaderName - rewriteFileEx verbosity cppHeaderPath (generateCabalMacrosHeader pkg lbi clbi) +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Build +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008, 2012 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point to actually building the modules in a package. It +-- doesn't actually do much itself, most of the work is delegated to +-- compiler-specific actions. It does do some non-compiler specific bits like +-- running pre-processors. +module Distribution.Simple.Build + ( -- * Build + build + + -- * Repl + , repl + , startInterpreter + + -- * Build preparation + , preBuildComponent + , AutogenFile (..) + , AutogenFileContents + , writeBuiltinAutogenFiles + , writeAutogenFiles + + -- * Internal package database creation + , createInternalPackageDB + ) where + +import Distribution.Compat.Prelude +import Distribution.Utils.Generic +import Prelude () + +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.Dependency +import Distribution.Types.ExecutableScope +import Distribution.Types.ForeignLib +import Distribution.Types.LibraryVisibility +import Distribution.Types.LocalBuildInfo +import Distribution.Types.ModuleRenaming +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.ParStrat +import Distribution.Types.TargetInfo +import Distribution.Utils.Path + +import Distribution.Backpack +import Distribution.Backpack.DescribeUnitId +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 + +import Distribution.Simple.Build.Macros (generateCabalMacrosHeader) +import Distribution.Simple.Build.PackageInfoModule (generatePackageInfoModule) +import Distribution.Simple.Build.PathsModule (generatePathsModule) +import qualified Distribution.Simple.Program.HcPkg as HcPkg + +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription +import Distribution.Simple.Compiler + +import Distribution.Simple.BuildPaths +import Distribution.Simple.BuildTarget +import Distribution.Simple.BuildToolDepends +import Distribution.Simple.Configure +import Distribution.Simple.Flag +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Program.Builtin (haskellSuiteProgram) +import qualified Distribution.Simple.Program.GHC as GHC +import Distribution.Simple.Program.Types +import Distribution.Simple.Register +import Distribution.Simple.Setup.Build +import Distribution.Simple.Setup.Config +import Distribution.Simple.Setup.Repl +import Distribution.Simple.ShowBuildInfo +import Distribution.Simple.Test.LibV09 +import Distribution.Simple.Utils +import Distribution.Utils.Json +import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText) + +import Distribution.Pretty +import Distribution.System +import Distribution.Verbosity +import Distribution.Version (thisVersion) + +import Distribution.Compat.Graph (IsNode (..)) + +import Control.Monad +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map +import Distribution.Simple.Errors +import System.Directory (doesFileExist, getCurrentDirectory, removeFile) +import System.FilePath (takeDirectory, (<.>), ()) + +-- ----------------------------------------------------------------------------- + +-- | Build the libraries and executables in this package. +build + :: PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> IO () +build pkg_descr lbi flags suffixes = do + checkSemaphoreSupport verbosity (compiler lbi) flags + targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags) + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) + info verbosity $ + "Component build order: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + componentsToBuild + ) + + when (null targets) $ + -- Only bother with this message if we're building the whole package + setupMessage verbosity "Building" (packageId pkg_descr) + + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + -- Before the actual building, dump out build-information. + -- This way, if the actual compilation failed, the options have still been + -- dumped. + dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags lbi)) pkg_descr lbi flags + + -- Now do the actual building + (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do + preBuildComponent verbosity lbi target + let comp = targetComponent target + clbi = targetCLBI target + bi = componentBuildInfo comp + progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) + lbi' = + lbi + { withPrograms = progs' + , withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , installedPkgs = index + } + par_strat <- + toFlag <$> case buildUseSemaphore flags of + Flag sem_name -> case buildNumJobs flags of + Flag{} -> do + warn verbosity $ "Ignoring -j due to --semaphore" + return $ UseSem sem_name + NoFlag -> return $ UseSem sem_name + NoFlag -> return $ case buildNumJobs flags of + Flag n -> NumJobs n + NoFlag -> Serial + mb_ipi <- + buildComponent + flags + par_strat + pkg_descr + lbi' + suffixes + comp + clbi + distPref + return (maybe index (Index.insert `flip` index) mb_ipi) + + return () + where + distPref = fromFlag (buildDistPref flags) + verbosity = fromFlag (buildVerbosity flags) + +-- | 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)))) $ + dieWithException verbosity CheckSemaphoreSupport + +-- | Write available build information for 'LocalBuildInfo' to disk. +-- +-- Dumps detailed build information 'build-info.json' to the given directory. +-- Build information contains basics such as compiler details, but also +-- lists what modules a component contains and how to compile the component, assuming +-- lib:Cabal made sure that dependencies are up-to-date. +dumpBuildInfo + :: Verbosity + -> FilePath + -- ^ To which directory should the build-info be dumped? + -> Flag DumpBuildInfo + -- ^ Should we dump detailed build information for this component? + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build + -> IO () +dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do + when shouldDumpBuildInfo $ do + -- Changing this line might break consumers of the dumped build info. + -- Announce changes on mailing lists! + let activeTargets = allTargetsInBuildOrder' pkg_descr lbi + info verbosity $ + "Dump build information for: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + activeTargets + ) + pwd <- getCurrentDirectory + + (compilerProg, _) <- case flavorToProgram (compilerFlavor (compiler lbi)) of + Nothing -> + dieWithException verbosity $ UnknownCompilerFlavor (compilerFlavor (compiler lbi)) + Just program -> requireProgram verbosity program (withPrograms lbi) + + let (warns, json) = mkBuildInfo pwd pkg_descr lbi flags (compilerProg, compiler lbi) activeTargets + buildInfoText = renderJson json + unless (null warns) $ + warn verbosity $ + "Encountered warnings while dumping build-info:\n" + ++ unlines warns + LBS.writeFile (buildInfoPref distPref) buildInfoText + + when (not shouldDumpBuildInfo) $ do + -- Remove existing build-info.json as it might be outdated now. + exists <- doesFileExist (buildInfoPref distPref) + when exists $ removeFile (buildInfoPref distPref) + where + shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo + + -- \| Given the flavor of the compiler, try to find out + -- which program we need. + flavorToProgram :: CompilerFlavor -> Maybe Program + flavorToProgram GHC = Just ghcProgram + flavorToProgram GHCJS = Just ghcjsProgram + flavorToProgram UHC = Just uhcProgram + flavorToProgram JHC = Just jhcProgram + flavorToProgram HaskellSuite{} = Just haskellSuiteProgram + flavorToProgram _ = Nothing + +repl + :: PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> ReplFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> [String] + -> IO () +repl pkg_descr lbi flags suffixes args = do + let distPref = fromFlag (replDistPref flags) + verbosity = fromFlag (replVerbosity flags) + + target <- + readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of + -- This seems DEEPLY questionable. + [] -> case allTargetsInBuildOrder' pkg_descr lbi of + (target : _) -> return target + [] -> dieWithException verbosity $ FailedToDetermineTarget + [target] -> return target + _ -> dieWithException verbosity $ NoMultipleTargets + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] + debug verbosity $ + "Component build order: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + componentsToBuild + ) + + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + let lbiForComponent comp lbi' = + lbi' + { withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , withPrograms = + addInternalBuildTools + pkg_descr + lbi' + (componentBuildInfo comp) + (withPrograms lbi') + } + + -- build any dependent components + sequence_ + [ do + let clbi = targetCLBI subtarget + comp = targetComponent subtarget + lbi' = lbiForComponent comp lbi + preBuildComponent verbosity lbi subtarget + buildComponent + mempty{buildVerbosity = toFlag verbosity} + NoFlag + pkg_descr + lbi' + suffixes + comp + clbi + distPref + | subtarget <- safeInit componentsToBuild + ] + + -- REPL for target components + let clbi = targetCLBI target + comp = targetComponent target + lbi' = lbiForComponent comp lbi + preBuildComponent verbosity lbi target + replComponent flags verbosity pkg_descr lbi' suffixes comp clbi distPref + +-- | Start an interpreter without loading any package files. +startInterpreter + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> PackageDBStack + -> IO () +startInterpreter verbosity programDb comp platform packageDBs = + case compilerFlavor comp of + GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs + GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs + _ -> dieWithException verbosity REPLNotSupported + +buildComponent + :: BuildFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> Component + -> ComponentLocalBuildInfo + -> FilePath + -> IO (Maybe InstalledPackageInfo) +buildComponent flags _ _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ = + dieWithException (fromFlag $ buildVerbosity flags) $ NoSupportBuildingTestSuite tt +buildComponent flags _ _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ = + dieWithException (fromFlag $ buildVerbosity flags) $ NoSupportBuildingBenchMark tt +buildComponent + flags + numJobs + pkg_descr + lbi0 + suffixes + comp@( CTest + test@TestSuite{testInterface = TestSuiteLibV09{}} + ) + clbi -- This ComponentLocalBuildInfo corresponds to a detailed + -- test suite and not a real component. It should not + -- be used, except to construct the CLBIs for the + -- library and stub executable that will actually be + -- built. + distPref = + do + let verbosity = fromFlag $ buildVerbosity flags + pwd <- getCurrentDirectory + let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = + testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi -- TODO find cpphs processed files + (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity + setupMessage' + verbosity + "Building" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) + let libbi = libBuildInfo lib + lib' = lib{libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir} + buildLib 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. + registerPackage + verbosity + (compiler lbi) + (withPrograms lbi) + (withPackageDB lbi) + ipi + HcPkg.defaultRegisterOptions + { HcPkg.registerMultiInstance = True + } + let ebi = buildInfo exe + -- NB: The stub executable is linked against the test-library + -- which already contains all `other-modules`, so we need + -- to remove those from the stub-exe's build-info + exe' = exe{buildInfo = (addExtraCSources ebi extras){otherModules = []}} + buildExe verbosity numJobs pkg_descr lbi exe' exeClbi + return Nothing -- Can't depend on test suite +buildComponent + flags + numJobs + pkg_descr + lbi + suffixes + comp + clbi + distPref = + do + let verbosity = fromFlag $ buildVerbosity flags + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + setupMessage' + verbosity + "Building" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) + case comp of + CLib lib -> do + let libbi = libBuildInfo lib + lib' = + lib + { libBuildInfo = + flip addExtraAsmSources extras $ + flip addExtraCmmSources extras $ + flip addExtraCxxSources extras $ + flip addExtraCSources extras $ + flip addExtraJsSources extras $ + libbi + } + + buildLib 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))) + then do + -- Register the library in-place, so exes can depend + -- on internally defined libraries. + pwd <- getCurrentDirectory + let + -- The in place registration uses the "-inplace" suffix, not an ABI hash + installedPkgInfo = + inplaceInstalledPackageInfo + pwd + distPref + pkg_descr + -- NB: Use a fake ABI hash to avoid + -- needing to recompute it every build. + (mkAbiHash "inplace") + lib' + lbi + clbi + debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo) + registerPackage + verbosity + (compiler lbi) + (withPrograms lbi) + (withPackageDB lbi) + installedPkgInfo + HcPkg.defaultRegisterOptions + { HcPkg.registerMultiInstance = True + } + return (Just installedPkgInfo) + else return Nothing + CFLib flib -> do + buildFLib verbosity numJobs pkg_descr lbi flib clbi + return Nothing + CExe exe -> do + let ebi = buildInfo exe + exe' = exe{buildInfo = addExtraCSources ebi extras} + buildExe verbosity numJobs pkg_descr lbi exe' clbi + return Nothing + CTest test@TestSuite{testInterface = TestSuiteExeV10{}} -> do + let exe = testSuiteExeV10AsExe test + (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity + let ebi = buildInfo exe + exe' = exe{buildInfo = addSrcDir (addExtraOtherModules (addExtraCSources ebi extras) generatedExtras) genDir} -- todo extend hssrcdirs + buildExe verbosity numJobs pkg_descr lbi exe' clbi + return Nothing + CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}} -> do + let exe = benchmarkExeV10asExe bm + let ebi = buildInfo exe + exe' = exe{buildInfo = addExtraCSources ebi extras} + buildExe verbosity numJobs pkg_descr lbi exe' clbi + return Nothing +#if __GLASGOW_HASKELL__ < 811 +-- silence pattern-match warnings prior to GHC 9.0 + _ -> error "impossible" +#endif + +generateCode + :: [String] + -> UnqualComponentName + -> PackageDescription + -> BuildInfo + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Verbosity + -> IO (FilePath, [ModuleName.ModuleName]) +generateCode codeGens nm pdesc bi lbi clbi verbosity = do + when (not . null $ codeGens) $ createDirectoryIfMissingVerbose verbosity True tgtDir + (\x -> (tgtDir, x)) . concat <$> mapM go codeGens + where + allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc) + dependencyLibs = filter (const True) allLibs -- intersect with componentPackageDeps of clbi + srcDirs = concatMap (hsSourceDirs . libBuildInfo) dependencyLibs + nm' = unUnqualComponentName nm + tgtDir = buildDir lbi nm' nm' ++ "-gen" + go :: String -> IO [ModuleName.ModuleName] + go codeGenProg = + fmap fromString . lines + <$> getDbProgramOutput + verbosity + (simpleProgram codeGenProg) + (withPrograms lbi) + ( (tgtDir : map getSymbolicPath srcDirs) + ++ ( "--" + : GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbosity lbi bi clbi tgtDir) + ) + ) + +-- | Add extra C sources generated by preprocessing to build +-- information. +addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo +addExtraCSources bi extras = bi{cSources = new} + where + new = ordNub (extras ++ cSources bi) + +-- | Add extra C++ sources generated by preprocessing to build +-- information. +addExtraCxxSources :: BuildInfo -> [FilePath] -> BuildInfo +addExtraCxxSources bi extras = bi{cxxSources = new} + where + new = ordNub (extras ++ cxxSources bi) + +-- | Add extra C-- sources generated by preprocessing to build +-- information. +addExtraCmmSources :: BuildInfo -> [FilePath] -> BuildInfo +addExtraCmmSources bi extras = bi{cmmSources = new} + where + new = ordNub (extras ++ cmmSources bi) + +-- | Add extra ASM sources generated by preprocessing to build +-- information. +addExtraAsmSources :: BuildInfo -> [FilePath] -> BuildInfo +addExtraAsmSources bi extras = bi{asmSources = new} + where + new = ordNub (extras ++ asmSources bi) + +-- | Add extra JS sources generated by preprocessing to build +-- information. +addExtraJsSources :: BuildInfo -> [FilePath] -> BuildInfo +addExtraJsSources bi extras = bi{jsSources = new} + where + new = ordNub (extras ++ jsSources bi) + +-- | Add extra HS modules generated by preprocessing to build +-- information. +addExtraOtherModules :: BuildInfo -> [ModuleName.ModuleName] -> BuildInfo +addExtraOtherModules bi extras = bi{otherModules = new} + where + new = ordNub (extras ++ otherModules bi) + +-- | Add extra source dir for generated modules. +addSrcDir :: BuildInfo -> FilePath -> BuildInfo +addSrcDir bi extra = bi{hsSourceDirs = new} + where + new = ordNub (unsafeMakeSymbolicPath extra : hsSourceDirs bi) + +replComponent + :: ReplFlags + -> Verbosity + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> Component + -> ComponentLocalBuildInfo + -> FilePath + -> IO () +replComponent _ verbosity _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ = + dieWithException verbosity $ NoSupportBuildingTestSuite tt +replComponent _ verbosity _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ = + dieWithException verbosity $ NoSupportBuildingBenchMark tt +replComponent + replFlags + verbosity + pkg_descr + lbi0 + suffixes + comp@( CTest + test@TestSuite{testInterface = TestSuiteLibV09{}} + ) + clbi + distPref = do + pwd <- getCurrentDirectory + let (pkg, lib, libClbi, lbi, _, _, _) = + testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + extras <- preprocessExtras verbosity comp lbi + let libbi = libBuildInfo lib + lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} + replLib replFlags pkg lbi lib' libClbi +replComponent + replFlags + verbosity + pkg_descr + lbi + suffixes + comp + clbi + _ = + do + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + 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 + CFLib flib -> + replFLib 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 + 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 + 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 +#if __GLASGOW_HASKELL__ < 811 +-- silence pattern-match warnings prior to GHC 9.0 + _ -> error "impossible" +#endif + +---------------------------------------------------- +-- Shared code for buildComponent and replComponent +-- + +-- | Translate a exe-style 'TestSuite' component into an exe for building +testSuiteExeV10AsExe :: TestSuite -> Executable +testSuiteExeV10AsExe test@TestSuite{testInterface = TestSuiteExeV10 _ mainFile} = + Executable + { exeName = testName test + , modulePath = mainFile + , exeScope = ExecutablePublic + , buildInfo = testBuildInfo test + } +testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind" + +-- | Translate a exe-style 'Benchmark' component into an exe for building +benchmarkExeV10asExe :: Benchmark -> Executable +benchmarkExeV10asExe bm@Benchmark{benchmarkInterface = BenchmarkExeV10 _ mainFile} = + Executable + { exeName = benchmarkName bm + , modulePath = mainFile + , exeScope = ExecutablePublic + , buildInfo = benchmarkBuildInfo bm + } +benchmarkExeV10asExe Benchmark{} = error "benchmarkExeV10asExe: wrong kind" + +-- | Translate a lib-style 'TestSuite' component into a lib + exe for building +testSuiteLibV09AsLibAndExe + :: PackageDescription + -> TestSuite + -> ComponentLocalBuildInfo + -> LocalBuildInfo + -> FilePath + -> FilePath + -> ( PackageDescription + , Library + , ComponentLocalBuildInfo + , LocalBuildInfo + , IPI.InstalledPackageInfo + , Executable + , ComponentLocalBuildInfo + ) +testSuiteLibV09AsLibAndExe + pkg_descr + test@TestSuite{testInterface = TestSuiteLibV09 _ m} + clbi + lbi + distPref + pwd = + (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) + where + bi = testBuildInfo test + lib = + Library + { libName = LMainLibName + , exposedModules = [m] + , reexportedModules = [] + , signatures = [] + , libExposed = True + , libVisibility = LibraryVisibilityPrivate + , libBuildInfo = bi + } + -- This is, like, the one place where we use a CTestName for a library. + -- Should NOT use library name, since that could conflict! + PackageIdentifier pkg_name pkg_ver = package pkg_descr + -- Note: we do make internal library from the test! + compat_name = MungedPackageName pkg_name (LSubLibName (testName test)) + compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi) + libClbi = + LibComponentLocalBuildInfo + { componentPackageDeps = componentPackageDeps clbi + , componentInternalDeps = componentInternalDeps clbi + , componentIsIndefinite_ = False + , componentExeDeps = componentExeDeps clbi + , componentLocalName = CLibName $ LSubLibName $ testName test + , componentIsPublic = False + , componentIncludes = componentIncludes clbi + , componentUnitId = componentUnitId clbi + , componentComponentId = componentComponentId clbi + , componentInstantiatedWith = [] + , componentCompatPackageName = compat_name + , componentCompatPackageKey = compat_key + , componentExposedModules = [IPI.ExposedModule m Nothing] + } + pkgName' = mkPackageName $ prettyShow compat_name + pkg = + pkg_descr + { package = (package pkg_descr){pkgName = pkgName'} + , executables = [] + , testSuites = [] + , subLibraries = [lib] + } + ipi = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi + testDir = + buildDir lbi + stubName test + stubName test + ++ "-tmp" + testLibDep = + Dependency + pkgName' + (thisVersion $ pkgVersion $ package pkg_descr) + mainLibSet + exe = + Executable + { exeName = mkUnqualComponentName $ stubName test + , modulePath = stubFilePath test + , exeScope = ExecutablePublic + , buildInfo = + (testBuildInfo test) + { hsSourceDirs = [unsafeMakeSymbolicPath testDir] + , targetBuildDepends = + testLibDep + : targetBuildDepends (testBuildInfo test) + } + } + -- \| The stub executable needs a new 'ComponentLocalBuildInfo' + -- 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) + ) + exeClbi = + ExeComponentLocalBuildInfo + { -- TODO: this is a hack, but as long as this is unique + -- (doesn't clobber something) we won't run into trouble + componentUnitId = mkUnitId (stubName test) + , componentComponentId = mkComponentId (stubName test) + , componentInternalDeps = [componentUnitId clbi] + , componentExeDeps = [] + , componentLocalName = CExeName $ mkUnqualComponentName $ stubName test + , componentPackageDeps = deps + , -- Assert DefUnitId invariant! + -- Executable can't be indefinite, so dependencies must + -- be definite packages. + componentIncludes = + map ((,defaultRenaming) . DefiniteUnitId . unsafeMkDefUnitId . fst) deps + } +testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" + +-- | Initialize a new package db file for libraries defined +-- internally to the package. +createInternalPackageDB + :: Verbosity + -> LocalBuildInfo + -> FilePath + -> IO PackageDB +createInternalPackageDB verbosity lbi distPref = do + existsAlready <- doesPackageDBExist dbPath + when existsAlready $ deletePackageDB dbPath + createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath + return (SpecificPackageDB dbPath) + where + dbPath = internalPackageDBPath lbi distPref + +addInternalBuildTools + :: PackageDescription + -> LocalBuildInfo + -> BuildInfo + -> ProgramDb + -> ProgramDb +addInternalBuildTools pkg lbi bi progs = + foldr updateProgram progs internalBuildTools + where + internalBuildTools = + [ simpleConfiguredProgram toolName' (FoundOnSystem toolLocation) + | toolName <- getAllInternalToolDependencies pkg bi + , let toolName' = unUnqualComponentName toolName + , let toolLocation = buildDir lbi toolName' toolName' <.> exeExtension (hostPlatform lbi) + ] + +-- TODO: build separate libs in separate dirs so that we can build +-- multiple libs, e.g. for 'LibTest' library-style test suites +buildLib + :: BuildFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +buildLib flags numJobs pkg_descr lbi lib clbi = + let verbosity = fromFlag $ buildVerbosity flags + in case compilerFlavor (compiler lbi) of + GHC -> GHC.buildLib flags numJobs pkg_descr lbi lib clbi + GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi + UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi + HaskellSuite{} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi + _ -> dieWithException verbosity BuildingNotSupportedWithCompiler + +-- | Build a foreign library +-- +-- NOTE: We assume that we already checked that we can actually build the +-- foreign library in configure. +buildFLib + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +buildFLib verbosity numJobs pkg_descr lbi flib clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi + _ -> dieWithException verbosity BuildingNotSupportedWithCompiler + +buildExe + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +buildExe verbosity numJobs pkg_descr lbi exe clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi + GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi + UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi + _ -> dieWithException verbosity BuildingNotSupportedWithCompiler + +replLib + :: ReplFlags + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +replLib replFlags pkg_descr lbi lib clbi = + let verbosity = 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 + GHCJS -> GHCJS.replLib (replOptionsFlags opts) verbosity NoFlag pkg_descr lbi lib clbi + _ -> dieWithException verbosity REPLNotSupported + +replExe + :: ReplFlags + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +replExe flags pkg_descr lbi exe clbi = + let verbosity = fromFlag $ replVerbosity flags + in case compilerFlavor (compiler lbi) of + GHC -> GHC.replExe flags NoFlag pkg_descr lbi exe clbi + GHCJS -> GHCJS.replExe (replOptionsFlags $ replReplOptions flags) verbosity NoFlag pkg_descr lbi exe clbi + _ -> dieWithException verbosity REPLNotSupported + +replFLib + :: ReplFlags + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +replFLib flags pkg_descr lbi exe clbi = + let verbosity = fromFlag $ replVerbosity flags + in case compilerFlavor (compiler lbi) of + GHC -> GHC.replFLib flags NoFlag pkg_descr lbi exe clbi + _ -> dieWithException verbosity REPLNotSupported + +-- | Pre-build steps for a component: creates the autogenerated files +-- for a particular configured component. +preBuildComponent + :: Verbosity + -> LocalBuildInfo + -- ^ Configuration information + -> TargetInfo + -> IO () +preBuildComponent verbosity lbi tgt = do + let pkg_descr = localPkgDescr lbi + clbi = targetCLBI tgt + createDirectoryIfMissingVerbose verbosity True (componentBuildDir lbi clbi) + writeBuiltinAutogenFiles verbosity pkg_descr lbi clbi + +-- | 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 +-- (see 'autogenComponentsModuleDir'). +-- +-- This includes: +-- +-- - @Paths_.hs@, +-- - @PackageInfo_.hs@, +-- - Backpack signature files for components that are not fully instantiated, +-- - @cabal_macros.h@. +writeBuiltinAutogenFiles + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> IO () +writeBuiltinAutogenFiles verbosity pkg lbi clbi = + writeAutogenFiles verbosity lbi clbi $ builtinAutogenFiles pkg lbi clbi + +-- | Built-in autogenerated files and their contents. This includes: +-- +-- - @Paths_.hs@, +-- - @PackageInfo_.hs@, +-- - Backpack signature files for components that are not fully instantiated, +-- - @cabal_macros.h@. +builtinAutogenFiles + :: PackageDescription + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Map AutogenFile AutogenFileContents +builtinAutogenFiles pkg lbi clbi = + Map.insert pathsFile pathsContents $ + Map.insert packageInfoFile packageInfoContents $ + Map.insert cppHeaderFile cppHeaderContents $ + emptySignatureModules clbi + where + pathsFile = AutogenModule (autogenPathsModuleName pkg) (Suffix "hs") + pathsContents = toUTF8LBS $ generatePathsModule pkg lbi clbi + packageInfoFile = AutogenModule (autogenPackageInfoModuleName pkg) (Suffix "hs") + packageInfoContents = toUTF8LBS $ generatePackageInfoModule pkg lbi + cppHeaderFile = AutogenFile $ toShortText cppHeaderName + cppHeaderContents = toUTF8LBS $ generateCabalMacrosHeader pkg lbi clbi + +-- | An empty @".hsig"@ Backpack signature module for each requirement, so that +-- GHC has a source file to look at it when it needs to typecheck +-- a signature. It's harmless to generate these modules, even when +-- there is a real @hsig@ file written by the user, since +-- include path ordering ensures that the real @hsig@ file +-- will always be picked up before the autogenerated one. +emptySignatureModules + :: ComponentLocalBuildInfo + -> Map AutogenFile AutogenFileContents +emptySignatureModules clbi = + case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + Map.fromList + [ ( AutogenModule modName (Suffix "hsig") + , emptyHsigFile modName + ) + | (modName, _) <- insts + ] + _ -> Map.empty + where + emptyHsigFile :: ModuleName -> AutogenFileContents + emptyHsigFile modName = + toUTF8LBS $ + "{-# OPTIONS_GHC -w #-}\n" + ++ "{-# LANGUAGE NoImplicitPrelude #-}\n" + ++ "signature " + ++ prettyShow modName + ++ " where" + +data AutogenFile + = AutogenModule !ModuleName !Suffix + | AutogenFile !ShortText + deriving (Show, Eq, Ord) + +-- | A representation of the contents of an autogenerated file. +type AutogenFileContents = LBS.ByteString + +-- | Write the given autogenerated files in the autogenerated modules +-- directory for the component. +writeAutogenFiles + :: Verbosity + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Map AutogenFile AutogenFileContents + -> IO () +writeAutogenFiles verbosity lbi clbi autogenFiles = do + -- Ensure that the overall autogenerated files directory exists. + createDirectoryIfMissingVerbose verbosity True autogenDir + for_ (Map.assocs autogenFiles) $ \(file, contents) -> do + let path = case file of + AutogenModule modName (Suffix ext) -> + autogenDir ModuleName.toFilePath modName <.> ext + AutogenFile fileName -> + autogenDir fromShortText fileName + dir = takeDirectory path + -- Ensure that the directory subtree for this autogenerated file exists. + createDirectoryIfMissingVerbose verbosity True dir + -- Write the contents of the file. + rewriteFileLBS verbosity path contents + where + autogenDir = autogenComponentModulesDir lbi clbi diff --git a/src/Distribution/Simple/Build/Inputs.hs b/src/Distribution/Simple/Build/Inputs.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Build/Inputs.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} + +module Distribution.Simple.Build.Inputs + ( -- * Inputs of actions for building components + PreBuildComponentInputs (..) + + -- * Queries over the component being built + , buildVerbosity + , buildComponent + , buildIsLib + , buildCLBI + , buildBI + , buildCompiler + + -- * Re-exports + , BuildingWhat (..) + , LocalBuildInfo (..) + , TargetInfo (..) + , buildingWhatVerbosity + , buildingWhatDistPref + ) +where + +import Distribution.Simple.Compiler +import Distribution.Simple.Setup (BuildingWhat (..), buildingWhatDistPref, buildingWhatVerbosity) +import Distribution.Types.BuildInfo +import Distribution.Types.Component +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Verbosity + +-- | The information required for a build computation which is available right +-- before building each component, i.e. the pre-build component inputs. +data PreBuildComponentInputs = PreBuildComponentInputs + { buildingWhat :: BuildingWhat + -- ^ What kind of build are we doing? + , localBuildInfo :: LocalBuildInfo + -- ^ Information about the package + , targetInfo :: TargetInfo + -- ^ Information about an individual component + } + +-- | Get the @'Verbosity'@ from the context the component being built is in. +buildVerbosity :: PreBuildComponentInputs -> Verbosity +buildVerbosity = buildingWhatVerbosity . buildingWhat + +-- | Get the @'Component'@ being built. +buildComponent :: PreBuildComponentInputs -> Component +buildComponent = targetComponent . targetInfo + +-- | Is the @'Component'@ being built a @'Library'@? +buildIsLib :: PreBuildComponentInputs -> Bool +buildIsLib = do + component <- buildComponent + let isLib + | CLib{} <- component = True + | otherwise = False + return isLib +{-# INLINE buildIsLib #-} + +-- | Get the @'ComponentLocalBuildInfo'@ for the component being built. +buildCLBI :: PreBuildComponentInputs -> ComponentLocalBuildInfo +buildCLBI = targetCLBI . targetInfo + +-- | Get the @'BuildInfo'@ of the component being built. +buildBI :: PreBuildComponentInputs -> BuildInfo +buildBI = componentBuildInfo . buildComponent + +-- | Get the @'Compiler'@ being used to build the component. +buildCompiler :: PreBuildComponentInputs -> Compiler +buildCompiler = compiler . localBuildInfo 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 @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Build.Macros -- Copyright : Simon Marlow 2008 @@ -19,92 +20,95 @@ -- -- TODO Figure out what to do about backpack and internal libraries. It is very -- suspicious that this stuff works with munged package identifiers -module Distribution.Simple.Build.Macros ( - generateCabalMacrosHeader, - generatePackageVersionMacros, +module Distribution.Simple.Build.Macros + ( generateCabalMacrosHeader + , generatePackageVersionMacros ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Version import Distribution.PackageDescription +import Distribution.Pretty import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program.Db import Distribution.Simple.Program.Types import Distribution.Types.MungedPackageId import Distribution.Types.MungedPackageName -import Distribution.Pretty +import Distribution.Version import qualified Distribution.Simple.Build.Macros.Z as Z -- | The contents of the @cabal_macros.h@ for the given configured package. --- generateCabalMacrosHeader :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String -generateCabalMacrosHeader pkg_descr lbi clbi = Z.render Z.Z - { Z.zPackages = map mkZPackage $ package pkg_descr : map getPid (componentPackageDeps clbi) - , Z.zTools = - [ Z.ZTool - { Z.ztoolName = programId prog +generateCabalMacrosHeader pkg_descr lbi clbi = + Z.render + Z.Z + { Z.zPackages = map mkZPackage $ package pkg_descr : map getPid (componentPackageDeps clbi) + , Z.zTools = + [ Z.ZTool + { Z.ztoolName = programId prog , Z.ztoolVersion = ver - , Z.ztoolX = major1 - , Z.ztoolY = major2 - , Z.ztoolZ = minor + , Z.ztoolX = major1 + , Z.ztoolY = major2 + , Z.ztoolZ = minor } - | prog <- configuredPrograms $ withPrograms lbi - , ver <- maybeToList (programVersion prog) - , let (major1,major2,minor) = majorMinor ver - ] - , Z.zPackageKey = case clbi of - LibComponentLocalBuildInfo{} -> componentCompatPackageKey clbi - _ -> "" - , Z.zComponentId = prettyShow (componentComponentId clbi) - , Z.zPackageVersion = pkgVersion (package pkg_descr) - , Z.zNotNull = not . null - , Z.zManglePkgName = map fixchar . unPackageName - , Z.zMangleStr = map fixchar - } + | prog <- configuredPrograms $ withPrograms lbi + , ver <- maybeToList (programVersion prog) + , let (major1, major2, minor) = majorMinor ver + ] + , Z.zPackageKey = case clbi of + LibComponentLocalBuildInfo{} -> componentCompatPackageKey clbi + _ -> "" + , Z.zComponentId = prettyShow (componentComponentId clbi) + , Z.zPackageVersion = pkgVersion (package pkg_descr) + , Z.zNotNull = not . null + , Z.zManglePkgName = map fixchar . unPackageName + , Z.zMangleStr = map fixchar + } where getPid (_, MungedPackageId (MungedPackageName pn _) v) = - -- NB: Drop the library name! We're just reporting package versions. - -- This would have to be revisited if you are allowed to depend - -- on different versions of the same package - PackageIdentifier pn v + -- NB: Drop the library name! We're just reporting package versions. + -- This would have to be revisited if you are allowed to depend + -- on different versions of the same package + PackageIdentifier pn v -- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@ -- macros for a list of package ids (usually used with the specific deps of -- a configured package). --- generatePackageVersionMacros :: Version -> [PackageId] -> String -generatePackageVersionMacros ver pkgids = Z.render Z.Z - { Z.zPackages = map mkZPackage pkgids - , Z.zTools = [] - , Z.zPackageKey = "" - , Z.zComponentId = "" - , Z.zPackageVersion = ver - , Z.zNotNull = not . null - , Z.zManglePkgName = map fixchar . unPackageName - , Z.zMangleStr = map fixchar - } +generatePackageVersionMacros ver pkgids = + Z.render + Z.Z + { Z.zPackages = map mkZPackage pkgids + , Z.zTools = [] + , Z.zPackageKey = "" + , Z.zComponentId = "" + , Z.zPackageVersion = ver + , Z.zNotNull = not . null + , Z.zManglePkgName = map fixchar . unPackageName + , Z.zMangleStr = map fixchar + } mkZPackage :: PackageId -> Z.ZPackage -mkZPackage (PackageIdentifier name ver) = Z.ZPackage - { Z.zpkgName = name +mkZPackage (PackageIdentifier name ver) = + Z.ZPackage + { Z.zpkgName = name , Z.zpkgVersion = ver - , Z.zpkgX = major1 - , Z.zpkgY = major2 - , Z.zpkgZ = minor + , Z.zpkgX = major1 + , Z.zpkgY = major2 + , Z.zpkgZ = minor } where - (major1,major2,minor) = majorMinor ver + (major1, major2, minor) = majorMinor ver majorMinor :: Version -> (String, String, String) majorMinor ver = case map show (versionNumbers ver) of - [] -> ("0", "0", "0") - [x] -> (x, "0", "0") - [x,y] -> (x, y, "0") - (x:y:z:_) -> (x, y, z) + [] -> ("0", "0", "0") + [x] -> (x, "0", "0") + [x, y] -> (x, y, "0") + (x : y : z : _) -> (x, y, z) fixchar :: Char -> Char fixchar '-' = '_' -fixchar c = c +fixchar c = c diff --git a/src/Distribution/Simple/Build/Macros/Z.hs b/src/Distribution/Simple/Build/Macros/Z.hs --- a/src/Distribution/Simple/Build/Macros/Z.hs +++ b/src/Distribution/Simple/Build/Macros/Z.hs @@ -1,3 +1,4 @@ +{- FOURMOLU_DISABLE -} {-# LANGUAGE DeriveGeneric #-} module Distribution.Simple.Build.Macros.Z (render, Z(..), ZPackage (..), ZTool (..)) where import Distribution.ZinzaPrelude 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 @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Build.PackageInfoModule -- Copyright : @@ -10,9 +11,8 @@ -- -- This is a module that Cabal generates for the benefit of packages. It -- enables them to find their package informations. --- -module Distribution.Simple.Build.PackageInfoModule ( - generatePackageInfoModule +module Distribution.Simple.Build.PackageInfoModule + ( generatePackageInfoModule ) where import Distribution.Compat.Prelude @@ -28,29 +28,33 @@ import qualified Distribution.Simple.Build.PackageInfoModule.Z as Z -- ------------------------------------------------------------ + -- * Building Paths_.hs + -- ------------------------------------------------------------ generatePackageInfoModule :: PackageDescription -> LocalBuildInfo -> String -generatePackageInfoModule pkg_descr lbi = Z.render Z.Z - { Z.zPackageName = showPkgName $ packageName pkg_descr - , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr - , Z.zSynopsis = fromShortText $ synopsis pkg_descr - , Z.zCopyright = fromShortText $ copyright pkg_descr - , Z.zHomepage = fromShortText $ homepage pkg_descr - , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax - } +generatePackageInfoModule pkg_descr lbi = + Z.render + Z.Z + { Z.zPackageName = showPkgName $ packageName pkg_descr + , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr + , 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]) + 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 + case compilerCompatVersion GHC (compiler lbi) of + Nothing -> False + Just version -> version `withinRange` orLaterVersion minVersion showPkgName :: PackageName -> String showPkgName = map fixchar . unPackageName fixchar :: Char -> Char fixchar '-' = '_' -fixchar c = c +fixchar c = c 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 @@ -5,23 +5,23 @@ import Distribution.ZinzaPrelude data Z = Z - { zPackageName :: String, - zVersionDigits :: String, - zSynopsis :: String, - zCopyright :: String, - zHomepage :: String, - zSupportsNoRebindableSyntax :: Bool + { zPackageName :: String + , zVersionDigits :: String + , 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 () + then do + tell "{-# LANGUAGE NoRebindableSyntax #-}\n" + return () + else do + return () tell "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n" tell "{-# OPTIONS_GHC -w #-}\n" tell "module PackageInfo_" 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 @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Build.Macros -- Copyright : Isaac Jones 2003-2005, @@ -13,9 +14,9 @@ -- This is a module that Cabal generates for the benefit of packages. It -- enables them to find their version number and find any installed data files -- at runtime. This code should probably be split off into another module. --- -module Distribution.Simple.Build.PathsModule ( - generatePathsModule, pkgPathEnvVar +module Distribution.Simple.Build.PathsModule + ( generatePathsModule + , pkgPathEnvVar ) where import Distribution.Compat.Prelude @@ -25,121 +26,124 @@ import Distribution.PackageDescription import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Utils (shortRelativePath) +import Distribution.Simple.Utils (shortRelativePath) import Distribution.System import Distribution.Version import qualified Distribution.Simple.Build.PathsModule.Z as Z -- ------------------------------------------------------------ + -- * Building Paths_.hs + -- ------------------------------------------------------------ generatePathsModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String -generatePathsModule pkg_descr lbi clbi = Z.render 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.zNot = not - , Z.zManglePkgName = showPkgName - - , Z.zPrefix = show flat_prefix - , Z.zBindir = zBindir - , Z.zLibdir = zLibdir - , Z.zDynlibdir = zDynlibdir - , Z.zDatadir = zDatadir - , Z.zLibexecdir = zLibexecdir - , Z.zSysconfdir = zSysconfdir - } +generatePathsModule pkg_descr lbi clbi = + Z.render + 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.zNot = not + , Z.zManglePkgName = showPkgName + , Z.zPrefix = show flat_prefix + , Z.zBindir = zBindir + , Z.zLibdir = zLibdir + , Z.zDynlibdir = zDynlibdir + , Z.zDatadir = zDatadir + , Z.zLibexecdir = zLibexecdir + , 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]) + 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 + 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 - || isNothing flat_bindirrel -- if the bin dir is an absolute path - || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) + hasLibs pkg_descr -- we can only make progs relocatable + || isNothing flat_bindirrel -- if the bin dir is an absolute path + || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) -- TODO: Here, and with zIsI386 & zIs8664 we should use TARGET platform isWindows = case buildOS of - Windows -> True - _ -> False + Windows -> True + _ -> False - supportsRelocatableProgs GHC = isWindows + supportsRelocatableProgs GHC = isWindows supportsRelocatableProgs GHCJS = isWindows - supportsRelocatableProgs _ = False + supportsRelocatableProgs _ = False cid = componentUnitId clbi InstallDirs - { bindir = flat_bindir - , libdir = flat_libdir - , dynlibdir = flat_dynlibdir - , datadir = flat_datadir - , libexecdir = flat_libexecdir - , sysconfdir = flat_sysconfdir - , prefix = flat_prefix - } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest + { bindir = flat_bindir + , libdir = flat_libdir + , dynlibdir = flat_dynlibdir + , datadir = flat_datadir + , libexecdir = flat_libexecdir + , sysconfdir = flat_sysconfdir + , prefix = flat_prefix + } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest InstallDirs - { bindir = flat_bindirrel - , libdir = flat_libdirrel - , dynlibdir = flat_dynlibdirrel - , datadir = flat_datadirrel - , libexecdir = flat_libexecdirrel - , sysconfdir = flat_sysconfdirrel - } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid + { bindir = flat_bindirrel + , libdir = flat_libdirrel + , dynlibdir = flat_dynlibdirrel + , datadir = flat_datadirrel + , libexecdir = flat_libexecdirrel + , sysconfdir = flat_sysconfdirrel + } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir :: String (zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir) - | relocatable lbi = - ( show flat_bindir_reloc - , show flat_libdir_reloc - , show flat_dynlibdir_reloc - , show flat_datadir_reloc - , show flat_libexecdir_reloc - , show flat_sysconfdir_reloc - ) - | absolute = - ( show flat_bindir - , show flat_libdir - , show flat_dynlibdir - , show flat_datadir - , show flat_libexecdir - , show flat_sysconfdir - ) - | isWindows = - ( "maybe (error \"PathsModule.generate\") id (" ++ show flat_bindirrel ++ ")" - , mkGetDir flat_libdir flat_libdirrel - , mkGetDir flat_dynlibdir flat_dynlibdirrel - , mkGetDir flat_datadir flat_datadirrel - , mkGetDir flat_libexecdir flat_libexecdirrel - , mkGetDir flat_sysconfdir flat_sysconfdirrel - ) - | otherwise = - error "panic! generatePathsModule: should never happen" + | relocatable lbi = + ( show flat_bindir_reloc + , show flat_libdir_reloc + , show flat_dynlibdir_reloc + , show flat_datadir_reloc + , show flat_libexecdir_reloc + , show flat_sysconfdir_reloc + ) + | absolute = + ( show flat_bindir + , show flat_libdir + , show flat_dynlibdir + , show flat_datadir + , show flat_libexecdir + , show flat_sysconfdir + ) + | isWindows = + ( "maybe (error \"PathsModule.generate\") id (" ++ show flat_bindirrel ++ ")" + , mkGetDir flat_libdir flat_libdirrel + , mkGetDir flat_dynlibdir flat_dynlibdirrel + , mkGetDir flat_datadir flat_datadirrel + , mkGetDir flat_libexecdir flat_libexecdirrel + , mkGetDir flat_sysconfdir flat_sysconfdirrel + ) + | otherwise = + error "panic! generatePathsModule: should never happen" mkGetDir :: FilePath -> Maybe FilePath -> String - mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel - mkGetDir dir Nothing = "return " ++ show dir + mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel + mkGetDir dir Nothing = "return " ++ show dir - flat_bindir_reloc = shortRelativePath flat_prefix flat_bindir - flat_libdir_reloc = shortRelativePath flat_prefix flat_libdir - flat_dynlibdir_reloc = shortRelativePath flat_prefix flat_dynlibdir - flat_datadir_reloc = shortRelativePath flat_prefix flat_datadir + flat_bindir_reloc = shortRelativePath flat_prefix flat_bindir + flat_libdir_reloc = shortRelativePath flat_prefix flat_libdir + flat_dynlibdir_reloc = shortRelativePath flat_prefix flat_dynlibdir + flat_datadir_reloc = shortRelativePath flat_prefix flat_datadir flat_libexecdir_reloc = shortRelativePath flat_prefix flat_libexecdir flat_sysconfdir_reloc = shortRelativePath flat_prefix flat_sysconfdir @@ -149,15 +153,17 @@ -- Note: The format of these strings is part of Cabal's public API; -- changing this function constitutes a *backwards-compatibility* break. pkgPathEnvVar - :: PackageDescription - -> String -- ^ path component; one of \"bindir\", \"libdir\", -- \"datadir\", \"libexecdir\", or \"sysconfdir\" - -> String -- ^ environment variable name + :: PackageDescription + -> String + -- ^ path component; one of \"bindir\", \"libdir\", -- \"datadir\", \"libexecdir\", or \"sysconfdir\" + -> String + -- ^ environment variable name pkgPathEnvVar pkg_descr var = - showPkgName (packageName pkg_descr) ++ "_" ++ var + showPkgName (packageName pkg_descr) ++ "_" ++ var showPkgName :: PackageName -> String showPkgName = map fixchar . unPackageName fixchar :: Char -> Char fixchar '-' = '_' -fixchar c = c +fixchar c = c 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 @@ -1,3 +1,4 @@ +{- FOURMOLU_DISABLE -} {-# LANGUAGE DeriveGeneric #-} module Distribution.Simple.Build.PathsModule.Z (render, Z(..)) where import Distribution.ZinzaPrelude 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,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.BuildPaths -- Copyright : Isaac Jones 2003-2004, @@ -11,53 +13,59 @@ -- Portability : portable -- -- A bunch of dirs, paths and file names used for intermediate build steps. --- - -module Distribution.Simple.BuildPaths ( - defaultDistPref, srcPref, - buildInfoPref, haddockDirName, hscolourPref, haddockPref, - autogenPackageModulesDir, - autogenComponentModulesDir, - - autogenPathsModuleName, - autogenPackageInfoModuleName, - cppHeaderName, - haddockName, - - mkGenericStaticLibName, - mkLibName, - mkProfLibName, - mkGenericSharedLibName, - mkSharedLibName, - mkStaticLibName, - mkGenericSharedBundledLibName, +module Distribution.Simple.BuildPaths + ( defaultDistPref + , srcPref + , buildInfoPref + , haddockDirName + , hscolourPref + , haddockPref + , autogenPackageModulesDir + , autogenComponentModulesDir + , autogenPathsModuleName + , autogenPackageInfoModuleName + , cppHeaderName + , haddockName + , mkGenericStaticLibName + , mkLibName + , mkProfLibName + , mkGenericSharedLibName + , mkSharedLibName + , mkStaticLibName + , mkGenericSharedBundledLibName + , exeExtension + , objExtension + , dllExtension + , staticLibExtension - exeExtension, - objExtension, - dllExtension, - staticLibExtension, -- * Source files & build directories - getSourceFiles, getLibSourceFiles, getExeSourceFiles, - getFLibSourceFiles, exeBuildDir, flibBuildDir, + , getSourceFiles + , getLibSourceFiles + , getExeSourceFiles + , getFLibSourceFiles + , exeBuildDir + , flibBuildDir ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Package -import Distribution.ModuleName as ModuleName +import Data.List (stripPrefix) import Distribution.Compiler +import Distribution.ModuleName as ModuleName +import Distribution.Package import Distribution.PackageDescription -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Setup import Distribution.Pretty -import Distribution.System -import Distribution.Verbosity +import Distribution.Simple.Errors +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PreProcess.Types (builtinHaskellSuffixes) +import Distribution.Simple.Setup.Common (defaultDistPref) +import Distribution.Simple.Setup.Haddock (HaddockTarget (..)) import Distribution.Simple.Utils +import Distribution.System import Distribution.Utils.Path - -import Data.List (stripPrefix) -import System.FilePath ((), (<.>), normalise) +import Distribution.Verbosity +import System.FilePath (normalise, (<.>), ()) -- --------------------------------------------------------------------------- -- Build directories and files @@ -80,8 +88,8 @@ -- | The directory to which generated haddock documentation should be written. haddockPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath -haddockPref haddockTarget distPref pkg_descr - = distPref "doc" "html" haddockDirName haddockTarget pkg_descr +haddockPref haddockTarget distPref pkg_descr = + distPref "doc" "html" haddockDirName haddockTarget pkg_descr -- | The directory in which we put auto-generated modules for EVERY -- component in the package. @@ -92,6 +100,7 @@ -- particular component. autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> String autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi "autogen" + -- NB: Look at 'checkForeignDeps' for where a simplified version of this -- has been copy-pasted. @@ -103,16 +112,18 @@ autogenPathsModuleName pkg_descr = ModuleName.fromString $ "Paths_" ++ map fixchar (prettyShow (packageName pkg_descr)) - where fixchar '-' = '_' - fixchar c = c + where + fixchar '-' = '_' + fixchar c = c -- | The name of the auto-generated PackageInfo_* module associated with a package autogenPackageInfoModuleName :: PackageDescription -> ModuleName autogenPackageInfoModuleName pkg_descr = ModuleName.fromString $ "PackageInfo_" ++ map fixchar (prettyShow (packageName pkg_descr)) - where fixchar '-' = '_' - fixchar c = c + where + fixchar '-' = '_' + fixchar c = c haddockName :: PackageDescription -> FilePath haddockName pkg_descr = prettyShow (packageName pkg_descr) <.> "haddock" @@ -120,56 +131,70 @@ -- ----------------------------------------------------------------------------- -- Source File helper -getLibSourceFiles :: Verbosity - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] +getLibSourceFiles + :: Verbosity + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, FilePath)] getLibSourceFiles verbosity lbi lib clbi = getSourceFiles verbosity searchpaths modules where - bi = libBuildInfo lib - modules = allLibModules lib clbi - searchpaths = componentBuildDir lbi clbi : map getSymbolicPath (hsSourceDirs bi) ++ - [ autogenComponentModulesDir lbi clbi - , autogenPackageModulesDir lbi ] + bi = libBuildInfo lib + modules = allLibModules lib clbi + searchpaths = + componentBuildDir lbi clbi + : map getSymbolicPath (hsSourceDirs bi) + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] -getExeSourceFiles :: Verbosity - -> LocalBuildInfo - -> Executable - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] +getExeSourceFiles + :: Verbosity + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, FilePath)] getExeSourceFiles verbosity lbi exe clbi = do - moduleFiles <- getSourceFiles verbosity searchpaths modules - srcMainPath <- findFileEx verbosity (map getSymbolicPath $ hsSourceDirs bi) (modulePath exe) - return ((ModuleName.main, srcMainPath) : moduleFiles) + moduleFiles <- getSourceFiles verbosity searchpaths modules + srcMainPath <- findFileEx verbosity (map getSymbolicPath $ hsSourceDirs bi) (modulePath exe) + return ((ModuleName.main, srcMainPath) : moduleFiles) where - bi = buildInfo exe - modules = otherModules bi - searchpaths = autogenComponentModulesDir lbi clbi - : autogenPackageModulesDir lbi - : exeBuildDir lbi exe : map getSymbolicPath (hsSourceDirs bi) + bi = buildInfo exe + modules = otherModules bi + searchpaths = + autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : exeBuildDir lbi exe + : map getSymbolicPath (hsSourceDirs bi) -getFLibSourceFiles :: Verbosity - -> LocalBuildInfo - -> ForeignLib - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] +getFLibSourceFiles + :: Verbosity + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, FilePath)] getFLibSourceFiles verbosity lbi flib clbi = getSourceFiles verbosity searchpaths modules where - bi = foreignLibBuildInfo flib - modules = otherModules bi - searchpaths = autogenComponentModulesDir lbi clbi - : autogenPackageModulesDir lbi - : flibBuildDir lbi flib : map getSymbolicPath (hsSourceDirs bi) + bi = foreignLibBuildInfo flib + modules = otherModules bi + searchpaths = + autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : flibBuildDir lbi flib + : map getSymbolicPath (hsSourceDirs bi) -getSourceFiles :: Verbosity -> [FilePath] - -> [ModuleName.ModuleName] - -> IO [(ModuleName.ModuleName, FilePath)] -getSourceFiles verbosity dirs modules = flip traverse modules $ \m -> fmap ((,) m) $ - findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m) +getSourceFiles + :: Verbosity + -> [FilePath] + -> [ModuleName.ModuleName] + -> IO [(ModuleName.ModuleName, FilePath)] +getSourceFiles verbosity dirs modules = flip traverse modules $ \m -> + fmap ((,) m) $ + findFileWithExtension builtinHaskellSuffixes dirs (ModuleName.toFilePath m) >>= maybe (notFound m) (return . normalise) where - notFound module_ = die' verbosity $ "can't find source for module " ++ prettyShow module_ + notFound module_ = + dieWithException verbosity $ CantFindSourceModule module_ -- | The directory where we put build results for an executable exeBuildDir :: LocalBuildInfo -> Executable -> FilePath @@ -195,29 +220,31 @@ mkLibName lib = mkGenericStaticLibName (getHSLibraryName lib) mkProfLibName :: UnitId -> String -mkProfLibName lib = mkGenericStaticLibName (getHSLibraryName lib ++ "_p") +mkProfLibName lib = mkGenericStaticLibName (getHSLibraryName lib ++ "_p") -- | Create a library name for a shared library from a given name. -- Prepends @lib@ and appends the @-\\@ -- as well as the shared library extension. mkGenericSharedLibName :: Platform -> CompilerId -> String -> String -mkGenericSharedLibName platform (CompilerId compilerFlavor compilerVersion) lib - = mconcat [ "lib", lib, "-", comp <.> dllExtension platform ] - where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion +mkGenericSharedLibName platform (CompilerId compilerFlavor compilerVersion) lib = + mconcat ["lib", lib, "-", comp <.> dllExtension platform] + where + comp = prettyShow compilerFlavor ++ prettyShow compilerVersion -- Implement proper name mangling for dynamical shared objects -- @libHS\-\\@ -- e.g. @libHSbase-2.1-ghc6.6.1.so@ mkSharedLibName :: Platform -> CompilerId -> UnitId -> String -mkSharedLibName platform comp lib - = mkGenericSharedLibName platform comp (getHSLibraryName lib) +mkSharedLibName platform comp lib = + mkGenericSharedLibName platform comp (getHSLibraryName lib) -- Static libs are named the same as shared libraries, only with -- a different extension. mkStaticLibName :: Platform -> CompilerId -> UnitId -> String -mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib - = "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform - where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion +mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib = + "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform + where + comp = prettyShow compilerFlavor ++ prettyShow compilerVersion -- | Create a library name for a bundled shared library from a given name. -- This matches the naming convention for shared libraries as implemented in @@ -230,24 +257,26 @@ -- "Cffi" -> "libffi.so" mkGenericSharedBundledLibName :: Platform -> CompilerId -> String -> String mkGenericSharedBundledLibName platform comp lib - | "HS" `isPrefixOf` lib - = mkGenericSharedLibName platform comp lib - | Just lib' <- stripPrefix "C" lib - = "lib" ++ lib' <.> dllExtension platform - | otherwise - = error ("Don't understand library name " ++ lib) + | "HS" `isPrefixOf` lib = + mkGenericSharedLibName platform comp lib + | Just lib' <- stripPrefix "C" lib = + "lib" ++ lib' <.> dllExtension platform + | otherwise = + error ("Don't understand library name " ++ lib) -- ------------------------------------------------------------ + -- * Platform file extensions + -- ------------------------------------------------------------ -- | Default extension for executable files on the current platform. -- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) exeExtension :: Platform -> String exeExtension platform = case platform of - Platform _ Windows -> "exe" - Platform Wasm32 _ -> "wasm" - _ -> "" + Platform _ Windows -> "exe" + Platform Wasm32 _ -> "wasm" + _ -> "" -- | Extension for object files. For GHC the extension is @\"o\"@. objExtension :: String @@ -256,10 +285,10 @@ -- | Extension for dynamically linked (or shared) libraries -- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows) dllExtension :: Platform -> String -dllExtension (Platform _arch os)= case os of - Windows -> "dll" - OSX -> "dylib" - _ -> "so" +dllExtension (Platform _arch os) = case os of + Windows -> "dll" + OSX -> "dylib" + _ -> "so" -- | Extension for static libraries -- @@ -267,5 +296,5 @@ -- interested in, not the build OS. staticLibExtension :: Platform -> String staticLibExtension (Platform _arch os) = case os of - Windows -> "lib" - _ -> "a" + Windows -> "lib" + _ -> "a" 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 @@ -1,1064 +1,1110 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.BuildTargets --- Copyright : (c) Duncan Coutts 2012 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- --- Handling for user-specified build targets ------------------------------------------------------------------------------ -module Distribution.Simple.BuildTarget ( - -- * Main interface - readTargetInfos, - readBuildTargets, -- in case you don't have LocalBuildInfo - - -- * Build targets - BuildTarget(..), - showBuildTarget, - QualLevel(..), - buildTargetComponentName, - - -- * Parsing user build targets - UserBuildTarget, - readUserBuildTargets, - showUserBuildTarget, - UserBuildTargetProblem(..), - reportUserBuildTargetProblems, - - -- * Resolving build targets - resolveBuildTargets, - BuildTargetProblem(..), - reportBuildTargetProblems, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.TargetInfo -import Distribution.Types.LocalBuildInfo -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.ForeignLib -import Distribution.Types.UnqualComponentName - -import Distribution.Package -import Distribution.PackageDescription -import Distribution.ModuleName -import Distribution.Simple.LocalBuildInfo -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Simple.Utils -import Distribution.Verbosity -import Distribution.Utils.Path - -import qualified Distribution.Compat.CharParsing as P - -import Control.Monad ( msum ) -import Data.List ( stripPrefix, groupBy ) -import qualified Data.List.NonEmpty as NE -import System.FilePath as FilePath - ( dropExtension, normalise, splitDirectories, joinPath, splitPath - , hasTrailingPathSeparator ) -import System.Directory ( doesFileExist, doesDirectoryExist ) -import qualified Data.Map as Map - --- | Take a list of 'String' build targets, and parse and validate them --- into actual 'TargetInfo's to be built/registered/whatever. -readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo] -readTargetInfos verbosity pkg_descr lbi args = do - build_targets <- readBuildTargets verbosity pkg_descr args - checkBuildTargets verbosity pkg_descr lbi build_targets - --- ------------------------------------------------------------ --- * User build targets --- ------------------------------------------------------------ - --- | Various ways that a user may specify a build target. --- -data UserBuildTarget = - - -- | A target specified by a single name. This could be a component - -- module or file. - -- - -- > cabal build foo - -- > cabal build Data.Foo - -- > cabal build Data/Foo.hs Data/Foo.hsc - -- - UserBuildTargetSingle String - - -- | A target specified by a qualifier and name. This could be a component - -- name qualified by the component namespace kind, or a module or file - -- qualified by the component name. - -- - -- > cabal build lib:foo exe:foo - -- > cabal build foo:Data.Foo - -- > cabal build foo:Data/Foo.hs - -- - | UserBuildTargetDouble String String - - -- | A fully qualified target, either a module or file qualified by a - -- component name with the component namespace kind. - -- - -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs - -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo - -- - | UserBuildTargetTriple String String String - deriving (Show, Eq, Ord) - - --- ------------------------------------------------------------ --- * Resolved build targets --- ------------------------------------------------------------ - --- | A fully resolved build target. --- -data BuildTarget = - - -- | A specific component - -- - BuildTargetComponent ComponentName - - -- | A specific module within a specific component. - -- - | BuildTargetModule ComponentName ModuleName - - -- | A specific file within a specific component. - -- - | BuildTargetFile ComponentName FilePath - deriving (Eq, Show, Generic) - -instance Binary BuildTarget - -buildTargetComponentName :: BuildTarget -> ComponentName -buildTargetComponentName (BuildTargetComponent cn) = cn -buildTargetComponentName (BuildTargetModule cn _) = cn -buildTargetComponentName (BuildTargetFile cn _) = cn - --- | Read a list of user-supplied build target strings and resolve them to --- 'BuildTarget's according to a 'PackageDescription'. If there are problems --- with any of the targets e.g. they don't exist or are misformatted, throw an --- 'IOException'. -readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget] -readBuildTargets verbosity pkg targetStrs = do - let (uproblems, utargets) = readUserBuildTargets targetStrs - reportUserBuildTargetProblems verbosity uproblems - - utargets' <- traverse checkTargetExistsAsFile utargets - - let (bproblems, btargets) = resolveBuildTargets pkg utargets' - reportBuildTargetProblems verbosity bproblems - - return btargets - -checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool) -checkTargetExistsAsFile t = do - fexists <- existsAsFile (fileComponentOfTarget t) - return (t, fexists) - - where - existsAsFile f = do - exists <- doesFileExist f - case splitPath f of - (d:_) | hasTrailingPathSeparator d -> doesDirectoryExist d - (d:_:_) | not exists -> doesDirectoryExist d - _ -> return exists - - fileComponentOfTarget (UserBuildTargetSingle s1) = s1 - fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2 - fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3 - - --- ------------------------------------------------------------ --- * Parsing user targets --- ------------------------------------------------------------ - -readUserBuildTargets :: [String] -> ([UserBuildTargetProblem] - ,[UserBuildTarget]) -readUserBuildTargets = partitionEithers . map readUserBuildTarget - --- | --- --- >>> readUserBuildTarget "comp" --- Right (UserBuildTargetSingle "comp") --- --- >>> readUserBuildTarget "lib:comp" --- Right (UserBuildTargetDouble "lib" "comp") --- --- >>> readUserBuildTarget "pkg:lib:comp" --- Right (UserBuildTargetTriple "pkg" "lib" "comp") --- --- >>> readUserBuildTarget "\"comp\"" --- Right (UserBuildTargetSingle "comp") --- --- >>> readUserBuildTarget "lib:\"comp\"" --- Right (UserBuildTargetDouble "lib" "comp") --- --- >>> readUserBuildTarget "pkg:lib:\"comp\"" --- Right (UserBuildTargetTriple "pkg" "lib" "comp") --- --- >>> readUserBuildTarget "pkg:lib:comp:more" --- Left (UserBuildTargetUnrecognised "pkg:lib:comp:more") --- --- >>> readUserBuildTarget "pkg:\"lib\":comp" --- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp") --- -readUserBuildTarget :: String -> Either UserBuildTargetProblem - UserBuildTarget -readUserBuildTarget targetstr = - case explicitEitherParsec parseTargetApprox targetstr of - Left _ -> Left (UserBuildTargetUnrecognised targetstr) - Right tgt -> Right tgt - - where - parseTargetApprox :: CabalParsing m => m UserBuildTarget - parseTargetApprox = do - -- read one, two, or three tokens, where last could be "hs-string" - ts <- tokens - return $ case ts of - (a, Nothing) -> UserBuildTargetSingle a - (a, Just (b, Nothing)) -> UserBuildTargetDouble a b - (a, Just (b, Just c)) -> UserBuildTargetTriple a b c - - tokens :: CabalParsing m => m (String, Maybe (String, Maybe String)) - tokens = (\s -> (s, Nothing)) <$> parsecHaskellString - <|> (,) <$> token <*> P.optional (P.char ':' *> tokens2) - - tokens2 :: CabalParsing m => m (String, Maybe String) - tokens2 = (\s -> (s, Nothing)) <$> parsecHaskellString - <|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token)) - - token :: CabalParsing m => m String - token = P.munch1 (\x -> not (isSpace x) && x /= ':') - -data UserBuildTargetProblem - = UserBuildTargetUnrecognised String - deriving Show - -reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO () -reportUserBuildTargetProblems verbosity problems = do - case [ target | UserBuildTargetUnrecognised target <- problems ] of - [] -> return () - target -> - die' verbosity $ unlines - [ "Unrecognised build target '" ++ name ++ "'." - | name <- target ] - ++ "Examples:\n" - ++ " - build foo -- component name " - ++ "(library, executable, test-suite or benchmark)\n" - ++ " - build Data.Foo -- module name\n" - ++ " - build Data/Foo.hsc -- file name\n" - ++ " - build lib:foo exe:foo -- component qualified by kind\n" - ++ " - build foo:Data.Foo -- module qualified by component\n" - ++ " - build foo:Data/Foo.hsc -- file qualified by component" - -showUserBuildTarget :: UserBuildTarget -> String -showUserBuildTarget = intercalate ":" . getComponents - where - getComponents (UserBuildTargetSingle s1) = [s1] - getComponents (UserBuildTargetDouble s1 s2) = [s1,s2] - getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3] - --- | Unless you use 'QL1', this function is PARTIAL; --- use 'showBuildTarget' instead. -showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String -showBuildTarget' ql pkgid bt = - showUserBuildTarget (renderBuildTarget ql bt pkgid) - --- | Unambiguously render a 'BuildTarget', so that it can --- be parsed in all situations. -showBuildTarget :: PackageId -> BuildTarget -> String -showBuildTarget pkgid t = - showBuildTarget' (qlBuildTarget t) pkgid t - where - qlBuildTarget BuildTargetComponent{} = QL2 - qlBuildTarget _ = QL3 - - --- ------------------------------------------------------------ --- * Resolving user targets to build targets --- ------------------------------------------------------------ - -{- -stargets = - [ BuildTargetComponent (CExeName "foo") - , BuildTargetModule (CExeName "foo") (mkMn "Foo") - , BuildTargetModule (CExeName "tst") (mkMn "Foo") - ] - where - mkMn :: String -> ModuleName - mkMn = fromJust . simpleParse - -ex_pkgid :: PackageIdentifier -Just ex_pkgid = simpleParse "thelib" --} - --- | Given a bunch of user-specified targets, try to resolve what it is they --- refer to. --- -resolveBuildTargets :: PackageDescription - -> [(UserBuildTarget, Bool)] - -> ([BuildTargetProblem], [BuildTarget]) -resolveBuildTargets pkg = partitionEithers - . map (uncurry (resolveBuildTarget pkg)) - -resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool - -> Either BuildTargetProblem BuildTarget -resolveBuildTarget pkg userTarget fexists = - case findMatch (matchBuildTarget pkg userTarget fexists) of - Unambiguous target -> Right target - Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets') - where targets' = disambiguateBuildTargets - (packageId pkg) - userTarget - targets - None errs -> Left (classifyMatchErrors errs) - - where - classifyMatchErrors errs - | Just expected' <- NE.nonEmpty expected - = let (things, got:|_) = NE.unzip expected' in - BuildTargetExpected userTarget (NE.toList things) got - | not (null nosuch) = BuildTargetNoSuch userTarget nosuch - | otherwise = error $ "resolveBuildTarget: internal error in matching" - where - expected = [ (thing, got) | MatchErrorExpected thing got <- errs ] - nosuch = [ (thing, got) | MatchErrorNoSuch thing got <- errs ] - - -data BuildTargetProblem - = BuildTargetExpected UserBuildTarget [String] String - -- ^ [expected thing] (actually got) - | BuildTargetNoSuch UserBuildTarget [(String, String)] - -- ^ [(no such thing, actually got)] - | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)] - deriving Show - - -disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget] - -> [(UserBuildTarget, BuildTarget)] -disambiguateBuildTargets pkgid original = - disambiguate (userTargetQualLevel original) - where - disambiguate ql ts - | null amb = unamb - | otherwise = unamb ++ disambiguate (succ ql) amb - where - (amb, unamb) = step ql ts - - userTargetQualLevel (UserBuildTargetSingle _ ) = QL1 - userTargetQualLevel (UserBuildTargetDouble _ _ ) = QL2 - userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3 - - step :: QualLevel -> [BuildTarget] - -> ([BuildTarget], [(UserBuildTarget, BuildTarget)]) - step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb)) - . partition (\g -> length g > 1) - . groupBy (equating fst) - . sortBy (comparing fst) - . map (\t -> (renderBuildTarget ql t pkgid, t)) - -data QualLevel = QL1 | QL2 | QL3 - deriving (Enum, Show) - -renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget -renderBuildTarget ql target pkgid = - case ql of - QL1 -> UserBuildTargetSingle s1 where s1 = single target - QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target - QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target - - where - single (BuildTargetComponent cn ) = dispCName cn - single (BuildTargetModule _ m) = prettyShow m - single (BuildTargetFile _ f) = f - - double (BuildTargetComponent cn ) = (dispKind cn, dispCName cn) - double (BuildTargetModule cn m) = (dispCName cn, prettyShow m) - double (BuildTargetFile cn f) = (dispCName cn, f) - - triple (BuildTargetComponent _ ) = error "triple BuildTargetComponent" - triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow m) - triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f) - - dispCName = componentStringName pkgid - dispKind = showComponentKindShort . componentKind - -reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO () -reportBuildTargetProblems verbosity problems = do - - case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unrecognised build target '" ++ showUserBuildTarget target - ++ "'.\n" - ++ "Expected a " ++ intercalate " or " expected - ++ ", rather than '" ++ got ++ "'." - | (target, expected, got) <- targets ] - - case [ (t, e) | BuildTargetNoSuch t e <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unknown build target '" ++ showUserBuildTarget target - ++ "'.\nThere is no " - ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" - | (thing, got) <- nosuch ] ++ "." - | (target, nosuch) <- targets ] - where - mungeThing "file" = "file target" - mungeThing thing = thing - - case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Ambiguous build target '" ++ showUserBuildTarget target - ++ "'. It could be:\n " - ++ unlines [ " "++ showUserBuildTarget ut ++ - " (" ++ showBuildTargetKind bt ++ ")" - | (ut, bt) <- amb ] - | (target, amb) <- targets ] - - where - showBuildTargetKind (BuildTargetComponent _ ) = "component" - showBuildTargetKind (BuildTargetModule _ _) = "module" - showBuildTargetKind (BuildTargetFile _ _) = "file" - - ----------------------------------- --- Top level BuildTarget matcher --- - -matchBuildTarget :: PackageDescription - -> UserBuildTarget -> Bool -> Match BuildTarget -matchBuildTarget pkg = \utarget fexists -> - case utarget of - UserBuildTargetSingle str1 -> - matchBuildTarget1 cinfo str1 fexists - - UserBuildTargetDouble str1 str2 -> - matchBuildTarget2 cinfo str1 str2 fexists - - UserBuildTargetTriple str1 str2 str3 -> - matchBuildTarget3 cinfo str1 str2 str3 fexists - where - cinfo = pkgComponentInfo pkg - -matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget -matchBuildTarget1 cinfo str1 fexists = - matchComponent1 cinfo str1 - `matchPlusShadowing` matchModule1 cinfo str1 - `matchPlusShadowing` matchFile1 cinfo str1 fexists - - -matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool - -> Match BuildTarget -matchBuildTarget2 cinfo str1 str2 fexists = - matchComponent2 cinfo str1 str2 - `matchPlusShadowing` matchModule2 cinfo str1 str2 - `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists - - -matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool - -> Match BuildTarget -matchBuildTarget3 cinfo str1 str2 str3 fexists = - matchModule3 cinfo str1 str2 str3 - `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists - - -data ComponentInfo = ComponentInfo { - cinfoName :: ComponentName, - cinfoStrName :: ComponentStringName, - cinfoSrcDirs :: [FilePath], - cinfoModules :: [ModuleName], - cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) - cinfoAsmFiles:: [FilePath], - cinfoCmmFiles:: [FilePath], - cinfoCFiles :: [FilePath], - cinfoCxxFiles:: [FilePath], - cinfoJsFiles :: [FilePath] - } - -type ComponentStringName = String - -pkgComponentInfo :: PackageDescription -> [ComponentInfo] -pkgComponentInfo pkg = - [ ComponentInfo { - cinfoName = componentName c, - cinfoStrName = componentStringName pkg (componentName c), - cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi, - cinfoModules = componentModules c, - cinfoHsFiles = componentHsFiles c, - cinfoAsmFiles= asmSources bi, - cinfoCmmFiles= cmmSources bi, - cinfoCFiles = cSources bi, - cinfoCxxFiles= cxxSources bi, - cinfoJsFiles = jsSources bi - } - | c <- pkgComponents pkg - , let bi = componentBuildInfo c ] - -componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName -componentStringName pkg (CLibName LMainLibName ) = prettyShow (packageName pkg) -componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name -componentStringName _ (CFLibName name) = unUnqualComponentName name -componentStringName _ (CExeName name) = unUnqualComponentName name -componentStringName _ (CTestName name) = unUnqualComponentName name -componentStringName _ (CBenchName name) = unUnqualComponentName name - -componentModules :: Component -> [ModuleName] --- TODO: Use of 'explicitLibModules' here is a bit wrong: --- a user could very well ask to build a specific signature --- that was inherited from other packages. To fix this --- we have to plumb 'LocalBuildInfo' through this code. --- Fortunately, this is only used by 'pkgComponentInfo' --- Please don't export this function unless you plan on fixing --- this. -componentModules (CLib lib) = explicitLibModules lib -componentModules (CFLib flib) = foreignLibModules flib -componentModules (CExe exe) = exeModules exe -componentModules (CTest test) = testModules test -componentModules (CBench bench) = benchmarkModules bench - -componentHsFiles :: Component -> [FilePath] -componentHsFiles (CExe exe) = [modulePath exe] -componentHsFiles (CTest TestSuite { - testInterface = TestSuiteExeV10 _ mainfile - }) = [mainfile] -componentHsFiles (CBench Benchmark { - benchmarkInterface = BenchmarkExeV10 _ mainfile - }) = [mainfile] -componentHsFiles _ = [] - -{- -ex_cs :: [ComponentInfo] -ex_cs = - [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) - , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) - ] - where - mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms) - mkMn :: String -> ModuleName - mkMn = fromJust . simpleParse - pkgid :: PackageIdentifier - Just pkgid = simpleParse "thelib" --} - ------------------------------- --- Matching component kinds --- - -data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind - deriving (Eq, Ord, Show, Enum, Bounded) - -componentKind :: ComponentName -> ComponentKind -componentKind (CLibName _) = LibKind -componentKind (CFLibName _) = FLibKind -componentKind (CExeName _) = ExeKind -componentKind (CTestName _) = TestKind -componentKind (CBenchName _) = BenchKind - -cinfoKind :: ComponentInfo -> ComponentKind -cinfoKind = componentKind . cinfoName - -matchComponentKind :: String -> Match ComponentKind -matchComponentKind s - | s `elem` ["lib", "library"] = return' LibKind - | s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind - | s `elem` ["exe", "executable"] = return' ExeKind - | s `elem` ["tst", "test", "test-suite"] = return' TestKind - | s `elem` ["bench", "benchmark"] = return' BenchKind - | otherwise = matchErrorExpected "component kind" s - where - return' ck = increaseConfidence >> return ck - -showComponentKind :: ComponentKind -> String -showComponentKind LibKind = "library" -showComponentKind FLibKind = "foreign-library" -showComponentKind ExeKind = "executable" -showComponentKind TestKind = "test-suite" -showComponentKind BenchKind = "benchmark" - -showComponentKindShort :: ComponentKind -> String -showComponentKindShort LibKind = "lib" -showComponentKindShort FLibKind = "flib" -showComponentKindShort ExeKind = "exe" -showComponentKindShort TestKind = "test" -showComponentKindShort BenchKind = "bench" - ------------------------------- --- Matching component targets --- - -matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget -matchComponent1 cs = \str1 -> do - guardComponentName str1 - c <- matchComponentName cs str1 - return (BuildTargetComponent (cinfoName c)) - -matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget -matchComponent2 cs = \str1 str2 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - return (BuildTargetComponent (cinfoName c)) - --- utils: - -guardComponentName :: String -> Match () -guardComponentName s - | all validComponentChar s - && not (null s) = increaseConfidence - | otherwise = matchErrorExpected "component name" s - where - validComponentChar c = isAlphaNum c || c == '.' - || c == '_' || c == '-' || c == '\'' - -matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo -matchComponentName cs str = - orNoSuchThing "component" str - $ increaseConfidenceFor - $ matchInexactly caseFold - [ (cinfoStrName c, c) | c <- cs ] - str - -matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String - -> Match ComponentInfo -matchComponentKindAndName cs ckind str = - orNoSuchThing (showComponentKind ckind ++ " component") str - $ increaseConfidenceFor - $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) - [ ((cinfoKind c, cinfoStrName c), c) | c <- cs ] - (ckind, str) - - ------------------------------- --- Matching module targets --- - -matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget -matchModule1 cs = \str1 -> do - guardModuleName str1 - nubMatchErrors $ do - c <- tryEach cs - let ms = cinfoModules c - m <- matchModuleName ms str1 - return (BuildTargetModule (cinfoName c) m) - -matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget -matchModule2 cs = \str1 str2 -> do - guardComponentName str1 - guardModuleName str2 - c <- matchComponentName cs str1 - let ms = cinfoModules c - m <- matchModuleName ms str2 - return (BuildTargetModule (cinfoName c) m) - -matchModule3 :: [ComponentInfo] -> String -> String -> String - -> Match BuildTarget -matchModule3 cs str1 str2 str3 = do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - guardModuleName str3 - let ms = cinfoModules c - m <- matchModuleName ms str3 - return (BuildTargetModule (cinfoName c) m) - --- utils: - -guardModuleName :: String -> Match () -guardModuleName s - | all validModuleChar s - && not (null s) = increaseConfidence - | otherwise = matchErrorExpected "module name" s - where - validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' - -matchModuleName :: [ModuleName] -> String -> Match ModuleName -matchModuleName ms str = - orNoSuchThing "module" str - $ increaseConfidenceFor - $ matchInexactly caseFold - [ (prettyShow m, m) - | m <- ms ] - str - - ------------------------------- --- Matching file targets --- - -matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget -matchFile1 cs str1 exists = - nubMatchErrors $ do - c <- tryEach cs - filepath <- matchComponentFile c str1 exists - return (BuildTargetFile (cinfoName c) filepath) - - -matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget -matchFile2 cs str1 str2 exists = do - guardComponentName str1 - c <- matchComponentName cs str1 - filepath <- matchComponentFile c str2 exists - return (BuildTargetFile (cinfoName c) filepath) - - -matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool - -> Match BuildTarget -matchFile3 cs str1 str2 str3 exists = do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - filepath <- matchComponentFile c str3 exists - return (BuildTargetFile (cinfoName c) filepath) - - -matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath -matchComponentFile c str fexists = - expecting "file" str $ - matchPlus - (matchFileExists str fexists) - (matchPlusShadowing - (msum [ matchModuleFileRooted dirs ms str - , matchOtherFileRooted dirs hsFiles str ]) - (msum [ matchModuleFileUnrooted ms str - , matchOtherFileUnrooted hsFiles str - , matchOtherFileUnrooted cFiles str - , matchOtherFileUnrooted jsFiles str ])) - where - dirs = cinfoSrcDirs c - ms = cinfoModules c - hsFiles = cinfoHsFiles c - cFiles = cinfoCFiles c - jsFiles = cinfoJsFiles c - - --- utils - -matchFileExists :: FilePath -> Bool -> Match a -matchFileExists _ False = mzero -matchFileExists fname True = do increaseConfidence - matchErrorNoSuch "file" fname - -matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath -matchModuleFileUnrooted ms str = do - let filepath = normalise str - _ <- matchModuleFileStem ms filepath - return filepath - -matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath -matchModuleFileRooted dirs ms str = nubMatches $ do - let filepath = normalise str - filepath' <- matchDirectoryPrefix dirs filepath - _ <- matchModuleFileStem ms filepath' - return filepath - -matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName -matchModuleFileStem ms = - increaseConfidenceFor - . matchInexactly caseFold - [ (toFilePath m, m) | m <- ms ] - . dropExtension - -matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath -matchOtherFileRooted dirs fs str = do - let filepath = normalise str - filepath' <- matchDirectoryPrefix dirs filepath - _ <- matchFile fs filepath' - return filepath - -matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath -matchOtherFileUnrooted fs str = do - let filepath = normalise str - _ <- matchFile fs filepath - return filepath - -matchFile :: [FilePath] -> FilePath -> Match FilePath -matchFile fs = increaseConfidenceFor - . matchInexactly caseFold [ (f, f) | f <- fs ] - -matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath -matchDirectoryPrefix dirs filepath = - exactMatches $ - catMaybes - [ stripDirectory (normalise dir) filepath | dir <- dirs ] - where - stripDirectory :: FilePath -> FilePath -> Maybe FilePath - stripDirectory dir fp = - joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp) - - ------------------------------- --- Matching monad --- - --- | A matcher embodies a way to match some input as being some recognised --- value. In particular it deals with multiple and ambiguous matches. --- --- There are various matcher primitives ('matchExactly', 'matchInexactly'), --- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can --- run a matcher against an input using 'findMatch'. --- - -data Match a = NoMatch Confidence [MatchError] - | ExactMatch Confidence [a] - | InexactMatch Confidence [a] - deriving Show - -type Confidence = Int - -data MatchError = MatchErrorExpected String String - | MatchErrorNoSuch String String - deriving (Show, Eq) - - -instance Alternative Match where - empty = mzero - (<|>) = mplus - -instance MonadPlus Match where - mzero = matchZero - mplus = matchPlus - -matchZero :: Match a -matchZero = NoMatch 0 [] - --- | Combine two matchers. Exact matches are used over inexact matches --- but if we have multiple exact, or inexact then the we collect all the --- ambiguous matches. --- -matchPlus :: Match a -> Match a -> Match a -matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = - ExactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a -matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = - InexactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b -matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') - | d1 > d2 = a - | d1 < d2 = b - | otherwise = NoMatch d1 (ms ++ ms') - --- | Combine two matchers. This is similar to 'ambiguousWith' with the --- difference that an exact match from the left matcher shadows any exact --- match on the right. Inexact matches are still collected however. --- -matchPlusShadowing :: Match a -> Match a -> Match a -matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a -matchPlusShadowing a b = matchPlus a b - -instance Functor Match where - fmap _ (NoMatch d ms) = NoMatch d ms - fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) - fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) - -instance Applicative Match where - pure a = ExactMatch 0 [a] - (<*>) = ap - -instance Monad Match where - return = pure - - NoMatch d ms >>= _ = NoMatch d ms - ExactMatch d xs >>= f = addDepth d - $ foldr matchPlus matchZero (map f xs) - InexactMatch d xs >>= f = addDepth d . forceInexact - $ foldr matchPlus matchZero (map f xs) - -addDepth :: Confidence -> Match a -> Match a -addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs -addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs -addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs - -forceInexact :: Match a -> Match a -forceInexact (ExactMatch d ys) = InexactMatch d ys -forceInexact m = m - ------------------------------- --- Various match primitives --- - -matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a -matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] -matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got] - -expecting :: String -> String -> Match a -> Match a -expecting thing got (NoMatch 0 _) = matchErrorExpected thing got -expecting _ _ m = m - -orNoSuchThing :: String -> String -> Match a -> Match a -orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got -orNoSuchThing _ _ m = m - -increaseConfidence :: Match () -increaseConfidence = ExactMatch 1 [()] - -increaseConfidenceFor :: Match a -> Match a -increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r - -nubMatches :: Eq 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) - -nubMatchErrors :: Match a -> Match a -nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs) -nubMatchErrors (ExactMatch d xs) = ExactMatch d xs -nubMatchErrors (InexactMatch d xs) = InexactMatch d xs - --- | Lift a list of matches to an exact match. --- -exactMatches, inexactMatches :: [a] -> Match a - -exactMatches [] = matchZero -exactMatches xs = ExactMatch 0 xs - -inexactMatches [] = matchZero -inexactMatches xs = InexactMatch 0 xs - -tryEach :: [a] -> Match a -tryEach = exactMatches - - ------------------------------- --- Top level match runner --- - --- | Given a matcher and a key to look up, use the matcher to find all the --- possible matches. There may be 'None', a single 'Unambiguous' match or --- you may have an 'Ambiguous' match with several possibilities. --- -findMatch :: Eq b => Match b -> MaybeAmbiguous b -findMatch match = - case match of - NoMatch _ msgs -> None (nub msgs) - ExactMatch _ xs -> checkAmbiguous xs - InexactMatch _ xs -> checkAmbiguous xs - where - checkAmbiguous xs = case nub xs of - [x] -> Unambiguous x - xs' -> Ambiguous xs' - -data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a] - deriving Show - - ------------------------------- --- Basic matchers --- - -{- --- | A primitive matcher that looks up a value in a finite 'Map'. The --- value must match exactly. --- -matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b) -matchExactly xs = - \x -> case Map.lookup x m of - Nothing -> matchZero - Just ys -> ExactMatch 0 ys - where - m :: Ord a => Map a [b] - m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] --} - --- | A primitive matcher that looks up a value in a finite 'Map'. It checks --- for an exact or inexact match. We get an inexact match if the match --- is not exact, but the canonical forms match. It takes a canonicalisation --- function for this purpose. --- --- So for example if we used string case fold as the canonicalisation --- function, then we would get case insensitive matching (but it will still --- report an exact match when the case matches too). --- -matchInexactly :: (Ord a, Ord a') => - (a -> a') -> - [(a, b)] -> (a -> Match b) -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 - where - m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] - - -- the map of canonicalised keys to groups of inexact matches - m' = Map.mapKeysWith (++) cannonicalise m - - - ------------------------------- --- Utils --- - -caseFold :: String -> String -caseFold = lowercase - - --- | Check that the given build targets are valid in the current context. --- --- Also swizzle into a more convenient form. --- -checkBuildTargets :: Verbosity -> PackageDescription -> LocalBuildInfo -> [BuildTarget] - -> IO [TargetInfo] -checkBuildTargets _ pkg_descr lbi [] = - return (allTargetsInBuildOrder' pkg_descr lbi) - -checkBuildTargets verbosity pkg_descr lbi targets = do - - let (enabled, disabled) = - partitionEithers - [ case componentDisabledReason (componentEnabledSpec lbi) comp of - Nothing -> Left target' - Just reason -> Right (cname, reason) - | target <- targets - , let target'@(cname,_) = swizzleTarget target - , let comp = getComponent pkg_descr cname ] - - case disabled of - [] -> return () - ((cname,reason):_) -> die' verbosity $ formatReason (showComponentName cname) reason - - for_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) -> - warn verbosity $ "Ignoring '" ++ either prettyShow id t ++ ". The whole " - ++ showComponentName c ++ " will be processed. (Support for " - ++ "module and file targets has not been implemented yet.)" - - -- Pick out the actual CLBIs for each of these cnames - enabled' <- for enabled $ \(cname, _) -> do - case componentNameTargets' pkg_descr lbi cname of - [] -> error "checkBuildTargets: nothing enabled" - [target] -> return target - _targets -> error "checkBuildTargets: multiple copies enabled" - - return enabled' - - where - swizzleTarget (BuildTargetComponent c) = (c, Nothing) - swizzleTarget (BuildTargetModule c m) = (c, Just (Left m)) - swizzleTarget (BuildTargetFile c f) = (c, Just (Right f)) - - formatReason cn DisabledComponent = - "Cannot process the " ++ cn ++ " because the component is marked " - ++ "as disabled in the .cabal file." - formatReason cn DisabledAllTests = - "Cannot process the " ++ cn ++ " because test suites are not " - ++ "enabled. Run configure with the flag --enable-tests" - formatReason cn DisabledAllBenchmarks = - "Cannot process the " ++ cn ++ " because benchmarks are not " - ++ "enabled. Re-run configure with the flag --enable-benchmarks" - formatReason cn (DisabledAllButOne cn') = - "Cannot process the " ++ cn ++ " because this package was " - ++ "configured only to build " ++ cn' ++ ". Re-run configure " - ++ "with the argument " ++ cn +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Client.BuildTargets +-- Copyright : (c) Duncan Coutts 2012 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Handling for user-specified build targets +module Distribution.Simple.BuildTarget + ( -- * Main interface + readTargetInfos + , readBuildTargets -- in case you don't have LocalBuildInfo + + -- * Build targets + , BuildTarget (..) + , showBuildTarget + , QualLevel (..) + , buildTargetComponentName + + -- * Parsing user build targets + , UserBuildTarget + , readUserBuildTargets + , showUserBuildTarget + , UserBuildTargetProblem (..) + , reportUserBuildTargetProblems + + -- * Resolving build targets + , resolveBuildTargets + , BuildTargetProblem (..) + , reportBuildTargetProblems + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.ForeignLib +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Types.UnqualComponentName + +import qualified Distribution.Compat.CharParsing as P +import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Simple.Errors +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Utils +import Distribution.Utils.Path +import Distribution.Verbosity + +import Control.Arrow ((&&&)) +import Control.Monad (msum) +import Data.List (groupBy, stripPrefix) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath as FilePath + ( dropExtension + , hasTrailingPathSeparator + , joinPath + , normalise + , splitDirectories + , splitPath + ) + +-- | Take a list of 'String' build targets, and parse and validate them +-- into actual 'TargetInfo's to be built/registered/whatever. +readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo] +readTargetInfos verbosity pkg_descr lbi args = do + build_targets <- readBuildTargets verbosity pkg_descr args + checkBuildTargets verbosity pkg_descr lbi build_targets + +-- ------------------------------------------------------------ + +-- * User build targets + +-- ------------------------------------------------------------ + +-- | Various ways that a user may specify a build target. +data UserBuildTarget + = -- | A target specified by a single name. This could be a component + -- module or file. + -- + -- > cabal build foo + -- > cabal build Data.Foo + -- > cabal build Data/Foo.hs Data/Foo.hsc + UserBuildTargetSingle String + | -- | A target specified by a qualifier and name. This could be a component + -- name qualified by the component namespace kind, or a module or file + -- qualified by the component name. + -- + -- > cabal build lib:foo exe:foo + -- > cabal build foo:Data.Foo + -- > cabal build foo:Data/Foo.hs + UserBuildTargetDouble String String + | -- | A fully qualified target, either a module or file qualified by a + -- component name with the component namespace kind. + -- + -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs + -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo + UserBuildTargetTriple String String String + deriving (Show, Eq, Ord) + +-- ------------------------------------------------------------ + +-- * Resolved build targets + +-- ------------------------------------------------------------ + +-- | A fully resolved build target. +data BuildTarget + = -- | A specific component + BuildTargetComponent ComponentName + | -- | A specific module within a specific component. + BuildTargetModule ComponentName ModuleName + | -- | A specific file within a specific component. + BuildTargetFile ComponentName FilePath + deriving (Eq, Show, Generic) + +instance Binary BuildTarget + +buildTargetComponentName :: BuildTarget -> ComponentName +buildTargetComponentName (BuildTargetComponent cn) = cn +buildTargetComponentName (BuildTargetModule cn _) = cn +buildTargetComponentName (BuildTargetFile cn _) = cn + +-- | Read a list of user-supplied build target strings and resolve them to +-- 'BuildTarget's according to a 'PackageDescription'. If there are problems +-- with any of the targets e.g. they don't exist or are misformatted, throw an +-- 'IOException'. +readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget] +readBuildTargets verbosity pkg targetStrs = do + let (uproblems, utargets) = readUserBuildTargets targetStrs + reportUserBuildTargetProblems verbosity uproblems + + utargets' <- traverse checkTargetExistsAsFile utargets + + let (bproblems, btargets) = resolveBuildTargets pkg utargets' + reportBuildTargetProblems verbosity bproblems + + return btargets + +checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool) +checkTargetExistsAsFile t = do + fexists <- existsAsFile (fileComponentOfTarget t) + return (t, fexists) + where + existsAsFile f = do + exists <- doesFileExist f + case splitPath f of + (d : _) | hasTrailingPathSeparator d -> doesDirectoryExist d + (d : _ : _) | not exists -> doesDirectoryExist d + _ -> return exists + + fileComponentOfTarget (UserBuildTargetSingle s1) = s1 + fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2 + fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3 + +-- ------------------------------------------------------------ + +-- * Parsing user targets + +-- ------------------------------------------------------------ + +readUserBuildTargets + :: [String] + -> ( [UserBuildTargetProblem] + , [UserBuildTarget] + ) +readUserBuildTargets = partitionEithers . map readUserBuildTarget + +-- | +-- +-- >>> readUserBuildTarget "comp" +-- Right (UserBuildTargetSingle "comp") +-- +-- >>> readUserBuildTarget "lib:comp" +-- Right (UserBuildTargetDouble "lib" "comp") +-- +-- >>> readUserBuildTarget "pkg:lib:comp" +-- Right (UserBuildTargetTriple "pkg" "lib" "comp") +-- +-- >>> readUserBuildTarget "\"comp\"" +-- Right (UserBuildTargetSingle "comp") +-- +-- >>> readUserBuildTarget "lib:\"comp\"" +-- Right (UserBuildTargetDouble "lib" "comp") +-- +-- >>> readUserBuildTarget "pkg:lib:\"comp\"" +-- Right (UserBuildTargetTriple "pkg" "lib" "comp") +-- +-- >>> readUserBuildTarget "pkg:lib:comp:more" +-- Left (UserBuildTargetUnrecognised "pkg:lib:comp:more") +-- +-- >>> readUserBuildTarget "pkg:\"lib\":comp" +-- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp") +readUserBuildTarget + :: String + -> Either + UserBuildTargetProblem + UserBuildTarget +readUserBuildTarget targetstr = + case explicitEitherParsec parseTargetApprox targetstr of + Left _ -> Left (UserBuildTargetUnrecognised targetstr) + Right tgt -> Right tgt + where + parseTargetApprox :: CabalParsing m => m UserBuildTarget + parseTargetApprox = do + -- read one, two, or three tokens, where last could be "hs-string" + ts <- tokens + return $ case ts of + (a, Nothing) -> UserBuildTargetSingle a + (a, Just (b, Nothing)) -> UserBuildTargetDouble a b + (a, Just (b, Just c)) -> UserBuildTargetTriple a b c + + tokens :: CabalParsing m => m (String, Maybe (String, Maybe String)) + tokens = + (\s -> (s, Nothing)) <$> parsecHaskellString + <|> (,) <$> token <*> P.optional (P.char ':' *> tokens2) + + tokens2 :: CabalParsing m => m (String, Maybe String) + tokens2 = + (\s -> (s, Nothing)) <$> parsecHaskellString + <|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token)) + + token :: CabalParsing m => m String + token = P.munch1 (\x -> not (isSpace x) && x /= ':') + +data UserBuildTargetProblem + = UserBuildTargetUnrecognised String + deriving (Show) + +reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO () +reportUserBuildTargetProblems verbosity problems = do + case [target | UserBuildTargetUnrecognised target <- problems] of + [] -> return () + target -> + dieWithException verbosity $ + UnrecognisedBuildTarget target + +showUserBuildTarget :: UserBuildTarget -> String +showUserBuildTarget = intercalate ":" . getComponents + where + getComponents (UserBuildTargetSingle s1) = [s1] + getComponents (UserBuildTargetDouble s1 s2) = [s1, s2] + getComponents (UserBuildTargetTriple s1 s2 s3) = [s1, s2, s3] + +-- | Unless you use 'QL1', this function is PARTIAL; +-- use 'showBuildTarget' instead. +showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String +showBuildTarget' ql pkgid bt = + showUserBuildTarget (renderBuildTarget ql bt pkgid) + +-- | Unambiguously render a 'BuildTarget', so that it can +-- be parsed in all situations. +showBuildTarget :: PackageId -> BuildTarget -> String +showBuildTarget pkgid t = + showBuildTarget' (qlBuildTarget t) pkgid t + where + qlBuildTarget BuildTargetComponent{} = QL2 + qlBuildTarget _ = QL3 + +-- ------------------------------------------------------------ + +-- * Resolving user targets to build targets + +-- ------------------------------------------------------------ + +{- +stargets = + [ BuildTargetComponent (CExeName "foo") + , BuildTargetModule (CExeName "foo") (mkMn "Foo") + , BuildTargetModule (CExeName "tst") (mkMn "Foo") + ] + where + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + +ex_pkgid :: PackageIdentifier +Just ex_pkgid = simpleParse "thelib" +-} + +-- | Given a bunch of user-specified targets, try to resolve what it is they +-- refer to. +resolveBuildTargets + :: PackageDescription + -> [(UserBuildTarget, Bool)] + -> ([BuildTargetProblem], [BuildTarget]) +resolveBuildTargets pkg = + partitionEithers + . map (uncurry (resolveBuildTarget pkg)) + +resolveBuildTarget + :: PackageDescription + -> UserBuildTarget + -> Bool + -> Either BuildTargetProblem BuildTarget +resolveBuildTarget pkg userTarget fexists = + case findMatch (matchBuildTarget pkg userTarget fexists) of + Unambiguous target -> Right target + Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets') + where + targets' = + disambiguateBuildTargets + (packageId pkg) + userTarget + targets + None errs -> Left (classifyMatchErrors errs) + where + classifyMatchErrors errs + | Just expected' <- NE.nonEmpty expected = + let unzip' = fmap fst &&& fmap snd + (things, got :| _) = unzip' expected' + in BuildTargetExpected userTarget (NE.toList things) got + | not (null nosuch) = BuildTargetNoSuch userTarget nosuch + | otherwise = error $ "resolveBuildTarget: internal error in matching" + where + expected = [(thing, got) | MatchErrorExpected thing got <- errs] + nosuch = [(thing, got) | MatchErrorNoSuch thing got <- errs] + +data BuildTargetProblem + = -- | [expected thing] (actually got) + BuildTargetExpected UserBuildTarget [String] String + | -- | [(no such thing, actually got)] + BuildTargetNoSuch UserBuildTarget [(String, String)] + | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)] + deriving (Show) + +disambiguateBuildTargets + :: PackageId + -> UserBuildTarget + -> [BuildTarget] + -> [(UserBuildTarget, BuildTarget)] +disambiguateBuildTargets pkgid original = + disambiguate (userTargetQualLevel original) + where + disambiguate ql ts + | null amb = unamb + | otherwise = unamb ++ disambiguate (succ ql) amb + where + (amb, unamb) = step ql ts + + userTargetQualLevel (UserBuildTargetSingle _) = QL1 + userTargetQualLevel (UserBuildTargetDouble _ _) = QL2 + userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3 + + step + :: QualLevel + -> [BuildTarget] + -> ([BuildTarget], [(UserBuildTarget, BuildTarget)]) + step ql = + (\(amb, unamb) -> (map snd $ concat amb, concat unamb)) + . partition (\g -> length g > 1) + . groupBy (equating fst) + . sortBy (comparing fst) + . map (\t -> (renderBuildTarget ql t pkgid, t)) + +data QualLevel = QL1 | QL2 | QL3 + deriving (Enum, Show) + +renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget +renderBuildTarget ql target pkgid = + case ql of + QL1 -> UserBuildTargetSingle s1 where s1 = single target + QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target + QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target + where + single (BuildTargetComponent cn) = dispCName cn + single (BuildTargetModule _ m) = prettyShow m + single (BuildTargetFile _ f) = f + + double (BuildTargetComponent cn) = (dispKind cn, dispCName cn) + double (BuildTargetModule cn m) = (dispCName cn, prettyShow m) + double (BuildTargetFile cn f) = (dispCName cn, f) + + triple (BuildTargetComponent _) = error "triple BuildTargetComponent" + triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow m) + triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f) + + dispCName = componentStringName pkgid + dispKind = showComponentKindShort . componentKind + +reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO () +reportBuildTargetProblems verbosity problems = do + case [(t, e, g) | BuildTargetExpected t e g <- problems] of + [] -> return () + targets -> + dieWithException verbosity $ + ReportBuildTargetProblems $ + map (\(target, expected, got) -> (showUserBuildTarget target, expected, got)) targets + + case [(t, e) | BuildTargetNoSuch t e <- problems] of + [] -> return () + targets -> + dieWithException verbosity $ + UnknownBuildTarget $ + map (\(target, nosuch) -> (showUserBuildTarget target, nosuch)) targets + + case [(t, ts) | BuildTargetAmbiguous t ts <- problems] of + [] -> return () + targets -> + dieWithException verbosity $ + AmbiguousBuildTarget $ + map + ( \(target, amb) -> + ( showUserBuildTarget target + , (map (\(ut, bt) -> (showUserBuildTarget ut, showBuildTargetKind bt)) amb) + ) + ) + targets + where + showBuildTargetKind (BuildTargetComponent _) = "component" + showBuildTargetKind (BuildTargetModule _ _) = "module" + showBuildTargetKind (BuildTargetFile _ _) = "file" + +---------------------------------- +-- Top level BuildTarget matcher +-- + +matchBuildTarget + :: PackageDescription + -> UserBuildTarget + -> Bool + -> Match BuildTarget +matchBuildTarget pkg = \utarget fexists -> + case utarget of + UserBuildTargetSingle str1 -> + matchBuildTarget1 cinfo str1 fexists + UserBuildTargetDouble str1 str2 -> + matchBuildTarget2 cinfo str1 str2 fexists + UserBuildTargetTriple str1 str2 str3 -> + matchBuildTarget3 cinfo str1 str2 str3 fexists + where + cinfo = pkgComponentInfo pkg + +matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget +matchBuildTarget1 cinfo str1 fexists = + matchComponent1 cinfo str1 + `matchPlusShadowing` matchModule1 cinfo str1 + `matchPlusShadowing` matchFile1 cinfo str1 fexists + +matchBuildTarget2 + :: [ComponentInfo] + -> String + -> String + -> Bool + -> Match BuildTarget +matchBuildTarget2 cinfo str1 str2 fexists = + matchComponent2 cinfo str1 str2 + `matchPlusShadowing` matchModule2 cinfo str1 str2 + `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists + +matchBuildTarget3 + :: [ComponentInfo] + -> String + -> String + -> String + -> Bool + -> Match BuildTarget +matchBuildTarget3 cinfo str1 str2 str3 fexists = + matchModule3 cinfo str1 str2 str3 + `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists + +data ComponentInfo = ComponentInfo + { cinfoName :: ComponentName + , cinfoStrName :: ComponentStringName + , cinfoSrcDirs :: [FilePath] + , cinfoModules :: [ModuleName] + , cinfoHsFiles :: [FilePath] -- other hs files (like main.hs) + , cinfoAsmFiles :: [FilePath] + , cinfoCmmFiles :: [FilePath] + , cinfoCFiles :: [FilePath] + , cinfoCxxFiles :: [FilePath] + , cinfoJsFiles :: [FilePath] + } + +type ComponentStringName = String + +pkgComponentInfo :: PackageDescription -> [ComponentInfo] +pkgComponentInfo pkg = + [ ComponentInfo + { cinfoName = componentName c + , cinfoStrName = componentStringName pkg (componentName c) + , cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi + , cinfoModules = componentModules c + , cinfoHsFiles = componentHsFiles c + , cinfoAsmFiles = asmSources bi + , cinfoCmmFiles = cmmSources bi + , cinfoCFiles = cSources bi + , cinfoCxxFiles = cxxSources bi + , cinfoJsFiles = jsSources bi + } + | c <- pkgComponents pkg + , let bi = componentBuildInfo c + ] + +componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName +componentStringName pkg (CLibName LMainLibName) = prettyShow (packageName pkg) +componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name +componentStringName _ (CFLibName name) = unUnqualComponentName name +componentStringName _ (CExeName name) = unUnqualComponentName name +componentStringName _ (CTestName name) = unUnqualComponentName name +componentStringName _ (CBenchName name) = unUnqualComponentName name + +componentModules :: Component -> [ModuleName] +-- TODO: Use of 'explicitLibModules' here is a bit wrong: +-- a user could very well ask to build a specific signature +-- that was inherited from other packages. To fix this +-- we have to plumb 'LocalBuildInfo' through this code. +-- Fortunately, this is only used by 'pkgComponentInfo' +-- Please don't export this function unless you plan on fixing +-- this. +componentModules (CLib lib) = explicitLibModules lib +componentModules (CFLib flib) = foreignLibModules flib +componentModules (CExe exe) = exeModules exe +componentModules (CTest test) = testModules test +componentModules (CBench bench) = benchmarkModules bench + +componentHsFiles :: Component -> [FilePath] +componentHsFiles (CExe exe) = [modulePath exe] +componentHsFiles + ( CTest + TestSuite + { testInterface = TestSuiteExeV10 _ mainfile + } + ) = [mainfile] +componentHsFiles + ( CBench + Benchmark + { benchmarkInterface = BenchmarkExeV10 _ mainfile + } + ) = [mainfile] +componentHsFiles _ = [] + +{- +ex_cs :: [ComponentInfo] +ex_cs = + [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) + , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) + ] + where + mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms) + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + pkgid :: PackageIdentifier + Just pkgid = simpleParse "thelib" +-} + +------------------------------ +-- Matching component kinds +-- + +data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind + deriving (Eq, Ord, Show, Enum, Bounded) + +componentKind :: ComponentName -> ComponentKind +componentKind (CLibName _) = LibKind +componentKind (CFLibName _) = FLibKind +componentKind (CExeName _) = ExeKind +componentKind (CTestName _) = TestKind +componentKind (CBenchName _) = BenchKind + +cinfoKind :: ComponentInfo -> ComponentKind +cinfoKind = componentKind . cinfoName + +matchComponentKind :: String -> Match ComponentKind +matchComponentKind s + | s `elem` ["lib", "library"] = return' LibKind + | s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind + | s `elem` ["exe", "executable"] = return' ExeKind + | s `elem` ["tst", "test", "test-suite"] = return' TestKind + | s `elem` ["bench", "benchmark"] = return' BenchKind + | otherwise = matchErrorExpected "component kind" s + where + return' ck = increaseConfidence >> return ck + +showComponentKind :: ComponentKind -> String +showComponentKind LibKind = "library" +showComponentKind FLibKind = "foreign-library" +showComponentKind ExeKind = "executable" +showComponentKind TestKind = "test-suite" +showComponentKind BenchKind = "benchmark" + +showComponentKindShort :: ComponentKind -> String +showComponentKindShort LibKind = "lib" +showComponentKindShort FLibKind = "flib" +showComponentKindShort ExeKind = "exe" +showComponentKindShort TestKind = "test" +showComponentKindShort BenchKind = "bench" + +------------------------------ +-- Matching component targets +-- + +matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget +matchComponent1 cs = \str1 -> do + guardComponentName str1 + c <- matchComponentName cs str1 + return (BuildTargetComponent (cinfoName c)) + +matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget +matchComponent2 cs = \str1 str2 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + return (BuildTargetComponent (cinfoName c)) + +-- utils: + +guardComponentName :: String -> Match () +guardComponentName s + | all validComponentChar s + && not (null s) = + increaseConfidence + | otherwise = matchErrorExpected "component name" s + where + validComponentChar c = + isAlphaNum c + || c == '.' + || c == '_' + || c == '-' + || c == '\'' + +matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo +matchComponentName cs str = + orNoSuchThing "component" str $ + increaseConfidenceFor $ + matchInexactly + caseFold + [(cinfoStrName c, c) | c <- cs] + str + +matchComponentKindAndName + :: [ComponentInfo] + -> ComponentKind + -> String + -> Match ComponentInfo +matchComponentKindAndName cs ckind str = + orNoSuchThing (showComponentKind ckind ++ " component") str $ + increaseConfidenceFor $ + matchInexactly + (\(ck, cn) -> (ck, caseFold cn)) + [((cinfoKind c, cinfoStrName c), c) | c <- cs] + (ckind, str) + +------------------------------ +-- Matching module targets +-- + +matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget +matchModule1 cs = \str1 -> do + guardModuleName str1 + nubMatchErrors $ do + c <- tryEach cs + let ms = cinfoModules c + m <- matchModuleName ms str1 + return (BuildTargetModule (cinfoName c) m) + +matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget +matchModule2 cs = \str1 str2 -> do + guardComponentName str1 + guardModuleName str2 + c <- matchComponentName cs str1 + let ms = cinfoModules c + m <- matchModuleName ms str2 + return (BuildTargetModule (cinfoName c) m) + +matchModule3 + :: [ComponentInfo] + -> String + -> String + -> String + -> Match BuildTarget +matchModule3 cs str1 str2 str3 = do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + guardModuleName str3 + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (BuildTargetModule (cinfoName c) m) + +-- utils: + +guardModuleName :: String -> Match () +guardModuleName s + | all validModuleChar s + && not (null s) = + increaseConfidence + | otherwise = matchErrorExpected "module name" s + where + validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' + +matchModuleName :: [ModuleName] -> String -> Match ModuleName +matchModuleName ms str = + orNoSuchThing "module" str $ + increaseConfidenceFor $ + matchInexactly + caseFold + [ (prettyShow m, m) + | m <- ms + ] + str + +------------------------------ +-- Matching file targets +-- + +matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget +matchFile1 cs str1 exists = + nubMatchErrors $ do + c <- tryEach cs + filepath <- matchComponentFile c str1 exists + return (BuildTargetFile (cinfoName c) filepath) + +matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget +matchFile2 cs str1 str2 exists = do + guardComponentName str1 + c <- matchComponentName cs str1 + filepath <- matchComponentFile c str2 exists + return (BuildTargetFile (cinfoName c) filepath) + +matchFile3 + :: [ComponentInfo] + -> String + -> String + -> String + -> Bool + -> Match BuildTarget +matchFile3 cs str1 str2 str3 exists = do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + filepath <- matchComponentFile c str3 exists + return (BuildTargetFile (cinfoName c) filepath) + +matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath +matchComponentFile c str fexists = + expecting "file" str $ + matchPlus + (matchFileExists str fexists) + ( matchPlusShadowing + ( msum + [ matchModuleFileRooted dirs ms str + , matchOtherFileRooted dirs hsFiles str + ] + ) + ( msum + [ matchModuleFileUnrooted ms str + , matchOtherFileUnrooted hsFiles str + , matchOtherFileUnrooted cFiles str + , matchOtherFileUnrooted jsFiles str + ] + ) + ) + where + dirs = cinfoSrcDirs c + ms = cinfoModules c + hsFiles = cinfoHsFiles c + cFiles = cinfoCFiles c + jsFiles = cinfoJsFiles c + +-- utils + +matchFileExists :: FilePath -> Bool -> Match a +matchFileExists _ False = mzero +matchFileExists fname True = do + increaseConfidence + matchErrorNoSuch "file" fname + +matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath +matchModuleFileUnrooted ms str = do + let filepath = normalise str + _ <- matchModuleFileStem ms filepath + return filepath + +matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath +matchModuleFileRooted dirs ms str = nubMatches $ do + let filepath = normalise str + filepath' <- matchDirectoryPrefix dirs filepath + _ <- matchModuleFileStem ms filepath' + return filepath + +matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName +matchModuleFileStem ms = + increaseConfidenceFor + . matchInexactly + caseFold + [(toFilePath m, m) | m <- ms] + . dropExtension + +matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath +matchOtherFileRooted dirs fs str = do + let filepath = normalise str + filepath' <- matchDirectoryPrefix dirs filepath + _ <- matchFile fs filepath' + return filepath + +matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath +matchOtherFileUnrooted fs str = do + let filepath = normalise str + _ <- matchFile fs filepath + return filepath + +matchFile :: [FilePath] -> FilePath -> Match FilePath +matchFile fs = + increaseConfidenceFor + . matchInexactly caseFold [(f, f) | f <- fs] + +matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath +matchDirectoryPrefix dirs filepath = + exactMatches $ + catMaybes + [stripDirectory (normalise dir) filepath | dir <- dirs] + where + stripDirectory :: FilePath -> FilePath -> Maybe FilePath + stripDirectory dir fp = + joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp) + +------------------------------ +-- Matching monad +-- + +-- | A matcher embodies a way to match some input as being some recognised +-- value. In particular it deals with multiple and ambiguous matches. +-- +-- There are various matcher primitives ('matchExactly', 'matchInexactly'), +-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can +-- run a matcher against an input using 'findMatch'. +data Match a + = NoMatch Confidence [MatchError] + | ExactMatch Confidence [a] + | InexactMatch Confidence [a] + deriving (Show) + +type Confidence = Int + +data MatchError + = MatchErrorExpected String String + | MatchErrorNoSuch String String + deriving (Show, Eq) + +instance Alternative Match where + empty = mzero + (<|>) = mplus + +instance MonadPlus Match where + mzero = matchZero + mplus = matchPlus + +matchZero :: Match a +matchZero = NoMatch 0 [] + +-- | Combine two matchers. Exact matches are used over inexact matches +-- but if we have multiple exact, or inexact then the we collect all the +-- ambiguous matches. +matchPlus :: Match a -> Match a -> Match a +matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = + ExactMatch (max d1 d2) (xs ++ xs') +matchPlus a@(ExactMatch _ _) (InexactMatch _ _) = a +matchPlus a@(ExactMatch _ _) (NoMatch _ _) = a +matchPlus (InexactMatch _ _) b@(ExactMatch _ _) = b +matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = + InexactMatch (max d1 d2) (xs ++ xs') +matchPlus a@(InexactMatch _ _) (NoMatch _ _) = a +matchPlus (NoMatch _ _) b@(ExactMatch _ _) = b +matchPlus (NoMatch _ _) b@(InexactMatch _ _) = b +matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') + | d1 > d2 = a + | d1 < d2 = b + | otherwise = NoMatch d1 (ms ++ ms') + +-- | Combine two matchers. This is similar to 'ambiguousWith' with the +-- difference that an exact match from the left matcher shadows any exact +-- match on the right. Inexact matches are still collected however. +matchPlusShadowing :: Match a -> Match a -> Match a +matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a +matchPlusShadowing a b = matchPlus a b + +instance Functor Match where + fmap _ (NoMatch d ms) = NoMatch d ms + fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) + fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) + +instance Applicative Match where + pure a = ExactMatch 0 [a] + (<*>) = ap + +instance Monad Match where + return = pure + + NoMatch d ms >>= _ = NoMatch d ms + ExactMatch d xs >>= f = + addDepth d $ + foldr matchPlus matchZero (map f xs) + InexactMatch d xs >>= f = + addDepth d . forceInexact $ + foldr matchPlus matchZero (map f xs) + +addDepth :: Confidence -> Match a -> Match a +addDepth d' (NoMatch d msgs) = NoMatch (d' + d) msgs +addDepth d' (ExactMatch d xs) = ExactMatch (d' + d) xs +addDepth d' (InexactMatch d xs) = InexactMatch (d' + d) xs + +forceInexact :: Match a -> Match a +forceInexact (ExactMatch d ys) = InexactMatch d ys +forceInexact m = m + +------------------------------ +-- Various match primitives +-- + +matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a +matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] +matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got] + +expecting :: String -> String -> Match a -> Match a +expecting thing got (NoMatch 0 _) = matchErrorExpected thing got +expecting _ _ m = m + +orNoSuchThing :: String -> String -> Match a -> Match a +orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got +orNoSuchThing _ _ m = m + +increaseConfidence :: Match () +increaseConfidence = ExactMatch 1 [()] + +increaseConfidenceFor :: Match a -> Match a +increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r + +nubMatches :: Eq 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) + +nubMatchErrors :: Match a -> Match a +nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs) +nubMatchErrors (ExactMatch d xs) = ExactMatch d xs +nubMatchErrors (InexactMatch d xs) = InexactMatch d xs + +-- | Lift a list of matches to an exact match. +exactMatches, inexactMatches :: [a] -> Match a +exactMatches [] = matchZero +exactMatches xs = ExactMatch 0 xs +inexactMatches [] = matchZero +inexactMatches xs = InexactMatch 0 xs + +tryEach :: [a] -> Match a +tryEach = exactMatches + +------------------------------ +-- Top level match runner +-- + +-- | Given a matcher and a key to look up, use the matcher to find all the +-- possible matches. There may be 'None', a single 'Unambiguous' match or +-- you may have an 'Ambiguous' match with several possibilities. +findMatch :: Eq b => Match b -> MaybeAmbiguous b +findMatch match = + case match of + NoMatch _ msgs -> None (nub msgs) + ExactMatch _ xs -> checkAmbiguous xs + InexactMatch _ xs -> checkAmbiguous xs + where + checkAmbiguous xs = case nub xs of + [x] -> Unambiguous x + xs' -> Ambiguous xs' + +data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a] + deriving (Show) + +------------------------------ +-- Basic matchers +-- + +{- +-- | A primitive matcher that looks up a value in a finite 'Map'. The +-- value must match exactly. +-- +matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b) +matchExactly xs = + \x -> case Map.lookup x m of + Nothing -> matchZero + Just ys -> ExactMatch 0 ys + where + m :: Ord a => Map a [b] + m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] +-} + +-- | A primitive matcher that looks up a value in a finite 'Map'. It checks +-- for an exact or inexact match. We get an inexact match if the match +-- is not exact, but the canonical forms match. It takes a canonicalisation +-- function for this purpose. +-- +-- So for example if we used string case fold as the canonicalisation +-- function, then we would get case insensitive matching (but it will still +-- report an exact match when the case matches too). +matchInexactly + :: (Ord a, Ord a') + => (a -> a') + -> [(a, b)] + -> (a -> Match b) +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 + where + m = Map.fromListWith (++) [(k, [x]) | (k, x) <- xs] + + -- the map of canonicalised keys to groups of inexact matches + m' = Map.mapKeysWith (++) cannonicalise m + +------------------------------ +-- Utils +-- + +caseFold :: String -> String +caseFold = lowercase + +-- | Check that the given build targets are valid in the current context. +-- +-- Also swizzle into a more convenient form. +checkBuildTargets + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> [BuildTarget] + -> IO [TargetInfo] +checkBuildTargets _ pkg_descr lbi [] = + return (allTargetsInBuildOrder' pkg_descr lbi) +checkBuildTargets + verbosity + pkg_descr + lbi@(LocalBuildInfo{componentEnabledSpec = enabledComps}) + targets = do + let (enabled, disabled) = + partitionEithers + [ case componentDisabledReason enabledComps comp of + Nothing -> Left target' + Just reason -> Right (cname, reason) + | target <- targets + , let target'@(cname, _) = swizzleTarget target + , let comp = getComponent pkg_descr cname + ] + + case disabled of + [] -> return () + ((cname, reason) : _) -> dieWithException verbosity $ CheckBuildTargets $ formatReason (showComponentName cname) reason + + for_ [(c, t) | (c, Just t) <- enabled] $ \(c, t) -> + warn verbosity $ + "Ignoring '" + ++ either prettyShow id t + ++ ". The whole " + ++ showComponentName c + ++ " will be processed. (Support for " + ++ "module and file targets has not been implemented yet.)" + + -- Pick out the actual CLBIs for each of these cnames + enabled' <- for enabled $ \(cname, _) -> do + case componentNameTargets' pkg_descr lbi cname of + [] -> error "checkBuildTargets: nothing enabled" + [target] -> return target + _targets -> error "checkBuildTargets: multiple copies enabled" + + return enabled' + where + swizzleTarget (BuildTargetComponent c) = (c, Nothing) + swizzleTarget (BuildTargetModule c m) = (c, Just (Left m)) + swizzleTarget (BuildTargetFile c f) = (c, Just (Right f)) + + formatReason cn DisabledComponent = + "Cannot process the " + ++ cn + ++ " because the component is marked " + ++ "as disabled in the .cabal file." + formatReason cn DisabledAllTests = + "Cannot process the " + ++ cn + ++ " because test suites are not " + ++ "enabled. Run configure with the flag --enable-tests" + formatReason cn DisabledAllBenchmarks = + "Cannot process the " + ++ cn + ++ " because benchmarks are not " + ++ "enabled. Re-run configure with the flag --enable-benchmarks" + formatReason cn (DisabledAllButOne cn') = + "Cannot process the " + ++ cn + ++ " because this package was " + ++ "configured only to build " + ++ cn' + ++ ". Re-run configure " + ++ "with the argument " + ++ cn 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 @@ -5,15 +5,42 @@ -- the functions contained to access those fields directly. module Distribution.Simple.BuildToolDepends where -import Prelude () -import Distribution.Compat.Prelude +import Distribution.Compat.Prelude +import Prelude () import qualified Data.Map as Map -import Distribution.Package -import Distribution.PackageDescription +import Distribution.Package +import Distribution.PackageDescription --- | Desugar a "build-tools" entry into proper a executable dependency if +-- | Same as 'desugarBuildTool', but requires atomic informations (package +-- name, executable names) instead of a whole 'PackageDescription'. +desugarBuildToolSimple + :: PackageName + -> [UnqualComponentName] + -> LegacyExeDependency + -> Maybe ExeDependency +desugarBuildToolSimple pname exeNames (LegacyExeDependency name reqVer) + | foundLocal = Just $ ExeDependency pname toolName reqVer + | otherwise = Map.lookup name allowMap + where + toolName = mkUnqualComponentName name + foundLocal = toolName `elem` exeNames + allowlist = + [ "hscolour" + , "haddock" + , "happy" + , "alex" + , "hsc2hs" + , "c2hs" + , "cpphs" + , "greencard" + , "hspec-discover" + ] + allowMap = Map.fromList $ flip map allowlist $ \n -> + (n, ExeDependency (mkPackageName n) (mkUnqualComponentName n) reqVer) + +-- | Desugar a "build-tools" entry into a proper executable dependency if -- possible. -- -- An entry can be so desugared in two cases: @@ -26,31 +53,25 @@ -- the same, but the hard-coding could just as well be per-key. -- -- The first cases matches first. -desugarBuildTool :: PackageDescription - -> LegacyExeDependency - -> Maybe ExeDependency +desugarBuildTool + :: PackageDescription + -> LegacyExeDependency + -> Maybe ExeDependency desugarBuildTool pkg led = - if foundLocal - then Just $ ExeDependency (packageName pkg) toolName reqVer - else Map.lookup name whiteMap - where - LegacyExeDependency name reqVer = led - toolName = mkUnqualComponentName name - foundLocal = toolName `elem` map exeName (executables pkg) - whitelist = [ "hscolour", "haddock", "happy", "alex", "hsc2hs", "c2hs" - , "cpphs", "greencard", "hspec-discover" - ] - whiteMap = Map.fromList $ flip map whitelist $ \n -> - (n, ExeDependency (mkPackageName n) (mkUnqualComponentName n) reqVer) + desugarBuildToolSimple + (packageName pkg) + (map exeName $ executables pkg) + led -- | Get everything from "build-tool-depends", along with entries from -- "build-tools" that we know how to desugar. -- -- This should almost always be used instead of just accessing the -- `buildToolDepends` field directly. -getAllToolDependencies :: PackageDescription - -> BuildInfo - -> [ExeDependency] +getAllToolDependencies + :: PackageDescription + -> BuildInfo + -> [ExeDependency] getAllToolDependencies pkg bi = buildToolDepends bi ++ mapMaybe (desugarBuildTool pkg) (buildTools bi) @@ -78,14 +99,14 @@ isInternal :: PackageDescription -> ExeDependency -> Bool isInternal pkg (ExeDependency n _ _) = n == packageName pkg - -- | Get internal "build-tool-depends", along with internal "build-tools" -- -- This is a tiny function, but used in a number of places. The same -- restrictions that apply to `isInternal` also apply to this function. -getAllInternalToolDependencies :: PackageDescription - -> BuildInfo - -> [UnqualComponentName] +getAllInternalToolDependencies + :: PackageDescription + -> BuildInfo + -> [UnqualComponentName] getAllInternalToolDependencies pkg bi = [ toolname | dep@(ExeDependency _ toolname _) <- getAllToolDependencies pkg bi diff --git a/src/Distribution/Simple/CCompiler.hs b/src/Distribution/Simple/CCompiler.hs --- a/src/Distribution/Simple/CCompiler.hs +++ b/src/Distribution/Simple/CCompiler.hs @@ -1,14 +1,4 @@ ----------------------------------------------------------------------------- --- | --- Module : Distribution.Simple.CCompiler --- Copyright : 2011, Dan Knapp --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This simple package provides types and functions for interacting with --- C compilers. Currently it's just a type enumerating extant C-like --- languages, which we call dialects. {- Redistribution and use in source and binary forms, with or without @@ -39,85 +29,109 @@ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -module Distribution.Simple.CCompiler ( - CDialect(..), - cSourceExtensions, - cDialectFilenameExtension, - filenameCDialect +-- | +-- Module : Distribution.Simple.CCompiler +-- Copyright : 2011, Dan Knapp +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This simple package provides types and functions for interacting with +-- C compilers. Currently it's just a type enumerating extant C-like +-- languages, which we call dialects. +module Distribution.Simple.CCompiler + ( CDialect (..) + , cSourceExtensions + , cDialectFilenameExtension + , filenameCDialect ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import System.FilePath - ( takeExtension ) - + ( takeExtension + ) -- | Represents a dialect of C. The Monoid instance expresses backward -- compatibility, in the sense that 'mappend a b' is the least inclusive -- dialect which both 'a' and 'b' can be correctly interpreted as. -data CDialect = C - | ObjectiveC - | CPlusPlus - | ObjectiveCPlusPlus - deriving (Eq, Show) +data CDialect + = C + | ObjectiveC + | CPlusPlus + | ObjectiveCPlusPlus + deriving (Eq, Show) instance Monoid CDialect where mempty = C mappend = (<>) instance Semigroup CDialect where - C <> anything = anything - ObjectiveC <> CPlusPlus = ObjectiveCPlusPlus - CPlusPlus <> ObjectiveC = ObjectiveCPlusPlus - _ <> ObjectiveCPlusPlus = ObjectiveCPlusPlus - ObjectiveC <> _ = ObjectiveC - CPlusPlus <> _ = CPlusPlus - ObjectiveCPlusPlus <> _ = ObjectiveCPlusPlus + C <> anything = anything + ObjectiveC <> CPlusPlus = ObjectiveCPlusPlus + CPlusPlus <> ObjectiveC = ObjectiveCPlusPlus + _ <> ObjectiveCPlusPlus = ObjectiveCPlusPlus + ObjectiveC <> _ = ObjectiveC + CPlusPlus <> _ = CPlusPlus + ObjectiveCPlusPlus <> _ = ObjectiveCPlusPlus -- | A list of all file extensions which are recognized as possibly containing -- some dialect of C code. Note that this list is only for source files, -- not for header files. cSourceExtensions :: [String] -cSourceExtensions = ["c", "i", "ii", "m", "mi", "mm", "M", "mii", "cc", "cp", - "cxx", "cpp", "CPP", "c++", "C"] - +cSourceExtensions = + [ "c" + , "i" + , "ii" + , "m" + , "mi" + , "mm" + , "M" + , "mii" + , "cc" + , "cp" + , "cxx" + , "cpp" + , "CPP" + , "c++" + , "C" + ] -- | Takes a dialect of C and whether code is intended to be passed through -- the preprocessor, and returns a filename extension for containing that -- code. cDialectFilenameExtension :: CDialect -> Bool -> String -cDialectFilenameExtension C True = "c" +cDialectFilenameExtension C True = "c" cDialectFilenameExtension C False = "i" -cDialectFilenameExtension ObjectiveC True = "m" +cDialectFilenameExtension ObjectiveC True = "m" cDialectFilenameExtension ObjectiveC False = "mi" -cDialectFilenameExtension CPlusPlus True = "cpp" -cDialectFilenameExtension CPlusPlus False = "ii" -cDialectFilenameExtension ObjectiveCPlusPlus True = "mm" +cDialectFilenameExtension CPlusPlus True = "cpp" +cDialectFilenameExtension CPlusPlus False = "ii" +cDialectFilenameExtension ObjectiveCPlusPlus True = "mm" cDialectFilenameExtension ObjectiveCPlusPlus False = "mii" - -- | Infers from a filename's extension the dialect of C which it contains, -- and whether it is intended to be passed through the preprocessor. filenameCDialect :: String -> Maybe (CDialect, Bool) filenameCDialect filename = do extension <- case takeExtension filename of - '.':ext -> Just ext - _ -> Nothing + '.' : ext -> Just ext + _ -> Nothing case extension of - "c" -> return (C, True) - "i" -> return (C, False) - "ii" -> return (CPlusPlus, False) - "m" -> return (ObjectiveC, True) - "mi" -> return (ObjectiveC, False) - "mm" -> return (ObjectiveCPlusPlus, True) - "M" -> return (ObjectiveCPlusPlus, True) + "c" -> return (C, True) + "i" -> return (C, False) + "ii" -> return (CPlusPlus, False) + "m" -> return (ObjectiveC, True) + "mi" -> return (ObjectiveC, False) + "mm" -> return (ObjectiveCPlusPlus, True) + "M" -> return (ObjectiveCPlusPlus, True) "mii" -> return (ObjectiveCPlusPlus, False) - "cc" -> return (CPlusPlus, True) - "cp" -> return (CPlusPlus, True) + "cc" -> return (CPlusPlus, True) + "cp" -> return (CPlusPlus, True) "cxx" -> return (CPlusPlus, True) "cpp" -> return (CPlusPlus, True) "CPP" -> return (CPlusPlus, True) "c++" -> return (CPlusPlus, True) - "C" -> return (CPlusPlus, True) - _ -> Nothing + "C" -> return (CPlusPlus, True) + _ -> Nothing 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 @@ -3,6 +3,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Command -- Copyright : Duncan Coutts 2007 @@ -18,88 +19,102 @@ -- run. It handles some common stuff automatically, like the @--help@ and -- command line completion flags. It is designed to allow other tools make -- derived commands. This feature is used heavily in @cabal-install@. - -module Distribution.Simple.Command ( - - -- * Command interface - CommandUI(..), - commandShowOptions, - CommandParse(..), - commandParseArgs, - getNormalCommandDescriptions, - helpCommandUI, - - -- ** Constructing commands - ShowOrParseArgs(..), - usageDefault, - usageAlternatives, - mkCommandUI, - hiddenCommand, +module Distribution.Simple.Command + ( -- * Command interface + CommandUI (..) + , commandShowOptions + , CommandParse (..) + , commandParseArgs + , getNormalCommandDescriptions + , helpCommandUI - -- ** Associating actions with commands - Command, - commandAddAction, - noExtraFlags, + -- ** Constructing commands + , ShowOrParseArgs (..) + , usageDefault + , usageAlternatives + , mkCommandUI + , hiddenCommand - -- ** Building lists of commands - CommandType(..), - CommandSpec(..), - commandFromSpec, + -- ** Associating actions with commands + , Command + , commandAddAction + , noExtraFlags - -- ** Running commands - commandsRun, + -- ** Building lists of commands + , CommandType (..) + , CommandSpec (..) + , commandFromSpec --- * Option Fields - OptionField(..), Name, + -- ** Running commands + , commandsRun + , commandsRunWithFallback + , defaultCommandFallback --- ** Constructing Option Fields - option, multiOption, + -- * Option Fields + , OptionField (..) + , Name --- ** Liftings & Projections - liftOption, liftOptionL, + -- ** Constructing Option Fields + , option + , multiOption --- * Option Descriptions - OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder, + -- ** Liftings & Projections + , liftOption + , liftOptionL --- ** OptDescr 'smart' constructors - MkOptDescr, - reqArg, reqArg', optArg, optArg', noArg, - boolOpt, boolOpt', choiceOpt, choiceOptFromEnum + -- * Option Descriptions + , OptDescr (..) + , Description + , SFlags + , LFlags + , OptFlags + , ArgPlaceHolder + -- ** OptDescr 'smart' constructors + , MkOptDescr + , reqArg + , reqArg' + , optArg + , optArg' + , optArgDef' + , noArg + , boolOpt + , boolOpt' + , choiceOpt + , choiceOptFromEnum ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () import qualified Data.Array as Array import qualified Data.List as List +import Distribution.Compat.Lens (ALens', (#~), (^#)) import qualified Distribution.GetOpt as GetOpt import Distribution.ReadE import Distribution.Simple.Utils -import Distribution.Compat.Lens (ALens', (^#), (#~)) - -data CommandUI flags = CommandUI { - -- | The name of the command as it would be entered on the command line. - -- For example @\"build\"@. - commandName :: String, - -- | A short, one line description of the command to use in help texts. - commandSynopsis :: String, - -- | A function that maps a program name to a usage summary for this - -- command. - commandUsage :: String -> String, - -- | Additional explanation of the command to use in help texts. - commandDescription :: Maybe (String -> String), - -- | Post-Usage notes and examples in help texts - commandNotes :: Maybe (String -> String), - -- | Initial \/ empty flags - commandDefaultFlags :: flags, - -- | All the Option fields for this command - commandOptions :: ShowOrParseArgs -> [OptionField flags] +data CommandUI flags = CommandUI + { commandName :: String + -- ^ The name of the command as it would be entered on the command line. + -- For example @\"build\"@. + , commandSynopsis :: String + -- ^ A short, one line description of the command to use in help texts. + , commandUsage :: String -> String + -- ^ A function that maps a program name to a usage summary for this + -- command. + , commandDescription :: Maybe (String -> String) + -- ^ Additional explanation of the command to use in help texts. + , commandNotes :: Maybe (String -> String) + -- ^ Post-Usage notes and examples in help texts + , commandDefaultFlags :: flags + -- ^ Initial \/ empty flags + , commandOptions :: ShowOrParseArgs -> [OptionField flags] + -- ^ All the Option fields for this command } data ShowOrParseArgs = ShowArgs | ParseArgs -type Name = String +type Name = String type Description = String -- | We usually have a data type for storing configuration values, where @@ -107,30 +122,43 @@ -- the value either via command line flags or a configuration file. -- An individual OptionField models such a field, and we usually -- build a list of options associated to a configuration data type. -data OptionField a = OptionField { - optionName :: Name, - optionDescr :: [OptDescr a] } +data OptionField a = OptionField + { optionName :: Name + , optionDescr :: [OptDescr a] + } -- | An OptionField takes one or more OptDescrs, describing the command line -- interface for the field. -data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder - (ReadE (a->a)) (a -> [String]) - - | OptArg Description OptFlags ArgPlaceHolder - (ReadE (a->a)) (a->a) (a -> [Maybe String]) - - | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)] - - | BoolOpt Description OptFlags{-True-} OptFlags{-False-} - (Bool -> a -> a) (a-> Maybe Bool) +data OptDescr a + = ReqArg + Description + OptFlags + ArgPlaceHolder + (ReadE (a -> a)) + (a -> [String]) + | OptArg + Description + OptFlags + ArgPlaceHolder + (ReadE (a -> a)) + (String, a -> a) + (a -> [Maybe String]) + | ChoiceOpt [(Description, OptFlags, a -> a, a -> Bool)] + | BoolOpt + Description + OptFlags {-True-} + OptFlags {-False-} + (Bool -> a -> a) + (a -> Maybe Bool) -- | Short command line option strings -type SFlags = [Char] +type SFlags = [Char] + -- | Long command line option strings -type LFlags = [String] -type OptFlags = (SFlags,LFlags) -type ArgPlaceHolder = String +type LFlags = [String] +type OptFlags = (SFlags, LFlags) +type ArgPlaceHolder = String -- | Create an option taking a single OptDescr. -- No explicit Name is given for the Option, the name is the first LFlag given. @@ -142,23 +170,40 @@ -- * @get@: Get the current value of the flag. -- * @set@: Set the value of the flag. Gets the current value of the flag as a -- parameter. -option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a - -> OptionField a -option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set] -option _ _ _ _ _ _ = error $ "Distribution.command.option: " - ++ "An OptionField must have at least one LFlag" +option + :: SFlags + -> LFlags + -> Description + -> get + -> set + -> MkOptDescr get set a + -> OptionField a +option sf lf@(n : _) d get set arg = OptionField n [arg sf lf d get set] +option _ _ _ _ _ _ = + error $ + "Distribution.command.option: " + ++ "An OptionField must have at least one LFlag" -- | Create an option taking several OptDescrs. -- You will have to give the flags and description individually to the -- OptDescr constructor. -multiOption :: Name -> get -> set - -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially - -- applied to flags and description. - -> OptionField a +multiOption + :: Name + -> get + -> set + -> [get -> set -> OptDescr a] + -- ^ MkOptDescr constructors partially + -- applied to flags and description. + -> OptionField a multiOption n get set args = OptionField n [arg get set | arg <- args] -type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set - -> OptDescr a +type MkOptDescr get set a = + SFlags + -> LFlags + -> Description + -> get + -> set + -> OptDescr a -- | Create a string-valued command line interface. -- Usually called in the context of 'option' or 'multiOption'. @@ -170,296 +215,398 @@ -- * @mkflag@: How to parse the argument into the option. -- * @showflag@: If parsing goes wrong, display a useful error message to -- the user. -reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String]) - -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg + :: Monoid b + => ArgPlaceHolder + -> ReadE b + -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a reqArg ad mkflag showflag sf lf d get set = - ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) - (showflag . get) + ReqArg + d + (sf, lf) + ad + (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (showflag . get) -- | Create a string-valued command line interface with a default value. -optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -optArg ad mkflag def showflag sf lf d get set = - OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) - (\b -> set (get b `mappend` def) b) - (showflag . get) +optArg + :: Monoid b + => ArgPlaceHolder + -> ReadE b + -> (String, b) + -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg ad mkflag (dv, mkDef) showflag sf lf d get set = + OptArg + d + (sf, lf) + ad + (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (dv, \b -> set (get b `mappend` mkDef) b) + (showflag . get) -- | (String -> a) variant of "reqArg" -reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String]) - -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg' + :: Monoid b + => ArgPlaceHolder + -> (String -> b) + -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a reqArg' ad mkflag showflag = - reqArg ad (succeedReadE mkflag) showflag + reqArg ad (succeedReadE mkflag) showflag -- | (String -> a) variant of "optArg" -optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) - -> (b -> [Maybe String]) - -> MkOptDescr (a -> b) (b -> a -> a) a +optArg' + :: Monoid b + => ArgPlaceHolder + -> (Maybe String -> b) + -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a optArg' ad mkflag showflag = - optArg ad (succeedReadE (mkflag . Just)) def showflag - where def = mkflag Nothing + optArg ad (succeedReadE (mkflag . Just)) ("", mkflag Nothing) showflag -noArg :: (Eq b) => b -> MkOptDescr (a -> b) (b -> a -> a) a -noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d +optArgDef' + :: Monoid b + => ArgPlaceHolder + -> (String, Maybe String -> b) + -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArgDef' ad (dv, mkflag) showflag = + optArg ad (succeedReadE (mkflag . Just)) (dv, mkflag Nothing) showflag -boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags - -> MkOptDescr (a -> b) (b -> a -> a) a -boolOpt g s sfT sfF _sf _lf@(n:_) d get set = - BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get) -boolOpt _ _ _ _ _ _ _ _ _ = error - "Distribution.Simple.Setup.boolOpt: unreachable" +noArg :: Eq b => b -> MkOptDescr (a -> b) (b -> a -> a) a +noArg flag sf lf d = choiceOpt [(flag, (sf, lf), d)] sf lf d -boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags - -> MkOptDescr (a -> b) (b -> a -> a) a -boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get) +boolOpt + :: (b -> Maybe Bool) + -> (Bool -> b) + -> SFlags + -> SFlags + -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt g s sfT sfF _sf _lf@(n : _) d get set = + BoolOpt d (sfT, ["enable-" ++ n]) (sfF, ["disable-" ++ n]) (set . s) (g . get) +boolOpt _ _ _ _ _ _ _ _ _ = + error + "Distribution.Simple.Setup.boolOpt: unreachable" +boolOpt' + :: (b -> Maybe Bool) + -> (Bool -> b) + -> OptFlags + -> OptFlags + -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set . s) (g . get) + -- | create a Choice option -choiceOpt :: Eq b => [(b,OptFlags,Description)] - -> MkOptDescr (a -> b) (b -> a -> a) a -choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts - where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff] +choiceOpt + :: Eq b + => [(b, OptFlags, Description)] + -> MkOptDescr (a -> b) (b -> a -> a) a +choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts + where + alts = [(d, flags, set alt, (== alt) . get) | (alt, flags, d) <- aa_ff] -- | create a Choice option out of an enumeration type. -- As long flags, the Show output is used. As short flags, the first character -- which does not conflict with a previous one is used. -choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => - MkOptDescr (a -> b) (b -> a -> a) a +choiceOptFromEnum + :: (Bounded b, Enum b, Show b, Eq b) + => MkOptDescr (a -> b) (b -> a -> a) a choiceOptFromEnum _sf _lf d get = - choiceOpt [ (x, (sf, [map toLower $ show x]), d') - | (x, sf) <- sflags' - , let d' = d ++ show x] - _sf _lf d get - where sflags' = foldl f [] [firstOne..] - f prev x = let prevflags = concatMap snd prev in - prev ++ take 1 [(x, [toLower sf]) - | sf <- show x, isAlpha sf - , toLower sf `notElem` prevflags] - firstOne = minBound `asTypeOf` get undefined + choiceOpt + [ (x, (sf, [map toLower $ show x]), d') + | (x, sf) <- sflags' + , let d' = d ++ show x + ] + _sf + _lf + d + get + where + sflags' = foldl f [] [firstOne ..] + f prev x = + let prevflags = concatMap snd prev + in prev + ++ take + 1 + [ (x, [toLower sf]) + | sf <- show x + , isAlpha sf + , toLower sf `notElem` prevflags + ] + firstOne = minBound `asTypeOf` get undefined -commandGetOpts :: ShowOrParseArgs -> CommandUI flags - -> [GetOpt.OptDescr (flags -> flags)] +commandGetOpts + :: ShowOrParseArgs + -> CommandUI flags + -> [GetOpt.OptDescr (flags -> flags)] commandGetOpts showOrParse command = - concatMap viewAsGetOpt (commandOptions command showOrParse) + concatMap viewAsGetOpt (commandOptions command showOrParse) viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a -> a)] viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa where - optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) = - [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d] - optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) = - [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] - where set' Nothing = Right def - set' (Just txt) = runReadE set txt + optDescrToGetOpt (ReqArg d (cs, ss) arg_desc set _) = + [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d] + optDescrToGetOpt (OptArg d (cs, ss) arg_desc set (dv, def) _) = + [GetOpt.Option cs ss (GetOpt.OptArg dv set' arg_desc) d] + where + set' Nothing = Right def + set' (Just txt) = runReadE set txt optDescrToGetOpt (ChoiceOpt alts) = - [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ] - optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) = - [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d ] - optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) = - [ GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d ] - optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) = - [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) - , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] + [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d, (sf, lf), set, _) <- alts] + optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) = + [GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d] + optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) = + [GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d] + optDescrToGetOpt (BoolOpt d (sfT, lfT) (sfF, lfF) set _) = + [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) + , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) + ] getCurrentChoice :: OptDescr a -> a -> [String] getCurrentChoice (ChoiceOpt alts) a = - [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a] - + [lf | (_, (_sf, lf : _), _, currentChoice) <- alts, currentChoice a] getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" - liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b liftOption get' set' opt = - opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt} + opt{optionDescr = liftOptDescr get' set' `map` optionDescr opt} -- | @since 3.4.0.0 liftOptionL :: ALens' b a -> OptionField a -> OptionField b liftOptionL l = liftOption (^# l) (l #~) - 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, set, get) <- opts] - -liftOptDescr get' set' (OptArg d ff ad set def get) = - OptArg d ff ad (liftSet get' set' `fmap` set) - (liftSet get' set' def) (get . get') - + ChoiceOpt + [ (d, ff, liftSet get' set' set, (get . get')) + | (d, ff, set, get) <- opts + ] +liftOptDescr get' set' (OptArg d ff ad set (dv, mkDef) get) = + OptArg + d + ff + ad + (liftSet get' set' `fmap` set) + (dv, liftSet get' set' mkDef) + (get . get') liftOptDescr get' set' (ReqArg d ff ad set get) = - ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') - + ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') liftOptDescr get' set' (BoolOpt d ffT ffF set get) = - BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') + BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b liftSet get' set' set x = set' (set $ get' x) x -- | Show flags in the standard long option command line format commandShowOptions :: CommandUI flags -> flags -> [String] -commandShowOptions command v = concat - [ showOptDescr v od | o <- commandOptions command ParseArgs - , od <- optionDescr o] +commandShowOptions command v = + concat + [ showOptDescr v od | o <- commandOptions command ParseArgs, od <- optionDescr o + ] where - maybePrefix [] = [] - maybePrefix (lOpt:_) = ["--" ++ lOpt] + maybePrefix [] = [] + maybePrefix (lOpt : _) = ["--" ++ lOpt] showOptDescr :: a -> OptDescr a -> [String] - showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled) - = case enabled x of - Nothing -> [] - Just True -> maybePrefix lfTs - Just False -> maybePrefix lfFs - showOptDescr x c@ChoiceOpt{} - = ["--" ++ val | val <- getCurrentChoice c x] - showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag) - = [ "--"++lf++"="++flag - | flag <- showflag x ] - showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag) - = [ case flag of - Just s -> "--"++lf++"="++s - Nothing -> "--"++lf - | flag <- showflag x ] - showOptDescr _ _ - = error "Distribution.Simple.Command.showOptDescr: unreachable" - + showOptDescr x (BoolOpt _ (_, lfTs) (_, lfFs) _ enabled) = + case enabled x of + Nothing -> [] + Just True -> maybePrefix lfTs + Just False -> maybePrefix lfFs + showOptDescr x c@ChoiceOpt{} = + ["--" ++ val | val <- getCurrentChoice c x] + showOptDescr x (ReqArg _ (_ssff, lf : _) _ _ showflag) = + [ "--" ++ lf ++ "=" ++ flag + | flag <- showflag x + ] + showOptDescr x (OptArg _ (_ssff, lf : _) _ _ _ showflag) = + [ case flag of + Just s -> "--" ++ lf ++ "=" ++ s + Nothing -> "--" ++ lf + | flag <- showflag x + ] + showOptDescr _ _ = + error "Distribution.Simple.Command.showOptDescr: unreachable" commandListOptions :: CommandUI flags -> [String] commandListOptions command = concatMap listOption $ addCommonFlags ShowArgs $ -- This is a slight hack, we don't want - -- "--list-options" showing up in the - -- list options output, so use ShowArgs + -- "--list-options" showing up in the + -- list options output, so use ShowArgs commandGetOpts ShowArgs command where listOption (GetOpt.Option shortNames longNames _ _) = - [ "-" ++ [name] | name <- shortNames ] - ++ [ "--" ++ name | name <- longNames ] + ["-" ++ [name] | name <- shortNames] + ++ ["--" ++ name | name <- longNames] -- | The help text for this command with descriptions of all the options. commandHelp :: CommandUI flags -> String -> String commandHelp command pname = - commandSynopsis command - ++ "\n\n" - ++ commandUsage command pname - ++ ( case commandDescription command of - Nothing -> "" - Just desc -> '\n': desc pname) - ++ "\n" - ++ ( if cname == "" - then "Global flags:" - else "Flags for " ++ cname ++ ":" ) - ++ ( GetOpt.usageInfo "" - . addCommonFlags ShowArgs - $ commandGetOpts ShowArgs command ) - ++ ( case commandNotes command of - Nothing -> "" - Just notes -> '\n': notes pname) - where cname = commandName command + commandSynopsis command + ++ "\n\n" + ++ commandUsage command pname + ++ ( case commandDescription command of + Nothing -> "" + Just desc -> '\n' : desc pname + ) + ++ "\n" + ++ ( if cname == "" + then "Global flags:" + else "Flags for " ++ cname ++ ":" + ) + ++ ( GetOpt.usageInfo "" + . addCommonFlags ShowArgs + $ commandGetOpts ShowArgs command + ) + ++ ( case commandNotes command of + Nothing -> "" + Just notes -> '\n' : notes pname + ) + where + cname = commandName command -- | Default "usage" documentation text for commands. usageDefault :: String -> String -> String usageDefault name pname = - "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" - ++ "Flags for " ++ name ++ ":" + "Usage: " + ++ pname + ++ " " + ++ name + ++ " [FLAGS]\n\n" + ++ "Flags for " + ++ name + ++ ":" -- | Create "usage" documentation from a list of parameter -- configurations. usageAlternatives :: String -> [String] -> String -> String -usageAlternatives name strs pname = unlines - [ start ++ pname ++ " " ++ name ++ " " ++ s - | let starts = "Usage: " : repeat " or: " - , (start, s) <- zip starts strs - ] +usageAlternatives name strs pname = + unlines + [ start ++ pname ++ " " ++ name ++ " " ++ s + | let starts = "Usage: " : repeat " or: " + , (start, s) <- zip starts strs + ] -- | Make a Command from standard 'GetOpt' options. -mkCommandUI :: String -- ^ name - -> String -- ^ synopsis - -> [String] -- ^ usage alternatives - -> flags -- ^ initial\/empty flags - -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options - -> CommandUI flags -mkCommandUI name synopsis usages flags options = CommandUI - { commandName = name - , commandSynopsis = synopsis - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = usageAlternatives name usages - , commandDefaultFlags = flags - , commandOptions = options - } +mkCommandUI + :: String + -- ^ name + -> String + -- ^ synopsis + -> [String] + -- ^ usage alternatives + -> flags + -- ^ initial\/empty flags + -> (ShowOrParseArgs -> [OptionField flags]) + -- ^ options + -> CommandUI flags +mkCommandUI name synopsis usages flags options = + CommandUI + { commandName = name + , commandSynopsis = synopsis + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = usageAlternatives name usages + , commandDefaultFlags = flags + , commandOptions = options + } -- | Common flags that apply to every command data CommonFlag = HelpFlag | ListOptionsFlag commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] commonFlags showOrParseArgs = case showOrParseArgs of - ShowArgs -> [help] + ShowArgs -> [help] ParseArgs -> [help, list] - where - help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) - "Show this help text" + where + help = + GetOpt.Option + helpShortFlags + ["help"] + (GetOpt.NoArg HelpFlag) + "Show this help text" helpShortFlags = case showOrParseArgs of - ShowArgs -> ['h'] + ShowArgs -> ['h'] ParseArgs -> ['h', '?'] - list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag) - "Print a list of command line flags" + list = + GetOpt.Option + [] + ["list-options"] + (GetOpt.NoArg ListOptionsFlag) + "Print a list of command line flags" -addCommonFlags :: ShowOrParseArgs - -> [GetOpt.OptDescr a] - -> [GetOpt.OptDescr (Either CommonFlag a)] +addCommonFlags + :: ShowOrParseArgs + -> [GetOpt.OptDescr a] + -> [GetOpt.OptDescr (Either CommonFlag a)] addCommonFlags showOrParseArgs options = - map (fmap Left) (commonFlags showOrParseArgs) - ++ map (fmap Right) options + map (fmap Left) (commonFlags showOrParseArgs) + ++ map (fmap Right) options -- | Parse a bunch of command line arguments --- -commandParseArgs :: CommandUI flags - -> Bool -- ^ Is the command a global or subcommand? - -> [String] - -> CommandParse (flags -> flags, [String]) +commandParseArgs + :: CommandUI flags + -> Bool + -- ^ Is the command a global or subcommand? + -> [String] + -> CommandParse (flags -> flags, [String]) commandParseArgs command global args = - let options = addCommonFlags ParseArgs - $ commandGetOpts ParseArgs command - order | global = GetOpt.RequireOrder - | otherwise = GetOpt.Permute - in case GetOpt.getOpt' order options args of - (flags, _, _, _) - | any listFlag flags -> CommandList (commandListOptions command) - | any helpFlag flags -> CommandHelp (commandHelp command) - where listFlag (Left ListOptionsFlag) = True; listFlag _ = False - helpFlag (Left HelpFlag) = True; helpFlag _ = False - (flags, opts, opts', []) - | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') - | otherwise -> CommandErrors (unrecognised opts') - (_, _, _, errs) -> CommandErrors errs - - where -- 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 ] - unrecognised opts = [ "unrecognized " - ++ "'" ++ (commandName command) ++ "'" - ++ " option `" ++ opt ++ "'\n" - | opt <- opts ] - -- For unrecognised global flags we put them in the position just after - -- the command, if there is one. This gives us a chance to parse them - -- as sub-command rather than global flags. - mix [] ys = ys - mix (x:xs) ys = x:ys++xs + let options = + addCommonFlags ParseArgs $ + commandGetOpts ParseArgs command + order + | global = GetOpt.RequireOrder + | otherwise = GetOpt.Permute + in case GetOpt.getOpt' order options args of + (flags, _, _, _) + | any listFlag flags -> CommandList (commandListOptions command) + | any helpFlag flags -> CommandHelp (commandHelp command) + where + listFlag (Left ListOptionsFlag) = True; listFlag _ = False + helpFlag (Left HelpFlag) = True; helpFlag _ = False + (flags, opts, opts', []) + | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') + | otherwise -> CommandErrors (unrecognised opts') + (_, _, _, errs) -> CommandErrors errs + where + -- 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] + unrecognised opts = + [ "unrecognized " + ++ "'" + ++ (commandName command) + ++ "'" + ++ " option `" + ++ opt + ++ "'\n" + | opt <- opts + ] + -- For unrecognised global flags we put them in the position just after + -- the command, if there is one. This gives us a chance to parse them + -- as sub-command rather than global flags. + mix [] ys = ys + mix (x : xs) ys = x : ys ++ xs -data CommandParse flags = CommandHelp (String -> String) - | CommandList [String] - | CommandErrors [String] - | CommandReadyToGo flags +data CommandParse flags + = CommandHelp (String -> String) + | CommandList [String] + | CommandErrors [String] + | CommandReadyToGo flags instance Functor CommandParse where - fmap _ (CommandHelp help) = CommandHelp help - fmap _ (CommandList opts) = CommandList opts - fmap _ (CommandErrors errs) = CommandErrors errs + fmap _ (CommandHelp help) = CommandHelp help + fmap _ (CommandList opts) = CommandList opts + fmap _ (CommandErrors errs) = CommandErrors errs fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) - data CommandType = NormalCommand | HiddenCommand -data Command action = - Command String String ([String] -> CommandParse action) CommandType +data Command action + = Command String String ([String] -> CommandParse action) CommandType -- | Mark command as hidden. Hidden commands don't show up in the 'progname -- help' or 'progname --help' output. @@ -467,132 +614,168 @@ hiddenCommand (Command name synopsys f _cmdType) = Command name synopsys f HiddenCommand -commandAddAction :: CommandUI flags - -> (flags -> [String] -> action) - -> Command action +commandAddAction + :: CommandUI flags + -> (flags -> [String] -> action) + -> Command action commandAddAction command action = - Command (commandName command) - (commandSynopsis command) - (fmap (uncurry applyDefaultArgs) . commandParseArgs command False) - NormalCommand + Command + (commandName command) + (commandSynopsis command) + (fmap (uncurry applyDefaultArgs) . commandParseArgs command False) + NormalCommand + where + applyDefaultArgs mkflags args = + let flags = mkflags (commandDefaultFlags command) + in action flags args - where applyDefaultArgs mkflags args = - let flags = mkflags (commandDefaultFlags command) - in action flags args +-- Print suggested command if edit distance is < 5 +badCommand :: [Command action] -> String -> CommandParse a +badCommand commands' cname = + case eDists of + [] -> CommandErrors [unErr] + (s : _) -> + CommandErrors + [ unErr + , "Maybe you meant `" ++ s ++ "`?\n" + ] + where + eDists = + map fst . List.sortBy (comparing snd) $ + [ (cname', dist) + | -- Note that this is not commandNames, so close suggestions will show + -- hidden commands + (Command cname' _ _ _) <- commands' + , let dist = editDistance cname' cname + , dist < 5 + ] + unErr = "unrecognised command: " ++ cname ++ " (try --help)" -commandsRun :: CommandUI a - -> [Command action] - -> [String] - -> CommandParse (a, CommandParse action) +commandsRun + :: CommandUI a + -> [Command action] + -> [String] + -> IO (CommandParse (a, CommandParse action)) commandsRun globalCommand commands args = - case commandParseArgs globalCommand True args of - CommandHelp help -> CommandHelp help - CommandList opts -> CommandList (opts ++ commandNames) - CommandErrors errs -> CommandErrors errs - CommandReadyToGo (mkflags, args') -> case args' of - ("help":cmdArgs) -> handleHelpCommand cmdArgs - (name:cmdArgs) -> case lookupCommand name of - [Command _ _ action _] - -> CommandReadyToGo (flags, action cmdArgs) - _ -> CommandReadyToGo (flags, badCommand name) - [] -> CommandReadyToGo (flags, noCommand) - where flags = mkflags (commandDefaultFlags globalCommand) + commandsRunWithFallback globalCommand commands defaultCommandFallback args - where - lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands' - , cname' == cname ] - noCommand = CommandErrors ["no command given (try --help)\n"] +defaultCommandFallback + :: [Command action] + -> String + -> [String] + -> IO (CommandParse action) +defaultCommandFallback commands' name _cmdArgs = pure $ badCommand commands' name - -- Print suggested command if edit distance is < 5 - badCommand :: String -> CommandParse a - badCommand cname = - case eDists of - [] -> CommandErrors [unErr] - (s:_) -> CommandErrors [ unErr - , "Maybe you meant `" ++ s ++ "`?\n"] +commandsRunWithFallback + :: CommandUI a + -> [Command action] + -> ([Command action] -> String -> [String] -> IO (CommandParse action)) + -> [String] + -> IO (CommandParse (a, CommandParse action)) +commandsRunWithFallback globalCommand commands defaultCommand args = + case commandParseArgs globalCommand True args of + CommandHelp help -> pure $ CommandHelp help + CommandList opts -> pure $ CommandList (opts ++ commandNames) + CommandErrors errs -> pure $ CommandErrors errs + CommandReadyToGo (mkflags, args') -> case args' of + ("help" : cmdArgs) -> handleHelpCommand flags cmdArgs + (name : cmdArgs) -> case lookupCommand name of + [Command _ _ action _] -> + pure $ CommandReadyToGo (flags, action cmdArgs) + _ -> do + final_cmd <- defaultCommand commands' name cmdArgs + return $ CommandReadyToGo (flags, final_cmd) + [] -> pure $ CommandReadyToGo (flags, noCommand) where - eDists = map fst . List.sortBy (comparing snd) $ - [ (cname', dist) - | (Command cname' _ _ _) <- commands' - , let dist = editDistance cname' cname - , dist < 5 ] - unErr = "unrecognised command: " ++ cname ++ " (try --help)" + flags = mkflags (commandDefaultFlags globalCommand) + where + lookupCommand cname = + [ cmd | cmd@(Command cname' _ _ _) <- commands', cname' == cname + ] - commands' = commands ++ [commandAddAction helpCommandUI undefined] - commandNames = [ name | (Command name _ _ NormalCommand) <- commands' ] + noCommand = CommandErrors ["no command given (try --help)\n"] + commands' = commands ++ [commandAddAction helpCommandUI undefined] + commandNames = [name | (Command name _ _ NormalCommand) <- commands'] + -- A bit of a hack: support "prog help" as a synonym of "prog --help" -- furthermore, support "prog help command" as "prog command --help" - handleHelpCommand cmdArgs = + handleHelpCommand flags cmdArgs = case commandParseArgs helpCommandUI True cmdArgs of - CommandHelp help -> CommandHelp help - CommandList list -> CommandList (list ++ commandNames) - CommandErrors _ -> CommandHelp globalHelp - CommandReadyToGo (_,[]) -> CommandHelp globalHelp - CommandReadyToGo (_,(name:cmdArgs')) -> + CommandHelp help -> pure $ CommandHelp help + CommandList list -> pure $ CommandList (list ++ commandNames) + CommandErrors _ -> pure $ CommandHelp globalHelp + CommandReadyToGo (_, []) -> pure $ CommandHelp globalHelp + CommandReadyToGo (_, (name : cmdArgs')) -> case lookupCommand name of [Command _ _ action _] -> - case action ("--help":cmdArgs') of - CommandHelp help -> CommandHelp help - CommandList _ -> CommandList [] - _ -> CommandHelp globalHelp - _ -> badCommand name - - where globalHelp = commandHelp globalCommand + case action ("--help" : cmdArgs') of + CommandHelp help -> pure $ CommandHelp help + CommandList _ -> pure $ CommandList [] + _ -> pure $ CommandHelp globalHelp + _ -> do + fall_back <- defaultCommand commands' name ("--help" : cmdArgs') + return $ CommandReadyToGo (flags, fall_back) + where + globalHelp = commandHelp globalCommand -- Levenshtein distance, from https://wiki.haskell.org/Edit_distance -- (Author: JeanPhilippeBernardy, Simple Permissive Licence) editDistance :: Eq a => [a] -> [a] -> Int -editDistance xs ys = table Array.! (m,n) +editDistance xs ys = table Array.! (m, n) where - (m,n) = (length xs, length ys) - x = Array.array (1,m) (zip [1..] xs) - y = Array.array (1,n) (zip [1..] ys) + (m, n) = (length xs, length ys) + x = Array.array (1, m) (zip [1 ..] xs) + y = Array.array (1, n) (zip [1 ..] ys) - table :: Array.Array (Int,Int) Int + table :: Array.Array (Int, Int) Int table = Array.array bnds [(ij, dist ij) | ij <- Array.range bnds] - bnds = ((0,0),(m,n)) + bnds = ((0, 0), (m, n)) - dist (0,j) = j - dist (i,0) = i - dist (i,j) = minimum - [ table Array.! (i-1,j) + 1 - , table Array.! (i,j-1) + 1 - , if x Array.! i == y Array.! j - then table Array.! (i-1,j-1) - else 1 + table Array.! (i-1,j-1) - ] + dist (0, j) = j + dist (i, 0) = i + dist (i, j) = + minimum + [ table Array.! (i - 1, j) + 1 + , table Array.! (i, j - 1) + 1 + , if x Array.! i == y Array.! j + then table Array.! (i - 1, j - 1) + else 1 + table Array.! (i - 1, j - 1) + ] -- | Utility function, many commands do not accept additional flags. This -- action fails with a helpful error message if the user supplies any extra. --- noExtraFlags :: [String] -> IO () noExtraFlags [] = return () noExtraFlags extraFlags = dieNoVerbosity $ "Unrecognised flags: " ++ intercalate ", " extraFlags ---TODO: eliminate this function and turn it into a variant on commandAddAction + +-- TODO: eliminate this function and turn it into a variant on commandAddAction -- instead like commandAddActionNoArgs that doesn't supply the [String] -- | Helper function for creating globalCommand description getNormalCommandDescriptions :: [Command action] -> [(String, String)] getNormalCommandDescriptions cmds = [ (name, description) - | Command name description _ NormalCommand <- cmds ] + | Command name description _ NormalCommand <- cmds + ] helpCommandUI :: CommandUI () helpCommandUI = - (mkCommandUI - "help" - "Help about commands." - ["[FLAGS]", "COMMAND [FLAGS]"] - () - (const [])) - { - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " help help\n" - ++ " Oh, apparently you already know this.\n" - } + ( mkCommandUI + "help" + "Help about commands." + ["[FLAGS]", "COMMAND [FLAGS]"] + () + (const []) + ) + { commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " help help\n" + ++ " Oh, apparently you already know this.\n" + } -- | wraps a @CommandUI@ together with a function that turns it into a @Command@. -- By hiding the type of flags for the UI allows construction of a list of all UIs at the 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,7 +1,8 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Compiler -- Copyright : Isaac Jones 2003-2004 @@ -20,88 +21,90 @@ -- only know about a single global package collection but GHC has a global and -- per-user one and it lets you create arbitrary other package databases. We do -- not yet fully support this latter feature. - -module Distribution.Simple.Compiler ( - -- * Haskell implementations - module Distribution.Compiler, - Compiler(..), - showCompilerId, showCompilerIdWithAbi, - compilerFlavor, compilerVersion, - compilerCompatFlavor, - compilerCompatVersion, - compilerInfo, +module Distribution.Simple.Compiler + ( -- * Haskell implementations + module Distribution.Compiler + , Compiler (..) + , showCompilerId + , showCompilerIdWithAbi + , compilerFlavor + , compilerVersion + , compilerCompatFlavor + , compilerCompatVersion + , compilerInfo - -- * Support for package databases - PackageDB(..), - PackageDBStack, - registrationPackageDB, - absolutePackageDBPaths, - absolutePackageDBPath, + -- * Support for package databases + , PackageDB (..) + , PackageDBStack + , registrationPackageDB + , absolutePackageDBPaths + , absolutePackageDBPath - -- * Support for optimisation levels - OptimisationLevel(..), - flagToOptimisationLevel, + -- * Support for optimisation levels + , OptimisationLevel (..) + , flagToOptimisationLevel - -- * Support for debug info levels - DebugInfoLevel(..), - flagToDebugInfoLevel, + -- * Support for debug info levels + , DebugInfoLevel (..) + , flagToDebugInfoLevel - -- * Support for language extensions - CompilerFlag, - languageToFlags, - unsupportedLanguages, - extensionsToFlags, - unsupportedExtensions, - parmakeSupported, - reexportedModulesSupported, - renamingPackageFlagsSupported, - unifiedIPIDRequired, - packageKeySupported, - unitIdSupported, - coverageSupported, - profilingSupported, - backpackSupported, - arResponseFilesSupported, - arDashLSupported, - libraryDynDirSupported, - libraryVisibilitySupported, + -- * Support for language extensions + , CompilerFlag + , languageToFlags + , unsupportedLanguages + , extensionsToFlags + , unsupportedExtensions + , parmakeSupported + , reexportedModulesSupported + , renamingPackageFlagsSupported + , unifiedIPIDRequired + , packageKeySupported + , unitIdSupported + , coverageSupported + , profilingSupported + , backpackSupported + , arResponseFilesSupported + , arDashLSupported + , libraryDynDirSupported + , libraryVisibilitySupported + , jsemSupported - -- * Support for profiling detail levels - ProfDetailLevel(..), - knownProfDetailLevels, - flagToProfDetailLevel, - showProfDetailLevel, + -- * Support for profiling detail levels + , ProfDetailLevel (..) + , knownProfDetailLevels + , flagToProfDetailLevel + , showProfDetailLevel ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Pretty +import Prelude () import Distribution.Compiler +import Distribution.Simple.Utils import Distribution.Version import Language.Haskell.Extension -import Distribution.Simple.Utils import qualified Data.Map as Map (lookup) import System.Directory (canonicalizePath) -data Compiler = Compiler { - compilerId :: CompilerId, - -- ^ Compiler flavour and version. - compilerAbiTag :: AbiTag, - -- ^ Tag for distinguishing incompatible ABI's on the same - -- architecture/os. - compilerCompat :: [CompilerId], - -- ^ Other implementations that this compiler claims to be - -- compatible with. - compilerLanguages :: [(Language, CompilerFlag)], - -- ^ Supported language standards. - compilerExtensions :: [(Extension, Maybe CompilerFlag)], - -- ^ Supported extensions. - compilerProperties :: Map String String - -- ^ A key-value map for properties not covered by the above fields. - } - deriving (Eq, Generic, Typeable, Show, Read) +data Compiler = Compiler + { compilerId :: CompilerId + -- ^ Compiler flavour and version. + , compilerAbiTag :: AbiTag + -- ^ Tag for distinguishing incompatible ABI's on the same + -- architecture/os. + , compilerCompat :: [CompilerId] + -- ^ Other implementations that this compiler claims to be + -- compatible with. + , compilerLanguages :: [(Language, CompilerFlag)] + -- ^ Supported language standards. + , compilerExtensions :: [(Extension, Maybe CompilerFlag)] + -- ^ Supported extensions. + , compilerProperties :: Map String String + -- ^ A key-value map for properties not covered by the above fields. + } + deriving (Eq, Generic, Typeable, Show, Read) instance Binary Compiler instance Structured Compiler @@ -111,30 +114,27 @@ showCompilerIdWithAbi :: Compiler -> String showCompilerIdWithAbi comp = - prettyShow (compilerId comp) ++ - case compilerAbiTag comp of - NoAbiTag -> [] - AbiTag xs -> '-':xs + prettyShow (compilerId comp) + ++ case compilerAbiTag comp of + NoAbiTag -> [] + AbiTag xs -> '-' : xs -compilerFlavor :: Compiler -> CompilerFlavor +compilerFlavor :: Compiler -> CompilerFlavor compilerFlavor = (\(CompilerId f _) -> f) . compilerId compilerVersion :: Compiler -> Version compilerVersion = (\(CompilerId _ v) -> v) . compilerId - -- | Is this compiler compatible with the compiler flavour we're interested in? -- -- For example this checks if the compiler is actually GHC or is another -- compiler that claims to be compatible with some version of GHC, e.g. GHCJS. -- -- > if compilerCompatFlavor GHC compiler then ... else ... --- compilerCompatFlavor :: CompilerFlavor -> Compiler -> Bool compilerCompatFlavor flavor comp = - flavor == compilerFlavor comp - || flavor `elem` [ flavor' | CompilerId flavor' _ <- compilerCompat comp ] - + flavor == compilerFlavor comp + || flavor `elem` [flavor' | CompilerId flavor' _ <- compilerCompat comp] -- | Is this compiler compatible with the compiler flavour we're interested in, -- and if so what version does it claim to be compatible with. @@ -145,35 +145,38 @@ -- > case compilerCompatVersion GHC compiler of -- > Just (Version (7:_)) -> ... -- > _ -> ... --- compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version compilerCompatVersion flavor comp | compilerFlavor comp == flavor = Just (compilerVersion comp) - | otherwise = - listToMaybe [ v | CompilerId fl v <- compilerCompat comp, fl == flavor ] + | otherwise = + listToMaybe [v | CompilerId fl v <- compilerCompat comp, fl == flavor] compilerInfo :: Compiler -> CompilerInfo -compilerInfo c = CompilerInfo (compilerId c) - (compilerAbiTag c) - (Just . compilerCompat $ c) - (Just . map fst . compilerLanguages $ c) - (Just . map fst . compilerExtensions $ c) +compilerInfo c = + CompilerInfo + (compilerId c) + (compilerAbiTag c) + (Just . compilerCompat $ c) + (Just . map fst . compilerLanguages $ c) + (Just . map fst . compilerExtensions $ c) -- ------------------------------------------------------------ + -- * Package databases + -- ------------------------------------------------------------ --- |Some compilers have a notion of a database of available packages. --- For some there is just one global db of packages, other compilers --- support a per-user or an arbitrary db specified at some location in --- the file system. This can be used to build isolated environments of --- packages, for example to build a collection of related packages --- without installing them globally. --- -data PackageDB = GlobalPackageDB - | UserPackageDB - | SpecificPackageDB FilePath - deriving (Eq, Generic, Ord, Show, Read, Typeable) +-- | Some compilers have a notion of a database of available packages. +-- For some there is just one global db of packages, other compilers +-- support a per-user or an arbitrary db specified at some location in +-- the file system. This can be used to build isolated environments of +-- packages, for example to build a collection of related packages +-- without installing them globally. +data PackageDB + = GlobalPackageDB + | UserPackageDB + | SpecificPackageDB FilePath + deriving (Eq, Generic, Ord, Show, Read, Typeable) instance Binary PackageDB instance Structured PackageDB @@ -193,114 +196,126 @@ -- we can use several custom package dbs and the user package db together. -- -- When it comes to writing, the top most (last) package is used. --- type PackageDBStack = [PackageDB] -- | Return the package that we should register into. This is the package db at -- the top of the stack. --- registrationPackageDB :: PackageDBStack -> PackageDB -registrationPackageDB dbs = case safeLast dbs of +registrationPackageDB dbs = case safeLast dbs of Nothing -> error "internal error: empty package db set" - Just p -> p + Just p -> p -- | Make package paths absolute - - absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack absolutePackageDBPaths = traverse absolutePackageDBPath absolutePackageDBPath :: PackageDB -> IO PackageDB -absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB -absolutePackageDBPath UserPackageDB = return UserPackageDB +absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB +absolutePackageDBPath UserPackageDB = return UserPackageDB absolutePackageDBPath (SpecificPackageDB db) = SpecificPackageDB `liftM` canonicalizePath db -- ------------------------------------------------------------ + -- * Optimisation levels + -- ------------------------------------------------------------ -- | Some compilers support optimising. Some have different levels. -- For compilers that do not the level is just capped to the level -- they do support. --- -data OptimisationLevel = NoOptimisation - | NormalOptimisation - | MaximumOptimisation - deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) +data OptimisationLevel + = NoOptimisation + | NormalOptimisation + | MaximumOptimisation + deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) instance Binary OptimisationLevel instance Structured OptimisationLevel flagToOptimisationLevel :: Maybe String -> OptimisationLevel -flagToOptimisationLevel Nothing = NormalOptimisation +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" - _ -> error $ "Can't parse optimisation level " ++ s + && i <= fromEnum (maxBound :: OptimisationLevel) -> + toEnum i + | otherwise -> + error $ + "Bad optimisation level: " + ++ show i + ++ ". Valid values are 0..2" + _ -> error $ "Can't parse optimisation level " ++ s -- ------------------------------------------------------------ + -- * Debug info levels + -- ------------------------------------------------------------ -- | Some compilers support emitting debug info. Some have different -- levels. For compilers that do not the level is just capped to the -- level they do support. --- -data DebugInfoLevel = NoDebugInfo - | MinimalDebugInfo - | NormalDebugInfo - | MaximalDebugInfo - deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) +data DebugInfoLevel + = NoDebugInfo + | MinimalDebugInfo + | NormalDebugInfo + | MaximalDebugInfo + deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) instance Binary DebugInfoLevel instance Structured DebugInfoLevel flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel -flagToDebugInfoLevel Nothing = NormalDebugInfo +flagToDebugInfoLevel Nothing = NormalDebugInfo flagToDebugInfoLevel (Just s) = case reads s of [(i, "")] | i >= fromEnum (minBound :: DebugInfoLevel) - && i <= fromEnum (maxBound :: DebugInfoLevel) - -> toEnum i - | otherwise -> error $ "Bad debug info level: " ++ show i - ++ ". Valid values are 0..3" - _ -> error $ "Can't parse debug info level " ++ s + && i <= fromEnum (maxBound :: DebugInfoLevel) -> + toEnum i + | otherwise -> + error $ + "Bad debug info level: " + ++ show i + ++ ". Valid values are 0..3" + _ -> error $ "Can't parse debug info level " ++ s -- ------------------------------------------------------------ + -- * Languages and Extensions + -- ------------------------------------------------------------ unsupportedLanguages :: Compiler -> [Language] -> [Language] unsupportedLanguages comp langs = - [ lang | lang <- langs - , isNothing (languageToFlag comp lang) ] + [ lang | lang <- langs, isNothing (languageToFlag comp lang) + ] languageToFlags :: Compiler -> Maybe Language -> [CompilerFlag] -languageToFlags comp = filter (not . null) - . catMaybes . map (languageToFlag comp) - . maybe [Haskell98] (\x->[x]) +languageToFlags comp = + filter (not . null) + . catMaybes + . map (languageToFlag comp) + . maybe [Haskell98] (\x -> [x]) languageToFlag :: Compiler -> Language -> Maybe CompilerFlag languageToFlag comp ext = lookup ext (compilerLanguages comp) - --- |For the given compiler, return the extensions it does not support. +-- | For the given compiler, return the extensions it does not support. unsupportedExtensions :: Compiler -> [Extension] -> [Extension] unsupportedExtensions comp exts = - [ ext | ext <- exts - , isNothing (extensionToFlag' comp ext) ] + [ ext | ext <- exts, isNothing (extensionToFlag' comp ext) + ] type CompilerFlag = String --- |For the given compiler, return the flags for the supported extensions. +-- | For the given compiler, return the flags for the supported extensions. extensionsToFlags :: Compiler -> [Extension] -> [CompilerFlag] -extensionsToFlags comp = nub . filter (not . null) - . catMaybes . map (extensionToFlag comp) +extensionsToFlags comp = + nub + . filter (not . null) + . catMaybes + . map (extensionToFlag comp) -- | Looks up the flag for a given extension, for a given compiler. -- Ignores the subtlety of extensions which lack associated flags. @@ -329,8 +344,9 @@ -- | Does this compiler support thinning/renaming on package flags? renamingPackageFlagsSupported :: Compiler -> Bool -renamingPackageFlagsSupported = ghcSupported - "Support thinning and renaming package flags" +renamingPackageFlagsSupported = + ghcSupported + "Support thinning and renaming package flags" -- | Does this compiler have unified IPIDs (so no package keys) unifiedIPIDRequired :: Compiler -> Bool @@ -348,18 +364,27 @@ backpackSupported :: Compiler -> Bool backpackSupported = ghcSupported "Support Backpack" +-- | Does this compiler support the -jsem option? +jsemSupported :: Compiler -> Bool +jsemSupported comp = case compilerFlavor comp of + GHC -> v >= mkVersion [9, 7] + _ -> 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]) - _ -> False - where - v = compilerVersion comp + -- 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] + ) + _ -> False + where + v = compilerVersion comp -- | Does this compiler's "ar" command supports response file -- arguments (i.e. @file-style arguments). @@ -376,41 +401,44 @@ coverageSupported :: Compiler -> Bool coverageSupported comp = case compilerFlavor comp of - GHC -> True + GHC -> True GHCJS -> True - _ -> False + _ -> False -- | Does this compiler support profiling? profilingSupported :: Compiler -> Bool profilingSupported comp = case compilerFlavor comp of - GHC -> True + GHC -> True GHCJS -> True - _ -> False + _ -> False -- | Does this compiler support a package database entry with: -- "visibility"? libraryVisibilitySupported :: Compiler -> Bool libraryVisibilitySupported comp = case compilerFlavor comp of - GHC -> v >= mkVersion [8,8] - _ -> False - where - v = compilerVersion comp + GHC -> v >= mkVersion [8, 8] + _ -> False + where + v = compilerVersion comp -- | Utility function for GHC only features ghcSupported :: String -> Compiler -> Bool ghcSupported key comp = case compilerFlavor comp of - GHC -> checkProp + GHC -> checkProp GHCJS -> checkProp - _ -> False - where checkProp = - case Map.lookup key (compilerProperties comp) of - Just "YES" -> True - _ -> False + _ -> False + where + checkProp = + case Map.lookup key (compilerProperties comp) of + Just "YES" -> True + _ -> False -- ------------------------------------------------------------ + -- * Profiling detail level + -- ------------------------------------------------------------ -- | Some compilers (notably GHC) support profiling and can instrument @@ -419,45 +447,47 @@ -- For compilers that do not support this notion or the particular detail -- levels, this is either ignored or just capped to some similar level -- they do support. --- -data ProfDetailLevel = ProfDetailNone - | ProfDetailDefault - | ProfDetailExportedFunctions - | ProfDetailToplevelFunctions - | ProfDetailAllFunctions - | ProfDetailTopLate - | ProfDetailOther String - deriving (Eq, Generic, Read, Show, Typeable) +data ProfDetailLevel + = ProfDetailNone + | ProfDetailDefault + | ProfDetailExportedFunctions + | ProfDetailToplevelFunctions + | ProfDetailAllFunctions + | ProfDetailTopLate + | ProfDetailOther String + deriving (Eq, Generic, Read, Show, Typeable) instance Binary ProfDetailLevel instance Structured ProfDetailLevel flagToProfDetailLevel :: String -> ProfDetailLevel flagToProfDetailLevel "" = ProfDetailDefault -flagToProfDetailLevel s = - case lookup (lowercase s) - [ (name, value) - | (primary, aliases, value) <- knownProfDetailLevels - , name <- primary : aliases ] - of Just value -> value - Nothing -> ProfDetailOther s +flagToProfDetailLevel s = + case lookup + (lowercase s) + [ (name, value) + | (primary, aliases, value) <- knownProfDetailLevels + , name <- primary : aliases + ] of + Just value -> value + Nothing -> ProfDetailOther s knownProfDetailLevels :: [(String, [String], ProfDetailLevel)] knownProfDetailLevels = - [ ("default", [], ProfDetailDefault) - , ("none", [], ProfDetailNone) - , ("exported-functions", ["exported"], ProfDetailExportedFunctions) + [ ("default", [], ProfDetailDefault) + , ("none", [], ProfDetailNone) + , ("exported-functions", ["exported"], ProfDetailExportedFunctions) , ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions) - , ("all-functions", ["all"], ProfDetailAllFunctions) - , ("late-toplevel", ["late"], ProfDetailTopLate) + , ("all-functions", ["all"], ProfDetailAllFunctions) + , ("late-toplevel", ["late"], ProfDetailTopLate) ] showProfDetailLevel :: ProfDetailLevel -> String showProfDetailLevel dl = case dl of - ProfDetailNone -> "none" - ProfDetailDefault -> "default" - ProfDetailExportedFunctions -> "exported-functions" - ProfDetailToplevelFunctions -> "toplevel-functions" - ProfDetailAllFunctions -> "all-functions" - ProfDetailTopLate -> "late-toplevel" - ProfDetailOther other -> other + ProfDetailNone -> "none" + ProfDetailDefault -> "default" + ProfDetailExportedFunctions -> "exported-functions" + ProfDetailToplevelFunctions -> "toplevel-functions" + ProfDetailAllFunctions -> "all-functions" + ProfDetailTopLate -> "late-toplevel" + ProfDetailOther other -> other 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 @@ -1,2143 +1,2699 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# 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 - , writePersistBuildConfig - , getConfigStateFile - , getPersistBuildConfig - , checkPersistBuildConfigOutdated - , tryGetPersistBuildConfig - , maybeGetPersistBuildConfig - , findDistPref, findDistPrefOrDefault - , getInternalLibraries - , computeComponentId - , computeCompatPackageKey - , localBuildInfoFile - , getInstalledPackages - , getInstalledPackagesMonitorFiles - , getPackageDBContents - , configCompilerEx, configCompilerAuxEx - , computeEffectiveProfiling - , ccLdOptionsBuildInfo - , checkForeignDeps - , interpretPackageDbFlags - , ConfigStateFileError(..) - , tryGetConfigStateFile - , platformDefines, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Compiler -import Distribution.Types.IncludeRenaming -import Distribution.Utils.NubList -import Distribution.Simple.Compiler -import Distribution.Simple.PreProcess -import Distribution.Package -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.PackageDescription -import Distribution.PackageDescription.PrettyPrint -import Distribution.PackageDescription.Configuration -import Distribution.PackageDescription.Check hiding (doesFileExist) -import Distribution.Simple.BuildToolDepends -import Distribution.Simple.Program -import Distribution.Simple.Setup as Setup -import Distribution.Simple.BuildTarget -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program.Db (appendProgramSearchPath, modifyProgramSearchPath, lookupProgramByName) -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Types.PackageVersionConstraint -import Distribution.Types.LocalBuildInfo -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.GivenComponent -import Distribution.Version -import Distribution.Verbosity -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Stack -import Distribution.Backpack.Configure -import Distribution.Backpack.DescribeUnitId -import Distribution.Backpack.PreExistingComponent -import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour) -import Distribution.Backpack.Id -import Distribution.Utils.LogProgress - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC -import qualified Distribution.Simple.HaskellSuite as HaskellSuite - -import Control.Exception - ( try ) -import Distribution.Utils.Structured ( structuredDecodeOrFailIO, structuredEncode ) -import Distribution.Compat.Directory - ( listDirectory, doesPathExist ) -import Data.ByteString.Lazy ( ByteString ) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy.Char8 as BLC8 -import Data.List - ( (\\), stripPrefix, intersect) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as Map -import System.Directory - ( canonicalizePath, createDirectoryIfMissing, doesFileExist - , getTemporaryDirectory, removeFile) -import System.FilePath - ( (), isAbsolute, takeDirectory ) -import qualified System.Info - ( compilerName, compilerVersion ) -import System.IO - ( hPutStrLn, hClose ) -import Distribution.Pretty - ( pretty, defaultStyle, prettyShow ) -import Distribution.Parsec - ( simpleParsec ) -import Text.PrettyPrint - ( Doc, ($+$), char, comma, hsep, nest - , punctuate, quotes, render, renderStyle, sep, text ) -import Distribution.Compat.Environment ( lookupEnv ) - -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 - = ConfigStateFileNoHeader -- ^ No header found. - | ConfigStateFileBadHeader -- ^ Incorrect header. - | ConfigStateFileNoParse -- ^ Cannot parse file contents. - | ConfigStateFileMissing -- ^ No file! - | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier - (Either ConfigStateFileError LocalBuildInfo) -- ^ Mismatched version. - deriving (Typeable) - --- | 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 'configure' command." -dispConfigStateFileError ConfigStateFileBadHeader = - text "Saved package config file header is corrupt." - <+> text "Re-run the 'configure' command." -dispConfigStateFileError ConfigStateFileNoParse = - text "Saved package config file is corrupt." - <+> text "Re-run the 'configure' command." -dispConfigStateFileError ConfigStateFileMissing = - text "Run the 'configure' command first." -dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) = - text "Saved package config file is outdated:" - $+$ badCabal $+$ badCompiler - $+$ text "Re-run the '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 :: FilePath -- ^ The file path of the @setup-config@ file. - -> IO LocalBuildInfo -getConfigStateFile filename = do - exists <- doesFileExist filename - unless exists $ throwIO ConfigStateFileMissing - -- 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 :: FilePath -- ^ The file path of the @setup-config@ file. - -> IO (Either ConfigStateFileError LocalBuildInfo) -tryGetConfigStateFile = try . getConfigStateFile - --- | Try to read the 'localBuildInfoFile'. -tryGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> IO (Either ConfigStateFileError LocalBuildInfo) -tryGetPersistBuildConfig = try . getPersistBuildConfig - --- | 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 :: FilePath -- ^ The @dist@ directory path. - -> IO LocalBuildInfo -getPersistBuildConfig = getConfigStateFile . localBuildInfoFile - --- | Try to read the 'localBuildInfoFile'. -maybeGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> IO (Maybe LocalBuildInfo) -maybeGetPersistBuildConfig = - liftM (either (const Nothing) Just) . tryGetPersistBuildConfig - --- | After running configure, output the 'LocalBuildInfo' to the --- 'localBuildInfoFile'. -writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write. - -> IO () -writePersistBuildConfig distPref lbi = do - createDirectoryIfMissing False distPref - writeFileAtomic (localBuildInfoFile distPref) $ - BLC8.unlines [showHeader pkgId, structuredEncode lbi] - where - 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 :: FilePath -> FilePath -> IO Bool -checkPersistBuildConfigOutdated distPref pkg_descr_file = - pkg_descr_file `moreRecentFile` localBuildInfoFile distPref - --- | Get the path of @dist\/setup-config@. -localBuildInfoFile :: FilePath -- ^ The @dist@ directory path. - -> FilePath -localBuildInfoFile distPref = distPref "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 :: FilePath -- ^ default \"dist\" prefix - -> Setup.Flag FilePath -- ^ override \"dist\" prefix - -> IO FilePath -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 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 FilePath -- ^ override \"dist\" prefix - -> IO FilePath -findDistPrefOrDefault = findDistPref defaultDistPref - --- |Perform the \"@.\/setup configure@\" action. --- Returns the @.setup-config@ file. -configure :: (GenericPackageDescription, HookedBuildInfo) - -> ConfigFlags -> IO LocalBuildInfo -configure (pkg_descr0, pbi) cfg = do - -- Determine the component we are configuring, if a user specified - -- one on the command line. We use a fake, flattened version of - -- the package since at this point, we're not really sure what - -- components we *can* configure. @Nothing@ means that we should - -- configure everything (the old behavior). - (mb_cname :: Maybe ComponentName) <- do - let flat_pkg_descr = flattenPackageDescription pkg_descr0 - targets <- readBuildTargets verbosity flat_pkg_descr (configArgs cfg) - -- TODO: bleat if you use the module/file syntax - let targets' = [ cname | BuildTargetComponent cname <- targets ] - case targets' of - _ | null (configArgs cfg) -> return Nothing - [cname] -> return (Just cname) - [] -> die' verbosity "No valid component targets found" - _ -> die' verbosity - "Can only configure either single component or all of them" - - let use_external_internal_deps = isJust mb_cname - case mb_cname of - Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0) - Just cname -> setupMessage' verbosity "Configuring" (packageId pkg_descr0) - cname (Just (configInstantiateWith cfg)) - - -- configCID is only valid for per-component configure - when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ - die' verbosity "--cid is only supported for per-component configure" - - checkDeprecatedFlags verbosity cfg - checkExactConfiguration verbosity pkg_descr0 cfg - - -- Where to build the package - let buildDir :: FilePath -- e.g. dist/build - -- fromFlag OK due to Distribution.Simple calling - -- findDistPrefOrDefault to fill it in - buildDir = fromFlag (configDistPref cfg) "build" - createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir - - -- What package database(s) to use - let packageDbs :: PackageDBStack - packageDbs - = interpretPackageDbFlags - (fromFlag (configUserInstall cfg)) - (configPackageDBs 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, - programDb :: ProgramDb) - <- configCompilerEx - (flagToMaybe (configHcFlavor cfg)) - (flagToMaybe (configHcPath cfg)) - (flagToMaybe (configHcPkg cfg)) - programDbPre - (lessVerbose verbosity) - - -- The InstalledPackageIndex of all installed packages - installedPackageSet :: InstalledPackageIndex - <- getInstalledPackages (lessVerbose verbosity) comp - packageDbs programDb - - -- The set of package names which are "shadowed" by internal - -- packages, and which component they map to - let internalPackageSet :: Set LibraryName - internalPackageSet = getInternalLibraries pkg_descr0 - - -- 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))) $ - die' verbosity $ - "--enable-tests/--enable-benchmarks are incompatible with" ++ - " explicitly specifying a component to configure." - - -- Some sanity checks related to dynamic/static linking. - when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $ - die' verbosity $ - "--enable-executable-dynamic and --enable-executable-static" ++ - " are incompatible with each other." - - -- 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 (die' verbosity) return $ - combinedConstraints (configConstraints cfg) - (configDependencies cfg) - installedPackageSet - - -- 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. - (pkg_descr :: PackageDescription, - flags :: FlagAssignment) - <- configureFinalizedPackage verbosity cfg enabled - allConstraints - (dependencySatisfiable - use_external_internal_deps - (fromFlagOrDefault False (configExactConfiguration cfg)) - (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg)) - (packageName pkg_descr0) - installedPackageSet - internalPackageSet - requiredDepsMap) - comp - compPlatform - pkg_descr0 - - debug verbosity $ "Finalized package description:\n" - ++ showPackageDescription pkg_descr - - let cabalFileDir = maybe "." takeDirectory $ - flagToMaybe (configCabalFilePath cfg) - checkCompilerProblems verbosity comp pkg_descr enabled - checkPackageProblems verbosity cabalFileDir pkg_descr0 - (updatePackageDescription pbi pkg_descr) - - -- 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 :: [PreExistingComponent] - <- configureDependencies - verbosity - use_external_internal_deps - internalPackageSet - installedPackageSet - requiredDepsMap - pkg_descr - enabled - - -- 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_descr) - let installDirs :: InstallDirTemplates - installDirs = combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs cfg) - - -- 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)) $ - die' verbosity $ "The package " ++ prettyShow (packageId pkg_descr0) - ++ " requires the following languages which are not " - ++ "supported by " ++ prettyShow (compilerId comp) ++ ": " - ++ intercalate ", " (map prettyShow langs) - let extlist = nub $ concatMap allExtensions - (enabledBuildInfos pkg_descr enabled) - let exts = unsupportedExtensions comp extlist - when (not (null exts)) $ - die' verbosity $ "The package " ++ prettyShow (packageId pkg_descr0) - ++ " requires the following language extensions which are not " - ++ "supported by " ++ prettyShow (compilerId comp) ++ ": " - ++ intercalate ", " (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)) $ - die' verbosity $ "Cannot build some foreign libraries: " - ++ intercalate "," unsupportedFLibs - - -- Configure certain external build tools, see below for which ones. - let requiredBuildTools = do - bi <- enabledBuildInfos pkg_descr enabled - -- First, we collect any tool dep that we know is external. This is, - -- in practice: - -- - -- 1. `build-tools` entries on the whitelist - -- - -- 2. `build-tool-depends` that aren't from the current package. - let externBuildToolDeps = - [ LegacyExeDependency (unUnqualComponentName eName) versionRange - | buildTool@(ExeDependency _ eName versionRange) - <- getAllToolDependencies pkg_descr bi - , not $ isInternal pkg_descr buildTool ] - -- Second, we collect any build-tools entry we don't know how to - -- desugar. We'll never have any idea how to build them, so we just - -- hope they are already on the PATH. - let unknownBuildTools = - [ buildTool - | buildTool <- buildTools bi - , Nothing == desugarBuildTool pkg_descr buildTool ] - externBuildToolDeps ++ unknownBuildTools - - programDb' <- - configureAllKnownPrograms (lessVerbose verbosity) programDb - >>= configureRequiredPrograms verbosity requiredBuildTools - - (pkg_descr', programDb'') <- - configurePkgconfigPackages verbosity pkg_descr programDb' enabled - - -- 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. - -- internalPackageSet - -- use_external_internal_deps - (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 - - -- 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.isDynamic comp) - 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.isDynamic comp - 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 - - when (withDynExe_ && not withSharedLib_) $ 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." - - setProfLBI <- configureProfiling verbosity cfg comp - - setCoverageLBI <- 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 reloc = fromFlagOrDefault False $ configRelocatable cfg - - let buildComponentsMap = - foldl' (\m clbi -> Map.insertWith (++) - (componentLocalName clbi) [clbi] m) - Map.empty buildComponents - - let lbi = (setCoverageLBI . setProfLBI) - LocalBuildInfo { - configFlags = cfg, - flagAssignment = flags, - componentEnabledSpec = enabled, - extraConfigArgs = [], -- Currently configure does not - -- take extra args, but if it - -- did they would go here. - installDirTemplates = installDirs, - compiler = comp, - hostPlatform = compPlatform, - buildDir = buildDir, - cabalFilePath = flagToMaybe (configCabalFilePath cfg), - componentGraph = Graph.fromDistinctList buildComponents, - componentNameMap = buildComponentsMap, - installedPkgs = packageDependsIndex, - pkgDescrFile = Nothing, - localPkgDescr = pkg_descr', - withPrograms = programDb'', - withVanillaLib = fromFlag $ configVanillaLib cfg, - withSharedLib = withSharedLib_, - withStaticLib = withStaticLib_, - withDynExe = withDynExe_, - withFullyStaticExe = withFullyStaticExe_, - withProfLib = 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, - withPackageDB = packageDbs, - progPrefix = fromFlag $ configProgPrefix cfg, - progSuffix = fromFlag $ configProgSuffix cfg, - relocatable = reloc - } - - when reloc (checkRelocatable verbosity pkg_descr 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) $ die' verbosity $ - "expected an absolute directory name for --prefix: " ++ 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 - - where - verbosity = fromFlag (configVerbosity cfg) - --- | 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 ++) - <$> appendProgramSearchPath (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) $ - die' verbosity $ "'--exact-configuration' was given, " - ++ "but the following flags were not specified: " - ++ intercalate ", " (map show 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) InstalledPackageInfo - -- ^ required dependencies - -> (Dependency -> Bool) -dependencySatisfiable - use_external_internal_deps - exact_config - allow_private_deps - pn installedPackageSet packageLibraries 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 - -- Except for internal deps, when we're NOT per-component mode; - -- those are just True. - then 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 - -- When we are doing per-component configure, we now need to - -- test if the internal dependency is in the index. This has - -- DIFFERENT semantics from normal dependency satisfiability. - then internalDepSatisfiableExternally - -- If a 'PackageName' is defined by an internal component, the dep is - -- satisfiable (we're going to build it ourselves) - else 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 (not . null . PackageIndex.lookupInternalDependency installedPackageSet pn vr) 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 - where maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap - --- | Finalize a generic package description. The workhorse is --- 'finalizePD' but there's a bit of other nattering --- about necessary. --- --- TODO: what exactly is the business with @flaggedTests@ and --- @flaggedBenchmarks@? -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_descr0', flags) <- - case finalizePD - (configConfigurationsFlags cfg) - enabled - satisfies - compPlatform - (compilerInfo comp) - allConstraints - pkg_descr0 - of Right r -> return r - Left missing -> - die' verbosity $ "Encountered missing or private dependencies:\n" - ++ (render . nest 4 . sep . punctuate comma - . map (pretty . simplifyDependency) - $ missing) - - -- add extra include/lib dirs as specified in cfg - -- we do it here so that those get checked too - let pkg_descr = addExtraIncludeLibDirs pkg_descr0' - - unless (nullFlagAssignment flags) $ - info verbosity $ "Flags chosen: " - ++ intercalate ", " [ unFlagName fn ++ "=" ++ prettyShow value - | (fn, value) <- unFlagAssignment flags ] - - return (pkg_descr, flags) - where - addExtraIncludeLibDirs pkg_descr = - 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 - } - --- | 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)) $ - die' verbosity $ - "Your compiler does not support thinning and renaming on " - ++ "package flags. To use this feature you must use " - ++ "GHC 7.9 or later." - - when (any (not.null.reexportedModules) (allLibraries pkg_descr) - && not (reexportedModulesSupported comp)) $ - die' verbosity $ - "Your compiler does not support module re-exports. To use " - ++ "this feature you must use GHC 7.9 or later." - - when (any (not.null.signatures) (allLibraries pkg_descr) - && not (backpackSupported comp)) $ - die' verbosity $ - "Your compiler does not support Backpack. To use " - ++ "this feature you must use GHC 8.1 or later." - --- | Select dependencies for the package. -configureDependencies - :: Verbosity - -> UseExternalInternalDeps - -> Set LibraryName - -> InstalledPackageIndex -- ^ installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo -- ^ required deps - -> PackageDescription - -> ComponentRequestedSpec - -> IO [PreExistingComponent] -configureDependencies verbosity use_external_internal_deps - packageLibraries 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 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 ] - - when (not (null internalPkgDeps) - && not (newPackageDepsBehaviour pkg_descr)) $ - die' verbosity $ "The field 'build-depends: " - ++ intercalate ", " (map (prettyShow . packageName) internalPkgDeps) - ++ "' refers to a library which is defined within the same " - ++ "package. To use this feature the package must specify at " - ++ "least 'cabal-version: >= 1.8'." - - reportFailedDependencies verbosity failedDeps - reportSelectedDependencies verbosity allPkgDeps - - return externalPkgDeps - --- | Select and apply coverage settings for the build based on the --- 'ConfigFlags' and 'Compiler'. -configureCoverage :: Verbosity -> ConfigFlags -> Compiler - -> IO (LocalBuildInfo -> LocalBuildInfo) -configureCoverage verbosity cfg comp = do - let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg) - tryLibCoverage = fromFlagOrDefault tryExeCoverage - (mappend (configCoverage cfg) (configLibCoverage cfg)) - if coverageSupported comp - then do - let apply lbi = lbi { libCoverage = tryLibCoverage - , exeCoverage = tryExeCoverage - } - return apply - else do - let apply lbi = lbi { libCoverage = False - , 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 -}, 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 tryExeProfiling = fromFlagOrDefault False - (mappend (configProf cfg) (configProfExe cfg)) - tryLibProfiling = fromFlagOrDefault tryExeProfiling - (mappend (configProf cfg) (configProfLib cfg)) - in (tryLibProfiling, tryExeProfiling) - --- | Select and apply profiling settings for the build based on the --- 'ConfigFlags' and 'Compiler'. -configureProfiling :: Verbosity -> ConfigFlags -> Compiler - -> IO (LocalBuildInfo -> LocalBuildInfo) -configureProfiling verbosity cfg comp = do - let (tryLibProfiling, 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 - - (exeProfWithoutLibProf, applyProfiling) <- - if profilingSupported comp - then do - exeLevel <- checkProfileLevel tryExeProfileLevel - libLevel <- checkProfileLevel tryLibProfileLevel - let apply lbi = lbi { withProfLib = tryLibProfiling - , withProfLibDetail = libLevel - , withProfExe = tryExeProfiling - , withProfExeDetail = exeLevel - } - return (tryExeProfiling && not tryLibProfiling, apply) - else do - let apply lbi = lbi { withProfLib = False - , withProfLibDetail = ProfDetailNone - , withProfExe = False - , withProfExeDetail = ProfDetailNone - } - when (tryExeProfiling || tryLibProfiling) $ warn verbosity - ("The compiler " ++ showCompilerId comp ++ " does not support " - ++ "profiling. Profiling has been disabled.") - return (False, apply) - - when exeProfWithoutLibProf $ warn verbosity - ("Executables will be built with profiling, but library " - ++ "profiling is disabled. Linking will fail if any executables " - ++ "depend on the library.") - - 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 - -- | An internal dependency ('PackageId' should be a library name) - -- which we are going to have to build. (The - -- 'PackageId' here is a hack to get a modest amount of - -- polymorphism out of the 'Package' typeclass.) - | InternalDependency PackageId - -data FailedDependency = DependencyNotExists PackageName - | DependencyMissingInternal PackageName LibraryName - | DependencyNoVersion Dependency - --- | Test for a package dependency and record the version we have installed. -selectDependency :: PackageId -- ^ Package id of current package - -> Set LibraryName -- ^ package libraries - -> 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 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 = 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 = 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' ] - -reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO () -reportFailedDependencies _ [] = return () -reportFailedDependencies verbosity failed = - die' verbosity (intercalate "\n\n" (map reportFailedDependency failed)) - - where - reportFailedDependency (DependencyNotExists pkgname) = - "there is no version of " ++ prettyShow pkgname ++ " installed.\n" - ++ "Perhaps you need to download and install it from\n" - ++ hackageUrl ++ prettyShow pkgname ++ "?" - - reportFailedDependency (DependencyMissingInternal pkgname lib) = - "internal dependency " ++ prettyShow (prettyLibraryNameComponent lib) ++ " not installed.\n" - ++ "Perhaps you need to configure and install it first?\n" - ++ "(This library was defined by " ++ prettyShow pkgname ++ ")" - - reportFailedDependency (DependencyNoVersion dep) = - "cannot satisfy dependency " ++ prettyShow (simplifyDependency dep) ++ "\n" - --- | 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 - -> PackageDBStack -- ^ The stack of package databases. - -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity comp packageDBs progdb = do - when (null packageDBs) $ - die' verbosity $ "No package databases have been specified. If you use " - ++ "--package-db=clear, you must follow it with --package-db= " - ++ "with 'global', 'user' or a specific file." - - 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 packageDBs' progdb - GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs' progdb - UHC -> UHC.getInstalledPackages verbosity comp packageDBs' progdb - HaskellSuite {} -> - HaskellSuite.getInstalledPackages verbosity packageDBs' progdb - flv -> die' verbosity $ "don't know how to find the installed packages for " - ++ prettyShow flv - where - packageDBExists (SpecificPackageDB path) = do - 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 - -> PackageDB -> ProgramDb - -> IO InstalledPackageIndex -getPackageDBContents verbosity comp packageDB progdb = do - info verbosity "Reading installed packages..." - case compilerFlavor comp of - GHC -> GHC.getPackageDBContents verbosity packageDB progdb - GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progdb - -- For other compilers, try to fall back on 'getInstalledPackages'. - _ -> getInstalledPackages verbosity comp [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 - -> PackageDBStack - -> ProgramDb -> Platform - -> IO [FilePath] -getInstalledPackagesMonitorFiles verbosity comp packageDBs progdb platform = - case compilerFlavor comp of - GHC -> GHC.getInstalledPackagesMonitorFiles - verbosity 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 [] - --- | 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 PackageDB] -> PackageDBStack -interpretPackageDbFlags userInstall = extra initialStack - 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] - -> InstalledPackageIndex - -> Either String ([PackageVersionConstraint], - Map (PackageName, ComponentName) InstalledPackageInfo) -combinedConstraints constraints dependencies installedPackages = do - - when (not (null badComponentIds)) $ - Left $ render $ text "The following package dependencies were requested" - $+$ nest 4 (dispDependencies badComponentIds) - $+$ text "however the given installed package instance does not exist." - - --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 lookupKnownProgram progName progdb of - Nothing -> - -- Try to configure it as a 'simpleProgram' automatically - -- - -- 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` (\_ -> die' verbosity notFound) - `catchExit` (\_ -> die' verbosity notFound) - let trim = dropWhile isSpace . dropWhileEnd isSpace - let v = PkgconfigVersion (toUTF8BS $ trim version) - if not (withinPkgconfigVersionRange v range) - then die' verbosity (badVersion v) - else info verbosity (depSatisfied v) - where - notFound = "The pkg-config package '" ++ pkg ++ "'" - ++ versionRequirement - ++ " is required but it could not be found." - badVersion v = "The pkg-config package '" ++ pkg ++ "'" - ++ versionRequirement - ++ " is required but the version installed on the" - ++ " system is version " ++ prettyShow v - 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 (drop 2) includeDirs', - extraLibs = map (drop 2) extraLibs', - extraLibDirs = map (drop 2) extraLibDirs', - extraLibsStatic = map (drop 2) extraLibsStatic', - extraLibDirsStatic = map (drop 2) extraLibDirsStatic', - ccOptions = cflags', - ldOptions = ldflags'' - } - --- ----------------------------------------------------------------------------- --- Determining the compiler details - -configCompilerAuxEx :: ConfigFlags - -> IO (Compiler, Platform, ProgramDb) -configCompilerAuxEx cfg = do - programDb <- mkProgramDb cfg defaultProgramDb - configCompilerEx (flagToMaybe $ configHcFlavor cfg) - (flagToMaybe $ configHcPath cfg) - (flagToMaybe $ configHcPkg cfg) - programDb - (fromFlag (configVerbosity cfg)) - -configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath - -> ProgramDb -> Verbosity - -> IO (Compiler, Platform, ProgramDb) -configCompilerEx Nothing _ _ _ verbosity = die' verbosity "Unknown compiler" -configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do - (comp, maybePlatform, programDb) <- case hcFlavor of - GHC -> GHC.configure verbosity hcPath hcPkg progdb - GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb - UHC -> UHC.configure verbosity hcPath hcPkg progdb - HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg progdb - _ -> die' verbosity "Unknown compiler" - 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 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 includeDirs) - isHeader = isSuffixOf ".h" - genHeaders <- for relIncDirs $ \dir -> - fmap (dir ) . filter isHeader <$> - listDirectory (buildDir lbi dir) `catchIO` (\_ -> return []) - srcHeaders <- for relIncDirs $ \dir -> - fmap (dir ) . filter isHeader <$> - listDirectory (baseDir lbi dir) `catchIO` (\_ -> return []) - let commonHeaders = concat genHeaders `intersect` concat srcHeaders - for_ commonHeaders $ \hdr -> do - warn verbosity $ "Duplicate header found in " - ++ (buildDir lbi hdr) - ++ " and " - ++ (baseDir lbi hdr) - ++ "; removing " - ++ (baseDir lbi hdr) - removeFile (baseDir lbi 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]) - - baseDir lbi' = fromMaybe "." (takeDirectory <$> cabalFilePath 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" ++ buildDir lbi "autogen" ] - -- `configure' may generate headers in the build directory - ++ [ "-I" ++ buildDir lbi dir - | dir <- ordNub (collectField includeDirs) - , not (isAbsolute dir)] - -- we might also reference headers from the - -- packages directory. - ++ [ "-I" ++ baseDir lbi dir - | dir <- ordNub (collectField includeDirs) - , not (isAbsolute dir)] - ++ [ "-I" ++ dir | dir <- ordNub (collectField includeDirs) - , isAbsolute dir] - ++ ["-I" ++ baseDir lbi] - ++ 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" ++ 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 program args = do - tempDir <- getTemporaryDirectory - withTempFile tempDir ".c" $ \cName cHnd -> - withTempFile tempDir "" $ \oNname oHnd -> do - hPutStrLn cHnd program - hClose cHnd - hClose oHnd - _ <- getDbProgramOutput verbosity - gccProgram (withPrograms lbi) (cName:"-o":oNname:args) - return True - `catchIO` (\_ -> return False) - `catchExit` (\_ -> return False) - - explainErrors Nothing [] = return () -- should be impossible! - explainErrors _ _ - | isNothing . lookupProgram gccProgram . withPrograms $ lbi - - = die' verbosity $ unlines - [ "No working gcc", - "This package depends on foreign library but we cannot " - ++ "find a working C compiler. If you have it in a " - ++ "non-standard location you can use the --with-gcc " - ++ "flag to specify it." ] - - explainErrors hdr libs = die' verbosity $ unlines $ - [ if plural - then "Missing dependencies on foreign libraries:" - else "Missing dependency on a foreign library:" - | missing ] - ++ case hdr of - Just (Left h) -> ["* Missing (or bad) header file: " ++ h ] - _ -> [] - ++ case libs of - [] -> [] - [lib] -> ["* Missing (or bad) C library: " ++ lib] - _ -> ["* Missing (or bad) C libraries: " ++ - intercalate ", " libs] - ++ [if plural then messagePlural else messageSingular | missing] - ++ case hdr of - Just (Left _) -> [ headerCppMessage ] - Just (Right h) -> [ (if missing then "* " else "") - ++ "Bad header file: " ++ h - , headerCcMessage ] - _ -> [] - - where - plural = length libs >= 2 - -- Is there something missing? (as opposed to broken) - missing = not (null libs) - || case hdr of Just (Left _) -> True; _ -> False - - messageSingular = - "This problem can usually be solved by installing the system " - ++ "package that provides this library (you may need the " - ++ "\"-dev\" version). If the library is already installed " - ++ "but in a non-standard location then you can use the flags " - ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " - ++ "where it is." - ++ "If the library file does exist, it may contain errors that " - ++ "are caught by the C compiler at the preprocessing stage. " - ++ "In this case you can re-run configure with the verbosity " - ++ "flag -v3 to see the error messages." - messagePlural = - "This problem can usually be solved by installing the system " - ++ "packages that provide these libraries (you may need the " - ++ "\"-dev\" versions). If the libraries are already installed " - ++ "but in a non-standard location then you can use the flags " - ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " - ++ "where they are." - ++ "If the library files do exist, it may contain errors that " - ++ "are caught by the C compiler at the preprocessing stage. " - ++ "In this case you can re-run configure with the verbosity " - ++ "flag -v3 to see the error messages." - headerCppMessage = - "If the header file does exist, it may contain errors that " - ++ "are caught by the C compiler at the preprocessing stage. " - ++ "In this case you can re-run configure with the verbosity " - ++ "flag -v3 to see the error messages." - headerCcMessage = - "The header file contains a compile error. " - ++ "You can re-run configure with the verbosity flag " - ++ "-v3 to see the error messages from the C compiler." - --- | 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 (Just pkg) - (errors, warnings) = - partitionEithers (M.mapMaybe classEW $ pureChecks ++ ioChecks) - if null errors - then traverse_ (warn verbosity) (map ppPackageCheck warnings) - else die' verbosity (intercalate "\n\n" $ 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 - --- | 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 ]) - $ die' verbosity $ "Operating system: " ++ prettyShow os ++ - ", does not support relocatable builds" - where - (Platform _ os) = hostPlatform lbi - - -- Check if the Compiler support relocatable builds - checkCompiler - = unless (compilerFlavor comp `elem` [ GHC ]) - $ die' verbosity $ "Compiler: " ++ show comp ++ - ", does not support relocatable builds" - where - comp = compiler lbi - - -- Check if all the install dirs are relative to same prefix - packagePrefixRelative - = unless (relativeInstallDirs installDirs) - $ die' verbosity $ "Installation directories are not prefix_relative:\n" ++ - show 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 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 - unless (p `isPrefixOf` canonicalized) $ - die' verbosity $ msg libdir - | 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) - msg l = "Library directory of a dependency: " ++ show l ++ - "\nis not relative to the installation prefix:\n" ++ - show p - --- ----------------------------------------------------------------------------- --- 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) - goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib) - goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib) - goGhcPlatform _ = unsupported [ - "Building foreign libraries is currently only supported on Mac OS, " - , "Linux and Windows" - ] - - goGhcOsx :: ForeignLibType -> Maybe String - goGhcOsx ForeignLibNativeShared - | not (null (foreignLibModDefFile flib)) = unsupported [ - "Module definition file not supported on OSX" - ] - | not (null (foreignLibVersionInfo flib)) = unsupported [ - "Foreign library versioning not currently supported on OSX" - ] - | otherwise = - Nothing - goGhcOsx _ = unsupported [ - "We can currently only build shared foreign libraries on OSX" - ] - - goGhcLinux :: ForeignLibType -> Maybe String - goGhcLinux ForeignLibNativeShared - | not (null (foreignLibModDefFile flib)) = unsupported [ - "Module definition file not supported on Linux" - ] - | not (null (foreignLibVersionInfo flib)) - && not (null (foreignLibVersionLinux flib)) = unsupported [ - "You must not specify both lib-version-info and lib-version-linux" - ] - | otherwise = - Nothing - goGhcLinux _ = unsupported [ - "We can currently only build shared foreign libraries on Linux" - ] - - goGhcWindows :: ForeignLibType -> Maybe String - goGhcWindows ForeignLibNativeShared - | not standalone = unsupported [ - "We can currently only build standalone libraries on Windows. Use\n" - , " if os(Windows)\n" - , " options: standalone\n" - , "in your foreign-library stanza." - ] - | not (null (foreignLibVersionInfo flib)) = unsupported [ - "Foreign library versioning not currently supported on Windows.\n" - , "You can specify module definition files in the mod-def-file field." - ] - | otherwise = - Nothing - goGhcWindows _ = unsupported [ - "We can currently only build shared foreign libraries on Windows" - ] +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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 + , 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.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 (lookupProgramByName, modifyProgramSearchPath, prependProgramSearchPath) +import Distribution.Simple.Setup.Common as Setup +import Distribution.Simple.Setup.Config as Setup +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.Utils.Structured (structuredDecodeOrFailIO, structuredEncode) +import System.Directory + ( canonicalizePath + , createDirectoryIfMissing + , doesFileExist + , getTemporaryDirectory + , removeFile + ) +import System.FilePath + ( isAbsolute + , takeDirectory + , () + ) +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 +import Distribution.Simple.Errors +import Distribution.Types.AnnotatedId + +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 + | -- | Mismatched version. + ConfigStateFileBadVersion + PackageIdentifier + PackageIdentifier + (Either ConfigStateFileError LocalBuildInfo) + deriving (Typeable) + +-- | 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 'configure' command." +dispConfigStateFileError ConfigStateFileBadHeader = + text "Saved package config file header is corrupt." + <+> text "Re-run the 'configure' command." +dispConfigStateFileError ConfigStateFileNoParse = + text "Saved package config file is corrupt." + <+> text "Re-run the 'configure' command." +dispConfigStateFileError ConfigStateFileMissing = + text "Run the 'configure' command first." +dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) = + text "Saved package config file is outdated:" + $+$ badCabal + $+$ badCompiler + $+$ text "Re-run the '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 + :: FilePath + -- ^ The file path of the @setup-config@ file. + -> IO LocalBuildInfo +getConfigStateFile filename = do + exists <- doesFileExist filename + unless exists $ throwIO ConfigStateFileMissing + -- 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 + :: FilePath + -- ^ The file path of the @setup-config@ file. + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetConfigStateFile = try . getConfigStateFile + +-- | Try to read the 'localBuildInfoFile'. +tryGetPersistBuildConfig + :: FilePath + -- ^ The @dist@ directory path. + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetPersistBuildConfig = try . getPersistBuildConfig + +-- | 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 + :: FilePath + -- ^ The @dist@ directory path. + -> IO LocalBuildInfo +getPersistBuildConfig = getConfigStateFile . localBuildInfoFile + +-- | Try to read the 'localBuildInfoFile'. +maybeGetPersistBuildConfig + :: FilePath + -- ^ The @dist@ directory path. + -> IO (Maybe LocalBuildInfo) +maybeGetPersistBuildConfig = + liftM (either (const Nothing) Just) . tryGetPersistBuildConfig + +-- | After running configure, output the 'LocalBuildInfo' to the +-- 'localBuildInfoFile'. +writePersistBuildConfig + :: FilePath + -- ^ The @dist@ directory path. + -> LocalBuildInfo + -- ^ The 'LocalBuildInfo' to write. + -> IO () +writePersistBuildConfig distPref lbi = do + createDirectoryIfMissing False distPref + writeFileAtomic (localBuildInfoFile distPref) $ + BLC8.unlines [showHeader pkgId, structuredEncode lbi] + where + 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 :: FilePath -> FilePath -> IO Bool +checkPersistBuildConfigOutdated distPref pkg_descr_file = + pkg_descr_file `moreRecentFile` localBuildInfoFile distPref + +-- | Get the path of @dist\/setup-config@. +localBuildInfoFile + :: FilePath + -- ^ The @dist@ directory path. + -> FilePath +localBuildInfoFile distPref = distPref "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 + :: FilePath + -- ^ default \"dist\" prefix + -> Setup.Flag FilePath + -- ^ override \"dist\" prefix + -> IO FilePath +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 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 FilePath + -- ^ override \"dist\" prefix + -> IO FilePath +findDistPrefOrDefault = findDistPref defaultDistPref + +-- | Perform the \"@.\/setup configure@\" action. +-- Returns the @.setup-config@ file. +configure + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo +configure (g_pkg_descr, hookedBuildInfo) cfg = do + -- Cabal pre-configure + (lbc1, comp, platform, enabledComps) <- preConfigurePackage cfg g_pkg_descr + + -- Cabal package-wide configure + (lbc2, pbd2, pkg_info) <- + finalizeAndConfigurePackage cfg lbc1 g_pkg_descr comp platform enabledComps + + -- Cabal per-component configure + externalPkgDeps <- finalCheckPackage g_pkg_descr pbd2 hookedBuildInfo pkg_info + configureComponents lbc2 pbd2 pkg_info externalPkgDeps + +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 + targets <- readBuildTargets verbosity flat_pkg_descr (configArgs cfg) + -- TODO: bleat if you use the module/file syntax + let targets' = [cname | BuildTargetComponent cname <- targets] + case targets' of + _ | null (configArgs cfg) -> return Nothing + [cname] -> return (Just cname) + [] -> 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 build_dir :: FilePath -- e.g. dist/build + build_dir = configFlagsBuildDir 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 build_dir + + lbc <- computeLocalBuildConfig cfg comp programDb00 + return (lbc, comp, compPlatform, enabled) + +computeLocalBuildConfig + :: ConfigFlags + -> Compiler + -> ProgramDb + -> IO LBC.LocalBuildConfig +computeLocalBuildConfig cfg comp programDb = do + let verbosity = fromFlag (configVerbosity cfg) + -- 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.isDynamic comp) + 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.isDynamic comp + 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 + + when (withDynExe_ && not withSharedLib_) $ + 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." + + 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 + , withProfLibDetail = ProfDetailNone + , withProfExe = False + , withProfExeDetail = ProfDetailNone + , withOptimization = fromFlag $ configOptimization cfg + , withDebugInfo = fromFlag $ configDebugInfo cfg + , withGHCiLib = withGHCiLib_ + , splitSections = split_sections + , splitObjs = split_objs + , stripExes = strip_exe + , stripLibs = strip_lib + , exeCoverage = False + , libCoverage = False + , relocatable = fromFlagOrDefault False $ configRelocatable cfg + } + + return $ + 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) ComponentId + , 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 verbosity = fromFlag (configVerbosity cfg) + + -- 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 = 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 verbosity = fromFlag (configVerbosity cfg) + + 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 + 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], [PromisedComponent]) +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 verbosity = fromFlag (configVerbosity cfg) + use_external_internal_deps = + case enabled of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + + let cabalFileDir = + maybe "." takeDirectory $ + flagToMaybe (configCabalFilePath cfg) + 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], [PromisedComponent]) + -> 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 verbosity = fromFlag (configVerbosity cfg) + 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 + 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 + + -- 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 :: [GivenComponent] -> Map (PackageName, ComponentName) ComponentId +mkPromisedDepsSet comps = Map.fromList [((pn, CLibName ln), cid) | GivenComponent pn ln cid <- 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) ComponentId + -> 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) ComponentId + -> InstalledPackageIndex + -- ^ installed packages + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ required deps + -> PackageDescription + -> ComponentRequestedSpec + -> IO ([PreExistingComponent], [PromisedComponent]) +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 -}, 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 tryExeProfiling = + fromFlagOrDefault + False + (mappend (configProf cfg) (configProfExe cfg)) + tryLibProfiling = + fromFlagOrDefault + tryExeProfiling + (mappend (configProf cfg) (configProfLib cfg)) + in (tryLibProfiling, 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, 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 + + (exeProfWithoutLibProf, applyProfiling) <- + if profilingSupported 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 + } + return (tryExeProfiling && not tryLibProfiling, apply) + else do + let apply buildOptions = + buildOptions + { LBC.withProfLib = 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 (False, apply) + + when exeProfWithoutLibProf $ + warn + verbosity + ( "Executables will be built with profiling, but library " + ++ "profiling is disabled. Linking will fail if any executables " + ++ "depend on the library." + ) + + 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 PromisedComponent + | -- | An internal dependency ('PackageId' should be a library name) + -- which we are going to have to build. (The + -- 'PackageId' here is a hack to get a modest amount of + -- polymorphism out of the 'Package' typeclass.) + InternalDependency 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) ComponentId + -- ^ 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 cid <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = + return $ PromisedDependency (PromisedComponent dep_pkgname (AnnotatedId currentCabalId (CLibName lib) cid)) + 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 cid <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = + return $ PromisedDependency (PromisedComponent dep_pkgname (AnnotatedId currentCabalId (CLibName lib) cid)) + 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 + -> PackageDBStack + -- ^ The stack of package databases. + -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp 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 packageDBs' progdb + GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs' progdb + UHC -> UHC.getInstalledPackages verbosity comp packageDBs' progdb + HaskellSuite{} -> + HaskellSuite.getInstalledPackages verbosity packageDBs' progdb + flv -> + dieWithException verbosity $ HowToFindInstalledPackages flv + where + packageDBExists (SpecificPackageDB path) = do + 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 + -> PackageDB + -> ProgramDb + -> IO InstalledPackageIndex +getPackageDBContents verbosity comp packageDB progdb = do + info verbosity "Reading installed packages..." + case compilerFlavor comp of + GHC -> GHC.getPackageDBContents verbosity packageDB progdb + GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progdb + -- For other compilers, try to fall back on 'getInstalledPackages'. + _ -> getInstalledPackages verbosity comp [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 + -> PackageDBStack + -> ProgramDb + -> Platform + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity comp packageDBs progdb platform = + case compilerFlavor comp of + GHC -> + GHC.getInstalledPackagesMonitorFiles + verbosity + 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 LocalBuildInfo{compiler = comp, withPackageDB = pkgDb, withPrograms = progDb} mkException unitids = do + ipindex <- getInstalledPackages verbosity comp 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 PackageDB] -> PackageDBStack +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 lookupKnownProgram progName progdb of + Nothing -> + -- Try to configure it as a 'simpleProgram' automatically + -- + -- 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 (drop 2) includeDirs' + , extraLibs = map (drop 2) extraLibs' + , extraLibDirs = map (drop 2) extraLibDirs' + , extraLibsStatic = map (drop 2) extraLibsStatic' + , extraLibDirsStatic = map (drop 2) extraLibDirsStatic' + , ccOptions = cflags' + , ldOptions = ldflags'' + } + +-- ----------------------------------------------------------------------------- +-- Determining the compiler details + +configCompilerAuxEx + :: ConfigFlags + -> IO (Compiler, Platform, ProgramDb) +configCompilerAuxEx cfg = do + programDb <- mkProgramDb cfg defaultProgramDb + configCompilerEx + (flagToMaybe $ configHcFlavor cfg) + (flagToMaybe $ configHcPath cfg) + (flagToMaybe $ configHcPkg cfg) + programDb + (fromFlag (configVerbosity cfg)) + +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 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 includeDirs) + isHeader = isSuffixOf ".h" + genHeaders <- for relIncDirs $ \dir -> + fmap (dir ) . filter isHeader + <$> listDirectory (buildDir lbi dir) `catchIO` (\_ -> return []) + srcHeaders <- for relIncDirs $ \dir -> + fmap (dir ) . filter isHeader + <$> listDirectory (baseDir lbi dir) `catchIO` (\_ -> return []) + let commonHeaders = concat genHeaders `intersect` concat srcHeaders + for_ commonHeaders $ \hdr -> do + warn verbosity $ + "Duplicate header found in " + ++ (buildDir lbi hdr) + ++ " and " + ++ (baseDir lbi hdr) + ++ "; removing " + ++ (baseDir lbi hdr) + removeFile (baseDir lbi 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]) + + baseDir lbi' = fromMaybe "." (takeDirectory <$> cabalFilePath 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" ++ buildDir lbi "autogen"] + -- `configure' may generate headers in the build directory + ++ [ "-I" ++ buildDir lbi dir + | dir <- ordNub (collectField includeDirs) + , not (isAbsolute dir) + ] + -- we might also reference headers from the + -- packages directory. + ++ [ "-I" ++ baseDir lbi dir + | dir <- ordNub (collectField includeDirs) + , not (isAbsolute dir) + ] + ++ [ "-I" ++ dir | dir <- ordNub (collectField includeDirs), isAbsolute dir + ] + ++ ["-I" ++ baseDir lbi] + ++ 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" ++ 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 program args = + do + tempDir <- getTemporaryDirectory + withTempFile tempDir ".c" $ \cName cHnd -> + withTempFile tempDir "" $ \oNname oHnd -> do + hPutStrLn cHnd program + hClose cHnd + hClose oHnd + _ <- + getDbProgramOutput + verbosity + gccProgram + (withPrograms lbi) + (cName : "-o" : 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 + +-- | 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 + 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 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) + goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib) + goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib) + goGhcPlatform _ = + unsupported + [ "Building foreign libraries is currently only supported on Mac OS, " + , "Linux and Windows" + ] + + goGhcOsx :: ForeignLibType -> Maybe String + goGhcOsx ForeignLibNativeShared + | not (null (foreignLibModDefFile flib)) = + unsupported + [ "Module definition file not supported on OSX" + ] + | not (null (foreignLibVersionInfo flib)) = + unsupported + [ "Foreign library versioning not currently supported on OSX" + ] + | otherwise = + Nothing + goGhcOsx _ = + unsupported + [ "We can currently only build shared foreign libraries on OSX" + ] + + goGhcLinux :: ForeignLibType -> Maybe String + goGhcLinux ForeignLibNativeShared + | not (null (foreignLibModDefFile flib)) = + unsupported + [ "Module definition file not supported on Linux" + ] + | not (null (foreignLibVersionInfo flib)) + && not (null (foreignLibVersionLinux flib)) = + unsupported + [ "You must not specify both lib-version-info and lib-version-linux" + ] + | otherwise = + Nothing + goGhcLinux _ = + unsupported + [ "We can currently only build shared foreign libraries on Linux" + ] + + goGhcWindows :: ForeignLibType -> Maybe String + goGhcWindows ForeignLibNativeShared + | not standalone = + unsupported + [ "We can currently only build standalone libraries on Windows. Use\n" + , " if os(Windows)\n" + , " options: standalone\n" + , "in your foreign-library stanza." + ] + | not (null (foreignLibVersionInfo flib)) = + unsupported + [ "Foreign library versioning not currently supported on Windows.\n" + , "You can specify module definition files in the mod-def-file field." + ] + | otherwise = + Nothing + goGhcWindows _ = + unsupported + [ "We can currently only build shared foreign libraries on Windows" + ] standalone :: Bool standalone = ForeignLibStandalone `elem` foreignLibOptions flib 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 @@ -1,9 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- +{-# OPTIONS_GHC -fno-warn-deprecations #-} + -- | -- Module : Distribution.Simple.ConfigureScript -- Copyright : Isaac Jones 2003-2005 @@ -11,44 +13,50 @@ -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable --- -{-# OPTIONS_GHC -fno-warn-deprecations #-} - -module Distribution.Simple.ConfigureScript ( - runConfigureScript +module Distribution.Simple.ConfigureScript + ( runConfigureScript ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -- local import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Simple.Errors +import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program import Distribution.Simple.Program.Db -import Distribution.Simple.Setup - -import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Config import Distribution.Simple.Utils +import Distribution.System (buildPlatform) import Distribution.Utils.NubList import Distribution.Verbosity -import Distribution.Pretty -import Distribution.System (buildPlatform) -- Base -import System.FilePath (searchPathSeparator, takeDirectory, (), - splitDirectories, dropDrive) +import System.FilePath + ( dropDrive + , searchPathSeparator + , splitDirectories + , takeDirectory + , () + ) #ifdef mingw32_HOST_OS import System.FilePath (normalise, splitDrive) #endif -import Distribution.Compat.Directory (makeAbsolute) -import Distribution.Compat.Environment (getEnvironment) +import Distribution.Compat.Directory (makeAbsolute) +import Distribution.Compat.Environment (getEnvironment) import Distribution.Compat.GetShortPathName (getShortPathName) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map -runConfigureScript :: Verbosity -> ConfigFlags -> LocalBuildInfo - -> IO () +runConfigureScript + :: Verbosity + -> ConfigFlags + -> LocalBuildInfo + -> IO () runConfigureScript verbosity flags lbi = do env <- getEnvironment let programDb = withPrograms lbi @@ -60,8 +68,9 @@ -- to ccFlags -- We don't try and tell configure which ld to use, as we don't have -- a way to pass its flags too - configureFile <- makeAbsolute $ - fromMaybe "." (takeDirectory <$> cabalFilePath lbi) "configure" + configureFile <- + makeAbsolute $ + fromMaybe "." (takeDirectory <$> cabalFilePath lbi) "configure" -- autoconf is fussy about filenames, and has a set of forbidden -- characters that can't appear in the build directory, etc: -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions @@ -78,30 +87,40 @@ let configureFile' = toUnix configureFile for_ badAutoconfCharacters $ \(c, cname) -> when (c `elem` dropDrive configureFile') $ - warn verbosity $ concat - [ "The path to the './configure' script, '", configureFile' - , "', contains the character '", [c], "' (", cname, ")." - , " This may cause the script to fail with an obscure error, or for" - , " building the package to fail later." - ] + warn verbosity $ + concat + [ "The path to the './configure' script, '" + , configureFile' + , "', contains the character '" + , [c] + , "' (" + , cname + , ")." + , " This may cause the script to fail with an obscure error, or for" + , " building the package to fail later." + ] - let -- Convert a flag name to name of environment variable to represent its - -- value for the configure script. - flagEnvVar :: FlagName -> String - flagEnvVar flag = "CABAL_FLAG_" ++ map f (unFlagName flag) - where f c - | isAlphaNum c = c - | otherwise = '_' - -- A map from such env vars to every flag name and value where the name - -- name maps to that that env var. - cabalFlagMap :: Map String (NonEmpty (FlagName, Bool)) - cabalFlagMap = Map.fromListWith (<>) - [ (flagEnvVar flag, (flag, bool) :| []) - | (flag, bool) <- unFlagAssignment $ flagAssignment lbi - ] + let + -- Convert a flag name to name of environment variable to represent its + -- value for the configure script. + flagEnvVar :: FlagName -> String + flagEnvVar flag = "CABAL_FLAG_" ++ map f (unFlagName flag) + where + f c + | isAlphaNum c = c + | otherwise = '_' + -- A map from such env vars to every flag name and value where the name + -- name maps to that that env var. + cabalFlagMap :: Map String (NonEmpty (FlagName, Bool)) + cabalFlagMap = + Map.fromListWith + (<>) + [ (flagEnvVar flag, (flag, bool) :| []) + | (flag, bool) <- unFlagAssignment $ flagAssignment lbi + ] -- A map from env vars to flag names to the single flag we will go with cabalFlagMapDeconflicted :: Map String (FlagName, Bool) <- - flip Map.traverseWithKey cabalFlagMap $ \ envVar -> \case + flip Map.traverseWithKey cabalFlagMap $ \envVar -> \case -- No conflict: no problem singleFlag :| [] -> pure singleFlag -- Conflict: warn and discard all but first @@ -109,51 +128,61 @@ let quote s = "'" ++ s ++ "'" toName = quote . unFlagName . fst renderedList = intercalate ", " $ NonEmpty.toList $ toName <$> collidingFlags - warn verbosity $ unwords - [ "Flags", renderedList, "all map to the same environment variable" - , quote envVar, "causing a collision." - , "The value first flag", toName firstFlag, "will be used." - ] + warn verbosity $ + unwords + [ "Flags" + , renderedList + , "all map to the same environment variable" + , quote envVar + , "causing a collision." + , "The value first flag" + , toName firstFlag + , "will be used." + ] pure firstFlag - let cabalFlagEnv = [ (envVar, Just val) - | (envVar, (_, bool)) <- Map.toList cabalFlagMapDeconflicted - , let val = if bool then "1" else "0" - ] ++ - [ ( "CABAL_FLAGS" - , Just $ unwords [ showFlagValue fv | fv <- unFlagAssignment $ flagAssignment lbi ] - ) - ] + let cabalFlagEnv = + [ (envVar, Just val) + | (envVar, (_, bool)) <- Map.toList cabalFlagMapDeconflicted + , let val = if bool then "1" else "0" + ] + ++ [ + ( "CABAL_FLAGS" + , Just $ unwords [showFlagValue fv | fv <- unFlagAssignment $ flagAssignment lbi] + ) + ] let extraPath = fromNubList $ configProgramPathExtra flags - let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) - $ lookup "CFLAGS" env + let cflagsEnv = + maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) $ + lookup "CFLAGS" env spSep = [searchPathSeparator] - pathEnv = maybe (intercalate spSep extraPath) - ((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env - overEnv = ("CFLAGS", Just cflagsEnv) : - [("PATH", Just pathEnv) | not (null extraPath)] ++ - cabalFlagEnv + pathEnv = + maybe + (intercalate spSep extraPath) + ((intercalate spSep extraPath ++ spSep) ++) + $ lookup "PATH" env + overEnv = + ("CFLAGS", Just cflagsEnv) + : [("PATH", Just pathEnv) | not (null extraPath)] + ++ cabalFlagEnv hp = hostPlatform lbi maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)] - args' = configureFile':args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag + args' = configureFile' : args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag shProg = simpleProgram "sh" - progDb <- appendProgramSearchPath verbosity extraPath emptyProgramDb - shConfiguredProg <- lookupProgram shProg - `fmap` configureProgram verbosity shProg progDb + progDb <- prependProgramSearchPath verbosity extraPath emptyProgramDb + shConfiguredProg <- + lookupProgram shProg + `fmap` configureProgram verbosity shProg progDb case shConfiguredProg of - Just sh -> runProgramInvocation verbosity $ - (programInvocation (sh {programOverrideEnv = overEnv}) args') - { progInvokeCwd = Just (buildDir lbi) } - Nothing -> die' verbosity notFoundMsg + Just sh -> + runProgramInvocation verbosity $ + (programInvocation (sh{programOverrideEnv = overEnv}) args') + { progInvokeCwd = Just (buildDir lbi) + } + Nothing -> dieWithException verbosity NotFoundMsg where args = configureArgs backwardsCompatHack flags backwardsCompatHack = False - - notFoundMsg = "The package has a './configure' script. " - ++ "If you are on Windows, This requires a " - ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. " - ++ "If you are not on Windows, ensure that an 'sh' command " - ++ "is discoverable in your path." -- | Convert Windows path to Unix ones toUnix :: String -> String diff --git a/src/Distribution/Simple/Errors.hs b/src/Distribution/Simple/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Errors.hs @@ -0,0 +1,800 @@ +----------------------------------------------------------------------------- + +-- Module : Distribution.Simple.Errors +-- Copyright : Suganya Arun +-- License : BSD3 +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A collection of Exception Types in the Cabal library package + +module Distribution.Simple.Errors + ( CabalException (..) + , FailedDependency (..) + , exceptionCode + , exceptionMessage + ) where + +import Distribution.Compat.Prelude +import Distribution.Compiler +import Distribution.InstalledPackageInfo +import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription (FlagName, UnqualComponentName) +import Distribution.Pretty + ( Pretty (pretty) + , prettyShow + ) +import Distribution.Simple.InstallDirs +import Distribution.Simple.PreProcess.Types (Suffix) +import Distribution.System (OS) +import Distribution.Types.BenchmarkType +import Distribution.Types.LibraryName +import Distribution.Types.PkgconfigVersion +import Distribution.Types.TestType +import Distribution.Types.VersionRange.Internal () +import Distribution.Version +import Text.PrettyPrint + +data FailedDependency + = DependencyNotExists PackageName + | DependencyMissingInternal PackageName LibraryName + | DependencyNoVersion Dependency + deriving (Show) + +-- Types representing exceptions thrown by functions in all the modules of Cabal Package +data CabalException + = NoBenchMarkProgram FilePath + | EnableBenchMark + | BenchMarkNameDisabled String + | NoBenchMark String + | NoLibraryFound + | CompilerNotInstalled CompilerFlavor + | CantFindIncludeFile String + | UnsupportedTestSuite String + | UnsupportedBenchMark String + | NoIncludeFileFound String + | NoModuleFound ModuleName [Suffix] + | RegMultipleInstancePkg + | SuppressingChecksOnFile + | NoSupportDirStylePackageDb + | OnlySupportSpecificPackageDb + | FailedToParseOutputDescribe String PackageId + | DumpFailed String String + | FailedToParseOutputDump String + | ListFailed String + | FailedToParseOutputList String + | ProgramNotFound String + | NoSupportForHoogle + | NoSupportForQuickJumpFlag + | NoGHCVersionFromHaddock + | NoGHCVersionFromCompiler + | HaddockAndGHCVersionDoesntMatch Version Version + | MustHaveSharedLibraries + | HaddockPackageFlags [(InstalledPackageInfo, [UnitId])] + | UnknownCompilerFlavor CompilerFlavor + | FailedToDetermineTarget + | NoMultipleTargets + | REPLNotSupported + | NoSupportBuildingTestSuite TestType + | NoSupportBuildingBenchMark BenchmarkType + | BuildingNotSupportedWithCompiler + | ProvideHaskellSuiteTool String + | CannotDetermineCompilerVersion + | PkgDumpFailed + | FailedToParseOutput + | CantFindSourceModule ModuleName + | VersionMismatchJS FilePath Version FilePath Version + | VersionMismatchGHCJS FilePath Version FilePath Version + | GlobalPackageDBLimitation + | GlobalPackageDBSpecifiedFirst + | MatchDirFileGlob String + | MatchDirFileGlobErrors [String] + | ErrorParsingFileDoesntExist FilePath + | FailedParsing String + | NotFoundMsg + | UnrecognisedBuildTarget [String] + | ReportBuildTargetProblems [(String, [String], String)] + | UnknownBuildTarget [(String, [(String, String)])] + | AmbiguousBuildTarget [(String, [(String, String)])] + | CheckBuildTargets String + | VersionMismatchGHC FilePath Version FilePath Version + | CheckPackageDbStackPost76 + | CheckPackageDbStackPre76 + | GlobalPackageDbSpecifiedFirst + | CantInstallForeignLib + | NoSupportForPreProcessingTest TestType + | NoSupportForPreProcessingBenchmark BenchmarkType + | CantFindSourceForPreProcessFile String + | NoSupportPreProcessingTestExtras TestType + | NoSupportPreProcessingBenchmarkExtras BenchmarkType + | UnlitException String + | RunProgramInvocationException FilePath String + | GetProgramInvocationException FilePath String + | GetProgramInvocationLBSException FilePath String + | CheckSemaphoreSupport + | NoLibraryForPackage + | SanityCheckHookedBuildInfo UnqualComponentName + | ConfigureScriptNotFound + | NoValidComponent + | ConfigureEitherSingleOrAll + | ConfigCIDValidForPreComponent + | SanityCheckForEnableComponents + | SanityCheckForDynamicStaticLinking + | UnsupportedLanguages PackageIdentifier CompilerId [String] + | UnsupportedLanguageExtension PackageIdentifier CompilerId [String] + | CantFindForeignLibraries [String] + | ExpectedAbsoluteDirectory FilePath + | FlagsNotSpecified [FlagName] + | EncounteredMissingDependency [Dependency] + | CompilerDoesn'tSupportThinning + | CompilerDoesn'tSupportReexports + | CompilerDoesn'tSupportBackpack + | LibraryWithinSamePackage [PackageId] + | ReportFailedDependencies [FailedDependency] String + | NoPackageDatabaseSpecified + | HowToFindInstalledPackages CompilerFlavor + | PkgConfigNotFound String String + | BadVersion String String PkgconfigVersion + | UnknownCompilerException + | NoWorkingGcc + | NoOSSupport OS + | NoCompilerSupport String + | InstallDirsNotPrefixRelative (InstallDirs FilePath) + | ExplainErrors (Maybe (Either [Char] [Char])) [String] + | CheckPackageProblems [String] + | LibDirDepsPrefixNotRelative FilePath FilePath + | CombinedConstraints Doc + | CantParseGHCOutput + | IncompatibleWithCabal String String + | Couldn'tFindTestProgram FilePath + | TestCoverageSupport + | Couldn'tFindTestProgLibV09 FilePath + | TestCoverageSupportLibV09 + | RawSystemStdout String + | FindFileCwd FilePath + | FindFileEx FilePath + | FindModuleFileEx ModuleName [Suffix] [FilePath] + | MultipleFilesWithExtension String + | NoDesc + | MultiDesc [String] + | RelocRegistrationInfo + | CreatePackageDB + | WithHcPkg String + | RegisMultiplePkgNotSupported + | RegisteringNotImplemented + | NoTestSuitesEnabled + | TestNameDisabled String + | NoSuchTest String + | ConfigureProgram String FilePath + | RequireProgram String + | NoProgramFound String VersionRange + | BadVersionDb String Version VersionRange FilePath + | UnknownVersionDb String VersionRange FilePath + | MissingCoveredInstalledLibrary UnitId + deriving (Show, Typeable) + +exceptionCode :: CabalException -> Int +exceptionCode e = case e of + NoBenchMarkProgram{} -> 1678 + EnableBenchMark{} -> 1453 + BenchMarkNameDisabled{} -> 2781 + NoBenchMark{} -> 1654 + NoLibraryFound -> 2546 + CompilerNotInstalled{} -> 7465 + CantFindIncludeFile{} -> 3876 + UnsupportedTestSuite{} -> 3245 + UnsupportedBenchMark{} -> 9123 + NoIncludeFileFound{} -> 2987 + NoModuleFound{} -> 6421 + RegMultipleInstancePkg{} -> 3421 + SuppressingChecksOnFile{} -> 5436 + NoSupportDirStylePackageDb -> 2980 + OnlySupportSpecificPackageDb -> 6547 + FailedToParseOutputDescribe{} -> 7218 + DumpFailed{} -> 6736 + FailedToParseOutputDump{} -> 9076 + ListFailed{} -> 5109 + FailedToParseOutputList{} -> 7650 + ProgramNotFound{} -> 4123 + NoSupportForHoogle{} -> 8706 + NoSupportForQuickJumpFlag{} -> 7086 + NoGHCVersionFromHaddock -> 5045 + NoGHCVersionFromCompiler -> 4098 + HaddockAndGHCVersionDoesntMatch{} -> 1998 + MustHaveSharedLibraries{} -> 6032 + HaddockPackageFlags{} -> 4569 + UnknownCompilerFlavor{} -> 3102 + FailedToDetermineTarget{} -> 5049 + NoMultipleTargets{} -> 6091 + REPLNotSupported{} -> 1098 + NoSupportBuildingTestSuite{} -> 4106 + NoSupportBuildingBenchMark{} -> 5320 + BuildingNotSupportedWithCompiler{} -> 7077 + ProvideHaskellSuiteTool{} -> 7509 + CannotDetermineCompilerVersion{} -> 4519 + PkgDumpFailed{} -> 2291 + FailedToParseOutput{} -> 5500 + CantFindSourceModule{} -> 8870 + VersionMismatchJS{} -> 9001 + VersionMismatchGHCJS{} -> 4001 + GlobalPackageDBLimitation{} -> 5002 + GlobalPackageDBSpecifiedFirst{} -> 3901 + MatchDirFileGlob{} -> 9760 + MatchDirFileGlobErrors{} -> 6661 + ErrorParsingFileDoesntExist{} -> 1234 + FailedParsing{} -> 6565 + NotFoundMsg{} -> 8011 + UnrecognisedBuildTarget{} -> 3410 + ReportBuildTargetProblems{} -> 5504 + UnknownBuildTarget{} -> 4444 + AmbiguousBuildTarget{} -> 7865 + CheckBuildTargets{} -> 4733 + VersionMismatchGHC{} -> 4000 + CheckPackageDbStackPost76{} -> 3000 + CheckPackageDbStackPre76{} -> 5640 + GlobalPackageDbSpecifiedFirst{} -> 2345 + CantInstallForeignLib{} -> 8221 + NoSupportForPreProcessingTest{} -> 3008 + NoSupportForPreProcessingBenchmark{} -> 6990 + CantFindSourceForPreProcessFile{} -> 7554 + NoSupportPreProcessingTestExtras{} -> 7886 + NoSupportPreProcessingBenchmarkExtras{} -> 9999 + UnlitException{} -> 5454 + RunProgramInvocationException{} -> 8012 + GetProgramInvocationException{} -> 7300 + GetProgramInvocationLBSException{} -> 6578 + CheckSemaphoreSupport{} -> 2002 + NoLibraryForPackage{} -> 8004 + SanityCheckHookedBuildInfo{} -> 6007 + ConfigureScriptNotFound{} -> 4567 + NoValidComponent{} -> 5680 + ConfigureEitherSingleOrAll{} -> 2001 + ConfigCIDValidForPreComponent{} -> 7006 + SanityCheckForEnableComponents{} -> 5004 + SanityCheckForDynamicStaticLinking{} -> 4007 + UnsupportedLanguages{} -> 8074 + UnsupportedLanguageExtension{} -> 5656 + CantFindForeignLibraries{} -> 4574 + ExpectedAbsoluteDirectory{} -> 6662 + FlagsNotSpecified{} -> 9080 + EncounteredMissingDependency{} -> 8010 + CompilerDoesn'tSupportThinning{} -> 4003 + CompilerDoesn'tSupportReexports{} -> 3456 + CompilerDoesn'tSupportBackpack{} -> 5446 + LibraryWithinSamePackage{} -> 7007 + ReportFailedDependencies{} -> 4321 + NoPackageDatabaseSpecified{} -> 2300 + HowToFindInstalledPackages{} -> 3003 + PkgConfigNotFound{} -> 7123 + BadVersion{} -> 7600 + UnknownCompilerException{} -> 3022 + NoWorkingGcc{} -> 1088 + NoOSSupport{} -> 3339 + NoCompilerSupport{} -> 2290 + InstallDirsNotPrefixRelative{} -> 6000 + ExplainErrors{} -> 4345 + CheckPackageProblems{} -> 5559 + LibDirDepsPrefixNotRelative{} -> 6667 + CombinedConstraints{} -> 5000 + CantParseGHCOutput{} -> 1980 + IncompatibleWithCabal{} -> 8123 + Couldn'tFindTestProgram{} -> 5678 + TestCoverageSupport{} -> 7890 + Couldn'tFindTestProgLibV09{} -> 9012 + TestCoverageSupportLibV09{} -> 1076 + RawSystemStdout{} -> 3098 + FindFileCwd{} -> 4765 + FindFileEx{} -> 2115 + FindModuleFileEx{} -> 6663 + MultipleFilesWithExtension{} -> 3333 + NoDesc{} -> 7654 + MultiDesc{} -> 5554 + RelocRegistrationInfo{} -> 4343 + CreatePackageDB{} -> 6787 + WithHcPkg{} -> 9876 + RegisMultiplePkgNotSupported{} -> 7632 + RegisteringNotImplemented{} -> 5411 + NoTestSuitesEnabled{} -> 9061 + TestNameDisabled{} -> 8210 + NoSuchTest{} -> 8000 + ConfigureProgram{} -> 5490 + RequireProgram{} -> 6666 + NoProgramFound{} -> 7620 + BadVersionDb{} -> 8038 + UnknownVersionDb{} -> 1008 + MissingCoveredInstalledLibrary{} -> 9341 + +versionRequirement :: VersionRange -> String +versionRequirement range + | isAnyVersion range = "" + | otherwise = " version " ++ prettyShow range + +exceptionMessage :: CabalException -> String +exceptionMessage e = case e of + NoBenchMarkProgram cmd -> "Could not find benchmark program \"" ++ cmd ++ "\". Did you build the package first?" + EnableBenchMark -> "No benchmarks enabled. Did you remember to configure with " ++ "\'--enable-benchmarks\'?" + BenchMarkNameDisabled bmName -> "Package configured with benchmark " ++ bmName ++ " disabled." + 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 + UnsupportedTestSuite testType -> "Unsupported test suite type: " ++ testType + UnsupportedBenchMark benchMarkType -> "Unsupported benchmark type: " ++ benchMarkType + NoIncludeFileFound f -> "can't find include file " ++ f + NoModuleFound m suffixes -> + "Could not find module: " + ++ prettyShow m + ++ " with any suffix: " + ++ show (map prettyShow suffixes) + ++ ".\n" + ++ "If the module " + ++ "is autogenerated it should be added to 'autogen-modules'." + RegMultipleInstancePkg -> "HcPkg.register: the compiler does not support,registering multiple instances of packages." + SuppressingChecksOnFile -> "HcPkg.register: the compiler does not support ,suppressing checks on files." + NoSupportDirStylePackageDb -> "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" + OnlySupportSpecificPackageDb -> "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" + FailedToParseOutputDescribe programId pkgId -> "failed to parse output of '" ++ programId ++ " describe " ++ prettyShow pkgId ++ "'" + DumpFailed programId exception -> programId ++ " dump failed: " ++ exception + FailedToParseOutputDump programId -> "failed to parse output of '" ++ programId ++ " dump'" + ListFailed programId -> programId ++ " list failed" + FailedToParseOutputList programId -> "failed to parse output of '" ++ programId ++ " list'" + ProgramNotFound progName -> "The program '" ++ progName ++ "' is required but it could not be found" + NoSupportForHoogle -> "Haddock 2.0 and 2.1 do not support the --hoogle flag." + NoSupportForQuickJumpFlag -> "Haddock prior to 2.19 does not support the --quickjump flag." + NoGHCVersionFromHaddock -> "Could not get GHC version from Haddock" + NoGHCVersionFromCompiler -> "Could not get GHC version from compiler" + HaddockAndGHCVersionDoesntMatch ghcVersion haddockGhcVersion -> + "Haddock's internal GHC version must match the configured " + ++ "GHC version.\n" + ++ "The GHC version is " + ++ prettyShow ghcVersion + ++ " but " + ++ "haddock is using GHC version " + ++ prettyShow haddockGhcVersion + MustHaveSharedLibraries -> "Must have vanilla or shared libraries " ++ "enabled in order to run haddock" + HaddockPackageFlags inf -> + "internal error when calculating transitive " + ++ "package dependencies.\nDebug info: " + ++ show inf + UnknownCompilerFlavor compilerFlavor -> "dumpBuildInfo: Unknown compiler flavor: " ++ show compilerFlavor + FailedToDetermineTarget -> "Failed to determine target." + NoMultipleTargets -> "The 'repl' command does not support multiple targets at once." + REPLNotSupported -> "A REPL is not supported with this compiler." + NoSupportBuildingTestSuite testType -> "No support for building test suite type " ++ show testType + 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 + VersionMismatchJS ghcjsProgPath ghcjsVersion ghcjsPkgProgPath ghcjsPkgGhcjsVersion -> + "Version mismatch between ghcjs and ghcjs-pkg: " + ++ show ghcjsProgPath + ++ " is version " + ++ prettyShow ghcjsVersion + ++ " " + ++ show ghcjsPkgProgPath + ++ " is version " + ++ prettyShow ghcjsPkgGhcjsVersion + VersionMismatchGHCJS ghcjsProgPath ghcjsGhcVersion ghcjsPkgProgPath ghcjsPkgVersion -> + "Version mismatch between ghcjs and ghcjs-pkg: " + ++ show ghcjsProgPath + ++ " was built with GHC version " + ++ prettyShow ghcjsGhcVersion + ++ " " + ++ show ghcjsPkgProgPath + ++ " was built with GHC version " + ++ prettyShow ghcjsPkgVersion + GlobalPackageDBLimitation -> + "With current ghc versions the global package db is always used " + ++ "and must be listed first. This ghc limitation may be lifted in " + ++ "future, see 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" + MatchDirFileGlob pathError -> pathError + MatchDirFileGlobErrors errors -> unlines errors + ErrorParsingFileDoesntExist filePath -> "Error Parsing: file \"" ++ filePath ++ "\" doesn't exist. Cannot continue." + FailedParsing name -> "Failed parsing \"" ++ name ++ "\"." + NotFoundMsg -> + "The package has a './configure' script. " + ++ "If you are on Windows, This requires a " + ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. " + ++ "If you are not on Windows, ensure that an 'sh' command " + ++ "is discoverable in your path." + UnrecognisedBuildTarget target -> + unlines + [ "Unrecognised build target '" ++ name ++ "'." + | name <- target + ] + ++ "Examples:\n" + ++ " - build foo -- component name " + ++ "(library, executable, test-suite or benchmark)\n" + ++ " - build Data.Foo -- module name\n" + ++ " - build Data/Foo.hsc -- file name\n" + ++ " - build lib:foo exe:foo -- component qualified by kind\n" + ++ " - build foo:Data.Foo -- module qualified by component\n" + ++ " - build foo:Data/Foo.hsc -- file qualified by component" + ReportBuildTargetProblems targets -> + unlines + [ "Unrecognised build target '" + ++ target + ++ "'.\n" + ++ "Expected a " + ++ intercalate " or " expected + ++ ", rather than '" + ++ got + ++ "'." + | (target, expected, got) <- targets + ] + UnknownBuildTarget targets -> + unlines + [ "Unknown build target '" + ++ target + ++ "'.\nThere is no " + ++ intercalate + " or " + [ mungeThing thing ++ " '" ++ got ++ "'" + | (thing, got) <- nosuch + ] + ++ "." + | (target, nosuch) <- targets + ] + where + mungeThing "file" = "file target" + mungeThing thing = thing + AmbiguousBuildTarget targets -> + unlines + [ "Ambiguous build target '" + ++ target + ++ "'. It could be:\n " + ++ unlines + [ " " + ++ ut + ++ " (" + ++ bt + ++ ")" + | (ut, bt) <- amb + ] + | (target, amb) <- targets + ] + CheckBuildTargets errorStr -> errorStr + VersionMismatchGHC ghcProgPath ghcVersion ghcPkgProgPath ghcPkgVersion -> + "Version mismatch between ghc and ghc-pkg: " + ++ ghcProgPath + ++ " is version " + ++ prettyShow ghcVersion + ++ " " + ++ ghcPkgProgPath + ++ " is version " + ++ prettyShow ghcPkgVersion + CheckPackageDbStackPost76 -> + "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" + CantInstallForeignLib -> "Can't install foreign-library symlink on non-Linux OS" + NoSupportForPreProcessingTest tt -> + "No support for preprocessing test " + ++ "suite type " + ++ prettyShow tt + NoSupportForPreProcessingBenchmark tt -> + "No support for preprocessing benchmark " + ++ "type " + ++ prettyShow tt + CantFindSourceForPreProcessFile errorStr -> errorStr + NoSupportPreProcessingTestExtras tt -> + "No support for preprocessing test suite type " + ++ prettyShow tt + NoSupportPreProcessingBenchmarkExtras tt -> + "No support for preprocessing benchmark " + ++ "type " + ++ prettyShow tt + UnlitException str -> str + RunProgramInvocationException path errors -> "'" ++ path ++ "' exited with an error:\n" ++ errors + GetProgramInvocationException path errors -> "'" ++ path ++ "' exited with an error:\n" ++ errors + GetProgramInvocationLBSException path errors -> "'" ++ path ++ "' exited with an error:\n" ++ errors + CheckSemaphoreSupport -> + "Your compiler does not support the -jsem flag. " + ++ "To use this feature you must use GHC 9.8 or later." + NoLibraryForPackage -> + "The buildinfo contains info for a library, " + ++ "but the package does not have a library." + SanityCheckHookedBuildInfo exe1 -> + "The buildinfo contains info for an executable called '" + ++ prettyShow exe1 + ++ "' but the package does not have a " + ++ "executable with that name." + ConfigureScriptNotFound -> "configure script not found." + NoValidComponent -> "No valid component targets found" + ConfigureEitherSingleOrAll -> "Can only configure either single component or all of them" + ConfigCIDValidForPreComponent -> "--cid is only supported for per-component configure" + SanityCheckForEnableComponents -> + "--enable-tests/--enable-benchmarks are incompatible with" + ++ " explicitly specifying a component to configure." + SanityCheckForDynamicStaticLinking -> + "--enable-executable-dynamic and --enable-executable-static" + ++ " are incompatible with each other." + UnsupportedLanguages pkgId compilerId langs -> + "The package " + ++ prettyShow (pkgId) + ++ " requires the following languages which are not " + ++ "supported by " + ++ prettyShow (compilerId) + ++ ": " + ++ intercalate ", " langs + UnsupportedLanguageExtension pkgId compilerId exts -> + "The package " + ++ prettyShow (pkgId) + ++ " requires the following language extensions which are not " + ++ "supported by " + ++ prettyShow (compilerId) + ++ ": " + ++ intercalate ", " exts + CantFindForeignLibraries unsupportedFLibs -> + "Cannot build some foreign libraries: " + ++ intercalate "," unsupportedFLibs + ExpectedAbsoluteDirectory fPath -> "expected an absolute directory name for --prefix: " ++ fPath + FlagsNotSpecified diffFlags -> + "'--exact-configuration' was given, " + ++ "but the following flags were not specified: " + ++ intercalate ", " (map show diffFlags) + EncounteredMissingDependency missing -> + "Encountered missing or private dependencies:\n" + ++ ( render + . nest 4 + . sep + . punctuate comma + . map (pretty . simplifyDependency) + $ missing + ) + CompilerDoesn'tSupportThinning -> + "Your compiler does not support thinning and renaming on " + ++ "package flags. To use this feature you must use " + ++ "GHC 7.9 or later." + CompilerDoesn'tSupportReexports -> + "Your compiler does not support module re-exports. To use " + ++ "this feature you must use GHC 7.9 or later." + CompilerDoesn'tSupportBackpack -> + "Your compiler does not support Backpack. To use " + ++ "this feature you must use GHC 8.1 or later." + LibraryWithinSamePackage internalPkgDeps -> + "The field 'build-depends: " + ++ intercalate ", " (map (prettyShow . packageName) internalPkgDeps) + ++ "' refers to a library which is defined within the same " + ++ "package. To use this feature the package must specify at " + ++ "least 'cabal-version: >= 1.8'." + ReportFailedDependencies failed hackageUrl -> (intercalate "\n\n" (map reportFailedDependency failed)) + where + reportFailedDependency (DependencyNotExists pkgname) = + "there is no version of " + ++ prettyShow pkgname + ++ " installed.\n" + ++ "Perhaps you need to download and install it from\n" + ++ hackageUrl + ++ prettyShow pkgname + ++ "?" + reportFailedDependency (DependencyMissingInternal pkgname lib) = + "internal dependency " + ++ prettyShow (prettyLibraryNameComponent lib) + ++ " not installed.\n" + ++ "Perhaps you need to configure and install it first?\n" + ++ "(This library was defined by " + ++ prettyShow pkgname + ++ ")" + reportFailedDependency (DependencyNoVersion dep) = + "cannot satisfy dependency " ++ prettyShow (simplifyDependency dep) ++ "\n" + NoPackageDatabaseSpecified -> + "No package databases have been specified. If you use " + ++ "--package-db=clear, you must follow it with --package-db= " + ++ "with 'global', 'user' or a specific file." + HowToFindInstalledPackages flv -> + "don't know how to find the installed packages for " + ++ prettyShow flv + PkgConfigNotFound pkg versionReq -> + "The pkg-config package '" + ++ pkg + ++ "'" + ++ versionReq + ++ " is required but it could not be found." + BadVersion pkg versionReq v -> + "The pkg-config package '" + ++ pkg + ++ "'" + ++ versionReq + ++ " is required but the version installed on the" + ++ " system is version " + ++ prettyShow v + UnknownCompilerException -> "Unknown compiler" + NoWorkingGcc -> + unlines + [ "No working gcc" + , "This package depends on foreign library but we cannot " + ++ "find a working C compiler. If you have it in a " + ++ "non-standard location you can use the --with-gcc " + ++ "flag to specify it." + ] + NoOSSupport os -> + "Operating system: " + ++ prettyShow os + ++ ", does not support relocatable builds" + NoCompilerSupport comp -> + "Compiler: " + ++ comp + ++ ", does not support relocatable builds" + InstallDirsNotPrefixRelative installDirs -> "Installation directories are not prefix_relative:\n" ++ show installDirs + ExplainErrors hdr libs -> + unlines $ + [ if plural + then "Missing dependencies on foreign libraries:" + else "Missing dependency on a foreign library:" + | missing + ] + ++ case hdr of + Just (Left h) -> ["* Missing (or bad) header file: " ++ h] + _ -> [] + ++ case libs of + [] -> [] + [lib] -> ["* Missing (or bad) C library: " ++ lib] + _ -> + [ "* Missing (or bad) C libraries: " + ++ intercalate ", " libs + ] + ++ [if plural then messagePlural else messageSingular | missing] + ++ case hdr of + Just (Left _) -> [headerCppMessage] + Just (Right h) -> + [ (if missing then "* " else "") + ++ "Bad header file: " + ++ h + , headerCcMessage + ] + _ -> [] + where + plural = length libs >= 2 + -- Is there something missing? (as opposed to broken) + missing = + not (null libs) + || case hdr of Just (Left _) -> True; _ -> False + messageSingular = + "This problem can usually be solved by installing the system " + ++ "package that provides this library (you may need the " + ++ "\"-dev\" version). If the library is already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where it is." + ++ "If the library file does exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." + messagePlural = + "This problem can usually be solved by installing the system " + ++ "packages that provide these libraries (you may need the " + ++ "\"-dev\" versions). If the libraries are already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where they are." + ++ "If the library files do exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." + headerCppMessage = + "If the header file does exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." + headerCcMessage = + "The header file contains a compile error. " + ++ "You can re-run configure with the verbosity flag " + ++ "-v3 to see the error messages from the C compiler." + CheckPackageProblems errors -> (intercalate "\n\n" $ errors) + LibDirDepsPrefixNotRelative l p -> + "Library directory of a dependency: " + ++ show l + ++ "\nis not relative to the installation prefix:\n" + ++ show p + CombinedConstraints dispDepend -> + render $ + text "The following package dependencies were requested" + $+$ nest 4 dispDepend + $+$ text "however the given installed package instance does not exist." + CantParseGHCOutput -> "Can't parse --info output of GHC" + IncompatibleWithCabal compilerName packagePathEnvVar -> + "Use of " + ++ compilerName + ++ "'s environment variable " + ++ packagePathEnvVar + ++ " is incompatible with Cabal. Use the " + ++ "flag --package-db to specify a package database (it can be " + ++ "used multiple times)." + Couldn'tFindTestProgram cmd -> + "Could not find test program \"" + ++ cmd + ++ "\". Did you build the package first?" + TestCoverageSupport -> "Test coverage is only supported for packages with a library component." + Couldn'tFindTestProgLibV09 cmd -> + "Could not find test program \"" + ++ cmd + ++ "\". Did you build the package first?" + TestCoverageSupportLibV09 -> "Test coverage is only supported for packages with a library component." + RawSystemStdout errors -> errors + FindFileCwd fileName -> fileName ++ " doesn't exist" + FindFileEx fileName -> fileName ++ " doesn't exist" + FindModuleFileEx mod_name extensions searchPath -> + "Could not find module: " + ++ prettyShow mod_name + ++ " with any suffix: " + ++ show (map prettyShow extensions) + ++ " in the search path: " + ++ show searchPath + MultipleFilesWithExtension buildInfoExt -> "Multiple files with extension " ++ buildInfoExt + NoDesc -> + "No cabal file found.\n" + ++ "Please create a package description file .cabal" + MultiDesc l -> + "Multiple cabal files found.\n" + ++ "Please use only one of: " + ++ intercalate ", " l + RelocRegistrationInfo -> + "Distribution.Simple.Register.relocRegistrationInfo: \ + \not implemented for this compiler" + CreatePackageDB -> + "Distribution.Simple.Register.createPackageDB: " + ++ "not implemented for this compiler" + WithHcPkg name -> + "Distribution.Simple.Register." + ++ name + ++ ":\ + \not implemented for this compiler" + RegisMultiplePkgNotSupported -> "Registering multiple package instances is not yet supported for this compiler" + RegisteringNotImplemented -> "Registering is not implemented for this compiler" + NoTestSuitesEnabled -> + "No test suites enabled. Did you remember to configure with " + ++ "\'--enable-tests\'?" + TestNameDisabled tName -> + "Package configured with test suite " + ++ tName + ++ " disabled." + NoSuchTest tName -> "no such test: " ++ tName + ConfigureProgram name path -> + "Cannot find the program '" + ++ name + ++ "'. User-specified path '" + ++ path + ++ "' does not refer to an executable and " + ++ "the program is not on the system path." + RequireProgram progName -> "The program '" ++ progName ++ "' is required but it could not be found." + NoProgramFound progName versionRange -> + "The program '" + ++ progName + ++ "'" + ++ versionRequirement versionRange + ++ " is required but it could not be found." + BadVersionDb progName version range locationPath -> + "The program '" + ++ progName + ++ "'" + ++ versionRequirement range + ++ " is required but the version found at " + ++ locationPath + ++ " is version " + ++ prettyShow version + UnknownVersionDb progName versionRange locationPath -> + "The program '" + ++ progName + ++ "'" + ++ versionRequirement versionRange + ++ " is required but the version of " + ++ locationPath + ++ " could not be determined." + MissingCoveredInstalledLibrary unitId -> + "Failed to find the installed unit '" + ++ prettyShow unitId + ++ "' in package database stack." 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,10 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Flag -- Copyright : Isaac Jones 2003-2004 @@ -16,55 +19,61 @@ -- for an explanation. -- -- Split off from "Distribution.Simple.Setup" to break import cycles. -module Distribution.Simple.Flag ( - Flag(..), - allFlags, - toFlag, - fromFlag, - fromFlagOrDefault, - flagElim, - flagToMaybe, - flagToList, - maybeToFlag, - BooleanFlag(..) ) where +module Distribution.Simple.Flag + ( Flag (..) + , allFlags + , toFlag + , fromFlag + , fromFlagOrDefault + , flagElim + , flagToMaybe + , flagToList + , maybeToFlag + , mergeListFlag + , BooleanFlag (..) + ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) import Distribution.Compat.Stack +import Prelude () -- ------------------------------------------------------------ + -- * Flag type + -- ------------------------------------------------------------ -- | All flags are monoids, they come in two flavours: -- -- 1. list flags eg -- --- > --ghc-option=foo --ghc-option=bar +-- > --ghc-option=foo --ghc-option=bar -- --- gives us all the values ["foo", "bar"] +-- gives us all the values ["foo", "bar"] -- -- 2. singular value flags, eg: -- --- > --enable-foo --disable-foo +-- > --enable-foo --disable-foo -- --- gives us Just False --- So this Flag type is for the latter singular kind of flag. +-- gives us Just False +-- +-- So, this 'Flag' type is for the latter singular kind of flag. -- Its monoid instance gives us the behaviour where it starts out as -- 'NoFlag' and later flags override earlier ones. -- -data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Typeable) +-- Isomorphic to 'Maybe' a. +data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Typeable, 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 + fmap _ NoFlag = NoFlag instance Applicative Flag where (Flag x) <*> y = x <$> y - NoFlag <*> _ = NoFlag + NoFlag <*> _ = NoFlag pure = Flag instance Monoid (Flag a) where @@ -73,7 +82,7 @@ instance Semigroup (Flag a) where _ <> f@(Flag _) = f - f <> NoFlag = f + f <> NoFlag = f instance Bounded a => Bounded (Flag a) where minBound = toFlag minBound @@ -81,52 +90,68 @@ instance Enum a => Enum (Flag a) where fromEnum = fromEnum . fromFlag - toEnum = toFlag . toEnum + toEnum = toFlag . toEnum enumFrom (Flag a) = map toFlag . enumFrom $ a - enumFrom _ = [] + enumFrom _ = [] enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b - enumFromThen _ _ = [] - enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b - enumFromTo _ _ = [] + 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 _ _ _ = [] + enumFromThenTo _ _ _ = [] +-- | Wraps a value in 'Flag'. toFlag :: a -> Flag a toFlag = Flag +-- | Extracts a value from a 'Flag', and throws an exception on 'NoFlag'. fromFlag :: WithCallStack (Flag a -> a) fromFlag (Flag x) = x -fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" +fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" +-- | 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 _ (Flag x) = x +fromFlagOrDefault def NoFlag = def +-- | Converts a 'Flag' value to a 'Maybe' value. flagToMaybe :: Flag a -> Maybe a flagToMaybe (Flag x) = Just x -flagToMaybe NoFlag = Nothing +flagToMaybe NoFlag = Nothing --- | @since 3.4.0.0 +-- | 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 n _ NoFlag = n flagElim _ f (Flag x) = f x +-- | Converts a 'Flag' value to a list. flagToList :: Flag a -> [a] flagToList (Flag x) = [x] -flagToList NoFlag = [] +flagToList NoFlag = [] +-- | Returns 'True' only if every 'Flag' 'Bool' value is Flag True, else 'False'. allFlags :: [Flag Bool] -> Flag Bool -allFlags flags = if all (\f -> fromFlagOrDefault False f) flags - then Flag True - else NoFlag +allFlags flags = + if all (\f -> fromFlagOrDefault False f) flags + then Flag True + else NoFlag +-- | Converts a 'Maybe' value to a 'Flag' value. maybeToFlag :: Maybe a -> Flag a -maybeToFlag Nothing = NoFlag +maybeToFlag Nothing = NoFlag maybeToFlag (Just x) = Flag x +-- | Merge the elements of a list 'Flag' with another list 'Flag'. +mergeListFlag :: Flag [a] -> Flag [a] -> Flag [a] +mergeListFlag currentFlags v = + Flag $ concat (flagToList currentFlags ++ flagToList v) + -- | Types that represent boolean flags. class BooleanFlag a where - asBool :: a -> Bool + asBool :: a -> Bool instance BooleanFlag Bool where asBool = id 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,2185 +1,1014 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.GHC --- Copyright : Isaac Jones 2003-2007 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is a fairly large module. It contains most of the GHC-specific code for --- configuring, building and installing packages. It also exports a function --- for finding out what packages are already installed. Configuring involves --- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions --- this version of ghc supports and returning a 'Compiler' value. --- --- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out --- what packages are installed. --- --- Building is somewhat complex as there is quite a bit of information to take --- into account. We have to build libs and programs, possibly for profiling and --- shared libs. We have to support building libraries that will be usable by --- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files --- using ghc. Linking, especially for @split-objs@ is remarkably complex, --- partly because there tend to be 1,000's of @.o@ files and this can often be --- more than we can pass to the @ld@ or @ar@ programs in one go. --- --- Installing for libs and exes involves finding the right files and copying --- them to the right places. One of the more tricky things about this module is --- remembering the layout of files in the build directory (which is not --- explicitly documented) and thus what search dirs are used for various kinds --- of files. - -module Distribution.Simple.GHC ( - getGhcInfo, - configure, - getInstalledPackages, - getInstalledPackagesMonitorFiles, - getPackageDBContents, - buildLib, buildFLib, buildExe, - replLib, replFLib, replExe, - startInterpreter, - installLib, installFLib, installExe, - libAbiHash, - hcPkgInfo, - registerPackage, - componentGhcOptions, - componentCcGhcOptions, - getGhcAppDir, - getLibDir, - isDynamic, - getGlobalPackageDB, - pkgRoot, - -- * Constructing and deconstructing GHC environment files - Internal.GhcEnvironmentFileEntry(..), - Internal.simpleGhcEnvironmentFile, - Internal.renderGhcEnvironmentFile, - Internal.writeGhcEnvironmentFile, - Internal.ghcPlatformAndVersionString, - readGhcEnvironmentFile, - parseGhcEnvironmentFile, - ParseErrorExc(..), - -- * Version-specific implementation quirks - getImplInfo, - GhcImplInfo(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Distribution.Simple.GHC.Internal as Internal -import Distribution.CabalSpecVersion -import Distribution.Simple.GHC.ImplInfo -import Distribution.Simple.GHC.EnvironmentParser -import Distribution.PackageDescription.Utils (cabalBug) -import Distribution.PackageDescription as PD -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.ComponentLocalBuildInfo -import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName -import Distribution.ModuleName (ModuleName) -import Distribution.Simple.Program -import Distribution.Simple.Program.Builtin (runghcProgram) -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import qualified Distribution.Simple.Program.Ar as Ar -import qualified Distribution.Simple.Program.Ld as Ld -import qualified Distribution.Simple.Program.Strip as Strip -import Distribution.Simple.Program.GHC -import Distribution.Simple.Setup -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Compiler -import Distribution.Version -import Distribution.System -import Distribution.Types.PackageName.Magic -import Distribution.Verbosity -import Distribution.Pretty -import Distribution.Utils.NubList -import Distribution.Utils.Path -import Language.Haskell.Extension - -import Control.Monad (msum, forM_) -import Data.Char (isLower) -import qualified Data.Map as Map -import System.Directory - ( doesFileExist, doesDirectoryExist - , getAppUserDataDirectory, createDirectoryIfMissing - , canonicalizePath, removeFile, renameFile, getDirectoryContents - , makeRelativeToCurrentDirectory ) -import System.FilePath ( (), (<.>), takeExtension - , takeDirectory, replaceExtension - ,isRelative ) -import qualified System.Info -#ifndef mingw32_HOST_OS -import System.Posix (createSymbolicLink) -#endif /* mingw32_HOST_OS */ - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb - -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity hcPath hcPkgPath 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.10 - -- ... and the following odd development version - unless (ghcVersion < mkVersion [9,10]) $ - warn verbosity $ - "Unknown/unsupported 'ghc' version detected " - ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 9.10): " - ++ 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) $ die' verbosity $ - "Version mismatch between ghc and ghc-pkg: " - ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion ++ " " - ++ programPath ghcPkgProg ++ " is version " ++ prettyShow 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 - - 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 - - -- starting with GHC 8.0, `TemplateHaskell` will be omitted from - -- `--supported-extensions` when it's not available. - -- for older GHCs we can use the "Have interpreter" property to - -- filter out `TemplateHaskell` - filterExtTH | ghcVersion < mkVersion [8] - , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap - = filterExt TemplateHaskell - | otherwise = id - - filterExt ext = filter ((/= EnableExtension ext) . fst) - - let comp = Compiler { - compilerId = CompilerId GHC ghcVersion, - compilerAbiTag = NoAbiTag, - compilerCompat = [], - compilerLanguages = languages, - compilerExtensions = extensions, - compilerProperties = ghcInfoMap - } - compPlatform = Internal.targetPlatform ghcInfo - -- configure gcc and ld - progdb4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap progdb3 - return (comp, compPlatform, 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: --- --- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) --- > /usr/local/bin/ghc-pkg-6.6.1(.exe) --- > /usr/local/bin/ghc-pkg(.exe) --- -guessToolFromGhcPath :: Program -> ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessToolFromGhcPath tool ghcProg verbosity searchpath - = do let toolname = programName tool - given_path = programPath ghcProg - given_dir = takeDirectory given_path - real_path <- canonicalizePath given_path - let real_dir = takeDirectory real_path - versionSuffix path = takeVersionSuffix (dropExeExtension path) - given_suf = versionSuffix given_path - real_suf = versionSuffix real_path - guessNormal dir = dir toolname <.> exeExtension buildPlatform - guessGhcVersioned dir suf = dir (toolname ++ "-ghc" ++ suf) - <.> exeExtension buildPlatform - guessVersioned dir suf = dir (toolname ++ suf) - <.> exeExtension buildPlatform - mkGuesses dir suf | null suf = [guessNormal dir] - | otherwise = [guessGhcVersioned dir suf, - guessVersioned dir suf, - guessNormal dir] - -- order matters here, see https://github.com/haskell/cabal/issues/7390 - guesses = (if real_path == given_path - then [] - else mkGuesses real_dir real_suf) - ++ mkGuesses given_dir given_suf - info verbosity $ "looking for tool " ++ toolname - ++ " near compiler in " ++ given_dir - debug verbosity $ "candidate locations: " ++ show guesses - exists <- traverse doesFileExist guesses - case [ file | (file, True) <- zip guesses exists ] of - -- If we can't find it near ghc, fall back to the usual - -- method. - [] -> programFindLocation tool verbosity searchpath - (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp - let lookedAt = map fst - . takeWhile (\(_file, exist) -> not exist) - $ zip guesses exists - return (Just (fp, lookedAt)) - - where takeVersionSuffix :: FilePath -> String - takeVersionSuffix = takeWhileEndLE isSuffixChar - - isSuffixChar :: Char -> Bool - isSuffixChar c = isDigit c || c == '.' || c == '-' - --- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a --- corresponding ghc-pkg, we try looking for both a versioned and unversioned --- ghc-pkg in the same dir, that is: --- --- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) --- > /usr/local/bin/ghc-pkg-6.6.1(.exe) --- > /usr/local/bin/ghc-pkg(.exe) --- -guessGhcPkgFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram - --- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a --- corresponding hsc2hs, we try looking for both a versioned and unversioned --- hsc2hs in the same dir, that is: --- --- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe) --- > /usr/local/bin/hsc2hs-6.6.1(.exe) --- > /usr/local/bin/hsc2hs(.exe) --- -guessHsc2hsFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram - --- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a --- corresponding haddock, we try looking for both a versioned and unversioned --- haddock in the same dir, that is: --- --- > /usr/local/bin/haddock-ghc-6.6.1(.exe) --- > /usr/local/bin/haddock-6.6.1(.exe) --- > /usr/local/bin/haddock(.exe) --- -guessHaddockFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram - -guessHpcFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHpcFromGhcPath = guessToolFromGhcPath hpcProgram - -guessRunghcFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessRunghcFromGhcPath = guessToolFromGhcPath runghcProgram - - -getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] -getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg - where - version = fromMaybe (error "GHC.getGhcInfo: no ghc version") $ programVersion ghcProg - implInfo = ghcVersionImplInfo version - --- | Given a single package DB, return all installed packages. -getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb - -> IO InstalledPackageIndex -getPackageDBContents verbosity packagedb progdb = do - pkgss <- getInstalledPackages' verbosity [packagedb] progdb - toPackageIndex verbosity pkgss progdb - --- | Given a package DB stack, return all installed packages. -getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack - -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity comp packagedbs progdb = do - checkPackageDbEnvVar verbosity - checkPackageDbStack verbosity comp packagedbs - pkgss <- getInstalledPackages' verbosity packagedbs progdb - index <- toPackageIndex verbosity pkgss progdb - return $! hackRtsPackage index - - where - hackRtsPackage index = - case PackageIndex.lookupPackageName index (mkPackageName "rts") of - [(_,[rts])] - -> PackageIndex.insert (removeMingwIncludeDir rts) index - _ -> index -- No (or multiple) ghc rts package is registered!! - -- Feh, whatever, the ghc test suite does some crazy stuff. - --- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a --- @PackageIndex@. Helper function used by 'getPackageDBContents' and --- 'getInstalledPackages'. -toPackageIndex :: Verbosity - -> [(PackageDB, [InstalledPackageInfo])] - -> ProgramDb - -> IO InstalledPackageIndex -toPackageIndex verbosity pkgss progdb = do - -- On Windows, various fields have $topdir/foo rather than full - -- paths. We need to substitute the right value in so that when - -- we, for example, call gcc, we have proper paths to give it. - topDir <- getLibDir' verbosity ghcProg - let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) - | (_, pkgs) <- pkgss ] - return $! mconcat indices - - where - ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb - --- | Return the 'FilePath' to the GHC application data directory. --- --- @since 3.4.0.0 -getGhcAppDir :: IO FilePath -getGhcAppDir = getAppUserDataDirectory "ghc" - -getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath -getLibDir verbosity lbi = - dropWhileEndLE isSpace `fmap` - getDbProgramOutput verbosity ghcProgram - (withPrograms lbi) ["--print-libdir"] - -getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath -getLibDir' verbosity ghcProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcProg ["--print-libdir"] - - --- | Return the 'FilePath' to the global GHC package database. -getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath -getGlobalPackageDB verbosity ghcProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcProg ["--print-global-package-db"] - --- | Return the 'FilePath' to the per-user GHC package database. -getUserPackageDB - :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath -getUserPackageDB _verbosity ghcProg platform = do - -- It's rather annoying that we have to reconstruct this, because ghc - -- hides this information from us otherwise. But for certain use cases - -- like change monitoring it really can't remain hidden. - appdir <- getGhcAppDir - return (appdir platformAndVersion packageConfFileName) - where - platformAndVersion = Internal.ghcPlatformAndVersionString - platform ghcVersion - packageConfFileName = "package.conf.d" - ghcVersion = fromMaybe (error "GHC.getUserPackageDB: no ghc version") $ programVersion ghcProg - -checkPackageDbEnvVar :: Verbosity -> IO () -checkPackageDbEnvVar verbosity = - Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH" - -checkPackageDbStack :: Verbosity -> Compiler -> PackageDBStack -> IO () -checkPackageDbStack verbosity comp = - if flagPackageConf implInfo - then checkPackageDbStackPre76 verbosity - else checkPackageDbStackPost76 verbosity - where implInfo = ghcVersionImplInfo (compilerVersion comp) - -checkPackageDbStackPost76 :: Verbosity -> PackageDBStack -> IO () -checkPackageDbStackPost76 _ (GlobalPackageDB:rest) - | GlobalPackageDB `notElem` rest = return () -checkPackageDbStackPost76 verbosity rest - | GlobalPackageDB `elem` rest = - die' verbosity $ "If the global package db is specified, it must be " - ++ "specified first and cannot be specified multiple times" -checkPackageDbStackPost76 _ _ = return () - -checkPackageDbStackPre76 :: Verbosity -> PackageDBStack -> IO () -checkPackageDbStackPre76 _ (GlobalPackageDB:rest) - | GlobalPackageDB `notElem` rest = return () -checkPackageDbStackPre76 verbosity rest - | GlobalPackageDB `notElem` rest = - die' verbosity $ - "With current ghc versions the global package db is always used " - ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6," - ++ "see https://gitlab.haskell.org/ghc/ghc/-/issues/5977" -checkPackageDbStackPre76 verbosity _ = - die' verbosity $ "If the global package db is specified, it must be " - ++ "specified first and cannot be specified multiple times" - --- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This --- 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' } - --- | Get the packages from specific PackageDBs, not cumulative. --- -getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb - -> IO [(PackageDB, [InstalledPackageInfo])] -getInstalledPackages' verbosity packagedbs progdb = - sequenceA - [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb - return (packagedb, pkgs) - | packagedb <- packagedbs ] - -getInstalledPackagesMonitorFiles :: Verbosity -> Platform - -> ProgramDb - -> [PackageDB] - -> IO [FilePath] -getInstalledPackagesMonitorFiles verbosity platform progdb = - traverse getPackageDBPath - where - getPackageDBPath :: PackageDB -> IO FilePath - getPackageDBPath GlobalPackageDB = - selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg - - getPackageDBPath UserPackageDB = - selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform - - getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path - - -- GHC has old style file dbs, and new style directory dbs. - -- Note that for dir style dbs, we only need to monitor the cache file, not - -- the whole directory. The ghc program itself only reads the cache file - -- so it's safe to only monitor this one file. - selectMonitorFile path = do - isFileStyle <- doesFileExist path - if isFileStyle then return path - else return (path "package.cache") - - ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb - - --- ----------------------------------------------------------------------------- --- Building a library - -buildLib :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib = buildOrReplLib Nothing - -replLib :: ReplOptions -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () -replLib = buildOrReplLib . Just - -buildOrReplLib :: Maybe ReplOptions -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () -buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do - let uid = componentUnitId clbi - libTargetDir = componentBuildDir lbi clbi - whenVanillaLib forceVanilla = - when (forceVanilla || withVanillaLib lbi) - whenProfLib = when (withProfLib lbi) - whenSharedLib forceShared = - when (forceShared || withSharedLib lbi) - whenStaticLib forceStatic = - when (forceStatic || withStaticLib lbi) - whenGHCiLib = when (withGHCiLib lbi) - forRepl = maybe False (const True) mReplFlags - whenReplLib = when forRepl - replFlags = fromMaybe mempty mReplFlags - comp = compiler lbi - ghcVersion = compilerVersion comp - implInfo = getImplInfo comp - platform@(Platform hostArch hostOS) = hostPlatform lbi - hasJsSupport = hostArch == JavaScript - has_code = not (componentIsIndefinite clbi) - - relLibTargetDir <- makeRelativeToCurrentDirectory libTargetDir - - (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - let runGhcProg = runGHC verbosity ghcProg comp platform - - let libBi = libBuildInfo lib - - -- ensure extra lib dirs exist before passing to ghc - cleanedExtraLibDirs <- filterM doesDirectoryExist (extraLibDirs libBi) - cleanedExtraLibDirsStatic <- filterM doesDirectoryExist (extraLibDirsStatic libBi) - - - let isGhcDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - doingTH = usesTemplateHaskellOrQQ libBi - forceVanillaLib = doingTH && not isGhcDynamic - forceSharedLib = doingTH && isGhcDynamic - -- TH always needs default libs, even when building for profiling - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = libCoverage lbi - -- TODO: Historically HPC files have been put into a directory which - -- has the package name. I'm going to avoid changing this for - -- now, but it would probably be better for this to be the - -- component ID instead... - pkg_name = prettyShow (PD.package pkg_descr) - distPref = fromFlag $ configDistPref $ configFlags lbi - hpcdir way - | forRepl = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name - | otherwise = mempty - - createDirectoryIfMissingVerbose verbosity True libTargetDir - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? - let cLikeSources = fromNubListR $ mconcat - [ toNubListR (cSources libBi) - , toNubListR (cxxSources libBi) - , toNubListR (cmmSources libBi) - , toNubListR (asmSources libBi) - , if hasJsSupport - -- JS files are C-like with GHC's JS backend: they are - -- "compiled" into `.o` files (renamed with a header). - -- This is a difference from GHCJS, for which we only - -- pass the JS files at link time. - then toNubListR (jsSources libBi) - else mempty - ] - cLikeObjs = map (`replaceExtension` objExtension) cLikeSources - baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir - vanillaOpts = baseOpts `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptNumJobs = numJobs, - ghcOptInputModules = toNubListR $ allLibModules lib clbi, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - - profOpts = vanillaOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Prof - } - - sharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = PD.ldOptions libBi - ++ [ "-static" - | withFullyStaticExe lbi ] - -- Pass extra `ld-options` given - -- through to GHC's linker. - ++ maybe [] programOverrideArgs - (lookupProgram ldProgram (withPrograms lbi)), - ghcOptLinkLibs = if withFullyStaticExe lbi - then extraLibsStatic libBi - else extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ - if withFullyStaticExe lbi - then cleanedExtraLibDirsStatic - else cleanedExtraLibDirs, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = toNubListR $ - PD.extraFrameworkDirs libBi, - ghcOptInputFiles = toNubListR - [relLibTargetDir x | x <- cLikeObjs] - } - replOpts = vanillaOpts { - ghcOptExtra = Internal.filterGhciFlags - (ghcOptExtra vanillaOpts) - <> replOptionsFlags replFlags, - ghcOptNumJobs = mempty, - ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules vanillaOpts) - } - `mappend` linkerOpts - `mappend` mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptOptimisation = toFlag GhcNoOptimisation - } - - vanillaSharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "dyn_hi", - ghcOptDynObjSuffix = toFlag "dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - - unless (forRepl || null (allLibModules lib clbi)) $ - do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts) - shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts) - useDynToo = dynamicTooSupported && - (forceVanillaLib || withVanillaLib lbi) && - (forceSharedLib || withSharedLib lbi) && - null (hcSharedOptions GHC libBi) - if not has_code - then vanilla - else - if useDynToo - then do - runGhcProg vanillaSharedOpts - case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of - (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> - -- When the vanilla and shared library builds are done - -- in one pass, only one set of HPC module interfaces - -- are generated. This set should suffice for both - -- static and dynamically linked executables. We copy - -- the modules interfaces so they are available under - -- both ways. - copyDirectoryRecursive verbosity dynDir vanillaDir - _ -> return () - else if isGhcDynamic - then do shared; vanilla - else do vanilla; shared - whenProfLib (runGhcProg profOpts) - - -- Build any C++ sources separately. - unless (not has_code || null (cxxSources libBi)) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi libBi clbi relLibTargetDir filename - vanillaCxxOpts = if isGhcDynamic - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCxxOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded cxxOpts = do - needsRecomp <- checkNeedsRecompilation filename cxxOpts - when needsRecomp $ runGhcProg cxxOpts - runGhcProgIfNeeded vanillaCxxOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) - | filename <- cxxSources libBi] - - -- build any C sources - let libraryName = case libName lib of - LMainLibName -> "the main library" - LSubLibName name -> "library " <> prettyShow name - cSrcs' <- checkCSources verbosity libraryName (cSources libBi) - unless (not has_code || null cSrcs') $ do - info verbosity "Building C Sources..." - forM_ cSrcs' $ \filename -> do - let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi libBi clbi relLibTargetDir filename - vanillaCcOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCcOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded ccOpts = do - needsRecomp <- checkNeedsRecompilation filename ccOpts - when needsRecomp $ runGhcProg ccOpts - runGhcProgIfNeeded vanillaCcOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) - - -- build any JS sources - unless (not has_code || not hasJsSupport || null (jsSources libBi)) $ do - info verbosity "Building JS Sources..." - sequence_ - [ do let vanillaJsOpts = Internal.componentJsGhcOptions verbosity implInfo - lbi libBi clbi relLibTargetDir filename - profJsOpts = vanillaJsOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - odir = fromFlag (ghcOptObjDir vanillaJsOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded jsOpts = do - needsRecomp <- checkNeedsRecompilation filename jsOpts - when needsRecomp $ runGhcProg jsOpts - runGhcProgIfNeeded vanillaJsOpts - unless forRepl $ whenProfLib (runGhcProgIfNeeded profJsOpts) - | filename <- jsSources libBi] - - -- build any ASM sources - unless (not has_code || null (asmSources libBi)) $ do - info verbosity "Building Assembler Sources..." - sequence_ - [ do let baseAsmOpts = Internal.componentAsmGhcOptions verbosity implInfo - lbi libBi clbi relLibTargetDir filename - vanillaAsmOpts = if isGhcDynamic - -- Dynamic GHC requires objects to be built - -- with -fPIC for REPL to work. See #2207. - then baseAsmOpts { ghcOptFPic = toFlag True } - else baseAsmOpts - profAsmOpts = vanillaAsmOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedAsmOpts = vanillaAsmOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaAsmOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded asmOpts = do - needsRecomp <- checkNeedsRecompilation filename asmOpts - when needsRecomp $ runGhcProg asmOpts - runGhcProgIfNeeded vanillaAsmOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedAsmOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profAsmOpts) - | filename <- asmSources libBi] - - -- build any Cmm sources - unless (not has_code || null (cmmSources libBi)) $ do - info verbosity "Building C-- Sources..." - sequence_ - [ do let baseCmmOpts = Internal.componentCmmGhcOptions verbosity implInfo - lbi libBi clbi relLibTargetDir filename - vanillaCmmOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCmmOpts { ghcOptFPic = toFlag True } - else baseCmmOpts - profCmmOpts = vanillaCmmOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCmmOpts = vanillaCmmOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCmmOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded cmmOpts = do - needsRecomp <- checkNeedsRecompilation filename cmmOpts - when needsRecomp $ runGhcProg cmmOpts - runGhcProgIfNeeded vanillaCmmOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCmmOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCmmOpts) - | filename <- cmmSources libBi] - - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - whenReplLib $ do - when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" - runGhcProg replOpts - - -- link: - when has_code . unless forRepl $ do - info verbosity "Linking..." - let cLikeProfObjs = map (`replaceExtension` ("p_" ++ objExtension)) - cLikeSources - cLikeSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) - cLikeSources - compiler_id = compilerId (compiler lbi) - vanillaLibFilePath = relLibTargetDir mkLibName uid - profileLibFilePath = relLibTargetDir mkProfLibName uid - sharedLibFilePath = relLibTargetDir - mkSharedLibName (hostPlatform lbi) compiler_id uid - staticLibFilePath = relLibTargetDir - mkStaticLibName (hostPlatform lbi) compiler_id uid - ghciLibFilePath = relLibTargetDir Internal.mkGHCiLibName uid - ghciProfLibFilePath = relLibTargetDir Internal.mkGHCiProfLibName uid - libInstallPath = libdir $ - absoluteComponentInstallDirs - pkg_descr lbi uid NoCopyDest - sharedLibInstallPath = libInstallPath - mkSharedLibName (hostPlatform lbi) compiler_id uid - - 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 lib lbi clbi - relLibTargetDir objExtension True - hProfObjs <- - if withProfLib lbi - then Internal.getHaskellObjects implInfo lib lbi clbi - relLibTargetDir ("p_" ++ objExtension) True - else return [] - hSharedObjs <- - if withSharedLib lbi - then Internal.getHaskellObjects implInfo lib lbi clbi - relLibTargetDir ("dyn_" ++ objExtension) False - else return [] - - unless (null hObjs && null cLikeObjs && null stubObjs) $ do - rpaths <- getRPaths lbi clbi - - let staticObjectFiles = - hObjs - ++ map (relLibTargetDir ) cLikeObjs - ++ stubObjs - profObjectFiles = - hProfObjs - ++ map (relLibTargetDir ) cLikeProfObjs - ++ stubProfObjs - dynamicObjectFiles = - hSharedObjs - ++ map (relLibTargetDir ) cLikeSharedObjs - ++ stubSharedObjs - -- After the relocation lib is created we invoke ghc -shared - -- with the dependencies spelled out as -package arguments - -- and ghc invokes the linker with the proper library paths - ghcSharedLinkArgs = - mempty { - ghcOptShared = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptInputFiles = toNubListR dynamicObjectFiles, - ghcOptOutputFile = toFlag sharedLibFilePath, - ghcOptExtra = 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, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = - toNubListR $ PD.extraFrameworkDirs libBi, - ghcOptRPaths = rpaths <> toNubListR (extraLibDirs libBi) - } - ghcStaticLinkArgs = - mempty { - ghcOptStaticLib = toFlag True, - ghcOptInputFiles = toNubListR staticObjectFiles, - ghcOptOutputFile = toFlag staticLibFilePath, - 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 clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs - } - - info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) - - whenVanillaLib False $ do - Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciLibFilePath staticObjectFiles - - whenProfLib $ do - Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciProfLibFilePath profObjectFiles - - whenSharedLib False $ - runGhcProg ghcSharedLinkArgs - - whenStaticLib False $ - runGhcProg ghcStaticLinkArgs - --- | Start a REPL without loading any source files. -startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform - -> PackageDBStack -> IO () -startInterpreter verbosity progdb comp platform packageDBs = do - let replOpts = mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptPackageDBs = packageDBs - } - checkPackageDbStack verbosity comp packageDBs - (ghcProg, _) <- requireProgram verbosity ghcProgram progdb - runGHC verbosity ghcProg comp platform replOpts - --- ----------------------------------------------------------------------------- --- Building an executable or foreign library - --- | Build a foreign library -buildFLib - :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> ForeignLib -> ComponentLocalBuildInfo -> IO () -buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib - -replFLib - :: ReplOptions -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> ForeignLib - -> ComponentLocalBuildInfo -> IO () -replFLib replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplFLib replFlags - --- | Build an executable with GHC. --- -buildExe - :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe - -replExe - :: ReplOptions -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Executable - -> ComponentLocalBuildInfo -> IO () -replExe replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplExe replFlags - --- | Building an executable, starting the REPL, and building foreign --- libraries are all very similar and implemented in 'gbuild'. The --- 'GBuildMode' distinguishes between the various kinds of operation. -data GBuildMode = - GBuildExe Executable - | GReplExe ReplOptions Executable - | GBuildFLib ForeignLib - | GReplFLib ReplOptions ForeignLib - -gbuildInfo :: GBuildMode -> BuildInfo -gbuildInfo (GBuildExe exe) = buildInfo exe -gbuildInfo (GReplExe _ exe) = buildInfo exe -gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib -gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib - -gbuildName :: GBuildMode -> String -gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe -gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe -gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib -gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib - -gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String -gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib -gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib - -exeTargetName :: Platform -> Executable -> String -exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform - --- | Target name for a foreign library (the actual file name) --- --- We do not use mkLibName and co here because the naming for foreign libraries --- is slightly different (we don't use "_p" or compiler version suffices, and we --- don't want the "lib" prefix on Windows). --- --- TODO: We do use `dllExtension` and co here, but really that's wrong: they --- use the OS used to build cabal to determine which extension to use, rather --- than the target OS (but this is wrong elsewhere in Cabal as well). -flibTargetName :: LocalBuildInfo -> ForeignLib -> String -flibTargetName lbi flib = - case (os, foreignLibType flib) of - (Windows, ForeignLibNativeShared) -> nm <.> "dll" - (Windows, ForeignLibNativeStatic) -> nm <.> "lib" - (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt - (_other, ForeignLibNativeShared) -> - "lib" ++ nm <.> dllExtension (hostPlatform lbi) - (_other, ForeignLibNativeStatic) -> - "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) - (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" - where - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - - os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' - - -- If a foreign lib foo has lib-version-info 5:1:2 or - -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 - -- Libtool's version-info data is translated into library versions in a - -- nontrivial way: so refer to libtool documentation. - versionedExt :: String - versionedExt = - let nums = foreignLibVersion flib os - in foldl (<.>) "so" (map show nums) - --- | Name for the library when building. --- --- If the `lib-version-info` field or the `lib-version-linux` field of --- a foreign library target is set, we need to incorporate that --- version into the SONAME field. --- --- If a foreign library foo has lib-version-info 5:1:2, it should be --- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. --- However, GHC does not allow overriding soname by setting linker --- options, as it sets a soname of its own (namely the output --- filename), after the user-supplied linker options. Hence, we have --- to compile the library with the soname as its filename. We rename --- the compiled binary afterwards. --- --- This method allows to adjust the name of the library at build time --- such that the correct soname can be set. -flibBuildName :: LocalBuildInfo -> ForeignLib -> String -flibBuildName lbi flib - -- On linux, if a foreign-library has version data, the first digit is used - -- to produce the SONAME. - | (os, foreignLibType flib) == - (Linux, ForeignLibNativeShared) - = let nums = foreignLibVersion flib os - in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) - | otherwise = flibTargetName lbi flib - where - os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' - - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - -gbuildIsRepl :: GBuildMode -> Bool -gbuildIsRepl (GBuildExe _) = False -gbuildIsRepl (GReplExe _ _) = True -gbuildIsRepl (GBuildFLib _) = False -gbuildIsRepl (GReplFLib _ _) = True - -gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool -gbuildNeedDynamic lbi bm = - case bm of - GBuildExe _ -> withDynExe lbi - GReplExe _ _ -> withDynExe lbi - GBuildFLib flib -> withDynFLib flib - GReplFLib _ flib -> withDynFLib flib - where - withDynFLib flib = - case foreignLibType flib of - ForeignLibNativeShared -> - ForeignLibStandalone `notElem` foreignLibOptions flib - ForeignLibNativeStatic -> - False - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -gbuildModDefFiles :: GBuildMode -> [FilePath] -gbuildModDefFiles (GBuildExe _) = [] -gbuildModDefFiles (GReplExe _ _) = [] -gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib -gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib - --- | "Main" module name when overridden by @ghc-options: -main-is ...@ --- or 'Nothing' if no @-main-is@ flag could be found. --- --- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. -exeMainModuleName :: Executable -> Maybe ModuleName -exeMainModuleName Executable{buildInfo = bnfo} = - -- GHC honors the last occurrence of a module name updated via -main-is - -- - -- Moreover, -main-is when parsed left-to-right can update either - -- the "Main" module name, or the "main" function name, or both, - -- see also 'decodeMainIsArg'. - msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts - where - ghcopts = hcOptions GHC bnfo - - findIsMainArgs [] = [] - findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest - findIsMainArgs (_:rest) = findIsMainArgs rest - --- | Decode argument to '-main-is' --- --- Returns 'Nothing' if argument set only the function name. --- --- This code has been stolen/refactored from GHC's DynFlags.setMainIs --- function. The logic here is deliberately imperfect as it is --- intended to be bug-compatible with GHC's parser. See discussion in --- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. -decodeMainIsArg :: String -> Maybe ModuleName -decodeMainIsArg arg - | headOf main_fn isLower - -- The arg looked like "Foo.Bar.baz" - = Just (ModuleName.fromString main_mod) - | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" - = Just (ModuleName.fromString arg) - | otherwise -- The arg looked like "baz" - = Nothing - where - headOf :: String -> (Char -> Bool) -> Bool - headOf str pred' = any pred' (safeHead str) - - (main_mod, main_fn) = splitLongestPrefix arg (== '.') - - splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) - splitLongestPrefix str pred' - | null r_pre = (str, []) - | otherwise = (reverse (safeTail r_pre), reverse r_suf) - -- 'safeTail' drops the char satisfying 'pred' - where (r_suf, r_pre) = break pred' (reverse str) - --- | A collection of: --- * C input files --- * C++ input files --- * GHC input files --- * GHC input modules --- --- Used to correctly build and link sources. -data BuildSources = BuildSources { - cSourcesFiles :: [FilePath], - cxxSourceFiles :: [FilePath], - inputSourceFiles :: [FilePath], - inputSourceModules :: [ModuleName] - } - --- | Locate and return the 'BuildSources' required to build and link. -gbuildSources :: Verbosity - -> PackageId - -> CabalSpecVersion - -> FilePath - -> GBuildMode - -> IO BuildSources -gbuildSources verbosity pkgId specVer tmpDir bm = - case bm of - GBuildExe exe -> exeSources exe - GReplExe _ exe -> exeSources exe - GBuildFLib flib -> return $ flibSources flib - GReplFLib _ flib -> return $ flibSources flib - where - exeSources :: Executable -> IO BuildSources - exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do - main <- findFileEx verbosity (tmpDir : map getSymbolicPath (hsSourceDirs bnfo)) modPath - let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe - otherModNames = exeModules exe - - -- Scripts have fakePackageId and are always Haskell but can have any extension. - if isHaskell main || pkgId == fakePackageId - then - if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) - then do - -- The cabal manual clearly states that `other-modules` is - -- intended for non-main modules. However, there's at least one - -- important package on Hackage (happy-1.19.5) which - -- violates this. We workaround this here so that we don't - -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which - -- would result in GHC complaining about duplicate Main - -- modules. - -- - -- Finally, we only enable this workaround for - -- specVersion < 2, as 'cabal-version:>=2.0' cabal files - -- have no excuse anymore to keep doing it wrong... ;-) - warn verbosity $ "Enabling workaround for Main module '" - ++ prettyShow mainModName - ++ "' listed in 'other-modules' illegally!" - - return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = filter (/= mainModName) $ - exeModules exe - } - - else return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = exeModules exe - } - else let (csf, cxxsf) - | isCxx main = ( cSources bnfo, main : cxxSources bnfo) - -- if main is not a Haskell source - -- and main is not a C++ source - -- then we assume that it is a C source - | otherwise = (main : cSources bnfo, cxxSources bnfo) - - in return BuildSources { - cSourcesFiles = csf, - cxxSourceFiles = cxxsf, - inputSourceFiles = [], - inputSourceModules = exeModules exe - } - - flibSources :: ForeignLib -> BuildSources - flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = - BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [], - 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"] - -replNoLoad :: Ord a => ReplOptions -> NubListR a -> NubListR a -replNoLoad replFlags l - | replOptionsNoLoad replFlags == Flag True = mempty - | otherwise = l - --- | Generic build function. See comment for 'GBuildMode'. -gbuild :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> GBuildMode -> ComponentLocalBuildInfo -> IO () -gbuild verbosity numJobs pkg_descr lbi bm clbi = do - (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - let replFlags = case bm of - GReplExe flags _ -> flags - GReplFLib flags _ -> flags - GBuildExe{} -> mempty - GBuildFLib{} -> mempty - comp = compiler lbi - platform = hostPlatform lbi - implInfo = getImplInfo comp - runGhcProg = runGHC verbosity ghcProg comp platform - - let bnfo = gbuildInfo bm - - -- the name that GHC really uses (e.g., with .exe on Windows for executables) - let targetName = gbuildTargetName lbi bm - let targetDir = buildDir lbi (gbuildName bm) - let tmpDir = targetDir (gbuildName bm ++ "-tmp") - createDirectoryIfMissingVerbose verbosity True targetDir - createDirectoryIfMissingVerbose verbosity True tmpDir - - -- 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 = exeCoverage lbi - distPref = fromFlag $ configDistPref $ configFlags lbi - hpcdir way - | gbuildIsRepl bm = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm) - | otherwise = mempty - - rpaths <- getRPaths lbi clbi - buildSources <- gbuildSources verbosity (package pkg_descr) (specVersion pkg_descr) tmpDir bm - - -- ensure extra lib dirs exist before passing to ghc - cleanedExtraLibDirs <- filterM doesDirectoryExist (extraLibDirs bnfo) - cleanedExtraLibDirsStatic <- filterM doesDirectoryExist (extraLibDirsStatic bnfo) - - - let cSrcs = cSourcesFiles buildSources - cxxSrcs = cxxSourceFiles buildSources - inputFiles = inputSourceFiles buildSources - inputModules = inputSourceModules buildSources - isGhcDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - cLikeObjs = map (`replaceExtension` objExtension) cSrcs - cxxObjs = map (`replaceExtension` objExtension) cxxSrcs - needDynamic = gbuildNeedDynamic lbi bm - needProfiling = withProfExe lbi - - -- build executables - baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir) - `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptInputFiles = toNubListR $ if package pkg_descr == fakePackageId - then filter isHaskell inputFiles - else inputFiles, - ghcOptInputScripts = toNubListR $ if package pkg_descr == fakePackageId - then filter (not . isHaskell) inputFiles - else [], - ghcOptInputModules = toNubListR inputModules - } - staticOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticOnly, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - profOpts = baseOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag False - (withProfExeDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Prof - } - dynOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - -- TODO: Does it hurt to set -fPIC for executables? - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - dynTooOpts = staticOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "dyn_hi", - ghcOptDynObjSuffix = toFlag "dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = PD.ldOptions bnfo - ++ [ "-static" - | withFullyStaticExe lbi ] - -- Pass extra `ld-options` given - -- through to GHC's linker. - ++ maybe [] programOverrideArgs - (lookupProgram ldProgram (withPrograms lbi)), - ghcOptLinkLibs = if withFullyStaticExe lbi - then extraLibsStatic bnfo - else extraLibs bnfo, - ghcOptLinkLibPath = toNubListR $ - if withFullyStaticExe lbi - then cleanedExtraLibDirsStatic - else cleanedExtraLibDirs, - ghcOptLinkFrameworks = toNubListR $ - PD.frameworks bnfo, - ghcOptLinkFrameworkDirs = toNubListR $ - PD.extraFrameworkDirs bnfo, - ghcOptInputFiles = toNubListR - [tmpDir x | x <- cLikeObjs ++ cxxObjs] - } - dynLinkerOpts = mempty { - ghcOptRPaths = rpaths <> toNubListR (extraLibDirs bnfo), - ghcOptInputFiles = toNubListR - [tmpDir x | x <- cLikeObjs ++ cxxObjs] - } - replOpts = baseOpts { - ghcOptExtra = Internal.filterGhciFlags - (ghcOptExtra baseOpts) - <> replOptionsFlags replFlags, - ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules baseOpts), - ghcOptInputFiles = replNoLoad replFlags (ghcOptInputFiles baseOpts) - } - -- For a normal compile we do separate invocations of ghc for - -- compiling as for linking. But for repl we have to do just - -- the one invocation, so that one has to include all the - -- linker stuff too, like -l flags and any .o files from C - -- files etc. - `mappend` linkerOpts - `mappend` mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptOptimisation = toFlag GhcNoOptimisation - } - commonOpts | needProfiling = profOpts - | needDynamic = dynOpts - | otherwise = staticOpts - compileOpts | useDynToo = dynTooOpts - | otherwise = commonOpts - withStaticExe = not needProfiling && not needDynamic - - -- For building exe's that use TH with -prof or -dynamic we actually have - -- to build twice, once without -prof/-dynamic and then again with - -- -prof/-dynamic. This is because the code that TH needs to run at - -- compile time needs to be the vanilla ABI so it can be loaded up and run - -- by the compiler. - -- With dynamic-by-default GHC the TH object files loaded at compile-time - -- need to be .dyn_o instead of .o. - doingTH = usesTemplateHaskellOrQQ bnfo - -- Should we use -dynamic-too instead of compiling twice? - useDynToo = dynamicTooSupported && isGhcDynamic - && doingTH && withStaticExe - && null (hcSharedOptions GHC bnfo) - compileTHOpts | isGhcDynamic = dynOpts - | otherwise = staticOpts - compileForTH - | gbuildIsRepl bm = False - | useDynToo = False - | isGhcDynamic = doingTH && (needProfiling || withStaticExe) - | otherwise = doingTH && (needProfiling || needDynamic) - - -- Build static/dynamic object files for TH, if needed. - when compileForTH $ - runGhcProg compileTHOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } - - -- Do not try to build anything if there are no input files. - -- This can happen if the cabal file ends up with only cSrcs - -- but no Haskell modules. - unless ((null inputFiles && null inputModules) - || gbuildIsRepl bm) $ - runGhcProg compileOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } - - -- build any C++ sources - unless (null cxxSrcs) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCxxOpts = if isGhcDynamic - -- Dynamic GHC requires C++ sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCxxOpts - | needDynamic = sharedCxxOpts - | otherwise = vanillaCxxOpts - -- TODO: Placing all Haskell, C, & C++ objects in a single directory - -- Has the potential for file collisions. In general we would - -- consider this a user error. However, we should strive to - -- add a warning if this occurs. - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cxxSrcs ] - - -- build any C sources - cSrcs' <- checkCSources verbosity (gbuildName bm) cSrcs - unless (null cSrcs') $ do - info verbosity "Building C Sources..." - forM_ cSrcs' $ \filename -> do - let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - let vanillaCcOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - let profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - let sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - let opts | needProfiling = profCcOpts - | needDynamic = sharedCcOpts - | otherwise = vanillaCcOpts - let odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - case bm of - GReplExe _ _ -> runGhcProg replOpts - GReplFLib _ _ -> runGhcProg replOpts - GBuildExe _ -> do - let linkOpts = commonOpts - `mappend` linkerOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag (null inputFiles) - } - `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) - - info verbosity "Linking..." - -- Work around old GHCs not relinking in this - -- situation, see #3294 - let target = targetDir targetName - when (compilerVersion comp < mkVersion [7,7]) $ do - e <- doesFileExist target - when e (removeFile target) - runGhcProg linkOpts { ghcOptOutputFile = toFlag target } - GBuildFLib flib -> do - let -- Instruct GHC to link against libHSrts. - rtsLinkOpts :: GhcOptions - rtsLinkOpts - | supportsFLinkRts = - mempty { - ghcOptLinkRts = toFlag True - } - | otherwise = - mempty { - ghcOptLinkLibs = rtsOptLinkLibs, - ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo - } - where - threaded = hasThreaded (gbuildInfo bm) - supportsFLinkRts = compilerVersion comp >= mkVersion [9,0] - rtsInfo = extractRtsInfo lbi - rtsOptLinkLibs = [ - if needDynamic - then if threaded - then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) - else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) - else if threaded - then statRtsThreadedLib (rtsStaticInfo rtsInfo) - else statRtsVanillaLib (rtsStaticInfo rtsInfo) - ] - - - linkOpts :: GhcOptions - linkOpts = case foreignLibType flib of - ForeignLibNativeShared -> - commonOpts - `mappend` linkerOpts - `mappend` dynLinkerOpts - `mappend` rtsLinkOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag True, - ghcOptShared = toFlag True, - ghcOptFPic = toFlag True, - ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm - } - -- See Note [RPATH] - `mappend` ifNeedsRPathWorkaround lbi mempty { - ghcOptLinkOptions = ["-Wl,--no-as-needed"] - , ghcOptLinkLibs = ["ffi"] - } - ForeignLibNativeStatic -> - -- this should be caught by buildFLib - -- (and if we do implement this, we probably don't even want to call - -- ghc here, but rather Ar.createArLibArchive or something) - cabalBug "static libraries not yet implemented" - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -- We build under a (potentially) different filename to set a - -- soname on supported platforms. See also the note for - -- @flibBuildName@. - info verbosity "Linking..." - let buildName = flibBuildName lbi flib - runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir buildName) } - renameFile (targetDir buildName) (targetDir targetName) - -{- -Note [RPATH] -~~~~~~~~~~~~ - -Suppose that the dynamic library depends on `base`, but not (directly) on -`integer-gmp` (which, however, is a dependency of `base`). We will link the -library as - - gcc ... -lHSbase-4.7.0.2-ghc7.8.4 -lHSinteger-gmp-0.5.1.0-ghc7.8.4 ... - -However, on systems (like Ubuntu) where the linker gets called with `-as-needed` -by default, the linker will notice that `integer-gmp` isn't actually a direct -dependency and hence omit the link. - -Then when we attempt to link a C program against this dynamic library, the -_static_ linker will attempt to verify that all symbols can be resolved. The -dynamic library itself does not require any symbols from `integer-gmp`, but -`base` does. In order to verify that the symbols used by `base` can be -resolved, the static linker needs to be able to _find_ integer-gmp. - -Finding the `base` dependency is simple, because the dynamic elf header -(`readelf -d`) for the library that we have created looks something like - - (NEEDED) Shared library: [libHSbase-4.7.0.2-ghc7.8.4.so] - (RPATH) Library rpath: [/path/to/base-4.7.0.2:...] - -However, when it comes to resolving the dependency on `integer-gmp`, it needs -to look at the dynamic header for `base`. On modern ghc (7.8 and higher) this -looks something like - - (NEEDED) Shared library: [libHSinteger-gmp-0.5.1.0-ghc7.8.4.so] - (RPATH) Library rpath: [$ORIGIN/../integer-gmp-0.5.1.0:...] - -This specifies the location of `integer-gmp` _in terms of_ the location of base -(using the `$ORIGIN`) variable. But here's the crux: when the static linker -attempts to verify that all symbols can be resolved, [**IT DOES NOT RESOLVE -`$ORIGIN`**](http://stackoverflow.com/questions/6323603/ld-using-rpath-origin-inside-a-shared-library-recursive). -As a consequence, it will not be able to resolve the symbols and report the -missing symbols as errors, _even though the dynamic linker **would** be able to -resolve these symbols_. We can tell the static linker not to report these -errors by using `--unresolved-symbols=ignore-all` and all will be fine when we -run the program ([(indeed, this is what the gold linker -does)](https://sourceware.org/ml/binutils/2013-05/msg00038.html), but it makes -the resulting library more difficult to use. - -Instead what we can do is make sure that the generated dynamic library has -explicit top-level dependencies on these libraries. This means that the static -linker knows where to find them, and when we have transitive dependencies on -the same libraries the linker will only load them once, so we avoid needing to -look at the `RPATH` of our dependencies. We can do this by passing -`--no-as-needed` to the linker, so that it doesn't omit any libraries. - -Note that on older ghc (7.6 and before) the Haskell libraries don't have an -RPATH set at all, which makes it even more important that we make these -top-level dependencies. - -Finally, we have to explicitly link against `libffi` for the same reason. For -newer ghc this _happens_ to be unnecessary on many systems because `libffi` is -a library which is not specific to GHC, and when the static linker verifies -that all symbols can be resolved it will find the `libffi` that is globally -installed (completely independent from ghc). Of course, this may well be the -_wrong_ version of `libffi`, but it's quite possible that symbol resolution -happens to work. This is of course the wrong approach, which is why we link -explicitly against `libffi` so that we will find the _right_ version of -`libffi`. --} - --- | Do we need the RPATH workaround? --- --- See Note [RPATH]. -ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a -ifNeedsRPathWorkaround lbi a = - case hostPlatform lbi of - Platform _ Linux -> a - _otherwise -> mempty - -data DynamicRtsInfo = DynamicRtsInfo { - dynRtsVanillaLib :: FilePath - , dynRtsThreadedLib :: FilePath - , dynRtsDebugLib :: FilePath - , dynRtsEventlogLib :: FilePath - , dynRtsThreadedDebugLib :: FilePath - , dynRtsThreadedEventlogLib :: FilePath - } - -data StaticRtsInfo = StaticRtsInfo { - statRtsVanillaLib :: FilePath - , statRtsThreadedLib :: FilePath - , statRtsDebugLib :: FilePath - , statRtsEventlogLib :: FilePath - , statRtsThreadedDebugLib :: FilePath - , statRtsThreadedEventlogLib :: FilePath - , statRtsProfilingLib :: FilePath - , statRtsThreadedProfilingLib :: FilePath - } - -data RtsInfo = RtsInfo { - rtsDynamicInfo :: DynamicRtsInfo - , rtsStaticInfo :: StaticRtsInfo - , rtsLibPaths :: [FilePath] - } - --- | Extract (and compute) information about the RTS library --- --- TODO: This hardcodes the name as @HSrts-ghc@. I don't know if we can --- find this information somewhere. We can lookup the 'hsLibraries' field of --- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which --- doesn't really help. -extractRtsInfo :: LocalBuildInfo -> RtsInfo -extractRtsInfo lbi = - case PackageIndex.lookupPackageName - (installedPkgs lbi) (mkPackageName "rts") of - [(_, [rts])] -> aux rts - _otherwise -> error "No (or multiple) ghc rts package is registered" - where - aux :: InstalledPackageInfo -> RtsInfo - aux rts = RtsInfo { - rtsDynamicInfo = DynamicRtsInfo { - dynRtsVanillaLib = withGhcVersion "HSrts" - , dynRtsThreadedLib = withGhcVersion "HSrts_thr" - , dynRtsDebugLib = withGhcVersion "HSrts_debug" - , dynRtsEventlogLib = withGhcVersion "HSrts_l" - , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" - , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" - } - , rtsStaticInfo = StaticRtsInfo { - statRtsVanillaLib = "HSrts" - , statRtsThreadedLib = "HSrts_thr" - , statRtsDebugLib = "HSrts_debug" - , statRtsEventlogLib = "HSrts_l" - , statRtsThreadedDebugLib = "HSrts_thr_debug" - , statRtsThreadedEventlogLib = "HSrts_thr_l" - , statRtsProfilingLib = "HSrts_p" - , statRtsThreadedProfilingLib = "HSrts_thr_p" - } - , rtsLibPaths = InstalledPackageInfo.libraryDirs rts - } - withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) - --- | 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. -checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool -checkNeedsRecompilation filename opts = filename `moreRecentFile` oname - where oname = getObjectFileName filename opts - --- | Finds the object file name of the given source file -getObjectFileName :: FilePath -> GhcOptions -> FilePath -getObjectFileName filename opts = oname - where odir = fromFlag (ghcOptObjDir opts) - oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) - oname = odir replaceExtension filename oext - --- | Calculate the RPATHs for the component we are building. --- --- Calculates relative RPATHs when 'relocatable' is set. -getRPaths :: LocalBuildInfo - -> ComponentLocalBuildInfo -- ^ Component we are building - -> IO (NubListR FilePath) -getRPaths lbi clbi | supportRPaths hostOS = do - libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi - let hostPref = case hostOS of - OSX -> "@loader_path" - _ -> "$ORIGIN" - relPath p = if isRelative p then hostPref p else p - rpaths = toNubListR (map relPath libraryPaths) - return rpaths - where - (Platform _ hostOS) = hostPlatform lbi - compid = compilerId . compiler $ lbi - - -- The list of RPath-supported operating systems below reflects the - -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ - -- reflect whether the OS supports RPATH. - - -- E.g. when this comment was written, the *BSD operating systems were - -- untested with regards to Cabal RPATH handling, and were hence set to - -- 'False', while those operating systems themselves do support RPATH. - supportRPaths Linux   = True - supportRPaths Windows = False - supportRPaths OSX   = True - supportRPaths FreeBSD   = - case compid of - CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True - _ -> False - supportRPaths OpenBSD   = False - supportRPaths NetBSD   = False - supportRPaths DragonFly = False - supportRPaths Solaris = False - supportRPaths AIX = False - supportRPaths HPUX = False - supportRPaths IRIX = False - supportRPaths HaLVM = False - supportRPaths IOS = False - supportRPaths Android = False - supportRPaths Ghcjs = False - supportRPaths Wasi = False - supportRPaths Hurd = False - supportRPaths (OtherOS _) = False - -- Do _not_ add a default case so that we get a warning here when a new OS - -- is added. - -getRPaths _ _ = return mempty - --- | Determine whether the given 'BuildInfo' is intended to link against the --- 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 - where - PerCompilerFlavor ghc _ = options bi - --- | 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 :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO String -libAbiHash verbosity _pkg_descr lbi lib clbi = do - let - libBi = libBuildInfo lib - comp = compiler lbi - platform = hostPlatform lbi - vanillaArgs = - (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) - `mappend` mempty { - ghcOptMode = toFlag GhcModeAbiHash, - ghcOptInputModules = toNubListR $ exposedModules lib - } - sharedArgs = vanillaArgs `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi - } - profArgs = vanillaArgs `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC libBi - } - ghcArgs - | withVanillaLib lbi = vanillaArgs - | withSharedLib lbi = sharedArgs - | withProfLib lbi = profArgs - | otherwise = error "libAbiHash: Can't find an enabled library way" - - (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - hash <- getProgramInvocationOutput verbosity - =<< ghcInvocation verbosity ghcProg comp platform ghcArgs - return (takeWhile (not . isSpace) hash) - -componentGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions -componentGhcOptions verbosity lbi = - Internal.componentGhcOptions verbosity implInfo lbi - where - comp = compiler lbi - implInfo = getImplInfo comp - -componentCcGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCcGhcOptions verbosity lbi = - Internal.componentCcGhcOptions verbosity implInfo lbi - where - comp = compiler lbi - implInfo = getImplInfo comp - --- ----------------------------------------------------------------------------- --- Installing - --- |Install executables for GHC. -installExe :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^Where to copy the files to - -> FilePath -- ^Build location - -> (FilePath, FilePath) -- ^Executable (prefix,suffix) - -> PackageDescription - -> Executable - -> IO () -installExe verbosity lbi binDir buildPref - (progprefix, progsuffix) _pkg exe = do - createDirectoryIfMissingVerbose verbosity True binDir - let exeName' = unUnqualComponentName $ exeName exe - exeFileName = exeTargetName (hostPlatform lbi) exe - fixedExeBaseName = progprefix ++ exeName' ++ progsuffix - installBinary dest = do - installExecutableFile verbosity - (buildPref exeName' exeFileName) - (dest <.> exeExtension (hostPlatform lbi)) - when (stripExes lbi) $ - Strip.stripExe verbosity (hostPlatform lbi) (withPrograms lbi) - (dest <.> exeExtension (hostPlatform lbi)) - installBinary (binDir fixedExeBaseName) - --- |Install foreign library for GHC. -installFLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^Build location - -> PackageDescription - -> ForeignLib - -> IO () -installFLib verbosity lbi targetDir builtDir _pkg flib = - install (foreignLibIsShared flib) - builtDir - targetDir - (flibTargetName lbi flib) - where - install isShared srcDir dstDir name = do - let src = srcDir name - dst = dstDir name - createDirectoryIfMissingVerbose verbosity True targetDir - -- TODO: Should we strip? (stripLibs lbi) - if isShared - then installExecutableFile verbosity src dst - else installOrdinaryFile verbosity src dst - -- Now install appropriate symlinks if library is versioned - let (Platform _ os) = hostPlatform lbi - when (not (null (foreignLibVersion flib os))) $ do - when (os /= Linux) $ die' verbosity - -- It should be impossible to get here. - "Can't install foreign-library symlink on non-Linux OS" -#ifndef mingw32_HOST_OS - -- 'createSymbolicLink file1 file2' creates a symbolic link - -- named 'file2' which points to the file 'file1'. - -- Note that we do want a symlink to 'name' rather than - -- 'dst', because the symlink will be relative to the - -- directory it's created in. - -- Finally, we first create the symlinks in a temporary - -- directory and then rename to simulate 'ln --force'. - withTempDirectory verbosity dstDir nm $ \tmpDir -> do - let link1 = flibBuildName lbi flib - link2 = "lib" ++ nm <.> "so" - createSymbolicLink name (tmpDir link1) - renameFile (tmpDir link1) (dstDir link1) - createSymbolicLink name (tmpDir link2) - renameFile (tmpDir link2) (dstDir link2) - where - nm :: String - nm = unUnqualComponentName $ foreignLibName flib -#endif /* mingw32_HOST_OS */ - - --- |Install for ghc, .hi, .a and, if --with-ghci given, .o -installLib :: Verbosity - -> LocalBuildInfo - -> 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 - -- copy .hi files over: - whenVanilla $ copyModuleFiles "hi" - whenProf $ copyModuleFiles "p_hi" - whenShared $ copyModuleFiles "dyn_hi" - - -- copy the built library files over: - whenHasCode $ do - whenVanilla $ do - sequence_ [ installOrdinary - builtDir - targetDir - (mkGenericStaticLibName (l ++ f)) - | l <- getHSLibraryName - (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib)) - , f <- "":extraLibFlavours (libBuildInfo lib) - ] - whenGHCi $ installOrdinary builtDir targetDir ghciLibName - whenProf $ do - installOrdinary builtDir targetDir profileLibName - whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName - whenShared $ if - -- The behavior for "extra-bundled-libraries" changed in version 2.5.0. - -- See ghc issue #15837 and Cabal PR #5855. - | specVersion pkg < CabalSpecV3_0 -> do - sequence_ [ installShared builtDir dynlibTargetDir - (mkGenericSharedLibName platform compiler_id (l ++ f)) - | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) - , f <- "":extraDynLibFlavours (libBuildInfo lib) - ] - | otherwise -> do - sequence_ [ installShared - builtDir - dynlibTargetDir - (mkGenericSharedLibName - platform - compiler_id - (getHSLibraryName uid ++ f)) - | f <- "":extraDynLibFlavours (libBuildInfo lib) - ] - sequence_ [ do - files <- getDirectoryContents builtDir - let l' = mkGenericSharedBundledLibName - platform - compiler_id - l - forM_ files $ \ file -> - when (l' `isPrefixOf` file) $ do - isFile <- doesFileExist (builtDir file) - when isFile $ do - installShared - builtDir - dynlibTargetDir - file - | l <- extraBundledLibs (libBuildInfo lib) - ] - - where - builtDir = componentBuildDir lbi clbi - - install isShared srcDir dstDir name = do - let src = srcDir name - dst = dstDir name - - createDirectoryIfMissingVerbose verbosity True dstDir - - if isShared - then installExecutableFile verbosity src dst - else installOrdinaryFile verbosity src dst - - when (stripLibs lbi) $ Strip.stripLib verbosity - platform (withPrograms lbi) dst - - installOrdinary = install False - installShared = install True - - copyModuleFiles ext = - findModuleFilesEx verbosity [builtDir] [ext] (allLibModules lib clbi) - >>= installOrdinaryFiles verbosity targetDir - - compiler_id = compilerId (compiler lbi) - platform = hostPlatform lbi - uid = componentUnitId clbi - profileLibName = mkProfLibName uid - ghciLibName = Internal.mkGHCiLibName uid - ghciProfLibName = Internal.mkGHCiProfLibName uid - - hasLib = not $ null (allLibModules lib clbi) - && null (cSources (libBuildInfo lib)) - && null (cxxSources (libBuildInfo lib)) - && null (cmmSources (libBuildInfo lib)) - && null (asmSources (libBuildInfo lib)) - && (null (jsSources (libBuildInfo lib)) || not hasJsSupport) - hasJsSupport = case hostPlatform lbi of - Platform JavaScript _ -> True - _ -> False - has_code = not (componentIsIndefinite clbi) - whenHasCode = when has_code - whenVanilla = when (hasLib && withVanillaLib lbi) - whenProf = when (hasLib && withProfLib lbi && has_code) - whenGHCi = when (hasLib && withGHCiLib lbi && has_code) - whenShared = when (hasLib && withSharedLib lbi && has_code) - --- ----------------------------------------------------------------------------- --- Registering - -hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo -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 - -registerPackage - :: Verbosity - -> ProgramDb - -> PackageDBStack - -> InstalledPackageInfo - -> HcPkg.RegisterOptions - -> IO () -registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = - HcPkg.register (hcPkgInfo progdb) verbosity packageDbs - installedPkgInfo registerOptions - -pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath -pkgRoot verbosity lbi = pkgRoot' - where - pkgRoot' GlobalPackageDB = - let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi) - in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg) - pkgRoot' UserPackageDB = do - appDir <- getGhcAppDir - let ver = compilerVersion (compiler lbi) - subdir = System.Info.arch ++ '-':System.Info.os - ++ '-':prettyShow ver - rootDir = appDir subdir - -- We must create the root directory for the user package database if it - -- does not yet exists. Otherwise '${pkgroot}' will resolve to a - -- directory at the time of 'ghc-pkg register', and registration will - -- fail. - createDirectoryIfMissing True rootDir - return rootDir - pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp) - --- ----------------------------------------------------------------------------- --- Utils - -isDynamic :: Compiler -> Bool -isDynamic = Internal.ghcLookupProperty "GHC Dynamic" - -supportsDynamicToo :: Compiler -> Bool -supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" - -withExt :: FilePath -> String -> FilePath -withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else "" - -checkCSources :: Verbosity -> String -> [String] -> IO [String] -checkCSources verbosity name cSrcs = do - let (headers, cSrcs') = partition (\filepath -> ".h" `isSuffixOf` filepath) cSrcs - others = filter (\filepath -> not (".c" `isSuffixOf` filepath)) cSrcs' - unless (null headers) $ do - let files = intercalate ", " headers - warn verbosity $ unlines - [ "The following header files listed in " <> name <> "'s c-sources will not be used: " <> files <> "." - , "Header files should be in the 'include' or 'install-include' stanza." - , "See https://cabal.readthedocs.io/en/3.10/cabal-package.html#pkg-field-includes" - ] - unless (null others) $ do - let files = intercalate ", " others - warn verbosity $ unlines - [ "The following files listed in " <> name <> "'s c-sources do not have the expected '.c' extension " <> files <> "." - , "C++ files should be in the 'cxx-sources' stanza." - , "See https://cabal.readthedocs.io/en/3.10/cabal-package.html#pkg-field-cxx-sources" - ] - return cSrcs' +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.GHC +-- Copyright : Isaac Jones 2003-2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a fairly large module. It contains most of the GHC-specific code for +-- configuring, building and installing packages. It also exports a function +-- for finding out what packages are already installed. Configuring involves +-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions +-- this version of ghc supports and returning a 'Compiler' value. +-- +-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out +-- what packages are installed. +-- +-- Building is somewhat complex as there is quite a bit of information to take +-- into account. We have to build libs and programs, possibly for profiling and +-- shared libs. We have to support building libraries that will be usable by +-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files +-- using ghc. Linking, especially for @split-objs@ is remarkably complex, +-- partly because there tend to be 1,000's of @.o@ files and this can often be +-- more than we can pass to the @ld@ or @ar@ programs in one go. +-- +-- Installing for libs and exes involves finding the right files and copying +-- them to the right places. One of the more tricky things about this module is +-- remembering the layout of files in the build directory (which is not +-- explicitly documented) and thus what search dirs are used for various kinds +-- of files. +module Distribution.Simple.GHC + ( getGhcInfo + , configure + , getInstalledPackages + , getInstalledPackagesMonitorFiles + , getPackageDBContents + , buildLib + , buildFLib + , buildExe + , replLib + , replFLib + , replExe + , startInterpreter + , installLib + , installFLib + , installExe + , libAbiHash + , hcPkgInfo + , registerPackage + , Internal.componentGhcOptions + , Internal.componentCcGhcOptions + , getGhcAppDir + , getLibDir + , isDynamic + , getGlobalPackageDB + , pkgRoot + + -- * Constructing and deconstructing GHC environment files + , Internal.GhcEnvironmentFileEntry (..) + , Internal.simpleGhcEnvironmentFile + , Internal.renderGhcEnvironmentFile + , Internal.writeGhcEnvironmentFile + , Internal.ghcPlatformAndVersionString + , readGhcEnvironmentFile + , parseGhcEnvironmentFile + , ParseErrorExc (..) + + -- * Version-specific implementation quirks + , getImplInfo + , GhcImplInfo (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Control.Monad (forM_) +import Data.List (stripPrefix) +import qualified Data.Map as Map +import Distribution.CabalSpecVersion +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.Package +import Distribution.PackageDescription as PD +import Distribution.Pretty +import Distribution.Simple.Build.Inputs (PreBuildComponentInputs (..)) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Flag (Flag (..), toFlag) +import qualified Distribution.Simple.GHC.Build as GHC +import Distribution.Simple.GHC.Build.Utils +import Distribution.Simple.GHC.EnvironmentParser +import Distribution.Simple.GHC.ImplInfo +import qualified Distribution.Simple.GHC.Internal as Internal +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess.Types +import Distribution.Simple.Program +import Distribution.Simple.Program.Builtin (runghcProgram) +import Distribution.Simple.Program.GHC +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import qualified Distribution.Simple.Program.Strip as Strip +import Distribution.Simple.Setup.Common (extraCompilationArtifacts) +import Distribution.Simple.Setup.Repl +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ParStrat +import Distribution.Types.TargetInfo +import Distribution.Utils.NubList +import Distribution.Verbosity +import Distribution.Version +import Language.Haskell.Extension +import System.Directory + ( canonicalizePath + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getAppUserDataDirectory + , getDirectoryContents + ) +import System.FilePath + ( takeDirectory + , (<.>) + , () + ) +import qualified System.Info +#ifndef mingw32_HOST_OS +import System.Directory (renameFile) +import System.Posix (createSymbolicLink) +#endif /* mingw32_HOST_OS */ + +import Distribution.Simple.Setup (BuildingWhat (..)) +import Distribution.Simple.Setup.Build + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure + :: Verbosity + -> Maybe FilePath + -> Maybe FilePath + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configure verbosity hcPath hcPkgPath 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.12 + -- ... and the following odd development version + unless (ghcVersion < mkVersion [9, 12]) $ + warn verbosity $ + "Unknown/unsupported 'ghc' version detected " + ++ "(Cabal " + ++ prettyShow cabalVersion + ++ " supports 'ghc' version < 9.12): " + ++ 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 + + 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 + + -- starting with GHC 8.0, `TemplateHaskell` will be omitted from + -- `--supported-extensions` when it's not available. + -- for older GHCs we can use the "Have interpreter" property to + -- filter out `TemplateHaskell` + filterExtTH + | ghcVersion < mkVersion [8] + , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap = + filterExt TemplateHaskell + | otherwise = id + + filterExt ext = filter ((/= EnableExtension ext) . fst) + + compilerId :: CompilerId + compilerId = CompilerId GHC ghcVersion + + compilerAbiTag :: AbiTag + compilerAbiTag = maybe NoAbiTag AbiTag (Map.lookup "Project Unit Id" ghcInfoMap >>= stripPrefix (prettyShow compilerId <> "-")) + + let comp = + Compiler + { compilerId + , compilerAbiTag + , compilerCompat = [] + , compilerLanguages = languages + , compilerExtensions = extensions + , compilerProperties = ghcInfoMap + } + compPlatform = Internal.targetPlatform ghcInfo + -- configure gcc and ld + progdb4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap progdb3 + return (comp, compPlatform, 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: +-- +-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +guessToolFromGhcPath + :: Program + -> ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessToolFromGhcPath tool ghcProg verbosity searchpath = + do + let toolname = programName tool + given_path = programPath ghcProg + given_dir = takeDirectory given_path + real_path <- canonicalizePath given_path + let real_dir = takeDirectory real_path + versionSuffix path = takeVersionSuffix (dropExeExtension path) + given_suf = versionSuffix given_path + real_suf = versionSuffix real_path + guessNormal dir = dir toolname <.> exeExtension buildPlatform + guessGhcVersioned dir suf = + dir + (toolname ++ "-ghc" ++ suf) + <.> exeExtension buildPlatform + guessVersioned dir suf = + dir + (toolname ++ suf) + <.> exeExtension buildPlatform + mkGuesses dir suf + | null suf = [guessNormal dir] + | otherwise = + [ guessGhcVersioned dir suf + , guessVersioned dir suf + , guessNormal dir + ] + -- order matters here, see https://github.com/haskell/cabal/issues/7390 + guesses = + ( if real_path == given_path + then [] + else mkGuesses real_dir real_suf + ) + ++ mkGuesses given_dir given_suf + info verbosity $ + "looking for tool " + ++ toolname + ++ " near compiler in " + ++ given_dir + debug verbosity $ "candidate locations: " ++ show guesses + exists <- traverse doesFileExist guesses + case [file | (file, True) <- zip guesses exists] of + -- If we can't find it near ghc, fall back to the usual + -- method. + [] -> programFindLocation tool verbosity searchpath + (fp : _) -> do + info verbosity $ "found " ++ toolname ++ " in " ++ fp + let lookedAt = + map fst + . takeWhile (\(_file, exist) -> not exist) + $ zip guesses exists + return (Just (fp, lookedAt)) + where + takeVersionSuffix :: FilePath -> String + takeVersionSuffix = takeWhileEndLE isSuffixChar + + isSuffixChar :: Char -> Bool + isSuffixChar c = isDigit c || c == '.' || c == '-' + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding ghc-pkg, we try looking for both a versioned and unversioned +-- ghc-pkg in the same dir, that is: +-- +-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +guessGhcPkgFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding hsc2hs, we try looking for both a versioned and unversioned +-- hsc2hs in the same dir, that is: +-- +-- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe) +-- > /usr/local/bin/hsc2hs-6.6.1(.exe) +-- > /usr/local/bin/hsc2hs(.exe) +guessHsc2hsFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding haddock, we try looking for both a versioned and unversioned +-- haddock in the same dir, that is: +-- +-- > /usr/local/bin/haddock-ghc-6.6.1(.exe) +-- > /usr/local/bin/haddock-6.6.1(.exe) +-- > /usr/local/bin/haddock(.exe) +guessHaddockFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram + +guessHpcFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHpcFromGhcPath = guessToolFromGhcPath hpcProgram + +guessRunghcFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessRunghcFromGhcPath = guessToolFromGhcPath runghcProgram + +getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] +getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg + where + version = fromMaybe (error "GHC.getGhcInfo: no ghc version") $ programVersion ghcProg + implInfo = ghcVersionImplInfo version + +-- | Given a single package DB, return all installed packages. +getPackageDBContents + :: Verbosity + -> PackageDB + -> ProgramDb + -> IO InstalledPackageIndex +getPackageDBContents verbosity packagedb progdb = do + pkgss <- getInstalledPackages' verbosity [packagedb] progdb + toPackageIndex verbosity pkgss progdb + +-- | Given a package DB stack, return all installed packages. +getInstalledPackages + :: Verbosity + -> Compiler + -> PackageDBStack + -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp packagedbs progdb = do + checkPackageDbEnvVar verbosity + checkPackageDbStack verbosity comp packagedbs + pkgss <- getInstalledPackages' verbosity packagedbs progdb + index <- toPackageIndex verbosity pkgss progdb + return $! hackRtsPackage index + where + hackRtsPackage index = + case PackageIndex.lookupPackageName index (mkPackageName "rts") of + [(_, [rts])] -> + PackageIndex.insert (removeMingwIncludeDir rts) index + _ -> index -- No (or multiple) ghc rts package is registered!! + -- Feh, whatever, the ghc test suite does some crazy stuff. + +-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a +-- @PackageIndex@. Helper function used by 'getPackageDBContents' and +-- 'getInstalledPackages'. +toPackageIndex + :: Verbosity + -> [(PackageDB, [InstalledPackageInfo])] + -> ProgramDb + -> IO InstalledPackageIndex +toPackageIndex verbosity pkgss progdb = do + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it. + topDir <- getLibDir' verbosity ghcProg + let indices = + [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss + ] + return $! mconcat indices + where + ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb + +-- | Return the 'FilePath' to the GHC application data directory. +-- +-- @since 3.4.0.0 +getGhcAppDir :: IO FilePath +getGhcAppDir = getAppUserDataDirectory "ghc" + +getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath +getLibDir verbosity lbi = + dropWhileEndLE isSpace + `fmap` getDbProgramOutput + verbosity + ghcProgram + (withPrograms lbi) + ["--print-libdir"] + +getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath +getLibDir' verbosity ghcProg = + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcProg ["--print-libdir"] + +-- | Return the 'FilePath' to the global GHC package database. +getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath +getGlobalPackageDB verbosity ghcProg = + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcProg ["--print-global-package-db"] + +-- | Return the 'FilePath' to the per-user GHC package database. +getUserPackageDB + :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath +getUserPackageDB _verbosity ghcProg platform = do + -- It's rather annoying that we have to reconstruct this, because ghc + -- hides this information from us otherwise. But for certain use cases + -- like change monitoring it really can't remain hidden. + appdir <- getGhcAppDir + return (appdir platformAndVersion packageConfFileName) + where + platformAndVersion = + Internal.ghcPlatformAndVersionString + platform + ghcVersion + packageConfFileName = "package.conf.d" + ghcVersion = fromMaybe (error "GHC.getUserPackageDB: no ghc version") $ programVersion ghcProg + +checkPackageDbEnvVar :: Verbosity -> IO () +checkPackageDbEnvVar verbosity = + Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH" + +checkPackageDbStack :: Verbosity -> Compiler -> PackageDBStack -> IO () +checkPackageDbStack verbosity comp = + if flagPackageConf implInfo + then checkPackageDbStackPre76 verbosity + else checkPackageDbStackPost76 verbosity + where + implInfo = ghcVersionImplInfo (compilerVersion comp) + +checkPackageDbStackPost76 :: Verbosity -> PackageDBStack -> IO () +checkPackageDbStackPost76 _ (GlobalPackageDB : rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStackPost76 verbosity rest + | GlobalPackageDB `elem` rest = + dieWithException verbosity CheckPackageDbStackPost76 +checkPackageDbStackPost76 _ _ = return () + +checkPackageDbStackPre76 :: Verbosity -> PackageDBStack -> 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'} + +-- | Get the packages from specific PackageDBs, not cumulative. +getInstalledPackages' + :: Verbosity + -> [PackageDB] + -> ProgramDb + -> IO [(PackageDB, [InstalledPackageInfo])] +getInstalledPackages' verbosity packagedbs progdb = + sequenceA + [ do + pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb + return (packagedb, pkgs) + | packagedb <- packagedbs + ] + +getInstalledPackagesMonitorFiles + :: Verbosity + -> Platform + -> ProgramDb + -> [PackageDB] + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity platform progdb = + traverse getPackageDBPath + where + getPackageDBPath :: PackageDB -> IO FilePath + getPackageDBPath GlobalPackageDB = + selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg + getPackageDBPath UserPackageDB = + selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform + getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path + + -- GHC has old style file dbs, and new style directory dbs. + -- Note that for dir style dbs, we only need to monitor the cache file, not + -- the whole directory. The ghc program itself only reads the cache file + -- so it's safe to only monitor this one file. + selectMonitorFile path = do + isFileStyle <- doesFileExist path + if isFileStyle + then return path + else return (path "package.cache") + + ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb + +-- ----------------------------------------------------------------------------- +-- Building a library + +buildLib + :: BuildFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +buildLib flags numJobs pkg lbi lib clbi = + GHC.build numJobs pkg $ + PreBuildComponentInputs (BuildNormal flags) lbi (TargetInfo clbi (CLib lib)) + +replLib + :: ReplFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +replLib flags numJobs pkg lbi lib clbi = + GHC.build numJobs pkg $ + PreBuildComponentInputs (BuildRepl flags) lbi (TargetInfo clbi (CLib lib)) + +-- | Start a REPL without loading any source files. +startInterpreter + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> PackageDBStack + -> IO () +startInterpreter verbosity progdb comp platform packageDBs = do + let replOpts = + mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptPackageDBs = packageDBs + } + checkPackageDbStack verbosity comp packageDBs + (ghcProg, _) <- requireProgram verbosity ghcProgram progdb + runGHC verbosity ghcProg comp platform replOpts + +-- ----------------------------------------------------------------------------- +-- Building an executable or foreign library + +-- | Build a foreign library +buildFLib + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +buildFLib v numJobs pkg lbi flib clbi = + GHC.build numJobs pkg $ + PreBuildComponentInputs (BuildNormal mempty{buildVerbosity = toFlag v}) lbi (TargetInfo clbi (CFLib flib)) + +replFLib + :: ReplFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +replFLib replFlags njobs pkg lbi flib clbi = + GHC.build njobs pkg $ + PreBuildComponentInputs (BuildRepl replFlags) lbi (TargetInfo clbi (CFLib flib)) + +-- | Build an executable with GHC. +buildExe + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +buildExe v njobs pkg lbi exe clbi = + GHC.build njobs pkg $ + PreBuildComponentInputs (BuildNormal mempty{buildVerbosity = toFlag v}) lbi (TargetInfo clbi (CExe exe)) + +replExe + :: ReplFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +replExe replFlags njobs pkg lbi exe clbi = + GHC.build njobs pkg $ + PreBuildComponentInputs (BuildRepl replFlags) lbi (TargetInfo clbi (CExe exe)) + +-- | 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 + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO String +libAbiHash verbosity _pkg_descr lbi lib clbi = do + let + libBi = libBuildInfo lib + comp = compiler lbi + platform = hostPlatform lbi + vanillaArgs = + (Internal.componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + `mappend` mempty + { ghcOptMode = toFlag GhcModeAbiHash + , ghcOptInputModules = toNubListR $ exposedModules lib + } + sharedArgs = + vanillaArgs + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcSharedOptions GHC libBi + } + profArgs = + vanillaArgs + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + True + (withProfLibDetail lbi) + , ghcOptHiSuffix = toFlag "p_hi" + , ghcOptObjSuffix = toFlag "p_o" + , ghcOptExtra = hcProfOptions GHC libBi + } + ghcArgs + | withVanillaLib lbi = vanillaArgs + | withSharedLib lbi = sharedArgs + | withProfLib lbi = profArgs + | otherwise = error "libAbiHash: Can't find an enabled library way" + + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) + + hash <- + getProgramInvocationOutput + verbosity + =<< ghcInvocation verbosity ghcProg comp platform ghcArgs + + return (takeWhile (not . isSpace) hash) + +-- ----------------------------------------------------------------------------- +-- Installing + +-- | Install executables for GHC. +installExe + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ Where to copy the files to + -> FilePath + -- ^ Build location + -> (FilePath, FilePath) + -- ^ Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe + verbosity + lbi + binDir + buildPref + (progprefix, progsuffix) + _pkg + exe = do + createDirectoryIfMissingVerbose verbosity True binDir + let exeName' = unUnqualComponentName $ exeName exe + exeFileName = exeTargetName (hostPlatform lbi) (exeName exe) + fixedExeBaseName = progprefix ++ exeName' ++ progsuffix + installBinary dest = do + installExecutableFile + verbosity + (buildPref exeName' exeFileName) + (dest <.> exeExtension (hostPlatform lbi)) + when (stripExes lbi) $ + Strip.stripExe + verbosity + (hostPlatform lbi) + (withPrograms lbi) + (dest <.> exeExtension (hostPlatform lbi)) + installBinary (binDir fixedExeBaseName) + +-- | Install foreign library for GHC. +installFLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ install location + -> FilePath + -- ^ Build location + -> PackageDescription + -> ForeignLib + -> IO () +installFLib verbosity lbi targetDir builtDir _pkg flib = + install + (foreignLibIsShared flib) + builtDir + targetDir + (flibTargetName lbi flib) + where + install isShared srcDir dstDir name = do + let src = srcDir name + dst = dstDir name + createDirectoryIfMissingVerbose verbosity True targetDir + -- TODO: Should we strip? (stripLibs lbi) + if isShared + then installExecutableFile verbosity src dst + else installOrdinaryFile verbosity src dst + -- Now install appropriate symlinks if library is versioned + let (Platform _ os) = hostPlatform lbi + when (not (null (foreignLibVersion flib os))) $ do + when (os /= Linux) $ + dieWithException verbosity $ + CantInstallForeignLib +#ifndef mingw32_HOST_OS + -- 'createSymbolicLink file1 file2' creates a symbolic link + -- named 'file2' which points to the file 'file1'. + -- Note that we do want a symlink to 'name' rather than + -- 'dst', because the symlink will be relative to the + -- directory it's created in. + -- Finally, we first create the symlinks in a temporary + -- directory and then rename to simulate 'ln --force'. + withTempDirectory verbosity dstDir nm $ \tmpDir -> do + let link1 = flibBuildName lbi flib + link2 = "lib" ++ nm <.> "so" + createSymbolicLink name (tmpDir link1) + renameFile (tmpDir link1) (dstDir link1) + createSymbolicLink name (tmpDir link2) + renameFile (tmpDir link2) (dstDir link2) + where + nm :: String + nm = unUnqualComponentName $ foreignLibName flib +#endif /* mingw32_HOST_OS */ + +-- | Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib + :: Verbosity + -> LocalBuildInfo + -> 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 + -- copy .hi files over: + whenVanilla $ copyModuleFiles $ Suffix "hi" + whenProf $ copyModuleFiles $ Suffix "p_hi" + whenShared $ copyModuleFiles $ Suffix "dyn_hi" + + -- copy extra compilation artifacts that ghc plugins may produce + copyDirectoryIfExists extraCompilationArtifacts + + -- copy the built library files over: + whenHasCode $ do + whenVanilla $ do + sequence_ + [ installOrdinary + builtDir + targetDir + (mkGenericStaticLibName (l ++ f)) + | l <- + getHSLibraryName + (componentUnitId clbi) + : (extraBundledLibs (libBuildInfo lib)) + , f <- "" : extraLibFlavours (libBuildInfo lib) + ] + whenGHCi $ installOrdinary builtDir targetDir ghciLibName + whenProf $ do + installOrdinary builtDir targetDir profileLibName + whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName + whenShared $ + if + -- The behavior for "extra-bundled-libraries" changed in version 2.5.0. + -- See ghc issue #15837 and Cabal PR #5855. + | specVersion pkg < CabalSpecV3_0 -> do + sequence_ + [ installShared + builtDir + dynlibTargetDir + (mkGenericSharedLibName platform compiler_id (l ++ f)) + | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) + , f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] + | otherwise -> do + sequence_ + [ installShared + builtDir + dynlibTargetDir + ( mkGenericSharedLibName + platform + compiler_id + (getHSLibraryName uid ++ f) + ) + | f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] + sequence_ + [ do + files <- getDirectoryContents builtDir + let l' = + mkGenericSharedBundledLibName + platform + compiler_id + l + forM_ files $ \file -> + when (l' `isPrefixOf` file) $ do + isFile <- doesFileExist (builtDir file) + when isFile $ do + installShared + builtDir + dynlibTargetDir + file + | l <- extraBundledLibs (libBuildInfo lib) + ] + where + builtDir = componentBuildDir lbi clbi + + install isShared srcDir dstDir name = do + let src = srcDir name + dst = dstDir name + + createDirectoryIfMissingVerbose verbosity True dstDir + + if isShared + then installExecutableFile verbosity src dst + else installOrdinaryFile verbosity src dst + + when (stripLibs lbi) $ + Strip.stripLib + verbosity + platform + (withPrograms lbi) + dst + + installOrdinary = install False + installShared = install True + + copyModuleFiles ext = + findModuleFilesEx verbosity [builtDir] [ext] (allLibModules lib clbi) + >>= installOrdinaryFiles verbosity targetDir + + copyDirectoryIfExists dirName = do + let src = builtDir dirName + dst = targetDir dirName + dirExists <- doesDirectoryExist src + when dirExists $ copyDirectoryRecursive verbosity src dst + + compiler_id = compilerId (compiler lbi) + platform = hostPlatform lbi + uid = componentUnitId clbi + profileLibName = mkProfLibName uid + ghciLibName = Internal.mkGHCiLibName uid + ghciProfLibName = Internal.mkGHCiProfLibName uid + + hasLib = + not $ + null (allLibModules lib clbi) + && null (cSources (libBuildInfo lib)) + && null (cxxSources (libBuildInfo lib)) + && null (cmmSources (libBuildInfo lib)) + && null (asmSources (libBuildInfo lib)) + && (null (jsSources (libBuildInfo lib)) || not hasJsSupport) + hasJsSupport = case hostPlatform lbi of + Platform JavaScript _ -> True + _ -> False + has_code = not (componentIsIndefinite clbi) + whenHasCode = when has_code + whenVanilla = when (hasLib && withVanillaLib lbi) + whenProf = when (hasLib && withProfLib lbi && has_code) + whenGHCi = when (hasLib && withGHCiLib lbi && has_code) + whenShared = when (hasLib && withSharedLib lbi && has_code) + +-- ----------------------------------------------------------------------------- +-- Registering + +hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo +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 + +registerPackage + :: Verbosity + -> ProgramDb + -> PackageDBStack + -> InstalledPackageInfo + -> HcPkg.RegisterOptions + -> IO () +registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = + HcPkg.register + (hcPkgInfo progdb) + verbosity + packageDbs + installedPkgInfo + registerOptions + +pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath +pkgRoot verbosity lbi = pkgRoot' + where + pkgRoot' GlobalPackageDB = + let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi) + in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg) + pkgRoot' UserPackageDB = do + appDir <- getGhcAppDir + let ver = compilerVersion (compiler lbi) + subdir = + System.Info.arch + ++ '-' + : System.Info.os + ++ '-' + : prettyShow ver + rootDir = appDir subdir + -- We must create the root directory for the user package database if it + -- does not yet exists. Otherwise '${pkgroot}' will resolve to a + -- directory at the time of 'ghc-pkg register', and registration will + -- fail. + createDirectoryIfMissing True rootDir + return rootDir + pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp) diff --git a/src/Distribution/Simple/GHC/Build.hs b/src/Distribution/Simple/GHC/Build.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHC/Build.hs @@ -0,0 +1,140 @@ +module Distribution.Simple.GHC.Build where + +import Distribution.Compat.Prelude +import Prelude () + +import Control.Monad.IO.Class +import qualified Data.Set as Set +import Distribution.PackageDescription as PD hiding (buildInfo) +import Distribution.Simple.Build.Inputs +import Distribution.Simple.Flag (Flag) +import Distribution.Simple.GHC.Build.ExtraSources +import Distribution.Simple.GHC.Build.Link +import Distribution.Simple.GHC.Build.Modules +import Distribution.Simple.GHC.Build.Utils (withDynFLib) +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Types.ComponentLocalBuildInfo (componentIsIndefinite) +import Distribution.Types.ParStrat +import Distribution.Utils.NubList (fromNubListR) +import System.Directory hiding (exeExtension) +import System.FilePath + +{- +Note [Build Target Dir vs Target Dir] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Where to place the build result (targetDir) and the build artifacts (buildTargetDir). + +\* For libraries, targetDir == buildTargetDir, where both the library and +artifacts are put together. + +\* For executables or foreign libs, buildTargetDir == targetDir/-tmp, where + the targetDir is the location where the target (e.g. the executable) is written to + and buildTargetDir is where the compilation artifacts (e.g. Main.o) will live + Arguably, this difference should not exist (#9498) (TODO) + +For instance, for a component `cabal-benchmarks`: + targetDir == /cabal-benchmarks + buildTargetDir == /cabal-benchmarks/cabal-benchmarks-tmp + +Or, for a library `Cabal`: + targetDir == /. + buildTargetDir == targetDir + +Furthermore, we need to account for the limit of characters in ghc +invocations that different OSes constrain us to. Cabal invocations can +rapidly reach this limit, in part, due to the long length of cabal v2 +prefixes. To minimize the likelihood, we use +`makeRelativeToCurrentDirectory` to shorten the paths used in invocations +(see da6321bb). + +However, in executables, we don't do this. It seems that we don't need to do it +for executable-like components because the linking step, instead of passing as +an argument the path to each module, it simply passes the module name, the sources dir, and --make. +RM: I believe we can use --make + module names instead of paths-to-objects +for linking libraries too (2024-01) (TODO) +-} + +-- | The main build phase of building a component. +-- Includes building Haskell modules, extra build sources, and linking. +build + :: Flag ParStrat + -> PackageDescription + -> PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO () +build numJobs pkg_descr pbci = do + let + verbosity = buildVerbosity pbci + component = buildComponent pbci + isLib = buildIsLib pbci + lbi = localBuildInfo pbci + clbi = buildCLBI pbci + + -- Create a few directories for building the component + -- See Note [Build Target Dir vs Target Dir] + let targetDir_absolute = componentBuildDir lbi clbi + buildTargetDir_absolute + -- Libraries use the target dir for building (see above) + | isLib = targetDir_absolute + -- In other cases, use targetDir/-tmp + | targetDirName : _ <- reverse $ splitDirectories targetDir_absolute = + targetDir_absolute (targetDirName ++ "-tmp") + | otherwise = error "GHC.build: targetDir is empty" + + liftIO $ do + createDirectoryIfMissingVerbose verbosity True targetDir_absolute + createDirectoryIfMissingVerbose verbosity True buildTargetDir_absolute + + -- See Note [Build Target Dir vs Target Dir] as well + _targetDir <- liftIO $ makeRelativeToCurrentDirectory targetDir_absolute + buildTargetDir <- + -- To preserve the previous behaviour, we don't use relative dirs for + -- executables. Historically, this isn't needed to reduce the CLI limit + -- (unlike for libraries) because we link executables with the module names + -- instead of passing the path to object file -- that's something else we + -- can now fix after the refactor lands. + if isLib + then liftIO $ makeRelativeToCurrentDirectory buildTargetDir_absolute + else return buildTargetDir_absolute + + (ghcProg, _) <- liftIO $ requireProgram verbosity ghcProgram (withPrograms lbi) + + -- Determine in which ways we want to build the component + let + wantVanilla = if isLib then withVanillaLib lbi else False + -- Arguably, wantStatic should be "withFullyStaticExe lbi" for executables, + -- but it was not before the refactor. + wantStatic = if isLib then withStaticLib lbi else not (wantDynamic || wantProf) + wantDynamic = case component of + CLib{} -> withSharedLib lbi + CFLib flib -> withDynFLib flib + CExe{} -> withDynExe lbi + CTest{} -> withDynExe lbi + CBench{} -> withDynExe lbi + wantProf = if isLib then withProfLib lbi else withProfExe lbi + + -- See also Note [Building Haskell Modules accounting for TH] in Distribution.Simple.GHC.Build.Modules + -- We build static by default if no other way is wanted. + -- For executables and foreign libraries, there should only be one wanted way. + wantedWays = + Set.fromList $ + -- If building a library, we accumulate all the ways, + -- otherwise, we take just one. + (if isLib then id else take 1) $ + [ProfWay | wantProf] + -- I don't see why we shouldn't build with dynamic + -- indefinite components. + <> [DynWay | wantDynamic && not (componentIsIndefinite clbi)] + <> [StaticWay | wantStatic || wantVanilla || not (wantDynamic || wantProf)] + + liftIO $ info verbosity ("Wanted build ways: " ++ show (Set.toList wantedWays)) + + -- 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). + buildOpts <- buildHaskellModules numJobs ghcProg pkg_descr buildTargetDir_absolute wantedWays pbci + extraSources <- buildAllExtraSources ghcProg buildTargetDir pbci + linkOrLoadComponent ghcProg pkg_descr (fromNubListR extraSources) (buildTargetDir, targetDir_absolute) (wantedWays, buildOpts) pbci diff --git a/src/Distribution/Simple/GHC/Build/ExtraSources.hs b/src/Distribution/Simple/GHC/Build/ExtraSources.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHC/Build/ExtraSources.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Distribution.Simple.GHC.Build.ExtraSources where + +import Control.Monad +import Data.Foldable +import Distribution.Simple.Flag +import qualified Distribution.Simple.GHC.Internal as Internal +import Distribution.Simple.Program.GHC +import Distribution.Simple.Utils +import Distribution.Utils.NubList + +import Distribution.Types.BuildInfo +import Distribution.Types.Component +import Distribution.Types.TargetInfo + +import Distribution.Simple.GHC.Build.Utils +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program.Types +import Distribution.System (Arch (JavaScript), Platform (..)) +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.Executable +import Distribution.Verbosity (Verbosity) + +import Distribution.Simple.Build.Inputs + +-- | An action that builds all the extra build sources of a component, i.e. C, +-- C++, Js, Asm, C-- sources. +buildAllExtraSources + :: ConfiguredProgram + -- ^ The GHC configured program + -> FilePath + -- ^ The build directory for this target + -> PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO (NubListR FilePath) + -- ^ Returns the (nubbed) list of extra sources that were built +buildAllExtraSources = + mconcat + [ buildCSources + , buildCxxSources + , buildJsSources + , buildAsmSources + , buildCmmSources + ] + +buildCSources + , buildCxxSources + , buildJsSources + , buildAsmSources + , buildCmmSources + :: ConfiguredProgram + -- ^ The GHC configured program + -> FilePath + -- ^ The build directory for this target + -> PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO (NubListR FilePath) + -- ^ Returns the list of extra sources that were built +buildCSources = + buildExtraSources + "C Sources" + Internal.componentCcGhcOptions + True + ( \c -> + cSources (componentBuildInfo c) + ++ case c of + CExe exe | isC (modulePath exe) -> [modulePath exe] + _otherwise -> [] + ) +buildCxxSources = + buildExtraSources + "C++ Sources" + Internal.componentCxxGhcOptions + True + ( \c -> + cxxSources (componentBuildInfo c) + ++ case c of + CExe exe | isCxx (modulePath exe) -> [modulePath exe] + _otherwise -> [] + ) +buildJsSources ghcProg buildTargetDir = do + Platform hostArch _ <- hostPlatform <$> localBuildInfo + let hasJsSupport = hostArch == JavaScript + buildExtraSources + "JS Sources" + Internal.componentJsGhcOptions + False + ( \c -> + if hasJsSupport + then -- JS files are C-like with GHC's JS backend: they are + -- "compiled" into `.o` files (renamed with a header). + -- This is a difference from GHCJS, for which we only + -- pass the JS files at link time. + jsSources (componentBuildInfo c) + else mempty + ) + ghcProg + buildTargetDir +buildAsmSources = + buildExtraSources + "Assembler Sources" + Internal.componentAsmGhcOptions + True + (asmSources . componentBuildInfo) +buildCmmSources = + buildExtraSources + "C-- Sources" + Internal.componentCmmGhcOptions + True + (cmmSources . componentBuildInfo) + +-- | Create 'PreBuildComponentRules' for a given type of extra build sources +-- which are compiled via a GHC invocation with the given options. Used to +-- define built-in extra sources, such as, C, Cxx, Js, Asm, and Cmm sources. +buildExtraSources + :: String + -- ^ String describing the extra sources being built, for printing. + -> (Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> GhcOptions) + -- ^ Function to determine the @'GhcOptions'@ for the + -- invocation of GHC when compiling these extra sources (e.g. + -- @'Internal.componentCxxGhcOptions'@, + -- @'Internal.componentCmmGhcOptions'@) + -> Bool + -- ^ Some types of build sources should not be built in the dynamic way, namely, JS sources. + -- I'm not entirely sure this remains true after we migrate to supporting GHC's JS backend rather than GHCJS. + -- Boolean for "do we allow building these sources the dynamic way?" + -> (Component -> [FilePath]) + -- ^ View the extra sources of a component, typically from + -- the build info (e.g. @'asmSources'@, @'cSources'@). + -- @'Executable'@ components might additionally add the + -- program entry point (@main-is@ file) to the extra sources, + -- if it should be compiled as the rest of them. + -> ConfiguredProgram + -- ^ The GHC configured program + -> FilePath + -- ^ The build directory for this target + -> PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO (NubListR FilePath) + -- ^ Returns the list of extra sources that were built +buildExtraSources description componentSourceGhcOptions wantDyn viewSources ghcProg buildTargetDir = + \PreBuildComponentInputs{buildingWhat, localBuildInfo = lbi, targetInfo} -> + let + bi = componentBuildInfo (targetComponent targetInfo) + verbosity = buildingWhatVerbosity buildingWhat + clbi = targetCLBI targetInfo + + sources = viewSources (targetComponent targetInfo) + + comp = compiler lbi + platform = hostPlatform lbi + -- Instead of keeping this logic here, we really just want to + -- receive as an input the `neededWays` from GHC/Build.build and build + -- accordingly, since we've already determined the extra needed ways + -- needed for e.g. template haskell. Although we'd have to account for 'wantDyn'. + isGhcDynamic = isDynamic comp + doingTH = usesTemplateHaskellOrQQ bi + forceSharedLib = doingTH && isGhcDynamic + runGhcProg = runGHC verbosity ghcProg comp platform + + buildAction sourceFile = do + let baseSrcOpts = + componentSourceGhcOptions + verbosity + lbi + bi + clbi + buildTargetDir + sourceFile + vanillaSrcOpts + -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + | isGhcDynamic && wantDyn = baseSrcOpts{ghcOptFPic = toFlag True} + | otherwise = baseSrcOpts + profSrcOpts = + vanillaSrcOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + } + sharedSrcOpts = + vanillaSrcOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + -- TODO: Placing all Haskell, C, & C++ objects in a single directory + -- Has the potential for file collisions. In general we would + -- consider this a user error. However, we should strive to + -- add a warning if this occurs. + odir = fromFlag (ghcOptObjDir vanillaSrcOpts) + compileIfNeeded opts = do + needsRecomp <- checkNeedsRecompilation sourceFile opts + when needsRecomp $ runGhcProg opts + + -- TODO: This whole section can be streamlined to the + -- wantedWays+neededWays logic used in Build/Modules.hs + createDirectoryIfMissingVerbose verbosity True odir + case targetComponent targetInfo of + -- For libraries, we compile extra objects in the three ways: vanilla, shared, and profiled. + -- We suffix shared objects with .dyn_o and profiled ones with .p_o. + CLib _lib + -- Unless for repl, in which case we only need the vanilla way + | BuildRepl _ <- buildingWhat -> + compileIfNeeded vanillaSrcOpts + | otherwise -> + do + compileIfNeeded vanillaSrcOpts + when (wantDyn && (forceSharedLib || withSharedLib lbi)) $ + compileIfNeeded sharedSrcOpts{ghcOptObjSuffix = toFlag "dyn_o"} + when (withProfLib lbi) $ + compileIfNeeded profSrcOpts{ghcOptObjSuffix = toFlag "p_o"} + + -- For foreign libraries, we determine with which options to build the + -- objects (vanilla vs shared vs profiled) + CFLib flib + | withProfExe lbi -> -- It doesn't sound right to query "ProfExe" for a foreign library... + compileIfNeeded profSrcOpts + | withDynFLib flib && wantDyn -> + compileIfNeeded sharedSrcOpts + | otherwise -> + compileIfNeeded vanillaSrcOpts + -- For the remaining component types (Exec, Test, Bench), we also + -- determine with which options to build the objects (vanilla vs shared vs + -- profiled), but predicate is the same for the three kinds. + _exeLike + | withProfExe lbi -> + compileIfNeeded profSrcOpts + | withDynExe lbi && wantDyn -> + compileIfNeeded sharedSrcOpts + | otherwise -> + compileIfNeeded vanillaSrcOpts + in + -- build any sources + if (null sources || componentIsIndefinite clbi) + then return mempty + else do + info verbosity ("Building " ++ description ++ "...") + traverse_ buildAction sources + return (toNubListR sources) diff --git a/src/Distribution/Simple/GHC/Build/Link.hs b/src/Distribution/Simple/GHC/Build/Link.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHC/Build/Link.hs @@ -0,0 +1,663 @@ +{-# LANGUAGE LambdaCase #-} + +module Distribution.Simple.GHC.Build.Link where + +import Distribution.Compat.Prelude +import Prelude () + +import Control.Exception (assert) +import Control.Monad (forM_) +import Control.Monad.IO.Class +import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Data.Set as Set +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) +import Distribution.Pretty +import Distribution.Simple.Build.Inputs +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.GHC.Build.Modules +import Distribution.Simple.GHC.Build.Utils (exeTargetName, flibBuildName, flibTargetName, 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 +import qualified Distribution.Simple.Program.Ld as Ld +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Repl +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Utils.NubList +import Distribution.Verbosity +import Distribution.Version +import System.Directory +import System.FilePath + +-- | Links together the object files of the Haskell modules and extra sources +-- using the context in which the component is being built. +-- +-- If the build kind is 'BuildRepl', we load the component into GHCi instead of linking. +linkOrLoadComponent + :: ConfiguredProgram + -- ^ The configured GHC program that will be used for linking + -> PackageDescription + -- ^ The package description containing the component being built + -> [FilePath] + -- ^ The full list of extra build sources (all C, C++, Js, + -- Asm, and Cmm sources), which were compiled to object + -- files. + -> (FilePath, FilePath) + -- ^ The build target dir, and the target dir. + -- See Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build + -> (Set.Set BuildWay, BuildWay -> GhcOptions) + -- ^ The set of build ways wanted based on the user opts, and a function to + -- convert a build way into the set of ghc options that were used to build + -- that way. + -> PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO () +linkOrLoadComponent ghcProg pkg_descr extraSources (buildTargetDir, targetDir) (wantedWays, buildOpts) pbci = do + let + verbosity = buildVerbosity pbci + target = targetInfo pbci + component = buildComponent pbci + what = buildingWhat pbci + lbi = localBuildInfo pbci + bi = buildBI pbci + clbi = buildCLBI pbci + + -- ensure extra lib dirs exist before passing to ghc + cleanedExtraLibDirs <- liftIO $ filterM doesDirectoryExist (extraLibDirs bi) + cleanedExtraLibDirsStatic <- liftIO $ filterM doesDirectoryExist (extraLibDirsStatic bi) + + let + extraSourcesObjs = map (`replaceExtension` objExtension) extraSources + + -- TODO: Shouldn't we use withStaticLib for libraries and something else + -- for foreign libs in the three cases where we use `withFullyStaticExe` below? + linkerOpts rpaths = + mempty + { ghcOptLinkOptions = + PD.ldOptions bi + ++ [ "-static" + | withFullyStaticExe lbi + ] + -- Pass extra `ld-options` given + -- through to GHC's linker. + ++ maybe + [] + programOverrideArgs + (lookupProgram ldProgram (withPrograms lbi)) + , ghcOptLinkLibs = + if withFullyStaticExe lbi + then extraLibsStatic bi + else extraLibs bi + , ghcOptLinkLibPath = + toNubListR $ + if withFullyStaticExe lbi + then cleanedExtraLibDirsStatic + else cleanedExtraLibDirs + , ghcOptLinkFrameworks = toNubListR $ PD.frameworks bi + , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs bi + , ghcOptInputFiles = toNubListR [buildTargetDir x | x <- extraSourcesObjs] + , ghcOptNoLink = Flag False + , ghcOptRPaths = rpaths + } + case what of + BuildRepl replFlags -> liftIO $ do + let + -- For repl we use the vanilla (static) ghc options + staticOpts = buildOpts StaticWay + replOpts = + staticOpts + { -- Repl options use Static as the base, but doesn't need to pass -static. + -- However, it maybe should, for uniformity. + ghcOptDynLinkMode = NoFlag + , ghcOptExtra = + Internal.filterGhciFlags + (ghcOptExtra staticOpts) + <> replOptionsFlags (replReplOptions replFlags) + , ghcOptInputModules = replNoLoad (replReplOptions replFlags) (ghcOptInputModules staticOpts) + , ghcOptInputFiles = replNoLoad (replReplOptions replFlags) (ghcOptInputFiles staticOpts) + } + -- For a normal compile we do separate invocations of ghc for + -- compiling as for linking. But for repl we have to do just + -- the one invocation, so that one has to include all the + -- linker stuff too, like -l flags and any .o files from C + -- files etc. + -- + -- TODO: The repl doesn't use the runtime paths from linkerOpts + -- (ghcOptRPaths), which looks like a bug. After the refactor we + -- can fix this. + `mappend` linkerOpts mempty + `mappend` mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptOptimisation = toFlag GhcNoOptimisation + } + + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + when (case component of CLib lib -> null (allLibModules lib clbi); _ -> False) $ + warn verbosity "No exposed modules" + runReplOrWriteFlags ghcProg lbi replFlags replOpts (pkgName (PD.package pkg_descr)) target + _otherwise -> + let + runGhcProg = runGHC verbosity ghcProg comp platform + platform = hostPlatform lbi + comp = compiler lbi + in + when (not $ componentIsIndefinite clbi) $ do + -- If not building dynamically, we don't pass any runtime paths. + rpaths <- if DynWay `Set.member` wantedWays then getRPaths pbci else return (toNubListR []) + liftIO $ do + info verbosity "Linking..." + let linkExeLike name = linkExecutable (linkerOpts rpaths) (wantedWays, buildOpts) targetDir name runGhcProg lbi + case component of + CLib lib -> linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWays + CFLib flib -> linkFLib flib bi lbi (linkerOpts rpaths) (wantedWays, buildOpts) targetDir runGhcProg + CExe exe -> linkExeLike (exeName exe) + CTest test -> linkExeLike (testName test) + CBench bench -> linkExeLike (benchmarkName bench) + +-- | Link a library component +linkLibrary + :: FilePath + -- ^ The library target build directory + -> [FilePath] + -- ^ 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 + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> [FilePath] + -- ^ Extra build sources (that were compiled to objects) + -> NubListR FilePath + -- ^ A list with the runtime-paths (rpaths), or empty if not linking dynamically + -> Set.Set BuildWay + -- ^ Wanted build ways and corresponding build options + -> IO () +linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWays = do + let + 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 mkLibName uid + profileLibFilePath = buildTargetDir mkProfLibName uid + sharedLibFilePath = + buildTargetDir + mkSharedLibName (hostPlatform lbi) compiler_id uid + staticLibFilePath = + buildTargetDir + mkStaticLibName (hostPlatform lbi) compiler_id uid + ghciLibFilePath = buildTargetDir Internal.mkGHCiLibName uid + ghciProfLibFilePath = buildTargetDir Internal.mkGHCiProfLibName uid + libInstallPath = + libdir $ + absoluteComponentInstallDirs + pkg_descr + lbi + uid + NoCopyDest + sharedLibInstallPath = + libInstallPath + mkSharedLibName (hostPlatform lbi) compiler_id uid + + getObjFiles way = + mconcat + [ Internal.getHaskellObjects + implInfo + lib + lbi + clbi + buildTargetDir + (buildWayPrefix way ++ objExtension) + True + , pure $ + map (buildTargetDir ) $ + map ((`replaceExtension` (buildWayPrefix way ++ objExtension))) extraSources + , catMaybes + <$> sequenceA + [ findFileWithExtension + [Suffix $ buildWayPrefix way ++ objExtension] + [buildTargetDir] + (ModuleName.toFilePath x ++ "_stub") + | ghcVersion < mkVersion [7, 2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi + ] + ] + + -- 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 + -- -shared...). The downside to doing this is that GHC would have to + -- reconstruct the module graph again. + -- That would mean linking the lib would be just like the executable, and + -- we could more easily merge the two. + -- + -- Right now, instead, we pass the path to each object file. + 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 + } + + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs dynObjectFiles = + ghcBaseLinkArgs + { ghcOptShared = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptInputFiles = toNubListR 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 + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs + , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi + , ghcOptLinkFrameworkDirs = + toNubListR $ PD.extraFrameworkDirs libBi + , ghcOptRPaths = rpaths + } + ghcStaticLinkArgs staticObjectFiles = + ghcBaseLinkArgs + { ghcOptStaticLib = toFlag True + , ghcOptInputFiles = toNubListR staticObjectFiles + , ghcOptOutputFile = toFlag staticLibFilePath + , ghcOptLinkLibs = extraLibs libBi + , -- TODO: Shouldn't this use cleanedExtraLibDirsStatic instead? + ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs + } + + staticObjectFiles <- getObjFiles StaticWay + profObjectFiles <- getObjFiles ProfWay + dynamicObjectFiles <- getObjFiles DynWay + + let + linkWay = \case + ProfWay -> do + Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles + when (withGHCiLib lbi) $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles + verbosity + lbi + ldProg + ghciProfLibFilePath + profObjectFiles + DynWay -> do + runGhcProg $ ghcSharedLinkArgs dynamicObjectFiles + StaticWay -> do + when (withVanillaLib lbi) $ do + Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles + when (withGHCiLib lbi) $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles + verbosity + lbi + ldProg + ghciLibFilePath + staticObjectFiles + when (withStaticLib lbi) $ do + runGhcProg $ ghcStaticLinkArgs staticObjectFiles + + -- 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))) + traverse_ linkWay wantedWays + +-- | Link the executable resulting from building this component, be it an +-- executable, test, or benchmark component. +linkExecutable + :: (GhcOptions) + -- ^ The linker-specific GHC options + -> (Set.Set BuildWay, BuildWay -> GhcOptions) + -- ^ The wanted build ways and corresponding GhcOptions that were + -- used to compile the modules in that way. + -> FilePath + -- ^ The target dir (2024-01:note: not the same as build target + -- dir, see Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build) + -> UnqualComponentName + -- ^ Name of executable-like target + -> (GhcOptions -> IO ()) + -- ^ Run the configured GHC program + -> LocalBuildInfo + -> IO () +linkExecutable linkerOpts (wantedWays, buildOpts) targetDir targetName runGhcProg lbi = do + -- When building an executable, we should only "want" one build way. + assert (Set.size wantedWays == 1) $ + forM_ wantedWays $ \way -> do + let baseOpts = buildOpts way + linkOpts = + baseOpts + `mappend` linkerOpts + `mappend` mempty + { -- If there are no input Haskell files we pass -no-hs-main, and + -- 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 exeTargetName (hostPlatform lbi) targetName + when (compilerVersion comp < mkVersion [7, 7]) $ do + e <- doesFileExist target + when e (removeFile target) + runGhcProg linkOpts{ghcOptOutputFile = toFlag target} + +-- | Link a foreign library component +linkFLib + :: ForeignLib + -> BuildInfo + -> LocalBuildInfo + -> (GhcOptions) + -- ^ The linker-specific GHC options + -> (Set.Set BuildWay, BuildWay -> GhcOptions) + -- ^ The wanted build ways and corresponding GhcOptions that were + -- used to compile the modules in that way. + -> FilePath + -- ^ The target dir (2024-01:note: not the same as build target + -- dir, see Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build) + -> (GhcOptions -> IO ()) + -- ^ Run the configured GHC program + -> IO () +linkFLib flib bi lbi linkerOpts (wantedWays, buildOpts) targetDir runGhcProg = do + let + comp = compiler lbi + + -- Instruct GHC to link against libHSrts. + rtsLinkOpts :: GhcOptions + rtsLinkOpts + | supportsFLinkRts = + mempty + { ghcOptLinkRts = toFlag True + } + | otherwise = + mempty + { ghcOptLinkLibs = rtsOptLinkLibs + , ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo + } + where + threaded = hasThreaded bi + supportsFLinkRts = compilerVersion comp >= mkVersion [9, 0] + rtsInfo = extractRtsInfo lbi + rtsOptLinkLibs = + [ if withDynFLib flib + then + if threaded + then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) + else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) + else + if threaded + then statRtsThreadedLib (rtsStaticInfo rtsInfo) + else statRtsVanillaLib (rtsStaticInfo rtsInfo) + ] + + linkOpts :: BuildWay -> GhcOptions + linkOpts way = case foreignLibType flib of + ForeignLibNativeShared -> + (buildOpts way) + `mappend` linkerOpts + `mappend` rtsLinkOpts + `mappend` mempty + { ghcOptLinkNoHsMain = toFlag True + , ghcOptShared = toFlag True + , ghcOptFPic = toFlag True + , ghcOptLinkModDefFiles = toNubListR $ foreignLibModDefFile flib + } + ForeignLibNativeStatic -> + -- this should be caught by buildFLib + -- (and if we do implement this, we probably don't even want to call + -- ghc here, but rather Ar.createArLibArchive or something) + cabalBug "static libraries not yet implemented" + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" + -- We build under a (potentially) different filename to set a + -- soname on supported platforms. See also the note for + -- @flibBuildName@. + let buildName = flibBuildName lbi flib + -- There should not be more than one wanted way when building an flib + assert (Set.size wantedWays == 1) $ + forM_ wantedWays $ \way -> do + runGhcProg (linkOpts way){ghcOptOutputFile = toFlag (targetDir buildName)} + renameFile (targetDir buildName) (targetDir flibTargetName lbi flib) + +-- | Calculate the RPATHs for the component we are building. +-- +-- Calculates relative RPATHs when 'relocatable' is set. +getRPaths + :: PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO (NubListR FilePath) +getRPaths pbci = do + let + lbi = localBuildInfo pbci + bi = buildBI pbci + clbi = buildCLBI pbci + + (Platform _ hostOS) = hostPlatform lbi + compid = compilerId . compiler $ lbi + + -- The list of RPath-supported operating systems below reflects the + -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ + -- reflect whether the OS supports RPATH. + + -- E.g. when this comment was written, the *BSD operating systems were + -- untested with regards to Cabal RPATH handling, and were hence set to + -- 'False', while those operating systems themselves do support RPATH. + supportRPaths Linux = True + supportRPaths Windows = False + supportRPaths OSX = True + supportRPaths FreeBSD = + case compid of + CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True + _ -> False + supportRPaths OpenBSD = False + supportRPaths NetBSD = False + supportRPaths DragonFly = False + supportRPaths Solaris = False + supportRPaths AIX = False + supportRPaths HPUX = False + supportRPaths IRIX = False + supportRPaths HaLVM = False + supportRPaths IOS = False + supportRPaths Android = False + supportRPaths Ghcjs = False + supportRPaths Wasi = False + supportRPaths Hurd = True + supportRPaths Haiku = False + supportRPaths (OtherOS _) = False + -- Do _not_ add a default case so that we get a warning here when a new OS + -- is added. + + if supportRPaths hostOS + then do + libraryPaths <- liftIO $ depLibraryPaths False (relocatable lbi) lbi clbi + let hostPref = case hostOS of + OSX -> "@loader_path" + _ -> "$ORIGIN" + relPath p = if isRelative p then hostPref p else p + rpaths = toNubListR (map relPath libraryPaths) <> toNubListR (extraLibDirs bi) + return rpaths + else return mempty + +data DynamicRtsInfo = DynamicRtsInfo + { dynRtsVanillaLib :: FilePath + , dynRtsThreadedLib :: FilePath + , dynRtsDebugLib :: FilePath + , dynRtsEventlogLib :: FilePath + , dynRtsThreadedDebugLib :: FilePath + , dynRtsThreadedEventlogLib :: FilePath + } + +data StaticRtsInfo = StaticRtsInfo + { statRtsVanillaLib :: FilePath + , statRtsThreadedLib :: FilePath + , statRtsDebugLib :: FilePath + , statRtsEventlogLib :: FilePath + , statRtsThreadedDebugLib :: FilePath + , statRtsThreadedEventlogLib :: FilePath + , statRtsProfilingLib :: FilePath + , statRtsThreadedProfilingLib :: FilePath + } + +data RtsInfo = RtsInfo + { rtsDynamicInfo :: DynamicRtsInfo + , rtsStaticInfo :: StaticRtsInfo + , rtsLibPaths :: [FilePath] + } + +-- | Extract (and compute) information about the RTS library +-- +-- TODO: This hardcodes the name as @HSrts-ghc@. I don't know if we can +-- find this information somewhere. We can lookup the 'hsLibraries' field of +-- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which +-- doesn't really help. +extractRtsInfo :: LocalBuildInfo -> RtsInfo +extractRtsInfo lbi = + case PackageIndex.lookupPackageName + (installedPkgs lbi) + (mkPackageName "rts") of + [(_, [rts])] -> aux rts + _otherwise -> error "No (or multiple) ghc rts package is registered" + where + aux :: InstalledPackageInfo -> RtsInfo + aux rts = + RtsInfo + { rtsDynamicInfo = + DynamicRtsInfo + { dynRtsVanillaLib = withGhcVersion "HSrts" + , dynRtsThreadedLib = withGhcVersion "HSrts_thr" + , dynRtsDebugLib = withGhcVersion "HSrts_debug" + , dynRtsEventlogLib = withGhcVersion "HSrts_l" + , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" + , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" + } + , rtsStaticInfo = + StaticRtsInfo + { statRtsVanillaLib = "HSrts" + , statRtsThreadedLib = "HSrts_thr" + , statRtsDebugLib = "HSrts_debug" + , statRtsEventlogLib = "HSrts_l" + , statRtsThreadedDebugLib = "HSrts_thr_debug" + , statRtsThreadedEventlogLib = "HSrts_thr_l" + , statRtsProfilingLib = "HSrts_p" + , statRtsThreadedProfilingLib = "HSrts_thr_p" + } + , rtsLibPaths = InstalledPackageInfo.libraryDirs rts + } + withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) + +-- | Determine whether the given 'BuildInfo' is intended to link against the +-- 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 + where + PerCompilerFlavor ghc _ = options bi + +-- | Load a target component into a repl, or write to disk a script which runs +-- GHCi with the GHC options Cabal elaborated to load the component interactively. +runReplOrWriteFlags + :: ConfiguredProgram + -> LocalBuildInfo + -> ReplFlags + -> GhcOptions + -> PackageName + -> TargetInfo + -> IO () +runReplOrWriteFlags ghcProg lbi rflags ghcOpts pkg_name target = + let bi = componentBuildInfo $ targetComponent target + clbi = targetCLBI target + comp = compiler lbi + platform = hostPlatform lbi + in case replOptionsFlagOutput (replReplOptions rflags) of + NoFlag -> runGHC (fromFlag $ replVerbosity rflags) ghcProg comp platform ghcOpts + Flag out_dir -> do + src_dir <- getCurrentDirectory + let uid = componentUnitId clbi + this_unit = prettyShow uid + reexported_modules = [mn | LibComponentLocalBuildInfo{} <- [clbi], IPI.ExposedModule mn (Just{}) <- componentExposedModules clbi] + hidden_modules = otherModules bi + extra_opts = + concat $ + [ ["-this-package-name", prettyShow pkg_name] + , ["-working-dir", src_dir] + ] + ++ [ ["-reexported-module", prettyShow m] | m <- reexported_modules + ] + ++ [ ["-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") + -- Write out the PATH information into `paths` subdirectory. + writeFileAtomic (out_dir "paths" this_unit) (encode ghcProg) + -- Write out options for this component into a file ready for loading into + -- the multi-repl + writeFileAtomic (out_dir this_unit) $ + BS.pack $ + escapeArgs $ + extra_opts ++ renderGhcOptions comp platform (ghcOpts{ghcOptMode = NoFlag}) + +replNoLoad :: Ord a => ReplOptions -> NubListR a -> NubListR a +replNoLoad replFlags l + | replOptionsNoLoad replFlags == Flag True = mempty + | otherwise = l diff --git a/src/Distribution/Simple/GHC/Build/Modules.hs b/src/Distribution/Simple/GHC/Build/Modules.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHC/Build/Modules.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} + +module Distribution.Simple.GHC.Build.Modules (buildHaskellModules, BuildWay (..), buildWayPrefix) where + +import Control.Monad.IO.Class +import Distribution.Compat.Prelude + +import Data.List (sortOn, (\\)) +import qualified Data.Set as Set +import Distribution.CabalSpecVersion +import Distribution.ModuleName (ModuleName) +import qualified Distribution.PackageDescription as PD +import Distribution.Pretty +import Distribution.Simple.Build.Inputs +import Distribution.Simple.Compiler +import Distribution.Simple.GHC.Build.Utils +import qualified Distribution.Simple.GHC.Internal as Internal +import qualified Distribution.Simple.Hpc as Hpc +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program.GHC +import Distribution.Simple.Program.Types +import Distribution.Simple.Setup.Common +import Distribution.Simple.Utils +import Distribution.Types.Benchmark +import Distribution.Types.BenchmarkInterface +import Distribution.Types.BuildInfo +import Distribution.Types.Executable +import Distribution.Types.ForeignLib +import Distribution.Types.PackageName.Magic +import Distribution.Types.ParStrat +import Distribution.Types.TestSuite +import Distribution.Types.TestSuiteInterface +import Distribution.Utils.NubList +import System.FilePath + +{- +Note [Building Haskell Modules accounting for TH] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are multiple ways in which we may want to build our Haskell modules: + * The static way (-static) + * 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 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. +This can happen because of Template Haskell. + +When we're using Template Haskell, we /need/ to additionally build modules with +the used GHC's default/vanilla ABI. This is because the code that TH needs to +run at compile time needs to be the vanilla ABI so it can be loaded up and run +by the compiler. With dynamic-by-default GHC the TH object files loaded at +compile-time need to be .dyn_o instead of .o. + + * If the GHC is dynamic by default, that means we may need to also build + the dynamic way in addition the wanted way. + + * If the GHC is static by default, we may need to build statically additionally. + +Of course, if the /wanted/ way is the way additionally /needed/ for TH, we don't need to do extra work. + +If it turns out that in the end we need to build both statically and +dynamically, we want to make use of GHC's -static -dynamic-too capability, which +builds modules in the two ways in a single invocation. + +If --dynamic-too is not supported by the GHC, then we need to be careful about +the order in which modules are built. Specifically, we must first build the +modules for TH with the vanilla ABI, and only afterwards the desired +(non-default) ways. + +A few examples: + +To build an executable with profiling, with a dynamic by default GHC, and TH is used: + * Build dynamic (needed) objects + * Build profiled objects + +To build a library with profiling and dynamically, with a static by default GHC, and TH is used: + * Build dynamic (wanted) and static (needed) objects together with --dynamic-too + * Build profiled objects + +To build an executable statically, with a static by default GHC, regardless of whether TH is used: + * Simply build static objects + +-} + +-- | Compile the Haskell modules of the component being built. +buildHaskellModules + :: Flag ParStrat + -- ^ The parallelism strategy (e.g. num of jobs) + -> ConfiguredProgram + -- ^ The GHC configured program + -> PD.PackageDescription + -- ^ The package description + -> FilePath + -- ^ The path to the build directory for this target, which + -- has already been created. + -> Set.Set BuildWay + -- ^ The set of wanted build ways according to user options + -> PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO (BuildWay -> GhcOptions) + -- ^ Returns a mapping from build ways to the 'GhcOptions' used in the + -- 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 pkg_descr buildTargetDir wantedWays pbci = do + -- See Note [Building Haskell Modules accounting for TH] + + let + verbosity = buildVerbosity pbci + isLib = buildIsLib pbci + clbi = buildCLBI pbci + lbi = localBuildInfo pbci + bi = buildBI pbci + what = buildingWhat pbci + comp = buildCompiler pbci + + -- 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? + + -- 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 (buildTargetDir extraCompilationArtifacts) way + | otherwise = mempty + + (inputFiles, inputModules) <- componentInputs buildTargetDir pkg_descr pbci + + let + runGhcProg = runGHC verbosity ghcProg comp platform + platform = hostPlatform lbi + + -- See Note [Building Haskell Modules accounting for TH] + doingTH = usesTemplateHaskellOrQQ bi + + -- We define the base opts which are shared across different build ways in + -- 'buildHaskellModules' + baseOpts way = + (Internal.componentGhcOptions verbosity lbi bi clbi buildTargetDir) + `mappend` mempty + { ghcOptMode = toFlag GhcModeMake + , -- Previously we didn't pass -no-link when building libs, + -- but I think that could result in a bug (e.g. if a lib module is + -- called Main and exports main). So we really want nolink when + -- building libs too (TODO). + ghcOptNoLink = if isLib then NoFlag else toFlag True + , ghcOptNumJobs = numJobs + , ghcOptInputModules = toNubListR inputModules + , ghcOptInputFiles = + toNubListR $ + if PD.package pkg_descr == fakePackageId + then filter isHaskell inputFiles + else inputFiles + , ghcOptInputScripts = + toNubListR $ + if PD.package pkg_descr == fakePackageId + then filter (not . isHaskell) inputFiles + else [] + , ghcOptExtra = buildWayExtraHcOptions way GHC bi + , ghcOptHiSuffix = optSuffixFlag (buildWayPrefix way) "hi" + , ghcOptObjSuffix = optSuffixFlag (buildWayPrefix way) "o" + , ghcOptHPCDir = hpcdir (buildWayHpcWay way) -- maybe this should not be passed for vanilla? + } + where + optSuffixFlag "" _ = NoFlag + optSuffixFlag pre x = toFlag (pre ++ x) + + -- 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} + dynOpts = + (baseOpts DynWay) + { ghcOptDynLinkMode = toFlag GhcDynamicOnly -- use -dynamic + , -- TODO: Does it hurt to set -fPIC for executables? + ghcOptFPic = toFlag True -- use -fPIC + } + profOpts = + (baseOpts ProfWay) + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + (if isLib then True else False) + ((if isLib then withProfLibDetail else withProfExeDetail) lbi) + } + -- Options for building both static and dynamic way at the same time, using + -- the GHC flag -static and -dynamic-too + dynTooOpts = + (baseOpts StaticWay) + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic -- use -dynamic-too + , ghcOptDynHiSuffix = toFlag (buildWayPrefix DynWay ++ "hi") + , ghcOptDynObjSuffix = toFlag (buildWayPrefix DynWay ++ "o") + , ghcOptHPCDir = hpcdir Hpc.Dyn + -- Should we pass hcSharedOpts in the -dynamic-too ghc invocation? + -- (Note that `baseOtps StaticWay = hcStaticOptions`, not hcSharedOpts) + } + + -- Determines how to build for each way, also serves as the base options + -- for loading modules in 'linkOrLoadComponent' + buildOpts way = case way of + StaticWay -> staticOpts + DynWay -> dynOpts + ProfWay -> profOpts + + defaultGhcWay = if isDynamic comp then DynWay else StaticWay + + -- If there aren't modules, or if we're loading the modules in repl, don't build. + unless (forRepl || (null inputFiles && null inputModules)) $ liftIO $ do + -- See Note [Building Haskell Modules accounting for TH] + let + neededWays = + wantedWays + <> Set.fromList + -- TODO: You also don't need to build the GHC way when doing TH if + -- you are using an external interpreter!! + [defaultGhcWay | doingTH && defaultGhcWay `Set.notMember` wantedWays] + + -- If we need both static and dynamic, use dynamic-too instead of + -- compiling twice (if we support it) + useDynamicToo = + StaticWay `Set.member` neededWays + && DynWay `Set.member` neededWays + && supportsDynamicToo comp + && null (hcSharedOptions GHC bi) + + -- The ways we'll build, in order + orderedBuilds + -- If we can use dynamic-too, do it first. The default GHC way can only + -- be static or dynamic, so, if we build both right away, any modules + -- possibly needed by TH later (e.g. if building profiled) are already built. + | useDynamicToo = + [buildStaticAndDynamicToo] + ++ (runGhcProg . buildOpts <$> Set.toList neededWays \\ [StaticWay, DynWay]) + -- Otherwise, we need to ensure the defaultGhcWay is built first + | otherwise = + runGhcProg . buildOpts <$> sortOn (\w -> if w == defaultGhcWay then 0 else fromEnum w + 1) (Set.toList neededWays) + + buildStaticAndDynamicToo = do + runGhcProg dynTooOpts + case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of + (Flag dynDir, Flag vanillaDir) -> + -- When the vanilla and shared library builds are done + -- in one pass, only one set of HPC module interfaces + -- are generated. This set should suffice for both + -- static and dynamically linked executables. We copy + -- the modules interfaces so they are available under + -- both ways. + copyDirectoryRecursive verbosity dynDir vanillaDir + _ -> return () + in + -- REVIEW:ADD? info verbosity "Building Haskell Sources..." + sequence_ orderedBuilds + return buildOpts + +data BuildWay = StaticWay | DynWay | ProfWay + deriving (Eq, Ord, Show, 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_" + +-- | Returns the corresponding 'Hpc.Way' for a 'BuildWay' +buildWayHpcWay :: BuildWay -> Hpc.Way +buildWayHpcWay = \case + StaticWay -> Hpc.Vanilla + ProfWay -> Hpc.Prof + DynWay -> Hpc.Dyn + +-- | Returns a function to extract the extra haskell compiler options from a +-- 'BuildInfo' and 'CompilerFlavor' +buildWayExtraHcOptions :: BuildWay -> CompilerFlavor -> BuildInfo -> [String] +buildWayExtraHcOptions = \case + StaticWay -> hcStaticOptions + ProfWay -> hcProfOptions + DynWay -> hcSharedOptions + +-- | Returns a pair of the Haskell input files and Haskell modules of the +-- component being built. +-- +-- The "input files" are either the path to the main Haskell module, or a repl +-- script (that does not necessarily have an extension). +componentInputs + :: FilePath + -- ^ Target build dir + -> PD.PackageDescription + -> PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO ([FilePath], [ModuleName]) + -- ^ The Haskell input files, and the Haskell modules +componentInputs buildTargetDir pkg_descr pbci = do + let + verbosity = buildVerbosity pbci + component = buildComponent pbci + clbi = buildCLBI pbci + + case component of + CLib lib -> + pure ([], allLibModules lib clbi) + CFLib flib -> + pure ([], foreignLibModules flib) + CExe Executable{buildInfo = bi', modulePath} -> + exeLikeInputs verbosity bi' modulePath + CTest TestSuite{testBuildInfo = bi', testInterface = TestSuiteExeV10 _ mainFile} -> + exeLikeInputs verbosity bi' mainFile + CBench Benchmark{benchmarkBuildInfo = bi', benchmarkInterface = BenchmarkExeV10 _ mainFile} -> + exeLikeInputs verbosity bi' mainFile + CTest TestSuite{} -> error "testSuiteExeV10AsExe: wrong kind" + CBench Benchmark{} -> error "benchmarkExeV10asExe: wrong kind" + where + exeLikeInputs verbosity bnfo modulePath = liftIO $ do + main <- findExecutableMain verbosity buildTargetDir (bnfo, modulePath) + let mainModName = exeMainModuleName bnfo + otherModNames = otherModules bnfo + + -- Scripts have fakePackageId and are always Haskell but can have any extension. + if isHaskell main || PD.package pkg_descr == fakePackageId + then + if PD.specVersion pkg_descr < CabalSpecV2_0 && (mainModName `elem` otherModNames) + then do + -- The cabal manual clearly states that `other-modules` is + -- intended for non-main modules. However, there's at least one + -- important package on Hackage (happy-1.19.5) which + -- violates this. We workaround this here so that we don't + -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which + -- would result in GHC complaining about duplicate Main + -- modules. + -- + -- Finally, we only enable this workaround for + -- specVersion < 2, as 'cabal-version:>=2.0' cabal files + -- have no excuse anymore to keep doing it wrong... ;-) + warn verbosity $ + "Enabling workaround for Main module '" + ++ prettyShow mainModName + ++ "' listed in 'other-modules' illegally!" + return ([main], filter (/= mainModName) otherModNames) + else return ([main], otherModNames) + else return ([], otherModNames) diff --git a/src/Distribution/Simple/GHC/Build/Utils.hs b/src/Distribution/Simple/GHC/Build/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHC/Build/Utils.hs @@ -0,0 +1,217 @@ +module Distribution.Simple.GHC.Build.Utils where + +import Distribution.Compat.Prelude +import Prelude () + +import Control.Monad (msum) +import Data.Char (isLower) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription as PD +import Distribution.PackageDescription.Utils (cabalBug) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import qualified Distribution.Simple.GHC.Internal as Internal +import Distribution.Simple.Program.GHC +import Distribution.Simple.Setup.Common +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.LocalBuildInfo +import Distribution.Utils.Path (getSymbolicPath) +import Distribution.Verbosity +import System.FilePath + ( replaceExtension + , takeExtension + , (<.>) + , () + ) + +-- | Find the path to the entry point of an executable (typically specified in +-- @main-is@, and found in @hs-source-dirs@). +findExecutableMain + :: Verbosity + -> FilePath + -- ^ Build directory + -> (BuildInfo, FilePath) + -- ^ The build info and module path of an executable-like component (Exe, Test, Bench) + -> IO FilePath + -- ^ The path to the main source file. +findExecutableMain verbosity bdir (bnfo, modPath) = + findFileEx verbosity (bdir : map getSymbolicPath (hsSourceDirs bnfo)) modPath + +-- | Does this compiler support the @-dynamic-too@ option +supportsDynamicToo :: Compiler -> Bool +supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" + +-- | Is this compiler's RTS dynamically linked? +isDynamic :: Compiler -> Bool +isDynamic = Internal.ghcLookupProperty "GHC Dynamic" + +-- | Should we dynamically link the foreign library, based on its 'foreignLibType'? +withDynFLib :: ForeignLib -> Bool +withDynFLib flib = + case foreignLibType flib of + ForeignLibNativeShared -> + ForeignLibStandalone `notElem` foreignLibOptions flib + ForeignLibNativeStatic -> + False + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" + +-- | 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++"] + +-- | Is this a C source file, i.e. ends with .c? +isC :: FilePath -> Bool +isC fp = elem (takeExtension fp) [".c"] + +-- | FilePath has a Haskell extension: .hs or .lhs +isHaskell :: FilePath -> Bool +isHaskell fp = elem (takeExtension fp) [".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. +checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool +checkNeedsRecompilation filename opts = filename `moreRecentFile` oname + where + oname = getObjectFileName filename opts + +-- | Finds the object file name of the given source file +getObjectFileName :: FilePath -> GhcOptions -> FilePath +getObjectFileName filename opts = oname + where + odir = fromFlag (ghcOptObjDir opts) + oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) + oname = odir replaceExtension filename oext + +-- | Target name for a foreign library (the actual file name) +-- +-- We do not use mkLibName and co here because the naming for foreign libraries +-- is slightly different (we don't use "_p" or compiler version suffices, and we +-- don't want the "lib" prefix on Windows). +-- +-- TODO: We do use `dllExtension` and co here, but really that's wrong: they +-- use the OS used to build cabal to determine which extension to use, rather +-- than the target OS (but this is wrong elsewhere in Cabal as well). +flibTargetName :: LocalBuildInfo -> ForeignLib -> String +flibTargetName lbi flib = + case (os, foreignLibType flib) of + (Windows, ForeignLibNativeShared) -> nm <.> "dll" + (Windows, ForeignLibNativeStatic) -> nm <.> "lib" + (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt + (_other, ForeignLibNativeShared) -> + "lib" ++ nm <.> dllExtension (hostPlatform lbi) + (_other, ForeignLibNativeStatic) -> + "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) + (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" + where + nm :: String + nm = unUnqualComponentName $ foreignLibName flib + + os :: OS + Platform _ os = hostPlatform lbi + + -- If a foreign lib foo has lib-version-info 5:1:2 or + -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 + -- Libtool's version-info data is translated into library versions in a + -- nontrivial way: so refer to libtool documentation. + versionedExt :: String + versionedExt = + let nums = foreignLibVersion flib os + in foldl (<.>) "so" (map show nums) + +-- | Name for the library when building. +-- +-- If the `lib-version-info` field or the `lib-version-linux` field of +-- a foreign library target is set, we need to incorporate that +-- version into the SONAME field. +-- +-- If a foreign library foo has lib-version-info 5:1:2, it should be +-- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. +-- However, GHC does not allow overriding soname by setting linker +-- options, as it sets a soname of its own (namely the output +-- filename), after the user-supplied linker options. Hence, we have +-- to compile the library with the soname as its filename. We rename +-- the compiled binary afterwards. +-- +-- This method allows to adjust the name of the library at build time +-- such that the correct soname can be set. +flibBuildName :: LocalBuildInfo -> ForeignLib -> String +flibBuildName lbi flib + -- On linux, if a foreign-library has version data, the first digit is used + -- to produce the SONAME. + | (os, foreignLibType flib) + == (Linux, ForeignLibNativeShared) = + let nums = foreignLibVersion flib os + in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) + | otherwise = flibTargetName lbi flib + where + os :: OS + Platform _ os = hostPlatform lbi + + nm :: String + nm = unUnqualComponentName $ foreignLibName flib + +-- | Gets the target name (name of actual executable file) from the name of an +-- executable-like component ('Executable', 'TestSuite', 'Benchmark'). +exeTargetName :: Platform -> UnqualComponentName -> String +exeTargetName platform name = unUnqualComponentName name `withExt` exeExtension platform + where + withExt :: FilePath -> String -> FilePath + withExt fp ext = fp <.> if takeExtension fp /= ('.' : ext) then ext else "" + +-- | "Main" module name when overridden by @ghc-options: -main-is ...@ +-- or 'Nothing' if no @-main-is@ flag could be found. +-- +-- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. +exeMainModuleName + :: BuildInfo + -- ^ The build info of the executable-like component (Exe, Test, Bench) + -> ModuleName +exeMainModuleName bnfo = + -- GHC honors the last occurrence of a module name updated via -main-is + -- + -- Moreover, -main-is when parsed left-to-right can update either + -- the "Main" module name, or the "main" function name, or both, + -- see also 'decodeMainIsArg'. + fromMaybe ModuleName.main $ msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts + where + ghcopts = hcOptions GHC bnfo + + findIsMainArgs [] = [] + findIsMainArgs ("-main-is" : arg : rest) = arg : findIsMainArgs rest + findIsMainArgs (_ : rest) = findIsMainArgs rest + +-- | Decode argument to '-main-is' +-- +-- Returns 'Nothing' if argument set only the function name. +-- +-- This code has been stolen/refactored from GHC's DynFlags.setMainIs +-- function. The logic here is deliberately imperfect as it is +-- intended to be bug-compatible with GHC's parser. See discussion in +-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. +decodeMainIsArg :: String -> Maybe ModuleName +decodeMainIsArg arg + | headOf main_fn isLower = + -- The arg looked like "Foo.Bar.baz" + Just (ModuleName.fromString main_mod) + | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" + = + Just (ModuleName.fromString arg) + | otherwise -- The arg looked like "baz" + = + Nothing + where + headOf :: String -> (Char -> Bool) -> Bool + headOf str pred' = any pred' (safeHead str) + + (main_mod, main_fn) = splitLongestPrefix arg (== '.') + + splitLongestPrefix :: String -> (Char -> Bool) -> (String, String) + splitLongestPrefix str pred' + | null r_pre = (str, []) + | otherwise = (reverse (safeTail r_pre), reverse r_suf) + where + -- 'safeTail' drops the char satisfying 'pred' + (r_suf, r_pre) = break pred' (reverse str) 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 @@ -4,39 +4,49 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -module Distribution.Simple.GHC.EnvironmentParser - ( parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc(..) ) where -import Prelude () +module Distribution.Simple.GHC.EnvironmentParser (parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc (..)) where + import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Compiler - ( PackageDB(..) ) + ( PackageDB (..) + ) import Distribution.Simple.GHC.Internal - ( GhcEnvironmentFileEntry(..) ) + ( GhcEnvironmentFileEntry (..) + ) import Distribution.Types.UnitId - ( mkUnitId ) + ( mkUnitId + ) import qualified Text.Parsec as P import Text.Parsec.String - ( Parser, parseFromFile ) + ( Parser + , parseFromFile + ) parseEnvironmentFileLine :: Parser GhcEnvironmentFileEntry -parseEnvironmentFileLine = GhcEnvFileComment <$> comment - <|> GhcEnvFilePackageId <$> unitId - <|> GhcEnvFilePackageDb <$> packageDb - <|> pure GhcEnvFileClearPackageDbStack <* clearDb - where - comment = P.string "--" *> P.many (P.noneOf "\r\n") - unitId = P.try $ P.string "package-id" *> 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 "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine)) - clearDb = P.string "clear-package-db" +parseEnvironmentFileLine = + GhcEnvFileComment <$> comment + <|> GhcEnvFilePackageId <$> unitId + <|> GhcEnvFilePackageDb <$> packageDb + <|> pure GhcEnvFileClearPackageDbStack <* clearDb + where + comment = P.string "--" *> P.many (P.noneOf "\r\n") + unitId = + P.try $ + P.string "package-id" + *> 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 "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine)) + clearDb = P.string "clear-package-db" newtype ParseErrorExc = ParseErrorExc P.ParseError - deriving (Show, Typeable) + deriving (Show, Typeable) instance Exception ParseErrorExc @@ -45,5 +55,5 @@ readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry] readGhcEnvironmentFile path = - either (throwIO . ParseErrorExc) return =<< - parseFromFile parseGhcEnvironmentFile path + either (throwIO . ParseErrorExc) return + =<< parseFromFile parseGhcEnvironmentFile path 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 @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.GHC.ImplInfo -- @@ -8,92 +9,127 @@ -- This module contains the data structure describing invocation -- details for a GHC or GHC-derived compiler, such as supported flags -- and workarounds for bugs. - -module Distribution.Simple.GHC.ImplInfo ( - GhcImplInfo(..), getImplInfo, - ghcVersionImplInfo, ghcjsVersionImplInfo - ) where +module Distribution.Simple.GHC.ImplInfo + ( GhcImplInfo (..) + , getImplInfo + , ghcVersionImplInfo + , ghcjsVersionImplInfo + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Compiler import Distribution.Version -{- | - Information about features and quirks of a GHC-based implementation. - - Compiler flavors based on GHC behave similarly enough that some of - the support code for them is shared. Every implementation has its - own peculiarities, that may or may not be a direct result of the - underlying GHC version. This record keeps track of these differences. - - All shared code (i.e. everything not in the Distribution.Simple.FLAVOR - module) should use implementation info rather than version numbers - to test for supported features. --} - +-- | +-- Information about features and quirks of a GHC-based implementation. +-- +-- Compiler flavors based on GHC behave similarly enough that some of +-- the support code for them is shared. Every implementation has its +-- own peculiarities, that may or may not be a direct result of the +-- underlying GHC version. This record keeps track of these differences. +-- +-- All shared code (i.e. everything not in the Distribution.Simple.FLAVOR +-- 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 -- ^ -XGHC2021 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 - , supportsDebugLevels :: Bool -- ^ supports numeric @-g@ levels - , supportsPkgEnvFiles :: Bool -- ^ picks up @.ghc.environment@ files - , flagWarnMissingHomeModules :: Bool -- ^ -Wmissing-home-modules is supported + { supportsHaskell2010 :: Bool + -- ^ -XHaskell2010 and -XHaskell98 flags + , 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 + -- ^ -Wmissing-home-modules is supported + , unitIdForExes :: Bool + -- ^ Pass -this-unit-id flag when building executables } getImplInfo :: Compiler -> GhcImplInfo getImplInfo comp = case compilerFlavor comp of - GHC -> ghcVersionImplInfo (compilerVersion comp) + GHC -> ghcVersionImplInfo (compilerVersion comp) GHCJS -> case compilerCompatVersion GHC comp of - Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer - _ -> error ("Distribution.Simple.GHC.Props.getImplProps: " ++ - "could not find GHC version for GHCJS compiler") - x -> error ("Distribution.Simple.GHC.Props.getImplProps only works" ++ - "for GHC-like compilers (GHC, GHCJS)" ++ - ", but found " ++ show x) + Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer + _ -> + error + ( "Distribution.Simple.GHC.Props.getImplProps: " + ++ "could not find GHC version for GHCJS compiler" + ) + x -> + error + ( "Distribution.Simple.GHC.Props.getImplProps only works" + ++ "for GHC-like compilers (GHC, GHCJS)" + ++ ", but found " + ++ show x + ) ghcVersionImplInfo :: Version -> GhcImplInfo -ghcVersionImplInfo ver = GhcImplInfo - { supportsHaskell2010 = v >= [7] - , supportsGHC2021 = v >= [9,1] - , 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] - , supportsDebugLevels = v >= [8,0] - , supportsPkgEnvFiles = v >= [8,0,1,20160901] -- broken in 8.0.1, fixed in 8.0.2 - , flagWarnMissingHomeModules = v >= [8,2] - } +ghcVersionImplInfo ver = + GhcImplInfo + { supportsHaskell2010 = v >= [7] + , 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] + } where v = versionNumbers ver -ghcjsVersionImplInfo :: Version -- ^ The GHCJS version - -> Version -- ^ The GHC version - -> GhcImplInfo -ghcjsVersionImplInfo _ghcjsver ghcver = GhcImplInfo - { supportsHaskell2010 = True - , supportsGHC2021 = True - , reportsNoExt = True - , alwaysNondecIndent = False - , flagGhciScript = True - , flagProfAuto = True - , flagProfLate = True - , flagPackageConf = False - , flagDebugInfo = False - , supportsDebugLevels = ghcv >= [8,0] - , supportsPkgEnvFiles = ghcv >= [8,0,2] --TODO: check this works in ghcjs - , flagWarnMissingHomeModules = ghcv >= [8,2] - } +ghcjsVersionImplInfo + :: Version + -- ^ The GHCJS version + -> Version + -- ^ The GHC version + -> GhcImplInfo +ghcjsVersionImplInfo _ghcjsver ghcver = + GhcImplInfo + { supportsHaskell2010 = True + , supportsGHC2021 = True + , supportsGHC2024 = ghcv >= [9, 9] + , reportsNoExt = True + , alwaysNondecIndent = False + , flagGhciScript = True + , flagProfAuto = True + , flagProfLate = True + , flagPackageConf = False + , flagDebugInfo = False + , 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] + } where ghcv = versionNumbers ghcver 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 @@ -2,722 +2,878 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- --- | --- Module : Distribution.Simple.GHC.Internal --- Copyright : Isaac Jones 2003-2007 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module contains functions shared by GHC (Distribution.Simple.GHC) --- and GHC-derived compilers. - -module Distribution.Simple.GHC.Internal ( - configureToolchain, - getLanguages, - getExtensions, - targetPlatform, - getGhcInfo, - componentCcGhcOptions, - componentCmmGhcOptions, - componentCxxGhcOptions, - componentAsmGhcOptions, - componentJsGhcOptions, - componentGhcOptions, - mkGHCiLibName, - mkGHCiProfLibName, - filterGhciFlags, - ghcLookupProperty, - getHaskellObjects, - mkGhcOptPackages, - substTopDir, - checkPackageDbEnvVar, - profDetailLevelFlag, - -- * GHC platform and version strings - ghcArchString, - ghcOsString, - ghcPlatformAndVersionString, - -- * Constructing GHC environment files - GhcEnvironmentFileEntry(..), - writeGhcEnvironmentFile, - simpleGhcEnvironmentFile, - ghcEnvironmentFileName, - renderGhcEnvironmentFile, - renderGhcEnvironmentFileEntry, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Simple.GHC.ImplInfo -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Backpack -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.PackageDescription -import Distribution.Lex -import Distribution.Simple.Compiler -import Distribution.Simple.Program.GHC -import Distribution.Simple.Setup -import qualified Distribution.ModuleName as ModuleName -import Distribution.Simple.Program -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.UnitId -import Distribution.Types.LocalBuildInfo -import Distribution.Types.TargetInfo -import Distribution.Simple.Utils -import Distribution.Simple.BuildPaths -import Distribution.System -import Distribution.Pretty ( prettyShow ) -import Distribution.Parsec ( simpleParsec ) -import Distribution.Utils.NubList ( toNubListR ) -import Distribution.Verbosity -import Distribution.Compat.Stack -import Distribution.Version (Version) -import Distribution.Utils.Path -import Language.Haskell.Extension - -import qualified Data.Map as Map -import qualified Data.ByteString.Lazy.Char8 as BS -import System.Directory ( getDirectoryContents, getTemporaryDirectory ) -import System.Environment ( getEnv ) -import System.FilePath ( (), (<.>), takeExtension - , takeDirectory, takeFileName) -import System.IO ( hClose, hPutStrLn ) - -targetPlatform :: [(String, String)] -> Maybe Platform -targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo - --- | Adjust the way we find and configure gcc and ld --- -configureToolchain :: GhcImplInfo - -> ConfiguredProgram - -> Map String String - -> ProgramDb - -> ProgramDb -configureToolchain _implInfo ghcProg ghcInfo = - addKnownProgram gccProgram { - programFindLocation = findProg gccProgramName extraGccPath, - programPostConf = configureGcc - } - . addKnownProgram ldProgram { - programFindLocation = findProg ldProgramName extraLdPath, - programPostConf = \v cp -> - -- Call any existing configuration first and then add any new configuration - configureLd v =<< programPostConf ldProgram v cp - } - . addKnownProgram arProgram { - programFindLocation = findProg arProgramName extraArPath - } - . addKnownProgram stripProgram { - programFindLocation = findProg stripProgramName extraStripPath - } - where - compilerDir = takeDirectory (programPath ghcProg) - base_dir = takeDirectory compilerDir - mingwBinDir = base_dir "mingw" "bin" - isWindows = case buildOS of Windows -> True; _ -> False - binPrefix = "" - - maybeName :: Program -> Maybe FilePath -> String - maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName) - - gccProgramName = maybeName gccProgram mbGccLocation - ldProgramName = maybeName ldProgram mbLdLocation - arProgramName = maybeName arProgram mbArLocation - stripProgramName = maybeName stripProgram mbStripLocation - - mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath] - mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath] - | otherwise = mbDir - where - mbDir = maybeToList . fmap takeDirectory $ mbPath - - extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir - 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, windowsExtraLdDir, - windowsExtraArDir, windowsExtraStripDir) = - let b = mingwBinDir binPrefix - in (b, b, b, b) - - findProg :: String -> [FilePath] - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) - findProg progName extraPath v searchpath = - findProgramOnSearchPath v searchpath' progName - where - searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath - - -- Read tool locations from the 'ghc --info' output. Useful when - -- cross-compiling. - mbGccLocation = 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" - - -- 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 - -- String. - -- - -- We first try to parse as a [String] and if this fails then tokenize the - -- flags ourself. - getFlags :: String -> [String] - getFlags key = - case Map.lookup key ghcInfo of - Nothing -> [] - Just flags - | (flags', ""):_ <- reads flags -> flags' - | otherwise -> tokenizeQuotedWords flags - - configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram - configureGcc _v gccProg = do - return gccProg { - programDefaultArgs = programDefaultArgs gccProg - ++ ccFlags ++ gccLinkerFlags - } - - configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram - configureLd v ldProg = do - ldProg' <- configureLd' v ldProg - return ldProg' { - programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags - } - - -- 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 - hPutStrLn testchnd "int foo() { return 0; }" - hClose testchnd; hClose testohnd - runProgram verbosity ghcProg - [ "-hide-all-packages" - , "-c", testcfile - , "-o", testofile - ] - withTempFile tempDir ".o" $ \testofile' testohnd' -> - do - hClose testohnd' - _ <- getProgramOutput verbosity ldProg - ["-x", "-r", testofile, "-o", testofile'] - return True - `catchIO` (\_ -> return False) - `catchExit` (\_ -> return False) - if ldx - then return ldProg { programDefaultArgs = ["-x"] } - else return ldProg - -getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram - -> IO [(Language, String)] -getLanguages _ implInfo _ - -- TODO: should be using --supported-languages rather than hard coding - | supportsGHC2021 implInfo = return - [ (GHC2021, "-XGHC2021") - , (Haskell2010, "-XHaskell2010") - , (Haskell98, "-XHaskell98") - ] - | supportsHaskell2010 implInfo = return [(Haskell98, "-XHaskell98") - ,(Haskell2010, "-XHaskell2010")] - | otherwise = return [(Haskell98, "")] - -getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram - -> IO [(String, String)] -getGhcInfo verbosity _implInfo ghcProg = do - xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg) - ["--info"] - case reads xs of - [(i, ss)] - | all isSpace ss -> - return i - _ -> - die' verbosity "Can't parse --info output of GHC" - -getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram - -> IO [(Extension, Maybe String)] -getExtensions verbosity implInfo 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 - -componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCcGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages 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 - } - - -componentCxxGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCxxGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages 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 - } - - -componentAsmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentAsmGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptAsmOptions = (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"]) ++ - (case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"]) ++ - asmOptions bi, - ghcOptObjDir = toFlag odir - } - -componentJsGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentJsGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptObjDir = toFlag odir - } - - -componentGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions -componentGhcOptions verbosity implInfo lbi bi clbi odir = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptCabal = toFlag True, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentComponentId = cid - , componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag cid - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptNoCode = toFlag $ componentIsIndefinite clbi, - ghcOptHideAllPackages = toFlag True, - ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptSplitSections = toFlag (splitSections lbi), - ghcOptSplitObjs = toFlag (splitObjs lbi), - ghcOptSourcePathClear = toFlag True, - ghcOptSourcePath = toNubListR $ [odir] ++ (map getSymbolicPath (hsSourceDirs bi)) - ++ [autogenComponentModulesDir lbi clbi] - ++ [autogenPackageModulesDir lbi], - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptCppOptions = cppOptions bi, - ghcOptCppIncludes = toNubListR $ - [autogenComponentModulesDir lbi clbi cppHeaderName], - ghcOptFfiIncludes = toNubListR $ includes bi, - ghcOptObjDir = toFlag odir, - ghcOptHiDir = toFlag odir, - ghcOptStubDir = toFlag odir, - ghcOptOutputDir = toFlag 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) - } - where - exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt) - | uid <- componentExeDeps clbi - -- TODO: Ugh, localPkgDescr - , Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] ] - -toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation -toGhcOptimisation NoOptimisation = mempty --TODO perhaps override? -toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation -toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation - - -componentCmmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCmmGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptCppOptions = cppOptions bi, - ghcOptCppIncludes = toNubListR $ - [autogenComponentModulesDir lbi clbi cppHeaderName], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), - ghcOptDebugInfo = toFlag (withDebugInfo lbi), - ghcOptExtra = cmmOptions bi, - ghcOptObjDir = toFlag odir - } - - --- | Strip out flags that are not supported in ghci -filterGhciFlags :: [String] -> [String] -filterGhciFlags = filter supported - where - supported ('-':'O':_) = False - supported "-debug" = False - supported "-threaded" = False - supported "-ticky" = False - supported "-eventlog" = False - supported "-prof" = False - supported "-unreg" = False - supported _ = True - -mkGHCiLibName :: UnitId -> String -mkGHCiLibName lib = getHSLibraryName lib <.> "o" - -mkGHCiProfLibName :: UnitId -> String -mkGHCiProfLibName lib = getHSLibraryName lib <.> "p_o" - -ghcLookupProperty :: String -> Compiler -> Bool -ghcLookupProperty prop comp = - case Map.lookup prop (compilerProperties comp) of - Just "YES" -> True - _ -> False - --- when using -split-objs, we need to search for object files in the --- Module_split directory for each module. -getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> FilePath -> String -> Bool -> IO [FilePath] -getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs - | splitObjs lbi && allow_split_objs = do - let splitSuffix = "_" ++ wanted_obj_ext ++ "_split" - dirs = [ pref (ModuleName.toFilePath x ++ splitSuffix) - | x <- allLibModules lib clbi ] - objss <- traverse getDirectoryContents dirs - let objs = [ dir obj - | (objs',dir) <- zip objss dirs, obj <- objs', - let obj_ext = takeExtension obj, - '.':wanted_obj_ext == obj_ext ] - return objs - | otherwise = - return [ pref ModuleName.toFilePath x <.> wanted_obj_ext - | x <- allLibModules lib clbi ] - -mkGhcOptPackages :: ComponentLocalBuildInfo - -> [(OpenUnitId, ModuleRenaming)] -mkGhcOptPackages = componentIncludes - -substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo -substTopDir topDir ipo - = ipo { - IPI.importDirs = map f (IPI.importDirs ipo), - IPI.libraryDirs = map f (IPI.libraryDirs ipo), - IPI.libraryDirsStatic = map f (IPI.libraryDirsStatic ipo), - IPI.includeDirs = map f (IPI.includeDirs ipo), - IPI.frameworkDirs = map f (IPI.frameworkDirs ipo), - IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo), - IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo) - } - where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest - f x = x - --- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let --- users know that this is the case. See ticket #335. Simply ignoring it is --- not a good idea, since then ghc and cabal are looking at different sets --- of package DBs and chaos is likely to ensue. --- --- An exception to this is when running cabal from within a `cabal exec` --- environment. In this case, `cabal exec` will set the --- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set --- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow --- GHC{,JS}_PACKAGE_PATH. -checkPackageDbEnvVar :: Verbosity -> String -> String -> IO () -checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do - mPP <- lookupEnv packagePathEnvVar - when (isJust mPP) $ do - mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH" - unless (mPP == mcsPP) abort - where - lookupEnv :: String -> IO (Maybe String) - lookupEnv name = (Just `fmap` getEnv name) - `catchIO` const (return Nothing) - abort = - die' verbosity $ "Use of " ++ compilerName ++ "'s environment variable " - ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the " - ++ "flag --package-db to specify a package database (it can be " - ++ "used multiple times)." - - _ = callStack -- TODO: output stack when erroring - -profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto -profDetailLevelFlag forLib mpl = - case mpl of - ProfDetailNone -> mempty - ProfDetailDefault | forLib -> toFlag GhcProfAutoExported - | otherwise -> toFlag GhcProfAutoToplevel - ProfDetailExportedFunctions -> toFlag GhcProfAutoExported - ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel - ProfDetailAllFunctions -> toFlag GhcProfAutoAll - ProfDetailTopLate -> toFlag GhcProfLate - ProfDetailOther _ -> mempty - - --- ----------------------------------------------------------------------------- --- GHC platform and version strings - --- | GHC's rendering of its host or target 'Arch' as used in its platform --- strings and certain file locations (such as user package db location). --- -ghcArchString :: Arch -> String -ghcArchString PPC = "powerpc" -ghcArchString PPC64 = "powerpc64" -ghcArchString other = prettyShow other - --- | GHC's rendering of its host or target 'OS' as used in its platform --- strings and certain file locations (such as user package db location). --- -ghcOsString :: OS -> String -ghcOsString Windows = "mingw32" -ghcOsString OSX = "darwin" -ghcOsString Solaris = "solaris2" -ghcOsString other = prettyShow other - --- | GHC's rendering of its platform and compiler version string as used in --- certain file locations (such as user package db location). --- For example @x86_64-linux-7.10.4@ --- -ghcPlatformAndVersionString :: Platform -> Version -> String -ghcPlatformAndVersionString (Platform arch os) version = - intercalate "-" [ ghcArchString arch, ghcOsString os, prettyShow version ] - - --- ----------------------------------------------------------------------------- --- Constructing GHC environment files - --- | The kinds of entries we can stick in a @.ghc.environment@ file. --- -data GhcEnvironmentFileEntry = - GhcEnvFileComment String -- ^ @-- a comment@ - | GhcEnvFilePackageId UnitId -- ^ @package-id foo-1.0-4fe301a...@ - | GhcEnvFilePackageDb PackageDB -- ^ @global-package-db@, - -- @user-package-db@ or - -- @package-db blah/package.conf.d/@ - | GhcEnvFileClearPackageDbStack -- ^ @clear-package-db@ - deriving (Eq, Ord, Show) - --- | Make entries for a GHC environment file based on a 'PackageDBStack' and --- a bunch of package (unit) ids. --- --- If you need to do anything more complicated then either use this as a basis --- and add more entries, or just make all the entries directly. --- -simpleGhcEnvironmentFile :: PackageDBStack - -> [UnitId] - -> [GhcEnvironmentFileEntry] -simpleGhcEnvironmentFile packageDBs pkgids = - GhcEnvFileClearPackageDbStack - : map GhcEnvFilePackageDb packageDBs - ++ map GhcEnvFilePackageId pkgids - --- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory. --- --- The 'Platform' and GHC 'Version' are needed as part of the file name. --- --- Returns the name of the file written. -writeGhcEnvironmentFile :: FilePath -- ^ directory in which to put it - -> Platform -- ^ the GHC target platform - -> Version -- ^ the GHC version - -> [GhcEnvironmentFileEntry] -- ^ the content - -> IO FilePath -writeGhcEnvironmentFile directory platform ghcversion entries = do - writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries - return envfile - where - envfile = directory ghcEnvironmentFileName platform ghcversion - --- | The @.ghc.environment-$arch-$os-$ver@ file name --- -ghcEnvironmentFileName :: Platform -> Version -> FilePath -ghcEnvironmentFileName platform ghcversion = - ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion - --- | Render a bunch of GHC environment file entries --- -renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry] -> String -renderGhcEnvironmentFile = - unlines . map renderGhcEnvironmentFileEntry - --- | Render an individual GHC environment file entry --- -renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry -> String -renderGhcEnvironmentFileEntry entry = case entry of - GhcEnvFileComment comment -> format comment - where format = intercalate "\n" . map ("--" <++>) . lines - pref <++> "" = pref - pref <++> str = pref ++ " " ++ str - GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid - GhcEnvFilePackageDb pkgdb -> - case pkgdb of - GlobalPackageDB -> "global-package-db" - UserPackageDB -> "user-package-db" - SpecificPackageDB dbfile -> "package-db " ++ dbfile - GhcEnvFileClearPackageDbStack -> "clear-package-db" + +-- | +-- Module : Distribution.Simple.GHC.Internal +-- Copyright : Isaac Jones 2003-2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains functions shared by GHC (Distribution.Simple.GHC) +-- and GHC-derived compilers. +module Distribution.Simple.GHC.Internal + ( configureToolchain + , getLanguages + , getExtensions + , targetPlatform + , getGhcInfo + , componentCcGhcOptions + , componentCmmGhcOptions + , componentCxxGhcOptions + , componentAsmGhcOptions + , componentJsGhcOptions + , componentGhcOptions + , mkGHCiLibName + , mkGHCiProfLibName + , filterGhciFlags + , ghcLookupProperty + , getHaskellObjects + , mkGhcOptPackages + , substTopDir + , checkPackageDbEnvVar + , profDetailLevelFlag + + -- * GHC platform and version strings + , ghcArchString + , ghcOsString + , ghcPlatformAndVersionString + + -- * Constructing GHC environment files + , GhcEnvironmentFileEntry (..) + , writeGhcEnvironmentFile + , simpleGhcEnvironmentFile + , ghcEnvironmentFileName + , renderGhcEnvironmentFile + , renderGhcEnvironmentFileEntry + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Data.Bool (bool) +import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Data.Map as Map +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.GHC.ImplInfo +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program +import Distribution.Simple.Program.GHC +import Distribution.Simple.Setup.Common (extraCompilationArtifacts) +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentId (ComponentId) +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Types.UnitId +import Distribution.Utils.NubList (toNubListR) +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version (Version) +import Language.Haskell.Extension +import System.Directory (getDirectoryContents, getTemporaryDirectory) +import System.Environment (getEnv) +import System.FilePath + ( takeDirectory + , takeExtension + , takeFileName + , (<.>) + , () + ) +import System.IO (hClose, hPutStrLn) + +targetPlatform :: [(String, String)] -> Maybe Platform +targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo + +-- | Adjust the way we find and configure gcc and ld +configureToolchain + :: GhcImplInfo + -> ConfiguredProgram + -> Map String String + -> ProgramDb + -> ProgramDb +configureToolchain _implInfo ghcProg ghcInfo = + addKnownProgram + gccProgram + { programFindLocation = findProg gccProgramName extraGccPath + , programPostConf = configureGcc + } + . addKnownProgram + ldProgram + { programFindLocation = findProg ldProgramName extraLdPath + , programPostConf = \v cp -> + -- Call any existing configuration first and then add any new configuration + configureLd v =<< programPostConf ldProgram v cp + } + . addKnownProgram + arProgram + { programFindLocation = findProg arProgramName extraArPath + } + . addKnownProgram + stripProgram + { programFindLocation = findProg stripProgramName extraStripPath + } + where + compilerDir = takeDirectory (programPath ghcProg) + base_dir = takeDirectory compilerDir + mingwBinDir = base_dir "mingw" "bin" + isWindows = case buildOS of Windows -> True; _ -> False + binPrefix = "" + + maybeName :: Program -> Maybe FilePath -> String + maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName) + + gccProgramName = maybeName gccProgram mbGccLocation + ldProgramName = maybeName ldProgram mbLdLocation + arProgramName = maybeName arProgram mbArLocation + stripProgramName = maybeName stripProgram mbStripLocation + + mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath] + mkExtraPath mbPath mingwPath + | isWindows = mbDir ++ [mingwPath] + | otherwise = mbDir + where + mbDir = maybeToList . fmap takeDirectory $ mbPath + + extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir + 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 + , windowsExtraLdDir + , windowsExtraArDir + , windowsExtraStripDir + ) = + let b = mingwBinDir binPrefix + in (b, b, b, b) + + findProg + :: String + -> [FilePath] + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) + findProg progName extraPath v searchpath = + findProgramOnSearchPath v searchpath' progName + where + searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath + + -- Read tool locations from the 'ghc --info' output. Useful when + -- cross-compiling. + mbGccLocation = 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" + + -- 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 + -- String. + -- + -- We first try to parse as a [String] and if this fails then tokenize the + -- flags ourself. + getFlags :: String -> [String] + getFlags key = + case Map.lookup key ghcInfo of + Nothing -> [] + Just flags + | (flags', "") : _ <- reads flags -> flags' + | otherwise -> tokenizeQuotedWords flags + + configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureGcc _v gccProg = do + return + gccProg + { programDefaultArgs = + programDefaultArgs gccProg + ++ ccFlags + ++ gccLinkerFlags + } + + configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd v ldProg = do + ldProg' <- configureLd' v ldProg + return + ldProg' + { programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags + } + + -- 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 + hPutStrLn testchnd "int foo() { return 0; }" + hClose testchnd + hClose testohnd + runProgram + verbosity + ghcProg + [ "-hide-all-packages" + , "-c" + , testcfile + , "-o" + , testofile + ] + withTempFile tempDir ".o" $ \testofile' testohnd' -> + do + hClose testohnd' + _ <- + getProgramOutput + verbosity + ldProg + ["-x", "-r", testofile, "-o", testofile'] + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + if ldx + then return ldProg{programDefaultArgs = ["-x"]} + else return ldProg + +getLanguages + :: Verbosity + -> GhcImplInfo + -> ConfiguredProgram + -> IO [(Language, String)] +getLanguages _ implInfo _ + -- TODO: should be using --supported-languages rather than hard coding + | supportsGHC2024 implInfo = + return + [ (GHC2024, "-XGHC2024") + , (GHC2021, "-XGHC2021") + , (Haskell2010, "-XHaskell2010") + , (Haskell98, "-XHaskell98") + ] + | supportsGHC2021 implInfo = + return + [ (GHC2021, "-XGHC2021") + , (Haskell2010, "-XHaskell2010") + , (Haskell98, "-XHaskell98") + ] + | supportsHaskell2010 implInfo = + return + [ (Haskell98, "-XHaskell98") + , (Haskell2010, "-XHaskell2010") + ] + | otherwise = return [(Haskell98, "")] + +getGhcInfo + :: Verbosity + -> GhcImplInfo + -> ConfiguredProgram + -> IO [(String, String)] +getGhcInfo verbosity _implInfo ghcProg = do + xs <- + getProgramOutput + verbosity + (suppressOverrideArgs ghcProg) + ["--info"] + case reads xs of + [(i, ss)] + | all isSpace ss -> + return i + _ -> + dieWithException verbosity CantParseGHCOutput + +getExtensions + :: Verbosity + -> GhcImplInfo + -> ConfiguredProgram + -> IO [(Extension, Maybe String)] +getExtensions verbosity implInfo 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 + +componentCcGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> FilePath + -> 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 = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , 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 + } + +componentCxxGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> FilePath + -> 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 = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , 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 + } + +componentAsmGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> FilePath + -> 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) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , 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 + } + +componentJsGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> FilePath + -> 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 = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptObjDir = toFlag odir + } + +componentGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> GhcOptions +componentGhcOptions verbosity lbi bi clbi odir = + 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) + , ghcOptCabal = toFlag True + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ | not (unitIdForExes implInfo) -> mempty + ExeComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + TestComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + BenchComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + FLibComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo + { componentComponentId = cid + , componentInstantiatedWith = insts + } -> + if null insts + then mempty + else toFlag cid + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + insts + _ -> [] + , ghcOptNoCode = toFlag $ componentIsIndefinite clbi + , ghcOptHideAllPackages = toFlag True + , ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages mempty clbi + , ghcOptSplitSections = toFlag (splitSections lbi) + , ghcOptSplitObjs = toFlag (splitObjs lbi) + , ghcOptSourcePathClear = toFlag True + , ghcOptSourcePath = + toNubListR $ + map getSymbolicPath (hsSourceDirs bi) + ++ [odir] + ++ [autogenComponentModulesDir lbi clbi] + ++ [autogenPackageModulesDir lbi] + , ghcOptCppIncludePath = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptCppOptions = cppOptions bi + , ghcOptCppIncludes = + toNubListR $ + [autogenComponentModulesDir lbi clbi cppHeaderName] + , ghcOptFfiIncludes = toNubListR $ includes bi + , ghcOptObjDir = toFlag odir + , ghcOptHiDir = toFlag odir + , ghcOptHieDir = bool NoFlag (toFlag $ odir extraCompilationArtifacts "hie") $ flagHie implInfo + , ghcOptStubDir = toFlag odir + , ghcOptOutputDir = toFlag 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) + } + where + exe_paths = + [ componentBuildDir lbi (targetCLBI exe_tgt) + | uid <- componentExeDeps clbi + , -- TODO: Ugh, localPkgDescr + Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] + ] + +toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation +toGhcOptimisation NoOptimisation = mempty -- TODO perhaps override? +toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation +toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation + +componentCmmGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> FilePath + -> 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 = + toNubListR $ + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [buildDir lbi dir | dir <- includeDirs bi] + , ghcOptCppOptions = cppOptions bi + , ghcOptCppIncludes = + toNubListR $ + [autogenComponentModulesDir lbi clbi 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 + where + supported ('-' : 'O' : _) = False + supported "-debug" = False + supported "-threaded" = False + supported "-ticky" = False + supported "-eventlog" = False + supported "-prof" = False + supported "-unreg" = False + supported _ = True + +mkGHCiLibName :: UnitId -> String +mkGHCiLibName lib = getHSLibraryName lib <.> "o" + +mkGHCiProfLibName :: UnitId -> String +mkGHCiProfLibName lib = getHSLibraryName lib <.> "p_o" + +ghcLookupProperty :: String -> Compiler -> Bool +ghcLookupProperty prop comp = + case Map.lookup prop (compilerProperties comp) of + Just "YES" -> True + _ -> False + +-- when using -split-objs, we need to search for object files in the +-- Module_split directory for each module. +getHaskellObjects + :: GhcImplInfo + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> String + -> Bool + -> IO [FilePath] +getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs + | splitObjs lbi && allow_split_objs = do + let splitSuffix = "_" ++ wanted_obj_ext ++ "_split" + dirs = + [ pref (ModuleName.toFilePath x ++ splitSuffix) + | x <- allLibModules lib clbi + ] + objss <- traverse getDirectoryContents dirs + let objs = + [ dir obj + | (objs', dir) <- zip objss dirs + , obj <- objs' + , let obj_ext = takeExtension obj + , '.' : wanted_obj_ext == obj_ext + ] + return objs + | otherwise = + return + [ pref ModuleName.toFilePath x <.> wanted_obj_ext + | x <- allLibModules lib clbi + ] + +-- | Create the required packaged arguments, but filtering out package arguments which +-- aren't yet built, but promised. This filtering is used when compiling C/Cxx/Asm files, +-- and is a hack to avoid passing bogus `-package` arguments to GHC. The assumption being that +-- in 99% of cases we will include the right `-package` so that the C file finds the right headers. +mkGhcOptPackages + :: Map (PackageName, ComponentName) ComponentId + -> ComponentLocalBuildInfo + -> [(OpenUnitId, ModuleRenaming)] +mkGhcOptPackages promisedPkgsMap clbi = + [ i | i@(uid, _) <- componentIncludes clbi, abstractUnitId uid `Set.notMember` promised_cids + ] + where + -- Promised deps are going to be simple UnitIds + promised_cids = Set.fromList (map newSimpleUnitId (Map.elems promisedPkgsMap)) + +substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo +substTopDir topDir ipo = + ipo + { IPI.importDirs = map f (IPI.importDirs ipo) + , IPI.libraryDirs = map f (IPI.libraryDirs ipo) + , IPI.libraryDirsStatic = map f (IPI.libraryDirsStatic ipo) + , IPI.includeDirs = map f (IPI.includeDirs ipo) + , IPI.frameworkDirs = map f (IPI.frameworkDirs ipo) + , IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo) + , IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo) + } + where + f ('$' : 't' : 'o' : 'p' : 'd' : 'i' : 'r' : rest) = topDir ++ rest + f x = x + +-- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let +-- users know that this is the case. See ticket #335. Simply ignoring it is +-- not a good idea, since then ghc and cabal are looking at different sets +-- of package DBs and chaos is likely to ensue. +-- +-- An exception to this is when running cabal from within a `cabal exec` +-- environment. In this case, `cabal exec` will set the +-- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set +-- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow +-- GHC{,JS}_PACKAGE_PATH. +checkPackageDbEnvVar :: Verbosity -> String -> String -> IO () +checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do + mPP <- lookupEnv packagePathEnvVar + when (isJust mPP) $ do + mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH" + unless (mPP == mcsPP) abort + where + lookupEnv :: String -> IO (Maybe String) + lookupEnv name = + (Just `fmap` getEnv name) + `catchIO` const (return Nothing) + abort = + dieWithException verbosity $ IncompatibleWithCabal compilerName packagePathEnvVar + _ = callStack -- TODO: output stack when erroring + +profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto +profDetailLevelFlag forLib mpl = + case mpl of + ProfDetailNone -> mempty + ProfDetailDefault + | forLib -> toFlag GhcProfAutoExported + | otherwise -> toFlag GhcProfAutoToplevel + ProfDetailExportedFunctions -> toFlag GhcProfAutoExported + ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel + ProfDetailAllFunctions -> toFlag GhcProfAutoAll + ProfDetailTopLate -> toFlag GhcProfLate + ProfDetailOther _ -> mempty + +-- ----------------------------------------------------------------------------- +-- GHC platform and version strings + +-- | GHC's rendering of its host or target 'Arch' as used in its platform +-- strings and certain file locations (such as user package db location). +ghcArchString :: Arch -> String +ghcArchString PPC = "powerpc" +ghcArchString PPC64 = "powerpc64" +ghcArchString PPC64LE = "powerpc64le" +ghcArchString other = prettyShow other + +-- | GHC's rendering of its host or target 'OS' as used in its platform +-- strings and certain file locations (such as user package db location). +ghcOsString :: OS -> String +ghcOsString Windows = "mingw32" +ghcOsString OSX = "darwin" +ghcOsString Solaris = "solaris2" +ghcOsString Hurd = "gnu" +ghcOsString other = prettyShow other + +-- | GHC's rendering of its platform and compiler version string as used in +-- certain file locations (such as user package db location). +-- For example @x86_64-linux-7.10.4@ +ghcPlatformAndVersionString :: Platform -> Version -> String +ghcPlatformAndVersionString (Platform arch os) version = + intercalate "-" [ghcArchString arch, ghcOsString os, prettyShow version] + +-- ----------------------------------------------------------------------------- +-- Constructing GHC environment files + +-- | The kinds of entries we can stick in a @.ghc.environment@ file. +data GhcEnvironmentFileEntry + = -- | @-- a comment@ + GhcEnvFileComment String + | -- | @package-id foo-1.0-4fe301a...@ + GhcEnvFilePackageId UnitId + | -- | @global-package-db@, + -- @user-package-db@ or + -- @package-db blah/package.conf.d/@ + GhcEnvFilePackageDb PackageDB + | -- | @clear-package-db@ + GhcEnvFileClearPackageDbStack + deriving (Eq, Ord, Show) + +-- | Make entries for a GHC environment file based on a 'PackageDBStack' and +-- a bunch of package (unit) ids. +-- +-- If you need to do anything more complicated then either use this as a basis +-- and add more entries, or just make all the entries directly. +simpleGhcEnvironmentFile + :: PackageDBStack + -> [UnitId] + -> [GhcEnvironmentFileEntry] +simpleGhcEnvironmentFile packageDBs pkgids = + GhcEnvFileClearPackageDbStack + : map GhcEnvFilePackageDb packageDBs + ++ map GhcEnvFilePackageId pkgids + +-- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory. +-- +-- The 'Platform' and GHC 'Version' are needed as part of the file name. +-- +-- Returns the name of the file written. +writeGhcEnvironmentFile + :: FilePath + -- ^ directory in which to put it + -> Platform + -- ^ the GHC target platform + -> Version + -- ^ the GHC version + -> [GhcEnvironmentFileEntry] + -- ^ the content + -> IO FilePath +writeGhcEnvironmentFile directory platform ghcversion entries = do + writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries + return envfile + where + envfile = directory ghcEnvironmentFileName platform ghcversion + +-- | The @.ghc.environment-$arch-$os-$ver@ file name +ghcEnvironmentFileName :: Platform -> Version -> FilePath +ghcEnvironmentFileName platform ghcversion = + ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion + +-- | Render a bunch of GHC environment file entries +renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry] -> String +renderGhcEnvironmentFile = + unlines . map renderGhcEnvironmentFileEntry + +-- | Render an individual GHC environment file entry +renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry -> String +renderGhcEnvironmentFileEntry entry = case entry of + GhcEnvFileComment comment -> format comment + where + format = intercalate "\n" . map ("--" <++>) . lines + pref <++> "" = pref + pref <++> str = pref ++ " " ++ str + GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid + GhcEnvFilePackageDb pkgdb -> + case pkgdb of + GlobalPackageDB -> "global-package-db" + UserPackageDB -> "user-package-db" + SpecificPackageDB dbfile -> "package-db " ++ dbfile + GhcEnvFileClearPackageDbStack -> "clear-package-db" 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,1841 +1,2034 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} - -module Distribution.Simple.GHCJS ( - getGhcInfo, - configure, - getInstalledPackages, - getInstalledPackagesMonitorFiles, - getPackageDBContents, - buildLib, buildFLib, buildExe, - replLib, replFLib, replExe, - startInterpreter, - installLib, installFLib, installExe, - libAbiHash, - hcPkgInfo, - registerPackage, - componentGhcOptions, - componentCcGhcOptions, - getLibDir, - isDynamic, - getGlobalPackageDB, - pkgRoot, - runCmd, - -- * Constructing and deconstructing GHC environment files - Internal.GhcEnvironmentFileEntry(..), - Internal.simpleGhcEnvironmentFile, - Internal.renderGhcEnvironmentFile, - Internal.writeGhcEnvironmentFile, - Internal.ghcPlatformAndVersionString, - readGhcEnvironmentFile, - parseGhcEnvironmentFile, - ParseErrorExc(..), - -- * Version-specific implementation quirks - getImplInfo, - GhcImplInfo(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Distribution.Simple.GHC.Internal as Internal -import Distribution.Simple.GHC.ImplInfo -import Distribution.Simple.GHC.EnvironmentParser -import Distribution.PackageDescription.Utils (cabalBug) -import Distribution.PackageDescription as PD -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.ComponentLocalBuildInfo -import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName -import Distribution.ModuleName (ModuleName) -import Distribution.Simple.Program -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import qualified Distribution.Simple.Program.Strip as Strip -import Distribution.Simple.Program.GHC -import Distribution.Simple.Setup -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Compiler -import Distribution.CabalSpecVersion -import Distribution.Version -import Distribution.System -import Distribution.Types.PackageName.Magic -import Distribution.Verbosity -import Distribution.Pretty -import Distribution.Utils.NubList -import Distribution.Utils.Path - -import Control.Monad (msum) -import Data.Char (isLower) -import qualified Data.Map as Map -import System.Directory - ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing - , canonicalizePath, removeFile, renameFile ) -import System.FilePath ( (), (<.>), takeExtension - , takeDirectory, replaceExtension - ,isRelative ) -import qualified System.Info - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb - -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity hcPath hcPkgPath conf0 = do - - (ghcjsProg, ghcjsVersion, progdb1) <- - requireProgramVersion verbosity ghcjsProgram - (orLaterVersion (mkVersion [0,1])) - (userMaybeSpecifyPath "ghcjs" hcPath conf0) - - Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg) - unless (ghcjsGhcVersion < mkVersion [8,8]) $ - warn verbosity $ - "Unknown/unsupported 'ghc' version detected " - ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 8.8): " - ++ programPath ghcjsProg ++ " is based on GHC version " ++ - prettyShow ghcjsGhcVersion - - let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion - - -- 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: - (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <- - requireProgramVersion verbosity ghcjsPkgProgram { - programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg - } - anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1) - - Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion - verbosity (programPath ghcjsPkgProg) - - when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die' verbosity $ - "Version mismatch between ghcjs and ghcjs-pkg: " - ++ programPath ghcjsProg ++ " is version " ++ prettyShow ghcjsVersion ++ " " - ++ programPath ghcjsPkgProg ++ " is version " ++ prettyShow ghcjsPkgGhcjsVersion - - when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die' verbosity $ - "Version mismatch between ghcjs and ghcjs-pkg: " - ++ programPath ghcjsProg - ++ " was built with GHC version " ++ prettyShow ghcjsGhcVersion ++ " " - ++ programPath ghcjsPkgProg - ++ " was built with GHC version " ++ prettyShow ghcjsPkgVersion - - - -- Likewise we try to find the matching hsc2hs and haddock programs. - let hsc2hsProgram' = hsc2hsProgram { - programFindLocation = - guessHsc2hsFromGhcjsPath ghcjsProg - } - haddockProgram' = haddockProgram { - programFindLocation = - guessHaddockFromGhcjsPath ghcjsProg - } - hpcProgram' = hpcProgram { - programFindLocation = guessHpcFromGhcjsPath ghcjsProg - } - {- - runghcProgram' = runghcProgram { - programFindLocation = guessRunghcFromGhcjsPath ghcjsProg - } -} - 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 - - 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) - -guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) -guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram - -guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) -guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram - -guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) -guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram - -guessHpcFromGhcjsPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHpcFromGhcjsPath = guessToolFromGhcjsPath hpcProgram - - -guessToolFromGhcjsPath :: Program -> ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath - = do let toolname = programName tool - given_path = programPath ghcjsProg - given_dir = takeDirectory given_path - real_path <- canonicalizePath given_path - let real_dir = takeDirectory real_path - versionSuffix path = takeVersionSuffix (dropExeExtension path) - given_suf = versionSuffix given_path - real_suf = versionSuffix real_path - guessNormal dir = dir toolname <.> exeExtension buildPlatform - guessGhcjs dir = dir (toolname ++ "-ghcjs") - <.> exeExtension buildPlatform - guessGhcjsVersioned dir suf = dir (toolname ++ "-ghcjs" ++ suf) - <.> exeExtension buildPlatform - guessVersioned dir suf = dir (toolname ++ suf) - <.> exeExtension buildPlatform - mkGuesses dir suf | null suf = [guessGhcjs dir, guessNormal dir] - | otherwise = [guessGhcjsVersioned dir suf, - guessVersioned dir suf, - guessGhcjs dir, - guessNormal dir] - guesses = mkGuesses given_dir given_suf ++ - if real_path == given_path - then [] - else mkGuesses real_dir real_suf - info verbosity $ "looking for tool " ++ toolname - ++ " near compiler in " ++ given_dir - debug verbosity $ "candidate locations: " ++ show guesses - exists <- traverse doesFileExist guesses - case [ file | (file, True) <- zip guesses exists ] of - -- If we can't find it near ghc, fall back to the usual - -- method. - [] -> programFindLocation tool verbosity searchpath - (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp - let lookedAt = map fst - . takeWhile (\(_file, exist) -> not exist) - $ zip guesses exists - return (Just (fp, lookedAt)) - - where takeVersionSuffix :: FilePath -> String - takeVersionSuffix = takeWhileEndLE isSuffixChar - - isSuffixChar :: Char -> Bool - isSuffixChar c = isDigit c || c == '.' || c == '-' - -getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] -getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg - where - version = fromMaybe (error "GHCJS.getGhcInfo: no version") $ programVersion ghcjsProg - implInfo = ghcVersionImplInfo version - --- | Given a single package DB, return all installed packages. -getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb - -> IO InstalledPackageIndex -getPackageDBContents verbosity packagedb progdb = do - pkgss <- getInstalledPackages' verbosity [packagedb] progdb - toPackageIndex verbosity pkgss progdb - --- | Given a package DB stack, return all installed packages. -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity packagedbs progdb = do - checkPackageDbEnvVar verbosity - checkPackageDbStack verbosity packagedbs - pkgss <- getInstalledPackages' verbosity packagedbs progdb - index <- toPackageIndex verbosity pkgss progdb - return $! index - -toPackageIndex :: Verbosity - -> [(PackageDB, [InstalledPackageInfo])] - -> ProgramDb - -> IO InstalledPackageIndex -toPackageIndex verbosity pkgss progdb = do - -- On Windows, various fields have $topdir/foo rather than full - -- paths. We need to substitute the right value in so that when - -- we, for example, call gcc, we have proper paths to give it. - topDir <- getLibDir' verbosity ghcjsProg - let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) - | (_, pkgs) <- pkgss ] - return $! (mconcat indices) - - where - ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb - -getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath -getLibDir verbosity lbi = - dropWhileEndLE isSpace `fmap` - getDbProgramOutput verbosity ghcjsProgram - (withPrograms lbi) ["--print-libdir"] - -getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath -getLibDir' verbosity ghcjsProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcjsProg ["--print-libdir"] - - --- | Return the 'FilePath' to the global GHC package database. -getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath -getGlobalPackageDB verbosity ghcProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcProg ["--print-global-package-db"] - --- | Return the 'FilePath' to the per-user GHC package database. -getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath -getUserPackageDB _verbosity ghcjsProg platform = do - -- It's rather annoying that we have to reconstruct this, because ghc - -- hides this information from us otherwise. But for certain use cases - -- like change monitoring it really can't remain hidden. - appdir <- getAppUserDataDirectory "ghcjs" - return (appdir platformAndVersion packageConfFileName) - where - platformAndVersion = Internal.ghcPlatformAndVersionString - platform ghcjsVersion - packageConfFileName = "package.conf.d" - ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg - -checkPackageDbEnvVar :: Verbosity -> IO () -checkPackageDbEnvVar verbosity = - Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH" - -checkPackageDbStack :: Verbosity -> PackageDBStack -> IO () -checkPackageDbStack _ (GlobalPackageDB:rest) - | GlobalPackageDB `notElem` rest = return () -checkPackageDbStack verbosity rest - | GlobalPackageDB `notElem` rest = - die' verbosity $ "With current ghc versions the global package db is always used " - ++ "and must be listed first. This ghc limitation may be lifted in " - ++ "future, see https://gitlab.haskell.org/ghc/ghc/-/issues/5977" -checkPackageDbStack verbosity _ = - die' verbosity $ "If the global package db is specified, it must be " - ++ "specified first and cannot be specified multiple times" - -getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb - -> IO [(PackageDB, [InstalledPackageInfo])] -getInstalledPackages' verbosity packagedbs progdb = - sequenceA - [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb - return (packagedb, pkgs) - | packagedb <- packagedbs ] - --- | Get the packages from specific PackageDBs, not cumulative. --- -getInstalledPackagesMonitorFiles :: Verbosity -> Platform - -> ProgramDb - -> [PackageDB] - -> IO [FilePath] -getInstalledPackagesMonitorFiles verbosity platform progdb = - traverse getPackageDBPath - where - getPackageDBPath :: PackageDB -> IO FilePath - getPackageDBPath GlobalPackageDB = - selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg - - getPackageDBPath UserPackageDB = - selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform - - getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path - - -- GHC has old style file dbs, and new style directory dbs. - -- Note that for dir style dbs, we only need to monitor the cache file, not - -- the whole directory. The ghc program itself only reads the cache file - -- so it's safe to only monitor this one file. - selectMonitorFile path = do - isFileStyle <- doesFileExist path - if isFileStyle then return path - else return (path "package.cache") - - ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb - - -toJSLibName :: String -> String -toJSLibName lib - | takeExtension lib `elem` [".dll",".dylib",".so"] - = replaceExtension lib "js_so" - | takeExtension lib == ".a" = replaceExtension lib "js_a" - | otherwise = lib <.> "js_a" - --- ----------------------------------------------------------------------------- --- Building a library - -buildLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo - -> IO () -buildLib = buildOrReplLib Nothing - -replLib :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () -replLib = buildOrReplLib . Just - -buildOrReplLib :: Maybe [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () -buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do - let uid = componentUnitId clbi - libTargetDir = componentBuildDir lbi clbi - whenVanillaLib forceVanilla = - when (forceVanilla || withVanillaLib lbi) - whenProfLib = when (withProfLib lbi) - whenSharedLib forceShared = - when (forceShared || withSharedLib lbi) - whenStaticLib forceStatic = - when (forceStatic || withStaticLib lbi) - -- whenGHCiLib = when (withGHCiLib lbi) - forRepl = maybe False (const True) mReplFlags - -- ifReplLib = when forRepl - comp = compiler lbi - implInfo = getImplInfo comp - platform@(Platform _hostArch _hostOS) = hostPlatform lbi - has_code = not (componentIsIndefinite clbi) - - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - let runGhcjsProg = runGHC verbosity ghcjsProg comp platform - - let libBi = libBuildInfo lib - - -- fixme flags shouldn't depend on ghcjs being dynamic or not - let isGhcjsDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - doingTH = usesTemplateHaskellOrQQ libBi - forceVanillaLib = doingTH && not isGhcjsDynamic - forceSharedLib = doingTH && isGhcjsDynamic - -- TH always needs default libs, even when building for profiling - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = libCoverage lbi - -- TODO: Historically HPC files have been put into a directory which - -- has the package name. I'm going to avoid changing this for - -- now, but it would probably be better for this to be the - -- component ID instead... - pkg_name = prettyShow (PD.package pkg_descr) - distPref = fromFlag $ configDistPref $ configFlags lbi - hpcdir way - | forRepl = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name - | otherwise = mempty - - createDirectoryIfMissingVerbose verbosity True libTargetDir - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? - let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) - jsSrcs = jsSources libBi - cObjs = map (`replaceExtension` objExtension) cLikeFiles - baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir - linkJsLibOpts = mempty { - ghcOptExtra = - [ "-link-js-lib" , getHSLibraryName uid - , "-js-lib-outputdir", libTargetDir ] ++ - jsSrcs - } - vanillaOptsNoJsLib = baseOpts `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptNumJobs = numJobs, - ghcOptInputModules = toNubListR $ allLibModules lib clbi, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts - - profOpts = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - -- ghcOptHiSuffix = toFlag "p_hi", - -- ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Prof - } - - sharedOpts = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - -- ghcOptHiSuffix = toFlag "dyn_hi", - -- ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - - vanillaSharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "js_dyn_hi", - ghcOptDynObjSuffix = toFlag "js_dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - - unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $ - do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts) - shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts) - useDynToo = dynamicTooSupported && - (forceVanillaLib || withVanillaLib lbi) && - (forceSharedLib || withSharedLib lbi) && - null (hcSharedOptions GHC libBi) - if not has_code - then vanilla - else - if useDynToo - then do - runGhcjsProg vanillaSharedOpts - case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of - (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> - -- When the vanilla and shared library builds are done - -- in one pass, only one set of HPC module interfaces - -- are generated. This set should suffice for both - -- static and dynamically linked executables. We copy - -- the modules interfaces so they are available under - -- both ways. - copyDirectoryRecursive verbosity dynDir vanillaDir - _ -> return () - else if isGhcjsDynamic - then do shared; vanilla - else do vanilla; shared - whenProfLib (runGhcjsProg profOpts) - - -- Build any C++ sources separately. - {- - unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCxxOpts = if isGhcjsDynamic - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCxxOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded cxxOpts = do - needsRecomp <- checkNeedsRecompilation filename cxxOpts - when needsRecomp $ runGhcjsProg cxxOpts - runGhcProgIfNeeded vanillaCxxOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) - | filename <- cxxSources libBi] - - ifReplLib $ do - when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" - ifReplLib (runGhcjsProg replOpts) --} - -- build any C sources - -- TODO: Add support for S and CMM files. - {- - unless (not has_code || null (cSources libBi) || not nativeToo) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCcOpts = if isGhcjsDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCcOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded ccOpts = do - needsRecomp <- checkNeedsRecompilation filename ccOpts - when needsRecomp $ runGhcjsProg ccOpts - runGhcProgIfNeeded vanillaCcOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) - | filename <- cSources libBi] --} - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - - -- link: - - when has_code . when False {- fixme nativeToo -} . unless forRepl $ do - info verbosity "Linking..." - let cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) - (cSources libBi ++ cxxSources libBi) - compiler_id = compilerId (compiler lbi) - sharedLibFilePath = libTargetDir mkSharedLibName (hostPlatform lbi) compiler_id uid - staticLibFilePath = libTargetDir mkStaticLibName (hostPlatform lbi) compiler_id uid - - 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 lib lbi clbi - libTargetDir objExtension True - hSharedObjs <- - if withSharedLib lbi - then Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir ("dyn_" ++ objExtension) False - else return [] - - unless (null hObjs && null cObjs && null stubObjs) $ do - rpaths <- getRPaths lbi clbi - - let staticObjectFiles = - hObjs - ++ map (libTargetDir ) cObjs - ++ stubObjs - dynamicObjectFiles = - hSharedObjs - ++ map (libTargetDir ) cSharedObjs - ++ stubSharedObjs - -- After the relocation lib is created we invoke ghc -shared - -- with the dependencies spelled out as -package arguments - -- and ghc invokes the linker with the proper library paths - ghcSharedLinkArgs = - mempty { - ghcOptShared = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptInputFiles = toNubListR dynamicObjectFiles, - ghcOptOutputFile = toFlag sharedLibFilePath, - ghcOptExtra = 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, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = - toNubListR $ PD.extraFrameworkDirs libBi, - ghcOptRPaths = rpaths - } - ghcStaticLinkArgs = - mempty { - ghcOptStaticLib = toFlag True, - ghcOptInputFiles = toNubListR staticObjectFiles, - ghcOptOutputFile = toFlag staticLibFilePath, - 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 clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi - } - - info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) -{- - whenVanillaLib False $ do - Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciLibFilePath staticObjectFiles - -} -{- - whenProfLib $ do - Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciProfLibFilePath profObjectFiles --} - whenSharedLib False $ - runGhcjsProg ghcSharedLinkArgs - - whenStaticLib False $ - runGhcjsProg ghcStaticLinkArgs - --- | Start a REPL without loading any source files. -startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform - -> PackageDBStack -> IO () -startInterpreter verbosity progdb comp platform packageDBs = do - let replOpts = mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptPackageDBs = packageDBs - } - checkPackageDbStack verbosity packageDBs - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb - runGHC verbosity ghcjsProg comp platform replOpts - --- ----------------------------------------------------------------------------- --- Building an executable or foreign library - --- | Build a foreign library -buildFLib - :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> ForeignLib -> ComponentLocalBuildInfo -> IO () -buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib - -replFLib - :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> ForeignLib - -> ComponentLocalBuildInfo -> IO () -replFLib replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplFLib replFlags - --- | Build an executable with GHC. --- -buildExe - :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe - -replExe - :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Executable - -> ComponentLocalBuildInfo -> IO () -replExe replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplExe replFlags - --- | Building an executable, starting the REPL, and building foreign --- libraries are all very similar and implemented in 'gbuild'. The --- 'GBuildMode' distinguishes between the various kinds of operation. -data GBuildMode = - GBuildExe Executable - | GReplExe [String] Executable - | GBuildFLib ForeignLib - | GReplFLib [String] ForeignLib - -gbuildInfo :: GBuildMode -> BuildInfo -gbuildInfo (GBuildExe exe) = buildInfo exe -gbuildInfo (GReplExe _ exe) = buildInfo exe -gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib -gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib - -gbuildName :: GBuildMode -> String -gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe -gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe -gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib -gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib - -gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String -gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib -gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib - -exeTargetName :: Platform -> Executable -> String -exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform - --- | Target name for a foreign library (the actual file name) --- --- We do not use mkLibName and co here because the naming for foreign libraries --- is slightly different (we don't use "_p" or compiler version suffices, and we --- don't want the "lib" prefix on Windows). --- --- TODO: We do use `dllExtension` and co here, but really that's wrong: they --- use the OS used to build cabal to determine which extension to use, rather --- than the target OS (but this is wrong elsewhere in Cabal as well). -flibTargetName :: LocalBuildInfo -> ForeignLib -> String -flibTargetName lbi flib = - case (os, foreignLibType flib) of - (Windows, ForeignLibNativeShared) -> nm <.> "dll" - (Windows, ForeignLibNativeStatic) -> nm <.> "lib" - (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt - (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi) - (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) - (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" - where - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - - os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' - - -- If a foreign lib foo has lib-version-info 5:1:2 or - -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 - -- Libtool's version-info data is translated into library versions in a - -- nontrivial way: so refer to libtool documentation. - versionedExt :: String - versionedExt = - let nums = foreignLibVersion flib os - in foldl (<.>) "so" (map show nums) - --- | Name for the library when building. --- --- If the `lib-version-info` field or the `lib-version-linux` field of --- a foreign library target is set, we need to incorporate that --- version into the SONAME field. --- --- If a foreign library foo has lib-version-info 5:1:2, it should be --- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. --- However, GHC does not allow overriding soname by setting linker --- options, as it sets a soname of its own (namely the output --- filename), after the user-supplied linker options. Hence, we have --- to compile the library with the soname as its filename. We rename --- the compiled binary afterwards. --- --- This method allows to adjust the name of the library at build time --- such that the correct soname can be set. -flibBuildName :: LocalBuildInfo -> ForeignLib -> String -flibBuildName lbi flib - -- On linux, if a foreign-library has version data, the first digit is used - -- to produce the SONAME. - | (os, foreignLibType flib) == - (Linux, ForeignLibNativeShared) - = let nums = foreignLibVersion flib os - in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) - | otherwise = flibTargetName lbi flib - where - os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' - - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - -gbuildIsRepl :: GBuildMode -> Bool -gbuildIsRepl (GBuildExe _) = False -gbuildIsRepl (GReplExe _ _) = True -gbuildIsRepl (GBuildFLib _) = False -gbuildIsRepl (GReplFLib _ _) = True - -gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool -gbuildNeedDynamic lbi bm = - case bm of - GBuildExe _ -> withDynExe lbi - GReplExe _ _ -> withDynExe lbi - GBuildFLib flib -> withDynFLib flib - GReplFLib _ flib -> withDynFLib flib - where - withDynFLib flib = - case foreignLibType flib of - ForeignLibNativeShared -> - ForeignLibStandalone `notElem` foreignLibOptions flib - ForeignLibNativeStatic -> - False - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -gbuildModDefFiles :: GBuildMode -> [FilePath] -gbuildModDefFiles (GBuildExe _) = [] -gbuildModDefFiles (GReplExe _ _) = [] -gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib -gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib - --- | "Main" module name when overridden by @ghc-options: -main-is ...@ --- or 'Nothing' if no @-main-is@ flag could be found. --- --- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. -exeMainModuleName :: Executable -> Maybe ModuleName -exeMainModuleName Executable{buildInfo = bnfo} = - -- GHC honors the last occurrence of a module name updated via -main-is - -- - -- Moreover, -main-is when parsed left-to-right can update either - -- the "Main" module name, or the "main" function name, or both, - -- see also 'decodeMainIsArg'. - msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts - where - ghcopts = hcOptions GHC bnfo - - findIsMainArgs [] = [] - findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest - findIsMainArgs (_:rest) = findIsMainArgs rest - --- | Decode argument to '-main-is' --- --- Returns 'Nothing' if argument set only the function name. --- --- This code has been stolen/refactored from GHC's DynFlags.setMainIs --- function. The logic here is deliberately imperfect as it is --- intended to be bug-compatible with GHC's parser. See discussion in --- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. -decodeMainIsArg :: String -> Maybe ModuleName -decodeMainIsArg arg - | headOf main_fn isLower - -- The arg looked like "Foo.Bar.baz" - = Just (ModuleName.fromString main_mod) - | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" - = Just (ModuleName.fromString arg) - | otherwise -- The arg looked like "baz" - = Nothing - where - headOf :: String -> (Char -> Bool) -> Bool - headOf str pred' = any pred' (safeHead str) - - (main_mod, main_fn) = splitLongestPrefix arg (== '.') - - splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) - splitLongestPrefix str pred' - | null r_pre = (str, []) - | otherwise = (reverse (safeTail r_pre), reverse r_suf) - -- 'safeTail' drops the char satisfying 'pred' - where (r_suf, r_pre) = break pred' (reverse str) - - --- | A collection of: --- * C input files --- * C++ input files --- * GHC input files --- * GHC input modules --- --- Used to correctly build and link sources. -data BuildSources = BuildSources { - cSourcesFiles :: [FilePath], - cxxSourceFiles :: [FilePath], - inputSourceFiles :: [FilePath], - inputSourceModules :: [ModuleName] - } - --- | Locate and return the 'BuildSources' required to build and link. -gbuildSources :: Verbosity - -> PackageId - -> CabalSpecVersion - -> FilePath - -> GBuildMode - -> IO BuildSources -gbuildSources verbosity pkgId specVer tmpDir bm = - case bm of - GBuildExe exe -> exeSources exe - GReplExe _ exe -> exeSources exe - GBuildFLib flib -> return $ flibSources flib - GReplFLib _ flib -> return $ flibSources flib - where - exeSources :: Executable -> IO BuildSources - exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do - main <- findFileEx verbosity (tmpDir : map getSymbolicPath (hsSourceDirs bnfo)) modPath - let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe - otherModNames = exeModules exe - - -- Scripts have fakePackageId and are always Haskell but can have any extension. - if isHaskell main || pkgId == fakePackageId - then - if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) - then do - -- The cabal manual clearly states that `other-modules` is - -- intended for non-main modules. However, there's at least one - -- important package on Hackage (happy-1.19.5) which - -- violates this. We workaround this here so that we don't - -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which - -- would result in GHC complaining about duplicate Main - -- modules. - -- - -- Finally, we only enable this workaround for - -- specVersion < 2, as 'cabal-version:>=2.0' cabal files - -- have no excuse anymore to keep doing it wrong... ;-) - warn verbosity $ "Enabling workaround for Main module '" - ++ prettyShow mainModName - ++ "' listed in 'other-modules' illegally!" - - return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = filter (/= mainModName) $ exeModules exe - } - - else return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = exeModules exe - } - else let (csf, cxxsf) - | isCxx main = ( cSources bnfo, main : cxxSources bnfo) - -- if main is not a Haskell source - -- and main is not a C++ source - -- then we assume that it is a C source - | otherwise = (main : cSources bnfo, cxxSources bnfo) - - in return BuildSources { - cSourcesFiles = csf, - cxxSourceFiles = cxxsf, - inputSourceFiles = [], - inputSourceModules = exeModules exe - } - - flibSources :: ForeignLib -> BuildSources - flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = - BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [], - 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 -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> GBuildMode -> ComponentLocalBuildInfo -> IO () -gbuild verbosity numJobs pkg_descr lbi bm clbi = do - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - let replFlags = case bm of - GReplExe flags _ -> flags - GReplFLib flags _ -> flags - GBuildExe{} -> mempty - GBuildFLib{} -> mempty - comp = compiler lbi - platform = hostPlatform lbi - implInfo = getImplInfo comp - runGhcProg = runGHC verbosity ghcjsProg comp platform - - let (bnfo, threaded) = case bm of - GBuildFLib _ -> popThreadedFlag (gbuildInfo bm) - _ -> (gbuildInfo bm, False) - - -- the name that GHC really uses (e.g., with .exe on Windows for executables) - let targetName = gbuildTargetName lbi bm - let targetDir = buildDir lbi (gbuildName bm) - let tmpDir = targetDir (gbuildName bm ++ "-tmp") - createDirectoryIfMissingVerbose verbosity True targetDir - createDirectoryIfMissingVerbose verbosity True tmpDir - - -- 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 = exeCoverage lbi - distPref = fromFlag $ configDistPref $ configFlags lbi - hpcdir way - | gbuildIsRepl bm = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm) - | otherwise = mempty - - rpaths <- getRPaths lbi clbi - buildSources <- gbuildSources verbosity (package pkg_descr) (specVersion pkg_descr) tmpDir bm - - let cSrcs = cSourcesFiles buildSources - cxxSrcs = cxxSourceFiles buildSources - inputFiles = inputSourceFiles buildSources - inputModules = inputSourceModules buildSources - isGhcDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - cObjs = map (`replaceExtension` objExtension) cSrcs - cxxObjs = map (`replaceExtension` objExtension) cxxSrcs - needDynamic = gbuildNeedDynamic lbi bm - needProfiling = withProfExe lbi - - -- build executables - buildRunner = case clbi of - LibComponentLocalBuildInfo {} -> False - FLibComponentLocalBuildInfo {} -> False - ExeComponentLocalBuildInfo {} -> True - TestComponentLocalBuildInfo {} -> True - BenchComponentLocalBuildInfo {} -> True - baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir) - `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptInputFiles = toNubListR $ if package pkg_descr == fakePackageId - then filter isHaskell inputFiles - else inputFiles, - ghcOptInputScripts = toNubListR $ if package pkg_descr == fakePackageId - then filter (not . isHaskell) inputFiles - else [], - ghcOptInputModules = toNubListR inputModules, - -- for all executable components (exe/test/bench), - -- GHCJS must be passed the "-build-runner" option - ghcOptExtra = - if buildRunner then ["-build-runner"] - else mempty - } - staticOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticOnly, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - profOpts = baseOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag False - (withProfExeDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Prof - } - dynOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - -- TODO: Does it hurt to set -fPIC for executables? - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - dynTooOpts = staticOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "dyn_hi", - ghcOptDynObjSuffix = toFlag "dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = PD.ldOptions bnfo, - ghcOptLinkLibs = extraLibs bnfo, - ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo, - ghcOptLinkFrameworks = toNubListR $ - PD.frameworks bnfo, - ghcOptLinkFrameworkDirs = toNubListR $ - PD.extraFrameworkDirs bnfo, - ghcOptInputFiles = toNubListR - [tmpDir x | x <- cObjs ++ cxxObjs] - } - dynLinkerOpts = mempty { - ghcOptRPaths = rpaths - } - replOpts = baseOpts { - ghcOptExtra = Internal.filterGhciFlags - (ghcOptExtra baseOpts) - <> replFlags - } - -- For a normal compile we do separate invocations of ghc for - -- compiling as for linking. But for repl we have to do just - -- the one invocation, so that one has to include all the - -- linker stuff too, like -l flags and any .o files from C - -- files etc. - `mappend` linkerOpts - `mappend` mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptOptimisation = toFlag GhcNoOptimisation - } - commonOpts | needProfiling = profOpts - | needDynamic = dynOpts - | otherwise = staticOpts - compileOpts | useDynToo = dynTooOpts - | otherwise = commonOpts - withStaticExe = not needProfiling && not needDynamic - - -- For building exe's that use TH with -prof or -dynamic we actually have - -- to build twice, once without -prof/-dynamic and then again with - -- -prof/-dynamic. This is because the code that TH needs to run at - -- compile time needs to be the vanilla ABI so it can be loaded up and run - -- by the compiler. - -- With dynamic-by-default GHC the TH object files loaded at compile-time - -- need to be .dyn_o instead of .o. - doingTH = usesTemplateHaskellOrQQ bnfo - -- Should we use -dynamic-too instead of compiling twice? - useDynToo = dynamicTooSupported && isGhcDynamic - && doingTH && withStaticExe - && null (hcSharedOptions GHC bnfo) - compileTHOpts | isGhcDynamic = dynOpts - | otherwise = staticOpts - compileForTH - | gbuildIsRepl bm = False - | useDynToo = False - | isGhcDynamic = doingTH && (needProfiling || withStaticExe) - | otherwise = doingTH && (needProfiling || needDynamic) - - -- Build static/dynamic object files for TH, if needed. - when compileForTH $ - runGhcProg compileTHOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } - - -- Do not try to build anything if there are no input files. - -- This can happen if the cabal file ends up with only cSrcs - -- but no Haskell modules. - unless ((null inputFiles && null inputModules) - || gbuildIsRepl bm) $ - runGhcProg compileOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } - - -- build any C++ sources - unless (null cxxSrcs) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCxxOpts = if isGhcDynamic - -- Dynamic GHC requires C++ sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCxxOpts - | needDynamic = sharedCxxOpts - | otherwise = vanillaCxxOpts - -- TODO: Placing all Haskell, C, & C++ objects in a single directory - -- Has the potential for file collisions. In general we would - -- consider this a user error. However, we should strive to - -- add a warning if this occurs. - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cxxSrcs ] - - -- build any C sources - unless (null cSrcs) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCcOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCcOpts - | needDynamic = sharedCcOpts - | otherwise = vanillaCcOpts - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cSrcs ] - - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - case bm of - GReplExe _ _ -> runGhcProg replOpts - GReplFLib _ _ -> runGhcProg replOpts - GBuildExe _ -> do - let linkOpts = commonOpts - `mappend` linkerOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag (null inputFiles) - } - `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) - - info verbosity "Linking..." - -- Work around old GHCs not relinking in this - -- situation, see #3294 - let target = targetDir targetName - when (compilerVersion comp < mkVersion [7,7]) $ do - e <- doesFileExist target - when e (removeFile target) - runGhcProg linkOpts { ghcOptOutputFile = toFlag target } - GBuildFLib flib -> do - let rtsInfo = extractRtsInfo lbi - rtsOptLinkLibs = [ - if needDynamic - then if threaded - then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) - else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) - else if threaded - then statRtsThreadedLib (rtsStaticInfo rtsInfo) - else statRtsVanillaLib (rtsStaticInfo rtsInfo) - ] - linkOpts = case foreignLibType flib of - ForeignLibNativeShared -> - commonOpts - `mappend` linkerOpts - `mappend` dynLinkerOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag True, - ghcOptShared = toFlag True, - ghcOptLinkLibs = rtsOptLinkLibs, - ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo, - ghcOptFPic = toFlag True, - ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm - } - -- See Note [RPATH] - `mappend` ifNeedsRPathWorkaround lbi mempty { - ghcOptLinkOptions = ["-Wl,--no-as-needed"] - , ghcOptLinkLibs = ["ffi"] - } - ForeignLibNativeStatic -> - -- this should be caught by buildFLib - -- (and if we do implement this, we probably don't even want to call - -- ghc here, but rather Ar.createArLibArchive or something) - cabalBug "static libraries not yet implemented" - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -- We build under a (potentially) different filename to set a - -- soname on supported platforms. See also the note for - -- @flibBuildName@. - info verbosity "Linking..." - let buildName = flibBuildName lbi flib - runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir buildName) } - renameFile (targetDir buildName) (targetDir targetName) - -{- -Note [RPATH] -~~~~~~~~~~~~ - -Suppose that the dynamic library depends on `base`, but not (directly) on -`integer-gmp` (which, however, is a dependency of `base`). We will link the -library as - - gcc ... -lHSbase-4.7.0.2-ghc7.8.4 -lHSinteger-gmp-0.5.1.0-ghc7.8.4 ... - -However, on systems (like Ubuntu) where the linker gets called with `-as-needed` -by default, the linker will notice that `integer-gmp` isn't actually a direct -dependency and hence omit the link. - -Then when we attempt to link a C program against this dynamic library, the -_static_ linker will attempt to verify that all symbols can be resolved. The -dynamic library itself does not require any symbols from `integer-gmp`, but -`base` does. In order to verify that the symbols used by `base` can be -resolved, the static linker needs to be able to _find_ integer-gmp. - -Finding the `base` dependency is simple, because the dynamic elf header -(`readelf -d`) for the library that we have created looks something like - - (NEEDED) Shared library: [libHSbase-4.7.0.2-ghc7.8.4.so] - (RPATH) Library rpath: [/path/to/base-4.7.0.2:...] - -However, when it comes to resolving the dependency on `integer-gmp`, it needs -to look at the dynamic header for `base`. On modern ghc (7.8 and higher) this -looks something like - - (NEEDED) Shared library: [libHSinteger-gmp-0.5.1.0-ghc7.8.4.so] - (RPATH) Library rpath: [$ORIGIN/../integer-gmp-0.5.1.0:...] - -This specifies the location of `integer-gmp` _in terms of_ the location of base -(using the `$ORIGIN`) variable. But here's the crux: when the static linker -attempts to verify that all symbols can be resolved, [**IT DOES NOT RESOLVE -`$ORIGIN`**](http://stackoverflow.com/questions/6323603/ld-using-rpath-origin-inside-a-shared-library-recursive). -As a consequence, it will not be able to resolve the symbols and report the -missing symbols as errors, _even though the dynamic linker **would** be able to -resolve these symbols_. We can tell the static linker not to report these -errors by using `--unresolved-symbols=ignore-all` and all will be fine when we -run the program ([(indeed, this is what the gold linker -does)](https://sourceware.org/ml/binutils/2013-05/msg00038.html), but it makes -the resulting library more difficult to use. - -Instead what we can do is make sure that the generated dynamic library has -explicit top-level dependencies on these libraries. This means that the static -linker knows where to find them, and when we have transitive dependencies on -the same libraries the linker will only load them once, so we avoid needing to -look at the `RPATH` of our dependencies. We can do this by passing -`--no-as-needed` to the linker, so that it doesn't omit any libraries. - -Note that on older ghc (7.6 and before) the Haskell libraries don't have an -RPATH set at all, which makes it even more important that we make these -top-level dependencies. - -Finally, we have to explicitly link against `libffi` for the same reason. For -newer ghc this _happens_ to be unnecessary on many systems because `libffi` is -a library which is not specific to GHC, and when the static linker verifies -that all symbols can be resolved it will find the `libffi` that is globally -installed (completely independent from ghc). Of course, this may well be the -_wrong_ version of `libffi`, but it's quite possible that symbol resolution -happens to work. This is of course the wrong approach, which is why we link -explicitly against `libffi` so that we will find the _right_ version of -`libffi`. --} - --- | Do we need the RPATH workaround? --- --- See Note [RPATH]. -ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a -ifNeedsRPathWorkaround lbi a = - case hostPlatform lbi of - Platform _ Linux -> a - _otherwise -> mempty - -data DynamicRtsInfo = DynamicRtsInfo { - dynRtsVanillaLib :: FilePath - , dynRtsThreadedLib :: FilePath - , dynRtsDebugLib :: FilePath - , dynRtsEventlogLib :: FilePath - , dynRtsThreadedDebugLib :: FilePath - , dynRtsThreadedEventlogLib :: FilePath - } - -data StaticRtsInfo = StaticRtsInfo { - statRtsVanillaLib :: FilePath - , statRtsThreadedLib :: FilePath - , statRtsDebugLib :: FilePath - , statRtsEventlogLib :: FilePath - , statRtsThreadedDebugLib :: FilePath - , statRtsThreadedEventlogLib :: FilePath - , statRtsProfilingLib :: FilePath - , statRtsThreadedProfilingLib :: FilePath - } - -data RtsInfo = RtsInfo { - rtsDynamicInfo :: DynamicRtsInfo - , rtsStaticInfo :: StaticRtsInfo - , rtsLibPaths :: [FilePath] - } - --- | Extract (and compute) information about the RTS library --- --- TODO: This hardcodes the name as @HSrts-ghc@. I don't know if we can --- find this information somewhere. We can lookup the 'hsLibraries' field of --- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which --- doesn't really help. -extractRtsInfo :: LocalBuildInfo -> RtsInfo -extractRtsInfo lbi = - case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of - [(_, [rts])] -> aux rts - _otherwise -> error "No (or multiple) ghc rts package is registered" - where - aux :: InstalledPackageInfo -> RtsInfo - aux rts = RtsInfo { - rtsDynamicInfo = DynamicRtsInfo { - dynRtsVanillaLib = withGhcVersion "HSrts" - , dynRtsThreadedLib = withGhcVersion "HSrts_thr" - , dynRtsDebugLib = withGhcVersion "HSrts_debug" - , dynRtsEventlogLib = withGhcVersion "HSrts_l" - , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" - , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" - } - , rtsStaticInfo = StaticRtsInfo { - statRtsVanillaLib = "HSrts" - , statRtsThreadedLib = "HSrts_thr" - , statRtsDebugLib = "HSrts_debug" - , statRtsEventlogLib = "HSrts_l" - , statRtsThreadedDebugLib = "HSrts_thr_debug" - , statRtsThreadedEventlogLib = "HSrts_thr_l" - , statRtsProfilingLib = "HSrts_p" - , statRtsThreadedProfilingLib = "HSrts_thr_p" - } - , rtsLibPaths = InstalledPackageInfo.libraryDirs rts - } - withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) - --- | 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. -checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool -checkNeedsRecompilation filename opts = filename `moreRecentFile` oname - where oname = getObjectFileName filename opts - --- | Finds the object file name of the given source file -getObjectFileName :: FilePath -> GhcOptions -> FilePath -getObjectFileName filename opts = oname - where odir = fromFlag (ghcOptObjDir opts) - oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) - oname = odir replaceExtension filename oext - --- | Calculate the RPATHs for the component we are building. --- --- Calculates relative RPATHs when 'relocatable' is set. -getRPaths :: LocalBuildInfo - -> ComponentLocalBuildInfo -- ^ Component we are building - -> IO (NubListR FilePath) -getRPaths lbi clbi | supportRPaths hostOS = do - libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi - let hostPref = case hostOS of - OSX -> "@loader_path" - _ -> "$ORIGIN" - relPath p = if isRelative p then hostPref p else p - rpaths = toNubListR (map relPath libraryPaths) - return rpaths - where - (Platform _ hostOS) = hostPlatform lbi - compid = compilerId . compiler $ lbi - - -- The list of RPath-supported operating systems below reflects the - -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ - -- reflect whether the OS supports RPATH. - - -- E.g. when this comment was written, the *BSD operating systems were - -- untested with regards to Cabal RPATH handling, and were hence set to - -- 'False', while those operating systems themselves do support RPATH. - supportRPaths Linux   = True - supportRPaths Windows = False - supportRPaths OSX   = True - supportRPaths FreeBSD   = - case compid of - CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True - _ -> False - supportRPaths OpenBSD   = False - supportRPaths NetBSD   = False - supportRPaths DragonFly = False - supportRPaths Solaris = False - supportRPaths AIX = False - supportRPaths HPUX = False - supportRPaths IRIX = False - supportRPaths HaLVM = False - supportRPaths IOS = False - supportRPaths Android = False - supportRPaths Ghcjs = False - supportRPaths Wasi = False - supportRPaths Hurd = False - supportRPaths (OtherOS _) = False - -- Do _not_ add a default case so that we get a warning here when a new OS - -- is added. - -getRPaths _ _ = return mempty - --- | Remove the "-threaded" flag when building a foreign library, as it has no --- effect when used with "-shared". Returns the updated 'BuildInfo', along --- with whether or not the flag was present, so we can use it to link against --- the appropriate RTS on our own. -popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) -popThreadedFlag bi = - ( bi { options = filterHcOptions (/= "-threaded") (options bi) } - , hasThreaded (options bi)) - - where - filterHcOptions :: (String -> Bool) - -> PerCompilerFlavor [String] - -> PerCompilerFlavor [String] - 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 :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO String -libAbiHash verbosity _pkg_descr lbi lib clbi = do - let - libBi = libBuildInfo lib - comp = compiler lbi - platform = hostPlatform lbi - vanillaArgs = - (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) - `mappend` mempty { - ghcOptMode = toFlag GhcModeAbiHash, - ghcOptInputModules = toNubListR $ exposedModules lib - } - sharedArgs = vanillaArgs `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "js_dyn_hi", - ghcOptObjSuffix = toFlag "js_dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi - } - profArgs = vanillaArgs `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - ghcOptHiSuffix = toFlag "js_p_hi", - ghcOptObjSuffix = toFlag "js_p_o", - ghcOptExtra = hcProfOptions GHC libBi - } - ghcArgs - | withVanillaLib lbi = vanillaArgs - | withSharedLib lbi = sharedArgs - | withProfLib lbi = profArgs - | otherwise = error "libAbiHash: Can't find an enabled library way" - - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - hash <- getProgramInvocationOutput verbosity - =<< ghcInvocation verbose ghcjsProg comp platform ghcArgs - return (takeWhile (not . isSpace) hash) - -componentGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions -componentGhcOptions verbosity lbi bi clbi odir = - let opts = Internal.componentGhcOptions verbosity implInfo lbi bi clbi odir - comp = compiler lbi - implInfo = getImplInfo comp - in opts { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi - } - - -componentCcGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCcGhcOptions verbosity lbi = - Internal.componentCcGhcOptions verbosity implInfo lbi - where - comp = compiler lbi - implInfo = getImplInfo comp - - --- ----------------------------------------------------------------------------- --- Installing - --- |Install executables for GHCJS. -installExe :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^Where to copy the files to - -> FilePath -- ^Build location - -> (FilePath, FilePath) -- ^Executable (prefix,suffix) - -> PackageDescription - -> Executable - -> IO () -installExe verbosity lbi binDir buildPref - (progprefix, progsuffix) _pkg exe = do - createDirectoryIfMissingVerbose verbosity True binDir - let exeName' = unUnqualComponentName $ exeName exe - exeFileName = exeName' - fixedExeBaseName = progprefix ++ exeName' ++ progsuffix - installBinary dest = do - runDbProgram verbosity ghcjsProgram (withPrograms lbi) $ - [ "--install-executable" - , buildPref exeName' exeFileName - , "-o", dest - ] ++ - case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of - (True, Just strip) -> ["-strip-program", programPath strip] - _ -> [] - installBinary (binDir fixedExeBaseName) - - --- |Install foreign library for GHC. -installFLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^Build location - -> PackageDescription - -> ForeignLib - -> IO () -installFLib verbosity lbi targetDir builtDir _pkg flib = - install (foreignLibIsShared flib) - builtDir - targetDir - (flibTargetName lbi flib) - where - install _isShared srcDir dstDir name = do - let src = srcDir name - dst = dstDir name - createDirectoryIfMissingVerbose verbosity True targetDir - installOrdinaryFile verbosity src dst - - --- |Install for ghc, .hi, .a and, if --with-ghci given, .o -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 - whenVanilla $ copyModuleFiles "js_hi" - whenProf $ copyModuleFiles "js_p_hi" - whenShared $ copyModuleFiles "js_dyn_hi" - - -- whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName - -- whenProf $ installOrdinary builtDir targetDir $ toJSLibName profileLibName - -- whenShared $ installShared builtDir dynlibTargetDir $ toJSLibName sharedLibName - -- fixme do these make the correct lib names? - whenHasCode $ do - whenVanilla $ do - sequence_ [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f)) - | l <- getHSLibraryName (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib)) - , f <- "":extraLibFlavours (libBuildInfo lib) - ] - -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName) - whenProf $ do - installOrdinary builtDir' targetDir (toJSLibName profileLibName) - -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName) - whenShared $ - sequence_ [ installShared builtDir' dynlibTargetDir - (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f)) - | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) - , f <- "":extraDynLibFlavours (libBuildInfo lib) - ] - where - builtDir' = componentBuildDir lbi clbi - - install isShared isJS srcDir dstDir name = do - let src = srcDir name - dst = dstDir name - createDirectoryIfMissingVerbose verbosity True dstDir - - if isShared - then installExecutableFile verbosity src dst - else installOrdinaryFile verbosity src dst - - when (stripLibs lbi && not isJS) $ - Strip.stripLib verbosity - (hostPlatform lbi) (withPrograms lbi) dst - - installOrdinary = install False True - installShared = install True True - - copyModuleFiles ext = - findModuleFilesEx verbosity [builtDir'] [ext] (allLibModules lib clbi) - >>= installOrdinaryFiles verbosity targetDir - - compiler_id = compilerId (compiler lbi) - platform = hostPlatform lbi - uid = componentUnitId clbi - -- vanillaLibName = mkLibName uid - profileLibName = mkProfLibName uid - -- sharedLibName = (mkSharedLibName (hostPlatform lbi) compiler_id) uid - - hasLib = not $ null (allLibModules lib clbi) - && null (cSources (libBuildInfo lib)) - && null (cxxSources (libBuildInfo lib)) - && null (jsSources (libBuildInfo lib)) - has_code = not (componentIsIndefinite clbi) - whenHasCode = when has_code - whenVanilla = when (hasLib && withVanillaLib lbi) - whenProf = when (hasLib && withProfLib lbi && has_code) - -- whenGHCi = when (hasLib && withGHCiLib lbi && has_code) - whenShared = when (hasLib && withSharedLib lbi && has_code) - - -adjustExts :: String -> String -> GhcOptions -> GhcOptions -adjustExts hiSuf objSuf opts = - opts `mappend` mempty { - ghcOptHiSuffix = toFlag hiSuf, - ghcOptObjSuffix = toFlag objSuf - } - -isDynamic :: Compiler -> Bool -isDynamic = Internal.ghcLookupProperty "GHC Dynamic" - -supportsDynamicToo :: Compiler -> Bool -supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" - -withExt :: FilePath -> String -> FilePath -withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else "" - -findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version) -findGhcjsGhcVersion verbosity pgm = - findProgramVersion "--numeric-ghc-version" id verbosity pgm - -findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version) -findGhcjsPkgGhcjsVersion verbosity pgm = - findProgramVersion "--numeric-ghcjs-version" id verbosity pgm - --- ----------------------------------------------------------------------------- --- Registering - -hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo -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 - -registerPackage - :: Verbosity - -> ProgramDb - -> PackageDBStack - -> InstalledPackageInfo - -> HcPkg.RegisterOptions - -> IO () -registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = - HcPkg.register (hcPkgInfo progdb) verbosity packageDbs - installedPkgInfo registerOptions - -pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath -pkgRoot verbosity lbi = pkgRoot' - where - pkgRoot' GlobalPackageDB = - let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi) - in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg) - pkgRoot' UserPackageDB = do - appDir <- getAppUserDataDirectory "ghcjs" - -- fixme correct this version - let ver = compilerVersion (compiler lbi) - subdir = System.Info.arch ++ '-':System.Info.os - ++ '-':prettyShow ver - rootDir = appDir subdir - -- We must create the root directory for the user package database if it - -- does not yet exists. Otherwise '${pkgroot}' will resolve to a - -- directory at the time of 'ghc-pkg register', and registration will - -- fail. - createDirectoryIfMissing True rootDir - return rootDir - pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp) - - --- | Get the JavaScript file name and command and arguments to run a --- program compiled by GHCJS --- the exe should be the base program name without exe extension -runCmd :: ProgramDb -> FilePath - -> (FilePath, FilePath, [String]) +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +module Distribution.Simple.GHCJS + ( getGhcInfo + , configure + , getInstalledPackages + , getInstalledPackagesMonitorFiles + , getPackageDBContents + , buildLib + , buildFLib + , buildExe + , replLib + , replFLib + , replExe + , startInterpreter + , installLib + , installFLib + , installExe + , libAbiHash + , hcPkgInfo + , registerPackage + , componentGhcOptions + , Internal.componentCcGhcOptions + , getLibDir + , isDynamic + , getGlobalPackageDB + , pkgRoot + , runCmd + + -- * Constructing and deconstructing GHC environment files + , Internal.GhcEnvironmentFileEntry (..) + , Internal.simpleGhcEnvironmentFile + , Internal.renderGhcEnvironmentFile + , Internal.writeGhcEnvironmentFile + , Internal.ghcPlatformAndVersionString + , readGhcEnvironmentFile + , parseGhcEnvironmentFile + , ParseErrorExc (..) + + -- * Version-specific implementation quirks + , getImplInfo + , GhcImplInfo (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Package +import Distribution.PackageDescription as PD +import Distribution.PackageDescription.Utils (cabalBug) +import Distribution.Pretty +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Flag +import Distribution.Simple.GHC.EnvironmentParser +import Distribution.Simple.GHC.ImplInfo +import qualified Distribution.Simple.GHC.Internal as Internal +import qualified Distribution.Simple.Hpc as Hpc +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess.Types +import Distribution.Simple.Program +import Distribution.Simple.Program.GHC +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import qualified Distribution.Simple.Program.Strip as Strip +import Distribution.Simple.Setup.Common +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.PackageName.Magic +import Distribution.Types.ParStrat +import Distribution.Utils.NubList +import Distribution.Utils.Path +import Distribution.Verbosity (Verbosity) +import Distribution.Version + +import Control.Monad (msum) +import Data.Char (isLower) +import qualified Data.Map as Map +import System.Directory + ( canonicalizePath + , createDirectoryIfMissing + , doesFileExist + , getAppUserDataDirectory + , removeFile + , renameFile + ) +import System.FilePath + ( isRelative + , replaceExtension + , takeDirectory + , takeExtension + , (<.>) + , () + ) +import qualified System.Info + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure + :: Verbosity + -> Maybe FilePath + -> Maybe FilePath + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configure verbosity hcPath hcPkgPath conf0 = do + (ghcjsProg, ghcjsVersion, progdb1) <- + requireProgramVersion + verbosity + ghcjsProgram + (orLaterVersion (mkVersion [0, 1])) + (userMaybeSpecifyPath "ghcjs" hcPath conf0) + + Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg) + unless (ghcjsGhcVersion < mkVersion [8, 8]) $ + warn verbosity $ + "Unknown/unsupported 'ghc' version detected " + ++ "(Cabal " + ++ prettyShow cabalVersion + ++ " supports 'ghc' version < 8.8): " + ++ programPath ghcjsProg + ++ " is based on GHC version " + ++ prettyShow ghcjsGhcVersion + + let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion + + -- 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: + (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <- + requireProgramVersion + verbosity + ghcjsPkgProgram + { programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg + } + anyVersion + (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1) + + Just ghcjsPkgGhcjsVersion <- + findGhcjsPkgGhcjsVersion + verbosity + (programPath ghcjsPkgProg) + + when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ + dieWithException verbosity $ + VersionMismatchJS + (programPath ghcjsProg) + ghcjsVersion + (programPath ghcjsPkgProg) + ghcjsPkgGhcjsVersion + + when (ghcjsGhcVersion /= ghcjsPkgVersion) $ + dieWithException verbosity $ + VersionMismatchGHCJS (programPath ghcjsProg) ghcjsGhcVersion (programPath ghcjsPkgProg) ghcjsPkgVersion + + -- Likewise we try to find the matching hsc2hs and haddock programs. + let hsc2hsProgram' = + hsc2hsProgram + { programFindLocation = + guessHsc2hsFromGhcjsPath ghcjsProg + } + haddockProgram' = + haddockProgram + { programFindLocation = + guessHaddockFromGhcjsPath ghcjsProg + } + hpcProgram' = + hpcProgram + { programFindLocation = guessHpcFromGhcjsPath ghcjsProg + } + {- + runghcProgram' = runghcProgram { + programFindLocation = guessRunghcFromGhcjsPath ghcjsProg + } -} + 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 + + 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) + +guessGhcjsPkgFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram + +guessHsc2hsFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram + +guessHaddockFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram + +guessHpcFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHpcFromGhcjsPath = guessToolFromGhcjsPath hpcProgram + +guessToolFromGhcjsPath + :: Program + -> ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath = + do + let toolname = programName tool + given_path = programPath ghcjsProg + given_dir = takeDirectory given_path + real_path <- canonicalizePath given_path + let real_dir = takeDirectory real_path + versionSuffix path = takeVersionSuffix (dropExeExtension path) + given_suf = versionSuffix given_path + real_suf = versionSuffix real_path + guessNormal dir = dir toolname <.> exeExtension buildPlatform + guessGhcjs dir = + dir + (toolname ++ "-ghcjs") + <.> exeExtension buildPlatform + guessGhcjsVersioned dir suf = + dir + (toolname ++ "-ghcjs" ++ suf) + <.> exeExtension buildPlatform + guessVersioned dir suf = + dir + (toolname ++ suf) + <.> exeExtension buildPlatform + mkGuesses dir suf + | null suf = [guessGhcjs dir, guessNormal dir] + | otherwise = + [ guessGhcjsVersioned dir suf + , guessVersioned dir suf + , guessGhcjs dir + , guessNormal dir + ] + guesses = + mkGuesses given_dir given_suf + ++ if real_path == given_path + then [] + else mkGuesses real_dir real_suf + info verbosity $ + "looking for tool " + ++ toolname + ++ " near compiler in " + ++ given_dir + debug verbosity $ "candidate locations: " ++ show guesses + exists <- traverse doesFileExist guesses + case [file | (file, True) <- zip guesses exists] of + -- If we can't find it near ghc, fall back to the usual + -- method. + [] -> programFindLocation tool verbosity searchpath + (fp : _) -> do + info verbosity $ "found " ++ toolname ++ " in " ++ fp + let lookedAt = + map fst + . takeWhile (\(_file, exist) -> not exist) + $ zip guesses exists + return (Just (fp, lookedAt)) + where + takeVersionSuffix :: FilePath -> String + takeVersionSuffix = takeWhileEndLE isSuffixChar + + isSuffixChar :: Char -> Bool + isSuffixChar c = isDigit c || c == '.' || c == '-' + +getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] +getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg + where + version = fromMaybe (error "GHCJS.getGhcInfo: no version") $ programVersion ghcjsProg + implInfo = ghcVersionImplInfo version + +-- | Given a single package DB, return all installed packages. +getPackageDBContents + :: Verbosity + -> PackageDB + -> ProgramDb + -> IO InstalledPackageIndex +getPackageDBContents verbosity packagedb progdb = do + pkgss <- getInstalledPackages' verbosity [packagedb] progdb + toPackageIndex verbosity pkgss progdb + +-- | Given a package DB stack, return all installed packages. +getInstalledPackages + :: Verbosity + -> PackageDBStack + -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity packagedbs progdb = do + checkPackageDbEnvVar verbosity + checkPackageDbStack verbosity packagedbs + pkgss <- getInstalledPackages' verbosity packagedbs progdb + index <- toPackageIndex verbosity pkgss progdb + return $! index + +toPackageIndex + :: Verbosity + -> [(PackageDB, [InstalledPackageInfo])] + -> ProgramDb + -> IO InstalledPackageIndex +toPackageIndex verbosity pkgss progdb = do + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it. + topDir <- getLibDir' verbosity ghcjsProg + let indices = + [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss + ] + return $! (mconcat indices) + where + ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb + +getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath +getLibDir verbosity lbi = + dropWhileEndLE isSpace + `fmap` getDbProgramOutput + verbosity + ghcjsProgram + (withPrograms lbi) + ["--print-libdir"] + +getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath +getLibDir' verbosity ghcjsProg = + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcjsProg ["--print-libdir"] + +-- | Return the 'FilePath' to the global GHC package database. +getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath +getGlobalPackageDB verbosity ghcProg = + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcProg ["--print-global-package-db"] + +-- | Return the 'FilePath' to the per-user GHC package database. +getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath +getUserPackageDB _verbosity ghcjsProg platform = do + -- It's rather annoying that we have to reconstruct this, because ghc + -- hides this information from us otherwise. But for certain use cases + -- like change monitoring it really can't remain hidden. + appdir <- getAppUserDataDirectory "ghcjs" + return (appdir platformAndVersion packageConfFileName) + where + platformAndVersion = + Internal.ghcPlatformAndVersionString + platform + ghcjsVersion + packageConfFileName = "package.conf.d" + ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg + +checkPackageDbEnvVar :: Verbosity -> IO () +checkPackageDbEnvVar verbosity = + Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH" + +checkPackageDbStack :: Verbosity -> PackageDBStack -> IO () +checkPackageDbStack _ (GlobalPackageDB : rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStack verbosity rest + | GlobalPackageDB `notElem` rest = + dieWithException verbosity GlobalPackageDBLimitation +checkPackageDbStack verbosity _ = + dieWithException verbosity GlobalPackageDBSpecifiedFirst + +getInstalledPackages' + :: Verbosity + -> [PackageDB] + -> ProgramDb + -> IO [(PackageDB, [InstalledPackageInfo])] +getInstalledPackages' verbosity packagedbs progdb = + sequenceA + [ do + pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb + return (packagedb, pkgs) + | packagedb <- packagedbs + ] + +-- | Get the packages from specific PackageDBs, not cumulative. +getInstalledPackagesMonitorFiles + :: Verbosity + -> Platform + -> ProgramDb + -> [PackageDB] + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity platform progdb = + traverse getPackageDBPath + where + getPackageDBPath :: PackageDB -> IO FilePath + getPackageDBPath GlobalPackageDB = + selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg + getPackageDBPath UserPackageDB = + selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform + getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path + + -- GHC has old style file dbs, and new style directory dbs. + -- Note that for dir style dbs, we only need to monitor the cache file, not + -- the whole directory. The ghc program itself only reads the cache file + -- so it's safe to only monitor this one file. + selectMonitorFile path = do + isFileStyle <- doesFileExist path + if isFileStyle + then return path + else return (path "package.cache") + + ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb + +toJSLibName :: String -> String +toJSLibName lib + | takeExtension lib `elem` [".dll", ".dylib", ".so"] = + replaceExtension lib "js_so" + | takeExtension lib == ".a" = replaceExtension lib "js_a" + | otherwise = lib <.> "js_a" + +-- ----------------------------------------------------------------------------- +-- Building a library + +buildLib + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +buildLib = buildOrReplLib Nothing + +replLib + :: [String] + -> Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +replLib = buildOrReplLib . Just + +buildOrReplLib + :: Maybe [String] + -> Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do + let uid = componentUnitId clbi + libTargetDir = componentBuildDir lbi clbi + whenVanillaLib forceVanilla = + when (forceVanilla || withVanillaLib lbi) + whenProfLib = when (withProfLib lbi) + whenSharedLib forceShared = + when (forceShared || withSharedLib lbi) + whenStaticLib forceStatic = + when (forceStatic || withStaticLib lbi) + -- whenGHCiLib = when (withGHCiLib lbi) + forRepl = maybe False (const True) mReplFlags + -- ifReplLib = when forRepl + comp = compiler lbi + implInfo = getImplInfo comp + platform@(Platform _hostArch _hostOS) = hostPlatform lbi + has_code = not (componentIsIndefinite clbi) + + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) + let runGhcjsProg = runGHC verbosity ghcjsProg comp platform + + let libBi = libBuildInfo lib + + -- fixme flags shouldn't depend on ghcjs being dynamic or not + let isGhcjsDynamic = isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + doingTH = usesTemplateHaskellOrQQ libBi + forceVanillaLib = doingTH && not isGhcjsDynamic + forceSharedLib = doingTH && isGhcjsDynamic + -- TH always needs default libs, even when building for profiling + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = libCoverage lbi + hpcdir way + | forRepl = mempty -- HPC is not supported in ghci + | isCoverageEnabled = toFlag $ Hpc.mixDir (libTargetDir extraCompilationArtifacts) way + | otherwise = mempty + + createDirectoryIfMissingVerbose verbosity True libTargetDir + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? + let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) + jsSrcs = jsSources libBi + cObjs = map (`replaceExtension` objExtension) cLikeFiles + baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir + linkJsLibOpts = + mempty + { ghcOptExtra = + [ "-link-js-lib" + , getHSLibraryName uid + , "-js-lib-outputdir" + , libTargetDir + ] + ++ jsSrcs + } + vanillaOptsNoJsLib = + baseOpts + `mappend` mempty + { ghcOptMode = toFlag GhcModeMake + , ghcOptNumJobs = numJobs + , ghcOptInputModules = toNubListR $ allLibModules lib clbi + , ghcOptHPCDir = hpcdir Hpc.Vanilla + } + vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts + + profOpts = + adjustExts "p_hi" "p_o" vanillaOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + True + (withProfLibDetail lbi) + , -- ghcOptHiSuffix = toFlag "p_hi", + -- ghcOptObjSuffix = toFlag "p_o", + ghcOptExtra = hcProfOptions GHC libBi + , ghcOptHPCDir = hpcdir Hpc.Prof + } + + sharedOpts = + adjustExts "dyn_hi" "dyn_o" vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , -- ghcOptHiSuffix = toFlag "dyn_hi", + -- ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = hcSharedOptions GHC libBi + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + + vanillaSharedOpts = + vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic + , ghcOptDynHiSuffix = toFlag "js_dyn_hi" + , ghcOptDynObjSuffix = toFlag "js_dyn_o" + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + + unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $ + do + let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts) + shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts) + useDynToo = + dynamicTooSupported + && (forceVanillaLib || withVanillaLib lbi) + && (forceSharedLib || withSharedLib lbi) + && null (hcSharedOptions GHC libBi) + if not has_code + then vanilla + else + if useDynToo + then do + runGhcjsProg vanillaSharedOpts + case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of + (Flag dynDir, Flag vanillaDir) -> + -- When the vanilla and shared library builds are done + -- in one pass, only one set of HPC module interfaces + -- are generated. This set should suffice for both + -- static and dynamically linked executables. We copy + -- the modules interfaces so they are available under + -- both ways. + copyDirectoryRecursive verbosity dynDir vanillaDir + _ -> return () + else + if isGhcjsDynamic + then do shared; vanilla + else do vanilla; shared + whenProfLib (runGhcjsProg profOpts) + + -- Build any C++ sources separately. + {- + unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do + info verbosity "Building C++ Sources..." + sequence_ + [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename + vanillaCxxOpts = if isGhcjsDynamic + then baseCxxOpts { ghcOptFPic = toFlag True } + else baseCxxOpts + profCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCxxOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded cxxOpts = do + needsRecomp <- checkNeedsRecompilation filename cxxOpts + when needsRecomp $ runGhcjsProg cxxOpts + runGhcProgIfNeeded vanillaCxxOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) + | filename <- cxxSources libBi] + + ifReplLib $ do + when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" + ifReplLib (runGhcjsProg replOpts) + -} + -- build any C sources + -- TODO: Add support for S and CMM files. + {- + unless (not has_code || null (cSources libBi) || not nativeToo) $ do + info verbosity "Building C Sources..." + sequence_ + [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename + vanillaCcOpts = if isGhcjsDynamic + -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + then baseCcOpts { ghcOptFPic = toFlag True } + else baseCcOpts + profCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCcOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded ccOpts = do + needsRecomp <- checkNeedsRecompilation filename ccOpts + when needsRecomp $ runGhcjsProg ccOpts + runGhcProgIfNeeded vanillaCcOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) + | filename <- cSources libBi] + -} + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + + -- link: + + when has_code . when False {- fixme nativeToo -} . unless forRepl $ do + info verbosity "Linking..." + let cSharedObjs = + map + (`replaceExtension` ("dyn_" ++ objExtension)) + (cSources libBi ++ cxxSources libBi) + compiler_id = compilerId (compiler lbi) + sharedLibFilePath = libTargetDir mkSharedLibName (hostPlatform lbi) compiler_id uid + staticLibFilePath = libTargetDir mkStaticLibName (hostPlatform lbi) compiler_id uid + + 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 + lib + lbi + clbi + libTargetDir + objExtension + True + hSharedObjs <- + if withSharedLib lbi + then + Internal.getHaskellObjects + implInfo + lib + lbi + clbi + libTargetDir + ("dyn_" ++ objExtension) + False + else return [] + + unless (null hObjs && null cObjs && null stubObjs) $ do + rpaths <- getRPaths lbi clbi + + let staticObjectFiles = + hObjs + ++ map (libTargetDir ) cObjs + ++ stubObjs + dynamicObjectFiles = + hSharedObjs + ++ map (libTargetDir ) cSharedObjs + ++ stubSharedObjs + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs = + mempty + { ghcOptShared = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptInputFiles = toNubListR dynamicObjectFiles + , ghcOptOutputFile = toFlag sharedLibFilePath + , ghcOptExtra = 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 + , 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 + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi + , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi + , ghcOptLinkFrameworkDirs = + toNubListR $ PD.extraFrameworkDirs libBi + , ghcOptRPaths = rpaths + } + ghcStaticLinkArgs = + mempty + { ghcOptStaticLib = toFlag True + , ghcOptInputFiles = toNubListR staticObjectFiles + , ghcOptOutputFile = toFlag staticLibFilePath + , 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 + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi + } + + info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) + {- + whenVanillaLib False $ do + Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity lbi ldProg + ghciLibFilePath staticObjectFiles + -} + {- + whenProfLib $ do + Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity lbi ldProg + ghciProfLibFilePath profObjectFiles + -} + whenSharedLib False $ + runGhcjsProg ghcSharedLinkArgs + + whenStaticLib False $ + runGhcjsProg ghcStaticLinkArgs + +-- | Start a REPL without loading any source files. +startInterpreter + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> PackageDBStack + -> IO () +startInterpreter verbosity progdb comp platform packageDBs = do + let replOpts = + mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptPackageDBs = packageDBs + } + checkPackageDbStack verbosity packageDBs + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb + runGHC verbosity ghcjsProg comp platform replOpts + +-- ----------------------------------------------------------------------------- +-- Building an executable or foreign library + +-- | Build a foreign library +buildFLib + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib + +replFLib + :: [String] + -> Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +replFLib replFlags v njobs pkg lbi = + gbuild v njobs pkg lbi . GReplFLib replFlags + +-- | Build an executable with GHC. +buildExe + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe + +replExe + :: [String] + -> Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +replExe replFlags v njobs pkg lbi = + gbuild v njobs pkg lbi . GReplExe replFlags + +-- | Building an executable, starting the REPL, and building foreign +-- libraries are all very similar and implemented in 'gbuild'. The +-- 'GBuildMode' distinguishes between the various kinds of operation. +data GBuildMode + = GBuildExe Executable + | GReplExe [String] Executable + | GBuildFLib ForeignLib + | GReplFLib [String] ForeignLib + +gbuildInfo :: GBuildMode -> BuildInfo +gbuildInfo (GBuildExe exe) = buildInfo exe +gbuildInfo (GReplExe _ exe) = buildInfo exe +gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib +gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib + +gbuildName :: GBuildMode -> String +gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe +gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe +gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib +gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib + +gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String +gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe +gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe +gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib +gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib + +exeTargetName :: Platform -> Executable -> String +exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform + +-- | Target name for a foreign library (the actual file name) +-- +-- We do not use mkLibName and co here because the naming for foreign libraries +-- is slightly different (we don't use "_p" or compiler version suffices, and we +-- don't want the "lib" prefix on Windows). +-- +-- TODO: We do use `dllExtension` and co here, but really that's wrong: they +-- use the OS used to build cabal to determine which extension to use, rather +-- than the target OS (but this is wrong elsewhere in Cabal as well). +flibTargetName :: LocalBuildInfo -> ForeignLib -> String +flibTargetName lbi flib = + case (os, foreignLibType flib) of + (Windows, ForeignLibNativeShared) -> nm <.> "dll" + (Windows, ForeignLibNativeStatic) -> nm <.> "lib" + (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt + (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi) + (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) + (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" + where + nm :: String + nm = unUnqualComponentName $ foreignLibName flib + + os :: OS + os = + let (Platform _ os') = hostPlatform lbi + in os' + + -- If a foreign lib foo has lib-version-info 5:1:2 or + -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 + -- Libtool's version-info data is translated into library versions in a + -- nontrivial way: so refer to libtool documentation. + versionedExt :: String + versionedExt = + let nums = foreignLibVersion flib os + in foldl (<.>) "so" (map show nums) + +-- | Name for the library when building. +-- +-- If the `lib-version-info` field or the `lib-version-linux` field of +-- a foreign library target is set, we need to incorporate that +-- version into the SONAME field. +-- +-- If a foreign library foo has lib-version-info 5:1:2, it should be +-- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. +-- However, GHC does not allow overriding soname by setting linker +-- options, as it sets a soname of its own (namely the output +-- filename), after the user-supplied linker options. Hence, we have +-- to compile the library with the soname as its filename. We rename +-- the compiled binary afterwards. +-- +-- This method allows to adjust the name of the library at build time +-- such that the correct soname can be set. +flibBuildName :: LocalBuildInfo -> ForeignLib -> String +flibBuildName lbi flib + -- On linux, if a foreign-library has version data, the first digit is used + -- to produce the SONAME. + | (os, foreignLibType flib) + == (Linux, ForeignLibNativeShared) = + let nums = foreignLibVersion flib os + in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) + | otherwise = flibTargetName lbi flib + where + os :: OS + os = + let (Platform _ os') = hostPlatform lbi + in os' + + nm :: String + nm = unUnqualComponentName $ foreignLibName flib + +gbuildIsRepl :: GBuildMode -> Bool +gbuildIsRepl (GBuildExe _) = False +gbuildIsRepl (GReplExe _ _) = True +gbuildIsRepl (GBuildFLib _) = False +gbuildIsRepl (GReplFLib _ _) = True + +gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool +gbuildNeedDynamic lbi bm = + case bm of + GBuildExe _ -> withDynExe lbi + GReplExe _ _ -> withDynExe lbi + GBuildFLib flib -> withDynFLib flib + GReplFLib _ flib -> withDynFLib flib + where + withDynFLib flib = + case foreignLibType flib of + ForeignLibNativeShared -> + ForeignLibStandalone `notElem` foreignLibOptions flib + ForeignLibNativeStatic -> + False + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" + +gbuildModDefFiles :: GBuildMode -> [FilePath] +gbuildModDefFiles (GBuildExe _) = [] +gbuildModDefFiles (GReplExe _ _) = [] +gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib +gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib + +-- | "Main" module name when overridden by @ghc-options: -main-is ...@ +-- or 'Nothing' if no @-main-is@ flag could be found. +-- +-- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. +exeMainModuleName :: Executable -> Maybe ModuleName +exeMainModuleName Executable{buildInfo = bnfo} = + -- GHC honors the last occurrence of a module name updated via -main-is + -- + -- Moreover, -main-is when parsed left-to-right can update either + -- the "Main" module name, or the "main" function name, or both, + -- see also 'decodeMainIsArg'. + msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts + where + ghcopts = hcOptions GHC bnfo + + findIsMainArgs [] = [] + findIsMainArgs ("-main-is" : arg : rest) = arg : findIsMainArgs rest + findIsMainArgs (_ : rest) = findIsMainArgs rest + +-- | Decode argument to '-main-is' +-- +-- Returns 'Nothing' if argument set only the function name. +-- +-- This code has been stolen/refactored from GHC's DynFlags.setMainIs +-- function. The logic here is deliberately imperfect as it is +-- intended to be bug-compatible with GHC's parser. See discussion in +-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. +decodeMainIsArg :: String -> Maybe ModuleName +decodeMainIsArg arg + | headOf main_fn isLower = + -- The arg looked like "Foo.Bar.baz" + Just (ModuleName.fromString main_mod) + | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" + = + Just (ModuleName.fromString arg) + | otherwise -- The arg looked like "baz" + = + Nothing + where + headOf :: String -> (Char -> Bool) -> Bool + headOf str pred' = any pred' (safeHead str) + + (main_mod, main_fn) = splitLongestPrefix arg (== '.') + + splitLongestPrefix :: String -> (Char -> Bool) -> (String, String) + splitLongestPrefix str pred' + | null r_pre = (str, []) + | otherwise = (reverse (safeTail r_pre), reverse r_suf) + where + -- 'safeTail' drops the char satisfying 'pred' + (r_suf, r_pre) = break pred' (reverse str) + +-- | A collection of: +-- * C input files +-- * C++ input files +-- * GHC input files +-- * GHC input modules +-- +-- Used to correctly build and link sources. +data BuildSources = BuildSources + { cSourcesFiles :: [FilePath] + , cxxSourceFiles :: [FilePath] + , inputSourceFiles :: [FilePath] + , inputSourceModules :: [ModuleName] + } + +-- | Locate and return the 'BuildSources' required to build and link. +gbuildSources + :: Verbosity + -> PackageId + -> CabalSpecVersion + -> FilePath + -> GBuildMode + -> IO BuildSources +gbuildSources verbosity pkgId specVer tmpDir bm = + case bm of + GBuildExe exe -> exeSources exe + GReplExe _ exe -> exeSources exe + GBuildFLib flib -> return $ flibSources flib + GReplFLib _ flib -> return $ flibSources flib + where + exeSources :: Executable -> IO BuildSources + exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do + main <- findFileEx verbosity (tmpDir : map getSymbolicPath (hsSourceDirs bnfo)) modPath + let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe + otherModNames = exeModules exe + + -- Scripts have fakePackageId and are always Haskell but can have any extension. + if isHaskell main || pkgId == fakePackageId + then + if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) + then do + -- The cabal manual clearly states that `other-modules` is + -- intended for non-main modules. However, there's at least one + -- important package on Hackage (happy-1.19.5) which + -- violates this. We workaround this here so that we don't + -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which + -- would result in GHC complaining about duplicate Main + -- modules. + -- + -- Finally, we only enable this workaround for + -- specVersion < 2, as 'cabal-version:>=2.0' cabal files + -- have no excuse anymore to keep doing it wrong... ;-) + warn verbosity $ + "Enabling workaround for Main module '" + ++ prettyShow mainModName + ++ "' listed in 'other-modules' illegally!" + + return + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [main] + , inputSourceModules = filter (/= mainModName) $ exeModules exe + } + else + return + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [main] + , inputSourceModules = exeModules exe + } + else + let (csf, cxxsf) + | isCxx main = (cSources bnfo, main : cxxSources bnfo) + -- if main is not a Haskell source + -- and main is not a C++ source + -- then we assume that it is a C source + | otherwise = (main : cSources bnfo, cxxSources bnfo) + in return + BuildSources + { cSourcesFiles = csf + , cxxSourceFiles = cxxsf + , inputSourceFiles = [] + , inputSourceModules = exeModules exe + } + + flibSources :: ForeignLib -> BuildSources + flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [] + , 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 + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> GBuildMode + -> ComponentLocalBuildInfo + -> IO () +gbuild verbosity numJobs pkg_descr lbi bm clbi = do + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) + let replFlags = case bm of + GReplExe flags _ -> flags + GReplFLib flags _ -> flags + GBuildExe{} -> mempty + GBuildFLib{} -> mempty + comp = compiler lbi + platform = hostPlatform lbi + runGhcProg = runGHC verbosity ghcjsProg comp platform + + let (bnfo, threaded) = case bm of + GBuildFLib _ -> popThreadedFlag (gbuildInfo bm) + _ -> (gbuildInfo bm, False) + + -- the name that GHC really uses (e.g., with .exe on Windows for executables) + let targetName = gbuildTargetName lbi bm + let targetDir = buildDir lbi (gbuildName bm) + let tmpDir = targetDir (gbuildName bm ++ "-tmp") + createDirectoryIfMissingVerbose verbosity True targetDir + createDirectoryIfMissingVerbose verbosity True tmpDir + + -- 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 = exeCoverage lbi + hpcdir way + | gbuildIsRepl bm = mempty -- HPC is not supported in ghci + | isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir extraCompilationArtifacts) way + | otherwise = mempty + + rpaths <- getRPaths lbi clbi + buildSources <- gbuildSources verbosity (package pkg_descr) (specVersion pkg_descr) tmpDir bm + + let cSrcs = cSourcesFiles buildSources + cxxSrcs = cxxSourceFiles buildSources + inputFiles = inputSourceFiles buildSources + inputModules = inputSourceModules buildSources + isGhcDynamic = isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + cObjs = map (`replaceExtension` objExtension) cSrcs + cxxObjs = map (`replaceExtension` objExtension) cxxSrcs + needDynamic = gbuildNeedDynamic lbi bm + needProfiling = withProfExe lbi + + -- build executables + buildRunner = case clbi of + LibComponentLocalBuildInfo{} -> False + FLibComponentLocalBuildInfo{} -> False + ExeComponentLocalBuildInfo{} -> True + TestComponentLocalBuildInfo{} -> True + BenchComponentLocalBuildInfo{} -> True + baseOpts = + (componentGhcOptions verbosity lbi bnfo clbi tmpDir) + `mappend` mempty + { ghcOptMode = toFlag GhcModeMake + , ghcOptInputFiles = + toNubListR $ + if package pkg_descr == fakePackageId + then filter isHaskell inputFiles + else inputFiles + , ghcOptInputScripts = + toNubListR $ + if package pkg_descr == fakePackageId + then filter (not . isHaskell) inputFiles + else [] + , ghcOptInputModules = toNubListR inputModules + , -- for all executable components (exe/test/bench), + -- GHCJS must be passed the "-build-runner" option + ghcOptExtra = + if buildRunner + then ["-build-runner"] + else mempty + } + staticOpts = + baseOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticOnly + , ghcOptHPCDir = hpcdir Hpc.Vanilla + } + profOpts = + baseOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + False + (withProfExeDetail lbi) + , ghcOptHiSuffix = toFlag "p_hi" + , ghcOptObjSuffix = toFlag "p_o" + , ghcOptExtra = hcProfOptions GHC bnfo + , ghcOptHPCDir = hpcdir Hpc.Prof + } + dynOpts = + baseOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , -- TODO: Does it hurt to set -fPIC for executables? + ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcSharedOptions GHC bnfo + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + dynTooOpts = + staticOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic + , ghcOptDynHiSuffix = toFlag "dyn_hi" + , ghcOptDynObjSuffix = toFlag "dyn_o" + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = + mempty + { ghcOptLinkOptions = PD.ldOptions bnfo + , ghcOptLinkLibs = extraLibs bnfo + , ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo + , ghcOptLinkFrameworks = + toNubListR $ + PD.frameworks bnfo + , ghcOptLinkFrameworkDirs = + toNubListR $ + PD.extraFrameworkDirs bnfo + , ghcOptInputFiles = + toNubListR + [tmpDir x | x <- cObjs ++ cxxObjs] + } + dynLinkerOpts = + mempty + { ghcOptRPaths = rpaths + } + replOpts = + baseOpts + { ghcOptExtra = + Internal.filterGhciFlags + (ghcOptExtra baseOpts) + <> replFlags + } + -- For a normal compile we do separate invocations of ghc for + -- compiling as for linking. But for repl we have to do just + -- the one invocation, so that one has to include all the + -- linker stuff too, like -l flags and any .o files from C + -- files etc. + `mappend` linkerOpts + `mappend` mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptOptimisation = toFlag GhcNoOptimisation + } + commonOpts + | needProfiling = profOpts + | needDynamic = dynOpts + | otherwise = staticOpts + compileOpts + | useDynToo = dynTooOpts + | otherwise = commonOpts + withStaticExe = not needProfiling && not needDynamic + + -- For building exe's that use TH with -prof or -dynamic we actually have + -- to build twice, once without -prof/-dynamic and then again with + -- -prof/-dynamic. This is because the code that TH needs to run at + -- compile time needs to be the vanilla ABI so it can be loaded up and run + -- by the compiler. + -- With dynamic-by-default GHC the TH object files loaded at compile-time + -- need to be .dyn_o instead of .o. + doingTH = usesTemplateHaskellOrQQ bnfo + -- Should we use -dynamic-too instead of compiling twice? + useDynToo = + dynamicTooSupported + && isGhcDynamic + && doingTH + && withStaticExe + && null (hcSharedOptions GHC bnfo) + compileTHOpts + | isGhcDynamic = dynOpts + | otherwise = staticOpts + compileForTH + | gbuildIsRepl bm = False + | useDynToo = False + | isGhcDynamic = doingTH && (needProfiling || withStaticExe) + | otherwise = doingTH && (needProfiling || needDynamic) + + -- Build static/dynamic object files for TH, if needed. + when compileForTH $ + runGhcProg + compileTHOpts + { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs + } + + -- Do not try to build anything if there are no input files. + -- This can happen if the cabal file ends up with only cSrcs + -- but no Haskell modules. + unless + ( (null inputFiles && null inputModules) + || gbuildIsRepl bm + ) + $ runGhcProg + compileOpts + { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs + } + + -- build any C++ sources + unless (null cxxSrcs) $ do + info verbosity "Building C++ Sources..." + sequence_ + [ do + let baseCxxOpts = + Internal.componentCxxGhcOptions + verbosity + lbi + bnfo + clbi + tmpDir + filename + vanillaCxxOpts = + if isGhcDynamic + then -- Dynamic GHC requires C++ sources to be built + -- with -fPIC for REPL to work. See #2207. + baseCxxOpts{ghcOptFPic = toFlag True} + else baseCxxOpts + profCxxOpts = + vanillaCxxOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + } + sharedCxxOpts = + vanillaCxxOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + opts + | needProfiling = profCxxOpts + | needDynamic = sharedCxxOpts + | otherwise = vanillaCxxOpts + -- TODO: Placing all Haskell, C, & C++ objects in a single directory + -- Has the potential for file collisions. In general we would + -- consider this a user error. However, we should strive to + -- add a warning if this occurs. + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True odir + needsRecomp <- checkNeedsRecompilation filename opts + when needsRecomp $ + runGhcProg opts + | filename <- cxxSrcs + ] + + -- build any C sources + unless (null cSrcs) $ do + info verbosity "Building C Sources..." + sequence_ + [ do + let baseCcOpts = + Internal.componentCcGhcOptions + verbosity + lbi + bnfo + clbi + tmpDir + filename + vanillaCcOpts = + if isGhcDynamic + then -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + baseCcOpts{ghcOptFPic = toFlag True} + else baseCcOpts + profCcOpts = + vanillaCcOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + } + sharedCcOpts = + vanillaCcOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + opts + | needProfiling = profCcOpts + | needDynamic = sharedCcOpts + | otherwise = vanillaCcOpts + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True odir + needsRecomp <- checkNeedsRecompilation filename opts + when needsRecomp $ + runGhcProg opts + | filename <- cSrcs + ] + + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + case bm of + GReplExe _ _ -> runGhcProg replOpts + GReplFLib _ _ -> runGhcProg replOpts + GBuildExe _ -> do + let linkOpts = + commonOpts + `mappend` linkerOpts + `mappend` mempty + { ghcOptLinkNoHsMain = toFlag (null inputFiles) + } + `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) + + info verbosity "Linking..." + -- Work around old GHCs not relinking in this + -- situation, see #3294 + let target = targetDir targetName + when (compilerVersion comp < mkVersion [7, 7]) $ do + e <- doesFileExist target + when e (removeFile target) + runGhcProg linkOpts{ghcOptOutputFile = toFlag target} + GBuildFLib flib -> do + let rtsInfo = extractRtsInfo lbi + rtsOptLinkLibs = + [ if needDynamic + then + if threaded + then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) + else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) + else + if threaded + then statRtsThreadedLib (rtsStaticInfo rtsInfo) + else statRtsVanillaLib (rtsStaticInfo rtsInfo) + ] + linkOpts = case foreignLibType flib of + ForeignLibNativeShared -> + commonOpts + `mappend` linkerOpts + `mappend` dynLinkerOpts + `mappend` mempty + { ghcOptLinkNoHsMain = toFlag True + , ghcOptShared = toFlag True + , ghcOptLinkLibs = rtsOptLinkLibs + , ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo + , ghcOptFPic = toFlag True + , ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm + } + ForeignLibNativeStatic -> + -- this should be caught by buildFLib + -- (and if we do implement this, we probably don't even want to call + -- ghc here, but rather Ar.createArLibArchive or something) + cabalBug "static libraries not yet implemented" + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" + -- We build under a (potentially) different filename to set a + -- soname on supported platforms. See also the note for + -- @flibBuildName@. + info verbosity "Linking..." + let buildName = flibBuildName lbi flib + runGhcProg linkOpts{ghcOptOutputFile = toFlag (targetDir buildName)} + renameFile (targetDir buildName) (targetDir targetName) + +data DynamicRtsInfo = DynamicRtsInfo + { dynRtsVanillaLib :: FilePath + , dynRtsThreadedLib :: FilePath + , dynRtsDebugLib :: FilePath + , dynRtsEventlogLib :: FilePath + , dynRtsThreadedDebugLib :: FilePath + , dynRtsThreadedEventlogLib :: FilePath + } + +data StaticRtsInfo = StaticRtsInfo + { statRtsVanillaLib :: FilePath + , statRtsThreadedLib :: FilePath + , statRtsDebugLib :: FilePath + , statRtsEventlogLib :: FilePath + , statRtsThreadedDebugLib :: FilePath + , statRtsThreadedEventlogLib :: FilePath + , statRtsProfilingLib :: FilePath + , statRtsThreadedProfilingLib :: FilePath + } + +data RtsInfo = RtsInfo + { rtsDynamicInfo :: DynamicRtsInfo + , rtsStaticInfo :: StaticRtsInfo + , rtsLibPaths :: [FilePath] + } + +-- | Extract (and compute) information about the RTS library +-- +-- TODO: This hardcodes the name as @HSrts-ghc@. I don't know if we can +-- find this information somewhere. We can lookup the 'hsLibraries' field of +-- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which +-- doesn't really help. +extractRtsInfo :: LocalBuildInfo -> RtsInfo +extractRtsInfo lbi = + case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of + [(_, [rts])] -> aux rts + _otherwise -> error "No (or multiple) ghc rts package is registered" + where + aux :: InstalledPackageInfo -> RtsInfo + aux rts = + RtsInfo + { rtsDynamicInfo = + DynamicRtsInfo + { dynRtsVanillaLib = withGhcVersion "HSrts" + , dynRtsThreadedLib = withGhcVersion "HSrts_thr" + , dynRtsDebugLib = withGhcVersion "HSrts_debug" + , dynRtsEventlogLib = withGhcVersion "HSrts_l" + , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" + , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" + } + , rtsStaticInfo = + StaticRtsInfo + { statRtsVanillaLib = "HSrts" + , statRtsThreadedLib = "HSrts_thr" + , statRtsDebugLib = "HSrts_debug" + , statRtsEventlogLib = "HSrts_l" + , statRtsThreadedDebugLib = "HSrts_thr_debug" + , statRtsThreadedEventlogLib = "HSrts_thr_l" + , statRtsProfilingLib = "HSrts_p" + , statRtsThreadedProfilingLib = "HSrts_thr_p" + } + , rtsLibPaths = InstalledPackageInfo.libraryDirs rts + } + withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) + +-- | 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. +checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool +checkNeedsRecompilation filename opts = filename `moreRecentFile` oname + where + oname = getObjectFileName filename opts + +-- | Finds the object file name of the given source file +getObjectFileName :: FilePath -> GhcOptions -> FilePath +getObjectFileName filename opts = oname + where + odir = fromFlag (ghcOptObjDir opts) + oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) + oname = odir replaceExtension filename oext + +-- | Calculate the RPATHs for the component we are building. +-- +-- Calculates relative RPATHs when 'relocatable' is set. +getRPaths + :: LocalBuildInfo + -> ComponentLocalBuildInfo + -- ^ Component we are building + -> IO (NubListR FilePath) +getRPaths lbi clbi | supportRPaths hostOS = do + libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi + let hostPref = case hostOS of + OSX -> "@loader_path" + _ -> "$ORIGIN" + relPath p = if isRelative p then hostPref p else p + rpaths = toNubListR (map relPath libraryPaths) + return rpaths + where + (Platform _ hostOS) = hostPlatform lbi + compid = compilerId . compiler $ lbi + + -- The list of RPath-supported operating systems below reflects the + -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ + -- reflect whether the OS supports RPATH. + + -- E.g. when this comment was written, the *BSD operating systems were + -- untested with regards to Cabal RPATH handling, and were hence set to + -- 'False', while those operating systems themselves do support RPATH. + supportRPaths Linux = True + supportRPaths Windows = False + supportRPaths OSX = True + supportRPaths FreeBSD = + case compid of + CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True + _ -> False + supportRPaths OpenBSD = False + supportRPaths NetBSD = False + supportRPaths DragonFly = False + supportRPaths Solaris = False + supportRPaths AIX = False + supportRPaths HPUX = False + supportRPaths IRIX = False + supportRPaths HaLVM = False + supportRPaths IOS = False + supportRPaths Android = False + supportRPaths Ghcjs = False + supportRPaths Wasi = False + supportRPaths Hurd = True + supportRPaths Haiku = False + supportRPaths (OtherOS _) = False +-- Do _not_ add a default case so that we get a warning here when a new OS +-- is added. + +getRPaths _ _ = return mempty + +-- | Remove the "-threaded" flag when building a foreign library, as it has no +-- effect when used with "-shared". Returns the updated 'BuildInfo', along +-- with whether or not the flag was present, so we can use it to link against +-- the appropriate RTS on our own. +popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) +popThreadedFlag bi = + ( bi{options = filterHcOptions (/= "-threaded") (options bi)} + , hasThreaded (options bi) + ) + where + filterHcOptions + :: (String -> Bool) + -> PerCompilerFlavor [String] + -> PerCompilerFlavor [String] + 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 + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO String +libAbiHash verbosity _pkg_descr lbi lib clbi = do + let + libBi = libBuildInfo lib + comp = compiler lbi + platform = hostPlatform lbi + vanillaArgs = + (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + `mappend` mempty + { ghcOptMode = toFlag GhcModeAbiHash + , ghcOptInputModules = toNubListR $ exposedModules lib + } + sharedArgs = + vanillaArgs + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "js_dyn_hi" + , ghcOptObjSuffix = toFlag "js_dyn_o" + , ghcOptExtra = hcSharedOptions GHC libBi + } + profArgs = + vanillaArgs + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + True + (withProfLibDetail lbi) + , ghcOptHiSuffix = toFlag "js_p_hi" + , ghcOptObjSuffix = toFlag "js_p_o" + , ghcOptExtra = hcProfOptions GHC libBi + } + ghcArgs + | withVanillaLib lbi = vanillaArgs + | withSharedLib lbi = sharedArgs + | withProfLib lbi = profArgs + | otherwise = error "libAbiHash: Can't find an enabled library way" + + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) + hash <- + getProgramInvocationOutput + verbosity + =<< ghcInvocation verbosity ghcjsProg comp platform ghcArgs + return (takeWhile (not . isSpace) hash) + +componentGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> GhcOptions +componentGhcOptions verbosity lbi bi clbi odir = + let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir + in opts + { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi + } + +-- ----------------------------------------------------------------------------- +-- Installing + +-- | Install executables for GHCJS. +installExe + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ Where to copy the files to + -> FilePath + -- ^ Build location + -> (FilePath, FilePath) + -- ^ Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe + verbosity + lbi + binDir + buildPref + (progprefix, progsuffix) + _pkg + exe = do + createDirectoryIfMissingVerbose verbosity True binDir + let exeName' = unUnqualComponentName $ exeName exe + exeFileName = exeName' + fixedExeBaseName = progprefix ++ exeName' ++ progsuffix + installBinary dest = do + runDbProgram verbosity ghcjsProgram (withPrograms lbi) $ + [ "--install-executable" + , buildPref exeName' exeFileName + , "-o" + , dest + ] + ++ case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of + (True, Just strip) -> ["-strip-program", programPath strip] + _ -> [] + installBinary (binDir fixedExeBaseName) + +-- | Install foreign library for GHC. +installFLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ install location + -> FilePath + -- ^ Build location + -> PackageDescription + -> ForeignLib + -> IO () +installFLib verbosity lbi targetDir builtDir _pkg flib = + install + (foreignLibIsShared flib) + builtDir + targetDir + (flibTargetName lbi flib) + where + install _isShared srcDir dstDir name = do + let src = srcDir name + dst = dstDir name + createDirectoryIfMissingVerbose verbosity True targetDir + installOrdinaryFile verbosity src dst + +-- | Install for ghc, .hi, .a and, if --with-ghci given, .o +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 + whenVanilla $ copyModuleFiles $ Suffix "js_hi" + whenProf $ copyModuleFiles $ Suffix "js_p_hi" + whenShared $ copyModuleFiles $ Suffix "js_dyn_hi" + + -- whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName + -- whenProf $ installOrdinary builtDir targetDir $ toJSLibName profileLibName + -- whenShared $ installShared builtDir dynlibTargetDir $ toJSLibName sharedLibName + -- fixme do these make the correct lib names? + whenHasCode $ do + whenVanilla $ do + sequence_ + [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f)) + | l <- getHSLibraryName (componentUnitId clbi) : (extraBundledLibs (libBuildInfo lib)) + , f <- "" : extraLibFlavours (libBuildInfo lib) + ] + -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName) + whenProf $ do + installOrdinary builtDir' targetDir (toJSLibName profileLibName) + -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName) + whenShared $ + sequence_ + [ installShared + builtDir' + dynlibTargetDir + (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f)) + | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) + , f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] + where + builtDir' = componentBuildDir lbi clbi + + install isShared isJS srcDir dstDir name = do + let src = srcDir name + dst = dstDir name + createDirectoryIfMissingVerbose verbosity True dstDir + + if isShared + then installExecutableFile verbosity src dst + else installOrdinaryFile verbosity src dst + + when (stripLibs lbi && not isJS) $ + Strip.stripLib + verbosity + (hostPlatform lbi) + (withPrograms lbi) + dst + + installOrdinary = install False True + installShared = install True True + + copyModuleFiles ext = + findModuleFilesEx verbosity [builtDir'] [ext] (allLibModules lib clbi) + >>= installOrdinaryFiles verbosity targetDir + + compiler_id = compilerId (compiler lbi) + platform = hostPlatform lbi + uid = componentUnitId clbi + -- vanillaLibName = mkLibName uid + profileLibName = mkProfLibName uid + -- sharedLibName = (mkSharedLibName (hostPlatform lbi) compiler_id) uid + + hasLib = + not $ + null (allLibModules lib clbi) + && null (cSources (libBuildInfo lib)) + && null (cxxSources (libBuildInfo lib)) + && null (jsSources (libBuildInfo lib)) + has_code = not (componentIsIndefinite clbi) + whenHasCode = when has_code + whenVanilla = when (hasLib && withVanillaLib lbi) + whenProf = when (hasLib && withProfLib lbi && has_code) + -- whenGHCi = when (hasLib && withGHCiLib lbi && has_code) + whenShared = when (hasLib && withSharedLib lbi && has_code) + +adjustExts :: String -> String -> GhcOptions -> GhcOptions +adjustExts hiSuf objSuf opts = + opts + `mappend` mempty + { ghcOptHiSuffix = toFlag hiSuf + , ghcOptObjSuffix = toFlag objSuf + } + +isDynamic :: Compiler -> Bool +isDynamic = Internal.ghcLookupProperty "GHC Dynamic" + +supportsDynamicToo :: Compiler -> Bool +supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" + +withExt :: FilePath -> String -> FilePath +withExt fp ext = fp <.> if takeExtension fp /= ('.' : ext) then ext else "" + +findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version) +findGhcjsGhcVersion verbosity pgm = + findProgramVersion "--numeric-ghc-version" id verbosity pgm + +findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version) +findGhcjsPkgGhcjsVersion verbosity pgm = + findProgramVersion "--numeric-ghcjs-version" id verbosity pgm + +-- ----------------------------------------------------------------------------- +-- Registering + +hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo +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 + +registerPackage + :: Verbosity + -> ProgramDb + -> PackageDBStack + -> InstalledPackageInfo + -> HcPkg.RegisterOptions + -> IO () +registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = + HcPkg.register + (hcPkgInfo progdb) + verbosity + packageDbs + installedPkgInfo + registerOptions + +pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath +pkgRoot verbosity lbi = pkgRoot' + where + pkgRoot' GlobalPackageDB = + let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi) + in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg) + pkgRoot' UserPackageDB = do + appDir <- getAppUserDataDirectory "ghcjs" + -- fixme correct this version + let ver = compilerVersion (compiler lbi) + subdir = + System.Info.arch + ++ '-' + : System.Info.os + ++ '-' + : prettyShow ver + rootDir = appDir subdir + -- We must create the root directory for the user package database if it + -- does not yet exists. Otherwise '${pkgroot}' will resolve to a + -- directory at the time of 'ghc-pkg register', and registration will + -- fail. + createDirectoryIfMissing True rootDir + return rootDir + pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp) + +-- | Get the JavaScript file name and command and arguments to run a +-- program compiled by GHCJS +-- the exe should be the base program name without exe extension +runCmd + :: ProgramDb + -> FilePath + -> (FilePath, FilePath, [String]) runCmd progdb exe = ( script , programPath ghcjsProg 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,8 +1,9 @@ {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Glob -- Copyright : Isaac Jones, Simon Marlow 2003-2004 @@ -13,206 +14,53 @@ -- Portability : portable -- -- Simple file globbing. +module Distribution.Simple.Glob + ( -- * Globs + Glob -module Distribution.Simple.Glob ( - GlobSyntaxError(..), - GlobResult(..), - matchDirFileGlob, - matchDirFileGlobWithDie, - runDirFileGlob, - fileGlobMatches, - parseFileGlob, - explainGlobSyntaxError, - isRecursiveInRoot, - Glob, - ) where + -- * Matching on globs + , GlobResult (..) + , globMatches + , fileGlobMatches + , matchDirFileGlob + , matchDirFileGlobWithDie + , runDirFileGlob -import Prelude () -import Distribution.Compat.Prelude + -- * Parsing globs + , parseFileGlob + , GlobSyntaxError (..) + , explainGlobSyntaxError -import Distribution.CabalSpecVersion -import Distribution.Simple.Utils -import Distribution.Verbosity + -- * Utility + , isRecursiveInRoot + ) +where -import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) -import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (), (<.>)) +import Distribution.Compat.Prelude +import Prelude () -import qualified Data.List.NonEmpty as NE +import Distribution.CabalSpecVersion (CabalSpecVersion) +import Distribution.Simple.Errors + ( CabalException (MatchDirFileGlob, MatchDirFileGlobErrors) + ) +import Distribution.Simple.Glob.Internal +import Distribution.Simple.Utils (dieWithException, warn) +import Distribution.Verbosity (Verbosity) --- Note throughout that we use splitDirectories, not splitPath. On --- Posix, this makes no difference, but, because Windows accepts both --- slash and backslash as its path separators, if we left in the --- separators from the glob we might not end up properly normalised. +------------------------------------------------------------------------------- -data GlobResult a - = GlobMatch a - -- ^ The glob matched the value supplied. - | GlobWarnMultiDot a - -- ^ The glob did not match the value supplied because the - -- cabal-version is too low and the extensions on the file did - -- not precisely match the glob's extensions, but rather the - -- glob was a proper suffix of the file's extensions; i.e., if - -- not for the low cabal-version, it would have matched. - | GlobMissingDirectory FilePath - -- ^ The glob couldn't match because the directory named doesn't - -- exist. The directory will be as it appears in the glob (i.e., - -- relative to the directory passed to 'matchDirFileGlob', and, - -- for 'data-files', relative to 'data-dir'). - deriving (Show, Eq, Ord, Functor) +-- * Matching +-------------------------------------------------------------------------------- + -- | Extract the matches from a list of 'GlobResult's. -- -- Note: throws away the 'GlobMissingDirectory' results; chances are -- that you want to check for these and error out if any are present. +-- +-- @since 3.12.0.0 globMatches :: [GlobResult a] -> [a] -globMatches input = [ a | GlobMatch a <- input ] - -data GlobSyntaxError - = StarInDirectory - | StarInFileName - | StarInExtension - | NoExtensionOnStar - | EmptyGlob - | LiteralFileNameGlobStar - | VersionDoesNotSupportGlobStar - | VersionDoesNotSupportGlob - deriving (Eq, Show) - -explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String -explainGlobSyntaxError filepath StarInDirectory = - "invalid file glob '" ++ filepath - ++ "'. A wildcard '**' is only allowed as the final parent" - ++ " directory. Stars must not otherwise appear in the parent" - ++ " directories." -explainGlobSyntaxError filepath StarInExtension = - "invalid file glob '" ++ filepath - ++ "'. Wildcards '*' are only allowed as the" - ++ " file's base name, not in the file extension." -explainGlobSyntaxError filepath StarInFileName = - "invalid file glob '" ++ filepath - ++ "'. Wildcards '*' may only totally replace the" - ++ " file's base name, not only parts of it." -explainGlobSyntaxError filepath NoExtensionOnStar = - "invalid file glob '" ++ filepath - ++ "'. If a wildcard '*' is used it must be with an file extension." -explainGlobSyntaxError filepath LiteralFileNameGlobStar = - "invalid file glob '" ++ filepath - ++ "'. Prior to 'cabal-version: 3.8'" - ++ " if a wildcard '**' is used as a parent directory, the" - ++ " file's base name must be a wildcard '*'." -explainGlobSyntaxError _ EmptyGlob = - "invalid file glob. A glob cannot be the empty string." -explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar = - "invalid file glob '" ++ filepath - ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'" - ++ " or greater. Alternatively, for compatibility with earlier Cabal" - ++ " versions, list the included directories explicitly." -explainGlobSyntaxError filepath VersionDoesNotSupportGlob = - "invalid file glob '" ++ filepath - ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. " - ++ "Alternatively if you require compatibility with earlier Cabal " - ++ "versions then list all the files explicitly." - -data IsRecursive = Recursive | NonRecursive deriving Eq - -data MultiDot = MultiDotDisabled | MultiDotEnabled - -data Glob - = GlobStem FilePath Glob - -- ^ A single subdirectory component + remainder. - | GlobFinal GlobFinal - -data GlobFinal - = FinalMatch IsRecursive MultiDot String - -- ^ First argument: Is this a @**/*.ext@ pattern? - -- Second argument: should we match against the exact extensions, or accept a suffix? - -- Third argument: the extensions to accept. - | FinalLit IsRecursive FilePath - -- ^ Literal file name. - -reconstructGlob :: Glob -> FilePath -reconstructGlob (GlobStem dir glob) = - dir reconstructGlob glob -reconstructGlob (GlobFinal final) = case final of - FinalMatch Recursive _ exts -> "**" "*" <.> exts - FinalMatch NonRecursive _ exts -> "*" <.> exts - FinalLit Recursive path -> "**" path - FinalLit NonRecursive path -> path - --- | Returns 'Nothing' if the glob didn't match at all, or 'Just' the --- result if the glob matched (or would have matched with a higher --- cabal-version). -fileGlobMatches :: Glob -> FilePath -> Maybe (GlobResult FilePath) -fileGlobMatches pat candidate = do - match <- fileGlobMatchesSegments pat (splitDirectories candidate) - return (candidate <$ match) - -fileGlobMatchesSegments :: Glob -> [FilePath] -> Maybe (GlobResult ()) -fileGlobMatchesSegments _ [] = Nothing -fileGlobMatchesSegments pat (seg : segs) = case pat of - GlobStem dir pat' -> do - guard (dir == seg) - fileGlobMatchesSegments pat' segs - GlobFinal final -> case final of - FinalMatch Recursive multidot ext -> do - let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg:|segs) - guard (not (null candidateBase)) - checkExt multidot ext candidateExts - FinalMatch NonRecursive multidot ext -> do - let (candidateBase, candidateExts) = splitExtensions seg - guard (null segs && not (null candidateBase)) - checkExt multidot ext candidateExts - FinalLit isRecursive filename -> do - guard ((isRecursive == Recursive || null segs) && filename == seg) - return (GlobMatch ()) - -checkExt - :: MultiDot - -> String -- ^ The pattern's extension - -> String -- ^ The candidate file's extension - -> Maybe (GlobResult ()) -checkExt multidot ext candidate - | ext == candidate = Just (GlobMatch ()) - | ext `isSuffixOf` candidate = case multidot of - MultiDotDisabled -> Just (GlobWarnMultiDot ()) - MultiDotEnabled -> Just (GlobMatch ()) - | otherwise = Nothing - -parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob -parseFileGlob version filepath = case reverse (splitDirectories filepath) of - [] -> - Left EmptyGlob - (filename : "**" : segments) - | allowGlobStar -> do - finalSegment <- case splitExtensions filename of - ("*", ext) | '*' `elem` ext -> Left StarInExtension - | null ext -> Left NoExtensionOnStar - | otherwise -> Right (FinalMatch Recursive multidot ext) - _ -> if allowLiteralFilenameGlobStar - then Right (FinalLit Recursive filename) - else Left LiteralFileNameGlobStar - foldM addStem (GlobFinal finalSegment) segments - | otherwise -> Left VersionDoesNotSupportGlobStar - (filename : segments) -> do - pat <- case splitExtensions filename of - ("*", ext) | not allowGlob -> Left VersionDoesNotSupportGlob - | '*' `elem` ext -> Left StarInExtension - | null ext -> Left NoExtensionOnStar - | otherwise -> Right (FinalMatch NonRecursive multidot ext) - (_, ext) | '*' `elem` ext -> Left StarInExtension - | '*' `elem` filename -> Left StarInFileName - | otherwise -> Right (FinalLit NonRecursive filename) - foldM addStem (GlobFinal pat) segments - where - allowGlob = version >= CabalSpecV1_6 - allowGlobStar = version >= CabalSpecV2_4 - addStem pat seg - | '*' `elem` seg = Left StarInDirectory - | otherwise = Right (GlobStem seg pat) - multidot - | version >= CabalSpecV2_4 = MultiDotEnabled - | otherwise = MultiDotDisabled - allowLiteralFilenameGlobStar = version >= CabalSpecV3_8 +globMatches input = [a | GlobMatch a <- input] -- | This will 'die'' when the glob matches no files, or if the glob -- refers to a missing directory, or if the glob fails to parse. @@ -227,118 +75,53 @@ -- prefix. -- -- The second 'FilePath' is the glob itself. --- matchDirFileGlob :: Verbosity -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath] -matchDirFileGlob v = matchDirFileGlobWithDie v die' +matchDirFileGlob v = matchDirFileGlobWithDie v dieWithException -- | Like 'matchDirFileGlob' but with customizable 'die' -- -- @since 3.6.0.0 --- -matchDirFileGlobWithDie :: Verbosity -> (Verbosity -> String -> IO [FilePath]) -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath] +matchDirFileGlobWithDie + :: Verbosity + -> (Verbosity -> CabalException -> IO [FilePath]) + -> CabalSpecVersion + -> FilePath + -> FilePath + -> IO [FilePath] matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob version filepath of - Left err -> rip verbosity $ explainGlobSyntaxError filepath err + Left err -> rip verbosity $ MatchDirFileGlob (explainGlobSyntaxError filepath err) Right glob -> do - results <- runDirFileGlob verbosity dir glob + results <- runDirFileGlob verbosity (Just version) dir glob let missingDirectories = - [ missingDir | GlobMissingDirectory missingDir <- results ] + [missingDir | GlobMissingDirectory missingDir <- results] matches = globMatches results + directoryMatches = [a | GlobMatchesDirectory a <- results] let errors :: [String] errors = - [ "filepath wildcard '" ++ filepath ++ "' refers to the directory" - ++ " '" ++ missingDir ++ "', which does not exist or is not a directory." - | missingDir <- missingDirectories - ] - ++ - [ "filepath wildcard '" ++ filepath ++ "' does not match any files." - | null matches - ] - - if null errors - then return matches - else rip verbosity $ unlines errors - --- | Match files against a pre-parsed glob, starting in a directory. --- --- The 'Version' argument must be the spec version of the package --- description being processed, as globs behave slightly differently --- in different spec versions. --- --- The 'FilePath' argument is the directory that the glob is relative --- to. It must be a valid directory (and hence it can't be the empty --- string). The returned values will not include this prefix. -runDirFileGlob :: Verbosity -> FilePath -> Glob -> IO [GlobResult FilePath] -runDirFileGlob verbosity rawDir pat = do - -- The default data-dir is null. Our callers -should- be - -- converting that to '.' themselves, but it's a certainty that - -- some future call-site will forget and trigger a really - -- hard-to-debug failure if we don't check for that here. - when (null rawDir) $ - warn verbosity $ - "Null dir passed to runDirFileGlob; interpreting it " - ++ "as '.'. This is probably an internal error." - let dir = if null rawDir then "." else rawDir - debug verbosity $ "Expanding glob '" ++ reconstructGlob pat ++ "' in directory '" ++ dir ++ "'." - -- 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 - -- extract the constant prefix from the pattern and start walking - -- there, and only walk as much as we need to: recursively if **, - -- the whole directory if *, and just the specific file if it's a - -- literal. - let (prefixSegments, final) = splitConstantPrefix pat - joinedPrefix = joinPath prefixSegments - case final of - FinalMatch recursive multidot exts -> do - let prefix = dir joinedPrefix - directoryExists <- doesDirectoryExist prefix - if directoryExists - then do - candidates <- case recursive of - Recursive -> getDirectoryContentsRecursive prefix - NonRecursive -> filterM (doesFileExist . (prefix )) =<< getDirectoryContents prefix - let checkName candidate = do - let (candidateBase, candidateExts) = splitExtensions $ takeFileName candidate - guard (not (null candidateBase)) - match <- checkExt multidot exts candidateExts - return (joinedPrefix candidate <$ match) - return $ mapMaybe checkName candidates - else - return [ GlobMissingDirectory joinedPrefix ] - FinalLit Recursive fn -> do - let prefix = dir joinedPrefix - directoryExists <- doesDirectoryExist prefix - if directoryExists - then do - candidates <- getDirectoryContentsRecursive prefix - let checkName candidate - | takeFileName candidate == fn = Just $ GlobMatch (joinedPrefix candidate) - | otherwise = Nothing - return $ mapMaybe checkName candidates - else - return [ GlobMissingDirectory joinedPrefix ] - - FinalLit NonRecursive fn -> do - exists <- doesFileExist (dir joinedPrefix fn) - return [ GlobMatch (joinedPrefix fn) | exists ] - -unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r) -unfoldr' f a = case f a of - Left r -> ([], r) - Right (b, a') -> case unfoldr' f a' of - (bs, r) -> (b : bs, r) - --- | Extract the (possibly null) constant prefix from the pattern. --- This has the property that, if @(pref, final) = splitConstantPrefix pat@, --- then @pat === foldr GlobStem (GlobFinal final) pref@. -splitConstantPrefix :: Glob -> ([FilePath], GlobFinal) -splitConstantPrefix = unfoldr' step - where - step (GlobStem seg pat) = Right (seg, pat) - step (GlobFinal pat) = Left pat + [ "filepath wildcard '" + ++ filepath + ++ "' refers to the directory" + ++ " '" + ++ missingDir + ++ "', which does not exist or is not a directory." + | missingDir <- missingDirectories + ] + ++ [ "filepath wildcard '" ++ filepath ++ "' does not match any files." + | null matches && null directoryMatches + -- we don't error out on directory matches, simply warn about them and ignore. + ] + warns :: [String] + warns = + [ "Ignoring directory '" ++ path ++ "'" ++ " listed in a Cabal package field which should only include files (not directories)." + | path <- directoryMatches + ] -isRecursiveInRoot :: Glob -> Bool -isRecursiveInRoot (GlobFinal (FinalMatch Recursive _ _)) = True -isRecursiveInRoot _ = False + if null errors + then do + unless (null warns) $ + warn verbosity $ + unlines warns + return matches + else rip verbosity $ MatchDirFileGlobErrors errors diff --git a/src/Distribution/Simple/Glob/Internal.hs b/src/Distribution/Simple/Glob/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Glob/Internal.hs @@ -0,0 +1,497 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Glob.Internal +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- License : BSD3 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Internal module for simple file globbing. +-- Please import "Distribution.Simple.Glob" instead. +module Distribution.Simple.Glob.Internal where + +import Distribution.Compat.Prelude +import Prelude () + +import Control.Monad (mapM) + +import Distribution.Parsec +import Distribution.Pretty + +import Distribution.CabalSpecVersion +import Distribution.Simple.Utils +import Distribution.Verbosity hiding (normal) + +import Data.List (stripPrefix) +import System.Directory +import System.FilePath + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-------------------------------------------------------------------------------- + +-- | A filepath specified by globbing. +data Glob + = -- | @/@ + GlobDir !GlobPieces !Glob + | -- | @**/@, where @**@ denotes recursively traversing + -- all directories and matching filenames on . + GlobDirRecursive !GlobPieces + | -- | A file glob. + GlobFile !GlobPieces + | -- | Trailing dir; a glob ending in @/@. + GlobDirTrailing + deriving (Eq, Show, Generic) + +instance Binary Glob +instance Structured Glob + +-- | A single directory or file component of a globbed path +type GlobPieces = [GlobPiece] + +-- | A piece of a globbing pattern +data GlobPiece + = -- | A wildcard @*@ + WildCard + | -- | A literal string @dirABC@ + Literal String + | -- | A union of patterns, e.g. @dir/{a,*.txt,c}/...@ + Union [GlobPieces] + deriving (Eq, Show, Generic) + +instance Binary GlobPiece +instance Structured GlobPiece + +------------------------------------------------------------------------------- + +-- * Matching + +-------------------------------------------------------------------------------- + +-- | Match a 'Glob' against the file system, starting from a +-- given root directory. The results are all relative to the given root. +-- +-- @since 3.12.0.0 +matchGlob :: FilePath -> Glob -> IO [FilePath] +matchGlob root glob = + -- For this function, which is the general globbing one (doesn't care about + -- cabal spec, used e.g. for monitoring), we consider all matches. + mapMaybe + ( \case + GlobMatch a -> Just a + GlobWarnMultiDot a -> Just a + GlobMatchesDirectory a -> Just a + GlobMissingDirectory{} -> Nothing + ) + <$> runDirFileGlob silent Nothing root glob + +-- | Match a globbing pattern against a file path component +matchGlobPieces :: GlobPieces -> String -> Bool +matchGlobPieces = goStart + where + -- From the man page, glob(7): + -- "If a filename starts with a '.', this character must be + -- matched explicitly." + + go, goStart :: [GlobPiece] -> String -> Bool + + goStart (WildCard : _) ('.' : _) = False + goStart (Union globs : rest) cs = + any + (\glob -> goStart (glob ++ rest) cs) + globs + goStart rest cs = go rest cs + + go [] "" = True + go (Literal lit : rest) cs + | Just cs' <- stripPrefix lit cs = + go rest cs' + | otherwise = False + go [WildCard] "" = True + go (WildCard : rest) (c : cs) = go rest (c : cs) || go (WildCard : rest) cs + go (Union globs : rest) cs = any (\glob -> go (glob ++ rest) cs) globs + go [] (_ : _) = False + go (_ : _) "" = False + +------------------------------------------------------------------------------- + +-- * Parsing & printing + +-------------------------------------------------------------------------------- +-- Filepaths with globs may be parsed in the special context is globbing in +-- cabal package fields, such as `data-files`. In that case, we restrict the +-- globbing syntax to that supported by the cabal spec version in use. +-- Otherwise, we parse the globs to the extent of our globbing features +-- (wildcards `*`, unions `{a,b,c}`, and directory-recursive wildcards `**`). + +-- ** Parsing globs in a cabal package + +parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob +parseFileGlob version filepath = case reverse (splitDirectories filepath) of + [] -> + Left EmptyGlob + (filename : "**" : segments) + | allowGlobStar -> do + finalSegment <- case splitExtensions filename of + ("*", ext) + | '*' `elem` ext -> Left StarInExtension + | null ext -> Left NoExtensionOnStar + | otherwise -> Right (GlobDirRecursive [WildCard, Literal ext]) + _ + | allowLiteralFilenameGlobStar -> + Right (GlobDirRecursive [Literal filename]) + | otherwise -> + Left LiteralFileNameGlobStar + + foldM addStem finalSegment segments + | otherwise -> Left VersionDoesNotSupportGlobStar + (filename : segments) -> do + pat <- case splitExtensions filename of + ("*", ext) + | not allowGlob -> Left VersionDoesNotSupportGlob + | '*' `elem` ext -> Left StarInExtension + | null ext -> Left NoExtensionOnStar + | otherwise -> Right (GlobFile [WildCard, Literal ext]) + (_, ext) + | '*' `elem` ext -> Left StarInExtension + | '*' `elem` filename -> Left StarInFileName + | otherwise -> Right (GlobFile [Literal filename]) + + foldM addStem pat segments + where + addStem pat seg + | '*' `elem` seg = Left StarInDirectory + | otherwise = Right (GlobDir [Literal seg] pat) + allowGlob = version >= CabalSpecV1_6 + allowGlobStar = version >= CabalSpecV2_4 + allowLiteralFilenameGlobStar = version >= CabalSpecV3_8 + +enableMultidot :: CabalSpecVersion -> Bool +enableMultidot version + | version >= CabalSpecV2_4 = True + | otherwise = False + +-- ** Parsing globs otherwise + +instance Pretty Glob where + pretty (GlobDir glob pathglob) = + dispGlobPieces glob + Disp.<> Disp.char '/' + Disp.<> pretty pathglob + pretty (GlobDirRecursive glob) = + Disp.text "**/" + Disp.<> dispGlobPieces glob + pretty (GlobFile glob) = dispGlobPieces glob + pretty GlobDirTrailing = Disp.empty + +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 '/' + <|> P.try + ( do + _ <- P.char '\\' + -- check this isn't an escape code + P.notFollowedBy (P.satisfy isGlobEscapedChar) + ) + + parsecGlob :: CabalParsing m => m GlobPieces + parsecGlob = some parsecPiece + where + parsecPiece = P.choice [literal, wildcard, union] + + wildcard = WildCard <$ P.char '*' + union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ',')) + literal = Literal <$> some litchar + + litchar = normal <|> escape + + normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\') + escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar + +-------------------------------------------------------------------------------- +-- Parse and printing utils +-------------------------------------------------------------------------------- + +dispGlobPieces :: GlobPieces -> Disp.Doc +dispGlobPieces = Disp.hcat . map dispPiece + where + dispPiece WildCard = Disp.char '*' + dispPiece (Literal str) = Disp.text (escape str) + dispPiece (Union globs) = + Disp.braces + ( Disp.hcat + ( Disp.punctuate + (Disp.char ',') + (map dispGlobPieces globs) + ) + ) + escape [] = [] + escape (c : cs) + | isGlobEscapedChar c = '\\' : c : escape cs + | otherwise = c : escape cs + +isGlobEscapedChar :: Char -> Bool +isGlobEscapedChar '*' = True +isGlobEscapedChar '{' = True +isGlobEscapedChar '}' = True +isGlobEscapedChar ',' = True +isGlobEscapedChar _ = False + +-- ** Cabal package globbing errors + +data GlobSyntaxError + = StarInDirectory + | StarInFileName + | StarInExtension + | NoExtensionOnStar + | EmptyGlob + | LiteralFileNameGlobStar + | VersionDoesNotSupportGlobStar + | VersionDoesNotSupportGlob + deriving (Eq, Show) + +explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String +explainGlobSyntaxError filepath StarInDirectory = + "invalid file glob '" + ++ filepath + ++ "'. A wildcard '**' is only allowed as the final parent" + ++ " directory. Stars must not otherwise appear in the parent" + ++ " directories." +explainGlobSyntaxError filepath StarInExtension = + "invalid file glob '" + ++ filepath + ++ "'. Wildcards '*' are only allowed as the" + ++ " file's base name, not in the file extension." +explainGlobSyntaxError filepath StarInFileName = + "invalid file glob '" + ++ filepath + ++ "'. Wildcards '*' may only totally replace the" + ++ " file's base name, not only parts of it." +explainGlobSyntaxError filepath NoExtensionOnStar = + "invalid file glob '" + ++ filepath + ++ "'. If a wildcard '*' is used it must be with an file extension." +explainGlobSyntaxError filepath LiteralFileNameGlobStar = + "invalid file glob '" + ++ filepath + ++ "'. Prior to 'cabal-version: 3.8'" + ++ " if a wildcard '**' is used as a parent directory, the" + ++ " file's base name must be a wildcard '*'." +explainGlobSyntaxError _ EmptyGlob = + "invalid file glob. A glob cannot be the empty string." +explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar = + "invalid file glob '" + ++ filepath + ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'" + ++ " or greater. Alternatively, for compatibility with earlier Cabal" + ++ " versions, list the included directories explicitly." +explainGlobSyntaxError filepath VersionDoesNotSupportGlob = + "invalid file glob '" + ++ filepath + ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. " + ++ "Alternatively if you require compatibility with earlier Cabal " + ++ "versions then list all the files explicitly." + +-- Note throughout that we use splitDirectories, not splitPath. On +-- Posix, this makes no difference, but, because Windows accepts both +-- slash and backslash as its path separators, if we left in the +-- separators from the glob we might not end up properly normalised. + +data GlobResult a + = -- | The glob matched the value supplied. + GlobMatch a + | -- | The glob did not match the value supplied because the + -- cabal-version is too low and the extensions on the file did + -- not precisely match the glob's extensions, but rather the + -- glob was a proper suffix of the file's extensions; i.e., if + -- not for the low cabal-version, it would have matched. + GlobWarnMultiDot a + | -- | The glob couldn't match because the directory named doesn't + -- exist. The directory will be as it appears in the glob (i.e., + -- relative to the directory passed to 'matchDirFileGlob', and, + -- for 'data-files', relative to 'data-dir'). + GlobMissingDirectory a + | -- | The glob matched a directory when we were looking for files only. + -- It didn't match a file! + -- + -- @since 3.12.0.0 + GlobMatchesDirectory a + deriving (Show, Eq, Ord, Functor) + +-- | Match files against a pre-parsed glob, starting in a directory. +-- +-- The 'Version' argument must be the spec version of the package +-- description being processed, as globs behave slightly differently +-- in different spec versions. +-- +-- The 'FilePath' argument is the directory that the glob is relative +-- to. It must be a valid directory (and hence it can't be the empty +-- string). The returned values will not include this prefix. +runDirFileGlob + :: Verbosity + -> Maybe CabalSpecVersion + -- ^ If the glob we are running should care about the cabal spec, and warnings such as 'GlobWarnMultiDot', then this should be the version. + -- If you want to run a glob but don't care about any of the cabal-spec restrictions on globs, use 'Nothing'! + -> FilePath + -> Glob + -> IO [GlobResult FilePath] +runDirFileGlob verbosity mspec rawRoot pat = do + -- The default data-dir is null. Our callers -should- be + -- converting that to '.' themselves, but it's a certainty that + -- some future call-site will forget and trigger a really + -- hard-to-debug failure if we don't check for that here. + when (null rawRoot) $ + warn verbosity $ + "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 + -- extract the constant prefix from the pattern and start walking + -- there, and only walk as much as we need to: recursively if **, + -- the whole directory if *, and just the specific file if it's a + -- literal. + let + (prefixSegments, variablePattern) = splitConstantPrefix pat + joinedPrefix = joinPath prefixSegments + + -- The glob matching function depends on whether we care about the cabal version or not + doesGlobMatch :: GlobPieces -> String -> Maybe (GlobResult ()) + doesGlobMatch glob str = case mspec of + Just spec -> checkNameMatches spec glob str + Nothing -> if matchGlobPieces glob str then Just (GlobMatch ()) else Nothing + + go (GlobFile glob) dir = do + entries <- getDirectoryContents (root dir) + catMaybes + <$> mapM + ( \s -> do + -- When running a glob from a Cabal package description (i.e. + -- when a cabal spec version is passed as an argument), we + -- disallow matching a @GlobFile@ against a directory, preferring + -- @GlobDir dir GlobDirTrailing@ to specify a directory match. + isFile <- maybe (return True) (const $ doesFileExist (root dir s)) mspec + let match = (dir s <$) <$> doesGlobMatch glob s + return $ + if isFile + then match + else case match of + Just (GlobMatch x) -> Just $ GlobMatchesDirectory x + Just (GlobWarnMultiDot x) -> Just $ GlobMatchesDirectory x + Just (GlobMatchesDirectory x) -> Just $ GlobMatchesDirectory x + Just (GlobMissingDirectory x) -> Just $ GlobMissingDirectory x -- this should never match, unless you are in a file-delete-heavy concurrent setting i guess + Nothing -> Nothing + ) + entries + go (GlobDirRecursive glob) dir = do + entries <- getDirectoryContentsRecursive (root dir) + return $ + mapMaybe + ( \s -> do + globMatch <- doesGlobMatch glob (takeFileName s) + pure ((dir s) <$ globMatch) + ) + entries + go (GlobDir glob globPath) dir = do + entries <- getDirectoryContents (root dir) + subdirs <- + filterM + ( \subdir -> + doesDirectoryExist + (root dir subdir) + ) + $ filter (matchGlobPieces glob) entries + 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] + 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 + where + step (GlobDir [Literal seg] pat') = Right (seg, pat') + step pat' = Left pat' + + unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r) + unfoldr' f a = case f a of + Left r -> ([], r) + Right (b, a') -> case unfoldr' f a' of + (bs, r) -> (b : bs, r) + +-- | Is the root of this relative glob path a directory-recursive wildcard, e.g. @**/*.txt@ ? +isRecursiveInRoot :: Glob -> Bool +isRecursiveInRoot (GlobDirRecursive _) = True +isRecursiveInRoot _ = False + +-- | Check how the string matches the glob under this cabal version +checkNameMatches :: CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ()) +checkNameMatches spec glob candidate + -- Check if glob matches in its general form + | matchGlobPieces glob candidate = + -- if multidot is supported, then this is a clean match + if enableMultidot spec + then pure (GlobMatch ()) + else -- if not, issue a warning saying multidot is needed for the match + + let (_, candidateExts) = splitExtensions $ takeFileName candidate + extractExts :: GlobPieces -> Maybe String + extractExts [] = Nothing + extractExts [Literal lit] + -- Any literal terminating a glob, and which does have an extension, + -- returns that extension. Otherwise, recurse until Nothing is returned. + | let ext = takeExtensions lit + , ext /= "" = + Just ext + extractExts (_ : x) = extractExts x + in case extractExts glob of + Just exts + | exts == candidateExts -> + return (GlobMatch ()) + | exts `isSuffixOf` candidateExts -> + return (GlobWarnMultiDot ()) + _ -> return (GlobMatch ()) + | otherwise = empty + +-- | How/does the glob match the given filepath, according to the cabal version? +-- Since this is pure, we don't make a distinction between matching on +-- directories or files (i.e. this function won't return 'GlobMatchesDirectory') +fileGlobMatches :: CabalSpecVersion -> Glob -> FilePath -> Maybe (GlobResult ()) +fileGlobMatches version g path = go g (splitDirectories path) + where + go GlobDirTrailing [] = Just (GlobMatch ()) + go (GlobFile glob) [file] = checkNameMatches version glob file + go (GlobDirRecursive glob) dirs + | [] <- reverse dirs = + Nothing -- @dir/**/x.txt@ should not match @dir/hello@ + | file : _ <- reverse dirs = + checkNameMatches version glob file + go (GlobDir glob globPath) (dir : dirs) = do + _ <- checkNameMatches version glob dir -- we only care if dir segment matches + go globPath dirs + go _ _ = Nothing 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 @@ -4,1039 +4,1238 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- --- | --- Module : Distribution.Simple.Haddock --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module deals with the @haddock@ and @hscolour@ commands. --- It uses information about installed packages (from @ghc-pkg@) to find the --- locations of documentation for dependent packages, so it can create links. --- --- The @hscolour@ support allows generating HTML versions of the original --- source, with coloured syntax highlighting. - -module Distribution.Simple.Haddock ( - haddock, createHaddockIndex, hscolour, - - haddockPackagePaths, - Visibility(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS - --- local -import Distribution.Backpack.DescribeUnitId -import Distribution.Backpack (OpenModule) -import Distribution.Types.ForeignLib -import Distribution.Types.UnqualComponentName -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Types.ExecutableScope -import Distribution.Types.LocalBuildInfo -import Distribution.Types.TargetInfo -import Distribution.Types.ExposedModule -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName -import Distribution.PackageDescription -import Distribution.Simple.Compiler -import Distribution.Simple.Glob -import Distribution.Simple.Program.GHC -import Distribution.Simple.Program.ResponseFile -import Distribution.Simple.Program -import Distribution.Simple.PreProcess -import Distribution.Simple.Setup -import Distribution.Simple.Build -import Distribution.Simple.BuildTarget -import Distribution.Simple.InstallDirs -import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate) -import Distribution.Simple.BuildPaths -import Distribution.Simple.Register -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import qualified Distribution.Simple.PackageIndex as PackageIndex -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Pretty -import Distribution.Parsec (simpleParsec) -import Distribution.Utils.NubList -import Distribution.Version -import qualified Distribution.Utils.ShortText as ShortText - -import Distribution.Verbosity -import Language.Haskell.Extension - -import Distribution.Compat.Semigroup (All (..), Any (..)) - -import Control.Monad -import Data.Either ( rights ) - -import System.Directory (getCurrentDirectory, doesDirectoryExist, doesFileExist) -import System.FilePath ( (), (<.>), normalise, isAbsolute ) -import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) - --- ------------------------------------------------------------------------------ --- Types - --- | A record that represents the arguments to the haddock executable, a product --- monoid. -data HaddockArgs = HaddockArgs { - argInterfaceFile :: Flag FilePath, - -- ^ Path to the interface file, relative to argOutputDir, required. - argPackageName :: Flag PackageIdentifier, - -- ^ Package name, required. - argHideModules :: (All,[ModuleName.ModuleName]), - -- ^ (Hide modules ?, modules to hide) - argIgnoreExports :: Any, - -- ^ Ignore export lists in modules? - argLinkSource :: Flag (Template,Template,Template), - -- ^ (Template for modules, template for symbols, template for lines). - argLinkedSource :: Flag Bool, - -- ^ Generate hyperlinked sources - argQuickJump :: Flag Bool, - -- ^ Generate quickjump index - argCssFile :: Flag FilePath, - -- ^ Optional custom CSS file. - argContents :: Flag String, - -- ^ Optional URL to contents page. - argGenContents :: Flag Bool, - -- ^ Generate contents - argIndex :: Flag String, - -- ^ Optional URL to index page. - argGenIndex :: Flag Bool, - -- ^ Generate index - argBaseUrl :: Flag String, - -- ^ Optional base url from which static files will be loaded. - argVerbose :: Any, - argOutput :: Flag [Output], - -- ^ HTML or Hoogle doc or both? Required. - argInterfaces :: [(FilePath, Maybe String, Maybe String, Visibility)], - -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)]. - argOutputDir :: Directory, - -- ^ Where to generate the documentation. - argTitle :: Flag String, - -- ^ Page title, required. - argPrologue :: Flag String, - -- ^ Prologue text, required for 'haddock', ignored by 'haddocks'. - argPrologueFile :: Flag FilePath, - -- ^ Prologue file name, ignored by 'haddock', optional for 'haddocks'. - argGhcOptions :: GhcOptions, - -- ^ Additional flags to pass to GHC. - argGhcLibDir :: Flag FilePath, - -- ^ To find the correct GHC, required. - argReexports :: [OpenModule], - -- ^ Re-exported modules - argTargets :: [FilePath], - -- ^ Modules to process. - argLib :: Flag String - -- ^ haddock's static \/ auxiliary files. -} deriving Generic - --- | The FilePath of a directory, it's a monoid under '()'. -newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord) - -unDir :: Directory -> FilePath -unDir = normalise . unDir' - -type Template = String - -data Output = Html | Hoogle - deriving Eq - --- ------------------------------------------------------------------------------ --- Haddock support - --- | Get Haddock program and check if it matches the request -getHaddockProg :: Verbosity - -> ProgramDb - -> Compiler - -> HaddockArgs - -> Flag Bool -- ^ quickjump feature - -> IO (ConfiguredProgram, Version) -getHaddockProg verbosity programDb comp args quickJumpFlag = do - let HaddockArgs { argQuickJump - , argOutput - } = args - hoogle = Hoogle `elem` fromFlagOrDefault [] argOutput - - (haddockProg, version, _) <- - requireProgramVersion verbosity haddockProgram - (orLaterVersion (mkVersion [2,0])) programDb - - -- various sanity checks - when (hoogle && version < mkVersion [2,2]) $ - die' verbosity "Haddock 2.0 and 2.1 do not support the --hoogle flag." - - when (fromFlag argQuickJump && version < mkVersion [2,19]) $ do - let msg = "Haddock prior to 2.19 does not support the --quickjump flag." - alt = "The generated documentation won't have the QuickJump feature." - if Flag True == quickJumpFlag - then die' verbosity msg - else warn verbosity (msg ++ "\n" ++ alt) - - haddockGhcVersionStr <- getProgramOutput verbosity haddockProg - ["--ghc-version"] - case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of - (Nothing, _) -> die' verbosity "Could not get GHC version from Haddock" - (_, Nothing) -> die' verbosity "Could not get GHC version from compiler" - (Just haddockGhcVersion, Just ghcVersion) - | haddockGhcVersion == ghcVersion -> return () - | otherwise -> die' verbosity $ - "Haddock's internal GHC version must match the configured " - ++ "GHC version.\n" - ++ "The GHC version is " ++ prettyShow ghcVersion ++ " but " - ++ "haddock is using GHC version " ++ prettyShow haddockGhcVersion - - return (haddockProg, version) - - -haddock :: PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> HaddockFlags - -> IO () -haddock pkg_descr _ _ haddockFlags - | not (hasLibs pkg_descr) - && not (fromFlag $ haddockExecutables haddockFlags) - && not (fromFlag $ haddockTestSuites haddockFlags) - && not (fromFlag $ haddockBenchmarks haddockFlags) - && not (fromFlag $ haddockForeignLibs haddockFlags) - = - warn (fromFlag $ haddockVerbosity haddockFlags) $ - "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." - -haddock pkg_descr lbi suffixes flags' = do - let verbosity = flag haddockVerbosity - comp = compiler lbi - platform = hostPlatform lbi - - quickJmpFlag = haddockQuickJump flags' - flags = case haddockTarget of - ForDevelopment -> flags' - ForHackage -> flags' - { haddockHoogle = Flag True - , haddockHtml = Flag True - , haddockHtmlLocation = Flag (pkg_url ++ "/docs") - , haddockContents = Flag (toPathTemplate pkg_url) - , haddockLinkedSource = Flag True - , haddockQuickJump = Flag True - } - pkg_url = "/package/$pkg-$version" - flag f = fromFlag $ f flags - - tmpFileOpts = defaultTempFileOptions - { optKeepTempFiles = flag haddockKeepTempFiles } - htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation - $ flags - haddockTarget = - fromFlagOrDefault ForDevelopment (haddockForHackage flags') - - libdirArgs <- getGhcLibDir verbosity lbi - let commonArgs = mconcat - [ libdirArgs - , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags - , fromPackageDescription haddockTarget pkg_descr ] - - (haddockProg, version) <- - getHaddockProg verbosity (withPrograms lbi) comp commonArgs quickJmpFlag - - -- We fall back to using HsColour only for versions of Haddock which don't - -- support '--hyperlinked-sources'. - when (flag haddockLinkedSource && version < mkVersion [2,17]) $ - hscolour' (warn verbosity) haddockTarget pkg_descr lbi suffixes - (defaultHscolourFlags `mappend` haddockToHscolour flags) - - targets <- readTargetInfos verbosity pkg_descr lbi (haddockArgs flags) - - let - targets' = - case targets of - [] -> allTargetsInBuildOrder' pkg_descr lbi - _ -> targets - - internalPackageDB <- - createInternalPackageDB verbosity lbi (flag haddockDistPref) - - (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do - - let component = targetComponent target - clbi = targetCLBI target - - componentInitialBuildSteps (flag haddockDistPref) pkg_descr lbi clbi verbosity - - let - lbi' = lbi { - withPackageDB = withPackageDB lbi ++ [internalPackageDB], - installedPkgs = index - } - - preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes - let - doExe com = case (compToExe com) of - Just exe -> do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ - \tmp -> do - exeArgs <- fromExecutable verbosity tmp lbi' clbi htmlTemplate - version exe - let exeArgs' = commonArgs `mappend` exeArgs - runHaddock verbosity tmpFileOpts comp platform - haddockProg True exeArgs' - Nothing -> do - warn (fromFlag $ haddockVerbosity flags) - "Unsupported component, skipping..." - return () - -- We define 'smsg' once and then reuse it inside the case, so that - -- we don't say we are running Haddock when we actually aren't - -- (e.g., Haddock is not run on non-libraries) - smsg :: IO () - smsg = setupMessage' verbosity "Running Haddock on" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - case component of - CLib lib -> do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ - \tmp -> do - smsg - libArgs <- fromLibrary verbosity tmp lbi' clbi htmlTemplate - version lib - let libArgs' = commonArgs `mappend` libArgs - runHaddock verbosity tmpFileOpts comp platform haddockProg True libArgs' - - pwd <- getCurrentDirectory - - let - ipi = inplaceInstalledPackageInfo - pwd (flag haddockDistPref) pkg_descr - (mkAbiHash "inplace") lib lbi' clbi - - debug verbosity $ "Registering inplace:\n" - ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) - - registerPackage verbosity (compiler lbi') (withPrograms lbi') - (withPackageDB lbi') ipi - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True - } - - return $ PackageIndex.insert ipi index - - CFLib flib -> (when (flag haddockForeignLibs) $ do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ - \tmp -> do - smsg - flibArgs <- fromForeignLib verbosity tmp lbi' clbi htmlTemplate - version flib - let libArgs' = commonArgs `mappend` flibArgs - runHaddock verbosity tmpFileOpts comp platform haddockProg True libArgs') - - >> return index - - CExe _ -> (when (flag haddockExecutables) $ smsg >> doExe component) >> return index - CTest _ -> (when (flag haddockTestSuites) $ smsg >> doExe component) >> return index - CBench _ -> (when (flag haddockBenchmarks) $ smsg >> doExe component) >> return index - - for_ (extraDocFiles pkg_descr) $ \ fpath -> do - files <- matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath - for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs) - - --- | Execute 'Haddock' configured with 'HaddocksFlags'. It is used to build --- index and contents for documentation of multiple packages. --- -createHaddockIndex :: Verbosity - -> ProgramDb - -> Compiler - -> Platform - -> HaddockProjectFlags - -> IO () -createHaddockIndex verbosity programDb comp platform flags = do - let args = fromHaddockProjectFlags flags - (haddockProg, _version) <- - getHaddockProg verbosity programDb comp args (Flag True) - runHaddock verbosity defaultTempFileOptions comp platform haddockProg False args - --- ------------------------------------------------------------------------------ --- Contributions to HaddockArgs (see also Doctest.hs for very similar code). - -fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs -fromFlags env flags = - mempty { - argHideModules = (maybe mempty (All . not) - $ flagToMaybe (haddockInternal flags), mempty), - argLinkSource = if fromFlag (haddockLinkedSource flags) - then Flag ("src/%{MODULE/./-}.html" - ,"src/%{MODULE/./-}.html#%{NAME}" - ,"src/%{MODULE/./-}.html#line-%{LINE}") - else NoFlag, - argLinkedSource = haddockLinkedSource flags, - argQuickJump = haddockQuickJump flags, - argCssFile = haddockCss flags, - argContents = fmap (fromPathTemplate . substPathTemplate env) - (haddockContents flags), - argGenContents = Flag False, - argIndex = fmap (fromPathTemplate . substPathTemplate env) - (haddockIndex flags), - argGenIndex = Flag False, - argBaseUrl = haddockBaseUrl flags, - argLib = haddockLib flags, - argVerbose = maybe mempty (Any . (>= deafening)) - . flagToMaybe $ haddockVerbosity flags, - argOutput = - Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++ - [ Hoogle | Flag True <- [haddockHoogle flags] ] - of [] -> [ Html ] - os -> os, - argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags, - - argGhcOptions = mempty { ghcOptExtra = ghcArgs } - } - where - ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags - -fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs -fromHaddockProjectFlags flags = - mempty - { argOutputDir = Dir (fromFlag $ haddockProjectDir flags) - , argQuickJump = Flag True - , argGenContents = Flag True - , argGenIndex = Flag True - , argPrologueFile = haddockProjectPrologue flags - , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags) - , argLinkedSource = Flag True - , argLib = haddockProjectLib flags - } - - -fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs -fromPackageDescription haddockTarget pkg_descr = mempty - { argInterfaceFile = Flag $ haddockName pkg_descr - , argPackageName = Flag $ packageId $ pkg_descr - , argOutputDir = Dir $ - "doc" "html" haddockDirName haddockTarget pkg_descr - , argPrologue = Flag $ ShortText.fromShortText $ - if ShortText.null desc - then synopsis pkg_descr - else desc - , argTitle = Flag $ showPkg ++ subtitle - } - where - desc = description pkg_descr - showPkg = prettyShow (packageId pkg_descr) - subtitle - | ShortText.null (synopsis pkg_descr) = "" - | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr) - -componentGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions -componentGhcOptions verbosity lbi bi clbi odir = - let f = case compilerFlavor (compiler lbi) of - GHC -> GHC.componentGhcOptions - GHCJS -> GHCJS.componentGhcOptions - _ -> error $ - "Distribution.Simple.Haddock.componentGhcOptions:" ++ - "haddock only supports GHC and GHCJS" - in f verbosity lbi bi clbi odir - -mkHaddockArgs :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> [FilePath] - -> BuildInfo - -> IO HaddockArgs -mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles bi = do - ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate - let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) { - -- Noooooooooo!!!!!111 - -- haddock stomps on our precious .hi - -- and .o files. Workaround by telling - -- haddock to write them elsewhere. - ghcOptObjDir = toFlag tmp, - ghcOptHiDir = toFlag tmp, - ghcOptStubDir = toFlag tmp - } `mappend` getGhcCppOpts haddockVersion bi - sharedOpts = vanillaOpts { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC bi - - } - opts <- if withVanillaLib lbi - then return vanillaOpts - else if withSharedLib lbi - then return sharedOpts - else die' verbosity $ "Must have vanilla or shared libraries " - ++ "enabled in order to run haddock" - - return ifaceArgs - { argGhcOptions = opts - , argTargets = inFiles - , argReexports = getReexports clbi - } - -fromLibrary :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> Library - -> IO HaddockArgs -fromLibrary verbosity tmp lbi clbi htmlTemplate haddockVersion lib = do - inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi - args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion - inFiles (libBuildInfo lib) - return args { - argHideModules = (mempty, otherModules (libBuildInfo lib)) - } - -fromExecutable :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> Executable - -> IO HaddockArgs -fromExecutable verbosity tmp lbi clbi htmlTemplate haddockVersion exe = do - inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi - args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate - haddockVersion inFiles (buildInfo exe) - return args { - argOutputDir = Dir $ unUnqualComponentName $ exeName exe, - argTitle = Flag $ unUnqualComponentName $ exeName exe - } - -fromForeignLib :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> ForeignLib - -> IO HaddockArgs -fromForeignLib verbosity tmp lbi clbi htmlTemplate haddockVersion flib = do - inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi - args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate - haddockVersion inFiles (foreignLibBuildInfo flib) - return args { - argOutputDir = Dir $ unUnqualComponentName $ foreignLibName flib, - argTitle = Flag $ unUnqualComponentName $ foreignLibName flib - } - -compToExe :: Component -> Maybe Executable -compToExe comp = - case comp of - CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } -> - Just Executable { - exeName = testName test, - modulePath = f, - exeScope = ExecutablePublic, - buildInfo = testBuildInfo test - } - CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } -> - Just Executable { - exeName = benchmarkName bench, - modulePath = f, - exeScope = ExecutablePublic, - buildInfo = benchmarkBuildInfo bench - } - CExe exe -> Just exe - _ -> Nothing - -getInterfaces :: Verbosity - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> IO HaddockArgs -getInterfaces verbosity lbi clbi htmlTemplate = do - (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate - traverse_ (warn (verboseUnmarkOutput verbosity)) warnings - return $ mempty { - argInterfaces = packageFlags - } - -getReexports :: ComponentLocalBuildInfo -> [OpenModule] -getReexports LibComponentLocalBuildInfo {componentExposedModules = mods } = - mapMaybe exposedReexport mods -getReexports _ = [] - -getGhcCppOpts :: Version - -> BuildInfo - -> GhcOptions -getGhcCppOpts haddockVersion bi = - mempty { - ghcOptExtensions = toNubListR [EnableExtension CPP | needsCpp], - ghcOptCppOptions = defines - } - where - needsCpp = EnableExtension CPP `elem` usedExtensions bi - defines = [haddockVersionMacro] - haddockVersionMacro = "-D__HADDOCK_VERSION__=" - ++ show (v1 * 1000 + v2 * 10 + v3) - where - (v1, v2, v3) = case versionNumbers haddockVersion of - [] -> (0,0,0) - [x] -> (x,0,0) - [x,y] -> (x,y,0) - (x:y:z:_) -> (x,y,z) - -getGhcLibDir :: Verbosity -> LocalBuildInfo - -> IO HaddockArgs -getGhcLibDir verbosity lbi = do - l <- case compilerFlavor (compiler lbi) of - GHC -> GHC.getLibDir verbosity lbi - GHCJS -> GHCJS.getLibDir verbosity lbi - _ -> error "haddock only supports GHC and GHCJS" - return $ mempty { argGhcLibDir = Flag l } - --- ------------------------------------------------------------------------------ --- | Call haddock with the specified arguments. -runHaddock :: Verbosity - -> TempFileOptions - -> Compiler - -> Platform - -> ConfiguredProgram - -> Bool -- ^ require targets - -> HaddockArgs - -> IO () -runHaddock verbosity tmpFileOpts comp platform haddockProg requireTargets args - | requireTargets && null (argTargets args) = warn verbosity $ - "Haddocks are being requested, but there aren't any modules given " - ++ "to create documentation for." - | otherwise = do - let haddockVersion = fromMaybe (error "unable to determine haddock version") - (programVersion haddockProg) - renderArgs verbosity tmpFileOpts haddockVersion comp platform args $ - \(flags,result)-> do - - runProgram verbosity haddockProg flags - - notice verbosity $ "Documentation created: " ++ result - - -renderArgs :: Verbosity - -> TempFileOptions - -> Version - -> Compiler - -> Platform - -> HaddockArgs - -> (([String], FilePath) -> IO a) - -> IO a -renderArgs verbosity tmpFileOpts version comp platform args k = do - let haddockSupportsUTF8 = version >= mkVersion [2,14,4] - haddockSupportsResponseFiles = version > mkVersion [2,16,2] - createDirectoryIfMissingVerbose verbosity True outputDir - case argPrologue args of - Flag prologueText -> - withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $ - \prologueFileName h -> do - do - when haddockSupportsUTF8 (hSetEncoding h utf8) - hPutStrLn h prologueText - hClose h - let pflag = "--prologue=" ++ prologueFileName - renderedArgs = pflag : renderPureArgs version comp platform args - if haddockSupportsResponseFiles - then - withResponseFile - verbosity - tmpFileOpts - outputDir - "haddock-response.txt" - (if haddockSupportsUTF8 then Just utf8 else Nothing) - renderedArgs - (\responseFileName -> k (["@" ++ responseFileName], result)) - else - k (renderedArgs, result) - _ -> do - let renderedArgs = (case argPrologueFile args of - Flag pfile -> ["--prologue="++pfile] - _ -> []) - <> renderPureArgs version comp platform args - if haddockSupportsResponseFiles - then - withResponseFile - verbosity - tmpFileOpts - outputDir - "haddock-response.txt" - (if haddockSupportsUTF8 then Just utf8 else Nothing) - renderedArgs - (\responseFileName -> k (["@" ++ responseFileName], result)) - else - k (renderedArgs, result) - where - outputDir = (unDir $ argOutputDir args) - result = intercalate ", " - . map (\o -> outputDir - case o of - Html - | fromFlagOrDefault False (argGenIndex args) -> - "index.html" - Html - | otherwise -> - mempty - Hoogle -> pkgstr <.> "txt") - . fromFlagOrDefault [Html] - . argOutput - $ args - where - pkgstr = prettyShow $ packageName pkgid - pkgid = arg argPackageName - arg f = fromFlag $ f args - -renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String] -renderPureArgs version comp platform args = concat - [ map (\f -> "--dump-interface="++ unDir (argOutputDir args) f) - . flagToList . argInterfaceFile $ args - - , if haddockSupportsPackageName - then maybe [] (\pkg -> [ "--package-name=" ++ prettyShow (pkgName pkg) - , "--package-version=" ++ prettyShow (pkgVersion pkg) - ]) - . flagToMaybe . argPackageName $ args - else [] - - , [ "--since-qual=external" | isVersion 2 20 ] - - , [ "--quickjump" | isVersion 2 19 - , True <- flagToList . argQuickJump $ args ] - - , [ "--hyperlinked-source" | isVersion 2 17 - , True <- flagToList . argLinkedSource $ args ] - - , (\(All b,xs) -> bool (map (("--hide=" ++) . prettyShow) xs) [] b) - . argHideModules $ args - - , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args - - , maybe [] (\(m,e,l) -> - ["--source-module=" ++ m - ,"--source-entity=" ++ e] - ++ if isVersion 2 14 then ["--source-entity-line=" ++ l] - else [] - ) . flagToMaybe . argLinkSource $ args - - , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args - - , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args - - , bool ["--gen-contents"] [] .fromFlagOrDefault False . argGenContents $ args - - , maybe [] ((:[]) . ("--use-index="++)) . flagToMaybe . argIndex $ args - - , 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") - . fromFlagOrDefault [] . argOutput $ args - - , renderInterfaces . argInterfaces $ args - - , (:[]) . ("--odir="++) . unDir . argOutputDir $ args - - , maybe [] - ( (:[]) - . ("--title="++) - . (bool (++" (internal documentation)") - id (getAny $ argIgnoreExports args)) - ) - . flagToMaybe . argTitle $ args - - , [ "--optghc=" ++ opt | let opts = argGhcOptions args - , opt <- renderGhcOptions comp platform opts ] - - , maybe [] (\l -> ["-B"++l]) $ - flagToMaybe (argGhcLibDir args) -- error if Nothing? - - -- https://github.com/haskell/haddock/pull/547 - , [ "--reexport=" ++ prettyShow r - | r <- argReexports args - , isVersion 2 19 - ] - - , argTargets $ args - , maybe [] ((:[]) . ("--lib="++)) . flagToMaybe . argLib $ args - ] - where - renderInterfaces = map renderInterface - - renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath, Visibility) -> String - renderInterface (i, html, hypsrc, visibility) = "--read-interface=" ++ - (intercalate "," $ concat [ [ fromMaybe "" html ] - , -- only render hypsrc path if html path - -- is given and hyperlinked-source is - -- enabled - [ case (html, hypsrc) of - (Nothing, _) -> "" - (_, Nothing) -> "" - (_, Just x) | isVersion 2 17 - , fromFlagOrDefault False . argLinkedSource $ args - -> x - | otherwise - -> "" - ] - , if haddockSupportsVisibility - then [ case visibility of - Visible -> "visible" - Hidden -> "hidden" - ] - else [] - , [ i ] - ]) - - bool a b c = if c then a else b - isVersion major minor = version >= mkVersion [major,minor] - verbosityFlag - | isVersion 2 5 = "--verbosity=1" - | otherwise = "--verbose" - haddockSupportsVisibility = version >= mkVersion [2,26,1] - haddockSupportsPackageName = version > mkVersion [2,16] - ---------------------------------------------------------------------------------- - --- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and --- HTML paths, and an optional warning for packages with missing documentation. -haddockPackagePaths :: [InstalledPackageInfo] - -> Maybe (InstalledPackageInfo -> FilePath) - -> IO ([( FilePath -- path to interface - -- file - - , Maybe FilePath -- url to html - -- documentation - - , Maybe FilePath -- url to hyperlinked - -- source - , Visibility - )] - , Maybe String -- warning about - -- missing documentation - ) -haddockPackagePaths ipkgs mkHtmlPath = do - interfaces <- sequenceA - [ case interfaceAndHtmlPath ipkg of - Nothing -> return (Left (packageId ipkg)) - Just (interface, html) -> do - - (html', hypsrc') <- - case html of - Just htmlPath -> do - let hypSrcPath = htmlPath defaultHyperlinkedSourceDirectory - hypSrcExists <- doesDirectoryExist hypSrcPath - return $ ( Just (fixFileUrl htmlPath) - , if hypSrcExists - then Just (fixFileUrl hypSrcPath) - else Nothing - ) - Nothing -> return (Nothing, Nothing) - - exists <- doesFileExist interface - if exists - then return (Right (interface, html', hypsrc', Visible)) - else return (Left pkgid) - | ipkg <- ipkgs, let pkgid = packageId ipkg - , pkgName pkgid `notElem` noHaddockWhitelist - ] - - let missing = [ pkgid | Left pkgid <- interfaces ] - warning = "The documentation for the following packages are not " - ++ "installed. No links will be generated to these packages: " - ++ intercalate ", " (map prettyShow missing) - flags = rights interfaces - - 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" ] - - -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'. - interfaceAndHtmlPath :: InstalledPackageInfo - -> Maybe (FilePath, Maybe FilePath) - interfaceAndHtmlPath pkg = do - interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) - html <- case mkHtmlPath of - Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) - Just mkPath -> Just (mkPath pkg) - return (interface, if null html then Nothing else Just html) - - -- The 'haddock-html' field in the hc-pkg output is often set as a - -- native path, but we need it as a URL. See #1064. Also don't "fix" - -- the path if it is an interpolated one. - fixFileUrl f | Nothing <- mkHtmlPath - , isAbsolute f = "file://" ++ f - | otherwise = f - - -- 'src' is the default hyperlinked source directory ever since. It is - -- not possible to configure that directory in any way in haddock. - defaultHyperlinkedSourceDirectory = "src" - - -haddockPackageFlags :: Verbosity - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate - -> IO ([( FilePath -- path to interface - -- file - - , Maybe FilePath -- url to html - -- documentation - - , Maybe FilePath -- url to hyperlinked - -- source - , Visibility - )] - , Maybe String -- warning about - -- missing documentation - ) -haddockPackageFlags verbosity lbi clbi htmlTemplate = do - let allPkgs = installedPkgs lbi - directDeps = map fst (componentPackageDeps clbi) - transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of - Left x -> return x - Right inf -> die' verbosity $ "internal error when calculating transitive " - ++ "package dependencies.\nDebug info: " ++ show inf - haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath - where - mkHtmlPath = fmap expandTemplateVars htmlTemplate - expandTemplateVars tmpl pkg = - fromPathTemplate . substPathTemplate (env pkg) $ tmpl - env pkg = haddockTemplateEnv lbi (packageId pkg) - - -haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv -haddockTemplateEnv lbi pkg_id = - (PrefixVar, prefix (installDirTemplates lbi)) - -- We want the legacy unit ID here, because it gives us nice paths - -- (Haddock people don't care about the dependencies) - : initialPathTemplateEnv - pkg_id - (mkLegacyUnitId pkg_id) - (compilerInfo (compiler lbi)) - (hostPlatform lbi) - --- ------------------------------------------------------------------------------ --- hscolour support. - -hscolour :: PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> HscolourFlags - -> IO () -hscolour = hscolour' dieNoVerbosity ForDevelopment - -hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. - -> HaddockTarget - -> PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> HscolourFlags - -> IO () -hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = - either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<< - lookupProgramVersion verbosity hscolourProgram - (orLaterVersion (mkVersion [1,8])) (withPrograms lbi) - where - go :: ConfiguredProgram -> IO () - go hscolourProg = do - warn verbosity $ - "the 'cabal hscolour' command is deprecated in favour of 'cabal " ++ - "haddock --hyperlink-source' and will be removed in the next major " ++ - "release." - - setupMessage verbosity "Running hscolour for" (packageId pkg_descr) - createDirectoryIfMissingVerbose verbosity True $ - hscolourPref haddockTarget distPref pkg_descr - - withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - let - doExe com = case (compToExe com) of - Just exe -> do - let outputDir = hscolourPref haddockTarget distPref pkg_descr - unUnqualComponentName (exeName exe) "src" - runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi - Nothing -> do - warn (fromFlag $ hscolourVerbosity flags) - "Unsupported component, skipping..." - return () - case comp of - CLib lib -> do - let outputDir = hscolourPref haddockTarget distPref pkg_descr "src" - runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi - CFLib flib -> do - let outputDir = hscolourPref haddockTarget distPref pkg_descr - unUnqualComponentName (foreignLibName flib) "src" - runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi - CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp - CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp - CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp - - stylesheet = flagToMaybe (hscolourCSS flags) - - verbosity = fromFlag (hscolourVerbosity flags) - distPref = fromFlag (hscolourDistPref flags) - - runHsColour prog outputDir moduleFiles = do - createDirectoryIfMissingVerbose verbosity True outputDir - - case stylesheet of -- copy the CSS file - Nothing | programVersion prog >= Just (mkVersion [1,9]) -> - runProgram verbosity prog - ["-print-css", "-o" ++ outputDir "hscolour.css"] - | otherwise -> return () - Just s -> copyFileVerbose verbosity s (outputDir "hscolour.css") - - for_ moduleFiles $ \(m, inFile) -> - runProgram verbosity prog - ["-css", "-anchor", "-o" ++ outFile m, inFile] - where - outFile m = outputDir - intercalate "-" (ModuleName.components m) <.> "html" - -haddockToHscolour :: HaddockFlags -> HscolourFlags -haddockToHscolour flags = - HscolourFlags { - hscolourCSS = haddockHscolourCss flags, - hscolourExecutables = haddockExecutables flags, - hscolourTestSuites = haddockTestSuites flags, - hscolourBenchmarks = haddockBenchmarks flags, - hscolourForeignLibs = haddockForeignLibs flags, - hscolourVerbosity = haddockVerbosity flags, - hscolourDistPref = haddockDistPref flags, - hscolourCabalFilePath = haddockCabalFilePath flags - } - --- ------------------------------------------------------------------------------ --- Boilerplate Monoid instance. -instance Monoid HaddockArgs where - mempty = gmempty - mappend = (<>) - -instance Semigroup HaddockArgs where - (<>) = gmappend - -instance Monoid Directory where - mempty = Dir "." - mappend = (<>) - -instance Semigroup Directory where - Dir m <> Dir n = Dir $ m n + +-- | +-- Module : Distribution.Simple.Haddock +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module deals with the @haddock@ and @hscolour@ commands. +-- It uses information about installed packages (from @ghc-pkg@) to find the +-- locations of documentation for dependent packages, so it can create links. +-- +-- The @hscolour@ support allows generating HTML versions of the original +-- source, with coloured syntax highlighting. +module Distribution.Simple.Haddock + ( haddock + , createHaddockIndex + , hscolour + , haddockPackagePaths + , Visibility (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS + +-- local + +import Distribution.Backpack (OpenModule) +import Distribution.Backpack.DescribeUnitId +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import qualified Distribution.ModuleName as ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Parsec (simpleParsec) +import Distribution.Pretty +import Distribution.Simple.Build +import Distribution.Simple.BuildPaths +import Distribution.Simple.BuildTarget +import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.Glob (matchDirFileGlob) +import Distribution.Simple.InstallDirs +import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Program.GHC +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import Distribution.Simple.Program.ResponseFile +import Distribution.Simple.Register +import Distribution.Simple.Setup.Haddock +import Distribution.Simple.Setup.Hscolour +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ExposedModule +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Utils.NubList +import qualified Distribution.Utils.ShortText as ShortText +import Distribution.Version + +import Distribution.Verbosity +import Language.Haskell.Extension + +import Distribution.Compat.Semigroup (All (..), Any (..)) + +import Control.Monad +import Data.Either (rights) + +import Distribution.Simple.Errors +import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory) +import System.FilePath (isAbsolute, normalise, (<.>), ()) +import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) + +-- ------------------------------------------------------------------------------ +-- Types + +-- | A record that represents the arguments to the haddock executable, a product +-- monoid. +data HaddockArgs = HaddockArgs + { argInterfaceFile :: Flag FilePath + -- ^ Path to the interface file, relative to argOutputDir, required. + , argPackageName :: Flag PackageIdentifier + -- ^ Package name, required. + , argHideModules :: (All, [ModuleName.ModuleName]) + -- ^ (Hide modules ?, modules to hide) + , argIgnoreExports :: Any + -- ^ Ignore export lists in modules? + , argLinkSource :: Flag (Template, Template, Template) + -- ^ (Template for modules, template for symbols, template for lines). + , argLinkedSource :: Flag Bool + -- ^ Generate hyperlinked sources + , argQuickJump :: Flag Bool + -- ^ Generate quickjump index + , argCssFile :: Flag FilePath + -- ^ Optional custom CSS file. + , argContents :: Flag String + -- ^ Optional URL to contents page. + , argGenContents :: Flag Bool + -- ^ Generate contents + , argIndex :: Flag String + -- ^ Optional URL to index page. + , argGenIndex :: Flag Bool + -- ^ Generate index + , argBaseUrl :: Flag String + -- ^ Optional base url from which static files will be loaded. + , argVerbose :: Any + , argOutput :: Flag [Output] + -- ^ HTML or Hoogle doc or both? Required. + , argInterfaces :: [(FilePath, Maybe String, Maybe String, Visibility)] + -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)]. + , argOutputDir :: Directory + -- ^ Where to generate the documentation. + , argTitle :: Flag String + -- ^ Page title, required. + , argPrologue :: Flag String + -- ^ Prologue text, required for 'haddock', ignored by 'haddocks'. + , argPrologueFile :: Flag FilePath + -- ^ Prologue file name, ignored by 'haddock', optional for 'haddocks'. + , argGhcOptions :: GhcOptions + -- ^ Additional flags to pass to GHC. + , argGhcLibDir :: Flag FilePath + -- ^ To find the correct GHC, required. + , argReexports :: [OpenModule] + -- ^ Re-exported modules + , argTargets :: [FilePath] + -- ^ Modules to process. + , argLib :: Flag String + -- ^ haddock's static \/ auxiliary files. + } + deriving (Generic) + +-- | The FilePath of a directory, it's a monoid under '()'. +newtype Directory = Dir {unDir' :: FilePath} deriving (Read, Show, Eq, Ord) + +unDir :: Directory -> FilePath +unDir = normalise . unDir' + +type Template = String + +data Output = Html | Hoogle + deriving (Eq) + +-- ------------------------------------------------------------------------------ +-- Haddock support + +-- | Get Haddock program and check if it matches the request +getHaddockProg + :: Verbosity + -> ProgramDb + -> Compiler + -> HaddockArgs + -> Flag Bool + -- ^ quickjump feature + -> IO (ConfiguredProgram, Version) +getHaddockProg verbosity programDb comp args quickJumpFlag = do + let HaddockArgs + { argQuickJump + , argOutput + } = args + hoogle = Hoogle `elem` fromFlagOrDefault [] argOutput + + (haddockProg, version, _) <- + requireProgramVersion + verbosity + haddockProgram + (orLaterVersion (mkVersion [2, 0])) + programDb + + -- various sanity checks + when (hoogle && version < mkVersion [2, 2]) $ + dieWithException verbosity NoSupportForHoogle + + when (fromFlag argQuickJump && version < mkVersion [2, 19]) $ do + let msg = "Haddock prior to 2.19 does not support the --quickjump flag." + alt = "The generated documentation won't have the QuickJump feature." + if Flag True == quickJumpFlag + then dieWithException verbosity NoSupportForQuickJumpFlag + else warn verbosity (msg ++ "\n" ++ alt) + + haddockGhcVersionStr <- + getProgramOutput + verbosity + haddockProg + ["--ghc-version"] + case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of + (Nothing, _) -> dieWithException verbosity NoGHCVersionFromHaddock + (_, Nothing) -> dieWithException verbosity NoGHCVersionFromCompiler + (Just haddockGhcVersion, Just ghcVersion) + | haddockGhcVersion == ghcVersion -> return () + | otherwise -> dieWithException verbosity $ HaddockAndGHCVersionDoesntMatch ghcVersion haddockGhcVersion + + return (haddockProg, version) + +haddock + :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HaddockFlags + -> IO () +haddock pkg_descr _ _ haddockFlags + | not (hasLibs pkg_descr) + && not (fromFlag $ haddockExecutables haddockFlags) + && not (fromFlag $ haddockTestSuites haddockFlags) + && not (fromFlag $ haddockBenchmarks haddockFlags) + && not (fromFlag $ haddockForeignLibs haddockFlags) = + warn (fromFlag $ haddockVerbosity haddockFlags) $ + "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." +haddock pkg_descr lbi suffixes flags' = do + let verbosity = flag haddockVerbosity + comp = compiler lbi + platform = hostPlatform lbi + + quickJmpFlag = haddockQuickJump flags' + flags = case haddockTarget of + ForDevelopment -> flags' + ForHackage -> + flags' + { haddockHoogle = Flag True + , haddockHtml = Flag True + , haddockHtmlLocation = Flag (pkg_url ++ "/docs") + , haddockContents = Flag (toPathTemplate pkg_url) + , haddockLinkedSource = Flag True + , haddockQuickJump = Flag True + } + pkg_url = "/package/$pkg-$version" + flag f = fromFlag $ f flags + + tmpFileOpts = + defaultTempFileOptions + { optKeepTempFiles = flag haddockKeepTempFiles + } + htmlTemplate = + fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ + flags + haddockTarget = + fromFlagOrDefault ForDevelopment (haddockForHackage flags') + + libdirArgs <- getGhcLibDir verbosity lbi + -- The haddock-output-dir flag overrides any other documentation placement concerns. + -- The point is to give the user full freedom over the location if they need it. + let overrideWithOutputDir args = case haddockOutputDir flags of + NoFlag -> args + Flag dir -> args{argOutputDir = Dir dir} + let commonArgs = + overrideWithOutputDir $ + mconcat + [ libdirArgs + , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags + , fromPackageDescription haddockTarget pkg_descr + ] + + (haddockProg, version) <- + getHaddockProg verbosity (withPrograms lbi) comp commonArgs quickJmpFlag + + -- We fall back to using HsColour only for versions of Haddock which don't + -- support '--hyperlinked-sources'. + let using_hscolour = flag haddockLinkedSource && version < mkVersion [2, 17] + when using_hscolour $ + hscolour' + (warn verbosity) + haddockTarget + pkg_descr + lbi + suffixes + (defaultHscolourFlags `mappend` haddockToHscolour flags) + + targets <- readTargetInfos verbosity pkg_descr lbi (haddockArgs flags) + + let + targets' = + case targets of + [] -> allTargetsInBuildOrder' pkg_descr lbi + _ -> targets + + internalPackageDB <- + createInternalPackageDB verbosity lbi (flag haddockDistPref) + + (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do + let component = targetComponent target + clbi = targetCLBI target + + preBuildComponent verbosity lbi target + + let + lbi' = + lbi + { withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , installedPkgs = index + } + + preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes + let + doExe com = case (compToExe com) of + Just exe -> do + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ + \tmp -> do + exeArgs <- + fromExecutable + verbosity + tmp + lbi' + clbi + htmlTemplate + version + exe + let exeArgs' = commonArgs `mappend` exeArgs + runHaddock + verbosity + tmpFileOpts + comp + platform + haddockProg + True + exeArgs' + Nothing -> do + warn + (fromFlag $ haddockVerbosity flags) + "Unsupported component, skipping..." + return () + -- We define 'smsg' once and then reuse it inside the case, so that + -- we don't say we are running Haddock when we actually aren't + -- (e.g., Haddock is not run on non-libraries) + smsg :: IO () + smsg = + setupMessage' + verbosity + "Running Haddock on" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) + case component of + CLib lib -> do + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ + \tmp -> do + smsg + libArgs <- + fromLibrary + verbosity + tmp + lbi' + clbi + htmlTemplate + version + lib + let libArgs' = commonArgs `mappend` libArgs + runHaddock verbosity tmpFileOpts comp platform haddockProg True libArgs' + + pwd <- getCurrentDirectory + + let + ipi = + inplaceInstalledPackageInfo + pwd + (flag haddockDistPref) + pkg_descr + (mkAbiHash "inplace") + lib + lbi' + clbi + + debug verbosity $ + "Registering inplace:\n" + ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) + + registerPackage + verbosity + (compiler lbi') + (withPrograms lbi') + (withPackageDB lbi') + ipi + HcPkg.defaultRegisterOptions + { HcPkg.registerMultiInstance = True + } + + return $ PackageIndex.insert ipi index + CFLib flib -> + when + (flag haddockForeignLibs) + ( do + withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ + \tmp -> do + smsg + flibArgs <- + fromForeignLib + verbosity + tmp + lbi' + clbi + htmlTemplate + version + flib + let libArgs' = commonArgs `mappend` flibArgs + runHaddock verbosity tmpFileOpts comp platform haddockProg True libArgs' + ) + >> return index + CExe _ -> when (flag haddockExecutables) (smsg >> doExe component) >> return index + CTest _ -> when (flag haddockTestSuites) (smsg >> doExe component) >> return index + CBench _ -> when (flag haddockBenchmarks) (smsg >> doExe component) >> return index + + for_ (extraDocFiles pkg_descr) $ \fpath -> do + files <- matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath + for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs) + +-- | Execute 'Haddock' configured with 'HaddocksFlags'. It is used to build +-- index and contents for documentation of multiple packages. +createHaddockIndex + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> HaddockProjectFlags + -> IO () +createHaddockIndex verbosity programDb comp platform flags = do + let args = fromHaddockProjectFlags flags + (haddockProg, _version) <- + getHaddockProg verbosity programDb comp args (Flag True) + runHaddock verbosity defaultTempFileOptions comp platform haddockProg False args + +-- ------------------------------------------------------------------------------ +-- Contributions to HaddockArgs (see also Doctest.hs for very similar code). + +fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs +fromFlags env flags = + mempty + { argHideModules = + ( maybe mempty (All . not) $ + flagToMaybe (haddockInternal flags) + , mempty + ) + , argLinkSource = + if fromFlag (haddockLinkedSource flags) + then + Flag + ( "src/%{MODULE/./-}.html" + , "src/%{MODULE/./-}.html#%{NAME}" + , "src/%{MODULE/./-}.html#line-%{LINE}" + ) + else NoFlag + , argLinkedSource = haddockLinkedSource flags + , argQuickJump = haddockQuickJump flags + , argCssFile = haddockCss flags + , argContents = + fmap + (fromPathTemplate . substPathTemplate env) + (haddockContents flags) + , argGenContents = Flag False + , argIndex = + fmap + (fromPathTemplate . substPathTemplate env) + (haddockIndex flags) + , argGenIndex = Flag False + , argBaseUrl = haddockBaseUrl flags + , argLib = haddockLib flags + , argVerbose = + maybe mempty (Any . (>= deafening)) + . flagToMaybe + $ haddockVerbosity flags + , argOutput = + Flag $ case [Html | Flag True <- [haddockHtml flags]] + ++ [Hoogle | Flag True <- [haddockHoogle flags]] of + [] -> [Html] + os -> os + , argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags + , argGhcOptions = mempty{ghcOptExtra = ghcArgs} + } + where + ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags + +fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs +fromHaddockProjectFlags flags = + mempty + { argOutputDir = Dir (fromFlag $ haddockProjectDir flags) + , argQuickJump = Flag True + , argGenContents = Flag True + , argGenIndex = Flag True + , argPrologueFile = haddockProjectPrologue flags + , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags) + , argLinkedSource = Flag True + , argLib = haddockProjectLib flags + } + +fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs +fromPackageDescription haddockTarget pkg_descr = + mempty + { argInterfaceFile = Flag $ haddockName pkg_descr + , argPackageName = Flag $ packageId $ pkg_descr + , argOutputDir = + Dir $ + "doc" "html" haddockDirName haddockTarget pkg_descr + , argPrologue = + Flag $ + ShortText.fromShortText $ + if ShortText.null desc + then synopsis pkg_descr + else desc + , argTitle = Flag $ showPkg ++ subtitle + } + where + desc = description pkg_descr + showPkg = prettyShow (packageId pkg_descr) + subtitle + | ShortText.null (synopsis pkg_descr) = "" + | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr) + +componentGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> GhcOptions +componentGhcOptions verbosity lbi bi clbi odir = + let f = case compilerFlavor (compiler lbi) of + GHC -> GHC.componentGhcOptions + GHCJS -> GHCJS.componentGhcOptions + _ -> + error $ + "Distribution.Simple.Haddock.componentGhcOptions:" + ++ "haddock only supports GHC and GHCJS" + in f verbosity lbi bi clbi odir + +mkHaddockArgs + :: Verbosity + -> FilePath + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> Version + -> [FilePath] + -> BuildInfo + -> IO HaddockArgs +mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles bi = do + ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate + let vanillaOpts = + (componentGhcOptions normal lbi bi clbi (buildDir lbi)) + { -- Noooooooooo!!!!!111 + -- haddock stomps on our precious .hi + -- and .o files. Workaround by telling + -- haddock to write them elsewhere. + ghcOptObjDir = toFlag tmp + , ghcOptHiDir = toFlag tmp + , ghcOptStubDir = toFlag tmp + } + `mappend` getGhcCppOpts haddockVersion bi + sharedOpts = + vanillaOpts + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcSharedOptions GHC bi + } + opts <- + if withVanillaLib lbi + then return vanillaOpts + else + if withSharedLib lbi + then return sharedOpts + else dieWithException verbosity MustHaveSharedLibraries + + return + ifaceArgs + { argGhcOptions = opts + , argTargets = inFiles + , argReexports = getReexports clbi + } + +fromLibrary + :: Verbosity + -> FilePath + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> Version + -> Library + -> IO HaddockArgs +fromLibrary verbosity tmp lbi clbi htmlTemplate haddockVersion lib = do + inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi + args <- + mkHaddockArgs + verbosity + tmp + lbi + clbi + htmlTemplate + haddockVersion + inFiles + (libBuildInfo lib) + return + args + { argHideModules = (mempty, otherModules (libBuildInfo lib)) + } + +fromExecutable + :: Verbosity + -> FilePath + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> Version + -> Executable + -> IO HaddockArgs +fromExecutable verbosity tmp lbi clbi htmlTemplate haddockVersion exe = do + inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi + args <- + mkHaddockArgs + verbosity + tmp + lbi + clbi + htmlTemplate + haddockVersion + inFiles + (buildInfo exe) + return + args + { argOutputDir = Dir $ unUnqualComponentName $ exeName exe + , argTitle = Flag $ unUnqualComponentName $ exeName exe + } + +fromForeignLib + :: Verbosity + -> FilePath + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> Version + -> ForeignLib + -> IO HaddockArgs +fromForeignLib verbosity tmp lbi clbi htmlTemplate haddockVersion flib = do + inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi + args <- + mkHaddockArgs + verbosity + tmp + lbi + clbi + htmlTemplate + haddockVersion + inFiles + (foreignLibBuildInfo flib) + return + args + { argOutputDir = Dir $ unUnqualComponentName $ foreignLibName flib + , argTitle = Flag $ unUnqualComponentName $ foreignLibName flib + } + +compToExe :: Component -> Maybe Executable +compToExe comp = + case comp of + CTest test@TestSuite{testInterface = TestSuiteExeV10 _ f} -> + Just + Executable + { exeName = testName test + , modulePath = f + , exeScope = ExecutablePublic + , buildInfo = testBuildInfo test + } + CBench bench@Benchmark{benchmarkInterface = BenchmarkExeV10 _ f} -> + Just + Executable + { exeName = benchmarkName bench + , modulePath = f + , exeScope = ExecutablePublic + , buildInfo = benchmarkBuildInfo bench + } + CExe exe -> Just exe + _ -> Nothing + +getInterfaces + :: Verbosity + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> IO HaddockArgs +getInterfaces verbosity lbi clbi htmlTemplate = do + (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate + traverse_ (warn (verboseUnmarkOutput verbosity)) warnings + return $ + mempty + { argInterfaces = packageFlags + } + +getReexports :: ComponentLocalBuildInfo -> [OpenModule] +getReexports LibComponentLocalBuildInfo{componentExposedModules = mods} = + mapMaybe exposedReexport mods +getReexports _ = [] + +getGhcCppOpts + :: Version + -> BuildInfo + -> GhcOptions +getGhcCppOpts haddockVersion bi = + mempty + { ghcOptExtensions = toNubListR [EnableExtension CPP | needsCpp] + , ghcOptCppOptions = defines + } + where + needsCpp = EnableExtension CPP `elem` usedExtensions bi + defines = [haddockVersionMacro] + haddockVersionMacro = + "-D__HADDOCK_VERSION__=" + ++ show (v1 * 1000 + v2 * 10 + v3) + where + (v1, v2, v3) = case versionNumbers haddockVersion of + [] -> (0, 0, 0) + [x] -> (x, 0, 0) + [x, y] -> (x, y, 0) + (x : y : z : _) -> (x, y, z) + +getGhcLibDir + :: Verbosity + -> LocalBuildInfo + -> IO HaddockArgs +getGhcLibDir verbosity lbi = do + l <- case compilerFlavor (compiler lbi) of + GHC -> GHC.getLibDir verbosity lbi + GHCJS -> GHCJS.getLibDir verbosity lbi + _ -> error "haddock only supports GHC and GHCJS" + return $ mempty{argGhcLibDir = Flag l} + +-- ------------------------------------------------------------------------------ + +-- | Call haddock with the specified arguments. +runHaddock + :: Verbosity + -> TempFileOptions + -> Compiler + -> Platform + -> ConfiguredProgram + -> Bool + -- ^ require targets + -> HaddockArgs + -> IO () +runHaddock verbosity tmpFileOpts comp platform haddockProg requireTargets args + | requireTargets && null (argTargets args) = + warn verbosity $ + "Haddocks are being requested, but there aren't any modules given " + ++ "to create documentation for." + | otherwise = do + let haddockVersion = + fromMaybe + (error "unable to determine haddock version") + (programVersion haddockProg) + renderArgs verbosity tmpFileOpts haddockVersion comp platform args $ + \(flags, result) -> do + runProgram verbosity haddockProg flags + + notice verbosity $ "Documentation created: " ++ result + +renderArgs + :: Verbosity + -> TempFileOptions + -> Version + -> Compiler + -> Platform + -> HaddockArgs + -> (([String], FilePath) -> IO a) + -> IO a +renderArgs verbosity tmpFileOpts version comp platform args k = do + let haddockSupportsUTF8 = version >= mkVersion [2, 14, 4] + haddockSupportsResponseFiles = version > mkVersion [2, 16, 2] + createDirectoryIfMissingVerbose verbosity True outputDir + case argPrologue args of + Flag prologueText -> + withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $ + \prologueFileName h -> do + do + when haddockSupportsUTF8 (hSetEncoding h utf8) + hPutStrLn h prologueText + hClose h + let pflag = "--prologue=" ++ prologueFileName + renderedArgs = pflag : renderPureArgs version comp platform args + if haddockSupportsResponseFiles + then + withResponseFile + verbosity + tmpFileOpts + outputDir + "haddock-response.txt" + (if haddockSupportsUTF8 then Just utf8 else Nothing) + renderedArgs + (\responseFileName -> k (["@" ++ responseFileName], result)) + else k (renderedArgs, result) + _ -> do + let renderedArgs = + ( case argPrologueFile args of + Flag pfile -> ["--prologue=" ++ pfile] + _ -> [] + ) + <> renderPureArgs version comp platform args + if haddockSupportsResponseFiles + then + withResponseFile + verbosity + tmpFileOpts + outputDir + "haddock-response.txt" + (if haddockSupportsUTF8 then Just utf8 else Nothing) + renderedArgs + (\responseFileName -> k (["@" ++ responseFileName], result)) + else k (renderedArgs, result) + where + outputDir = (unDir $ argOutputDir args) + isNotArgContents = isNothing (flagToMaybe $ argContents args) + isNotArgIndex = isNothing (flagToMaybe $ argIndex args) + isArgGenIndex = fromFlagOrDefault False (argGenIndex args) + -- Haddock, when generating HTML, does not generate an index if the options + -- --use-contents or --use-index are passed to it. See + -- https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-use-contents + isIndexGenerated = isArgGenIndex && isNotArgContents && isNotArgIndex + result = + intercalate ", " + . map + ( \o -> + outputDir + case o of + Html + | isIndexGenerated -> + "index.html" + Html + | otherwise -> + mempty + Hoogle -> pkgstr <.> "txt" + ) + . fromFlagOrDefault [Html] + . argOutput + $ args + where + pkgstr = prettyShow $ packageName pkgid + pkgid = arg argPackageName + arg f = fromFlag $ f args + +renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String] +renderPureArgs version comp platform args = + concat + [ map (\f -> "--dump-interface=" ++ unDir (argOutputDir args) f) + . flagToList + . argInterfaceFile + $ args + , if haddockSupportsPackageName + then + maybe + [] + ( \pkg -> + [ "--package-name=" ++ prettyShow (pkgName pkg) + , "--package-version=" ++ prettyShow (pkgVersion pkg) + ] + ) + . flagToMaybe + . argPackageName + $ args + else [] + , ["--since-qual=external" | isVersion 2 20] + , [ "--quickjump" | isVersion 2 19, True <- flagToList . argQuickJump $ args + ] + , ["--hyperlinked-source" | isHyperlinkedSource] + , (\(All b, xs) -> bool (map (("--hide=" ++) . prettyShow) xs) [] b) + . argHideModules + $ args + , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args + , -- Haddock's --source-* options are ignored once --hyperlinked-source is + -- set. + -- See https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-hyperlinked-source + -- To avoid Haddock's warning, we only set --source-* options if + -- --hyperlinked-source is not set. + if isHyperlinkedSource + then [] + else + maybe + [] + ( \(m, e, l) -> + [ "--source-module=" ++ m + , "--source-entity=" ++ e + ] + ++ if isVersion 2 14 + then ["--source-entity-line=" ++ l] + else [] + ) + . flagToMaybe + . argLinkSource + $ args + , maybe [] ((: []) . ("--css=" ++)) . flagToMaybe . argCssFile $ args + , maybe [] ((: []) . ("--use-contents=" ++)) . flagToMaybe . argContents $ args + , bool ["--gen-contents"] [] . fromFlagOrDefault False . argGenContents $ args + , maybe [] ((: []) . ("--use-index=" ++)) . flagToMaybe . argIndex $ args + , 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") + . fromFlagOrDefault [] + . argOutput + $ args + , renderInterfaces . argInterfaces $ args + , (: []) . ("--odir=" ++) . unDir . argOutputDir $ args + , maybe + [] + ( (: []) + . ("--title=" ++) + . ( bool + (++ " (internal documentation)") + id + (getAny $ argIgnoreExports args) + ) + ) + . flagToMaybe + . argTitle + $ args + , [ "--optghc=" ++ opt | let opts = argGhcOptions args, opt <- renderGhcOptions comp platform opts + ] + , maybe [] (\l -> ["-B" ++ l]) $ + flagToMaybe (argGhcLibDir args) -- error if Nothing? + , -- https://github.com/haskell/haddock/pull/547 + [ "--reexport=" ++ prettyShow r + | r <- argReexports args + , isVersion 2 19 + ] + , argTargets $ args + , maybe [] ((: []) . ("--lib=" ++)) . flagToMaybe . argLib $ args + ] + where + renderInterfaces = map renderInterface + + renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath, Visibility) -> String + renderInterface (i, html, hypsrc, visibility) = + "--read-interface=" + ++ intercalate + "," + ( concat + [ [fromMaybe "" html] + , -- only render hypsrc path if html path + -- is given and hyperlinked-source is + -- enabled + + [ case (html, hypsrc) of + (Nothing, _) -> "" + (_, Nothing) -> "" + (_, Just x) + | isVersion 2 17 + , fromFlagOrDefault False . argLinkedSource $ args -> + x + | otherwise -> + "" + ] + , if haddockSupportsVisibility + then + [ case visibility of + Visible -> "visible" + Hidden -> "hidden" + ] + else [] + , [i] + ] + ) + + bool a b c = if c then a else b + isVersion major minor = version >= mkVersion [major, minor] + verbosityFlag + | isVersion 2 5 = "--verbosity=1" + | otherwise = "--verbose" + haddockSupportsVisibility = version >= mkVersion [2, 26, 1] + haddockSupportsPackageName = version > mkVersion [2, 16] + haddockSupportsHyperlinkedSource = isVersion 2 17 + isHyperlinkedSource = + haddockSupportsHyperlinkedSource + && fromFlagOrDefault False (argLinkedSource args) + +--------------------------------------------------------------------------------- + +-- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and +-- HTML paths, and an optional warning for packages with missing documentation. +haddockPackagePaths + :: [InstalledPackageInfo] + -> Maybe (InstalledPackageInfo -> FilePath) + -> IO + ( [ ( FilePath -- path to interface + -- file + , Maybe FilePath -- url to html + -- documentation + , Maybe FilePath -- url to hyperlinked + -- source + , Visibility + ) + ] + , Maybe String -- warning about + -- missing documentation + ) +haddockPackagePaths ipkgs mkHtmlPath = do + interfaces <- + sequenceA + [ case interfaceAndHtmlPath ipkg of + Nothing -> return (Left (packageId ipkg)) + Just (interface, html) -> do + (html', hypsrc') <- + case html of + Just htmlPath -> do + let hypSrcPath = htmlPath defaultHyperlinkedSourceDirectory + hypSrcExists <- doesDirectoryExist hypSrcPath + return $ + ( Just (fixFileUrl htmlPath) + , if hypSrcExists + then Just (fixFileUrl hypSrcPath) + else Nothing + ) + Nothing -> return (Nothing, Nothing) + + exists <- doesFileExist interface + if exists + then return (Right (interface, html', hypsrc', Visible)) + else return (Left pkgid) + | ipkg <- ipkgs + , let pkgid = packageId ipkg + , pkgName pkgid `notElem` noHaddockWhitelist + ] + + let missing = [pkgid | Left pkgid <- interfaces] + warning = + "The documentation for the following packages are not " + ++ "installed. No links will be generated to these packages: " + ++ intercalate ", " (map prettyShow missing) + flags = rights interfaces + + 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"] + + -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'. + interfaceAndHtmlPath + :: InstalledPackageInfo + -> Maybe (FilePath, Maybe FilePath) + interfaceAndHtmlPath pkg = do + interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) + html <- case mkHtmlPath of + Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) + Just mkPath -> Just (mkPath pkg) + return (interface, if null html then Nothing else Just html) + + -- The 'haddock-html' field in the hc-pkg output is often set as a + -- native path, but we need it as a URL. See #1064. Also don't "fix" + -- the path if it is an interpolated one. + fixFileUrl f + | Nothing <- mkHtmlPath + , isAbsolute f = + "file://" ++ f + | otherwise = f + + -- 'src' is the default hyperlinked source directory ever since. It is + -- not possible to configure that directory in any way in haddock. + defaultHyperlinkedSourceDirectory = "src" + +haddockPackageFlags + :: Verbosity + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -> IO + ( [ ( FilePath -- path to interface + -- file + , Maybe FilePath -- url to html + -- documentation + , Maybe FilePath -- url to hyperlinked + -- source + , Visibility + ) + ] + , Maybe String -- warning about + -- missing documentation + ) +haddockPackageFlags verbosity lbi clbi htmlTemplate = do + let allPkgs = installedPkgs lbi + directDeps = map fst (componentPackageDeps clbi) + transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of + Left x -> return x + Right inf -> + dieWithException verbosity $ HaddockPackageFlags inf + + haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath + where + mkHtmlPath = fmap expandTemplateVars htmlTemplate + expandTemplateVars tmpl pkg = + fromPathTemplate . substPathTemplate (env pkg) $ tmpl + env pkg = haddockTemplateEnv lbi (packageId pkg) + +haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv +haddockTemplateEnv lbi pkg_id = + (PrefixVar, prefix (installDirTemplates lbi)) + -- We want the legacy unit ID here, because it gives us nice paths + -- (Haddock people don't care about the dependencies) + : initialPathTemplateEnv + pkg_id + (mkLegacyUnitId pkg_id) + (compilerInfo (compiler lbi)) + (hostPlatform lbi) + +-- ------------------------------------------------------------------------------ +-- hscolour support. + +hscolour + :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour = hscolour' dieNoVerbosity ForDevelopment + +hscolour' + :: (String -> IO ()) + -- ^ Called when the 'hscolour' exe is not found. + -> HaddockTarget + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = + either (\excep -> onNoHsColour $ exceptionMessage excep) (\(hscolourProg, _, _) -> go hscolourProg) + =<< lookupProgramVersion + verbosity + hscolourProgram + (orLaterVersion (mkVersion [1, 8])) + (withPrograms lbi) + where + go :: ConfiguredProgram -> IO () + go hscolourProg = do + warn verbosity $ + "the 'cabal hscolour' command is deprecated in favour of 'cabal " + ++ "haddock --hyperlink-source' and will be removed in the next major " + ++ "release." + + setupMessage verbosity "Running hscolour for" (packageId pkg_descr) + createDirectoryIfMissingVerbose verbosity True $ + hscolourPref haddockTarget distPref pkg_descr + + withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do + let tgt = TargetInfo clbi comp + preBuildComponent verbosity lbi tgt + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + let + doExe com = case (compToExe com) of + Just exe -> do + let outputDir = + hscolourPref haddockTarget distPref pkg_descr + unUnqualComponentName (exeName exe) + "src" + runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi + Nothing -> do + warn + (fromFlag $ hscolourVerbosity flags) + "Unsupported component, skipping..." + return () + case comp of + CLib lib -> do + let outputDir = hscolourPref haddockTarget distPref pkg_descr "src" + runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi + CFLib flib -> do + let outputDir = + hscolourPref haddockTarget distPref pkg_descr + unUnqualComponentName (foreignLibName flib) + "src" + runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi + CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp + CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp + CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp + + stylesheet = flagToMaybe (hscolourCSS flags) + + verbosity = fromFlag (hscolourVerbosity flags) + distPref = fromFlag (hscolourDistPref flags) + + runHsColour prog outputDir moduleFiles = do + createDirectoryIfMissingVerbose verbosity True outputDir + + case stylesheet of -- copy the CSS file + Nothing + | programVersion prog >= Just (mkVersion [1, 9]) -> + runProgram + verbosity + prog + ["-print-css", "-o" ++ outputDir "hscolour.css"] + | otherwise -> return () + Just s -> copyFileVerbose verbosity s (outputDir "hscolour.css") + + for_ moduleFiles $ \(m, inFile) -> + runProgram + verbosity + prog + ["-css", "-anchor", "-o" ++ outFile m, inFile] + where + outFile m = + outputDir + intercalate "-" (ModuleName.components m) <.> "html" + +haddockToHscolour :: HaddockFlags -> HscolourFlags +haddockToHscolour flags = + HscolourFlags + { hscolourCSS = haddockHscolourCss flags + , hscolourExecutables = haddockExecutables flags + , hscolourTestSuites = haddockTestSuites flags + , hscolourBenchmarks = haddockBenchmarks flags + , hscolourForeignLibs = haddockForeignLibs flags + , hscolourVerbosity = haddockVerbosity flags + , hscolourDistPref = haddockDistPref flags + , hscolourCabalFilePath = haddockCabalFilePath flags + } + +-- ------------------------------------------------------------------------------ +-- Boilerplate Monoid instance. +instance Monoid HaddockArgs where + mempty = gmempty + mappend = (<>) + +instance Semigroup HaddockArgs where + (<>) = gmappend + +instance Monoid Directory where + mempty = Dir "." + mappend = (<>) + +instance Semigroup Directory where + Dir m <> Dir n = Dir $ m n diff --git a/src/Distribution/Simple/HaskellSuite.hs b/src/Distribution/Simple/HaskellSuite.hs --- a/src/Distribution/Simple/HaskellSuite.hs +++ b/src/Distribution/Simple/HaskellSuite.hs @@ -3,39 +3,42 @@ module Distribution.Simple.HaskellSuite where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import qualified Data.List.NonEmpty as NE -import Distribution.Simple.Program -import Distribution.Simple.Compiler -import Distribution.Simple.Utils -import Distribution.Simple.BuildPaths -import Distribution.Verbosity -import Distribution.Version -import Distribution.Pretty -import Distribution.Parsec (simpleParsec) -import Distribution.Package import Distribution.InstalledPackageInfo hiding (includeDirs) -import Distribution.Simple.PackageIndex as PackageIndex +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 -import Distribution.Simple.Program.Builtin configure - :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) + :: 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 (die' verbosity msg) return mbHcPath + in maybe (dieWithException verbosity $ ProvideHaskellSuiteTool msg) return mbHcPath when (isJust hcPkgPath) $ warn verbosity "--with-hc-pkg option is ignored for haskell-suite" @@ -54,13 +57,13 @@ progdb1 return (comp, Nothing, progdb2) - where configureCompiler hcPath progdb0' = do let haskellSuiteProgram' = haskellSuiteProgram - { programFindLocation = \v p -> findProgramOnSearchPath v p hcPath } + { 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. @@ -69,19 +72,20 @@ (confdCompiler, progdb2) <- requireProgram verbosity haskellSuiteProgram' progdb1 extensions <- getExtensions verbosity confdCompiler - languages <- getLanguages 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 - } + comp = + Compiler + { compilerId = CompilerId (HaskellSuite compName) compVersion + , compilerAbiTag = NoAbiTag + , compilerCompat = [] + , compilerLanguages = languages + , compilerExtensions = extensions + , compilerProperties = mempty + } return (comp, confdCompiler, progdb2) @@ -99,58 +103,73 @@ name = concat $ safeInit parts -- there shouldn't be any spaces in the name anyway versionStr = fromMaybe "" $ safeLast parts version <- - maybe (die' verbosity "haskell-suite: couldn't determine compiler version") return $ - simpleParsec versionStr + 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"] + lines + `fmap` rawSystemStdout verbosity (programPath prog) ["--supported-extensions"] return - [ (ext, Just $ "-X" ++ prettyShow ext) | Just ext <- map simpleParsec extStrs ] + [(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"] + lines + `fmap` rawSystemStdout verbosity (programPath prog) ["--supported-languages"] return - [ (ext, "-G" ++ prettyShow ext) | Just ext <- map simpleParsec langStrs ] + [(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 -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex +getInstalledPackages + :: Verbosity + -> PackageDBStack + -> ProgramDb + -> IO InstalledPackageIndex getInstalledPackages verbosity packagedbs progdb = liftM (PackageIndex.fromList . concat) $ for packagedbs $ \packagedb -> - do str <- - getDbProgramOutput verbosity haskellSuitePkgProgram progdb - ["dump", packageDbOpt packagedb] - `catchExit` \_ -> die' verbosity $ "pkg dump failed" - case parsePackages str of - Right ok -> return ok - _ -> die' verbosity "failed to parse output of 'pkg dump'" + 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) + 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 + splitWith p xs = + ys : case zs of + [] -> [] + _ : ws -> splitWith p ws + where + (ys, zs) = break p xs buildLib - :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () + :: 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, @@ -167,28 +186,37 @@ pkgid = packageId pkg_descr runDbProgram verbosity haskellSuiteProgram progdb $ - [ "compile", "--build-dir", odir ] ++ - concat [ ["-i", d] | d <- srcDirs ] ++ - concat [ ["-I", d] | d <- [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] ++ 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 ] - - + ["compile", "--build-dir", odir] + ++ concat [["-i", d] | d <- srcDirs] + ++ concat + [ ["-I", d] + | d <- + [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + , odir + ] + ++ 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 + -> FilePath + -- ^ install location + -> FilePath + -- ^ install location for dynamic libraries + -> FilePath + -- ^ Build location -> PackageDescription -> Library -> ComponentLocalBuildInfo @@ -197,11 +225,16 @@ let progdb = withPrograms lbi runDbProgram verbosity haskellSuitePkgProgram progdb $ [ "install-library" - , "--build-dir", builtDir - , "--target-dir", targetDir - , "--dynlib-target-dir", dynlibTargetDir - , "--package-id", prettyShow $ packageId pkg - ] ++ map prettyShow (allLibModules lib clbi) + , "--build-dir" + , builtDir + , "--target-dir" + , targetDir + , "--dynlib-target-dir" + , dynlibTargetDir + , "--package-id" + , prettyShow $ packageId pkg + ] + ++ map prettyShow (allLibModules lib clbi) registerPackage :: Verbosity @@ -213,16 +246,22 @@ (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb runProgramInvocation verbosity $ - (programInvocation hspkg - ["update", packageDbOpt $ registrationPackageDB packageDbs]) - { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo } + ( programInvocation + hspkg + ["update", packageDbOpt $ registrationPackageDB packageDbs] + ) + { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo + } initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO () initPackageDB verbosity progdb dbPath = - runDbProgram verbosity haskellSuitePkgProgram progdb + runDbProgram + verbosity + haskellSuitePkgProgram + progdb ["init", dbPath] packageDbOpt :: PackageDB -> String -packageDbOpt GlobalPackageDB = "--global" -packageDbOpt UserPackageDB = "--user" +packageDbOpt GlobalPackageDB = "--global" +packageDbOpt UserPackageDB = "--user" packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ db diff --git a/src/Distribution/Simple/Hpc.hs b/src/Distribution/Simple/Hpc.hs --- a/src/Distribution/Simple/Hpc.hs +++ b/src/Distribution/Simple/Hpc.hs @@ -1,7 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Hpc -- Copyright : Thomas Tuegel 2011 @@ -13,39 +15,38 @@ -- This module provides functions for locating various HPC-related paths and -- a function for adding the necessary options to a PackageDescription to -- build test suites with HPC enabled. - module Distribution.Simple.Hpc - ( Way(..), guessWay - , htmlDir - , mixDir - , tixDir - , tixFilePath - , markupPackage - , markupTest - ) where + ( Way (..) + , guessWay + , htmlDir + , mixDir + , tixDir + , tixFilePath + , HPCMarkupInfo (..) + , markupPackage + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName -import Distribution.ModuleName ( main ) -import qualified Distribution.PackageDescription as PD +import Distribution.ModuleName (ModuleName, main) import Distribution.PackageDescription - ( Library(..) - , TestSuite(..) - , testModules - ) + ( TestSuite (..) + , testModules + ) +import qualified Distribution.PackageDescription as PD import Distribution.Pretty -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..)) import Distribution.Simple.Program - ( hpcProgram - , requireProgramVersion - ) -import Distribution.Simple.Program.Hpc ( markup, union ) -import Distribution.Simple.Utils ( notice ) -import Distribution.Version ( anyVersion ) -import Distribution.Verbosity ( Verbosity() ) -import System.Directory ( createDirectoryIfMissing, doesFileExist ) + ( hpcProgram + , requireProgramVersion + ) +import Distribution.Simple.Program.Hpc (markup, union) +import Distribution.Simple.Utils (notice) +import Distribution.Types.UnqualComponentName +import Distribution.Verbosity (Verbosity ()) +import Distribution.Version (anyVersion) +import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath -- ------------------------------------------------------------------------- @@ -54,9 +55,12 @@ data Way = Vanilla | Prof | Dyn deriving (Bounded, Enum, Eq, Read, Show) -hpcDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Directory containing component's HPC .mix files +hpcDir + :: FilePath + -- ^ \"dist/\" prefix + -> Way + -> FilePath + -- ^ Directory containing component's HPC .mix files hpcDir distPref way = distPref "hpc" wayDir where wayDir = case way of @@ -64,52 +68,40 @@ Prof -> "prof" Dyn -> "dyn" -mixDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Directory containing test suite's .mix files -mixDir distPref way name = hpcDir distPrefBuild way "mix" name - where - -- This is a hack for HPC over test suites, needed to match the directory - -- where HPC saves and reads .mix files when the main library of the same - -- package is being processed, perhaps in a previous cabal run (#5213). - -- E.g., @distPref@ may be - -- @./dist-newstyle/build/x86_64-linux/ghc-9.0.1/cabal-gh5213-0.1/t/tests@ - -- but the path where library mix files reside has two less components - -- at the end (@t/tests@) and this reduced path needs to be passed to - -- both @hpc@ and @ghc@. For non-default optimization levels, the path - -- suffix is one element longer and the extra path element needs - -- to be preserved. - distPrefElements = splitDirectories distPref - distPrefBuild = case drop (length distPrefElements - 3) distPrefElements of - ["t", _, "noopt"] -> - joinPath $ take (length distPrefElements - 3) distPrefElements - ++ ["noopt"] - ["t", _, "opt"] -> - joinPath $ take (length distPrefElements - 3) distPrefElements - ++ ["opt"] - [_, "t", _] -> - joinPath $ take (length distPrefElements - 2) distPrefElements - _ -> distPref +mixDir + :: FilePath + -- ^ \"dist/\" prefix + -> Way + -> FilePath + -- ^ Directory containing test suite's .mix files +mixDir distPref way = hpcDir distPref way "mix" -tixDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Directory containing test suite's .tix files -tixDir distPref way name = hpcDir distPref way "tix" name +tixDir + :: FilePath + -- ^ \"dist/\" prefix + -> Way + -> FilePath + -- ^ Directory containing test suite's .tix files +tixDir distPref way = hpcDir distPref way "tix" -- | Path to the .tix file containing a test suite's sum statistics. -tixFilePath :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Path to test suite's .tix file -tixFilePath distPref way name = tixDir distPref way name name <.> "tix" +tixFilePath + :: FilePath + -- ^ \"dist/\" prefix + -> Way + -> FilePath + -- ^ Component name + -> FilePath + -- ^ Path to test suite's .tix file +tixFilePath distPref way name = tixDir distPref way name <.> "tix" -htmlDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Path to test suite's HTML markup directory -htmlDir distPref way name = hpcDir distPref way "html" name +htmlDir + :: FilePath + -- ^ \"dist/\" prefix + -> Way + -> FilePath + -- ^ Path to test suite's HTML markup directory +htmlDir distPref way = hpcDir distPref way "html" -- | Attempt to guess the way the test suites in this package were compiled -- and linked with the library so the correct module interfaces are found. @@ -119,59 +111,70 @@ | withDynExe lbi = Dyn | otherwise = Vanilla --- | Generate the HTML markup for a test suite. -markupTest :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^ \"dist/\" prefix - -> String -- ^ Library name - -> TestSuite - -> Library - -> IO () -markupTest verbosity lbi distPref libraryName suite library = do - tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName' - when tixFileExists $ do - -- behaviour of 'markup' depends on version, so we need *a* version - -- but no particular one - (hpc, hpcVer, _) <- requireProgramVersion verbosity - hpcProgram anyVersion (withPrograms lbi) - let htmlDir_ = htmlDir distPref way testName' - markup hpc hpcVer verbosity - (tixFilePath distPref way testName') mixDirs - htmlDir_ - (exposedModules library) - notice verbosity $ "Test coverage report written to " - ++ htmlDir_ "hpc_index" <.> "html" - where - way = guessWay lbi - testName' = unUnqualComponentName $ testName suite - mixDirs = map (mixDir distPref way) [ testName', libraryName ] +-- | Haskell Program Coverage information required to produce a valid HPC +-- report through the `hpc markup` call for the package libraries. +data HPCMarkupInfo = HPCMarkupInfo + { pathsToLibsArtifacts :: [FilePath] + -- ^ The paths to the library components whose modules are included in the + -- coverage report + , libsModulesToInclude :: [ModuleName] + -- ^ The modules to include in the coverage report + } --- | Generate the HTML markup for all of a package's test suites. -markupPackage :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^ \"dist/\" prefix - -> PD.PackageDescription - -> [TestSuite] - -> IO () -markupPackage verbosity lbi distPref pkg_descr suites = do - let tixFiles = map (tixFilePath distPref way) testNames - tixFilesExist <- traverse doesFileExist tixFiles - when (and tixFilesExist) $ do - -- behaviour of 'markup' depends on version, so we need *a* version - -- but no particular one - (hpc, hpcVer, _) <- requireProgramVersion verbosity - hpcProgram anyVersion (withPrograms lbi) - let outFile = tixFilePath distPref way libraryName - htmlDir' = htmlDir distPref way libraryName - excluded = concatMap testModules suites ++ [ main ] - createDirectoryIfMissing True $ takeDirectory outFile - union hpc verbosity tixFiles outFile excluded - markup hpc hpcVer verbosity outFile mixDirs htmlDir' included - notice verbosity $ "Package coverage report written to " - ++ htmlDir' "hpc_index.html" +-- | Generate the HTML markup for a package's test suites. +markupPackage + :: Verbosity + -> HPCMarkupInfo + -> LocalBuildInfo + -> FilePath + -- ^ Testsuite \"dist/\" prefix + -> PD.PackageDescription + -> [TestSuite] + -> IO () +markupPackage verbosity HPCMarkupInfo{pathsToLibsArtifacts, libsModulesToInclude} lbi testDistPref pkg_descr suites = do + let tixFiles = map (tixFilePath testDistPref way) testNames + tixFilesExist <- traverse doesFileExist tixFiles + when (and tixFilesExist) $ do + -- behaviour of 'markup' depends on version, so we need *a* version + -- but no particular one + (hpc, hpcVer, _) <- + requireProgramVersion + verbosity + hpcProgram + anyVersion + (withPrograms lbi) + let htmlDir' = htmlDir testDistPref way + -- The tix file used to generate the report is either the testsuite's + -- tix file, when there is only one testsuite, or the sum of the tix + -- files of all testsuites in the package, which gets put under pkgName + -- for this component (a bit weird) + -- TODO: cabal-install should pass to Cabal where to put the summed tix + -- and report, and perhaps even the testsuites from other packages in + -- the project which are currently not accounted for in the summed + -- report. + tixFile <- case suites of + -- We call 'markupPackage' once for each testsuite to run individually, + -- to get the coverage report of just the one testsuite + [oneTest] -> do + let testName' = unUnqualComponentName $ testName oneTest + return $ + tixFilePath testDistPref way testName' + -- And call 'markupPackage' once per `test` invocation with all the + -- testsuites to run, which results in multiple tix files being considered + _ -> do + let excluded = concatMap testModules suites ++ [main] + pkgName = prettyShow $ PD.package pkg_descr + summedTixFile = tixFilePath testDistPref way pkgName + createDirectoryIfMissing True $ takeDirectory summedTixFile + union hpc verbosity tixFiles summedTixFile excluded + return summedTixFile + + markup hpc hpcVer verbosity tixFile mixDirs htmlDir' libsModulesToInclude + notice verbosity $ + "Package coverage report written to " + ++ htmlDir' + "hpc_index.html" where way = guessWay lbi testNames = fmap (unUnqualComponentName . testName) suites - mixDirs = map (mixDir distPref way) $ libraryName : testNames - included = concatMap (exposedModules) $ PD.allLibraries pkg_descr - libraryName = prettyShow $ PD.package pkg_descr + mixDirs = map (`mixDir` way) pathsToLibsArtifacts 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 @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Install -- Copyright : Isaac Jones 2003-2004 @@ -14,62 +15,87 @@ -- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into -- place based on the prefix argument. It does the generic bits and then calls -- compiler-specific functions to do the rest. - -module Distribution.Simple.Install ( - install, +module Distribution.Simple.Install + ( install ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.TargetInfo -import Distribution.Types.LocalBuildInfo +import Distribution.Types.ExecutableScope import Distribution.Types.ForeignLib +import Distribution.Types.LocalBuildInfo import Distribution.Types.PackageDescription +import Distribution.Types.TargetInfo import Distribution.Types.UnqualComponentName -import Distribution.Types.ExecutableScope import Distribution.Package import Distribution.PackageDescription -import Distribution.Simple.LocalBuildInfo import Distribution.Simple.BuildPaths (haddockName, haddockPref) +import Distribution.Simple.BuildTarget +import Distribution.Simple.Compiler + ( CompilerFlavor (..) + , compilerFlavor + ) +import Distribution.Simple.Flag + ( fromFlag + ) import Distribution.Simple.Glob (matchDirFileGlob) +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Setup.Copy + ( CopyFlags (..) + ) +import Distribution.Simple.Setup.Haddock + ( HaddockTarget (ForDevelopment) + ) import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose - , installDirectoryContents, installOrdinaryFile, isInSearchPath - , die', info, noticeNoWrap, warn ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), compilerFlavor ) -import Distribution.Simple.Setup - ( CopyFlags(..), fromFlag, HaddockTarget(ForDevelopment) ) -import Distribution.Simple.BuildTarget + ( createDirectoryIfMissingVerbose + , dieWithException + , info + , installDirectoryContents + , installOrdinaryFile + , isInSearchPath + , noticeNoWrap + , warn + ) import Distribution.Utils.Path (getSymbolicPath) -import qualified Distribution.Simple.GHC as GHC +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Simple.Errors +import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC import qualified Distribution.Simple.HaskellSuite as HaskellSuite -import Distribution.Compat.Graph (IsNode(..)) +import qualified Distribution.Simple.UHC as UHC import System.Directory - ( doesDirectoryExist, doesFileExist ) + ( doesDirectoryExist + , doesFileExist + ) import System.FilePath - ( takeFileName, takeDirectory, (), isRelative ) + ( isRelative + , takeDirectory + , takeFileName + , () + ) -import Distribution.Verbosity import Distribution.Pretty - ( prettyShow ) + ( prettyShow + ) +import Distribution.Verbosity --- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" --- actions. Move files into place based on the prefix argument. +-- | Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" +-- actions. Move files into place based on the prefix argument. -- --- This does NOT register libraries, you should call 'register' --- to do that. - -install :: PackageDescription -- ^information from the .cabal file - -> LocalBuildInfo -- ^information from the configure step - -> CopyFlags -- ^flags sent to copy or install - -> IO () +-- This does NOT register libraries, you should call 'register' +-- to do that. +install + :: PackageDescription + -- ^ information from the .cabal file + -> LocalBuildInfo + -- ^ information from the configure step + -> CopyFlags + -- ^ flags sent to copy or install + -> IO () install pkg_descr lbi flags = do checkHasLibsOrExes targets <- readTargetInfos verbosity pkg_descr lbi (copyArgs flags) @@ -80,27 +106,33 @@ withNeededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) $ \target -> let comp = targetComponent target clbi = targetCLBI target - in copyComponent verbosity pkg_descr lbi comp clbi copydest - where - distPref = fromFlag (copyDistPref flags) - verbosity = fromFlag (copyVerbosity flags) - copydest = fromFlag (copyDest flags) + in copyComponent verbosity pkg_descr lbi comp clbi copydest + where + distPref = fromFlag (copyDistPref flags) + verbosity = fromFlag (copyVerbosity flags) + copydest = fromFlag (copyDest flags) - checkHasLibsOrExes = - unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $ - die' verbosity "No executables and no library found. Nothing to do." + checkHasLibsOrExes = + unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $ + dieWithException verbosity NoLibraryFound -- | Copy package global files. -copyPackage :: Verbosity -> PackageDescription - -> LocalBuildInfo -> FilePath -> CopyDest -> IO () +copyPackage + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> FilePath + -> CopyDest + -> IO () copyPackage verbosity pkg_descr lbi distPref copydest = do - let -- This is a bit of a hack, to handle files which are not - -- per-component (data files and Haddock files.) - InstallDirs { - datadir = dataPref, - docdir = docPref, - htmldir = htmlPref, - haddockdir = interfacePref + let + -- This is a bit of a hack, to handle files which are not + -- per-component (data files and Haddock files.) + InstallDirs + { datadir = dataPref + , docdir = docPref + , htmldir = htmlPref + , haddockdir = interfacePref } = absoluteInstallCommandDirs pkg_descr lbi (localUnitId lbi) copydest -- Install (package-global) data files @@ -109,30 +141,40 @@ -- Install (package-global) Haddock files -- TODO: these should be done per-library docExists <- doesDirectoryExist $ haddockPref ForDevelopment distPref pkg_descr - info verbosity ("directory " ++ haddockPref ForDevelopment distPref pkg_descr ++ - " does exist: " ++ show docExists) + info + verbosity + ( "directory " + ++ haddockPref ForDevelopment distPref pkg_descr + ++ " does exist: " + ++ show docExists + ) -- TODO: this is a bit questionable, Haddock files really should -- be per library (when there are convenience libraries.) when docExists $ do - createDirectoryIfMissingVerbose verbosity True htmlPref - installDirectoryContents verbosity - (haddockPref ForDevelopment distPref pkg_descr) htmlPref - -- setPermissionsRecursive [Read] htmlPref - -- The haddock interface file actually already got installed - -- in the recursive copy, but now we install it where we actually - -- want it to be (normally the same place). We could remove the - -- copy in htmlPref first. - let haddockInterfaceFileSrc = haddockPref ForDevelopment distPref pkg_descr - haddockName pkg_descr - haddockInterfaceFileDest = interfacePref haddockName pkg_descr - -- We only generate the haddock interface file for libs, So if the - -- package consists only of executables there will not be one: - exists <- doesFileExist haddockInterfaceFileSrc - when exists $ do - createDirectoryIfMissingVerbose verbosity True interfacePref - installOrdinaryFile verbosity haddockInterfaceFileSrc - haddockInterfaceFileDest + createDirectoryIfMissingVerbose verbosity True htmlPref + installDirectoryContents + verbosity + (haddockPref ForDevelopment distPref pkg_descr) + htmlPref + -- setPermissionsRecursive [Read] htmlPref + -- The haddock interface file actually already got installed + -- in the recursive copy, but now we install it where we actually + -- want it to be (normally the same place). We could remove the + -- copy in htmlPref first. + let haddockInterfaceFileSrc = + haddockPref ForDevelopment distPref pkg_descr + haddockName pkg_descr + haddockInterfaceFileDest = interfacePref haddockName pkg_descr + -- We only generate the haddock interface file for libs, So if the + -- package consists only of executables there will not be one: + exists <- doesFileExist haddockInterfaceFileSrc + when exists $ do + createDirectoryIfMissingVerbose verbosity True interfacePref + installOrdinaryFile + verbosity + haddockInterfaceFileSrc + haddockInterfaceFileDest let lfiles = licenseFiles pkg_descr unless (null lfiles) $ do @@ -143,118 +185,136 @@ installOrdinaryFile verbosity lfile (docPref takeFileName lfile) -- | Copy files associated with a component. -copyComponent :: Verbosity -> PackageDescription - -> LocalBuildInfo -> Component -> ComponentLocalBuildInfo - -> CopyDest - -> IO () +copyComponent + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Component + -> ComponentLocalBuildInfo + -> CopyDest + -> IO () copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do - let InstallDirs{ - libdir = libPref, - dynlibdir = dynlibPref, - includedir = incPref - } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest - buildPref = componentBuildDir lbi clbi - - case libName lib of - LMainLibName -> noticeNoWrap verbosity ("Installing library in " ++ libPref) - LSubLibName n -> noticeNoWrap verbosity ("Installing internal library " ++ prettyShow n ++ " in " ++ libPref) + let InstallDirs + { libdir = libPref + , dynlibdir = dynlibPref + , includedir = incPref + } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest + buildPref = componentBuildDir lbi clbi - -- install include files for all compilers - they may be needed to compile - -- haskell files (using the CPP extension) - installIncludeFiles verbosity (libBuildInfo lib) lbi buildPref incPref + case libName lib of + LMainLibName -> noticeNoWrap verbosity ("Installing library in " ++ libPref) + LSubLibName n -> noticeNoWrap verbosity ("Installing internal library " ++ prettyShow n ++ " in " ++ libPref) - 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 - _ -> die' verbosity $ "installing with " - ++ prettyShow (compilerFlavor (compiler lbi)) - ++ " is not implemented" + -- install include files for all compilers - they may be needed to compile + -- haskell files (using the CPP extension) + 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 + _ -> + dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do - let InstallDirs{ - flibdir = flibPref, - includedir = incPref - } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest - buildPref = componentBuildDir lbi clbi - - noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref) - installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref + let InstallDirs + { flibdir = flibPref + , includedir = incPref + } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest + buildPref = componentBuildDir lbi clbi - case compilerFlavor (compiler lbi) of - GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib - GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib - _ -> die' verbosity $ "installing foreign lib with " - ++ prettyShow (compilerFlavor (compiler lbi)) - ++ " is not implemented" + noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref) + installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref + case compilerFlavor (compiler lbi) of + GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib + GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib + _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do - let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest - -- the installers know how to find the actual location of the - -- binaries - buildPref = buildDir lbi - uid = componentUnitId clbi - pkgid = packageId pkg_descr - binPref | ExecutablePrivate <- exeScope exe = libexecdir installDirs - | otherwise = bindir installDirs - progPrefixPref = substPathTemplate pkgid lbi uid (progPrefix lbi) - progSuffixPref = substPathTemplate pkgid lbi uid (progSuffix lbi) - progFix = (progPrefixPref, progSuffixPref) - noticeNoWrap verbosity ("Installing executable " ++ prettyShow (exeName exe) - ++ " in " ++ binPref) - inPath <- isInSearchPath binPref - when (not inPath) $ - warn verbosity ("The directory " ++ binPref - ++ " is not in the system search path.") - case compilerFlavor (compiler lbi) of - GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe - GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe - UHC -> return () - HaskellSuite {} -> return () - _ -> die' verbosity $ "installing with " - ++ prettyShow (compilerFlavor (compiler lbi)) - ++ " is not implemented" + let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest + -- the installers know how to find the actual location of the + -- binaries + buildPref = buildDir lbi + uid = componentUnitId clbi + pkgid = packageId pkg_descr + binPref + | ExecutablePrivate <- exeScope exe = libexecdir installDirs + | otherwise = bindir installDirs + progPrefixPref = substPathTemplate pkgid lbi uid (progPrefix lbi) + progSuffixPref = substPathTemplate pkgid lbi uid (progSuffix lbi) + progFix = (progPrefixPref, progSuffixPref) + noticeNoWrap + verbosity + ( "Installing executable " + ++ prettyShow (exeName exe) + ++ " in " + ++ binPref + ) + inPath <- isInSearchPath binPref + when (not inPath) $ + warn + verbosity + ( "The directory " + ++ binPref + ++ " is not in the system search path." + ) + case compilerFlavor (compiler lbi) of + GHC -> GHC.installExe verbosity lbi 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)) -- Nothing to do for benchmark/testsuite copyComponent _ _ _ (CBench _) _ _ = return () copyComponent _ _ _ (CTest _) _ _ = return () -- | Install the files listed in data-files --- installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO () installDataFiles verbosity pkg_descr destDataDir = - flip traverse_ (dataFiles pkg_descr) $ \ glob -> do + flip traverse_ (dataFiles pkg_descr) $ \glob -> do let srcDataDirRaw = dataDir pkg_descr - srcDataDir = if null srcDataDirRaw - then "." - else srcDataDirRaw + srcDataDir = + if null srcDataDirRaw + then "." + else srcDataDirRaw files <- matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir glob - for_ files $ \ file' -> do + for_ files $ \file' -> do let src = srcDataDir file' dst = destDataDir file' createDirectoryIfMissingVerbose verbosity True (takeDirectory dst) installOrdinaryFile verbosity src dst -- | Install the files listed in install-includes for a library --- installIncludeFiles :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO () installIncludeFiles verbosity libBi lbi buildPref destIncludeDir = do - let relincdirs = "." : filter isRelative (includeDirs libBi) - incdirs = [ baseDir lbi dir | dir <- relincdirs ] - ++ [ buildPref dir | dir <- relincdirs ] - incs <- traverse (findInc incdirs) (installIncludes libBi) - sequence_ - [ do createDirectoryIfMissingVerbose verbosity True destDir - installOrdinaryFile verbosity srcFile destFile - | (relFile, srcFile) <- incs - , let destFile = destIncludeDir relFile - destDir = takeDirectory destFile ] + let relincdirs = "." : filter isRelative (includeDirs libBi) + incdirs = + [baseDir lbi dir | dir <- relincdirs] + ++ [buildPref dir | dir <- relincdirs] + incs <- traverse (findInc incdirs) (installIncludes libBi) + sequence_ + [ do + createDirectoryIfMissingVerbose verbosity True destDir + installOrdinaryFile verbosity srcFile destFile + | (relFile, srcFile) <- incs + , let destFile = destIncludeDir relFile + destDir = takeDirectory destFile + ] where - baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath lbi') - findInc [] file = die' verbosity ("can't find include file " ++ file) - findInc (dir:dirs) file = do - let path = dir file - exists <- doesFileExist path - if exists then return (file, path) else findInc dirs file + baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath 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 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 @@ -6,6 +6,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.InstallDirs -- Copyright : Isaac Jones 2003-2004 @@ -22,48 +23,49 @@ -- changing the prefix all other dirs still end up changed appropriately. So it -- provides a 'PathTemplate' type and functions for substituting for these -- templates. - -module Distribution.Simple.InstallDirs ( - InstallDirs(..), - InstallDirTemplates, - defaultInstallDirs, - defaultInstallDirs', - combineInstallDirs, - absoluteInstallDirs, - CopyDest(..), - prefixRelativeInstallDirs, - substituteInstallDirTemplates, - - PathTemplate, - PathTemplateVariable(..), - PathTemplateEnv, - toPathTemplate, - fromPathTemplate, - combinePathTemplate, - substPathTemplate, - initialPathTemplateEnv, - platformTemplateEnv, - compilerTemplateEnv, - packageTemplateEnv, - abiTemplateEnv, - installDirsTemplateEnv, +module Distribution.Simple.InstallDirs + ( InstallDirs (..) + , InstallDirTemplates + , defaultInstallDirs + , defaultInstallDirs' + , combineInstallDirs + , absoluteInstallDirs + , CopyDest (..) + , prefixRelativeInstallDirs + , substituteInstallDirTemplates + , PathTemplate + , PathTemplateVariable (..) + , PathTemplateEnv + , toPathTemplate + , fromPathTemplate + , combinePathTemplate + , substPathTemplate + , initialPathTemplateEnv + , platformTemplateEnv + , compilerTemplateEnv + , packageTemplateEnv + , abiTemplateEnv + , installDirsTemplateEnv ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Compat.Environment (lookupEnv) -import Distribution.Pretty -import Distribution.Package -import Distribution.System import Distribution.Compiler +import Distribution.Package +import Distribution.Pretty import Distribution.Simple.InstallDirs.Internal +import Distribution.System import System.Directory (getAppUserDataDirectory) import System.FilePath - ( (), isPathSeparator - , pathSeparator, dropDrive - , takeDirectory ) + ( dropDrive + , isPathSeparator + , pathSeparator + , takeDirectory + , () + ) #ifdef mingw32_HOST_OS import qualified Prelude @@ -74,32 +76,32 @@ -- --------------------------------------------------------------------------- -- Installation directories - -- | The directories where we will install files for packages. -- -- We have several different directories for different types of files since -- many systems have conventions whereby different types of files in a package -- are installed in different directories. This is particularly the case on -- Unix style systems. --- -data InstallDirs dir = InstallDirs { - prefix :: dir, - bindir :: dir, - libdir :: dir, - libsubdir :: dir, - dynlibdir :: dir, - flibdir :: dir, -- ^ foreign libraries - libexecdir :: dir, - libexecsubdir:: dir, - includedir :: dir, - datadir :: dir, - datasubdir :: dir, - docdir :: dir, - mandir :: dir, - htmldir :: dir, - haddockdir :: dir, - sysconfdir :: dir - } deriving (Eq, Read, Show, Functor, Generic, Typeable) +data InstallDirs dir = InstallDirs + { prefix :: dir + , bindir :: dir + , libdir :: dir + , libsubdir :: dir + , dynlibdir :: dir + , flibdir :: dir + -- ^ foreign libraries + , libexecdir :: dir + , libexecsubdir :: dir + , includedir :: dir + , datadir :: dir + , datasubdir :: dir + , docdir :: dir + , mandir :: dir + , htmldir :: dir + , haddockdir :: dir + , sysconfdir :: dir + } + deriving (Eq, Read, Show, Functor, Generic, Typeable) instance Binary dir => Binary (InstallDirs dir) instance Structured dir => Structured (InstallDirs dir) @@ -111,38 +113,41 @@ instance Semigroup dir => Semigroup (InstallDirs dir) where (<>) = gmappend -combineInstallDirs :: (a -> b -> c) - -> InstallDirs a - -> InstallDirs b - -> InstallDirs c -combineInstallDirs combine a b = InstallDirs { - prefix = prefix a `combine` prefix b, - bindir = bindir a `combine` bindir b, - libdir = libdir a `combine` libdir b, - libsubdir = libsubdir a `combine` libsubdir b, - dynlibdir = dynlibdir a `combine` dynlibdir b, - flibdir = flibdir a `combine` flibdir b, - libexecdir = libexecdir a `combine` libexecdir b, - libexecsubdir= libexecsubdir a `combine` libexecsubdir b, - includedir = includedir a `combine` includedir b, - datadir = datadir a `combine` datadir b, - datasubdir = datasubdir a `combine` datasubdir b, - docdir = docdir a `combine` docdir b, - mandir = mandir a `combine` mandir b, - htmldir = htmldir a `combine` htmldir b, - haddockdir = haddockdir a `combine` haddockdir b, - sysconfdir = sysconfdir a `combine` sysconfdir b - } +combineInstallDirs + :: (a -> b -> c) + -> InstallDirs a + -> InstallDirs b + -> InstallDirs c +combineInstallDirs combine a b = + InstallDirs + { prefix = prefix a `combine` prefix b + , bindir = bindir a `combine` bindir b + , libdir = libdir a `combine` libdir b + , libsubdir = libsubdir a `combine` libsubdir b + , dynlibdir = dynlibdir a `combine` dynlibdir b + , flibdir = flibdir a `combine` flibdir b + , libexecdir = libexecdir a `combine` libexecdir b + , libexecsubdir = libexecsubdir a `combine` libexecsubdir b + , includedir = includedir a `combine` includedir b + , datadir = datadir a `combine` datadir b + , datasubdir = datasubdir a `combine` datasubdir b + , docdir = docdir a `combine` docdir b + , mandir = mandir a `combine` mandir b + , htmldir = htmldir a `combine` htmldir b + , haddockdir = haddockdir a `combine` haddockdir b + , sysconfdir = sysconfdir a `combine` sysconfdir b + } appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a -appendSubdirs append dirs = dirs { - libdir = libdir dirs `append` libsubdir dirs, - libexecdir = libexecdir dirs `append` libexecsubdir dirs, - datadir = datadir dirs `append` datasubdir dirs, - libsubdir = error "internal error InstallDirs.libsubdir", - libexecsubdir = error "internal error InstallDirs.libexecsubdir", - datasubdir = error "internal error InstallDirs.datasubdir" - } +appendSubdirs append dirs = + dirs + { libdir = libdir dirs `append` libsubdir dirs + , libexecdir = libexecdir dirs `append` libexecsubdir dirs + , datadir = datadir dirs `append` datasubdir dirs + , libsubdir = error "internal error InstallDirs.libsubdir" + , libexecsubdir = error "internal error InstallDirs.libexecsubdir" + , datasubdir = error "internal error InstallDirs.datasubdir" + } -- | The installation directories in terms of 'PathTemplate's that contain -- variables. @@ -165,7 +170,6 @@ -- -- An additional complication is the need to support relocatable packages on -- systems which support such things, like Windows. --- type InstallDirTemplates = InstallDirs PathTemplate -- --------------------------------------------------------------------------- @@ -174,56 +178,77 @@ defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates defaultInstallDirs = defaultInstallDirs' False -defaultInstallDirs' :: Bool {- use external internal deps -} - -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates +defaultInstallDirs' + :: Bool {- use external internal deps -} + -> CompilerFlavor + -> Bool + -> Bool + -> IO InstallDirTemplates defaultInstallDirs' True comp userInstall hasLibs = do dflt <- defaultInstallDirs' False comp userInstall hasLibs -- Be a bit more hermetic about per-component installs - return dflt { datasubdir = toPathTemplate $ "$abi" "$libname", - docdir = toPathTemplate $ "$datadir" "doc" "$abi" "$libname" - } + return + dflt + { datasubdir = toPathTemplate $ "$abi" "$libname" + , docdir = toPathTemplate $ "$datadir" "doc" "$abi" "$libname" + } defaultInstallDirs' False comp userInstall _hasLibs = do installPrefix <- - if userInstall + if userInstall then do mDir <- lookupEnv "CABAL_DIR" case mDir of Nothing -> getAppUserDataDirectory "cabal" Just dir -> return dir else case buildOS of - Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir - return (windowsProgramFilesDir "Haskell") - _ -> return "/usr/local" + Windows -> do + windowsProgramFilesDir <- getWindowsProgramFilesDir + return (windowsProgramFilesDir "Haskell") + Haiku -> return "/boot/system/non-packaged" + _ -> return "/usr/local" installLibDir <- - case buildOS of + case buildOS of Windows -> return "$prefix" - _ -> return ("$prefix" "lib") - return $ fmap toPathTemplate $ InstallDirs { - prefix = installPrefix, - bindir = "$prefix" "bin", - libdir = installLibDir, - libsubdir = case comp of - UHC -> "$pkgid" - _other -> "$abi" "$libname", - dynlibdir = "$libdir" case comp of - UHC -> "$pkgid" - _other -> "$abi", - libexecsubdir= "$abi" "$pkgid", - flibdir = "$libdir", - libexecdir = case buildOS of - Windows -> "$prefix" "$libname" - _other -> "$prefix" "libexec", - includedir = "$libdir" "$libsubdir" "include", - datadir = case buildOS of - Windows -> "$prefix" - _other -> "$prefix" "share", - datasubdir = "$abi" "$pkgid", - docdir = "$datadir" "doc" "$abi" "$pkgid", - mandir = "$datadir" "man", - htmldir = "$docdir" "html", - haddockdir = "$htmldir", - sysconfdir = "$prefix" "etc" - } + _ -> return ("$prefix" "lib") + return $ + fmap toPathTemplate $ + InstallDirs + { prefix = installPrefix + , bindir = "$prefix" "bin" + , libdir = installLibDir + , libsubdir = case comp of + UHC -> "$pkgid" + _other -> "$abi" "$libname" + , dynlibdir = + "$libdir" case comp of + UHC -> "$pkgid" + _other -> "$abi" + , libexecsubdir = "$abi" "$pkgid" + , flibdir = "$libdir" + , libexecdir = case buildOS of + Windows -> "$prefix" "$libname" + Haiku -> "$libdir" + _other -> "$prefix" "libexec" + , includedir = case buildOS of + Haiku -> "$prefix" "develop" "headers" + _other -> "$libdir" "$libsubdir" "include" + , datadir = case buildOS of + Windows -> "$prefix" + Haiku -> "$prefix" "data" + _other -> "$prefix" "share" + , datasubdir = "$abi" "$pkgid" + , docdir = case buildOS of + Haiku -> "$prefix" "documentation" + _other -> "$datadir" "doc" "$abi" "$pkgid" + , mandir = case buildOS of + Haiku -> "$docdir" "man" + _other -> "$datadir" "man" + , htmldir = "$docdir" "html" + , haddockdir = "$htmldir" + , sysconfdir = case buildOS of + Haiku -> "boot" "system" "settings" + _other -> "$prefix" "etc" + } -- --------------------------------------------------------------------------- -- Converting directories, absolute or prefix-relative @@ -239,102 +264,111 @@ -- can replace 'prefix' with the 'PrefixVar' and get resulting -- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it -- each to check which paths are relative to the $prefix. --- -substituteInstallDirTemplates :: PathTemplateEnv - -> InstallDirTemplates -> InstallDirTemplates +substituteInstallDirTemplates + :: PathTemplateEnv + -> InstallDirTemplates + -> InstallDirTemplates substituteInstallDirTemplates env dirs = dirs' where - dirs' = InstallDirs { - -- So this specifies exactly which vars are allowed in each template - prefix = subst prefix [], - bindir = subst bindir [prefixVar], - libdir = subst libdir [prefixVar, bindirVar], - libsubdir = subst libsubdir [], - dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar], - flibdir = subst flibdir [prefixVar, bindirVar, libdirVar], - libexecdir = subst libexecdir prefixBinLibVars, - libexecsubdir = subst libexecsubdir [], - includedir = subst includedir prefixBinLibVars, - datadir = subst datadir prefixBinLibVars, - datasubdir = subst datasubdir [], - docdir = subst docdir prefixBinLibDataVars, - mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]), - htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]), - haddockdir = subst haddockdir (prefixBinLibDataVars ++ - [docdirVar, htmldirVar]), - sysconfdir = subst sysconfdir prefixBinLibVars - } - subst dir env' = substPathTemplate (env'++env) (dir dirs) + dirs' = + InstallDirs + { -- So this specifies exactly which vars are allowed in each template + prefix = subst prefix [] + , bindir = subst bindir [prefixVar] + , libdir = subst libdir [prefixVar, bindirVar] + , libsubdir = subst libsubdir [] + , dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar] + , flibdir = subst flibdir [prefixVar, bindirVar, libdirVar] + , libexecdir = subst libexecdir prefixBinLibVars + , libexecsubdir = subst libexecsubdir [] + , includedir = subst includedir prefixBinLibVars + , datadir = subst datadir prefixBinLibVars + , datasubdir = subst datasubdir [] + , docdir = subst docdir prefixBinLibDataVars + , mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]) + , htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]) + , haddockdir = + subst + haddockdir + ( prefixBinLibDataVars + ++ [docdirVar, htmldirVar] + ) + , sysconfdir = subst sysconfdir prefixBinLibVars + } + subst dir env' = substPathTemplate (env' ++ env) (dir dirs) - prefixVar = (PrefixVar, prefix dirs') - bindirVar = (BindirVar, bindir dirs') - libdirVar = (LibdirVar, libdir dirs') - libsubdirVar = (LibsubdirVar, libsubdir dirs') - datadirVar = (DatadirVar, datadir dirs') - datasubdirVar = (DatasubdirVar, datasubdir dirs') - docdirVar = (DocdirVar, docdir dirs') - htmldirVar = (HtmldirVar, htmldir dirs') + prefixVar = (PrefixVar, prefix dirs') + bindirVar = (BindirVar, bindir dirs') + libdirVar = (LibdirVar, libdir dirs') + libsubdirVar = (LibsubdirVar, libsubdir dirs') + datadirVar = (DatadirVar, datadir dirs') + datasubdirVar = (DatasubdirVar, datasubdir dirs') + docdirVar = (DocdirVar, docdir dirs') + htmldirVar = (HtmldirVar, htmldir dirs') prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] -- | Convert from abstract install directories to actual absolute ones by -- substituting for all the variables in the abstract paths, to get real -- absolute path. -absoluteInstallDirs :: PackageIdentifier - -> UnitId - -> CompilerInfo - -> CopyDest - -> Platform - -> InstallDirs PathTemplate - -> InstallDirs FilePath +absoluteInstallDirs + :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> CopyDest + -> Platform + -> InstallDirs PathTemplate + -> InstallDirs FilePath absoluteInstallDirs pkgId libname compilerId copydest platform dirs = - (case copydest of - CopyTo destdir -> fmap ((destdir ) . dropDrive) - CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir)) - _ -> id) - . appendSubdirs () - . fmap fromPathTemplate - $ substituteInstallDirTemplates env dirs + ( case copydest of + CopyTo destdir -> fmap ((destdir ) . dropDrive) + CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir)) + _ -> id + ) + . appendSubdirs () + . fmap fromPathTemplate + $ substituteInstallDirTemplates env dirs where env = initialPathTemplateEnv pkgId libname compilerId platform substPrefix pre root path | pre `isPrefixOf` path = root ++ drop (length pre) path - | otherwise = path - + | otherwise = path --- |The location prefix for the /copy/ command. +-- | The location prefix for the /copy/ command. data CopyDest = NoCopyDest | CopyTo FilePath - | CopyToDb FilePath - -- ^ when using the ${pkgroot} as prefix. The CopyToDb will - -- adjust the paths to be relative to the provided package - -- database when copying / installing. + | -- | when using the ${pkgroot} as prefix. The CopyToDb will + -- adjust the paths to be relative to the provided package + -- database when copying / installing. + CopyToDb FilePath deriving (Eq, Show, Generic) instance Binary CopyDest +instance Structured CopyDest -- | Check which of the paths are relative to the installation $prefix. -- -- If any of the paths are not relative, ie they are absolute paths, then it -- prevents us from making a relocatable package (also known as a \"prefix -- independent\" package). --- -prefixRelativeInstallDirs :: PackageIdentifier - -> UnitId - -> CompilerInfo - -> Platform - -> InstallDirTemplates - -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs + :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> Platform + -> InstallDirTemplates + -> InstallDirs (Maybe FilePath) prefixRelativeInstallDirs pkgId libname compilerId platform dirs = - fmap relative - . appendSubdirs combinePathTemplate - $ -- substitute the path template into each other, except that we map + fmap relative + . appendSubdirs combinePathTemplate + $ substituteInstallDirTemplates -- substitute the path template into each other, except that we map -- \$prefix back to $prefix. We're trying to end up with templates that -- mention no vars except $prefix. - substituteInstallDirTemplates env dirs { - prefix = PathTemplate [Variable PrefixVar] - } + env + dirs + { prefix = PathTemplate [Variable PrefixVar] + } where env = initialPathTemplateEnv pkgId libname compilerId platform @@ -342,17 +376,16 @@ -- path by stripping off $prefix/ or $prefix relative dir = case dir of PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) - relative' (Variable PrefixVar : Ordinary (s:rest) : rest') - | isPathSeparator s = Just (Ordinary rest : rest') + relative' (Variable PrefixVar : Ordinary (s : rest) : rest') + | isPathSeparator s = Just (Ordinary rest : rest') relative' (Variable PrefixVar : rest) = Just rest - relative' _ = Nothing + relative' _ = Nothing -- --------------------------------------------------------------------------- -- Path templates -- | An abstract path, possibly containing variables that need to be -- substituted for to get a real 'FilePath'. --- newtype PathTemplate = PathTemplate [PathComponent] deriving (Eq, Ord, Generic, Typeable) @@ -362,15 +395,14 @@ type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] -- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. --- toPathTemplate :: FilePath -> PathTemplate -toPathTemplate fp = PathTemplate +toPathTemplate fp = + PathTemplate . fromMaybe (error $ "panic! toPathTemplate " ++ show fp) . readMaybe -- TODO: eradicateNoParse $ fp -- | Convert back to a path, any remaining vars are included --- fromPathTemplate :: PathTemplate -> FilePath fromPathTemplate (PathTemplate template) = show template @@ -380,71 +412,80 @@ substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate substPathTemplate environment (PathTemplate template) = - PathTemplate (concatMap subst template) - - where subst component@(Ordinary _) = [component] - subst component@(Variable variable) = - case lookup variable environment of - Just (PathTemplate components) -> components - Nothing -> [component] + PathTemplate (concatMap subst template) + where + subst component@(Ordinary _) = [component] + subst component@(Variable variable) = + case lookup variable environment of + Just (PathTemplate components) -> components + Nothing -> [component] -- | The initial environment has all the static stuff but no paths -initialPathTemplateEnv :: PackageIdentifier - -> UnitId - -> CompilerInfo - -> Platform - -> PathTemplateEnv +initialPathTemplateEnv + :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> Platform + -> PathTemplateEnv initialPathTemplateEnv pkgId libname compiler platform = - packageTemplateEnv pkgId libname - ++ compilerTemplateEnv compiler - ++ platformTemplateEnv platform - ++ abiTemplateEnv compiler platform + packageTemplateEnv pkgId libname + ++ compilerTemplateEnv compiler + ++ platformTemplateEnv platform + ++ abiTemplateEnv compiler platform packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv packageTemplateEnv pkgId uid = - [(PkgNameVar, PathTemplate [Ordinary $ prettyShow (packageName pkgId)]) - ,(PkgVerVar, PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)]) - -- Invariant: uid is actually a HashedUnitId. Hard to enforce because - -- it's an API change. - ,(LibNameVar, PathTemplate [Ordinary $ prettyShow uid]) - ,(PkgIdVar, PathTemplate [Ordinary $ prettyShow pkgId]) + [ (PkgNameVar, PathTemplate [Ordinary $ prettyShow (packageName pkgId)]) + , (PkgVerVar, PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)]) + , -- Invariant: uid is actually a HashedUnitId. Hard to enforce because + -- it's an API change. + (LibNameVar, PathTemplate [Ordinary $ prettyShow uid]) + , (PkgIdVar, PathTemplate [Ordinary $ prettyShow pkgId]) ] compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv compilerTemplateEnv compiler = - [(CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)]) + [ (CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)]) ] platformTemplateEnv :: Platform -> PathTemplateEnv platformTemplateEnv (Platform arch os) = - [(OSVar, PathTemplate [Ordinary $ prettyShow os]) - ,(ArchVar, PathTemplate [Ordinary $ prettyShow arch]) + [ (OSVar, PathTemplate [Ordinary $ prettyShow os]) + , (ArchVar, PathTemplate [Ordinary $ prettyShow arch]) ] abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv abiTemplateEnv compiler (Platform arch os) = - [(AbiVar, PathTemplate [Ordinary $ prettyShow arch ++ '-':prettyShow os ++ - '-':prettyShow (compilerInfoId compiler) ++ - case compilerInfoAbiTag compiler of - NoAbiTag -> "" - AbiTag tag -> '-':tag]) - ,(AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)]) + [ + ( AbiVar + , PathTemplate + [ Ordinary $ + prettyShow arch + ++ '-' + : prettyShow os + ++ '-' + : prettyShow (compilerInfoId compiler) + ++ case compilerInfoAbiTag compiler of + NoAbiTag -> "" + AbiTag tag -> '-' : tag + ] + ) + , (AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)]) ] installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv installDirsTemplateEnv dirs = - [(PrefixVar, prefix dirs) - ,(BindirVar, bindir dirs) - ,(LibdirVar, libdir dirs) - ,(LibsubdirVar, libsubdir dirs) - ,(DynlibdirVar, dynlibdir dirs) - ,(DatadirVar, datadir dirs) - ,(DatasubdirVar, datasubdir dirs) - ,(DocdirVar, docdir dirs) - ,(HtmldirVar, htmldir dirs) + [ (PrefixVar, prefix dirs) + , (BindirVar, bindir dirs) + , (LibdirVar, libdir dirs) + , (LibsubdirVar, libsubdir dirs) + , (DynlibdirVar, dynlibdir dirs) + , (DatadirVar, datadir dirs) + , (DatasubdirVar, datasubdir dirs) + , (DocdirVar, docdir dirs) + , (HtmldirVar, htmldir dirs) ] - -- --------------------------------------------------------------------------- -- Parsing and showing path templates: @@ -458,13 +499,16 @@ show (PathTemplate template) = show (show template) instance Read PathTemplate where - readsPrec p s = [ (PathTemplate template, s') - | (path, s') <- readsPrec p s - , (template, "") <- reads path ] + readsPrec p s = + [ (PathTemplate template, s') + | (path, s') <- readsPrec p s + , (template, "") <- reads path + ] -- --------------------------------------------------------------------------- -- Internal utilities +{- FOURMOLU_DISABLE -} getWindowsProgramFilesDir :: IO FilePath getWindowsProgramFilesDir = do #ifdef mingw32_HOST_OS @@ -473,6 +517,7 @@ let m = Nothing #endif return (fromMaybe "C:\\Program Files" m) +{- FOURMOLU_ENABLE -} #ifdef mingw32_HOST_OS shGetFolderPath :: CInt -> IO (Maybe FilePath) @@ -490,6 +535,7 @@ -- csidl_PROGRAM_FILES_COMMON :: CInt -- csidl_PROGRAM_FILES_COMMON = 0x002b +{- FOURMOLU_DISABLE -} #ifdef x86_64_HOST_ARCH #define CALLCONV ccall #else @@ -504,3 +550,4 @@ -> CWString -> Prelude.IO CInt #endif +{- FOURMOLU_ENABLE -} 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 @@ -1,127 +1,160 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} + module Distribution.Simple.InstallDirs.Internal - ( PathComponent(..) - , PathTemplateVariable(..) + ( PathComponent (..) + , PathTemplateVariable (..) ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -data PathComponent = - Ordinary FilePath - | Variable PathTemplateVariable - deriving (Eq, Ord, Generic, Typeable) +data PathComponent + = Ordinary FilePath + | Variable PathTemplateVariable + deriving (Eq, Ord, Generic, Typeable) instance Binary PathComponent instance Structured PathComponent -data PathTemplateVariable = - PrefixVar -- ^ The @$prefix@ path variable - | BindirVar -- ^ The @$bindir@ path variable - | LibdirVar -- ^ The @$libdir@ path variable - | LibsubdirVar -- ^ The @$libsubdir@ path variable - | DynlibdirVar -- ^ The @$dynlibdir@ path variable - | DatadirVar -- ^ The @$datadir@ path variable - | DatasubdirVar -- ^ The @$datasubdir@ path variable - | DocdirVar -- ^ The @$docdir@ path variable - | HtmldirVar -- ^ The @$htmldir@ path variable - | PkgNameVar -- ^ The @$pkg@ package name path variable - | PkgVerVar -- ^ The @$version@ package version path variable - | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@ - | LibNameVar -- ^ The @$libname@ path variable - | CompilerVar -- ^ The compiler name and version, eg @ghc-6.6.1@ - | OSVar -- ^ The operating system name, eg @windows@ or @linux@ - | ArchVar -- ^ The CPU architecture name, eg @i386@ or @x86_64@ - | AbiVar -- ^ The compiler's ABI identifier, - --- $arch-$os-$compiler-$abitag - | AbiTagVar -- ^ The optional ABI tag for the compiler - | ExecutableNameVar -- ^ The executable name; used in shell wrappers - | TestSuiteNameVar -- ^ The name of the test suite being run - | TestSuiteResultVar -- ^ The result of the test suite being run, eg - -- @pass@, @fail@, or @error@. - | BenchmarkNameVar -- ^ The name of the benchmark being run +data PathTemplateVariable + = -- | The @$prefix@ path variable + PrefixVar + | -- | The @$bindir@ path variable + BindirVar + | -- | The @$libdir@ path variable + LibdirVar + | -- | The @$libsubdir@ path variable + LibsubdirVar + | -- | The @$dynlibdir@ path variable + DynlibdirVar + | -- | The @$datadir@ path variable + DatadirVar + | -- | The @$datasubdir@ path variable + DatasubdirVar + | -- | The @$docdir@ path variable + DocdirVar + | -- | The @$htmldir@ path variable + HtmldirVar + | -- | The @$pkg@ package name path variable + PkgNameVar + | -- | The @$version@ package version path variable + PkgVerVar + | -- | The @$pkgid@ package Id path variable, eg @foo-1.0@ + PkgIdVar + | -- | The @$libname@ path variable + LibNameVar + | -- | The compiler name and version, eg @ghc-6.6.1@ + CompilerVar + | -- | The operating system name, eg @windows@ or @linux@ + OSVar + | -- | The CPU architecture name, eg @i386@ or @x86_64@ + ArchVar + | -- | The compiler's ABI identifier, + AbiVar + | --- $arch-$os-$compiler-$abitag + + -- | The optional ABI tag for the compiler + AbiTagVar + | -- | The executable name; used in shell wrappers + ExecutableNameVar + | -- | The name of the test suite being run + TestSuiteNameVar + | -- | The result of the test suite being run, eg + -- @pass@, @fail@, or @error@. + TestSuiteResultVar + | -- | The name of the benchmark being run + BenchmarkNameVar deriving (Eq, Ord, Generic, Typeable) instance Binary PathTemplateVariable instance Structured PathTemplateVariable instance Show PathTemplateVariable where - show PrefixVar = "prefix" - show LibNameVar = "libname" - show BindirVar = "bindir" - show LibdirVar = "libdir" - show LibsubdirVar = "libsubdir" - show DynlibdirVar = "dynlibdir" - show DatadirVar = "datadir" + show PrefixVar = "prefix" + show LibNameVar = "libname" + show BindirVar = "bindir" + show LibdirVar = "libdir" + show LibsubdirVar = "libsubdir" + show DynlibdirVar = "dynlibdir" + show DatadirVar = "datadir" show DatasubdirVar = "datasubdir" - show DocdirVar = "docdir" - show HtmldirVar = "htmldir" - show PkgNameVar = "pkg" - show PkgVerVar = "version" - show PkgIdVar = "pkgid" - show CompilerVar = "compiler" - show OSVar = "os" - show ArchVar = "arch" - show AbiTagVar = "abitag" - show AbiVar = "abi" + show DocdirVar = "docdir" + show HtmldirVar = "htmldir" + show PkgNameVar = "pkg" + show PkgVerVar = "version" + show PkgIdVar = "pkgid" + show CompilerVar = "compiler" + show OSVar = "os" + show ArchVar = "arch" + show AbiTagVar = "abitag" + show AbiVar = "abi" show ExecutableNameVar = "executablename" - show TestSuiteNameVar = "test-suite" + show TestSuiteNameVar = "test-suite" show TestSuiteResultVar = "result" - show BenchmarkNameVar = "benchmark" + show BenchmarkNameVar = "benchmark" instance Read PathTemplateVariable where readsPrec _ s = - take 1 - [ (var, drop (length varStr) s) - | (varStr, var) <- vars - , varStr `isPrefixOf` s ] - -- NB: order matters! Longer strings first - where vars = [("prefix", PrefixVar) - ,("bindir", BindirVar) - ,("libdir", LibdirVar) - ,("libsubdir", LibsubdirVar) - ,("dynlibdir", DynlibdirVar) - ,("datadir", DatadirVar) - ,("datasubdir", DatasubdirVar) - ,("docdir", DocdirVar) - ,("htmldir", HtmldirVar) - ,("pkgid", PkgIdVar) - ,("libname", LibNameVar) - ,("pkgkey", LibNameVar) -- backwards compatibility - ,("pkg", PkgNameVar) - ,("version", PkgVerVar) - ,("compiler", CompilerVar) - ,("os", OSVar) - ,("arch", ArchVar) - ,("abitag", AbiTagVar) - ,("abi", AbiVar) - ,("executablename", ExecutableNameVar) - ,("test-suite", TestSuiteNameVar) - ,("result", TestSuiteResultVar) - ,("benchmark", BenchmarkNameVar)] + take + 1 + [ (var, drop (length varStr) s) + | (varStr, var) <- vars + , varStr `isPrefixOf` s + ] + where + -- NB: order matters! Longer strings first + vars = + [ ("prefix", PrefixVar) + , ("bindir", BindirVar) + , ("libdir", LibdirVar) + , ("libsubdir", LibsubdirVar) + , ("dynlibdir", DynlibdirVar) + , ("datadir", DatadirVar) + , ("datasubdir", DatasubdirVar) + , ("docdir", DocdirVar) + , ("htmldir", HtmldirVar) + , ("pkgid", PkgIdVar) + , ("libname", LibNameVar) + , ("pkgkey", LibNameVar) -- backwards compatibility + , ("pkg", PkgNameVar) + , ("version", PkgVerVar) + , ("compiler", CompilerVar) + , ("os", OSVar) + , ("arch", ArchVar) + , ("abitag", AbiTagVar) + , ("abi", AbiVar) + , ("executablename", ExecutableNameVar) + , ("test-suite", TestSuiteNameVar) + , ("result", TestSuiteResultVar) + , ("benchmark", BenchmarkNameVar) + ] instance Show PathComponent where show (Ordinary path) = path - show (Variable var) = '$':show var + show (Variable var) = '$' : show var showList = foldr (\x -> (shows x .)) id instance Read PathComponent where -- for some reason we collapse multiple $ symbols here readsPrec _ = lex0 - where lex0 [] = [] - lex0 ('$':'$':s') = lex0 ('$':s') - lex0 ('$':s') = case [ (Variable var, s'') - | (var, s'') <- reads s' ] of - [] -> lex1 "$" s' - ok -> ok - lex0 s' = lex1 [] s' - lex1 "" "" = [] - lex1 acc "" = [(Ordinary (reverse acc), "")] - lex1 acc ('$':'$':s) = lex1 acc ('$':s) - lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)] - lex1 acc (c:s) = lex1 (c:acc) s - readList [] = [([],"")] - readList s = [ (component:components, s'') - | (component, s') <- reads s - , (components, s'') <- readList s' ] + where + lex0 [] = [] + lex0 ('$' : '$' : s') = lex0 ('$' : s') + lex0 ('$' : s') = case [ (Variable var, s'') + | (var, s'') <- reads s' + ] of + [] -> lex1 "$" s' + ok -> ok + lex0 s' = lex1 [] s' + lex1 "" "" = [] + lex1 acc "" = [(Ordinary (reverse acc), "")] + lex1 acc ('$' : '$' : s) = lex1 acc ('$' : s) + lex1 acc ('$' : s) = [(Ordinary (reverse acc), '$' : s)] + lex1 acc (c : s) = lex1 (c : acc) s + readList [] = [([], "")] + readList s = + [ (component : components, s'') + | (component, s') <- reads s + , (components, s'') <- readList s' + ] 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,11 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.LocalBuildInfo -- Copyright : Isaac Jones 2003-2004 @@ -18,81 +21,89 @@ -- programs, the package database to use and a bunch of miscellaneous configure -- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets -- passed in to very many subsequent build actions. - -module Distribution.Simple.LocalBuildInfo ( - LocalBuildInfo(..), - localComponentId, - localUnitId, - localCompatPackageKey, +module Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo (..) + , localComponentId + , localUnitId + , localCompatPackageKey - -- * Buildable package components - Component(..), - ComponentName(..), - LibraryName(..), - defaultLibName, - showComponentName, - componentNameString, - ComponentLocalBuildInfo(..), - componentBuildDir, - foldComponent, - componentName, - componentBuildInfo, - componentBuildable, - pkgComponents, - pkgBuildableComponents, - lookupComponent, - getComponent, - allComponentsInBuildOrder, - depLibraryPaths, - allLibModules, + -- * Convenience accessors + , buildDir + , cabalFilePath + , progPrefix + , progSuffix - withAllComponentsInBuildOrder, - withLibLBI, - withExeLBI, - withBenchLBI, - withTestLBI, - enabledTestLBIs, - enabledBenchLBIs, + -- * Buildable package components + , Component (..) + , ComponentName (..) + , LibraryName (..) + , defaultLibName + , showComponentName + , componentNameString + , ComponentLocalBuildInfo (..) + , componentBuildDir + , foldComponent + , componentName + , componentBuildInfo + , componentBuildable + , pkgComponents + , pkgBuildableComponents + , lookupComponent + , getComponent + , allComponentsInBuildOrder + , depLibraryPaths + , allLibModules + , withAllComponentsInBuildOrder + , withLibLBI + , withExeLBI + , withBenchLBI + , withTestLBI + , enabledTestLBIs + , enabledBenchLBIs - -- * Installation directories - module Distribution.Simple.InstallDirs, - absoluteInstallDirs, prefixRelativeInstallDirs, - absoluteInstallCommandDirs, - absoluteComponentInstallDirs, prefixRelativeComponentInstallDirs, - substPathTemplate, + -- * Installation directories + , module Distribution.Simple.InstallDirs + , absoluteInstallDirs + , prefixRelativeInstallDirs + , absoluteInstallCommandDirs + , absoluteComponentInstallDirs + , prefixRelativeComponentInstallDirs + , substPathTemplate ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Types.Component -import Distribution.Types.PackageId -import Distribution.Types.UnitId -import Distribution.Types.ComponentName -import Distribution.Types.UnqualComponentName -import Distribution.Types.PackageDescription import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentName import Distribution.Types.LocalBuildInfo +import Distribution.Types.PackageDescription +import Distribution.Types.PackageId import Distribution.Types.TargetInfo +import Distribution.Types.UnitId +import Distribution.Types.UnqualComponentName -import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, - prefixRelativeInstallDirs, - substPathTemplate, ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.PackageDescription +import qualified Distribution.Compat.Graph as Graph import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Package import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Pretty import Distribution.Simple.Compiler +import Distribution.Simple.InstallDirs hiding + ( absoluteInstallDirs + , prefixRelativeInstallDirs + , substPathTemplate + ) +import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.PackageIndex import Distribution.Simple.Utils -import Distribution.Pretty -import qualified Distribution.Compat.Graph as Graph import Data.List (stripPrefix) import System.FilePath -import System.Directory (doesDirectoryExist, canonicalizePath) +import System.Directory (canonicalizePath, doesDirectoryExist) -- ----------------------------------------------------------------------------- -- Configuration information of buildable components @@ -101,83 +112,104 @@ -- For now, we assume that libraries/executables/test-suites/benchmarks -- are only ever built once. With Backpack, we need a special case for -- libraries so that we can handle building them multiple times. -componentBuildDir lbi clbi - = buildDir lbi - case componentLocalName clbi of - CLibName LMainLibName -> - if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) - then "" - else prettyShow (componentUnitId clbi) - CLibName (LSubLibName s) -> - if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) - then unUnqualComponentName s - else prettyShow (componentUnitId clbi) - CFLibName s -> unUnqualComponentName s - CExeName s -> unUnqualComponentName s - CTestName s -> unUnqualComponentName s - CBenchName s -> unUnqualComponentName s +componentBuildDir lbi clbi = + buildDir lbi + case componentLocalName clbi of + CLibName LMainLibName -> + if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) + then "" + else prettyShow (componentUnitId clbi) + CLibName (LSubLibName s) -> + if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) + then unUnqualComponentName s + else prettyShow (componentUnitId clbi) + CFLibName s -> unUnqualComponentName s + CExeName s -> unUnqualComponentName s + CTestName s -> unUnqualComponentName s + CBenchName s -> unUnqualComponentName s -- | Perform the action on each enabled 'library' in the package -- description with the 'ComponentLocalBuildInfo'. -withLibLBI :: PackageDescription -> LocalBuildInfo - -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO () +withLibLBI + :: PackageDescription + -> LocalBuildInfo + -> (Library -> ComponentLocalBuildInfo -> IO ()) + -> IO () withLibLBI pkg lbi f = - withAllTargetsInBuildOrder' pkg lbi $ \target -> - case targetComponent target of - CLib lib -> f lib (targetCLBI target) - _ -> return () + withAllTargetsInBuildOrder' pkg lbi $ \target -> + case targetComponent target of + CLib lib -> f lib (targetCLBI target) + _ -> return () -- | Perform the action on each enabled 'Executable' in the package -- description. Extended version of 'withExe' that also gives corresponding -- build info. -withExeLBI :: PackageDescription -> LocalBuildInfo - -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO () +withExeLBI + :: PackageDescription + -> LocalBuildInfo + -> (Executable -> ComponentLocalBuildInfo -> IO ()) + -> IO () withExeLBI pkg lbi f = - withAllTargetsInBuildOrder' pkg lbi $ \target -> - case targetComponent target of - CExe exe -> f exe (targetCLBI target) - _ -> return () + withAllTargetsInBuildOrder' pkg lbi $ \target -> + case targetComponent target of + CExe exe -> f exe (targetCLBI target) + _ -> return () -- | Perform the action on each enabled 'Benchmark' in the package -- description. -withBenchLBI :: PackageDescription -> LocalBuildInfo - -> (Benchmark -> ComponentLocalBuildInfo -> IO ()) -> IO () +withBenchLBI + :: PackageDescription + -> LocalBuildInfo + -> (Benchmark -> ComponentLocalBuildInfo -> IO ()) + -> IO () withBenchLBI pkg lbi f = - sequence_ [ f bench clbi | (bench, clbi) <- enabledBenchLBIs pkg lbi ] + sequence_ [f bench clbi | (bench, clbi) <- enabledBenchLBIs pkg lbi] -withTestLBI :: PackageDescription -> LocalBuildInfo - -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () +withTestLBI + :: PackageDescription + -> LocalBuildInfo + -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) + -> IO () withTestLBI pkg lbi f = - sequence_ [ f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi ] + sequence_ [f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi] -enabledTestLBIs :: PackageDescription -> LocalBuildInfo - -> [(TestSuite, ComponentLocalBuildInfo)] +enabledTestLBIs + :: PackageDescription + -> LocalBuildInfo + -> [(TestSuite, ComponentLocalBuildInfo)] enabledTestLBIs pkg lbi = - [ (test, targetCLBI target) - | target <- allTargetsInBuildOrder' pkg lbi - , CTest test <- [targetComponent target] ] + [ (test, targetCLBI target) + | target <- allTargetsInBuildOrder' pkg lbi + , CTest test <- [targetComponent target] + ] -enabledBenchLBIs :: PackageDescription -> LocalBuildInfo - -> [(Benchmark, ComponentLocalBuildInfo)] +enabledBenchLBIs + :: PackageDescription + -> LocalBuildInfo + -> [(Benchmark, ComponentLocalBuildInfo)] enabledBenchLBIs pkg lbi = - [ (bench, targetCLBI target) - | target <- allTargetsInBuildOrder' pkg lbi - , CBench bench <- [targetComponent target] ] + [ (bench, targetCLBI target) + | target <- allTargetsInBuildOrder' pkg lbi + , CBench bench <- [targetComponent target] + ] -- | Perform the action on each buildable 'Library' or 'Executable' (Component) -- in the PackageDescription, subject to the build order specified by the -- 'compBuildOrder' field of the given 'LocalBuildInfo' -withAllComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo - -> (Component -> ComponentLocalBuildInfo -> IO ()) - -> IO () +withAllComponentsInBuildOrder + :: PackageDescription + -> LocalBuildInfo + -> (Component -> ComponentLocalBuildInfo -> IO ()) + -> IO () withAllComponentsInBuildOrder pkg lbi f = - withAllTargetsInBuildOrder' pkg lbi $ \target -> - f (targetComponent target) (targetCLBI target) + withAllTargetsInBuildOrder' pkg lbi $ \target -> + f (targetComponent target) (targetCLBI target) -allComponentsInBuildOrder :: LocalBuildInfo - -> [ComponentLocalBuildInfo] -allComponentsInBuildOrder lbi = - Graph.topSort (componentGraph lbi) +allComponentsInBuildOrder + :: LocalBuildInfo + -> [ComponentLocalBuildInfo] +allComponentsInBuildOrder (LocalBuildInfo{componentGraph = compGraph}) = + Graph.topSort compGraph -- ----------------------------------------------------------------------------- -- A random function that has no business in this module @@ -186,42 +218,62 @@ -- transitive dependencies of the component we are building. -- -- When wanted, and possible, returns paths relative to the installDirs 'prefix' -depLibraryPaths :: Bool -- ^ Building for inplace? - -> Bool -- ^ Generate prefix-relative library paths - -> LocalBuildInfo - -> ComponentLocalBuildInfo -- ^ Component that is being built - -> IO [FilePath] -depLibraryPaths inplace relative lbi clbi = do - let pkgDescr = localPkgDescr lbi - installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest - executable = case clbi of - ExeComponentLocalBuildInfo {} -> True - _ -> False - relDir | executable = bindir installDirs - | otherwise = libdir installDirs +depLibraryPaths + :: Bool + -- ^ Building for inplace? + -> Bool + -- ^ Generate prefix-relative library paths + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -- ^ Component that is being built + -> IO [FilePath] +depLibraryPaths + inplace + relative + lbi@( LocalBuildInfo + { localPkgDescr = pkgDescr + , installedPkgs = installed + } + ) + clbi = do + let installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest + executable = case clbi of + ExeComponentLocalBuildInfo{} -> True + _ -> False + relDir + | executable = bindir installDirs + | otherwise = libdir installDirs - let -- TODO: this is kind of inefficient - internalDeps = [ uid - | (uid, _) <- componentPackageDeps clbi - -- Test that it's internal - , sub_target <- allTargetsInBuildOrder' pkgDescr lbi - , componentUnitId (targetCLBI (sub_target)) == uid ] - internalLibs = [ getLibDir (targetCLBI sub_target) - | sub_target <- neededTargetsInBuildOrder' - pkgDescr lbi internalDeps ] - {- - -- This is better, but it doesn't work, because we may be passed a - -- CLBI which doesn't actually exist, and was faked up when we - -- were building a test suite/benchmark. See #3599 for proposal - -- to fix this. - let internalCLBIs = filter ((/= componentUnitId clbi) . componentUnitId) - . map targetCLBI - $ neededTargetsInBuildOrder lbi [componentUnitId clbi] - internalLibs = map getLibDir internalCLBIs - -} - getLibDir sub_clbi - | inplace = componentBuildDir lbi sub_clbi - | otherwise = dynlibdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest) + let + -- TODO: this is kind of inefficient + internalDeps = + [ uid + | (uid, _) <- componentPackageDeps clbi + , -- Test that it's internal + sub_target <- allTargetsInBuildOrder' pkgDescr lbi + , componentUnitId (targetCLBI (sub_target)) == uid + ] + internalLibs = + [ getLibDir (targetCLBI sub_target) + | sub_target <- + neededTargetsInBuildOrder' + pkgDescr + lbi + internalDeps + ] + {- + -- This is better, but it doesn't work, because we may be passed a + -- CLBI which doesn't actually exist, and was faked up when we + -- were building a test suite/benchmark. See #3599 for proposal + -- to fix this. + let internalCLBIs = filter ((/= componentUnitId clbi) . componentUnitId) + . map targetCLBI + $ neededTargetsInBuildOrder lbi [componentUnitId clbi] + internalLibs = map getLibDir internalCLBIs + -} + getLibDir sub_clbi + | inplace = componentBuildDir lbi sub_clbi + | otherwise = dynlibdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest) -- Why do we go through all the trouble of a hand-crafting -- internalLibs, when 'installedPkgs' actually contains the @@ -232,48 +284,54 @@ -- is a moot point if you are using a per-component build, -- because you never have any internal libraries in this case; -- they're all external. - let external_ipkgs = filter is_external (allPackages (installedPkgs lbi)) + let external_ipkgs = filter is_external (allPackages installed) is_external ipkg = not (installedUnitId ipkg `elem` 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 - [] -> Installed.libraryDirs pkg - d -> d - allDepLibDirs = concatMap getDynDir external_ipkgs + getDynDir pkg = case Installed.libraryDynDirs pkg of + [] -> Installed.libraryDirs pkg + d -> d + allDepLibDirs = concatMap getDynDir external_ipkgs allDepLibDirs' = internalLibs ++ allDepLibDirs allDepLibDirsC <- traverse canonicalizePathNoFail allDepLibDirs' - let p = prefix installDirs + let p = prefix installDirs prefixRelative l = isJust (stripPrefix p l) libPaths - | relative && - prefixRelative relDir = map (\l -> - if prefixRelative l - then shortRelativePath relDir l - else l - ) allDepLibDirsC - | otherwise = allDepLibDirsC + | relative + && prefixRelative relDir = + map + ( \l -> + if prefixRelative l + then shortRelativePath relDir l + else l + ) + allDepLibDirsC + | otherwise = allDepLibDirsC - return libPaths - where - -- 'canonicalizePath' fails on UNIX when the directory does not exists. - -- So just don't canonicalize when it doesn't exist. - canonicalizePathNoFail p = do - exists <- doesDirectoryExist p - if exists - then canonicalizePath p - else return p + -- For some reason, this function returns lots of duplicates. Avoid + -- exceeding `ARG_MAX` (the result of this function is used to populate + -- `LD_LIBRARY_PATH`) by deduplicating the list. + return $ ordNub libPaths + where + -- 'canonicalizePath' fails on UNIX when the directory does not exists. + -- So just don't canonicalize when it doesn't exist. + canonicalizePathNoFail p = do + exists <- doesDirectoryExist p + if exists + then canonicalizePath p + else return p -- | Get all module names that needed to be built by GHC; i.e., all -- of these 'ModuleName's have interface files associated with them -- that need to be installed. allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName] allLibModules lib clbi = - ordNub $ - explicitLibModules lib ++ - case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> map fst insts + ordNub $ + explicitLibModules lib + ++ case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> map fst insts _ -> [] -- ----------------------------------------------------------------------------- @@ -283,49 +341,59 @@ -- assuming that @$libname@ points to the public library (or some fake -- package identifier if there is no public library.) IF AT ALL -- POSSIBLE, please use 'absoluteComponentInstallDirs' instead. -absoluteInstallDirs :: PackageDescription -> LocalBuildInfo - -> CopyDest - -> InstallDirs FilePath +absoluteInstallDirs + :: PackageDescription + -> LocalBuildInfo + -> CopyDest + -> InstallDirs FilePath absoluteInstallDirs pkg lbi copydest = - absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest + absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest -- | See 'InstallDirs.absoluteInstallDirs'. -absoluteComponentInstallDirs :: PackageDescription -> LocalBuildInfo - -> UnitId - -> CopyDest - -> InstallDirs FilePath -absoluteComponentInstallDirs pkg lbi uid copydest = - InstallDirs.absoluteInstallDirs - (packageId pkg) - uid - (compilerInfo (compiler lbi)) - copydest - (hostPlatform lbi) - (installDirTemplates lbi) +absoluteComponentInstallDirs + :: PackageDescription + -> LocalBuildInfo + -> UnitId + -> CopyDest + -> InstallDirs FilePath +absoluteComponentInstallDirs + pkg + (LocalBuildInfo{compiler = comp, hostPlatform = plat, installDirTemplates = installDirs}) + uid + copydest = + InstallDirs.absoluteInstallDirs + (packageId pkg) + uid + (compilerInfo comp) + copydest + plat + installDirs -absoluteInstallCommandDirs :: PackageDescription -> LocalBuildInfo - -> UnitId - -> CopyDest - -> InstallDirs FilePath +absoluteInstallCommandDirs + :: PackageDescription + -> LocalBuildInfo + -> UnitId + -> CopyDest + -> InstallDirs FilePath absoluteInstallCommandDirs pkg lbi uid copydest = - dirs { - -- Handle files which are not - -- per-component (data files and Haddock files.) - datadir = datadir dirs', - -- NB: The situation with Haddock is a bit delicate. On the - -- one hand, the easiest to understand Haddock documentation - -- path is pkgname-0.1, which means it's per-package (not - -- per-component). But this means that it's impossible to - -- install Haddock documentation for internal libraries. We'll - -- keep this constraint for now; this means you can't use - -- Cabal to Haddock internal libraries. This does not seem - -- like a big problem. - docdir = docdir dirs', - htmldir = htmldir dirs', - haddockdir = haddockdir dirs' + dirs + { -- Handle files which are not + -- per-component (data files and Haddock files.) + datadir = datadir dirs' + , -- NB: The situation with Haddock is a bit delicate. On the + -- one hand, the easiest to understand Haddock documentation + -- path is pkgname-0.1, which means it's per-package (not + -- per-component). But this means that it's impossible to + -- install Haddock documentation for internal libraries. We'll + -- keep this constraint for now; this means you can't use + -- Cabal to Haddock internal libraries. This does not seem + -- like a big problem. + docdir = docdir dirs' + , htmldir = htmldir dirs' + , haddockdir = haddockdir dirs' } where - dirs = absoluteComponentInstallDirs pkg lbi uid copydest + dirs = absoluteComponentInstallDirs pkg lbi uid copydest -- Notice use of 'absoluteInstallDirs' (not the -- per-component variant). This means for non-library -- packages we'll just pick a nondescriptive foo-0.1 @@ -335,31 +403,46 @@ -- assuming that @$libname@ points to the public library (or some fake -- package identifier if there is no public library.) IF AT ALL -- POSSIBLE, please use 'prefixRelativeComponentInstallDirs' instead. -prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo - -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs + :: PackageId + -> LocalBuildInfo + -> InstallDirs (Maybe FilePath) prefixRelativeInstallDirs pkg_descr lbi = - prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId lbi) - --- |See 'InstallDirs.prefixRelativeInstallDirs' -prefixRelativeComponentInstallDirs :: PackageId -> LocalBuildInfo - -> UnitId - -> InstallDirs (Maybe FilePath) -prefixRelativeComponentInstallDirs pkg_descr lbi uid = - InstallDirs.prefixRelativeInstallDirs - (packageId pkg_descr) - uid - (compilerInfo (compiler lbi)) - (hostPlatform lbi) - (installDirTemplates lbi) + prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId lbi) -substPathTemplate :: PackageId -> LocalBuildInfo - -> UnitId - -> PathTemplate -> FilePath -substPathTemplate pkgid lbi uid = fromPathTemplate - . ( InstallDirs.substPathTemplate env ) - where env = initialPathTemplateEnv - pkgid - uid - (compilerInfo (compiler lbi)) - (hostPlatform lbi) +-- | See 'InstallDirs.prefixRelativeInstallDirs' +prefixRelativeComponentInstallDirs + :: PackageId + -> LocalBuildInfo + -> UnitId + -> InstallDirs (Maybe FilePath) +prefixRelativeComponentInstallDirs + pkg_descr + (LocalBuildInfo{compiler = comp, hostPlatform = plat, installDirTemplates = installDirs}) + uid = + InstallDirs.prefixRelativeInstallDirs + (packageId pkg_descr) + uid + (compilerInfo comp) + plat + installDirs +substPathTemplate + :: PackageId + -> LocalBuildInfo + -> UnitId + -> PathTemplate + -> FilePath +substPathTemplate + pkgid + (LocalBuildInfo{compiler = comp, hostPlatform = plat}) + uid = + fromPathTemplate + . (InstallDirs.substPathTemplate env) + where + env = + initialPathTemplateEnv + pkgid + uid + (compilerInfo comp) + plat 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 @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.PackageDescription -- Copyright : Isaac Jones 2003-2005 @@ -8,33 +9,37 @@ -- Portability : portable -- -- This defines parsers for the @.cabal@ format - -module Distribution.Simple.PackageDescription ( - -- * Read and Parse files - readGenericPackageDescription, - readHookedBuildInfo, +module Distribution.Simple.PackageDescription + ( -- * Read and Parse files + readGenericPackageDescription + , readHookedBuildInfo -- * Utility Parsing function - parseString, - ) where + , parseString + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () +import qualified Data.ByteString as BS +import Data.List (groupBy) import Distribution.Fields.ParseResult import Distribution.PackageDescription import Distribution.PackageDescription.Parsec - ( parseGenericPackageDescription, parseHookedBuildInfo ) -import Distribution.Parsec.Error ( showPError ) + ( parseGenericPackageDescription + , parseHookedBuildInfo + ) +import Distribution.Parsec.Error (showPError) import Distribution.Parsec.Warning - ( PWarning(..), PWarnType(PWTExperimental), showPWarning ) -import Distribution.Simple.Utils ( equating, die', warn ) -import Distribution.Verbosity ( normal, Verbosity ) - -import Data.List ( groupBy ) -import Text.Printf ( printf ) -import qualified Data.ByteString as BS + ( PWarnType (PWTExperimental) + , PWarning (..) + , showPWarning + ) +import Distribution.Simple.Errors +import Distribution.Simple.Utils (dieWithException, equating, warn) +import Distribution.Verbosity (Verbosity, normal) import System.Directory (doesFileExist) +import Text.Printf (printf) readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription readGenericPackageDescription = readAndParseFile parseGenericPackageDescription @@ -49,55 +54,63 @@ -- -- Argument order is chosen to encourage partial application. readAndParseFile - :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser - -> Verbosity -- ^ Verbosity level - -> FilePath -- ^ File to read - -> IO a + :: (BS.ByteString -> ParseResult a) + -- ^ File contents to final value parser + -> Verbosity + -- ^ Verbosity level + -> FilePath + -- ^ File to read + -> IO a readAndParseFile parser verbosity fpath = do - exists <- doesFileExist fpath - unless exists $ - die' verbosity $ - "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." - bs <- BS.readFile fpath - parseString parser verbosity fpath bs + exists <- doesFileExist fpath + unless exists $ + dieWithException verbosity $ + ErrorParsingFileDoesntExist fpath + bs <- BS.readFile fpath + parseString parser verbosity fpath bs parseString - :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser - -> Verbosity -- ^ Verbosity level - -> String -- ^ File name - -> BS.ByteString - -> IO a + :: (BS.ByteString -> ParseResult a) + -- ^ File contents to final value parser + -> Verbosity + -- ^ Verbosity level + -> String + -- ^ File name + -> BS.ByteString + -> IO a parseString parser verbosity name bs = do - let (warnings, result) = runParseResult (parser bs) - traverse_ (warn verbosity . showPWarning name) (flattenDups verbosity warnings) - case result of - Right x -> return x - Left (_, errors) -> do - traverse_ (warn verbosity . showPError name) errors - die' verbosity $ "Failed parsing \"" ++ name ++ "\"." + let (warnings, result) = runParseResult (parser bs) + traverse_ (warn verbosity . showPWarning name) (flattenDups verbosity warnings) + case result of + Right x -> return x + Left (_, errors) -> do + traverse_ (warn verbosity . showPError name) 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 ws - | verbosity <= normal = rest ++ experimentals - | otherwise = ws -- show all instances - where - (exps, rest) = partition (\(PWarning w _ _) -> w == PWTExperimental) ws - experimentals = - concatMap flatCount - . groupBy (equating warningStr) - . sortBy (comparing warningStr) - $ exps + | verbosity <= normal = rest ++ experimentals + | otherwise = ws -- show all instances + where + (exps, rest) = partition (\(PWarning w _ _) -> w == PWTExperimental) ws + experimentals = + concatMap flatCount + . groupBy (equating warningStr) + . sortBy (comparing warningStr) + $ exps - warningStr (PWarning _ _ w) = w + warningStr (PWarning _ _ w) = w - -- flatten if we have 3 or more examples - flatCount :: [PWarning] -> [PWarning] - 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)) - ] + -- flatten if we have 3 or more examples + flatCount :: [PWarning] -> [PWarning] + 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)) + ] 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 @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.PackageIndex -- Copyright : (c) David Himmelstrup 2005, @@ -43,80 +44,77 @@ -- 'Distribution.Client.PackageIndex', which indexes packages only by -- 'PackageName' (this makes it suitable for indexing source packages, -- for which we don't know 'UnitId's.) --- -module Distribution.Simple.PackageIndex ( - -- * Package index data type - InstalledPackageIndex, - PackageIndex, - - -- * Creating an index - fromList, - - -- * Updates - merge, +module Distribution.Simple.PackageIndex + ( -- * Package index data type + InstalledPackageIndex + , PackageIndex - insert, + -- * Creating an index + , fromList - deleteUnitId, - deleteSourcePackageId, - deletePackageName, --- deleteDependency, + -- * Updates + , merge + , insert + , deleteUnitId + , deleteSourcePackageId + , deletePackageName + -- deleteDependency, - -- * Queries + -- * Queries - -- ** Precise lookups - lookupUnitId, - lookupComponentId, - lookupSourcePackageId, - lookupPackageId, - lookupPackageName, - lookupDependency, - lookupInternalDependency, + -- ** Precise lookups + , lookupUnitId + , lookupComponentId + , lookupSourcePackageId + , lookupPackageId + , lookupPackageName + , lookupDependency + , lookupInternalDependency - -- ** Case-insensitive searches - searchByName, - SearchResult(..), - searchByNameSubstring, - searchWithPredicate, + -- ** Case-insensitive searches + , searchByName + , SearchResult (..) + , searchByNameSubstring + , searchWithPredicate - -- ** Bulk queries - allPackages, - allPackagesByName, - allPackagesBySourcePackageId, - allPackagesBySourcePackageIdAndLibName, + -- ** Bulk queries + , allPackages + , allPackagesByName + , allPackagesBySourcePackageId + , allPackagesBySourcePackageIdAndLibName - -- ** Special queries - brokenPackages, - dependencyClosure, - reverseDependencyClosure, - topologicalOrder, - reverseTopologicalOrder, - dependencyInconsistencies, - dependencyCycles, - dependencyGraph, - moduleNameIndex + -- ** Special queries + , brokenPackages + , dependencyClosure + , reverseDependencyClosure + , topologicalOrder + , reverseTopologicalOrder + , dependencyInconsistencies + , dependencyCycles + , dependencyGraph + , moduleNameIndex ) where -import Prelude () -import Distribution.Compat.Prelude hiding (lookup) import qualified Data.Map.Strict as Map +import Distribution.Compat.Prelude hiding (lookup) +import Prelude () -import Distribution.Package import Distribution.Backpack -import Distribution.ModuleName import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Version +import Distribution.ModuleName +import Distribution.Package import Distribution.Simple.Utils import Distribution.Types.LibraryName +import Distribution.Version import Control.Exception (assert) +import Control.Monad import Data.Array ((!)) import qualified Data.Array as Array import qualified Data.Graph as Graph -import Data.List as List ( groupBy, deleteBy, deleteFirstsBy ) +import Data.List as List (deleteBy, deleteFirstsBy, groupBy) import qualified Data.List.NonEmpty as NE -import qualified Data.Tree as Tree -import Control.Monad +import qualified Data.Tree as Tree import Distribution.Compat.Stack import qualified Prelude (foldr1) @@ -126,27 +124,25 @@ -- -- Packages are uniquely identified in by their 'UnitId', they can -- also be efficiently looked up by package name or by name and version. --- -data PackageIndex a = PackageIndex { - -- The primary index. Each InstalledPackageInfo record is uniquely identified - -- by its UnitId. - -- - unitIdIndex :: !(Map UnitId a), - - -- This auxiliary index maps package names (case-sensitively) to all the - -- versions and instances of that package. This allows us to find all - -- versions satisfying a dependency. - -- - -- It is a three-level index. The first level is the package name, - -- the second is the package version and the final level is instances - -- of the same package version. These are unique by UnitId - -- and are kept in preference order. - -- - -- FIXME: Clarify what "preference order" means. Check that this invariant is - -- preserved. See #1463 for discussion. - packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a])) - - } deriving (Eq, Generic, Show, Read, Typeable) +data PackageIndex a = PackageIndex + { -- The primary index. Each InstalledPackageInfo record is uniquely identified + -- by its UnitId. + -- + unitIdIndex :: !(Map UnitId a) + , -- This auxiliary index maps package names (case-sensitively) to all the + -- versions and instances of that package. This allows us to find all + -- versions satisfying a dependency. + -- + -- It is a three-level index. The first level is the package name, + -- the second is the package version and the final level is instances + -- of the same package version. These are unique by UnitId + -- and are kept in preference order. + -- + -- FIXME: Clarify what "preference order" means. Check that this invariant is + -- preserved. See #1463 for discussion. + packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a])) + } + deriving (Eq, Generic, Show, Read, Typeable) instance Binary a => Binary (PackageIndex a) instance Structured a => Structured (PackageIndex a) @@ -156,9 +152,10 @@ type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo instance Monoid (PackageIndex IPI.InstalledPackageInfo) where - mempty = PackageIndex Map.empty Map.empty + mempty = PackageIndex Map.empty Map.empty mappend = (<>) - --save one mappend with empty in the common case: + + -- save one mappend with empty in the common case: mconcat [] = mempty mconcat xs = Prelude.foldr1 mappend xs @@ -170,69 +167,84 @@ invariant (PackageIndex pids pnames) = -- trace (show pids' ++ "\n" ++ show pnames') $ pids' == pnames' - where - pids' = map installedUnitId (Map.elems pids) - pnames' = sort - [ assert pinstOk (installedUnitId pinst) - | ((pname, plib), pvers) <- Map.toList pnames - , let pversOk = not (Map.null pvers) - , (pver, pinsts) <- assert pversOk $ Map.toList pvers - , let pinsts' = sortBy (comparing installedUnitId) pinsts - pinstsOk = all (\g -> length g == 1) - (groupBy (equating installedUnitId) pinsts') - , pinst <- assert pinstsOk $ pinsts' - , let pinstOk = packageName pinst == pname + where + pids' = map installedUnitId (Map.elems pids) + pnames' = + sort + [ assert pinstOk (installedUnitId pinst) + | ((pname, plib), pvers) <- Map.toList pnames + , let pversOk = not (Map.null pvers) + , (pver, pinsts) <- assert pversOk $ Map.toList pvers + , let pinsts' = sortBy (comparing installedUnitId) pinsts + pinstsOk = + all + (\g -> length g == 1) + (groupBy (equating installedUnitId) pinsts') + , pinst <- assert pinstsOk $ pinsts' + , let pinstOk = + packageName pinst == pname && packageVersion pinst == pver - && IPI.sourceLibName pinst == plib - ] - -- If you see this invariant failing (ie the assert in mkPackageIndex below) - -- then one thing to check is if it is happening in fromList. Check if the - -- second list above (the sort [...] bit) is ending up with duplicates. This - -- has been observed in practice once due to a messed up ghc-pkg db. How/why - -- it became messed up was not discovered. + && IPI.sourceLibName pinst == plib + ] +-- If you see this invariant failing (ie the assert in mkPackageIndex below) +-- then one thing to check is if it is happening in fromList. Check if the +-- second list above (the sort [...] bit) is ending up with duplicates. This +-- has been observed in practice once due to a messed up ghc-pkg db. How/why +-- it became messed up was not discovered. -- + -- * Internal helpers + -- -mkPackageIndex :: WithCallStack (Map UnitId IPI.InstalledPackageInfo - -> Map (PackageName, LibraryName) - (Map Version [IPI.InstalledPackageInfo]) - -> InstalledPackageIndex) +mkPackageIndex + :: WithCallStack + ( Map UnitId IPI.InstalledPackageInfo + -> Map + (PackageName, LibraryName) + (Map Version [IPI.InstalledPackageInfo]) + -> InstalledPackageIndex + ) mkPackageIndex pids pnames = assert (invariant index) index - where index = PackageIndex pids pnames - + where + index = PackageIndex pids pnames -- + -- * Construction + -- -- | Build an index out of a bunch of packages. -- -- If there are duplicates by 'UnitId' then later ones mask earlier -- ones. --- fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames) where - pids = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ] - pnames = + pids = Map.fromList [(installedUnitId pkg, pkg) | pkg <- pkgs] + pnames = Map.fromList [ (liftM2 (,) packageName IPI.sourceLibName (NE.head pkgsN), pvers) - | pkgsN <- NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName)) - . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion)) - $ pkgs + | pkgsN <- + NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName)) + . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion)) + $ pkgs , let pvers = Map.fromList - [ (packageVersion (NE.head pkgsNV), - NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV)) - | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN - ] + [ ( packageVersion (NE.head pkgsNV) + , NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV) + ) + | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN + ] ] -- + -- * Updates + -- -- | Merge two indexes. @@ -244,101 +256,110 @@ -- \"preferred\" over those from the first. Being preferred means they are top -- result when we do a lookup by source 'PackageId'. This is the mechanism we -- use to prefer user packages over global packages. --- -merge :: InstalledPackageIndex -> InstalledPackageIndex - -> InstalledPackageIndex +merge + :: InstalledPackageIndex + -> InstalledPackageIndex + -> InstalledPackageIndex merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = - mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2) - (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) + mkPackageIndex + (Map.unionWith (\_ y -> y) pids1 pids2) + (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) where -- Packages in the second list mask those in the first, however preferred -- packages go first in the list. mergeBuckets xs ys = ys ++ (xs \\ ys) (\\) = deleteFirstsBy (equating installedUnitId) - -- | Inserts a single package into the index. -- -- This is equivalent to (but slightly quicker than) using 'mappend' or -- 'merge' with a singleton index. --- insert :: IPI.InstalledPackageInfo -> InstalledPackageIndex -> InstalledPackageIndex insert pkg (PackageIndex pids pnames) = - mkPackageIndex pids' pnames' - + mkPackageIndex pids' pnames' where - pids' = Map.insert (installedUnitId pkg) pkg pids + pids' = Map.insert (installedUnitId pkg) pkg pids pnames' = insertPackageName pnames insertPackageName = - Map.insertWith (\_ -> insertPackageVersion) - (packageName pkg, IPI.sourceLibName pkg) - (Map.singleton (packageVersion pkg) [pkg]) + Map.insertWith + (\_ -> insertPackageVersion) + (packageName pkg, IPI.sourceLibName pkg) + (Map.singleton (packageVersion pkg) [pkg]) insertPackageVersion = - Map.insertWith (\_ -> insertPackageInstance) - (packageVersion pkg) [pkg] + Map.insertWith + (\_ -> insertPackageInstance) + (packageVersion pkg) + [pkg] insertPackageInstance pkgs = pkg : deleteBy (equating installedUnitId) pkg pkgs - -- | Removes a single installed package from the index. --- -deleteUnitId :: UnitId -> InstalledPackageIndex - -> InstalledPackageIndex +deleteUnitId + :: UnitId + -> InstalledPackageIndex + -> InstalledPackageIndex deleteUnitId ipkgid original@(PackageIndex pids pnames) = case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of - (Nothing, _) -> original - (Just spkgid, pids') -> mkPackageIndex pids' - (deletePkgName spkgid pnames) - + (Nothing, _) -> original + (Just spkgid, pids') -> + mkPackageIndex + pids' + (deletePkgName spkgid pnames) where deletePkgName spkgid = Map.update (deletePkgVersion spkgid) (packageName spkgid, IPI.sourceLibName spkgid) deletePkgVersion spkgid = - (\m -> if Map.null m then Nothing else Just m) - . Map.update deletePkgInstance (packageVersion spkgid) + (\m -> if Map.null m then Nothing else Just m) + . Map.update deletePkgInstance (packageVersion spkgid) deletePkgInstance = - (\xs -> if null xs then Nothing else Just xs) - . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined + (\xs -> if null xs then Nothing else Just xs) + . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined -- | Removes all packages with this source 'PackageId' from the index. --- -deleteSourcePackageId :: PackageId -> InstalledPackageIndex - -> InstalledPackageIndex +deleteSourcePackageId + :: PackageId + -> InstalledPackageIndex + -> InstalledPackageIndex deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = -- NB: Doesn't delete internal packages case Map.lookup (packageName pkgid, LMainLibName) pnames of - Nothing -> original - Just pvers -> case Map.lookup (packageVersion pkgid) pvers of - Nothing -> original - Just pkgs -> mkPackageIndex - (foldl' (flip (Map.delete . installedUnitId)) pids pkgs) - (deletePkgName pnames) + Nothing -> original + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> original + Just pkgs -> + mkPackageIndex + (foldl' (flip (Map.delete . installedUnitId)) pids pkgs) + (deletePkgName pnames) where deletePkgName = Map.update deletePkgVersion (packageName pkgid, LMainLibName) deletePkgVersion = - (\m -> if Map.null m then Nothing else Just m) - . Map.delete (packageVersion pkgid) - + (\m -> if Map.null m then Nothing else Just m) + . Map.delete (packageVersion pkgid) -- | Removes all packages with this (case-sensitive) name from the index. -- -- NB: Does NOT delete internal libraries from this package. --- -deletePackageName :: PackageName -> InstalledPackageIndex - -> InstalledPackageIndex +deletePackageName + :: PackageName + -> InstalledPackageIndex + -> InstalledPackageIndex deletePackageName name original@(PackageIndex pids pnames) = case Map.lookup (name, LMainLibName) pnames of - Nothing -> original - Just pvers -> mkPackageIndex - (foldl' (flip (Map.delete . installedUnitId)) pids - (concat (Map.elems pvers))) - (Map.delete (name, LMainLibName) pnames) + Nothing -> original + Just pvers -> + mkPackageIndex + ( foldl' + (flip (Map.delete . installedUnitId)) + pids + (concat (Map.elems pvers)) + ) + (Map.delete (name, LMainLibName) pnames) {- -- | Removes all packages satisfying this dependency from the index. @@ -349,11 +370,12 @@ -} -- + -- * Bulk queries + -- -- | Get all the packages from the index. --- allPackages :: PackageIndex a -> [a] allPackages = Map.elems . unitIdIndex @@ -362,91 +384,99 @@ -- They are grouped by package name (case-sensitively). -- -- (Doesn't include private libraries.) --- allPackagesByName :: PackageIndex a -> [(PackageName, [a])] allPackagesByName index = [ (pkgname, concat (Map.elems pvers)) - | ((pkgname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) ] + | ((pkgname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) + ] -- | Get all the packages from the index. -- -- They are grouped by source package id (package name and version). -- -- (Doesn't include private libraries) --- -allPackagesBySourcePackageId :: HasUnitId a => PackageIndex a - -> [(PackageId, [a])] +allPackagesBySourcePackageId + :: HasUnitId a + => PackageIndex a + -> [(PackageId, [a])] allPackagesBySourcePackageId index = [ (packageId ipkg, ipkgs) | ((_, LMainLibName), pvers) <- Map.toList (packageIdIndex index) - , ipkgs@(ipkg:_) <- Map.elems pvers ] + , ipkgs@(ipkg : _) <- Map.elems pvers + ] -- | Get all the packages from the index. -- -- They are grouped by source package id and library name. -- -- This DOES include internal libraries. -allPackagesBySourcePackageIdAndLibName :: HasUnitId a => PackageIndex a - -> [((PackageId, LibraryName), [a])] +allPackagesBySourcePackageIdAndLibName + :: HasUnitId a + => PackageIndex a + -> [((PackageId, LibraryName), [a])] allPackagesBySourcePackageIdAndLibName index = [ ((packageId ipkg, ln), ipkgs) | ((_, ln), pvers) <- Map.toList (packageIdIndex index) - , ipkgs@(ipkg:_) <- Map.elems pvers ] + , ipkgs@(ipkg : _) <- Map.elems pvers + ] -- + -- * Lookups + -- -- | Does a lookup by unit identifier. -- -- Since multiple package DBs mask each other by 'UnitId', -- then we get back at most one package. --- -lookupUnitId :: PackageIndex a -> UnitId - -> Maybe a +lookupUnitId + :: PackageIndex a + -> UnitId + -> Maybe a lookupUnitId index uid = Map.lookup uid (unitIdIndex index) -- | Does a lookup by component identifier. In the absence -- of Backpack, this is just a 'lookupUnitId'. --- -lookupComponentId :: PackageIndex a -> ComponentId - -> Maybe a +lookupComponentId + :: PackageIndex a + -> ComponentId + -> Maybe a lookupComponentId index cid = - Map.lookup (newSimpleUnitId cid) (unitIdIndex index) + Map.lookup (newSimpleUnitId cid) (unitIdIndex index) -- | Does a lookup by source package id (name & version). -- -- There can be multiple installed packages with the same source 'PackageId' -- but different 'UnitId'. They are returned in order of -- preference, with the most preferred first. --- lookupSourcePackageId :: PackageIndex a -> PackageId -> [a] lookupSourcePackageId index pkgid = -- 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 -> [] + Nothing -> [] + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> [] Just pkgs -> pkgs -- in preference order -- | Convenient alias of 'lookupSourcePackageId', but assuming only -- one package per package ID. lookupPackageId :: PackageIndex a -> PackageId -> Maybe a -lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of - [] -> Nothing - [pkg] -> Just pkg - _ -> error "Distribution.Simple.PackageIndex: multiple matches found" +lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of + [] -> Nothing + [pkg] -> Just pkg + _ -> error "Distribution.Simple.PackageIndex: multiple matches found" -- | Does a lookup by source package name. --- -lookupPackageName :: PackageIndex a -> PackageName - -> [(Version, [a])] +lookupPackageName + :: PackageIndex a + -> PackageName + -> [(Version, [a])] lookupPackageName index name = -- Do not match internal libraries case Map.lookup (name, LMainLibName) (packageIdIndex index) of - Nothing -> [] - Just pvers -> Map.toList pvers - + Nothing -> [] + Just pvers -> Map.toList pvers -- | Does a lookup by source package name and a range of versions. -- @@ -457,12 +487,14 @@ -- function on those; use 'lookupInternalDependency' instead. -- -- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. --- -lookupDependency :: InstalledPackageIndex -> PackageName -> VersionRange - -> [(Version, [IPI.InstalledPackageInfo])] +lookupDependency + :: InstalledPackageIndex + -> PackageName + -> VersionRange + -> [(Version, [IPI.InstalledPackageInfo])] lookupDependency index pn vr = - -- Yes, a little bit of a misnomer here! - lookupInternalDependency index pn vr LMainLibName + -- Yes, a little bit of a misnomer here! + lookupInternalDependency index pn vr LMainLibName -- | Does a lookup by source package name and a range of versions. -- @@ -470,30 +502,34 @@ -- satisfying the version range constraint. -- -- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. --- -lookupInternalDependency :: InstalledPackageIndex -> PackageName -> VersionRange - -> LibraryName - -> [(Version, [IPI.InstalledPackageInfo])] +lookupInternalDependency + :: InstalledPackageIndex + -> PackageName + -> VersionRange + -> 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') - ] - 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) - + Nothing -> [] + Just pvers -> + [ (ver, pkgs') + | (ver, pkgs) <- Map.toList pvers + , ver `withinRange` versionRange + , 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) -- + -- * Case insensitive name lookups + -- -- | Does a case-insensitive search by package name. @@ -507,42 +543,45 @@ -- have an ambiguous result, and we get back all the versions of all the -- packages. The list of ambiguous results is split by exact package name. So -- it is a non-empty list of non-empty lists. --- searchByName :: PackageIndex a -> String -> SearchResult [a] searchByName index name = -- Don't match internal packages - case [ pkgs | pkgs@((pname, LMainLibName),_) <- Map.toList (packageIdIndex index) - , lowercase (unPackageName pname) == lname ] of - [] -> None - [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) - pkgss -> case find ((mkPackageName name ==) . fst . fst) pkgss of - Just (_,pvers) -> Unambiguous (concat (Map.elems pvers)) - Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) - where lname = lowercase name + case [ pkgs | pkgs@((pname, LMainLibName), _) <- Map.toList (packageIdIndex index), lowercase (unPackageName pname) == lname + ] of + [] -> None + [(_, pvers)] -> Unambiguous (concat (Map.elems pvers)) + pkgss -> case find ((mkPackageName name ==) . fst . fst) pkgss of + Just (_, pvers) -> Unambiguous (concat (Map.elems pvers)) + Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) + where + lname = lowercase name data SearchResult a = None | Unambiguous a | Ambiguous [a] -- | Does a case-insensitive substring search by package name. -- -- That is, all packages that contain the given string in their name. --- searchByNameSubstring :: PackageIndex a -> String -> [a] searchByNameSubstring index searchterm = searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n) - where lsearchterm = lowercase searchterm + where + lsearchterm = lowercase searchterm -- | @since 3.4.0.0 searchWithPredicate :: PackageIndex a -> (String -> Bool) -> [a] searchWithPredicate index predicate = [ pkg - -- Don't match internal packages - | ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) + | -- Don't match internal packages + ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) , predicate (unPackageName pname) , pkgs <- Map.elems pvers - , pkg <- pkgs ] + , pkg <- pkgs + ] -- + -- * Special queries + -- -- None of the stuff below depends on the internal representation of the index. @@ -554,27 +593,30 @@ -- This actually computes the strongly connected components. So it gives us a -- list of groups of packages where within each group they all depend on each -- other, directly or indirectly. --- dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]] dependencyCycles index = - [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] + [vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList] where - adjacencyList = [ (pkg, installedUnitId pkg, installedDepends pkg) - | pkg <- allPackages index ] - + adjacencyList = + [ (pkg, installedUnitId pkg, installedDepends pkg) + | pkg <- allPackages index + ] -- | All packages that have immediate dependencies that are not in the index. -- -- Returns such packages along with the dependencies that they're missing. --- -brokenPackages :: PackageInstalled a => PackageIndex a - -> [(a, [UnitId])] +brokenPackages + :: PackageInstalled a + => PackageIndex a + -> [(a, [UnitId])] brokenPackages index = [ (pkg, missing) - | pkg <- allPackages index - , let missing = [ pkg' | pkg' <- installedDepends pkg - , isNothing (lookupUnitId index pkg') ] - , not (null missing) ] + | pkg <- allPackages index + , let missing = + [ pkg' | pkg' <- installedDepends pkg, isNothing (lookupUnitId index pkg') + ] + , not (null missing) + ] -- | Tries to take the transitive closure of the package dependencies. -- @@ -583,78 +625,89 @@ -- -- * Note that if the result is @Right []@ it is because at least one of -- the original given 'PackageId's do not occur in the index. --- -dependencyClosure :: InstalledPackageIndex - -> [UnitId] - -> Either (InstalledPackageIndex) - [(IPI.InstalledPackageInfo, [UnitId])] +dependencyClosure + :: InstalledPackageIndex + -> [UnitId] + -> Either + (InstalledPackageIndex) + [(IPI.InstalledPackageInfo, [UnitId])] dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of (completed, []) -> Left completed - (completed, _) -> Right (brokenPackages completed) - where - closure completed failed [] = (completed, failed) - closure completed failed (pkgid:pkgids) = case lookupUnitId index pkgid of - Nothing -> closure completed (pkgid:failed) pkgids - Just pkg -> case lookupUnitId completed (installedUnitId pkg) of - Just _ -> closure completed failed pkgids + (completed, _) -> Right (brokenPackages completed) + where + closure completed failed [] = (completed, failed) + closure completed failed (pkgid : pkgids) = case lookupUnitId index pkgid of + Nothing -> closure completed (pkgid : failed) pkgids + Just pkg -> case lookupUnitId completed (installedUnitId pkg) of + Just _ -> closure completed failed pkgids Nothing -> closure completed' failed pkgids' - where completed' = insert pkg completed - pkgids' = installedDepends pkg ++ pkgids + where + completed' = insert pkg completed + pkgids' = installedDepends pkg ++ pkgids -- | Takes the transitive closure of the packages reverse dependencies. -- -- * The given 'PackageId's must be in the index. --- -reverseDependencyClosure :: PackageInstalled a => PackageIndex a - -> [UnitId] - -> [a] +reverseDependencyClosure + :: PackageInstalled a + => PackageIndex a + -> [UnitId] + -> [a] reverseDependencyClosure index = - map vertexToPkg - . concatMap Tree.flatten - . Graph.dfs reverseDepGraph - . map (fromMaybe noSuchPkgId . pkgIdToVertex) - + map vertexToPkg + . concatMap Tree.flatten + . Graph.dfs reverseDepGraph + . map (fromMaybe noSuchPkgId . pkgIdToVertex) where (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index reverseDepGraph = Graph.transposeG depGraph noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" topologicalOrder :: PackageInstalled a => PackageIndex a -> [a] -topologicalOrder index = map toPkgId - . Graph.topSort - $ graph - where (graph, toPkgId, _) = dependencyGraph index +topologicalOrder index = + map toPkgId + . Graph.topSort + $ graph + where + (graph, toPkgId, _) = dependencyGraph index reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a] -reverseTopologicalOrder index = map toPkgId - . Graph.topSort - . Graph.transposeG - $ graph - where (graph, toPkgId, _) = dependencyGraph index +reverseTopologicalOrder index = + map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where + (graph, toPkgId, _) = dependencyGraph index -- | Builds a graph of the package dependencies. -- -- Dependencies on other packages that are not in the index are discarded. -- You can check if there are any such dependencies with 'brokenPackages'. --- -dependencyGraph :: PackageInstalled a => PackageIndex a - -> (Graph.Graph, - Graph.Vertex -> a, - UnitId -> Maybe Graph.Vertex) +dependencyGraph + :: PackageInstalled a + => PackageIndex a + -> ( Graph.Graph + , Graph.Vertex -> a + , UnitId -> Maybe Graph.Vertex + ) dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex) where - graph = Array.listArray bounds - [ [ v | Just v <- map id_to_vertex (installedDepends pkg) ] - | pkg <- pkgs ] + graph = + Array.listArray + bounds + [ [v | Just v <- map id_to_vertex (installedDepends pkg)] + | pkg <- pkgs + ] - pkgs = sortBy (comparing packageId) (allPackages index) - vertices = zip (map installedUnitId pkgs) [0..] - vertex_map = Map.fromList vertices + pkgs = sortBy (comparing packageId) (allPackages index) + vertices = zip (map installedUnitId pkgs) [0 ..] + vertex_map = Map.fromList vertices id_to_vertex pid = Map.lookup pid vertex_map vertex_to_pkg vertex = pkgTable ! vertex - pkgTable = Array.listArray bounds pkgs + pkgTable = Array.listArray bounds pkgs topBound = length pkgs - 1 bounds = (0, topBound) @@ -671,29 +724,36 @@ -- Each element in the result is a package name along with the packages that -- depend on it and the versions they require. These are guaranteed to be -- distinct. --- -dependencyInconsistencies :: InstalledPackageIndex - -- At DepUniqueKey... - -> [(DepUniqueKey, - -- There were multiple packages (BAD!) - [(UnitId, - -- And here are the packages which - -- immediately depended on it - [IPI.InstalledPackageInfo])])] +dependencyInconsistencies + :: InstalledPackageIndex + -- At DepUniqueKey... + -> [ ( DepUniqueKey + , -- There were multiple packages (BAD!) + [ ( UnitId + , -- And here are the packages which + -- immediately depended on it + [IPI.InstalledPackageInfo] + ) + ] + ) + ] dependencyInconsistencies index = do - (dep_key, insts_map) <- Map.toList inverseIndex - let insts = Map.toList insts_map - guard (length insts >= 2) - return (dep_key, insts) + (dep_key, insts_map) <- Map.toList inverseIndex + let insts = Map.toList insts_map + guard (length insts >= 2) + return (dep_key, insts) where inverseIndex :: Map DepUniqueKey (Map UnitId [IPI.InstalledPackageInfo]) inverseIndex = Map.fromListWith (Map.unionWith (++)) $ do - pkg <- allPackages index - dep_ipid <- installedDepends pkg - Just dep <- [lookupUnitId index dep_ipid] - let dep_key = (packageName dep, IPI.sourceLibName dep, - Map.fromList (IPI.instantiatedWith dep)) - return (dep_key, Map.singleton dep_ipid [pkg]) + pkg <- allPackages index + dep_ipid <- installedDepends pkg + Just dep <- [lookupUnitId index dep_ipid] + let dep_key = + ( packageName dep + , IPI.sourceLibName dep + , Map.fromList (IPI.instantiatedWith dep) + ) + return (dep_key, Map.singleton dep_ipid [pkg]) -- | A rough approximation of GHC's module finder, takes a -- 'InstalledPackageIndex' and turns it into a map from module names to their @@ -705,12 +765,14 @@ pkg <- allPackages index IPI.ExposedModule m reexport <- IPI.exposedModules pkg case reexport of - Nothing -> return (m, [pkg]) - Just (OpenModuleVar _) -> [] - Just (OpenModule _ m') | m == m' -> [] - | otherwise -> return (m', [pkg]) - -- The heuristic is this: we want to prefer the original package - -- which originally exported a module. However, if a reexport - -- also *renamed* the module (m /= m'), then we have to use the - -- downstream package, since the upstream package has the wrong - -- module name! + Nothing -> return (m, [pkg]) + Just (OpenModuleVar _) -> [] + Just (OpenModule _ m') + | m == m' -> [] + | otherwise -> return (m', [pkg]) + +-- The heuristic is this: we want to prefer the original package +-- which originally exported a module. However, if a reexport +-- also *renamed* the module (m /= m'), then we have to use the +-- downstream package, since the upstream package has the wrong +-- module name! 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 @@ -2,840 +2,921 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- --- | --- Module : Distribution.Simple.PreProcess --- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defines a 'PreProcessor' abstraction which represents a pre-processor --- that can transform one kind of file into another. There is also a --- 'PPSuffixHandler' which is a combination of a file extension and a function --- for configuring a 'PreProcessor'. It defines a bunch of known built-in --- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and --- lists them in 'knownSuffixHandlers'. On top of this it provides a function --- for actually preprocessing some sources given a bunch of known suffix --- handlers. This module is not as good as it could be, it could really do with --- a rewrite to address some of the problems we have with pre-processors. - -module Distribution.Simple.PreProcess (preprocessComponent, preprocessExtras, - knownSuffixHandlers, ppSuffixes, - PPSuffixHandler, PreProcessor(..), - mkSimplePreProcessor, runSimplePreProcessor, - ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, - ppHappy, ppAlex, ppUnlit, platformDefines, - unsorted - ) - where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Compat.Stack - -import Distribution.Simple.PreProcess.Unlit -import Distribution.Backpack.DescribeUnitId -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName -import Distribution.ModuleName (ModuleName) -import Distribution.PackageDescription as PD -import qualified Distribution.InstalledPackageInfo as Installed -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.CCompiler -import Distribution.Simple.Compiler -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Simple.Program -import Distribution.Simple.Program.ResponseFile -import Distribution.Simple.Test.LibV09 -import Distribution.System -import Distribution.Types.PackageName.Magic -import Distribution.Pretty -import Distribution.Version -import Distribution.Verbosity -import Distribution.Utils.Path - -import System.Directory (doesFileExist, doesDirectoryExist) -import System.Info (os, arch) -import System.FilePath (splitExtension, dropExtensions, (), (<.>), - takeDirectory, normalise, replaceExtension, - takeExtensions) - --- |The interface to a preprocessor, which may be implemented using an --- external program, but need not be. The arguments are the name of --- the input file, the name of the output file and a verbosity level. --- Here is a simple example that merely prepends a comment to the given --- source file: --- --- > ppTestHandler :: PreProcessor --- > ppTestHandler = --- > PreProcessor { --- > platformIndependent = True, --- > 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 --- --- 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 --- dirs that this file was found in. The output base dir is the build dir where --- all the generated source files are put. --- --- The reason for splitting it up this way is that some pre-processors don't --- simply generate one output .hs file from one input file but have --- dependencies on other generated files (notably c2hs, where building one --- .hs file may require reading other .chi files, and then compiling the .hs --- file may require reading a generated .h file). In these cases the generated --- files need to embed relative path names to each other (eg the generated .hs --- file mentions the .h file in the FFI imports). This path must be relative to --- the base directory where the generated files are located, it cannot be --- relative to the top level of the build tree because the compilers do not --- look for .h files relative to there, ie we do not use \"-I .\", instead we --- use \"-I dist\/build\" (or whatever dist dir has been set by the user) --- --- Most pre-processors do not care of course, so mkSimplePreProcessor and --- runSimplePreProcessor functions handle the simple case. --- -data PreProcessor = PreProcessor { - - -- Is the output of the pre-processor platform independent? eg happy output - -- is portable haskell but c2hs's output is platform dependent. - -- This matters since only platform independent generated code can be - -- included into a source tarball. - platformIndependent :: Bool, - - -- TODO: deal with pre-processors that have implementation dependent output - -- eg alex and happy have --ghc flags. However we can't really include - -- ghc-specific code into supposedly portable source tarballs. - - -- | This function can reorder /all/ modules, not just those that the - -- require the preprocessor in question. As such, this function should be - -- well-behaved and not reorder modules it doesn't have dominion over! - -- - -- @since 3.8.1.0 - ppOrdering :: Verbosity - -> [FilePath] -- Source directories - -> [ModuleName] -- Module names - -> IO [ModuleName], -- Sorted modules - - runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir - -> (FilePath, FilePath) -- Output file name, relative to an output base dir - -> Verbosity -- verbosity - -> IO () -- Should exit if the preprocessor fails - } - --- | Just present the modules in the order given; this is the default and it is --- appropriate for preprocessors which do not have any sort of dependencies --- between modules. -unsorted :: Verbosity - -> [FilePath] - -> [ModuleName] - -> IO [ModuleName] -unsorted _ _ ms = pure ms - --- | Function to determine paths to possible extra C sources for a --- preprocessor: just takes the path to the build directory and uses --- this to search for C sources with names that match the --- preprocessor's output name format. -type PreProcessorExtras = FilePath -> IO [FilePath] - - -mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) - -> (FilePath, FilePath) - -> (FilePath, FilePath) -> Verbosity -> IO () -mkSimplePreProcessor simplePP - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity - where inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) - -runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity - -> IO () -runSimplePreProcessor pp inFile outFile verbosity = - runPreProcessor pp (".", inFile) (".", outFile) verbosity - --- |A preprocessor for turning non-Haskell files with the given extension --- into plain Haskell source files. -type PPSuffixHandler - = (String, BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor) - --- | Apply preprocessors to the sources from 'hsSourceDirs' for a given --- component (lib, exe, or test suite). --- --- XXX: This is terrible -preprocessComponent :: PackageDescription - -> Component - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Bool - -> Verbosity - -> [PPSuffixHandler] - -> IO () -preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = - -- Skip preprocessing for scripts since they should be regular Haskell files, - -- but may have no or unknown extensions. - when (package pd /= fakePackageId) $ do - -- NB: never report instantiation here; we'll report it properly when - -- building. - setupMessage' verbosity "Preprocessing" (packageId pd) - (componentLocalName clbi) (Nothing :: Maybe [(ModuleName, Module)]) - case comp of - (CLib lib@Library{ libBuildInfo = bi }) -> do - let dirs = map getSymbolicPath (hsSourceDirs bi) ++ - [ autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi] - let hndlrs = localHandlers bi - mods <- orderingFromHandlers verbosity dirs hndlrs (allLibModules lib clbi) - for_ (map ModuleName.toFilePath mods) $ - pre dirs (componentBuildDir lbi clbi) hndlrs - (CFLib flib@ForeignLib { foreignLibBuildInfo = bi, foreignLibName = nm }) -> do - let nm' = unUnqualComponentName nm - let flibDir = buildDir lbi nm' nm' ++ "-tmp" - dirs = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi] - let hndlrs = localHandlers bi - mods <- orderingFromHandlers verbosity dirs hndlrs (foreignLibModules flib) - for_ (map ModuleName.toFilePath mods) $ - pre dirs flibDir hndlrs - (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do - let nm' = unUnqualComponentName nm - let exeDir = buildDir lbi nm' nm' ++ "-tmp" - dirs = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi] - let hndlrs = localHandlers bi - mods <- orderingFromHandlers verbosity dirs hndlrs (otherModules bi) - for_ (map ModuleName.toFilePath mods) $ - pre dirs exeDir hndlrs - pre (map getSymbolicPath (hsSourceDirs bi)) exeDir (localHandlers bi) $ - dropExtensions (modulePath exe) - CTest test@TestSuite{ testName = nm } -> do - let nm' = unUnqualComponentName nm - case testInterface test of - TestSuiteExeV10 _ f -> - preProcessTest test f $ buildDir lbi nm' nm' ++ "-tmp" - TestSuiteLibV09 _ _ -> do - let testDir = buildDir lbi stubName test - stubName test ++ "-tmp" - writeSimpleTestStub test testDir - preProcessTest test (stubFilePath test) testDir - TestSuiteUnsupported tt -> - die' verbosity $ "No support for preprocessing test " - ++ "suite type " ++ prettyShow tt - CBench bm@Benchmark{ benchmarkName = nm } -> do - let nm' = unUnqualComponentName nm - case benchmarkInterface bm of - BenchmarkExeV10 _ f -> - preProcessBench bm f $ buildDir lbi nm' nm' ++ "-tmp" - BenchmarkUnsupported tt -> - die' verbosity $ "No support for preprocessing benchmark " - ++ "type " ++ prettyShow tt - where - orderingFromHandlers v d hndlrs mods = - foldM (\acc (_,pp) -> ppOrdering pp v d acc) mods hndlrs - builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"] - builtinCSuffixes = cSourceExtensions - builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes - localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers] - pre dirs dir lhndlrs fp = - preprocessFile (map unsafeMakeSymbolicPath dirs) dir isSrcDist fp verbosity builtinSuffixes lhndlrs True - preProcessTest test = preProcessComponent (testBuildInfo test) - (testModules test) - preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm) - (benchmarkModules bm) - - preProcessComponent - :: BuildInfo - -> [ModuleName] - -> FilePath - -> FilePath - -> IO () - preProcessComponent bi modules exePath dir = do - let biHandlers = localHandlers bi - sourceDirs = map getSymbolicPath (hsSourceDirs bi) ++ [ autogenComponentModulesDir lbi clbi - , autogenPackageModulesDir lbi ] - sequence_ [ preprocessFile (map unsafeMakeSymbolicPath sourceDirs) dir isSrcDist - (ModuleName.toFilePath modu) verbosity builtinSuffixes - biHandlers False - | modu <- modules ] - -- XXX: what we do here (re SymbolicPath dir) - -- XXX: 2020-10-15 do we rely here on CWD being the PackageDir? - -- Note we don't fail on missing in this case, because the main file may be generated later (i.e. by a test code generator) - preprocessFile (unsafeMakeSymbolicPath dir : hsSourceDirs bi) dir isSrcDist - (dropExtensions $ exePath) verbosity - builtinSuffixes biHandlers False - ---TODO: try to list all the modules that could not be found --- not just the first one. It's annoying and slow due to the need --- to reconfigure after editing the .cabal file each time. - --- | Find the first extension of the file that exists, and preprocess it --- if required. -preprocessFile - :: [SymbolicPath PackageDir SourceDir] -- ^ source directories - - -> FilePath -- ^build directory - -> Bool -- ^preprocess for sdist - -> FilePath -- ^module file name - -> Verbosity -- ^verbosity - -> [String] -- ^builtin suffixes - -> [(String, PreProcessor)] -- ^possible preprocessors - -> Bool -- ^fail on missing file - -> IO () -preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do - -- look for files in the various source dirs with this module name - -- and a file extension of a known preprocessor - psrcFiles <- findFileWithExtension' (map fst handlers) (map getSymbolicPath searchLoc) baseFile - case psrcFiles of - -- no preprocessor file exists, look for an ordinary source file - -- just to make sure one actually exists at all for this module. - -- Note: by looking in the target/output build dir too, we allow - -- source files to appear magically in the target build dir without - -- any corresponding "real" source file. This lets custom Setup.hs - -- files generate source modules directly into the build dir without - -- the rest of the build system being aware of it (somewhat dodgy) - Nothing -> do - bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : map getSymbolicPath searchLoc) baseFile - case (bsrcFiles, failOnMissing) of - (Nothing, True) -> - die' verbosity $ "can't find source for " ++ baseFile - ++ " in " ++ intercalate ", " (map getSymbolicPath searchLoc) - _ -> return () - -- found a pre-processable file in one of the source dirs - Just (psrcLoc, psrcRelFile) -> do - let (srcStem, ext) = splitExtension psrcRelFile - psrcFile = psrcLoc psrcRelFile - pp = fromMaybe (error "Distribution.Simple.PreProcess: Just expected") - (lookup (safeTail ext) handlers) - -- Preprocessing files for 'sdist' is different from preprocessing - -- for 'build'. When preprocessing for sdist we preprocess to - -- avoid that the user has to have the preprocessors available. - -- ATM, we don't have a way to specify which files are to be - -- preprocessed and which not, so for sdist we only process - -- platform independent files and put them into the 'buildLoc' - -- (which we assume is set to the temp. directory that will become - -- the tarball). - --TODO: eliminate sdist variant, just supply different handlers - when (not forSDist || forSDist && platformIndependent pp) $ do - -- look for existing pre-processed source file in the dest dir to - -- see if we really have to re-run the preprocessor. - ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile - recomp <- case ppsrcFiles of - Nothing -> return True - Just ppsrcFile -> - psrcFile `moreRecentFile` ppsrcFile - when recomp $ do - let destDir = buildLoc dirName srcStem - createDirectoryIfMissingVerbose verbosity True destDir - runPreProcessorWithHsBootHack pp - (psrcLoc, psrcRelFile) - (buildLoc, srcStem <.> "hs") - - where - dirName = takeDirectory - - -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files - -- be in the same place as the hs files, so if we put the hs file in dist/ - -- then we need to copy the hs-boot file there too. This should probably be - -- done another way. Possibly we should also be looking for .lhs-boot - -- files, but I think that preprocessors only produce .hs files. - runPreProcessorWithHsBootHack pp - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) = do - runPreProcessor pp - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity - - exists <- doesFileExist inBoot - when exists $ copyFileVerbose verbosity inBoot outBoot - - where - inBoot = replaceExtension inFile "hs-boot" - outBoot = replaceExtension outFile "hs-boot" - - inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) - --- ------------------------------------------------------------ --- * known preprocessors --- ------------------------------------------------------------ - -ppGreenCard :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppGreenCard _ lbi _ - = PreProcessor { - platformIndependent = False, - ppOrdering = unsorted, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - runDbProgram verbosity 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 -ppUnlit = - PreProcessor { - platformIndependent = True, - ppOrdering = unsorted, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - withUTF8FileContents inFile $ \contents -> - either (writeUTF8File outFile) (die' verbosity) (unlit inFile contents) - } - -ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppCpp = ppCpp' [] - -ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppCpp' extraArgs bi lbi clbi = - case compilerFlavor (compiler lbi) of - GHC -> ppGhcCpp ghcProgram (const True) args bi lbi clbi - GHCJS -> ppGhcCpp ghcjsProgram (const True) args bi lbi clbi - _ -> ppCpphs args bi lbi clbi - where cppArgs = getCppOptions bi lbi - args = cppArgs ++ extraArgs - -ppGhcCpp :: Program -> (Version -> Bool) - -> [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppGhcCpp program xHs extraArgs _bi lbi clbi = - PreProcessor { - platformIndependent = False, - ppOrdering = unsorted, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (prog, version, _) <- requireProgramVersion verbosity - program anyVersion (withPrograms lbi) - runProgram verbosity prog $ - ["-E", "-cpp"] - -- This is a bit of an ugly hack. We're going to - -- unlit the file ourselves later on if appropriate, - -- so we need GHC not to unlit it now or it'll get - -- double-unlitted. In the future we might switch to - -- using cpphs --unlit instead. - ++ (if xHs version then ["-x", "hs"] else []) - ++ [ "-optP-include", "-optP"++ (autogenComponentModulesDir lbi clbi cppHeaderName) ] - ++ ["-o", outFile, inFile] - ++ extraArgs - } - -ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppCpphs extraArgs _bi lbi clbi = - PreProcessor { - platformIndependent = False, - ppOrdering = unsorted, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity - cpphsProgram anyVersion (withPrograms lbi) - runProgram verbosity cpphsProg $ - ("-O" ++ outFile) : inFile - : "--noline" : "--strip" - : (if cpphsVersion >= mkVersion [1,6] - then ["--include="++ (autogenComponentModulesDir lbi clbi cppHeaderName)] - else []) - ++ extraArgs - } - -ppHsc2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppHsc2hs bi lbi clbi = - PreProcessor { - platformIndependent = False, - ppOrdering = unsorted, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - (hsc2hsProg, hsc2hsVersion, _) <- requireProgramVersion verbosity - hsc2hsProgram anyVersion (withPrograms lbi) - -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122. - let isCross = hostPlatform lbi /= buildPlatform - prependCrossFlags = if isCross then ("-x":) else id - let hsc2hsSupportsResponseFiles = hsc2hsVersion >= mkVersion [0,68,4] - pureArgs = genPureArgs hsc2hsVersion gccProg inFile outFile - if hsc2hsSupportsResponseFiles - then withResponseFile - verbosity - defaultTempFileOptions - (takeDirectory outFile) - "hsc2hs-response.txt" - Nothing - pureArgs - (\responseFileName -> - runProgram verbosity hsc2hsProg (prependCrossFlags ["@"++ responseFileName])) - else runProgram verbosity hsc2hsProg (prependCrossFlags pureArgs) - } - where - -- Returns a list of command line arguments that can either be passed - -- 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 <- 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" ++ dir | dir <- PD.includeDirs bi ] - ++ [ "--cflag=-I" ++ buildDir lbi dir | dir <- 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" ++ autogenComponentModulesDir lbi clbi, - "-I" ++ autogenPackageModulesDir lbi, - "-include", autogenComponentModulesDir lbi clbi cppHeaderName ] ] - ++ [ "--lflag=-L" ++ opt - | opt <- - if withFullyStaticExe lbi - then PD.extraLibDirsStatic bi - else PD.extraLibDirs bi - ] - ++ [ "--lflag=-Wl,-R," ++ 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 ] - ++ [ opt | opt <- 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 - ] - ++ [ opt | opt <- Installed.ldOptions pkg ] ] - ++ preccldFlags - ++ hsc2hsOptions bi - ++ postccldFlags - - ++ ["-o", outFile, inFile] - where - -- hsc2hs flag parsing was wrong - -- (see -- https://github.com/haskell/hsc2hs/issues/35) - -- so we need to put -- --cc/--ld *after* hsc2hsOptions, - -- for older hsc2hs (pre 0.68.8) so that they can be overridden. - ccldFlags = - [ "--cc=" ++ programPath gccProg - , "--ld=" ++ programPath gccProg - ] - - (preccldFlags, postccldFlags) - | hsc2hsVersion >= mkVersion [0,68,8] = (ccldFlags, []) - | otherwise = ([], ccldFlags) - - hacked_index = packageHacks (installedPkgs lbi) - -- Look only at the dependencies of the current component - -- being built! This relies on 'installedPkgs' maintaining - -- 'InstalledPackageInfo' for internal deps too; see #2971. - pkgs = PackageIndex.topologicalOrder $ - case PackageIndex.dependencyClosure hacked_index - (map fst (componentPackageDeps clbi)) of - Left index' -> index' - Right inf -> - error ("ppHsc2hs: broken closure: " ++ show inf) - isOSX = case buildOS of OSX -> True; _ -> False - isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True; - packageHacks = case compilerFlavor (compiler lbi) of - GHC -> hackRtsPackage - GHCJS -> hackRtsPackage - _ -> id - -- We don't link in the actual Haskell libraries of our dependencies, so - -- the -u flags in the ldOptions of the rts package mean linking fails on - -- OS X (its ld is a tad stricter than gnu ld). Thus we remove the - -- ldOptions for GHC's rts package: - hackRtsPackage index = - case PackageIndex.lookupPackageName index (mkPackageName "rts") of - [(_, [rts])] - -> PackageIndex.insert rts { Installed.ldOptions = [] } index - _ -> error "No (or multiple) ghc rts package is registered!!" - -ppHsc2hsExtras :: PreProcessorExtras -ppHsc2hsExtras buildBaseDir = filter ("_hsc.c" `isSuffixOf`) `fmap` - getDirectoryContentsRecursive buildBaseDir - -ppC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppC2hs bi lbi clbi = - PreProcessor { - platformIndependent = False, - ppOrdering = unsorted, - runPreProcessor = \(inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity -> do - (c2hsProg, _, _) <- requireProgramVersion verbosity - c2hsProgram (orLaterVersion (mkVersion [0,15])) - (withPrograms lbi) - (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - runProgram verbosity c2hsProg $ - - -- Options from the current package: - [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] - ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ] - ++ [ "--cppopts=-include" ++ (autogenComponentModulesDir lbi clbi cppHeaderName) ] - ++ [ "--include=" ++ outBaseDir ] - - -- Options from dependent packages - ++ [ "--cppopts=" ++ opt - | pkg <- pkgs - , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] - ++ [ opt | opt@('-':c:_) <- Installed.ccOptions pkg - -- c2hs 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 Installed.cxxOptions unless this changes! - , c `elem` "DIU" ] ] - --TODO: install .chi files for packages, so we can --include - -- those dirs here, for the dependencies - - -- input and output files - ++ [ "--output-dir=" ++ outBaseDir - , "--output=" ++ outRelativeFile - , inBaseDir inRelativeFile ] - } - where - pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) - -ppC2hsExtras :: PreProcessorExtras -ppC2hsExtras d = filter (\p -> takeExtensions p == ".chs.c") `fmap` - getDirectoryContentsRecursive d - ---TODO: perhaps use this with hsc2hs too ---TODO: remove cc-options from cpphs for cabal-version: >= 1.10 ---TODO: Refactor and add separate getCppOptionsForHs, getCppOptionsForCxx, & getCppOptionsForC --- instead of combining all these cases in a single function. This blind combination can --- potentially lead to compilation inconsistencies. -getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] -getCppOptions bi lbi - = platformDefines lbi - ++ cppOptions bi - ++ ["-I" ++ dir | dir <- PD.includeDirs bi] - ++ [opt | opt@('-':c:_) <- PD.ccOptions bi ++ PD.cxxOptions bi, c `elem` "DIU"] - -platformDefines :: LocalBuildInfo -> [String] -platformDefines lbi = - case compilerFlavor comp of - GHC -> - ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++ - ["-D" ++ os ++ "_BUILD_OS=1"] ++ - ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ - map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ - map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr - GHCJS -> - compatGlasgowHaskell ++ - ["-D__GHCJS__=" ++ versionInt version] ++ - ["-D" ++ os ++ "_BUILD_OS=1"] ++ - ["-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 - Platform hostArch hostOS = hostPlatform lbi - version = compilerVersion comp - compatGlasgowHaskell = - maybe [] (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v]) - (compilerCompatVersion GHC comp) - -- TODO: move this into the compiler abstraction - -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all - -- the other compilers. Check if that's really what they want. - versionInt :: Version -> String - versionInt v = case versionNumbers v of - [] -> "1" - [n] -> show n - n1:n2:_ -> - -- 6.8.x -> 608 - -- 6.10.x -> 610 - let s1 = show n1 - s2 = show n2 - middle = case s2 of - _ : _ : _ -> "" - _ -> "0" - in s1 ++ middle ++ s2 - - osStr = case hostOS of - Linux -> ["linux"] - Windows -> ["mingw32"] - OSX -> ["darwin"] - FreeBSD -> ["freebsd"] - OpenBSD -> ["openbsd"] - NetBSD -> ["netbsd"] - DragonFly -> ["dragonfly"] - Solaris -> ["solaris2"] - AIX -> ["aix"] - HPUX -> ["hpux"] - IRIX -> ["irix"] - HaLVM -> [] - IOS -> ["ios"] - Android -> ["android"] - Ghcjs -> ["ghcjs"] - Wasi -> ["wasi"] - Hurd -> ["hurd"] - OtherOS _ -> [] - archStr = case hostArch of - I386 -> ["i386"] - X86_64 -> ["x86_64"] - PPC -> ["powerpc"] - PPC64 -> ["powerpc64"] - Sparc -> ["sparc"] - Arm -> ["arm"] - AArch64 -> ["aarch64"] - Mips -> ["mips"] - SH -> [] - IA64 -> ["ia64"] - S390 -> ["s390"] - S390X -> ["s390x"] - Alpha -> ["alpha"] - Hppa -> ["hppa"] - Rs6000 -> ["rs6000"] - M68k -> ["m68k"] - Vax -> ["vax"] - JavaScript -> ["javascript"] - Wasm32 -> ["wasm32"] - OtherArch _ -> [] - -ppHappy :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppHappy _ lbi _ = pp { platformIndependent = True } - where pp = standardPP lbi happyProgram (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-agc"] - hcFlags GHCJS = ["-agc"] - hcFlags _ = [] - -ppAlex :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppAlex _ lbi _ = pp { platformIndependent = True } - where pp = standardPP lbi alexProgram (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-g"] - hcFlags GHCJS = ["-g"] - hcFlags _ = [] - -standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor -standardPP lbi prog args = - PreProcessor { - platformIndependent = False, - ppOrdering = unsorted, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - runDbProgram verbosity prog (withPrograms lbi) - (args ++ ["-o", outFile, inFile]) - } - --- |Convenience function; get the suffixes of these preprocessors. -ppSuffixes :: [ PPSuffixHandler ] -> [String] -ppSuffixes = map fst - --- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. -knownSuffixHandlers :: [ PPSuffixHandler ] -knownSuffixHandlers = - [ ("gc", ppGreenCard) - , ("chs", ppC2hs) - , ("hsc", ppHsc2hs) - , ("x", ppAlex) - , ("y", ppHappy) - , ("ly", ppHappy) - , ("cpphs", ppCpp) - ] - --- |Standard preprocessors with possible extra C sources: c2hs, hsc2hs. -knownExtrasHandlers :: [ PreProcessorExtras ] -knownExtrasHandlers = [ ppC2hsExtras, ppHsc2hsExtras ] - --- | Find any extra C sources generated by preprocessing that need to --- be added to the component (addresses issue #238). -preprocessExtras :: Verbosity - -> Component - -> LocalBuildInfo - -> IO [FilePath] -preprocessExtras verbosity comp lbi = case comp of - CLib _ -> pp $ buildDir lbi - (CExe Executable { exeName = nm }) -> do - let nm' = unUnqualComponentName nm - pp $ buildDir lbi nm' nm' ++ "-tmp" - (CFLib ForeignLib { foreignLibName = nm }) -> do - let nm' = unUnqualComponentName nm - pp $ buildDir lbi nm' nm' ++ "-tmp" - CTest test -> do - let nm' = unUnqualComponentName $ testName test - case testInterface test of - TestSuiteExeV10 _ _ -> - pp $ buildDir lbi nm' nm' ++ "-tmp" - TestSuiteLibV09 _ _ -> - pp $ buildDir lbi stubName test stubName test ++ "-tmp" - TestSuiteUnsupported tt -> - die' verbosity $ "No support for preprocessing test suite type " ++ - prettyShow tt - CBench bm -> do - let nm' = unUnqualComponentName $ benchmarkName bm - case benchmarkInterface bm of - BenchmarkExeV10 _ _ -> - pp $ buildDir lbi nm' nm' ++ "-tmp" - BenchmarkUnsupported tt -> - die' verbosity $ "No support for preprocessing benchmark " - ++ "type " ++ prettyShow tt - where - pp :: FilePath -> IO [FilePath] - pp dir = do - b <- doesDirectoryExist dir - if b - then (map (dir ) . filter not_sub . concat) - <$> for knownExtrasHandlers - (withLexicalCallStack (\f -> f dir)) - else pure [] - -- TODO: This is a terrible hack to work around #3545 while we don't - -- reorganize the directory layout. Basically, for the main - -- library, we might accidentally pick up autogenerated sources for - -- our subcomponents, because they are all stored as subdirectories - -- in dist/build. This is a cheap and cheerful check to prevent - -- this from happening. It is not particularly correct; for example - -- if a user has a test suite named foobar and puts their C file in - -- foobar/foo.c, this test will incorrectly exclude it. But I - -- didn't want to break BC... - not_sub p = and [ not (pre `isPrefixOf` p) | pre <- component_dirs ] - component_dirs = component_names (localPkgDescr lbi) - -- TODO: libify me - component_names pkg_descr = fmap unUnqualComponentName $ - mapMaybe (libraryNameString . libName) (subLibraries pkg_descr) ++ - map exeName (executables pkg_descr) ++ - map testName (testSuites pkg_descr) ++ - map benchmarkName (benchmarks pkg_descr) + +-- | +-- Module : Distribution.Simple.PreProcess +-- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module defines 'PPSuffixHandler', which is a combination of a file +-- extension and a function for configuring a 'PreProcessor'. It also defines +-- a bunch of known built-in preprocessors like @cpp@, @cpphs@, @c2hs@, +-- @hsc2hs@, @happy@, @alex@ etc and lists them in 'knownSuffixHandlers'. +-- On top of this it provides a function for actually preprocessing some sources +-- given a bunch of known suffix handlers. +-- This module is not as good as it could be, it could really do with a rewrite +-- to address some of the problems we have with pre-processors. +module Distribution.Simple.PreProcess + ( preprocessComponent + , preprocessExtras + , knownSuffixHandlers + , ppSuffixes + , PPSuffixHandler + , Suffix (..) + , builtinHaskellSuffixes + , builtinHaskellBootSuffixes + , PreProcessor (..) + , mkSimplePreProcessor + , runSimplePreProcessor + , ppCpp + , ppCpp' + , ppGreenCard + , ppC2hs + , ppHsc2hs + , ppHappy + , ppAlex + , ppUnlit + , platformDefines + , unsorted + ) +where + +import Distribution.Compat.Prelude +import Distribution.Compat.Stack +import Prelude () + +import Distribution.Backpack.DescribeUnitId +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Package +import Distribution.PackageDescription as PD +import Distribution.Simple.BuildPaths +import Distribution.Simple.CCompiler +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.LocalBuildInfo +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess.Types +import Distribution.Simple.PreProcess.Unlit +import Distribution.Simple.Program +import Distribution.Simple.Program.ResponseFile +import Distribution.Simple.Test.LibV09 +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.PackageName.Magic +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath + ( dropExtensions + , normalise + , replaceExtension + , splitExtension + , takeDirectory + , takeExtensions + , (<.>) + , () + ) +import System.Info (arch, os) + +-- | Just present the modules in the order given; this is the default and it is +-- appropriate for preprocessors which do not have any sort of dependencies +-- between modules. +unsorted + :: Verbosity + -> [FilePath] + -> [ModuleName] + -> IO [ModuleName] +unsorted _ _ ms = pure ms + +-- | Function to determine paths to possible extra C sources for a +-- preprocessor: just takes the path to the build directory and uses +-- this to search for C sources with names that match the +-- preprocessor's output name format. +type PreProcessorExtras = FilePath -> IO [FilePath] + +mkSimplePreProcessor + :: (FilePath -> FilePath -> Verbosity -> IO ()) + -> (FilePath, FilePath) + -> (FilePath, FilePath) + -> Verbosity + -> IO () +mkSimplePreProcessor + simplePP + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) + verbosity = simplePP inFile outFile verbosity + where + inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +runSimplePreProcessor + :: PreProcessor + -> FilePath + -> FilePath + -> Verbosity + -> IO () +runSimplePreProcessor pp inFile outFile verbosity = + runPreProcessor pp (".", inFile) (".", outFile) verbosity + +-- | A preprocessor for turning non-Haskell files with the given 'Suffix' +-- (i.e. file extension) into plain Haskell source files. +type PPSuffixHandler = + (Suffix, BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor) + +-- | Apply preprocessors to the sources from 'hsSourceDirs' for a given +-- component (lib, exe, or test suite). +-- +-- XXX: This is terrible +preprocessComponent + :: PackageDescription + -> Component + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Bool + -> Verbosity + -> [PPSuffixHandler] + -> IO () +preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = + -- Skip preprocessing for scripts since they should be regular Haskell files, + -- but may have no or unknown extensions. + when (package pd /= fakePackageId) $ do + -- NB: never report instantiation here; we'll report it properly when + -- building. + setupMessage' + verbosity + "Preprocessing" + (packageId pd) + (componentLocalName clbi) + (Nothing :: Maybe [(ModuleName, Module)]) + case comp of + (CLib lib@Library{libBuildInfo = bi}) -> do + let dirs = + map getSymbolicPath (hsSourceDirs bi) + ++ [autogenComponentModulesDir lbi clbi, autogenPackageModulesDir lbi] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (allLibModules lib clbi) + for_ (map ModuleName.toFilePath mods) $ + pre dirs (componentBuildDir lbi clbi) hndlrs + (CFLib flib@ForeignLib{foreignLibBuildInfo = bi, foreignLibName = nm}) -> do + let nm' = unUnqualComponentName nm + let flibDir = buildDir lbi nm' nm' ++ "-tmp" + dirs = + map getSymbolicPath (hsSourceDirs bi) + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (foreignLibModules flib) + for_ (map ModuleName.toFilePath mods) $ + pre dirs flibDir hndlrs + (CExe exe@Executable{buildInfo = bi, exeName = nm}) -> do + let nm' = unUnqualComponentName nm + let exeDir = buildDir lbi nm' nm' ++ "-tmp" + dirs = + map getSymbolicPath (hsSourceDirs bi) + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (otherModules bi) + for_ (map ModuleName.toFilePath mods) $ + pre dirs exeDir hndlrs + pre (map getSymbolicPath (hsSourceDirs bi)) exeDir (localHandlers bi) $ + dropExtensions (modulePath exe) + CTest test@TestSuite{testName = nm} -> do + let nm' = unUnqualComponentName nm + case testInterface test of + TestSuiteExeV10 _ f -> + preProcessTest test f $ buildDir lbi nm' nm' ++ "-tmp" + TestSuiteLibV09 _ _ -> do + let testDir = + buildDir lbi + stubName test + stubName test + ++ "-tmp" + writeSimpleTestStub test testDir + preProcessTest test (stubFilePath test) testDir + TestSuiteUnsupported tt -> + dieWithException verbosity $ NoSupportForPreProcessingTest tt + CBench bm@Benchmark{benchmarkName = nm} -> do + let nm' = unUnqualComponentName nm + case benchmarkInterface bm of + BenchmarkExeV10 _ f -> + preProcessBench bm f $ buildDir lbi nm' nm' ++ "-tmp" + BenchmarkUnsupported tt -> + dieWithException verbosity $ NoSupportForPreProcessingBenchmark tt + where + orderingFromHandlers v d hndlrs mods = + foldM (\acc (_, pp) -> ppOrdering pp v d acc) mods hndlrs + builtinCSuffixes = map Suffix cSourceExtensions + builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes + localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers] + pre dirs dir lhndlrs fp = + preprocessFile (map unsafeMakeSymbolicPath dirs) dir isSrcDist fp verbosity builtinSuffixes lhndlrs True + preProcessTest test = + preProcessComponent + (testBuildInfo test) + (testModules test) + preProcessBench bm = + preProcessComponent + (benchmarkBuildInfo bm) + (benchmarkModules bm) + + preProcessComponent + :: BuildInfo + -> [ModuleName] + -> FilePath + -> FilePath + -> IO () + preProcessComponent bi modules exePath dir = do + let biHandlers = localHandlers bi + sourceDirs = + map getSymbolicPath (hsSourceDirs bi) + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] + sequence_ + [ preprocessFile + (map unsafeMakeSymbolicPath sourceDirs) + dir + isSrcDist + (ModuleName.toFilePath modu) + verbosity + builtinSuffixes + biHandlers + False + | modu <- modules + ] + -- XXX: what we do here (re SymbolicPath dir) + -- XXX: 2020-10-15 do we rely here on CWD being the PackageDir? + -- Note we don't fail on missing in this case, because the main file may be generated later (i.e. by a test code generator) + preprocessFile + (unsafeMakeSymbolicPath dir : hsSourceDirs bi) + dir + isSrcDist + (dropExtensions $ exePath) + verbosity + builtinSuffixes + biHandlers + False + +-- TODO: try to list all the modules that could not be found +-- not just the first one. It's annoying and slow due to the need +-- to reconfigure after editing the .cabal file each time. + +-- | Find the first extension of the file that exists, and preprocess it +-- if required. +preprocessFile + :: [SymbolicPath PackageDir SourceDir] + -- ^ source directories + -> FilePath + -- ^ build directory + -> Bool + -- ^ preprocess for sdist + -> FilePath + -- ^ module file name + -> Verbosity + -- ^ verbosity + -> [Suffix] + -- ^ builtin suffixes + -> [(Suffix, PreProcessor)] + -- ^ possible preprocessors + -> Bool + -- ^ fail on missing file + -> IO () +preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do + -- look for files in the various source dirs with this module name + -- and a file extension of a known preprocessor + psrcFiles <- findFileWithExtension' (map fst handlers) (map getSymbolicPath searchLoc) baseFile + case psrcFiles of + -- no preprocessor file exists, look for an ordinary source file + -- just to make sure one actually exists at all for this module. + -- Note: by looking in the target/output build dir too, we allow + -- source files to appear magically in the target build dir without + -- any corresponding "real" source file. This lets custom Setup.hs + -- files generate source modules directly into the build dir without + -- the rest of the build system being aware of it (somewhat dodgy) + Nothing -> do + bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : map getSymbolicPath searchLoc) baseFile + case (bsrcFiles, failOnMissing) of + (Nothing, True) -> + dieWithException verbosity $ + CantFindSourceForPreProcessFile $ + "can't find source for " + ++ baseFile + ++ " in " + ++ intercalate ", " (map getSymbolicPath searchLoc) + _ -> return () + -- found a pre-processable file in one of the source dirs + Just (psrcLoc, psrcRelFile) -> do + let (srcStem, ext) = splitExtension psrcRelFile + psrcFile = psrcLoc psrcRelFile + pp = + fromMaybe + (error "Distribution.Simple.PreProcess: Just expected") + (lookup (Suffix $ safeTail ext) handlers) + -- Preprocessing files for 'sdist' is different from preprocessing + -- for 'build'. When preprocessing for sdist we preprocess to + -- avoid that the user has to have the preprocessors available. + -- ATM, we don't have a way to specify which files are to be + -- preprocessed and which not, so for sdist we only process + -- platform independent files and put them into the 'buildLoc' + -- (which we assume is set to the temp. directory that will become + -- the tarball). + -- TODO: eliminate sdist variant, just supply different handlers + when (not forSDist || forSDist && platformIndependent pp) $ do + -- look for existing pre-processed source file in the dest dir to + -- see if we really have to re-run the preprocessor. + ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile + recomp <- case ppsrcFiles of + Nothing -> return True + Just ppsrcFile -> + psrcFile `moreRecentFile` ppsrcFile + when recomp $ do + let destDir = buildLoc dirName srcStem + createDirectoryIfMissingVerbose verbosity True destDir + runPreProcessorWithHsBootHack + pp + (psrcLoc, psrcRelFile) + (buildLoc, srcStem <.> "hs") + where + dirName = takeDirectory + + -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files + -- be in the same place as the hs files, so if we put the hs file in dist/ + -- then we need to copy the hs-boot file there too. This should probably be + -- done another way. Possibly we should also be looking for .lhs-boot + -- files, but I think that preprocessors only produce .hs files. + runPreProcessorWithHsBootHack + pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) = do + runPreProcessor + pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) + verbosity + + exists <- doesFileExist inBoot + when exists $ copyFileVerbose verbosity inBoot outBoot + where + inBoot = replaceExtension inFile "hs-boot" + outBoot = replaceExtension outFile "hs-boot" + + inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +-- ------------------------------------------------------------ + +-- * known preprocessors + +-- ------------------------------------------------------------ + +ppGreenCard :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppGreenCard _ lbi _ = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + runDbProgram + verbosity + 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 +ppUnlit = + PreProcessor + { platformIndependent = True + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + withUTF8FileContents inFile $ \contents -> + either (writeUTF8File outFile) (dieWithException verbosity) (unlit inFile contents) + } + +ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppCpp = ppCpp' [] + +ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppCpp' extraArgs bi lbi clbi = + case compilerFlavor (compiler lbi) of + GHC -> ppGhcCpp ghcProgram (const True) args bi lbi clbi + GHCJS -> ppGhcCpp ghcjsProgram (const True) args bi lbi clbi + _ -> ppCpphs args bi lbi clbi + where + cppArgs = getCppOptions bi lbi + args = cppArgs ++ extraArgs + +ppGhcCpp + :: Program + -> (Version -> Bool) + -> [String] + -> BuildInfo + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> PreProcessor +ppGhcCpp program xHs extraArgs _bi lbi clbi = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (prog, version, _) <- + requireProgramVersion + verbosity + program + anyVersion + (withPrograms lbi) + runProgram verbosity prog $ + ["-E", "-cpp"] + -- This is a bit of an ugly hack. We're going to + -- unlit the file ourselves later on if appropriate, + -- so we need GHC not to unlit it now or it'll get + -- double-unlitted. In the future we might switch to + -- using cpphs --unlit instead. + ++ (if xHs version then ["-x", "hs"] else []) + ++ ["-optP-include", "-optP" ++ (autogenComponentModulesDir lbi clbi cppHeaderName)] + ++ ["-o", outFile, inFile] + ++ extraArgs + } + +ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppCpphs extraArgs _bi lbi clbi = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (cpphsProg, cpphsVersion, _) <- + requireProgramVersion + verbosity + cpphsProgram + anyVersion + (withPrograms lbi) + runProgram verbosity cpphsProg $ + ("-O" ++ outFile) + : inFile + : "--noline" + : "--strip" + : ( if cpphsVersion >= mkVersion [1, 6] + then ["--include=" ++ (autogenComponentModulesDir lbi clbi cppHeaderName)] + else [] + ) + ++ extraArgs + } + +ppHsc2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppHsc2hs bi lbi clbi = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + (hsc2hsProg, hsc2hsVersion, _) <- + requireProgramVersion + verbosity + hsc2hsProgram + anyVersion + (withPrograms lbi) + -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122. + let isCross = hostPlatform lbi /= buildPlatform + prependCrossFlags = if isCross then ("-x" :) else id + let hsc2hsSupportsResponseFiles = hsc2hsVersion >= mkVersion [0, 68, 4] + pureArgs = genPureArgs hsc2hsVersion gccProg inFile outFile + if hsc2hsSupportsResponseFiles + then + withResponseFile + verbosity + defaultTempFileOptions + (takeDirectory outFile) + "hsc2hs-response.txt" + Nothing + pureArgs + ( \responseFileName -> + runProgram verbosity hsc2hsProg (prependCrossFlags ["@" ++ responseFileName]) + ) + else runProgram verbosity hsc2hsProg (prependCrossFlags pureArgs) + } + where + -- Returns a list of command line arguments that can either be passed + -- 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 <- 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" ++ dir | dir <- PD.includeDirs bi] + ++ ["--cflag=-I" ++ buildDir lbi dir | dir <- 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" ++ autogenComponentModulesDir lbi clbi + , "-I" ++ autogenPackageModulesDir lbi + , "-include" + , autogenComponentModulesDir lbi clbi cppHeaderName + ] + ] + ++ [ "--lflag=-L" ++ opt + | opt <- + if withFullyStaticExe lbi + then PD.extraLibDirsStatic bi + else PD.extraLibDirs bi + ] + ++ [ "--lflag=-Wl,-R," ++ 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 + ] + ++ preccldFlags + ++ hsc2hsOptions bi + ++ postccldFlags + ++ ["-o", outFile, inFile] + where + -- hsc2hs flag parsing was wrong + -- (see -- https://github.com/haskell/hsc2hs/issues/35) + -- so we need to put -- --cc/--ld *after* hsc2hsOptions, + -- for older hsc2hs (pre 0.68.8) so that they can be overridden. + ccldFlags = + [ "--cc=" ++ programPath gccProg + , "--ld=" ++ programPath gccProg + ] + + (preccldFlags, postccldFlags) + | hsc2hsVersion >= mkVersion [0, 68, 8] = (ccldFlags, []) + | otherwise = ([], ccldFlags) + + hacked_index = packageHacks (installedPkgs lbi) + -- Look only at the dependencies of the current component + -- being built! This relies on 'installedPkgs' maintaining + -- 'InstalledPackageInfo' for internal deps too; see #2971. + pkgs = PackageIndex.topologicalOrder $ + case PackageIndex.dependencyClosure + hacked_index + (map fst (componentPackageDeps clbi)) of + Left index' -> index' + Right inf -> + error ("ppHsc2hs: broken closure: " ++ show inf) + isOSX = case buildOS of OSX -> True; _ -> False + isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True + packageHacks = case compilerFlavor (compiler lbi) of + GHC -> hackRtsPackage + GHCJS -> hackRtsPackage + _ -> id + -- We don't link in the actual Haskell libraries of our dependencies, so + -- the -u flags in the ldOptions of the rts package mean linking fails on + -- OS X (its ld is a tad stricter than gnu ld). Thus we remove the + -- ldOptions for GHC's rts package: + hackRtsPackage index = + case PackageIndex.lookupPackageName index (mkPackageName "rts") of + [(_, [rts])] -> + PackageIndex.insert rts{Installed.ldOptions = []} index + _ -> error "No (or multiple) ghc rts package is registered!!" + +ppHsc2hsExtras :: PreProcessorExtras +ppHsc2hsExtras buildBaseDir = + filter ("_hsc.c" `isSuffixOf`) + `fmap` getDirectoryContentsRecursive buildBaseDir + +ppC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppC2hs bi lbi clbi = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = + \(inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) + verbosity -> do + (c2hsProg, _, _) <- + requireProgramVersion + verbosity + c2hsProgram + (orLaterVersion (mkVersion [0, 15])) + (withPrograms lbi) + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + runProgram verbosity c2hsProg $ + -- Options from the current package: + ["--cpp=" ++ programPath gccProg, "--cppopts=-E"] + ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] + ++ ["--cppopts=-include" ++ (autogenComponentModulesDir lbi clbi cppHeaderName)] + ++ ["--include=" ++ outBaseDir] + -- Options from dependent packages + ++ [ "--cppopts=" ++ opt + | pkg <- pkgs + , opt <- + ["-I" ++ opt | opt <- Installed.includeDirs pkg] + ++ [ opt | opt@('-' : c : _) <- Installed.ccOptions pkg, + -- c2hs 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 Installed.cxxOptions unless this changes! + c `elem` "DIU" + ] + ] + -- TODO: install .chi files for packages, so we can --include + -- those dirs here, for the dependencies + + -- input and output files + ++ [ "--output-dir=" ++ outBaseDir + , "--output=" ++ outRelativeFile + , inBaseDir inRelativeFile + ] + } + where + pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) + +ppC2hsExtras :: PreProcessorExtras +ppC2hsExtras d = + filter (\p -> takeExtensions p == ".chs.c") + `fmap` getDirectoryContentsRecursive d + +-- TODO: perhaps use this with hsc2hs too +-- TODO: remove cc-options from cpphs for cabal-version: >= 1.10 +-- TODO: Refactor and add separate getCppOptionsForHs, getCppOptionsForCxx, & getCppOptionsForC +-- instead of combining all these cases in a single function. This blind combination can +-- potentially lead to compilation inconsistencies. +getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] +getCppOptions bi lbi = + platformDefines lbi + ++ cppOptions bi + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ [opt | opt@('-' : c : _) <- PD.ccOptions bi ++ PD.cxxOptions bi, c `elem` "DIU"] + +platformDefines :: LocalBuildInfo -> [String] +platformDefines lbi = + case compilerFlavor comp of + GHC -> + ["-D__GLASGOW_HASKELL__=" ++ versionInt version] + ++ ["-D" ++ os ++ "_BUILD_OS=1"] + ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"] + ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr + ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr + GHCJS -> + compatGlasgowHaskell + ++ ["-D__GHCJS__=" ++ versionInt version] + ++ ["-D" ++ os ++ "_BUILD_OS=1"] + ++ ["-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 + Platform hostArch hostOS = hostPlatform lbi + version = compilerVersion comp + compatGlasgowHaskell = + maybe + [] + (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v]) + (compilerCompatVersion GHC comp) + -- TODO: move this into the compiler abstraction + -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all + -- the other compilers. Check if that's really what they want. + versionInt :: Version -> String + versionInt v = case versionNumbers v of + [] -> "1" + [n] -> show n + n1 : n2 : _ -> + -- 6.8.x -> 608 + -- 6.10.x -> 610 + let s1 = show n1 + s2 = show n2 + middle = case s2 of + _ : _ : _ -> "" + _ -> "0" + in s1 ++ middle ++ s2 + + osStr = case hostOS of + Linux -> ["linux"] + Windows -> ["mingw32"] + OSX -> ["darwin"] + FreeBSD -> ["freebsd"] + OpenBSD -> ["openbsd"] + NetBSD -> ["netbsd"] + DragonFly -> ["dragonfly"] + Solaris -> ["solaris2"] + AIX -> ["aix"] + HPUX -> ["hpux"] + IRIX -> ["irix"] + HaLVM -> [] + IOS -> ["ios"] + Android -> ["android"] + Ghcjs -> ["ghcjs"] + Wasi -> ["wasi"] + Hurd -> ["hurd"] + Haiku -> ["haiku"] + OtherOS _ -> [] + archStr = case hostArch of + I386 -> ["i386"] + X86_64 -> ["x86_64"] + PPC -> ["powerpc"] + PPC64 -> ["powerpc64"] + PPC64LE -> ["powerpc64le"] + Sparc -> ["sparc"] + Sparc64 -> ["sparc64"] + Arm -> ["arm"] + AArch64 -> ["aarch64"] + Mips -> ["mips"] + SH -> [] + IA64 -> ["ia64"] + S390 -> ["s390"] + S390X -> ["s390x"] + Alpha -> ["alpha"] + Hppa -> ["hppa"] + Rs6000 -> ["rs6000"] + M68k -> ["m68k"] + Vax -> ["vax"] + RISCV64 -> ["riscv64"] + LoongArch64 -> ["loongarch64"] + JavaScript -> ["javascript"] + Wasm32 -> ["wasm32"] + OtherArch _ -> [] + +ppHappy :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppHappy _ lbi _ = pp{platformIndependent = True} + where + pp = standardPP lbi happyProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-agc"] + hcFlags GHCJS = ["-agc"] + hcFlags _ = [] + +ppAlex :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppAlex _ lbi _ = pp{platformIndependent = True} + where + pp = standardPP lbi alexProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-g"] + hcFlags GHCJS = ["-g"] + hcFlags _ = [] + +standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor +standardPP lbi prog args = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + runDbProgram + verbosity + prog + (withPrograms lbi) + (args ++ ["-o", outFile, inFile]) + } + +-- | Convenience function; get the suffixes of these preprocessors. +ppSuffixes :: [PPSuffixHandler] -> [Suffix] +ppSuffixes = map fst + +-- | Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. +knownSuffixHandlers :: [PPSuffixHandler] +knownSuffixHandlers = + [ (Suffix "gc", ppGreenCard) + , (Suffix "chs", ppC2hs) + , (Suffix "hsc", ppHsc2hs) + , (Suffix "x", ppAlex) + , (Suffix "y", ppHappy) + , (Suffix "ly", ppHappy) + , (Suffix "cpphs", ppCpp) + ] + +-- | Standard preprocessors with possible extra C sources: c2hs, hsc2hs. +knownExtrasHandlers :: [PreProcessorExtras] +knownExtrasHandlers = [ppC2hsExtras, ppHsc2hsExtras] + +-- | Find any extra C sources generated by preprocessing that need to +-- be added to the component (addresses issue #238). +preprocessExtras + :: Verbosity + -> Component + -> LocalBuildInfo + -> IO [FilePath] +preprocessExtras verbosity comp lbi = case comp of + CLib _ -> pp $ buildDir lbi + (CExe Executable{exeName = nm}) -> do + let nm' = unUnqualComponentName nm + pp $ buildDir lbi nm' nm' ++ "-tmp" + (CFLib ForeignLib{foreignLibName = nm}) -> do + let nm' = unUnqualComponentName nm + pp $ buildDir lbi nm' nm' ++ "-tmp" + CTest test -> do + let nm' = unUnqualComponentName $ testName test + case testInterface test of + TestSuiteExeV10 _ _ -> + pp $ buildDir lbi nm' nm' ++ "-tmp" + TestSuiteLibV09 _ _ -> + pp $ buildDir lbi stubName test stubName test ++ "-tmp" + TestSuiteUnsupported tt -> + dieWithException verbosity $ NoSupportPreProcessingTestExtras tt + CBench bm -> do + let nm' = unUnqualComponentName $ benchmarkName bm + case benchmarkInterface bm of + BenchmarkExeV10 _ _ -> + pp $ buildDir lbi nm' nm' ++ "-tmp" + BenchmarkUnsupported tt -> + dieWithException verbosity $ NoSupportPreProcessingBenchmarkExtras tt + where + pp :: FilePath -> IO [FilePath] + pp dir = do + b <- doesDirectoryExist dir + if b + then + (map (dir ) . filter not_sub . concat) + <$> for + knownExtrasHandlers + (withLexicalCallStack (\f -> f dir)) + else pure [] + -- TODO: This is a terrible hack to work around #3545 while we don't + -- reorganize the directory layout. Basically, for the main + -- library, we might accidentally pick up autogenerated sources for + -- our subcomponents, because they are all stored as subdirectories + -- in dist/build. This is a cheap and cheerful check to prevent + -- this from happening. It is not particularly correct; for example + -- if a user has a test suite named foobar and puts their C file in + -- foobar/foo.c, this test will incorrectly exclude it. But I + -- didn't want to break BC... + not_sub p = and [not (pre `isPrefixOf` p) | pre <- component_dirs] + component_dirs = component_names (localPkgDescr lbi) + -- TODO: libify me + component_names pkg_descr = + fmap unUnqualComponentName $ + mapMaybe (libraryNameString . libName) (subLibraries pkg_descr) + ++ map exeName (executables pkg_descr) + ++ map testName (testSuites pkg_descr) + ++ map benchmarkName (benchmarks pkg_descr) diff --git a/src/Distribution/Simple/PreProcess/Types.hs b/src/Distribution/Simple/PreProcess/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/PreProcess/Types.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.PreProcess.Types +-- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines a 'PreProcessor' abstraction which represents a pre-processor +-- that can transform one kind of file into another. +module Distribution.Simple.PreProcess.Types + ( Suffix (..) + , PreProcessor (..) + , builtinHaskellSuffixes + , builtinHaskellBootSuffixes + ) +where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.ModuleName (ModuleName) +import Distribution.Pretty +import Distribution.Verbosity +import qualified Text.PrettyPrint as Disp + +-- | The interface to a preprocessor, which may be implemented using an +-- external program, but need not be. The arguments are the name of +-- the input file, the name of the output file and a verbosity level. +-- Here is a simple example that merely prepends a comment to the given +-- source file: +-- +-- > ppTestHandler :: PreProcessor +-- > ppTestHandler = +-- > PreProcessor { +-- > platformIndependent = True, +-- > 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 +-- +-- 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 +-- dirs that this file was found in. The output base dir is the build dir where +-- all the generated source files are put. +-- +-- The reason for splitting it up this way is that some pre-processors don't +-- simply generate one output .hs file from one input file but have +-- dependencies on other generated files (notably c2hs, where building one +-- .hs file may require reading other .chi files, and then compiling the .hs +-- file may require reading a generated .h file). In these cases the generated +-- files need to embed relative path names to each other (eg the generated .hs +-- file mentions the .h file in the FFI imports). This path must be relative to +-- the base directory where the generated files are located, it cannot be +-- relative to the top level of the build tree because the compilers do not +-- look for .h files relative to there, ie we do not use \"-I .\", instead we +-- use \"-I dist\/build\" (or whatever dist dir has been set by the user) +-- +-- Most pre-processors do not care of course, so mkSimplePreProcessor and +-- runSimplePreProcessor functions handle the simple case. +data PreProcessor = PreProcessor + { -- Is the output of the pre-processor platform independent? eg happy output + -- is portable haskell but c2hs's output is platform dependent. + -- This matters since only platform independent generated code can be + -- included into a source tarball. + platformIndependent :: Bool + , -- TODO: deal with pre-processors that have implementation dependent output + -- eg alex and happy have --ghc flags. However we can't really include + -- ghc-specific code into supposedly portable source tarballs. + + ppOrdering + :: Verbosity + -> [FilePath] -- Source directories + -> [ModuleName] -- Module names + -> IO [ModuleName] -- Sorted modules + + -- ^ This function can reorder /all/ modules, not just those that the + -- require the preprocessor in question. As such, this function should be + -- well-behaved and not reorder modules it doesn't have dominion over! + -- + -- @since 3.8.1.0 + , runPreProcessor + :: (FilePath, FilePath) -- Location of the source file relative to a base dir + -> (FilePath, FilePath) -- Output file name, relative to an output base dir + -> Verbosity -- verbosity + -> IO () -- Should exit if the preprocessor fails + } + +-- | A suffix (or file extension). +-- +-- Mostly used to decide which preprocessor to use, e.g. files with suffix @"y"@ +-- are usually processed by the @"happy"@ build tool. +newtype Suffix = Suffix String + deriving (Eq, Ord, Show, Generic, IsString) + +instance Pretty Suffix where + pretty (Suffix s) = Disp.text s + +instance Binary Suffix +instance Structured Suffix + +builtinHaskellSuffixes :: [Suffix] +builtinHaskellSuffixes = map Suffix ["hs", "lhs", "hsig", "lhsig"] + +builtinHaskellBootSuffixes :: [Suffix] +builtinHaskellBootSuffixes = map Suffix ["hs-boot", "lhs-boot"] diff --git a/src/Distribution/Simple/PreProcess/Unlit.hs b/src/Distribution/Simple/PreProcess/Unlit.hs --- a/src/Distribution/Simple/PreProcess/Unlit.hs +++ b/src/Distribution/Simple/PreProcess/Unlit.hs @@ -1,4 +1,9 @@ ----------------------------------------------------------------------------- + +-- This version is interesting because instead of striping comment lines, it +-- turns them into "-- " style comments. This allows using haddock markup +-- in literate scripts without having to use "> --" prefix. + -- | -- Module : Distribution.Simple.PreProcess.Unlit -- Copyright : ... @@ -8,73 +13,77 @@ -- -- Remove the \"literal\" markups from a Haskell source file, including -- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" - --- This version is interesting because instead of striping comment lines, it --- turns them into "-- " style comments. This allows using haddock markup --- in literate scripts without having to use "> --" prefix. - -module Distribution.Simple.PreProcess.Unlit (unlit,plain) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.Generic (safeTail, safeLast, safeInit) +module Distribution.Simple.PreProcess.Unlit (unlit, plain) where import Data.List (mapAccumL) +import Distribution.Compat.Prelude +import Distribution.Simple.Errors +import Distribution.Utils.Generic (safeInit, safeLast, safeTail) +import Prelude () -data Classified = BirdTrack String | Blank String | Ordinary String - | Line !Int String | CPP String - | BeginCode | EndCode - -- output only: - | Error String | Comment String +data Classified + = BirdTrack String + | Blank String + | Ordinary String + | Line !Int String + | CPP String + | BeginCode + | EndCode + | -- output only: + Error String + | Comment String -- | No unliteration. plain :: String -> String -> String plain _ hs = hs classify :: String -> Classified -classify ('>':s) = BirdTrack s -classify ('#':s) = case tokens s of - (line:file@('"':_:_):_) | all isDigit line - && safeLast file == Just '"' - -- this shouldn't fail as we tested for 'all isDigit' - -> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse - _ -> CPP s - where tokens = unfoldr $ \str -> case lex str of - (t@(_:_), str'):_ -> Just (t, str') - _ -> Nothing -classify ('\\':s) +classify ('>' : s) = BirdTrack s +classify ('#' : s) = case tokens s of + (line : file@('"' : _ : _) : _) + | all isDigit line + && safeLast file == Just '"' -> + -- this shouldn't fail as we tested for 'all isDigit' + Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse + _ -> CPP s + where + tokens = unfoldr $ \str -> case lex str of + (t@(_ : _), str') : _ -> Just (t, str') + _ -> Nothing +classify ('\\' : s) | "begin{code}" `isPrefixOf` s = BeginCode - | "end{code}" `isPrefixOf` s = EndCode -classify s | all isSpace s = Blank s -classify s = Ordinary s + | "end{code}" `isPrefixOf` s = EndCode +classify s | all isSpace s = Blank s +classify s = Ordinary s -- So the weird exception for comment indenting is to make things work with -- haddock, see classifyAndCheckForBirdTracks below. unclassify :: Bool -> Classified -> String -unclassify _ (BirdTrack s) = ' ':s -unclassify _ (Blank s) = s -unclassify _ (Ordinary s) = s -unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file -unclassify _ (CPP s) = '#':s -unclassify True (Comment "") = " --" -unclassify True (Comment s) = " -- " ++ s -unclassify False (Comment "") = "--" -unclassify False (Comment s) = "-- " ++ s -unclassify _ _ = internalError +unclassify _ (BirdTrack s) = ' ' : s +unclassify _ (Blank s) = s +unclassify _ (Ordinary s) = s +unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file +unclassify _ (CPP s) = '#' : s +unclassify True (Comment "") = " --" +unclassify True (Comment s) = " -- " ++ s +unclassify False (Comment "") = "--" +unclassify False (Comment s) = "-- " ++ s +unclassify _ _ = internalError -- | 'unlit' takes a filename (for error reports), and transforms the -- given string, to eliminate the literate comments from the program text. -unlit :: FilePath -> String -> Either String String +unlit :: FilePath -> String -> Either String CabalException unlit file input = - let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks - . inlines - $ input - in either (Left . unlines . map (unclassify usesBirdTracks)) - Right - . checkErrors - . reclassify - $ classified - + let (usesBirdTracks, classified) = + classifyAndCheckForBirdTracks + . inlines + $ input + in either + (Left . unlines . map (unclassify usesBirdTracks)) + Right + . checkErrors + . reclassify + $ classified where -- So haddock requires comments and code to align, since it treats comments -- as following the layout rule. This is a pain for us since bird track @@ -94,16 +103,17 @@ in (seenBirdTrack || isBirdTrack classification, classification) isBirdTrack (BirdTrack _) = True - isBirdTrack _ = False + isBirdTrack _ = False - checkErrors ls = case [ e | Error e <- ls ] of - [] -> Left ls - (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) - where (f, n) = errorPos file 1 ls - errorPos f n [] = (f, n) - errorPos f n (Error _:_) = (f, n) - errorPos _ _ (Line n' f':ls) = errorPos f' n' ls - errorPos f n (_ :ls) = errorPos f (n+1) ls + checkErrors ls = case [e | Error e <- ls] of + [] -> Left ls + (message : _) -> Right (UnlitException (f ++ ":" ++ show n ++ ": " ++ message)) + where + (f, n) = errorPos file 1 ls + errorPos f n [] = (f, n) + errorPos f n (Error _ : _) = (f, n) + errorPos _ _ (Line n' f' : ls) = errorPos f' n' ls + errorPos f n (_ : ls) = errorPos f (n + 1) ls -- Here we model a state machine, with each state represented by -- a local function. We only have four states (well, five, @@ -117,51 +127,51 @@ reclassify :: [Classified] -> [Classified] reclassify = blank -- begin in blank state where - latex [] = [] - latex (EndCode :ls) = Blank "" : comment ls - latex (BeginCode :_ ) = [Error "\\begin{code} in code section"] - latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls - latex ( l:ls) = l : latex ls + latex [] = [] + latex (EndCode : ls) = Blank "" : comment ls + latex (BeginCode : _) = [Error "\\begin{code} in code section"] + latex (BirdTrack l : ls) = Ordinary ('>' : l) : latex ls + latex (l : ls) = l : latex ls - blank [] = [] - blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - blank (BeginCode :ls) = Blank "" : latex ls - blank (BirdTrack l:ls) = BirdTrack l : bird ls - blank (Ordinary l:ls) = Comment l : comment ls - blank ( l:ls) = l : blank ls + blank [] = [] + blank (EndCode : _) = [Error "\\end{code} without \\begin{code}"] + blank (BeginCode : ls) = Blank "" : latex ls + blank (BirdTrack l : ls) = BirdTrack l : bird ls + blank (Ordinary l : ls) = Comment l : comment ls + blank (l : ls) = l : blank ls - bird [] = [] - bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - bird (BeginCode :ls) = Blank "" : latex ls - bird (Blank l :ls) = Blank l : blank ls - bird (Ordinary _:_ ) = [Error "program line before comment line"] - bird ( l:ls) = l : bird ls + bird [] = [] + bird (EndCode : _) = [Error "\\end{code} without \\begin{code}"] + bird (BeginCode : ls) = Blank "" : latex ls + bird (Blank l : ls) = Blank l : blank ls + bird (Ordinary _ : _) = [Error "program line before comment line"] + bird (l : ls) = l : bird ls - comment [] = [] - comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - comment (BeginCode :ls) = Blank "" : latex ls - comment (CPP l :ls) = CPP l : comment ls - comment (BirdTrack _:_ ) = [Error "comment line before program line"] + comment [] = [] + comment (EndCode : _) = [Error "\\end{code} without \\begin{code}"] + comment (BeginCode : ls) = Blank "" : latex ls + comment (CPP l : ls) = CPP l : comment ls + comment (BirdTrack _ : _) = [Error "comment line before program line"] -- a blank line and another ordinary line following a comment -- will be treated as continuing the comment. Otherwise it's -- then end of the comment, with a blank line. - comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls - comment (Blank l:ls) = Blank l : blank ls - comment (Line n f :ls) = Line n f : comment ls - comment (Ordinary l:ls) = Comment l : comment ls - comment (Comment _: _) = internalError - comment (Error _: _) = internalError + comment (Blank l : ls@(Ordinary _ : _)) = Comment l : comment ls + comment (Blank l : ls) = Blank l : blank ls + comment (Line n f : ls) = Line n f : comment ls + comment (Ordinary l : ls) = Comment l : comment ls + comment (Comment _ : _) = internalError + comment (Error _ : _) = internalError -- Re-implementation of 'lines', for better efficiency (but decreased laziness). -- Also, importantly, accepts non-standard DOS and Mac line ending characters. inlines :: String -> [String] inlines xs = lines' xs id where - lines' [] acc = [acc []] - lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS - lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS - lines' ('\n':s) acc = acc [] : lines' s id -- Unix - lines' (c:s) acc = lines' s (acc . (c:)) + lines' [] acc = [acc []] + lines' ('\^M' : '\n' : s) acc = acc [] : lines' s id -- DOS + lines' ('\^M' : s) acc = acc [] : lines' s id -- MacOS + lines' ('\n' : s) acc = acc [] : lines' s id -- Unix + lines' (c : s) acc = lines' s (acc . (c :)) internalError :: a internalError = error "unlit: internal error" 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 @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 @@ -34,150 +35,158 @@ -- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a -- hook user the ability to get the above flags and such so that they -- don't have to write all the PATH logic inside Setup.lhs. - -module Distribution.Simple.Program ( - -- * Program and functions for constructing them - Program(..) - , ProgramSearchPath - , ProgramSearchPathEntry(..) - , simpleProgram - , findProgramOnSearchPath - , defaultProgramSearchPath - , findProgramVersion +module Distribution.Simple.Program + ( -- * Program and functions for constructing them + Program (..) + , ProgramSearchPath + , ProgramSearchPathEntry (..) + , simpleProgram + , findProgramOnSearchPath + , defaultProgramSearchPath + , findProgramVersion -- * Configured program and related functions - , ConfiguredProgram(..) - , programPath - , ProgArg - , ProgramLocation(..) - , runProgram - , getProgramOutput - , suppressOverrideArgs + , ConfiguredProgram (..) + , programPath + , ProgArg + , ProgramLocation (..) + , runProgram + , getProgramOutput + , suppressOverrideArgs -- * Program invocations - , ProgramInvocation(..) - , emptyProgramInvocation - , simpleProgramInvocation - , programInvocation - , runProgramInvocation - , getProgramInvocationOutput - , getProgramInvocationLBS + , ProgramInvocation (..) + , emptyProgramInvocation + , simpleProgramInvocation + , programInvocation + , runProgramInvocation + , getProgramInvocationOutput + , getProgramInvocationLBS -- * The collection of unconfigured and configured programs - , builtinPrograms + , builtinPrograms -- * The collection of configured programs we can run - , ProgramDb - , defaultProgramDb - , emptyProgramDb - , restoreProgramDb - , addKnownProgram - , addKnownPrograms - , lookupKnownProgram - , knownPrograms - , getProgramSearchPath - , setProgramSearchPath - , userSpecifyPath - , userSpecifyPaths - , userMaybeSpecifyPath - , userSpecifyArgs - , userSpecifyArgss - , userSpecifiedArgs - , lookupProgram - , lookupProgramVersion - , updateProgram - , configureProgram - , configureAllKnownPrograms - , reconfigurePrograms - , requireProgram - , requireProgramVersion - , needProgram - , runDbProgram - , getDbProgramOutput + , ProgramDb + , defaultProgramDb + , emptyProgramDb + , restoreProgramDb + , addKnownProgram + , addKnownPrograms + , lookupKnownProgram + , knownPrograms + , getProgramSearchPath + , setProgramSearchPath + , userSpecifyPath + , userSpecifyPaths + , userMaybeSpecifyPath + , userSpecifyArgs + , userSpecifyArgss + , userSpecifiedArgs + , lookupProgram + , lookupProgramVersion + , updateProgram + , configureProgram + , configureAllKnownPrograms + , reconfigurePrograms + , requireProgram + , requireProgramVersion + , needProgram + , runDbProgram + , getDbProgramOutput -- * Programs that Cabal knows about - , ghcProgram - , ghcPkgProgram - , ghcjsProgram - , ghcjsPkgProgram - , hmakeProgram - , jhcProgram - , uhcProgram - , gccProgram - , arProgram - , stripProgram - , happyProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , hscolourProgram - , doctestProgram - , haddockProgram - , greencardProgram - , ldProgram - , tarProgram - , cppProgram - , pkgConfigProgram - , hpcProgram - ) where + , ghcProgram + , ghcPkgProgram + , ghcjsProgram + , ghcjsPkgProgram + , hmakeProgram + , jhcProgram + , uhcProgram + , gccProgram + , arProgram + , stripProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , hscolourProgram + , doctestProgram + , haddockProgram + , greencardProgram + , ldProgram + , tarProgram + , cppProgram + , pkgConfigProgram + , hpcProgram + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Run -import Distribution.Simple.Program.Db +import Distribution.Simple.Errors import Distribution.Simple.Program.Builtin +import Distribution.Simple.Program.Db import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.Verbosity -- | Runs the given configured program. -runProgram :: Verbosity -- ^Verbosity - -> ConfiguredProgram -- ^The program to run - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO () +runProgram + :: Verbosity + -- ^ Verbosity + -> ConfiguredProgram + -- ^ The program to run + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO () runProgram verbosity prog args = runProgramInvocation verbosity (programInvocation prog args) - -- | Runs the given configured program and gets the output. --- -getProgramOutput :: Verbosity -- ^Verbosity - -> ConfiguredProgram -- ^The program to run - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO String +getProgramOutput + :: Verbosity + -- ^ Verbosity + -> ConfiguredProgram + -- ^ The program to run + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO String getProgramOutput verbosity prog args = getProgramInvocationOutput verbosity (programInvocation prog args) - -- | Looks up the given program in the program database and runs it. --- -runDbProgram :: Verbosity -- ^verbosity - -> Program -- ^The program to run - -> ProgramDb -- ^look up the program here - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO () +runDbProgram + :: Verbosity + -- ^ verbosity + -> Program + -- ^ The program to run + -> ProgramDb + -- ^ look up the program here + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO () runDbProgram verbosity prog programDb args = case lookupProgram prog programDb of - Nothing -> die' verbosity notFound + Nothing -> + dieWithException verbosity $ ProgramNotFound (programName prog) Just configuredProg -> runProgram verbosity configuredProg args - where - notFound = "The program '" ++ programName prog - ++ "' is required but it could not be found" -- | Looks up the given program in the program database and runs it. --- -getDbProgramOutput :: Verbosity -- ^verbosity - -> Program -- ^The program to run - -> ProgramDb -- ^look up the program here - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO String +getDbProgramOutput + :: Verbosity + -- ^ verbosity + -> Program + -- ^ The program to run + -> ProgramDb + -- ^ look up the program here + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO String getDbProgramOutput verbosity prog programDb args = case lookupProgram prog programDb of - Nothing -> die' verbosity notFound + Nothing -> dieWithException verbosity $ ProgramNotFound (programName prog) Just configuredProg -> getProgramOutput verbosity configuredProg args - where - notFound = "The program '" ++ programName prog - ++ "' is required but it could not be found" 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 @@ -1,9 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE NondecreasingIndentation #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Ar -- Copyright : Duncan Coutts 2009 @@ -12,125 +13,155 @@ -- Portability : portable -- -- This module provides an library interface to the @ar@ program. - -module Distribution.Simple.Program.Ar ( - createArLibArchive, - multiStageProgramInvocation +module Distribution.Simple.Program.Ar + ( createArLibArchive + , multiStageProgramInvocation ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Distribution.Compat.CopyFile (filesEqual) -import Distribution.Simple.Compiler (arResponseFilesSupported, arDashLSupported) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Compiler (arDashLSupported, arResponseFilesSupported) +import Distribution.Simple.Flag + ( fromFlagOrDefault + ) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..)) import Distribution.Simple.Program - ( ProgramInvocation, arProgram, requireProgram ) + ( ProgramInvocation + , arProgram + , requireProgram + ) import Distribution.Simple.Program.ResponseFile - ( withResponseFile ) + ( withResponseFile + ) import Distribution.Simple.Program.Run - ( programInvocation, multiStageProgramInvocation - , runProgramInvocation ) -import Distribution.Simple.Setup - ( fromFlagOrDefault, configUseResponseFiles ) + ( multiStageProgramInvocation + , programInvocation + , runProgramInvocation + ) +import Distribution.Simple.Setup.Config + ( configUseResponseFiles + ) import Distribution.Simple.Utils - ( defaultTempFileOptions, dieWithLocation', withTempDirectory ) + ( defaultTempFileOptions + , dieWithLocation' + , withTempDirectory + ) import Distribution.System - ( Arch(..), OS(..), Platform(..) ) + ( Arch (..) + , OS (..) + , Platform (..) + ) import Distribution.Verbosity - ( Verbosity, deafening, verbose ) + ( Verbosity + , deafening + , verbose + ) import System.Directory (doesFileExist, renameFile) -import System.FilePath ((), splitFileName) +import System.FilePath (splitFileName, ()) import System.IO - ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek) - , hFileSize, hSeek, withBinaryFile ) + ( Handle + , IOMode (ReadWriteMode) + , SeekMode (AbsoluteSeek) + , hFileSize + , hSeek + , withBinaryFile + ) -- | Call @ar@ to create a library archive from a bunch of object files. --- -createArLibArchive :: Verbosity -> LocalBuildInfo - -> FilePath -> [FilePath] -> IO () +createArLibArchive + :: Verbosity + -> LocalBuildInfo + -> FilePath + -> [FilePath] + -> IO () createArLibArchive verbosity lbi targetPath files = do (ar, _) <- requireProgram verbosity arProgram progDb let (targetDir, targetName) = splitFileName targetPath - withTempDirectory verbosity targetDir "objs" $ \ tmpDir -> do - let tmpPath = tmpDir targetName + withTempDirectory verbosity targetDir "objs" $ \tmpDir -> do + let tmpPath = tmpDir targetName - -- The args to use with "ar" are actually rather subtle and system-dependent. - -- In particular we have the following issues: - -- - -- -- On OS X, "ar q" does not make an archive index. Archives with no - -- index cannot be used. - -- - -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us - -- do that. We have duplicates because of modules like "A.M" and "B.M" - -- both make an object file "M.o" and ar does not consider the directory. - -- - -- -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier - -- in "q" mode which compels the archiver to add the members of an input - -- archive to the output, rather than the archive itself. This is - -- necessary as GHC may produce .o files that are actually archives. See - -- https://gitlab.haskell.org/ghc/ghc/-/issues/21068. - -- - -- Our solution is to use "ar r" in the simple case when one call is enough. - -- When we need to call ar multiple times we use "ar q" and for the last - -- call on OSX we use "ar qs" so that it'll make the index. + -- The args to use with "ar" are actually rather subtle and system-dependent. + -- In particular we have the following issues: + -- + -- -- On OS X, "ar q" does not make an archive index. Archives with no + -- index cannot be used. + -- + -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us + -- do that. We have duplicates because of modules like "A.M" and "B.M" + -- both make an object file "M.o" and ar does not consider the directory. + -- + -- -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier + -- in "q" mode which compels the archiver to add the members of an input + -- archive to the output, rather than the archive itself. This is + -- necessary as GHC may produce .o files that are actually archives. See + -- https://gitlab.haskell.org/ghc/ghc/-/issues/21068. + -- + -- Our solution is to use "ar r" in the simple case when one call is enough. + -- When we need to call ar multiple times we use "ar q" and for the last + -- call on OSX we use "ar qs" so that it'll make the index. - let simpleArgs = case hostOS of - OSX -> ["-r", "-s"] - _ | dashLSupported -> ["-qL"] - _ -> ["-r"] + let simpleArgs = case hostOS of + OSX -> ["-r", "-s"] + _ | dashLSupported -> ["-qL"] + _ -> ["-r"] - initialArgs = ["-q"] - finalArgs = case hostOS of - OSX -> ["-q", "-s"] - _ | dashLSupported -> ["-qL"] - _ -> ["-q"] + initialArgs = ["-q"] + finalArgs = case hostOS of + OSX -> ["-q", "-s"] + _ | dashLSupported -> ["-qL"] + _ -> ["-q"] - extraArgs = verbosityOpts verbosity ++ [tmpPath] + extraArgs = verbosityOpts verbosity ++ [tmpPath] - simple = programInvocation ar (simpleArgs ++ extraArgs) - initial = programInvocation ar (initialArgs ++ extraArgs) - middle = initial - final = programInvocation ar (finalArgs ++ extraArgs) + simple = programInvocation ar (simpleArgs ++ extraArgs) + initial = programInvocation ar (initialArgs ++ extraArgs) + middle = initial + final = programInvocation ar (finalArgs ++ extraArgs) - oldVersionManualOverride = - fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi - responseArgumentsNotSupported = - not (arResponseFilesSupported (compiler lbi)) - dashLSupported = - arDashLSupported (compiler lbi) + oldVersionManualOverride = + fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi + responseArgumentsNotSupported = + not (arResponseFilesSupported (compiler lbi)) + dashLSupported = + arDashLSupported (compiler lbi) - invokeWithResponesFile :: FilePath -> ProgramInvocation - invokeWithResponesFile atFile = - programInvocation ar $ - simpleArgs ++ extraArgs ++ ['@' : atFile] + invokeWithResponesFile :: FilePath -> ProgramInvocation + invokeWithResponesFile atFile = + programInvocation ar $ + simpleArgs ++ extraArgs ++ ['@' : atFile] - if oldVersionManualOverride || responseArgumentsNotSupported - then - sequence_ - [ runProgramInvocation verbosity inv - | inv <- multiStageProgramInvocation - simple (initial, middle, final) files ] - else - withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $ + if oldVersionManualOverride || responseArgumentsNotSupported + then + sequence_ + [ runProgramInvocation verbosity inv + | inv <- + multiStageProgramInvocation + simple + (initial, middle, final) + files + ] + else withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $ \path -> runProgramInvocation verbosity $ invokeWithResponesFile path - unless (hostArch == Arm -- See #1537 - || hostOS == AIX) $ -- AIX uses its own "ar" format variant - wipeMetadata verbosity tmpPath - equal <- filesEqual tmpPath targetPath - unless equal $ renameFile tmpPath targetPath - + unless + ( hostArch == Arm -- See #1537 + || hostOS == AIX + ) + $ wipeMetadata verbosity tmpPath -- AIX uses its own "ar" format variant + equal <- filesEqual tmpPath targetPath + unless equal $ renameFile tmpPath targetPath where progDb = withPrograms lbi Platform hostArch hostOS = hostPlatform lbi verbosityOpts v | v >= deafening = ["-v"] - | v >= verbose = [] - | otherwise = ["-c"] -- Do not warn if library had to be created. + | v >= verbose = [] + | otherwise = ["-c"] -- Do not warn if library had to be created. -- | @ar@ by default includes various metadata for each object file in their -- respective headers, so the output can differ for the same inputs, making @@ -140,17 +171,18 @@ -- rather harder than just re-implementing this feature. wipeMetadata :: Verbosity -> FilePath -> IO () wipeMetadata verbosity path = do - -- Check for existence first (ReadWriteMode would create one otherwise) - exists <- doesFileExist path - unless exists $ wipeError "Temporary file disappeared" - withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h - + -- Check for existence first (ReadWriteMode would create one otherwise) + exists <- doesFileExist path + unless exists $ wipeError "Temporary file disappeared" + withBinaryFile path ReadWriteMode $ \h -> hFileSize h >>= wipeArchive h where - wipeError msg = dieWithLocation' verbosity path Nothing $ + wipeError msg = + dieWithLocation' verbosity path Nothing $ "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg archLF = "!\x0a" -- global magic, 8 bytes x60LF = "\x60\x0a" -- header magic, 2 bytes - metadata = BS.concat + metadata = + BS.concat [ "0 " -- mtime, 12 bytes , "0 " -- UID, 6 bytes , "0 " -- GID, 6 bytes @@ -162,40 +194,41 @@ -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details wipeArchive :: Handle -> Integer -> IO () wipeArchive h archiveSize = do - global <- BS.hGet h (BS.length archLF) - unless (global == archLF) $ wipeError "Bad global header" - wipeHeader (toInteger $ BS.length archLF) - + global <- BS.hGet h (BS.length archLF) + unless (global == archLF) $ wipeError "Bad global header" + wipeHeader (toInteger $ BS.length archLF) where wipeHeader :: Integer -> IO () wipeHeader offset = case compare offset archiveSize of - EQ -> return () - GT -> wipeError (atOffset "Archive truncated") - LT -> do - header <- BS.hGet h headerSize - unless (BS.length header == headerSize) $ - wipeError (atOffset "Short header") - let magic = BS.drop 58 header - unless (magic == x60LF) . wipeError . atOffset $ - "Bad magic " ++ show magic ++ " in header" - - let name = BS.take 16 header - let size = BS.take 10 $ BS.drop 48 header - objSize <- case reads (BS8.unpack size) of - [(n, s)] | all isSpace s -> return n - _ -> wipeError (atOffset "Bad file size in header") + EQ -> return () + GT -> wipeError (atOffset "Archive truncated") + LT -> do + header <- BS.hGet h headerSize + unless (BS.length header == headerSize) $ + wipeError (atOffset "Short header") + let magic = BS.drop 58 header + unless (magic == x60LF) . wipeError . atOffset $ + "Bad magic " ++ show magic ++ " in header" - let replacement = BS.concat [ name, metadata, size, magic ] - unless (BS.length replacement == headerSize) $ - wipeError (atOffset "Something has gone terribly wrong") - hSeek h AbsoluteSeek offset - BS.hPut h replacement + let name = BS.take 16 header + let size = BS.take 10 $ BS.drop 48 header + objSize <- case reads (BS8.unpack size) of + [(n, s)] | all isSpace s -> return n + _ -> wipeError (atOffset "Bad file size in header") - let nextHeader = offset + toInteger headerSize + - -- Odd objects are padded with an extra '\x0a' - if odd objSize then objSize + 1 else objSize - hSeek h AbsoluteSeek nextHeader - wipeHeader nextHeader + let replacement = BS.concat [name, metadata, size, magic] + unless (BS.length replacement == headerSize) $ + wipeError (atOffset "Something has gone terribly wrong") + hSeek h AbsoluteSeek offset + BS.hPut h replacement + let nextHeader = + offset + + toInteger headerSize + + + -- Odd objects are padded with an extra '\x0a' + if odd objSize then objSize + 1 else objSize + hSeek h AbsoluteSeek nextHeader + wipeHeader nextHeader where atOffset msg = msg ++ " at offset " ++ show offset 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 @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Builtin -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 @@ -9,47 +10,45 @@ -- The module defines all the known built-in 'Program's. -- -- Where possible we try to find their version numbers. --- -module Distribution.Simple.Program.Builtin ( - - -- * The collection of unconfigured and configured programs - builtinPrograms, +module Distribution.Simple.Program.Builtin + ( -- * The collection of unconfigured and configured programs + builtinPrograms -- * Programs that Cabal knows about - ghcProgram, - ghcPkgProgram, - runghcProgram, - ghcjsProgram, - ghcjsPkgProgram, - hmakeProgram, - jhcProgram, - haskellSuiteProgram, - haskellSuitePkgProgram, - uhcProgram, - gccProgram, - arProgram, - stripProgram, - happyProgram, - alexProgram, - hsc2hsProgram, - c2hsProgram, - cpphsProgram, - hscolourProgram, - doctestProgram, - haddockProgram, - greencardProgram, - ldProgram, - tarProgram, - cppProgram, - pkgConfigProgram, - hpcProgram, + , ghcProgram + , ghcPkgProgram + , runghcProgram + , ghcjsProgram + , ghcjsPkgProgram + , hmakeProgram + , jhcProgram + , haskellSuiteProgram + , haskellSuitePkgProgram + , uhcProgram + , gccProgram + , arProgram + , stripProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , hscolourProgram + , doctestProgram + , haddockProgram + , greencardProgram + , ldProgram + , tarProgram + , cppProgram + , pkgConfigProgram + , hpcProgram ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Simple.Program.GHC import Distribution.Simple.Program.Find +import Distribution.Simple.Program.GHC import Distribution.Simple.Program.Internal import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types @@ -60,137 +59,153 @@ import qualified Data.Map as Map -- ------------------------------------------------------------ + -- * Known programs + -- ------------------------------------------------------------ -- | The default list of programs. -- These programs are typically used internally to Cabal. builtinPrograms :: [Program] builtinPrograms = - [ - -- compilers and related progs - ghcProgram - , runghcProgram - , ghcPkgProgram - , ghcjsProgram - , ghcjsPkgProgram - , haskellSuiteProgram - , haskellSuitePkgProgram - , hmakeProgram - , jhcProgram - , uhcProgram - , hpcProgram - -- preprocessors - , hscolourProgram - , doctestProgram - , haddockProgram - , happyProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , greencardProgram - -- platform toolchain - , gccProgram - , arProgram - , stripProgram - , ldProgram - , tarProgram - -- configuration tools - , pkgConfigProgram - ] + [ -- compilers and related progs + ghcProgram + , runghcProgram + , ghcPkgProgram + , ghcjsProgram + , ghcjsPkgProgram + , haskellSuiteProgram + , haskellSuitePkgProgram + , hmakeProgram + , jhcProgram + , uhcProgram + , hpcProgram + , -- preprocessors + hscolourProgram + , doctestProgram + , haddockProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , greencardProgram + , -- platform toolchain + gccProgram + , arProgram + , stripProgram + , ldProgram + , tarProgram + , -- configuration tools + pkgConfigProgram + ] ghcProgram :: Program -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), - - programNormaliseArgs = normaliseGhcArgs - } +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) + , programNormaliseArgs = normaliseGhcArgs + } runghcProgram :: Program -runghcProgram = (simpleProgram "runghc") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "runghc 7.10.3" - (_:ver:_) -> ver - _ -> "" - } +runghcProgram = + (simpleProgram "runghc") + { programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "runghc 7.10.3" + (_ : ver : _) -> ver + _ -> "" + } ghcPkgProgram :: Program -ghcPkgProgram = (simpleProgram "ghc-pkg") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "ghc-pkg --version" gives a string like - -- "GHC package manager version 6.4.1" - case words str of - (_:_:_:_:ver:_) -> ver - _ -> "" - } +ghcPkgProgram = + (simpleProgram "ghc-pkg") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghc-pkg --version" gives a string like + -- "GHC package manager version 6.4.1" + case words str of + (_ : _ : _ : _ : ver : _) -> ver + _ -> "" + } ghcjsProgram :: Program -ghcjsProgram = (simpleProgram "ghcjs") { - programFindVersion = findProgramVersion "--numeric-ghcjs-version" id - } +ghcjsProgram = + (simpleProgram "ghcjs") + { programFindVersion = findProgramVersion "--numeric-ghcjs-version" id + } -- note: version is the version number of the GHC version that ghcjs-pkg was built with ghcjsPkgProgram :: Program -ghcjsPkgProgram = (simpleProgram "ghcjs-pkg") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "ghcjs-pkg --version" gives a string like - -- "GHCJS package manager version 6.4.1" - case words str of - (_:_:_:_:ver:_) -> ver - _ -> "" - } +ghcjsPkgProgram = + (simpleProgram "ghcjs-pkg") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghcjs-pkg --version" gives a string like + -- "GHCJS package manager version 6.4.1" + case words str of + (_ : _ : _ : _ : ver : _) -> ver + _ -> "" + } 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 - _ -> "" - } +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") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- invoking "jhc --version" gives a string like - -- "jhc 0.3.20080208 (wubgipkamcep-2) - -- compiled by ghc-6.8 on a x86_64 running linux" - case words str of - (_:ver:_) -> ver - _ -> "" - } +jhcProgram = + (simpleProgram "jhc") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- invoking "jhc --version" gives a string like + -- "jhc 0.3.20080208 (wubgipkamcep-2) + -- compiled by ghc-6.8 on a x86_64 running linux" + case words str of + (_ : ver : _) -> ver + _ -> "" + } uhcProgram :: Program -uhcProgram = (simpleProgram "uhc") { - programFindVersion = findProgramVersion "--version-dotted" id - } +uhcProgram = + (simpleProgram "uhc") + { programFindVersion = findProgramVersion "--version-dotted" id + } hpcProgram :: Program -hpcProgram = (simpleProgram "hpc") - { - programFindVersion = findProgramVersion "version" $ \str -> - case words str of - (_ : _ : _ : ver : _) -> ver - _ -> "" +hpcProgram = + (simpleProgram "hpc") + { programFindVersion = findProgramVersion "version" $ \str -> + case words str of + (_ : _ : _ : ver : _) -> ver + _ -> "" } -- This represents a haskell-suite compiler. Of course, the compiler @@ -210,118 +225,130 @@ -- The path to the real compiler is found and recorded in the ProgramDb -- during the configure phase. haskellSuiteProgram :: Program -haskellSuiteProgram = (simpleProgram "haskell-suite") { - -- pretend that the program exists, otherwise it won't be in the - -- "configured" state - programFindLocation = \_verbosity _searchPath -> - return $ Just ("haskell-suite-dummy-location", []) - } +haskellSuiteProgram = + (simpleProgram "haskell-suite") + { -- pretend that the program exists, otherwise it won't be in the + -- "configured" state + programFindLocation = \_verbosity _searchPath -> + return $ Just ("haskell-suite-dummy-location", []) + } -- This represent a haskell-suite package manager. See the comments for -- haskellSuiteProgram. haskellSuitePkgProgram :: Program -haskellSuitePkgProgram = (simpleProgram "haskell-suite-pkg") { - programFindLocation = \_verbosity _searchPath -> - return $ Just ("haskell-suite-pkg-dummy-location", []) - } - +haskellSuitePkgProgram = + (simpleProgram "haskell-suite-pkg") + { programFindLocation = \_verbosity _searchPath -> + return $ Just ("haskell-suite-pkg-dummy-location", []) + } happyProgram :: Program -happyProgram = (simpleProgram "happy") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "happy --version" gives a string like - -- "Happy Version 1.16 Copyright (c) ...." - case words str of - (_:_:ver:_) -> ver - _ -> "" - } +happyProgram = + (simpleProgram "happy") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "happy --version" gives a string like + -- "Happy Version 1.16 Copyright (c) ...." + case words str of + (_ : _ : ver : _) -> ver + _ -> "" + } alexProgram :: Program -alexProgram = (simpleProgram "alex") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "alex --version" gives a string like - -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" - case words str of - (_:_:ver:_) -> takeWhile (\x -> isDigit x || x == '.') ver - _ -> "" - } +alexProgram = + (simpleProgram "alex") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "alex --version" gives a string like + -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" + case words str of + (_ : _ : ver : _) -> takeWhile (\x -> isDigit x || x == '.') ver + _ -> "" + } gccProgram :: Program -gccProgram = (simpleProgram "gcc") { - programFindVersion = findProgramVersion "-dumpversion" id - } +gccProgram = + (simpleProgram "gcc") + { programFindVersion = findProgramVersion "-dumpversion" id + } arProgram :: Program arProgram = simpleProgram "ar" stripProgram :: Program -stripProgram = (simpleProgram "strip") { - programFindVersion = findProgramVersion "--version" stripExtractVersion . lessVerbose - } +stripProgram = + (simpleProgram "strip") + { programFindVersion = \verbosity -> + findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity) + } hsc2hsProgram :: Program -hsc2hsProgram = (simpleProgram "hsc2hs") { - programFindVersion = - findProgramVersion "--version" $ \str -> - -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" - case words str of - (_:_:ver:_) -> ver - _ -> "" - } +hsc2hsProgram = + (simpleProgram "hsc2hs") + { programFindVersion = + findProgramVersion "--version" $ \str -> + -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" + case words str of + (_ : _ : ver : _) -> ver + _ -> "" + } c2hsProgram :: Program -c2hsProgram = (simpleProgram "c2hs") { - programFindVersion = findProgramVersion "--numeric-version" id - } +c2hsProgram = + (simpleProgram "c2hs") + { programFindVersion = findProgramVersion "--numeric-version" id + } cpphsProgram :: Program -cpphsProgram = (simpleProgram "cpphs") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "cpphs --version" gives a string like "cpphs 1.3" - case words str of - (_:ver:_) -> ver - _ -> "" - } +cpphsProgram = + (simpleProgram "cpphs") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "cpphs --version" gives a string like "cpphs 1.3" + case words str of + (_ : ver : _) -> ver + _ -> "" + } hscolourProgram :: Program -hscolourProgram = (simpleProgram "hscolour") { - programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour", - programFindVersion = findProgramVersion "-version" $ \str -> - -- Invoking "HsColour -version" gives a string like "HsColour 1.7" - case words str of - (_:ver:_) -> ver - _ -> "" - } +hscolourProgram = + (simpleProgram "hscolour") + { programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour" + , programFindVersion = findProgramVersion "-version" $ \str -> + -- Invoking "HsColour -version" gives a string like "HsColour 1.7" + case words str of + (_ : ver : _) -> ver + _ -> "" + } -- TODO: Ensure that doctest is built against the same GHC as the one -- that's being used. Same for haddock. @phadej pointed this out. doctestProgram :: Program -doctestProgram = (simpleProgram "doctest") { - programFindLocation = \v p -> findProgramOnSearchPath v p "doctest" - , programFindVersion = findProgramVersion "--version" $ \str -> - -- "doctest version 0.11.2" - case words str of - (_:_:ver:_) -> ver - _ -> "" - } +doctestProgram = + (simpleProgram "doctest") + { programFindLocation = \v p -> findProgramOnSearchPath v p "doctest" + , programFindVersion = findProgramVersion "--version" $ \str -> + -- "doctest version 0.11.2" + case words str of + (_ : _ : ver : _) -> ver + _ -> "" + } haddockProgram :: Program -haddockProgram = (simpleProgram "haddock") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "haddock --version" gives a string like - -- "Haddock version 0.8, (c) Simon Marlow 2006" - case words str of - (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver - _ -> "", - - programNormaliseArgs = \_ _ args -> args - } +haddockProgram = + (simpleProgram "haddock") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "haddock --version" gives a string like + -- "Haddock version 0.8, (c) Simon Marlow 2006" + case words str of + (_ : _ : ver : _) -> takeWhile (`elem` ('.' : ['0' .. '9'])) ver + _ -> "" + , programNormaliseArgs = \_ _ args -> args + } greencardProgram :: Program greencardProgram = simpleProgram "greencard" ldProgram :: Program -ldProgram = (simpleProgram "ld") +ldProgram = + (simpleProgram "ld") { programPostConf = \verbosity ldProg -> do -- The `lld` linker cannot create merge (relocatable) objects so we -- want to detect this. @@ -361,19 +388,22 @@ } tarProgram :: Program -tarProgram = (simpleProgram "tar") { - -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the - -- '--format' option. - programPostConf = \verbosity tarProg -> do - tarHelpOutput <- getProgramInvocationOutput - verbosity (programInvocation tarProg ["--help"]) - -- Some versions of tar don't support '--help'. - `catchIO` (\_ -> return "") - let k = "Supports --format" - v = if "--format" `isInfixOf` tarHelpOutput then "YES" else "NO" - m = Map.insert k v (programProperties tarProg) - return $ tarProg { programProperties = m } - } +tarProgram = + (simpleProgram "tar") + { -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the + -- '--format' option. + programPostConf = \verbosity tarProg -> do + tarHelpOutput <- + getProgramInvocationOutput + verbosity + (programInvocation tarProg ["--help"]) + -- Some versions of tar don't support '--help'. + `catchIO` (\_ -> return "") + let k = "Supports --format" + v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO" + m = Map.insert k v (programProperties tarProg) + return $ tarProg{programProperties = m} + } cppProgram :: Program cppProgram = simpleProgram "cpp" 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 @@ -1,8 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Db -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 @@ -23,64 +24,64 @@ -- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a -- hook user the ability to get the above flags and such so that they -- don't have to write all the PATH logic inside Setup.lhs. - -module Distribution.Simple.Program.Db ( - -- * The collection of configured programs we can run - ProgramDb, - emptyProgramDb, - defaultProgramDb, - restoreProgramDb, +module Distribution.Simple.Program.Db + ( -- * The collection of configured programs we can run + ProgramDb + , emptyProgramDb + , defaultProgramDb + , restoreProgramDb -- ** Query and manipulate the program db - addKnownProgram, - addKnownPrograms, - appendProgramSearchPath, - lookupKnownProgram, - knownPrograms, - getProgramSearchPath, - setProgramSearchPath, - modifyProgramSearchPath, - userSpecifyPath, - userSpecifyPaths, - userMaybeSpecifyPath, - userSpecifyArgs, - userSpecifyArgss, - userSpecifiedArgs, - lookupProgram, - lookupProgramByName, - updateProgram, - configuredPrograms, + , addKnownProgram + , addKnownPrograms + , prependProgramSearchPath + , lookupKnownProgram + , knownPrograms + , getProgramSearchPath + , setProgramSearchPath + , modifyProgramSearchPath + , userSpecifyPath + , userSpecifyPaths + , userMaybeSpecifyPath + , userSpecifyArgs + , userSpecifyArgss + , userSpecifiedArgs + , lookupProgram + , lookupProgramByName + , updateProgram + , configuredPrograms -- ** Query and manipulate the program db - configureProgram, - configureAllKnownPrograms, - unconfigureProgram, - lookupProgramVersion, - reconfigurePrograms, - requireProgram, - requireProgramVersion, - needProgram, - + , configureProgram + , configureAllKnownPrograms + , unconfigureProgram + , lookupProgramVersion + , reconfigurePrograms + , requireProgram + , requireProgramVersion + , needProgram ) where import Distribution.Compat.Prelude import Prelude () -import Distribution.Pretty import Distribution.Simple.Program.Builtin import Distribution.Simple.Program.Find import Distribution.Simple.Program.Types import Distribution.Simple.Utils -import Distribution.Utils.Structured (Structure (..), Structured (..)) +import Distribution.Utils.Structured (Structure (..), Structured (..)) import Distribution.Verbosity import Distribution.Version import Data.Tuple (swap) import qualified Data.Map as Map +import Distribution.Simple.Errors -- ------------------------------------------------------------ + -- * Programs database + -- ------------------------------------------------------------ -- | The configuration is a collection of information about programs. It @@ -91,17 +92,16 @@ -- by one we try to configure them at which point we move them into the -- configured collection. For unconfigured programs we record not just the -- 'Program' but also any user-provided arguments and location for the program. -data ProgramDb = ProgramDb { - unconfiguredProgs :: UnconfiguredProgs, - progSearchPath :: ProgramSearchPath, - configuredProgs :: ConfiguredProgs - } +data ProgramDb = ProgramDb + { unconfiguredProgs :: UnconfiguredProgs + , progSearchPath :: ProgramSearchPath + , configuredProgs :: ConfiguredProgs + } deriving (Typeable) type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) -type UnconfiguredProgs = Map.Map String UnconfiguredProgram -type ConfiguredProgs = Map.Map String ConfiguredProgram - +type UnconfiguredProgs = Map.Map String UnconfiguredProgram +type ConfiguredProgs = Map.Map String ConfiguredProgram emptyProgramDb :: ProgramDb emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty @@ -109,38 +109,38 @@ defaultProgramDb :: ProgramDb defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb - -- internal helpers: -updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) - -> ProgramDb -> ProgramDb +updateUnconfiguredProgs + :: (UnconfiguredProgs -> UnconfiguredProgs) + -> ProgramDb + -> ProgramDb updateUnconfiguredProgs update progdb = - progdb { unconfiguredProgs = update (unconfiguredProgs progdb) } + progdb{unconfiguredProgs = update (unconfiguredProgs progdb)} -updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs) - -> ProgramDb -> ProgramDb +updateConfiguredProgs + :: (ConfiguredProgs -> ConfiguredProgs) + -> ProgramDb + -> ProgramDb updateConfiguredProgs update progdb = - progdb { configuredProgs = update (configuredProgs progdb) } - + progdb{configuredProgs = update (configuredProgs progdb)} -- Read & Show instances are based on listToFM -- | Note that this instance does not preserve the known 'Program's. -- See 'restoreProgramDb' for details. --- instance Show ProgramDb where show = show . Map.toAscList . configuredProgs -- | Note that this instance does not preserve the known 'Program's. -- See 'restoreProgramDb' for details. --- instance Read ProgramDb where readsPrec p s = - [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r) - | (s', r) <- readsPrec p s ] + [ (emptyProgramDb{configuredProgs = Map.fromList s'}, r) + | (s', r) <- readsPrec p s + ] -- | Note that this instance does not preserve the known 'Program's. -- See 'restoreProgramDb' for details. --- instance Binary ProgramDb where put db = do put (progSearchPath db) @@ -148,18 +148,22 @@ get = do searchpath <- get - progs <- get - return $! emptyProgramDb { - progSearchPath = searchpath, - configuredProgs = progs - } + progs <- get + return $! + emptyProgramDb + { progSearchPath = searchpath + , configuredProgs = progs + } instance Structured ProgramDb where - structure p = Nominal (typeRep p) 0 "ProgramDb" - [ structure (Proxy :: Proxy ProgramSearchPath) - , structure (Proxy :: Proxy ConfiguredProgs) - ] - + structure p = + Nominal + (typeRep p) + 0 + "ProgramDb" + [ structure (Proxy :: Proxy ProgramSearchPath) + , structure (Proxy :: Proxy ConfiguredProgs) + ] -- | The 'Read'\/'Show' and 'Binary' instances do not preserve all the -- unconfigured 'Programs' because 'Program' is not in 'Read'\/'Show' because @@ -168,142 +172,144 @@ -- -- * It does not add the default programs, but you probably want them, use -- 'builtinPrograms' in addition to any extra you might need. --- restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb restoreProgramDb = addKnownPrograms - -- ------------------------------- -- Managing unconfigured programs -- | Add a known program that we may configure later --- addKnownProgram :: Program -> ProgramDb -> ProgramDb -addKnownProgram prog = updateUnconfiguredProgs $ - Map.insertWith combine (programName prog) (prog, Nothing, []) - where combine _ (_, path, args) = (prog, path, args) - +addKnownProgram prog = + updateUnconfiguredProgs $ + Map.insertWith combine (programName prog) (prog, Nothing, []) + where + combine _ (_, path, args) = (prog, path, args) addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb addKnownPrograms progs progdb = foldl' (flip addKnownProgram) progdb progs - lookupKnownProgram :: String -> ProgramDb -> Maybe Program lookupKnownProgram name = - fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs - + fmap (\(p, _, _) -> p) . Map.lookup name . unconfiguredProgs knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)] knownPrograms progdb = - [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs progdb) - , let p' = Map.lookup (programName p) (configuredProgs progdb) ] + [ (p, p') | (p, _, _) <- Map.elems (unconfiguredProgs progdb), let p' = Map.lookup (programName p) (configuredProgs progdb) + ] -- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This is the default list of locations where programs are looked for when -- configuring them. This can be overridden for specific programs (with -- 'userSpecifyPath'), and specific known programs can modify or ignore this -- search path in their own configuration code. --- getProgramSearchPath :: ProgramDb -> ProgramSearchPath getProgramSearchPath = progSearchPath -- | Change the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This will affect programs that are configured from here on, so you -- should usually set it before configuring any programs. --- setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb -setProgramSearchPath searchpath db = db { progSearchPath = searchpath } +setProgramSearchPath searchpath db = db{progSearchPath = searchpath} -- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This will affect programs that are configured from here on, so you -- should usually modify it before configuring any programs. --- -modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath) - -> ProgramDb - -> ProgramDb +modifyProgramSearchPath + :: (ProgramSearchPath -> ProgramSearchPath) + -> ProgramDb + -> ProgramDb modifyProgramSearchPath f db = setProgramSearchPath (f $ getProgramSearchPath db) db -- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb' --- by appending the provided extra paths. Also logs the added paths +-- by prepending the provided extra paths. Also logs the added paths -- in info verbosity. -appendProgramSearchPath +prependProgramSearchPath :: Verbosity -> [FilePath] -> ProgramDb -> IO ProgramDb -appendProgramSearchPath verbosity extraPaths db = +prependProgramSearchPath verbosity extraPaths db = if not $ null extraPaths then do logExtraProgramSearchPath verbosity extraPaths pure $ modifyProgramSearchPath (map ProgramSearchPathDir extraPaths ++) db else pure db --- |User-specify this path. Basically override any path information --- for this program in the configuration. If it's not a known --- program ignore it. --- -userSpecifyPath :: String -- ^Program name - -> FilePath -- ^user-specified path to the program - -> ProgramDb -> ProgramDb +-- | User-specify this path. Basically override any path information +-- for this program in the configuration. If it's not a known +-- program ignore it. +userSpecifyPath + :: String + -- ^ Program name + -> FilePath + -- ^ user-specified path to the program + -> ProgramDb + -> ProgramDb userSpecifyPath name path = updateUnconfiguredProgs $ - flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args) - + flip Map.update name $ + \(prog, _, args) -> Just (prog, Just path, args) -userMaybeSpecifyPath :: String -> Maybe FilePath - -> ProgramDb -> ProgramDb -userMaybeSpecifyPath _ Nothing progdb = progdb +userMaybeSpecifyPath + :: String + -> Maybe FilePath + -> ProgramDb + -> ProgramDb +userMaybeSpecifyPath _ Nothing progdb = progdb userMaybeSpecifyPath name (Just path) progdb = userSpecifyPath name path progdb - --- |User-specify the arguments for this program. Basically override --- any args information for this program in the configuration. If it's --- not a known program, ignore it.. -userSpecifyArgs :: String -- ^Program name - -> [ProgArg] -- ^user-specified args - -> ProgramDb - -> ProgramDb +-- | User-specify the arguments for this program. Basically override +-- any args information for this program in the configuration. If it's +-- not a known program, ignore it.. +userSpecifyArgs + :: String + -- ^ Program name + -> [ProgArg] + -- ^ user-specified args + -> ProgramDb + -> ProgramDb userSpecifyArgs name args' = - updateUnconfiguredProgs - (flip Map.update name $ - \(prog, path, args) -> Just (prog, path, args ++ args')) - . updateConfiguredProgs - (flip Map.update name $ - \prog -> Just prog { programOverrideArgs = programOverrideArgs prog - ++ args' }) - + updateUnconfiguredProgs + ( flip Map.update name $ + \(prog, path, args) -> Just (prog, path, args ++ args') + ) + . updateConfiguredProgs + ( flip Map.update name $ + \prog -> + Just + prog + { programOverrideArgs = + programOverrideArgs prog + ++ args' + } + ) -- | Like 'userSpecifyPath' but for a list of progs and their paths. --- -userSpecifyPaths :: [(String, FilePath)] - -> ProgramDb - -> ProgramDb +userSpecifyPaths + :: [(String, FilePath)] + -> ProgramDb + -> ProgramDb userSpecifyPaths paths progdb = foldl' (\progdb' (prog, path) -> userSpecifyPath prog path progdb') progdb paths - -- | Like 'userSpecifyPath' but for a list of progs and their args. --- -userSpecifyArgss :: [(String, [ProgArg])] - -> ProgramDb - -> ProgramDb +userSpecifyArgss + :: [(String, [ProgArg])] + -> ProgramDb + -> ProgramDb userSpecifyArgss argss progdb = foldl' (\progdb' (prog, args) -> userSpecifyArgs prog args progdb') progdb argss - -- | 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 - + join . fmap (\(_, p, _) -> p) . Map.lookup (programName prog) . unconfiguredProgs -- | Get any extra args that have been previously specified for a program. --- userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] userSpecifiedArgs prog = - maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs - + maybe [] (\(_, _, as) -> as) . Map.lookup (programName prog) . unconfiguredProgs -- ----------------------------- -- Managing configured programs @@ -317,11 +323,13 @@ lookupProgramByName name = Map.lookup name . configuredProgs -- | Update a configured program in the database. -updateProgram :: ConfiguredProgram -> ProgramDb - -> ProgramDb -updateProgram prog = updateConfiguredProgs $ - Map.insert (programId prog) prog - +updateProgram + :: ConfiguredProgram + -> ProgramDb + -> ProgramDb +updateProgram prog = + updateConfiguredProgs $ + Map.insert (programId prog) prog -- | List all configured programs. configuredPrograms :: ProgramDb -> [ConfiguredProgram] @@ -343,57 +351,54 @@ -- front all the programs we will need, so we try to configure them all. -- To verify that a program was actually successfully configured use -- 'requireProgram'. --- -configureProgram :: Verbosity - -> Program - -> ProgramDb - -> IO ProgramDb +configureProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO ProgramDb configureProgram verbosity prog progdb = do let name = programName prog maybeLocation <- case userSpecifiedPath prog progdb of - Nothing -> + Nothing -> programFindLocation prog verbosity (progSearchPath progdb) - >>= return . fmap (swap . fmap FoundOnSystem . swap) + >>= return . fmap (swap . fmap FoundOnSystem . swap) Just path -> do absolute <- doesExecutableExist path if absolute then return (Just (UserSpecified path, [])) - else findProgramOnSearchPath verbosity (progSearchPath progdb) path - >>= maybe (die' verbosity notFound) - (return . Just . swap . fmap UserSpecified . swap) - where notFound = "Cannot find the program '" ++ name - ++ "'. User-specified path '" - ++ path ++ "' does not refer to an executable and " - ++ "the program is not on the system path." + else + findProgramOnSearchPath verbosity (progSearchPath progdb) path + >>= maybe + (dieWithException verbosity $ ConfigureProgram name path) + (return . Just . swap . fmap UserSpecified . swap) case maybeLocation of Nothing -> return progdb Just (location, triedLocations) -> do version <- programFindVersion prog verbosity (locationPath location) newPath <- programSearchPathAsPATHVar (progSearchPath progdb) - let configuredProg = ConfiguredProgram { - programId = name, - programVersion = version, - programDefaultArgs = [], - programOverrideArgs = userSpecifiedArgs prog progdb, - programOverrideEnv = [("PATH", Just newPath)], - programProperties = Map.empty, - programLocation = location, - programMonitorFiles = triedLocations - } + let configuredProg = + ConfiguredProgram + { programId = name + , programVersion = version + , programDefaultArgs = [] + , programOverrideArgs = userSpecifiedArgs prog progdb + , programOverrideEnv = [("PATH", Just newPath)] + , programProperties = Map.empty + , programLocation = location + , programMonitorFiles = triedLocations + } configuredProg' <- programPostConf prog verbosity configuredProg return (updateConfiguredProgs (Map.insert name configuredProg') progdb) - -- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. --- -configurePrograms :: Verbosity - -> [Program] - -> ProgramDb - -> IO ProgramDb +configurePrograms + :: Verbosity + -> [Program] + -> ProgramDb + -> IO ProgramDb configurePrograms verbosity progs progdb = foldM (flip (configureProgram verbosity)) progdb progs - -- | Unconfigure a program. This is basically a hack and you shouldn't -- use it, but it can be handy for making sure a 'requireProgram' -- actually reconfigures. @@ -402,51 +407,51 @@ updateConfiguredProgs $ Map.delete progname -- | Try to configure all the known programs that have not yet been configured. --- -configureAllKnownPrograms :: Verbosity - -> ProgramDb - -> IO ProgramDb +configureAllKnownPrograms + :: Verbosity + -> ProgramDb + -> IO ProgramDb configureAllKnownPrograms verbosity progdb = - configurePrograms verbosity - [ prog | (prog,_,_) <- Map.elems notYetConfigured ] progdb + configurePrograms + verbosity + [prog | (prog, _, _) <- Map.elems notYetConfigured] + progdb where - notYetConfigured = unconfiguredProgs progdb - `Map.difference` configuredProgs progdb - + notYetConfigured = + unconfiguredProgs progdb + `Map.difference` configuredProgs progdb -- | reconfigure a bunch of programs given new user-specified args. It takes -- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs -- with a new path it calls 'configureProgram'. --- -reconfigurePrograms :: Verbosity - -> [(String, FilePath)] - -> [(String, [ProgArg])] - -> ProgramDb - -> IO ProgramDb +reconfigurePrograms + :: Verbosity + -> [(String, FilePath)] + -> [(String, [ProgArg])] + -> ProgramDb + -> IO ProgramDb reconfigurePrograms verbosity paths argss progdb = do configurePrograms verbosity progs - . userSpecifyPaths paths - . userSpecifyArgss argss - $ progdb - + . userSpecifyPaths paths + . userSpecifyArgss argss + $ progdb where - progs = catMaybes [ lookupKnownProgram name progdb | (name,_) <- paths ] - + progs = catMaybes [lookupKnownProgram name progdb | (name, _) <- paths] -- | Check that a program is configured and available to be run. -- -- It raises an exception if the program could not be configured, otherwise -- it returns the configured program. --- -requireProgram :: Verbosity -> Program -> ProgramDb - -> IO (ConfiguredProgram, ProgramDb) +requireProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO (ConfiguredProgram, ProgramDb) requireProgram verbosity prog progdb = do - mres <- needProgram verbosity prog progdb - case mres of - Nothing -> die' verbosity notFound - Just res -> return res - where - notFound = "The program '" ++ programName prog ++ "' is required but it could not be found." + mres <- needProgram verbosity prog progdb + case mres of + Nothing -> dieWithException verbosity $ RequireProgram (programName prog) + Just res -> return res -- | Check that a program is configured and available to be run. -- @@ -454,17 +459,19 @@ -- or is not found. -- -- @since 3.0.1.0 -needProgram :: Verbosity -> Program -> ProgramDb - -> IO (Maybe (ConfiguredProgram, ProgramDb)) +needProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO (Maybe (ConfiguredProgram, ProgramDb)) needProgram verbosity prog progdb = do - -- If it's not already been configured, try to configure it now progdb' <- case lookupProgram prog progdb of Nothing -> configureProgram verbosity prog progdb - Just _ -> return progdb + Just _ -> return progdb case lookupProgram prog progdb' of - Nothing -> return Nothing + Nothing -> return Nothing Just configuredProg -> return (Just (configuredProg, progdb')) -- | Check that a program is configured and available to be run. @@ -476,50 +483,39 @@ -- It returns the configured program, its version number and a possibly updated -- 'ProgramDb'. If the program could not be configured or the version is -- unsuitable, it returns an error value. --- lookupProgramVersion - :: Verbosity -> Program -> VersionRange -> ProgramDb - -> IO (Either String (ConfiguredProgram, Version, ProgramDb)) + :: Verbosity + -> Program + -> VersionRange + -> ProgramDb + -> IO (Either CabalException (ConfiguredProgram, Version, ProgramDb)) lookupProgramVersion verbosity prog range programDb = do - -- If it's not already been configured, try to configure it now programDb' <- case lookupProgram prog programDb of Nothing -> configureProgram verbosity prog programDb - Just _ -> return programDb + Just _ -> return programDb case lookupProgram prog programDb' of - Nothing -> return $! Left notFound - Just configuredProg@ConfiguredProgram { programLocation = location } -> + Nothing -> return $! Left $ NoProgramFound (programName prog) range + Just configuredProg@ConfiguredProgram{programLocation = location} -> case programVersion configuredProg of Just version | withinRange version range -> - return $! Right (configuredProg, version ,programDb') - | otherwise -> - return $! Left (badVersion version location) - Nothing -> - return $! Left (unknownVersion location) - - where notFound = "The program '" - ++ programName prog ++ "'" ++ versionRequirement - ++ " is required but it could not be found." - badVersion v l = "The program '" - ++ programName prog ++ "'" ++ versionRequirement - ++ " is required but the version found at " - ++ locationPath l ++ " is version " ++ prettyShow v - unknownVersion l = "The program '" - ++ programName prog ++ "'" ++ versionRequirement - ++ " is required but the version of " - ++ locationPath l ++ " could not be determined." - versionRequirement - | isAnyVersion range = "" - | otherwise = " version " ++ prettyShow range + return $! Right (configuredProg, version, programDb') + | otherwise -> + return $! Left $ BadVersionDb (programName prog) version range (locationPath location) + Nothing -> + return $! Left $ UnknownVersionDb (programName prog) range (locationPath location) -- | Like 'lookupProgramVersion', but raises an exception in case of error -- instead of returning 'Left errMsg'. --- -requireProgramVersion :: Verbosity -> Program -> VersionRange - -> ProgramDb - -> IO (ConfiguredProgram, Version, ProgramDb) +requireProgramVersion + :: Verbosity + -> Program + -> VersionRange + -> ProgramDb + -> IO (ConfiguredProgram, Version, ProgramDb) requireProgramVersion verbosity prog range programDb = - join $ either (die' verbosity) return `fmap` - lookupProgramVersion verbosity prog range programDb + join $ + either (dieWithException verbosity) return + `fmap` 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 @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Find -- Copyright : Duncan Coutts 2013 @@ -24,34 +25,39 @@ -- So we need an extension of the usual 'findExecutable' that can look in -- additional locations, either before, after or instead of the normal OS -- locations. --- -module Distribution.Simple.Program.Find ( - -- * Program search path - ProgramSearchPath, - ProgramSearchPathEntry(..), - defaultProgramSearchPath, - findProgramOnSearchPath, - programSearchPathAsPATHVar, - logExtraProgramSearchPath, - getSystemSearchPath, - getExtraPathEnv, - simpleProgram +module Distribution.Simple.Program.Find + ( -- * Program search path + ProgramSearchPath + , ProgramSearchPathEntry (..) + , defaultProgramSearchPath + , findProgramOnSearchPath + , programSearchPathAsPATHVar + , logExtraProgramSearchPath + , getSystemSearchPath + , getExtraPathEnv + , simpleProgram ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Verbosity +import Distribution.Compat.Environment import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.System -import Distribution.Compat.Environment +import Distribution.Verbosity import qualified System.Directory as Directory - ( findExecutable ) + ( findExecutable + ) import System.FilePath as FilePath - ( (), (<.>), splitSearchPath, searchPathSeparator, getSearchPath - , takeDirectory ) + ( getSearchPath + , searchPathSeparator + , splitSearchPath + , takeDirectory + , (<.>) + , () + ) #if defined(mingw32_HOST_OS) import qualified System.Win32 as Win32 #endif @@ -68,69 +74,74 @@ "Including the following directories in PATH:" : map ("- " ++) extraPaths -findProgramOnSearchPath :: Verbosity -> ProgramSearchPath - -> FilePath -> IO (Maybe (FilePath, [FilePath])) +findProgramOnSearchPath + :: Verbosity + -> ProgramSearchPath + -> FilePath + -> IO (Maybe (FilePath, [FilePath])) findProgramOnSearchPath verbosity searchpath prog = do - debug verbosity $ "Searching for " ++ prog ++ " in path." - res <- tryPathElems [] searchpath - case res of - Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") - Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at "++ path) - return res + debug verbosity $ "Searching for " ++ prog ++ " in path." + res <- tryPathElems [] searchpath + case res of + Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") + Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at " ++ path) + return res where - tryPathElems :: [[FilePath]] -> [ProgramSearchPathEntry] - -> IO (Maybe (FilePath, [FilePath])) - tryPathElems _ [] = return Nothing - tryPathElems tried (pe:pes) = do + tryPathElems + :: [[FilePath]] + -> [ProgramSearchPathEntry] + -> IO (Maybe (FilePath, [FilePath])) + tryPathElems _ [] = return Nothing + tryPathElems tried (pe : pes) = do res <- tryPathElem pe case res of - (Nothing, notfoundat) -> tryPathElems (notfoundat : tried) pes + (Nothing, notfoundat) -> tryPathElems (notfoundat : tried) pes (Just foundat, notfoundat) -> return (Just (foundat, alltried)) where alltried = concat (reverse (notfoundat : tried)) tryPathElem :: ProgramSearchPathEntry -> IO (Maybe FilePath, [FilePath]) tryPathElem (ProgramSearchPathDir dir) = - findFirstExe [ dir prog <.> ext | ext <- exeExtensions ] - + findFirstExe [dir prog <.> ext | ext <- exeExtensions] -- On windows, getSystemSearchPath is not guaranteed 100% correct so we -- use findExecutable and then approximate the not-found-at locations. tryPathElem ProgramSearchPathDefault | buildOS == Windows = do - mExe <- firstJustM [ findExecutable (prog <.> ext) | ext <- exeExtensions ] + mExe <- firstJustM [findExecutable (prog <.> ext) | ext <- exeExtensions] syspath <- getSystemSearchPath case mExe of Nothing -> - let notfoundat = [ dir prog | dir <- syspath ] in - return (Nothing, notfoundat) - + let notfoundat = [dir prog | dir <- syspath] + in return (Nothing, notfoundat) Just foundat -> do - let founddir = takeDirectory foundat - notfoundat = [ dir prog - | dir <- takeWhile (/= founddir) syspath ] + let founddir = takeDirectory foundat + notfoundat = + [ dir prog + | dir <- takeWhile (/= founddir) syspath + ] return (Just foundat, notfoundat) -- On other OSs we can just do the simple thing tryPathElem ProgramSearchPathDefault = do dirs <- getSystemSearchPath - findFirstExe [ dir prog <.> ext | dir <- dirs, ext <- exeExtensions ] + findFirstExe [dir prog <.> ext | dir <- dirs, ext <- exeExtensions] findFirstExe :: [FilePath] -> IO (Maybe FilePath, [FilePath]) findFirstExe = go [] where - go fs' [] = return (Nothing, reverse fs') - go fs' (f:fs) = do + go fs' [] = return (Nothing, reverse fs') + go fs' (f : fs) = do isExe <- doesExecutableExist f if isExe then return (Just f, reverse fs') - else go (f:fs') fs + else go (f : fs') fs -- Helper for evaluating actions until the first one returns 'Just' firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a) firstJustM [] = return Nothing - firstJustM (ma:mas) = do + firstJustM (ma : mas) = do a <- ma case a of - Just _ -> return a + Just _ -> return a Nothing -> firstJustM mas -- | Adds some paths to the "PATH" entry in the key-value environment provided @@ -157,17 +168,16 @@ -- algorithm looks at more than just the @%PATH%@. programSearchPathAsPATHVar :: ProgramSearchPath -> IO String programSearchPathAsPATHVar searchpath = do - ess <- traverse getEntries searchpath - return (intercalate [searchPathSeparator] (concat ess)) + ess <- traverse getEntries searchpath + return (intercalate [searchPathSeparator] (concat ess)) where getEntries (ProgramSearchPathDir dir) = return [dir] - getEntries ProgramSearchPathDefault = do + getEntries ProgramSearchPathDefault = do env <- getEnvironment return (maybe [] splitSearchPath (lookup "PATH" env)) -- | Get the system search path. On Unix systems this is just the @$PATH@ env -- var, but on windows it's a bit more complicated. --- getSystemSearchPath :: IO [FilePath] getSystemSearchPath = fmap nub $ do #if defined(mingw32_HOST_OS) @@ -207,19 +217,18 @@ _ -> return mExe #endif - -- | Make a simple named program. -- -- By default we'll just search for it in the path and not try to find the -- version name. You can override these behaviours if necessary, eg: -- -- > (simpleProgram "foo") { programFindLocation = ... , programFindVersion ... } --- simpleProgram :: String -> Program -simpleProgram name = Program { - programName = name, - programFindLocation = \v p -> findProgramOnSearchPath v p name, - programFindVersion = \_ _ -> return Nothing, - programPostConf = \_ p -> return p, - programNormaliseArgs = \_ _ -> id - } +simpleProgram name = + Program + { programName = name + , programFindLocation = \v p -> findProgramOnSearchPath v p name + , programFindVersion = \_ _ -> return Nothing + , programPostConf = \_ p -> return p + , programNormaliseArgs = \_ _ -> id + } 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 @@ -4,861 +4,917 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Simple.Program.GHC ( - GhcOptions(..), - GhcMode(..), - GhcOptimisation(..), - GhcDynLinkMode(..), - GhcProfAuto(..), - - ghcInvocation, - renderGhcOptions, - - runGHC, - - packageDbArgsDb, - normaliseGhcArgs - - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Backpack -import Distribution.Compat.Semigroup (First'(..), Last'(..), Option'(..)) -import Distribution.Simple.GHC.ImplInfo -import Distribution.PackageDescription -import Distribution.ModuleName -import Distribution.Simple.Compiler -import Distribution.Simple.Flag -import Distribution.Simple.Program.Find (getExtraPathEnv) -import Distribution.Simple.Program.Run -import Distribution.Simple.Program.Types -import Distribution.System -import Distribution.Pretty -import Distribution.Types.ComponentId -import Distribution.Verbosity -import Distribution.Version -import Distribution.Utils.NubList -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 - -normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String] -normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs - | ghcVersion `withinRange` supportedGHCVersions - = argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs - where - supportedGHCVersions :: VersionRange - supportedGHCVersions = orLaterVersion (mkVersion [8,0]) - -- we (weakly) support unknown future GHC versions for the purpose - -- of filtering GHC arguments - - from :: Monoid m => [Int] -> m -> m - from version flags - | ghcVersion `withinRange` orLaterVersion (mkVersion version) = flags - | otherwise = mempty - - to :: Monoid m => [Int] -> m -> m - to version flags - | ghcVersion `withinRange` earlierVersion (mkVersion version) = flags - | otherwise = mempty - - checkGhcFlags :: forall m . Monoid m => ([String] -> m) -> m - checkGhcFlags fun = mconcat - [ fun ghcArgs - , checkComponentFlags libBuildInfo pkgLibs - , checkComponentFlags buildInfo executables - , checkComponentFlags testBuildInfo testSuites - , checkComponentFlags benchmarkBuildInfo benchmarks - ] - where - pkgLibs = maybeToList library ++ subLibraries - - checkComponentFlags :: (a -> BuildInfo) -> [a] -> m - checkComponentFlags getInfo = foldMap (checkComponent . getInfo) - where - checkComponent :: BuildInfo -> m - checkComponent = foldMap fun . filterGhcOptions . allGhcOptions - - allGhcOptions :: BuildInfo -> [(CompilerFlavor, [String])] - allGhcOptions = foldMap (perCompilerFlavorToList .) - [options, profOptions, sharedOptions, staticOptions] - - filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]] - filterGhcOptions l = [opts | (GHC, opts) <- l] - - safeToFilterWarnings :: Bool - safeToFilterWarnings = getAll $ checkGhcFlags checkWarnings - where - checkWarnings :: [String] -> All - checkWarnings = All . Set.null . foldr alter Set.empty - - alter :: String -> Set String -> Set String - alter flag = appEndo $ mconcat - [ \s -> Endo $ if s == "-Werror" then Set.insert s else id - , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id - , \s -> from [8,6] . Endo $ - if s == "-Werror=compat" - then Set.union compatWarningSet else id - , \s -> from [8,6] . Endo $ - if s == "-Wno-error=compat" - then (`Set.difference` compatWarningSet) else id - , \s -> from [8,6] . Endo $ - if s == "-Wwarn=compat" - then (`Set.difference` compatWarningSet) else id - , from [8,4] $ markFlag "-Werror=" Set.insert - , from [8,4] $ markFlag "-Wwarn=" Set.delete - , from [8,4] $ markFlag "-Wno-error=" Set.delete - ] flag - - markFlag - :: String - -> (String -> Set String -> Set String) - -> String - -> Endo (Set String) - markFlag name update flag = Endo $ case stripPrefix name flag of - Just rest | not (null rest) && rest /= "compat" -> update rest - _ -> id - - flagArgumentFilter :: [String] -> [String] -> [String] - flagArgumentFilter flags = go - where - makeFilter :: String -> String -> Option' (First' ([String] -> [String])) - makeFilter flag arg = Option' $ First' . filterRest <$> stripPrefix flag arg - where - filterRest leftOver = case dropEq leftOver of - [] -> drop 1 - _ -> id - - checkFilter :: String -> Maybe ([String] -> [String]) - checkFilter = fmap getFirst' . getOption' . foldMap makeFilter flags - - go :: [String] -> [String] - go [] = [] - go (arg:args) = case checkFilter arg of - Just f -> go (f args) - Nothing -> arg : go args - - argumentFilters :: [String] -> [String] - argumentFilters = flagArgumentFilter - ["-ghci-script", "-H", "-interactive-print"] - - filterRtsOpts :: [String] -> [String] - filterRtsOpts = go False - where - go :: Bool -> [String] -> [String] - go _ [] = [] - go _ ("+RTS":opts) = go True opts - go _ ("-RTS":opts) = go False opts - go isRTSopts (opt:opts) = addOpt $ go isRTSopts opts - where - addOpt | isRTSopts = id - | otherwise = (opt:) - - simpleFilters :: String -> Bool - simpleFilters = not . getAny . mconcat - [ flagIn simpleFlags - , Any . isPrefixOf "-ddump-" - , Any . isPrefixOf "-dsuppress-" - , Any . isPrefixOf "-dno-suppress-" - , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"] - , flagIn . invertibleFlagSet "-f" . mconcat $ - [ [ "reverse-errors", "warn-unused-binds", "break-on-error" - , "break-on-exception", "print-bind-result" - , "print-bind-contents", "print-evld-with-show" - , "implicit-import-qualified", "error-spans" - ] - , from [7,8] - [ "print-explicit-foralls" -- maybe also earlier, but GHC-7.6 doesn't have --show-options - , "print-explicit-kinds" - ] - , from [8,0] - [ "print-explicit-coercions" - , "print-explicit-runtime-reps" - , "print-equality-relations" - , "print-unicode-syntax" - , "print-expanded-synonyms" - , "print-potential-instances" - , "print-typechecker-elaboration" - ] - , from [8,2] - [ "diagnostics-show-caret", "local-ghci-history" - , "show-warning-groups", "hide-source-paths" - , "show-hole-constraints" - ] - , from [8,4] ["show-loaded-modules"] - , from [8,6] [ "ghci-leak-check", "no-it" ] - , from [8,10] - [ "defer-diagnostics" -- affects printing of diagnostics - , "keep-going" -- try harder, the build will still fail if it's erroneous - , "print-axiom-incomps" -- print more debug info for closed type families - ] - ] - , flagIn . invertibleFlagSet "-d" $ [ "ppr-case-as-let", "ppr-ticks" ] - , isOptIntFlag - , isIntFlag - , if safeToFilterWarnings - then isWarning <> (Any . ("-w"==)) - else mempty - , from [8,6] $ - if safeToFilterHoles - then isTypedHoleFlag - else mempty - ] - - flagIn :: Set String -> String -> Any - flagIn set flag = Any $ Set.member flag set - - isWarning :: String -> Any - isWarning = mconcat $ map ((Any .) . isPrefixOf) - ["-fwarn-", "-fno-warn-", "-W", "-Wno-"] - - simpleFlags :: Set String - simpleFlags = Set.fromList . mconcat $ - [ [ "-n", "-#include", "-Rghc-timing", "-dstg-stats" - , "-dth-dec-file", "-dsource-stats", "-dverbose-core2core" - , "-dverbose-stg2stg", "-dcore-lint", "-dstg-lint", "-dcmm-lint" - , "-dasm-lint", "-dannot-lint", "-dshow-passes", "-dfaststring-stats" - , "-fno-max-relevant-binds", "-recomp", "-no-recomp", "-fforce-recomp" - , "-fno-force-recomp" - ] - - , from [8,2] - [ "-fno-max-errors", "-fdiagnostics-color=auto" - , "-fdiagnostics-color=always", "-fdiagnostics-color=never" - , "-dppr-debug", "-dno-debug-output" - ] - - , from [8,4] [ "-ddebug-output" ] - , from [8,4] $ to [8,6] [ "-fno-max-valid-substitutions" ] - , from [8,6] [ "-dhex-word-literals" ] - , from [8,8] [ "-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits" ] - , from [9,0] [ "-dlinear-core-lint" ] - ] - - isOptIntFlag :: String -> Any - isOptIntFlag = mconcat . map (dropIntFlag True) $ ["-v", "-j"] - - isIntFlag :: String -> Any - isIntFlag = mconcat . map (dropIntFlag False) . mconcat $ - [ [ "-fmax-relevant-binds", "-ddpr-user-length", "-ddpr-cols" - , "-dtrace-level", "-fghci-hist-size" ] - , from [8,2] ["-fmax-uncovered-patterns", "-fmax-errors"] - , from [8,4] $ to [8,6] ["-fmax-valid-substitutions"] - ] - - dropIntFlag :: Bool -> String -> String -> Any - dropIntFlag isOpt flag input = Any $ case stripPrefix flag input of - Nothing -> False - Just rest | isOpt && null rest -> True - | otherwise -> case parseInt rest of - Just _ -> True - Nothing -> False - where - parseInt :: String -> Maybe Int - parseInt = readMaybe . dropEq - - dropEq :: String -> String - dropEq ('=':s) = s - dropEq s = s - - invertibleFlagSet :: String -> [String] -> Set String - invertibleFlagSet prefix flagNames = - Set.fromList $ (++) <$> [prefix, prefix ++ "no-"] <*> flagNames - - compatWarningSet :: Set String - compatWarningSet = Set.fromList $ mconcat - [ from [8,6] - [ "missing-monadfail-instances", "semigroup" - , "noncanonical-monoid-instances", "implicit-kind-vars" ] - ] - - safeToFilterHoles :: Bool - safeToFilterHoles = getAll . checkGhcFlags $ - All . fromMaybe True . fmap getLast' . getOption' . 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 - - isTypedHoleFlag :: String -> Any - isTypedHoleFlag = mconcat - [ flagIn . invertibleFlagSet "-f" $ - [ "show-hole-constraints", "show-valid-substitutions" - , "show-valid-hole-fits", "sort-valid-hole-fits" - , "sort-by-size-hole-fits", "sort-by-subsumption-hole-fits" - , "abstract-refinement-hole-fits", "show-provenance-of-hole-fits" - , "show-hole-matches-of-hole-fits", "show-type-of-hole-fits" - , "show-type-app-of-hole-fits", "show-type-app-vars-of-hole-fits" - , "unclutter-valid-hole-fits" - ] - , flagIn . Set.fromList $ - [ "-fno-max-valid-hole-fits", "-fno-max-refinement-hole-fits" - , "-fno-refinement-level-hole-fits" ] - , mconcat . map (dropIntFlag False) $ - [ "-fmax-valid-hole-fits", "-fmax-refinement-hole-fits" - , "-frefinement-level-hole-fits" ] - ] - -normaliseGhcArgs _ _ args = args - --- | A structured set of GHC options/flags --- --- Note that options containing lists fall into two categories: --- --- * options that can be safely deduplicated, e.g. input modules or --- enabled extensions; --- * options that cannot be deduplicated in general without changing --- semantics, e.g. extra ghc options or linking options. -data GhcOptions = GhcOptions { - - -- | The major mode for the ghc invocation. - ghcOptMode :: Flag GhcMode, - - -- | Any extra options to pass directly to ghc. These go at the end and hence - -- override other stuff. - ghcOptExtra :: [String], - - -- | Extra default flags to pass directly to ghc. These go at the beginning - -- and so can be overridden by other stuff. - ghcOptExtraDefault :: [String], - - ----------------------- - -- Inputs and outputs - - -- | The main input files; could be .hs, .hi, .c, .o, depending on mode. - ghcOptInputFiles :: NubListR FilePath, - - -- | Script files with irregular extensions that need -x hs. - ghcOptInputScripts :: NubListR FilePath, - - -- | The names of input Haskell modules, mainly for @--make@ mode. - ghcOptInputModules :: NubListR ModuleName, - - -- | Location for output file; the @ghc -o@ flag. - ghcOptOutputFile :: Flag FilePath, - - -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode; - -- the @ghc -dyno@ flag. - ghcOptOutputDynFile :: Flag FilePath, - - -- | Start with an empty search path for Haskell source files; - -- the @ghc -i@ flag (@-i@ on its own with no path argument). - ghcOptSourcePathClear :: Flag Bool, - - -- | Search path for Haskell source files; the @ghc -i@ flag. - ghcOptSourcePath :: NubListR FilePath, - - ------------- - -- Packages - - -- | The unit ID the modules will belong to; the @ghc -this-unit-id@ - -- flag (or @-this-package-key@ or @-package-name@ on older - -- versions of GHC). This is a 'String' because we assume you've - -- already figured out what the correct format for this string is - -- (we need to handle backwards compatibility.) - ghcOptThisUnitId :: Flag String, - - -- | GHC doesn't make any assumptions about the format of - -- definite unit ids, so when we are instantiating a package it - -- needs to be told explicitly what the component being instantiated - -- is. This only gets set when 'ghcOptInstantiatedWith' is non-empty - ghcOptThisComponentId :: Flag ComponentId, - - -- | How the requirements of the package being compiled are to - -- be filled. When typechecking an indefinite package, the 'OpenModule' - -- is always a 'OpenModuleVar'; otherwise, it specifies the installed module - -- that instantiates a package. - ghcOptInstantiatedWith :: [(ModuleName, OpenModule)], - - -- | No code? (But we turn on interface writing - ghcOptNoCode :: Flag Bool, - - -- | GHC package databases to use, the @ghc -package-conf@ flag. - ghcOptPackageDBs :: PackageDBStack, - - -- | The GHC packages to bring into scope when compiling, - -- the @ghc -package-id@ flags. - ghcOptPackages :: - NubListR (OpenUnitId, ModuleRenaming), - - -- | Start with a clean package set; the @ghc -hide-all-packages@ flag - ghcOptHideAllPackages :: Flag Bool, - - -- | Warn about modules, not listed in command line - ghcOptWarnMissingHomeModules :: Flag Bool, - - -- | Don't automatically link in Haskell98 etc; the @ghc - -- -no-auto-link-packages@ flag. - ghcOptNoAutoLinkPackages :: Flag Bool, - - ----------------- - -- Linker stuff - - -- | Names of libraries to link in; the @ghc -l@ flag. - ghcOptLinkLibs :: [FilePath], - - -- | Search path for libraries to link in; the @ghc -L@ flag. - ghcOptLinkLibPath :: NubListR FilePath, - - -- | Options to pass through to the linker; the @ghc -optl@ flag. - ghcOptLinkOptions :: [String], - - -- | OSX only: frameworks to link in; the @ghc -framework@ flag. - ghcOptLinkFrameworks :: NubListR String, - - -- | OSX only: Search path for frameworks to link in; the - -- @ghc -framework-path@ flag. - ghcOptLinkFrameworkDirs :: NubListR String, - - -- | Instruct GHC to link against @libHSrts@ when producing a shared library. - ghcOptLinkRts :: Flag Bool, - - -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag. - ghcOptNoLink :: Flag Bool, - - -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ - -- flag. - ghcOptLinkNoHsMain :: Flag Bool, - - -- | Module definition files (Windows specific) - ghcOptLinkModDefFiles :: NubListR FilePath, - - -------------------- - -- C and CPP stuff - - -- | Options to pass through to the C compiler; the @ghc -optc@ flag. - ghcOptCcOptions :: [String], - - -- | Options to pass through to the C++ compiler. - ghcOptCxxOptions :: [String], - - -- | Options to pass through to the Assembler. - ghcOptAsmOptions :: [String], - - -- | Options to pass through to CPP; the @ghc -optP@ flag. - ghcOptCppOptions :: [String], - - -- | Search path for CPP includes like header files; the @ghc -I@ flag. - ghcOptCppIncludePath :: NubListR FilePath, - - -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag. - ghcOptCppIncludes :: NubListR FilePath, - - -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag. - ghcOptFfiIncludes :: NubListR FilePath, - - -- | Program to use for the C and C++ compiler; the @ghc -pgmc@ flag. - ghcOptCcProgram :: Flag FilePath, - - ---------------------------- - -- Language and extensions - - -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag. - ghcOptLanguage :: Flag Language, - - -- | The language extensions; the @ghc -X@ flag. - ghcOptExtensions :: NubListR Extension, - - -- | A GHC version-dependent mapping of extensions to flags. This must be - -- set to be able to make use of the 'ghcOptExtensions'. - ghcOptExtensionMap :: Map Extension (Maybe CompilerFlag), - - ---------------- - -- Compilation - - -- | What optimisation level to use; the @ghc -O@ flag. - ghcOptOptimisation :: Flag GhcOptimisation, - - -- | Emit debug info; the @ghc -g@ flag. - ghcOptDebugInfo :: Flag DebugInfoLevel, - - -- | Compile in profiling mode; the @ghc -prof@ flag. - ghcOptProfilingMode :: Flag Bool, - - -- | Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags. - ghcOptProfilingAuto :: Flag GhcProfAuto, - - -- | Use the \"split sections\" feature; the @ghc -split-sections@ flag. - ghcOptSplitSections :: Flag Bool, - - -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag. - ghcOptSplitObjs :: Flag Bool, - - -- | Run N jobs simultaneously (if possible). - ghcOptNumJobs :: Flag (Maybe Int), - - -- | Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags. - ghcOptHPCDir :: Flag FilePath, - - ---------------- - -- GHCi - - -- | Extra GHCi startup scripts; the @-ghci-script@ flag - ghcOptGHCiScripts :: [FilePath], - - ------------------------ - -- Redirecting outputs - - ghcOptHiSuffix :: Flag String, - ghcOptObjSuffix :: Flag String, - ghcOptDynHiSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode - ghcOptDynObjSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode - ghcOptHiDir :: Flag FilePath, - ghcOptObjDir :: Flag FilePath, - ghcOptOutputDir :: Flag FilePath, - ghcOptStubDir :: Flag FilePath, - - -------------------- - -- Creating libraries - - ghcOptDynLinkMode :: Flag GhcDynLinkMode, - ghcOptStaticLib :: Flag Bool, - ghcOptShared :: Flag Bool, - ghcOptFPic :: Flag Bool, - ghcOptDylibName :: Flag String, - ghcOptRPaths :: NubListR FilePath, - - --------------- - -- Misc flags - - -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. - ghcOptVerbosity :: Flag Verbosity, - - -- | Put the extra folders in the PATH environment variable we invoke - -- GHC with - ghcOptExtraPath :: NubListR FilePath, - - -- | Let GHC know that it is Cabal that's calling it. - -- Modifies some of the GHC error messages. - ghcOptCabal :: Flag Bool - -} deriving (Show, Generic) - - -data GhcMode = GhcModeCompile -- ^ @ghc -c@ - | GhcModeLink -- ^ @ghc@ - | GhcModeMake -- ^ @ghc --make@ - | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@ - | GhcModeAbiHash -- ^ @ghc --abi-hash@ --- | GhcModeDepAnalysis -- ^ @ghc -M@ --- | GhcModeEvaluate -- ^ @ghc -e@ - deriving (Show, Eq) - -data GhcOptimisation = GhcNoOptimisation -- ^ @-O0@ - | GhcNormalOptimisation -- ^ @-O@ - | GhcMaximumOptimisation -- ^ @-O2@ - | GhcSpecialOptimisation String -- ^ e.g. @-Odph@ - deriving (Show, Eq) - -data GhcDynLinkMode = GhcStaticOnly -- ^ @-static@ - | GhcDynamicOnly -- ^ @-dynamic@ - | GhcStaticAndDynamic -- ^ @-static -dynamic-too@ - deriving (Show, Eq) - -data GhcProfAuto = GhcProfAutoAll -- ^ @-fprof-auto@ - | GhcProfAutoToplevel -- ^ @-fprof-auto-top@ - | GhcProfAutoExported -- ^ @-fprof-auto-exported@ - | GhcProfLate -- ^ @-fprof-late - deriving (Show, Eq) - -runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> Platform -> GhcOptions - -> IO () -runGHC verbosity ghcProg comp platform opts = do - runProgramInvocation verbosity =<< ghcInvocation verbosity ghcProg comp platform opts - -ghcInvocation :: Verbosity -> ConfiguredProgram -> Compiler -> Platform -> GhcOptions - -> IO ProgramInvocation -ghcInvocation verbosity ghcProg comp platform opts = do - -- NOTE: GHC is the only program whose path we modify with more values than - -- the standard @extra-prog-path@, namely the folders of the executables in - -- the components, see @componentGhcOptions@. - let envOverrides = programOverrideEnv ghcProg - extraPath <- getExtraPathEnv verbosity envOverrides (fromNubListR (ghcOptExtraPath opts)) - let ghcProg' = ghcProg{programOverrideEnv = envOverrides ++ extraPath} - - pure $ programInvocation ghcProg' (renderGhcOptions comp platform opts) - -renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] -renderGhcOptions comp _platform@(Platform _arch os) opts - | compilerFlavor comp `notElem` [GHC, GHCJS] = - error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " - ++ "compiler flavor must be 'GHC' or 'GHCJS'!" - | otherwise = - concat - [ case flagToMaybe (ghcOptMode opts) of - Nothing -> [] - Just GhcModeCompile -> ["-c"] - Just GhcModeLink -> [] - Just GhcModeMake -> ["--make"] - Just GhcModeInteractive -> ["--interactive"] - Just GhcModeAbiHash -> ["--abi-hash"] --- Just GhcModeDepAnalysis -> ["-M"] --- Just GhcModeEvaluate -> ["-e", expr] - - , ghcOptExtraDefault opts - - , [ "-no-link" | flagBool ghcOptNoLink ] - , [ "-flink-rts" | flagBool ghcOptLinkRts ] - - --------------- - -- Misc flags - - , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) - - , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal ] - - ---------------- - -- Compilation - - , case flagToMaybe (ghcOptOptimisation opts) of - Nothing -> [] - Just GhcNoOptimisation -> ["-O0"] - Just GhcNormalOptimisation -> ["-O"] - Just GhcMaximumOptimisation -> ["-O2"] - Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph - - , case flagToMaybe (ghcOptDebugInfo opts) of - Nothing -> [] - Just NoDebugInfo -> [] - Just MinimalDebugInfo -> ["-g1"] - Just NormalDebugInfo -> ["-g2"] - Just MaximalDebugInfo -> ["-g3"] - - , [ "-prof" | flagBool ghcOptProfilingMode ] - - , case flagToMaybe (ghcOptProfilingAuto opts) of - _ | not (flagBool ghcOptProfilingMode) - -> [] - Nothing -> [] - Just GhcProfAutoAll - | flagProfAuto implInfo -> ["-fprof-auto"] - | otherwise -> ["-auto-all"] -- not the same, but close - 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"] - - , [ "-split-sections" | flagBool ghcOptSplitSections ] - , [ "-split-objs" | flagBool ghcOptSplitObjs ] - - , case flagToMaybe (ghcOptHPCDir opts) of - Nothing -> [] - Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir] - - , if parmakeSupported comp - then case ghcOptNumJobs opts of - NoFlag -> [] - Flag n -> ["-j" ++ maybe "" show n] - else [] - - -------------------- - -- Creating libraries - - , [ "-staticlib" | flagBool ghcOptStaticLib ] - , [ "-shared" | flagBool ghcOptShared ] - , case flagToMaybe (ghcOptDynLinkMode opts) of - Nothing -> [] - Just GhcStaticOnly -> ["-static"] - Just GhcDynamicOnly -> ["-dynamic"] - Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"] - , [ "-fPIC" | flagBool ghcOptFPic ] - - , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ] - - ------------------------ - -- Redirecting outputs - - , concat [ ["-osuf", suf] | suf <- flag ghcOptObjSuffix ] - , concat [ ["-hisuf", suf] | suf <- flag ghcOptHiSuffix ] - , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ] - , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix ] - , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir ] - , concat [ ["-odir", dir] | dir <- flag ghcOptObjDir ] - , concat [ ["-hidir", dir] | dir <- flag ghcOptHiDir ] - , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir ] - - ----------------------- - -- Source search path - - , [ "-i" | flagBool ghcOptSourcePathClear ] - , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ] - - -------------------- - - -------------------- - -- CPP, C, and C++ stuff - - , [ "-I" ++ dir | dir <- flags ghcOptCppIncludePath ] - , [ "-optP" ++ opt | opt <- ghcOptCppOptions opts] - , concat [ [ "-optP-include", "-optP" ++ inc] - | inc <- flags ghcOptCppIncludes ] - , [ "-optc" ++ opt | opt <- ghcOptCcOptions opts] - , -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc - 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 ] - - ----------------- - -- Linker stuff - - , [ "-optl" ++ opt | opt <- ghcOptLinkOptions opts] - , ["-l" ++ lib | lib <- ghcOptLinkLibs opts] - , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath ] - , if isOSX - then concat [ ["-framework", fmwk] - | fmwk <- flags ghcOptLinkFrameworks ] - else [] - , if isOSX - then concat [ ["-framework-path", path] - | path <- flags ghcOptLinkFrameworkDirs ] - else [] - , [ "-no-hs-main" | flagBool ghcOptLinkNoHsMain ] - , [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ] - , concat [ [ "-optl-Wl,-rpath," ++ dir] - | dir <- flags ghcOptRPaths ] - , [ modDefFile | modDefFile <- flags ghcOptLinkModDefFiles ] - - ------------- - -- Packages - - , concat [ [ case () of - _ | unitIdSupported comp -> "-this-unit-id" - | packageKeySupported comp -> "-this-package-key" - | otherwise -> "-package-name" - , this_arg ] - | this_arg <- flag ghcOptThisUnitId ] - - , concat [ ["-this-component-id", prettyShow this_cid ] - | this_cid <- flag ghcOptThisComponentId ] - - , if null (ghcOptInstantiatedWith opts) - then [] - else "-instantiated-with" - : intercalate "," (map (\(n,m) -> prettyShow n ++ "=" - ++ prettyShow m) - (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 (ghcOptPackageDBs opts) - - , concat $ let space "" = "" - space xs = ' ' : xs - in [ ["-package-id", prettyShow ipkgid ++ space (prettyShow rns)] - | (ipkgid,rns) <- flags ghcOptPackages ] - - ---------------------------- - -- Language and extensions - - , if supportsHaskell2010 implInfo - then [ "-X" ++ prettyShow lang | lang <- flag ghcOptLanguage ] - else [] - - , [ ext' - | ext <- flags ghcOptExtensions - , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of - Just (Just arg) -> [arg] - Just Nothing -> [] - Nothing -> - error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " - ++ prettyShow ext ++ " not present in ghcOptExtensionMap." - ] - - ---------------- - -- GHCi - - , concat [ [ "-ghci-script", script ] | script <- ghcOptGHCiScripts opts - , flagGhciScript implInfo ] - - --------------- - -- Inputs - - -- Specify the input file(s) first, so that in ghci the `main-is` module is - -- in scope instead of the first module defined in `other-modules`. - , flags ghcOptInputFiles - , concat [ [ "-x", "hs", script] | script <- flags ghcOptInputScripts ] - , [ prettyShow modu | modu <- flags ghcOptInputModules ] - - , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ] - , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ] - - --------------- - -- Extra - - , ghcOptExtra opts - - ] - - - where - implInfo = getImplInfo comp - isOSX = os == OSX - flag flg = flagToList (flg opts) - flags flg = fromNubListR . flg $ opts - flagBool flg = fromFlagOrDefault False (flg opts) - -verbosityOpts :: Verbosity -> [String] -verbosityOpts verbosity - | verbosity >= deafening = ["-v"] - | verbosity >= normal = [] - | otherwise = ["-w", "-v0"] - - --- | GHC <7.6 uses '-package-conf' instead of '-package-db'. -packageDbArgsConf :: PackageDBStack -> [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 :: PackageDBStack -> [String] --- special cases to make arguments prettier in common scenarios -packageDbArgsDb dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) - | all isSpecific dbs -> concatMap single dbs - (GlobalPackageDB:dbs) - | all isSpecific dbs -> "-no-user-package-db" - : concatMap single dbs - dbs -> "-clear-package-db" - : concatMap single dbs - where - single (SpecificPackageDB db) = [ "-package-db", db ] - single GlobalPackageDB = [ "-global-package-db" ] - single UserPackageDB = [ "-user-package-db" ] - isSpecific (SpecificPackageDB _) = True - isSpecific _ = False - -packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String] -packageDbArgs implInfo - | flagPackageConf implInfo = packageDbArgsConf - | otherwise = packageDbArgsDb +module Distribution.Simple.Program.GHC + ( GhcOptions (..) + , GhcMode (..) + , GhcOptimisation (..) + , GhcDynLinkMode (..) + , GhcProfAuto (..) + , ghcInvocation + , renderGhcOptions + , runGHC + , packageDbArgsDb + , normaliseGhcArgs + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Backpack +import Distribution.Compat.Semigroup (First' (..), Last' (..), Option' (..)) +import Distribution.ModuleName +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.GHC.ImplInfo +import Distribution.Simple.Program.Find (getExtraPathEnv) +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types +import Distribution.System +import Distribution.Types.ComponentId +import Distribution.Utils.NubList +import Distribution.Verbosity +import Distribution.Version +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 Distribution.Types.ParStrat + +normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String] +normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs + | ghcVersion `withinRange` supportedGHCVersions = + argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs + where + supportedGHCVersions :: VersionRange + supportedGHCVersions = orLaterVersion (mkVersion [8, 0]) + -- we (weakly) support unknown future GHC versions for the purpose + -- of filtering GHC arguments + + from :: Monoid m => [Int] -> m -> m + from version flags + | ghcVersion `withinRange` orLaterVersion (mkVersion version) = flags + | otherwise = mempty + + to :: Monoid m => [Int] -> m -> m + to version flags + | ghcVersion `withinRange` earlierVersion (mkVersion version) = flags + | otherwise = mempty + + checkGhcFlags :: forall m. Monoid m => ([String] -> m) -> m + checkGhcFlags fun = + mconcat + [ fun ghcArgs + , checkComponentFlags libBuildInfo pkgLibs + , checkComponentFlags buildInfo executables + , checkComponentFlags testBuildInfo testSuites + , checkComponentFlags benchmarkBuildInfo benchmarks + ] + where + pkgLibs = maybeToList library ++ subLibraries + + checkComponentFlags :: (a -> BuildInfo) -> [a] -> m + checkComponentFlags getInfo = foldMap (checkComponent . getInfo) + where + checkComponent :: BuildInfo -> m + checkComponent = foldMap fun . filterGhcOptions . allGhcOptions + + allGhcOptions :: BuildInfo -> [(CompilerFlavor, [String])] + allGhcOptions = + foldMap + (perCompilerFlavorToList .) + [options, profOptions, sharedOptions, staticOptions] + + filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]] + filterGhcOptions l = [opts | (GHC, opts) <- l] + + safeToFilterWarnings :: Bool + safeToFilterWarnings = getAll $ checkGhcFlags checkWarnings + where + checkWarnings :: [String] -> All + checkWarnings = All . Set.null . foldr alter Set.empty + + alter :: String -> Set String -> Set String + alter flag = + appEndo $ + mconcat + [ \s -> Endo $ if s == "-Werror" then Set.insert s else id + , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id + , \s -> + from [8, 6] . Endo $ + if s == "-Werror=compat" + then Set.union compatWarningSet + else id + , \s -> + from [8, 6] . Endo $ + if s == "-Wno-error=compat" + then (`Set.difference` compatWarningSet) + else id + , \s -> + from [8, 6] . Endo $ + if s == "-Wwarn=compat" + then (`Set.difference` compatWarningSet) + else id + , from [8, 4] $ markFlag "-Werror=" Set.insert + , from [8, 4] $ markFlag "-Wwarn=" Set.delete + , from [8, 4] $ markFlag "-Wno-error=" Set.delete + ] + flag + + markFlag + :: String + -> (String -> Set String -> Set String) + -> String + -> Endo (Set String) + markFlag name update flag = Endo $ case stripPrefix name flag of + Just rest | not (null rest) && rest /= "compat" -> update rest + _ -> id + + flagArgumentFilter :: [String] -> [String] -> [String] + flagArgumentFilter flags = go + where + makeFilter :: String -> String -> Option' (First' ([String] -> [String])) + makeFilter flag arg = Option' $ First' . filterRest <$> stripPrefix flag arg + where + filterRest leftOver = case dropEq leftOver of + [] -> drop 1 + _ -> id + + checkFilter :: String -> Maybe ([String] -> [String]) + checkFilter = fmap getFirst' . getOption' . foldMap makeFilter flags + + go :: [String] -> [String] + go [] = [] + go (arg : args) = case checkFilter arg of + Just f -> go (f args) + Nothing -> arg : go args + + argumentFilters :: [String] -> [String] + argumentFilters = + flagArgumentFilter + ["-ghci-script", "-H", "-interactive-print"] + + filterRtsOpts :: [String] -> [String] + filterRtsOpts = go False + where + go :: Bool -> [String] -> [String] + go _ [] = [] + go _ ("+RTS" : opts) = go True opts + go _ ("-RTS" : opts) = go False opts + go isRTSopts (opt : opts) = addOpt $ go isRTSopts opts + where + addOpt + | isRTSopts = id + | otherwise = (opt :) + + simpleFilters :: String -> Bool + simpleFilters = + not + . getAny + . mconcat + [ flagIn simpleFlags + , Any . isPrefixOf "-ddump-" + , Any . isPrefixOf "-dsuppress-" + , Any . isPrefixOf "-dno-suppress-" + , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"] + , flagIn . invertibleFlagSet "-f" . mconcat $ + [ + [ "reverse-errors" + , "warn-unused-binds" + , "break-on-error" + , "break-on-exception" + , "print-bind-result" + , "print-bind-contents" + , "print-evld-with-show" + , "implicit-import-qualified" + , "error-spans" + ] + , from + [7, 8] + [ "print-explicit-foralls" -- maybe also earlier, but GHC-7.6 doesn't have --show-options + , "print-explicit-kinds" + ] + , from + [8, 0] + [ "print-explicit-coercions" + , "print-explicit-runtime-reps" + , "print-equality-relations" + , "print-unicode-syntax" + , "print-expanded-synonyms" + , "print-potential-instances" + , "print-typechecker-elaboration" + ] + , from + [8, 2] + [ "diagnostics-show-caret" + , "local-ghci-history" + , "show-warning-groups" + , "hide-source-paths" + , "show-hole-constraints" + ] + , from [8, 4] ["show-loaded-modules"] + , from [8, 6] ["ghci-leak-check", "no-it"] + , from + [8, 10] + [ "defer-diagnostics" -- affects printing of diagnostics + , "keep-going" -- try harder, the build will still fail if it's erroneous + , "print-axiom-incomps" -- print more debug info for closed type families + ] + ] + , flagIn . invertibleFlagSet "-d" $ ["ppr-case-as-let", "ppr-ticks"] + , isOptIntFlag + , isIntFlag + , if safeToFilterWarnings + then isWarning <> (Any . ("-w" ==)) + else mempty + , from [8, 6] $ + if safeToFilterHoles + then isTypedHoleFlag + else mempty + ] + + flagIn :: Set String -> String -> Any + flagIn set flag = Any $ Set.member flag set + + isWarning :: String -> Any + isWarning = + mconcat $ + map + ((Any .) . isPrefixOf) + ["-fwarn-", "-fno-warn-", "-W", "-Wno-"] + + simpleFlags :: Set String + simpleFlags = + Set.fromList . mconcat $ + [ + [ "-n" + , "-#include" + , "-Rghc-timing" + , "-dstg-stats" + , "-dth-dec-file" + , "-dsource-stats" + , "-dverbose-core2core" + , "-dverbose-stg2stg" + , "-dcore-lint" + , "-dstg-lint" + , "-dcmm-lint" + , "-dasm-lint" + , "-dannot-lint" + , "-dshow-passes" + , "-dfaststring-stats" + , "-fno-max-relevant-binds" + , "-recomp" + , "-no-recomp" + , "-fforce-recomp" + , "-fno-force-recomp" + ] + , from + [8, 2] + [ "-fno-max-errors" + , "-fdiagnostics-color=auto" + , "-fdiagnostics-color=always" + , "-fdiagnostics-color=never" + , "-dppr-debug" + , "-dno-debug-output" + ] + , from [8, 4] ["-ddebug-output"] + , from [8, 4] $ to [8, 6] ["-fno-max-valid-substitutions"] + , from [8, 6] ["-dhex-word-literals"] + , from [8, 8] ["-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits"] + , from [9, 0] ["-dlinear-core-lint"] + ] + + isOptIntFlag :: String -> Any + isOptIntFlag = mconcat . map (dropIntFlag True) $ ["-v", "-j"] + + isIntFlag :: String -> Any + isIntFlag = + mconcat . map (dropIntFlag False) . mconcat $ + [ + [ "-fmax-relevant-binds" + , "-ddpr-user-length" + , "-ddpr-cols" + , "-dtrace-level" + , "-fghci-hist-size" + ] + , from [8, 2] ["-fmax-uncovered-patterns", "-fmax-errors"] + , from [8, 4] $ to [8, 6] ["-fmax-valid-substitutions"] + ] + + dropIntFlag :: Bool -> String -> String -> Any + dropIntFlag isOpt flag input = Any $ case stripPrefix flag input of + Nothing -> False + Just rest + | isOpt && null rest -> True + | otherwise -> case parseInt rest of + Just _ -> True + Nothing -> False + where + parseInt :: String -> Maybe Int + parseInt = readMaybe . dropEq + + dropEq :: String -> String + dropEq ('=' : s) = s + dropEq s = s + + invertibleFlagSet :: String -> [String] -> Set String + invertibleFlagSet prefix flagNames = + Set.fromList $ (++) <$> [prefix, prefix ++ "no-"] <*> flagNames + + compatWarningSet :: Set String + compatWarningSet = + Set.fromList $ + mconcat + [ from + [8, 6] + [ "missing-monadfail-instances" + , "semigroup" + , "noncanonical-monoid-instances" + , "implicit-kind-vars" + ] + ] + + safeToFilterHoles :: Bool + safeToFilterHoles = + getAll . checkGhcFlags $ + All . fromMaybe True . fmap getLast' . getOption' . 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 + + isTypedHoleFlag :: String -> Any + isTypedHoleFlag = + mconcat + [ flagIn . invertibleFlagSet "-f" $ + [ "show-hole-constraints" + , "show-valid-substitutions" + , "show-valid-hole-fits" + , "sort-valid-hole-fits" + , "sort-by-size-hole-fits" + , "sort-by-subsumption-hole-fits" + , "abstract-refinement-hole-fits" + , "show-provenance-of-hole-fits" + , "show-hole-matches-of-hole-fits" + , "show-type-of-hole-fits" + , "show-type-app-of-hole-fits" + , "show-type-app-vars-of-hole-fits" + , "unclutter-valid-hole-fits" + ] + , flagIn . Set.fromList $ + [ "-fno-max-valid-hole-fits" + , "-fno-max-refinement-hole-fits" + , "-fno-refinement-level-hole-fits" + ] + , mconcat . map (dropIntFlag False) $ + [ "-fmax-valid-hole-fits" + , "-fmax-refinement-hole-fits" + , "-frefinement-level-hole-fits" + ] + ] +normaliseGhcArgs _ _ args = args + +-- | A structured set of GHC options/flags +-- +-- Note that options containing lists fall into two categories: +-- +-- * options that can be safely deduplicated, e.g. input modules or +-- enabled extensions; +-- * options that cannot be deduplicated in general without changing +-- semantics, e.g. extra ghc options or linking options. +data GhcOptions = GhcOptions + { ghcOptMode :: Flag GhcMode + -- ^ The major mode for the ghc invocation. + , ghcOptExtra :: [String] + -- ^ Any extra options to pass directly to ghc. These go at the end and hence + -- override other stuff. + , ghcOptExtraDefault :: [String] + -- ^ Extra default flags to pass directly to ghc. These go at the beginning + -- and so can be overridden by other stuff. + , ----------------------- + -- Inputs and outputs + + ghcOptInputFiles :: NubListR FilePath + -- ^ The main input files; could be .hs, .hi, .c, .o, depending on mode. + , ghcOptInputScripts :: NubListR FilePath + -- ^ Script files with irregular extensions that need -x hs. + , ghcOptInputModules :: NubListR ModuleName + -- ^ The names of input Haskell modules, mainly for @--make@ mode. + , ghcOptOutputFile :: Flag FilePath + -- ^ Location for output file; the @ghc -o@ flag. + , ghcOptOutputDynFile :: Flag FilePath + -- ^ Location for dynamic output file in 'GhcStaticAndDynamic' mode; + -- the @ghc -dyno@ flag. + , ghcOptSourcePathClear :: Flag Bool + -- ^ Start with an empty search path for Haskell source files; + -- the @ghc -i@ flag (@-i@ on its own with no path argument). + , ghcOptSourcePath :: NubListR FilePath + -- ^ Search path for Haskell source files; the @ghc -i@ flag. + , ------------- + -- Packages + + ghcOptThisUnitId :: Flag String + -- ^ The unit ID the modules will belong to; the @ghc -this-unit-id@ + -- flag (or @-this-package-key@ or @-package-name@ on older + -- versions of GHC). This is a 'String' because we assume you've + -- already figured out what the correct format for this string is + -- (we need to handle backwards compatibility.) + , ghcOptThisComponentId :: Flag ComponentId + -- ^ GHC doesn't make any assumptions about the format of + -- definite unit ids, so when we are instantiating a package it + -- needs to be told explicitly what the component being instantiated + -- is. This only gets set when 'ghcOptInstantiatedWith' is non-empty + , ghcOptInstantiatedWith :: [(ModuleName, OpenModule)] + -- ^ How the requirements of the package being compiled are to + -- be filled. When typechecking an indefinite package, the 'OpenModule' + -- is always a 'OpenModuleVar'; otherwise, it specifies the installed module + -- that instantiates a package. + , ghcOptNoCode :: Flag Bool + -- ^ No code? (But we turn on interface writing + , ghcOptPackageDBs :: PackageDBStack + -- ^ GHC package databases to use, the @ghc -package-conf@ flag. + , ghcOptPackages + :: NubListR (OpenUnitId, ModuleRenaming) + -- ^ The GHC packages to bring into scope when compiling, + -- the @ghc -package-id@ flags. + , ghcOptHideAllPackages :: Flag Bool + -- ^ Start with a clean package set; the @ghc -hide-all-packages@ flag + , ghcOptWarnMissingHomeModules :: Flag Bool + -- ^ Warn about modules, not listed in command line + , ghcOptNoAutoLinkPackages :: Flag Bool + -- ^ Don't automatically link in Haskell98 etc; the @ghc + -- -no-auto-link-packages@ flag. + , ----------------- + -- Linker stuff + + ghcOptLinkLibs :: [FilePath] + -- ^ Names of libraries to link in; the @ghc -l@ flag. + , ghcOptLinkLibPath :: NubListR FilePath + -- ^ Search path for libraries to link in; the @ghc -L@ flag. + , ghcOptLinkOptions :: [String] + -- ^ Options to pass through to the linker; the @ghc -optl@ flag. + , ghcOptLinkFrameworks :: NubListR String + -- ^ OSX only: frameworks to link in; the @ghc -framework@ flag. + , ghcOptLinkFrameworkDirs :: NubListR String + -- ^ OSX only: Search path for frameworks to link in; the + -- @ghc -framework-path@ flag. + , ghcOptLinkRts :: Flag Bool + -- ^ Instruct GHC to link against @libHSrts@ when producing a shared library. + , ghcOptNoLink :: Flag Bool + -- ^ Don't do the link step, useful in make mode; the @ghc -no-link@ flag. + , ghcOptLinkNoHsMain :: Flag Bool + -- ^ Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ + -- flag. + , ghcOptLinkModDefFiles :: NubListR FilePath + -- ^ Module definition files (Windows specific) + , -------------------- + -- C and CPP stuff + + ghcOptCcOptions :: [String] + -- ^ Options to pass through to the C compiler; the @ghc -optc@ flag. + , ghcOptCxxOptions :: [String] + -- ^ Options to pass through to the C++ compiler. + , ghcOptAsmOptions :: [String] + -- ^ Options to pass through to the Assembler. + , ghcOptCppOptions :: [String] + -- ^ Options to pass through to CPP; the @ghc -optP@ flag. + , ghcOptCppIncludePath :: NubListR FilePath + -- ^ Search path for CPP includes like header files; the @ghc -I@ flag. + , ghcOptCppIncludes :: NubListR FilePath + -- ^ Extra header files to include at CPP stage; the @ghc -optP-include@ flag. + , 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. + , ---------------------------- + -- Language and extensions + + ghcOptLanguage :: Flag Language + -- ^ The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag. + , ghcOptExtensions :: NubListR Extension + -- ^ The language extensions; the @ghc -X@ flag. + , ghcOptExtensionMap :: Map Extension (Maybe CompilerFlag) + -- ^ A GHC version-dependent mapping of extensions to flags. This must be + -- set to be able to make use of the 'ghcOptExtensions'. + , ---------------- + -- Compilation + + ghcOptOptimisation :: Flag GhcOptimisation + -- ^ What optimisation level to use; the @ghc -O@ flag. + , ghcOptDebugInfo :: Flag DebugInfoLevel + -- ^ Emit debug info; the @ghc -g@ flag. + , ghcOptProfilingMode :: Flag Bool + -- ^ Compile in profiling mode; the @ghc -prof@ flag. + , ghcOptProfilingAuto :: Flag GhcProfAuto + -- ^ Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags. + , ghcOptSplitSections :: Flag Bool + -- ^ Use the \"split sections\" feature; the @ghc -split-sections@ flag. + , ghcOptSplitObjs :: Flag Bool + -- ^ Use the \"split object files\" feature; the @ghc -split-objs@ flag. + , ghcOptNumJobs :: Flag ParStrat + -- ^ Run N jobs simultaneously (if possible). + , ghcOptHPCDir :: Flag FilePath + -- ^ Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags. + , ---------------- + -- GHCi + + ghcOptGHCiScripts :: [FilePath] + -- ^ Extra GHCi startup scripts; the @-ghci-script@ flag + , ------------------------ + -- Redirecting outputs + + ghcOptHiSuffix :: Flag String + , ghcOptObjSuffix :: Flag String + , ghcOptDynHiSuffix :: Flag String + -- ^ only in 'GhcStaticAndDynamic' mode + , ghcOptDynObjSuffix :: Flag String + -- ^ only in 'GhcStaticAndDynamic' mode + , ghcOptHiDir :: Flag FilePath + , ghcOptHieDir :: Flag FilePath + , ghcOptObjDir :: Flag FilePath + , ghcOptOutputDir :: Flag FilePath + , ghcOptStubDir :: Flag FilePath + , -------------------- + -- Creating libraries + + ghcOptDynLinkMode :: Flag GhcDynLinkMode + , ghcOptStaticLib :: Flag Bool + , ghcOptShared :: Flag Bool + , ghcOptFPic :: Flag Bool + , ghcOptDylibName :: Flag String + , ghcOptRPaths :: NubListR FilePath + , --------------- + -- Misc flags + + ghcOptVerbosity :: Flag Verbosity + -- ^ Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. + , ghcOptExtraPath :: NubListR FilePath + -- ^ Put the extra folders in the PATH environment variable we invoke + -- GHC with + , ghcOptCabal :: Flag Bool + -- ^ Let GHC know that it is Cabal that's calling it. + -- Modifies some of the GHC error messages. + } + deriving (Show, Generic) + +data GhcMode + = -- | @ghc -c@ + GhcModeCompile + | -- | @ghc@ + GhcModeLink + | -- | @ghc --make@ + GhcModeMake + | -- | @ghci@ \/ @ghc --interactive@ + GhcModeInteractive + | -- | @ghc --abi-hash@ + -- | GhcModeDepAnalysis -- ^ @ghc -M@ + -- | GhcModeEvaluate -- ^ @ghc -e@ + GhcModeAbiHash + deriving (Show, Eq) + +data GhcOptimisation + = -- | @-O0@ + GhcNoOptimisation + | -- | @-O@ + GhcNormalOptimisation + | -- | @-O2@ + GhcMaximumOptimisation + | -- | e.g. @-Odph@ + GhcSpecialOptimisation String + deriving (Show, Eq) + +data GhcDynLinkMode + = -- | @-static@ + GhcStaticOnly + | -- | @-dynamic@ + GhcDynamicOnly + | -- | @-static -dynamic-too@ + GhcStaticAndDynamic + deriving (Show, Eq) + +data GhcProfAuto + = -- | @-fprof-auto@ + GhcProfAutoAll + | -- | @-fprof-auto-top@ + GhcProfAutoToplevel + | -- | @-fprof-auto-exported@ + GhcProfAutoExported + | -- | @-fprof-late + GhcProfLate + deriving (Show, Eq) + +runGHC + :: Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> GhcOptions + -> IO () +runGHC verbosity ghcProg comp platform opts = do + runProgramInvocation verbosity =<< ghcInvocation verbosity ghcProg comp platform opts + +ghcInvocation + :: Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> GhcOptions + -> IO ProgramInvocation +ghcInvocation verbosity ghcProg comp platform opts = do + -- NOTE: GHC is the only program whose path we modify with more values than + -- the standard @extra-prog-path@, namely the folders of the executables in + -- the components, see @componentGhcOptions@. + let envOverrides = programOverrideEnv ghcProg + extraPath <- getExtraPathEnv verbosity envOverrides (fromNubListR (ghcOptExtraPath opts)) + let ghcProg' = ghcProg{programOverrideEnv = envOverrides ++ extraPath} + + pure $ programInvocation ghcProg' (renderGhcOptions comp platform opts) + +renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] +renderGhcOptions comp _platform@(Platform _arch os) opts + | compilerFlavor comp `notElem` [GHC, GHCJS] = + error $ + "Distribution.Simple.Program.GHC.renderGhcOptions: " + ++ "compiler flavor must be 'GHC' or 'GHCJS'!" + | otherwise = + concat + [ case flagToMaybe (ghcOptMode opts) of + Nothing -> [] + Just GhcModeCompile -> ["-c"] + Just GhcModeLink -> [] + Just GhcModeMake -> ["--make"] + Just GhcModeInteractive -> ["--interactive"] + Just GhcModeAbiHash -> ["--abi-hash"] + , -- Just GhcModeDepAnalysis -> ["-M"] + -- Just GhcModeEvaluate -> ["-e", expr] + + ghcOptExtraDefault opts + , ["-no-link" | flagBool ghcOptNoLink] + , ["-flink-rts" | flagBool ghcOptLinkRts] + , --------------- + -- Misc flags + + maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) + , ["-fbuilding-cabal-package" | flagBool ghcOptCabal] + , ---------------- + -- Compilation + + case flagToMaybe (ghcOptOptimisation opts) of + Nothing -> [] + Just GhcNoOptimisation -> ["-O0"] + Just GhcNormalOptimisation -> ["-O"] + Just GhcMaximumOptimisation -> ["-O2"] + Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph + , case flagToMaybe (ghcOptDebugInfo opts) of + Nothing -> [] + Just NoDebugInfo -> [] + Just MinimalDebugInfo -> ["-g1"] + Just NormalDebugInfo -> ["-g2"] + Just MaximalDebugInfo -> ["-g3"] + , ["-prof" | flagBool ghcOptProfilingMode] + , case flagToMaybe (ghcOptProfilingAuto opts) of + _ + | not (flagBool ghcOptProfilingMode) -> + [] + Nothing -> [] + Just GhcProfAutoAll + | flagProfAuto implInfo -> ["-fprof-auto"] + | otherwise -> ["-auto-all"] -- not the same, but close + 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"] + , ["-split-sections" | flagBool ghcOptSplitSections] + , ["-split-objs" | flagBool ghcOptSplitObjs] + , case flagToMaybe (ghcOptHPCDir opts) of + Nothing -> [] + Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir] + , if parmakeSupported comp + then case ghcOptNumJobs opts of + NoFlag -> [] + Flag Serial -> [] + Flag (UseSem name) -> + if jsemSupported comp + then ["-jsem " ++ name] + else [] + Flag (NumJobs n) -> ["-j" ++ maybe "" show n] + else [] + , -------------------- + -- Creating libraries + + ["-staticlib" | flagBool ghcOptStaticLib] + , ["-shared" | flagBool ghcOptShared] + , case flagToMaybe (ghcOptDynLinkMode opts) of + Nothing -> [] + Just GhcStaticOnly -> ["-static"] + Just GhcDynamicOnly -> ["-dynamic"] + Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"] + , ["-fPIC" | flagBool ghcOptFPic] + , concat [["-dylib-install-name", libname] | libname <- flag ghcOptDylibName] + , ------------------------ + -- Redirecting outputs + + concat [["-osuf", suf] | suf <- flag ghcOptObjSuffix] + , concat [["-hisuf", suf] | suf <- flag ghcOptHiSuffix] + , concat [["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix] + , concat [["-dynhisuf", suf] | suf <- flag ghcOptDynHiSuffix] + , concat [["-outputdir", dir] | dir <- flag ghcOptOutputDir] + , concat [["-odir", dir] | dir <- flag ghcOptObjDir] + , concat [["-hidir", dir] | dir <- flag ghcOptHiDir] + , concat [["-hiedir", dir] | dir <- flag ghcOptHieDir] + , concat [["-stubdir", dir] | dir <- flag ghcOptStubDir] + , ----------------------- + -- Source search path + + ["-i" | flagBool ghcOptSourcePathClear] + , ["-i" ++ dir | dir <- flags ghcOptSourcePath] + , -------------------- + + -------------------- + -- CPP, C, and C++ stuff + + ["-I" ++ dir | dir <- flags ghcOptCppIncludePath] + , ["-optP" ++ opt | opt <- ghcOptCppOptions opts] + , concat + [ ["-optP-include", "-optP" ++ inc] + | inc <- flags ghcOptCppIncludes + ] + , ["-optc" ++ opt | opt <- ghcOptCcOptions opts] + , -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc + 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] + , ----------------- + -- Linker stuff + + ["-optl" ++ opt | opt <- ghcOptLinkOptions opts] + , ["-l" ++ lib | lib <- ghcOptLinkLibs opts] + , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath] + , if isOSX + then + concat + [ ["-framework", fmwk] + | fmwk <- flags ghcOptLinkFrameworks + ] + else [] + , if isOSX + then + concat + [ ["-framework-path", path] + | path <- flags ghcOptLinkFrameworkDirs + ] + else [] + , ["-no-hs-main" | flagBool ghcOptLinkNoHsMain] + , ["-dynload deploy" | not (null (flags ghcOptRPaths))] + , ["-optl-Wl,-rpath," ++ dir | dir <- flags ghcOptRPaths] + , flags ghcOptLinkModDefFiles + , ------------- + -- Packages + + concat + [ [ case () of + _ + | unitIdSupported comp -> "-this-unit-id" + | packageKeySupported comp -> "-this-package-key" + | otherwise -> "-package-name" + , this_arg + ] + | this_arg <- flag ghcOptThisUnitId + ] + , concat + [ ["-this-component-id", prettyShow this_cid] + | this_cid <- flag ghcOptThisComponentId + ] + , if null (ghcOptInstantiatedWith opts) + then [] + else + "-instantiated-with" + : intercalate + "," + ( map + ( \(n, m) -> + prettyShow n + ++ "=" + ++ prettyShow m + ) + (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 (ghcOptPackageDBs opts) + , concat $ + let space "" = "" + space xs = ' ' : xs + in [ ["-package-id", prettyShow ipkgid ++ space (prettyShow rns)] + | (ipkgid, rns) <- flags ghcOptPackages + ] + , ---------------------------- + -- Language and extensions + + if supportsHaskell2010 implInfo + then ["-X" ++ prettyShow lang | lang <- flag ghcOptLanguage] + else [] + , [ ext' + | ext <- flags ghcOptExtensions + , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of + Just (Just arg) -> [arg] + Just Nothing -> [] + Nothing -> + error $ + "Distribution.Simple.Program.GHC.renderGhcOptions: " + ++ prettyShow ext + ++ " not present in ghcOptExtensionMap." + ] + , ---------------- + -- GHCi + + concat + [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts, flagGhciScript implInfo + ] + , --------------- + -- Inputs + + -- Specify the input file(s) first, so that in ghci the `main-is` module is + -- in scope instead of the first module defined in `other-modules`. + flags ghcOptInputFiles + , concat [["-x", "hs", script] | script <- flags ghcOptInputScripts] + , [prettyShow modu | modu <- flags ghcOptInputModules] + , concat [["-o", out] | out <- flag ghcOptOutputFile] + , concat [["-dyno", out] | out <- flag ghcOptOutputDynFile] + , --------------- + -- Extra + + ghcOptExtra opts + ] + where + implInfo = getImplInfo comp + isOSX = os == OSX + flag flg = flagToList (flg opts) + flags flg = fromNubListR . flg $ opts + flagBool flg = fromFlagOrDefault False (flg opts) + +verbosityOpts :: Verbosity -> [String] +verbosityOpts verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] + +-- | GHC <7.6 uses '-package-conf' instead of '-package-db'. +packageDbArgsConf :: PackageDBStack -> [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 :: PackageDBStack -> [String] +-- special cases to make arguments prettier in common scenarios +packageDbArgsDb dbstack = case dbstack of + (GlobalPackageDB : UserPackageDB : dbs) + | all isSpecific dbs -> concatMap single dbs + (GlobalPackageDB : dbs) + | all isSpecific dbs -> + "-no-user-package-db" + : concatMap single dbs + dbs -> + "-clear-package-db" + : concatMap single dbs + where + single (SpecificPackageDB db) = ["-package-db", db] + single GlobalPackageDB = ["-global-package-db"] + single UserPackageDB = ["-user-package-db"] + isSpecific (SpecificPackageDB _) = True + isSpecific _ = False + +packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String] +packageDbArgs implInfo + | flagPackageConf implInfo = packageDbArgsConf + | otherwise = packageDbArgsDb -- ----------------------------------------------------------------------------- -- 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,9 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.HcPkg -- Copyright : Duncan Coutts 2009, 2013 @@ -13,35 +14,34 @@ -- -- This module provides an library interface to the @hc-pkg@ program. -- Currently only GHC and GHCJS have hc-pkg programs. - -module Distribution.Simple.Program.HcPkg ( - -- * Types - HcPkgInfo(..), - RegisterOptions(..), - defaultRegisterOptions, +module Distribution.Simple.Program.HcPkg + ( -- * Types + HcPkgInfo (..) + , RegisterOptions (..) + , defaultRegisterOptions -- * Actions - init, - invoke, - register, - unregister, - recache, - expose, - hide, - dump, - describe, - list, + , init + , invoke + , register + , unregister + , recache + , expose + , hide + , dump + , describe + , list -- * Program invocations - initInvocation, - registerInvocation, - unregisterInvocation, - recacheInvocation, - exposeInvocation, - hideInvocation, - dumpInvocation, - describeInvocation, - listInvocation, + , initInvocation + , registerInvocation + , unregisterInvocation + , recacheInvocation + , exposeInvocation + , hideInvocation + , dumpInvocation + , describeInvocation + , listInvocation ) where import Distribution.Compat.Prelude hiding (init) @@ -51,6 +51,7 @@ import Distribution.Parsec import Distribution.Pretty import Distribution.Simple.Compiler +import Distribution.Simple.Errors import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types import Distribution.Simple.Utils @@ -59,42 +60,46 @@ import Distribution.Types.UnitId import Distribution.Verbosity -import Data.List (stripPrefix) +import Data.List (stripPrefix) import System.FilePath as FilePath (isPathSeparator, joinPath, splitDirectories, splitPath, (<.>), ()) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.List.NonEmpty as NE +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +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 + { 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) + | not (supportsDirDbs hpi) + || (not (requiresDirDbs hpi) && preferCompat) = + writeFile path "[]" + | otherwise = + runProgramInvocation verbosity (initInvocation hpi verbosity path) -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. @@ -102,194 +107,185 @@ invoke hpi verbosity dbStack extraArgs = runProgramInvocation verbosity invocation where - args = packageDbStackOpts hpi dbStack ++ extraArgs + args = packageDbStackOpts hpi dbStack ++ extraArgs invocation = programInvocation (hcPkgProgram hpi) args -- | Additional variations in the behaviour for 'register'. -data RegisterOptions = RegisterOptions { - -- | Allows re-registering \/ overwriting an existing package - registerAllowOverwrite :: Bool, - - -- | Insist on the ability to register multiple instances of a - -- single version of a single package. This will fail if the @hc-pkg@ - -- does not support it, see 'nativeMultiInstance' and - -- 'recacheMultiInstance'. - registerMultiInstance :: Bool, - - -- | Require that no checks are performed on the existence of package - -- files mentioned in the registration info. This must be used if - -- registering prior to putting the files in their final place. This will - -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'. - registerSuppressFilesCheck :: Bool - } +data RegisterOptions = RegisterOptions + { registerAllowOverwrite :: Bool + -- ^ 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'. + , registerSuppressFilesCheck :: Bool + -- ^ Require that no checks are performed on the existence of package + -- files mentioned in the registration info. This must be used if + -- registering prior to putting the files in their final place. This will + -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'. + } -- | Defaults are @True@, @False@ and @False@ defaultRegisterOptions :: RegisterOptions -defaultRegisterOptions = RegisterOptions { - registerAllowOverwrite = True, - registerMultiInstance = False, - registerSuppressFilesCheck = False - } +defaultRegisterOptions = + RegisterOptions + { registerAllowOverwrite = True + , registerMultiInstance = False + , registerSuppressFilesCheck = False + } -- | Call @hc-pkg@ to register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-db] --- -register :: HcPkgInfo -> Verbosity -> PackageDBStack - -> InstalledPackageInfo - -> RegisterOptions - -> IO () +register + :: HcPkgInfo + -> Verbosity + -> PackageDBStack + -> InstalledPackageInfo + -> RegisterOptions + -> IO () register hpi verbosity packagedbs pkgInfo registerOptions | registerMultiInstance registerOptions - , not (nativeMultiInstance hpi || recacheMultiInstance hpi) - = die' verbosity $ "HcPkg.register: the compiler does not support " - ++ "registering multiple instances of packages." - + , not (nativeMultiInstance hpi || recacheMultiInstance hpi) = + dieWithException verbosity RegMultipleInstancePkg | registerSuppressFilesCheck registerOptions - , not (suppressFilesCheck hpi) - = die' verbosity $ "HcPkg.register: the compiler does not support " - ++ "suppressing checks on files." - - -- This is a trick. Older versions of GHC do not support the - -- --enable-multi-instance flag for ghc-pkg register but it turns out that - -- 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. - -- + , 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 - = do let pkgdb = registrationPackageDB packagedbs - writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo - recache hpi verbosity pkgdb - - | otherwise - = runProgramInvocation verbosity - (registerInvocation hpi verbosity packagedbs pkgInfo registerOptions) + , recacheMultiInstance hpi = + do + let pkgdb = registrationPackageDB packagedbs + writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo + recache hpi verbosity pkgdb + | otherwise = + runProgramInvocation + verbosity + (registerInvocation hpi verbosity packagedbs pkgInfo registerOptions) -writeRegistrationFileDirectly :: Verbosity - -> HcPkgInfo - -> PackageDB - -> InstalledPackageInfo - -> IO () +writeRegistrationFileDirectly + :: Verbosity + -> HcPkgInfo + -> PackageDB + -> InstalledPackageInfo + -> IO () writeRegistrationFileDirectly verbosity hpi (SpecificPackageDB dir) pkgInfo - | supportsDirDbs hpi - = do let pkgfile = dir prettyShow (installedUnitId pkgInfo) <.> "conf" - writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) - - | otherwise - = die' verbosity $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" - + | supportsDirDbs hpi = + do + let pkgfile = 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. - die' verbosity $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" - + -- 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 -> PackageDB -> PackageId -> IO () unregister hpi verbosity packagedb pkgid = - runProgramInvocation verbosity + runProgramInvocation + verbosity (unregisterInvocation hpi verbosity packagedb pkgid) - -- | Call @hc-pkg@ to recache the registered packages. -- -- > hc-pkg recache [--user | --global | --package-db] --- recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO () recache hpi verbosity packagedb = - runProgramInvocation verbosity + runProgramInvocation + verbosity (recacheInvocation hpi verbosity packagedb) - -- | Call @hc-pkg@ to expose a package. -- -- > hc-pkg expose [pkgid] [--user | --global | --package-db] --- expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () expose hpi verbosity packagedb pkgid = - runProgramInvocation verbosity + runProgramInvocation + verbosity (exposeInvocation hpi verbosity packagedb pkgid) -- | Call @hc-pkg@ to retrieve a specific package -- -- > hc-pkg describe [pkgid] [--user | --global | --package-db] --- describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo] describe hpi verbosity packagedb pid = do - - output <- getProgramInvocationLBS verbosity - (describeInvocation hpi verbosity packagedb pid) - `catchIO` \_ -> return mempty + output <- + getProgramInvocationLBS + verbosity + (describeInvocation hpi verbosity packagedb pid) + `catchIO` \_ -> return mempty case parsePackages output of Left ok -> return ok - _ -> die' verbosity $ "failed to parse output of '" - ++ programId (hcPkgProgram hpi) ++ " describe " ++ prettyShow pid ++ "'" + _ -> dieWithException verbosity $ FailedToParseOutputDescribe (programId (hcPkgProgram hpi)) pid -- | Call @hc-pkg@ to hide a package. -- -- > hc-pkg hide [pkgid] [--user | --global | --package-db] --- hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () hide hpi verbosity packagedb pkgid = - runProgramInvocation verbosity + runProgramInvocation + verbosity (hideInvocation hpi verbosity packagedb pkgid) - -- | Call @hc-pkg@ to get all the details of all the packages in the given -- package database. --- dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo] dump hpi verbosity packagedb = do - - output <- getProgramInvocationLBS verbosity - (dumpInvocation hpi verbosity packagedb) - `catchIO` \e -> die' verbosity $ programId (hcPkgProgram hpi) ++ " dump failed: " - ++ displayException e + output <- + getProgramInvocationLBS + verbosity + (dumpInvocation hpi verbosity packagedb) + `catchIO` \e -> + dieWithException verbosity $ DumpFailed (programId (hcPkgProgram hpi)) (displayException e) case parsePackages output of Left ok -> return ok - _ -> die' verbosity $ "failed to parse output of '" - ++ programId (hcPkgProgram hpi) ++ " dump'" - + _ -> dieWithException verbosity $ FailedToParseOutputDump (programId (hcPkgProgram hpi)) parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String] parsePackages lbs0 = - case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of - Right ok -> Left [ setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok ] - Left msgs -> Right (NE.toList msgs) + case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of + Right ok -> Left [setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok] + Left msgs -> Right (NE.toList msgs) where splitPkgs :: LBS.ByteString -> [BS.ByteString] splitPkgs = checkEmpty . doSplit where -- Handle the case of there being no packages at all. checkEmpty [s] | BS.all isSpace8 s = [] - checkEmpty ss = ss + checkEmpty ss = ss isSpace8 :: Word8 -> Bool - isSpace8 9 = True -- '\t' + isSpace8 9 = True -- '\t' isSpace8 10 = True -- '\n' isSpace8 13 = True -- '\r' isSpace8 32 = True -- ' ' - isSpace8 _ = False + isSpace8 _ = False doSplit :: LBS.ByteString -> [BS.ByteString] doSplit lbs = go (LBS.findIndices (\w -> w == 10 || w == 13) lbs) where go :: [Int64] -> [BS.ByteString] - go [] = [ LBS.toStrict lbs ] - go (idx:idxs) = - let (pfx, sfx) = LBS.splitAt idx lbs - in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of + go [] = [LBS.toStrict lbs] + go (idx : idxs) = + let (pfx, sfx) = LBS.splitAt idx lbs + in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of Just sfx' -> LBS.toStrict pfx : doSplit sfx' - Nothing -> go idxs + Nothing -> go idxs separators :: [LBS.ByteString] separators = ["\n---\n", "\r\n---\r\n", "\r---\r"] @@ -303,26 +299,25 @@ | 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) -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. -- The "pkgroot" is the directory containing the package database. mungePackagePaths pkgroot pkginfo = - pkginfo { - importDirs = mungePaths (importDirs pkginfo), - includeDirs = mungePaths (includeDirs pkginfo), - libraryDirs = mungePaths (libraryDirs pkginfo), - libraryDirsStatic = mungePaths (libraryDirsStatic pkginfo), - libraryDynDirs = mungePaths (libraryDynDirs pkginfo), - frameworkDirs = mungePaths (frameworkDirs pkginfo), - haddockInterfaces = mungePaths (haddockInterfaces pkginfo), - haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) + pkginfo + { importDirs = mungePaths (importDirs pkginfo) + , includeDirs = mungePaths (includeDirs pkginfo) + , libraryDirs = mungePaths (libraryDirs pkginfo) + , libraryDirsStatic = mungePaths (libraryDirsStatic pkginfo) + , libraryDynDirs = mungePaths (libraryDynDirs pkginfo) + , frameworkDirs = mungePaths (frameworkDirs pkginfo) + , haddockInterfaces = mungePaths (haddockInterfaces pkginfo) + , haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) } where mungePaths = map mungePath - mungeUrls = map mungeUrl + mungeUrls = map mungeUrl mungePath p = case stripVarPrefix "${pkgroot}" p of Just p' -> pkgroot p' @@ -332,53 +327,55 @@ Just p' -> toUrlPath pkgroot p' Nothing -> p - toUrlPath r p = "file:///" - -- URLs always use posix style '/' separators: - ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) + toUrlPath r p = + "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) stripVarPrefix var p = case splitPath p of - (root:path') -> case stripPrefix var root of + (root : path') -> case stripPrefix var root of Just [sep] | isPathSeparator sep -> Just (joinPath path') - _ -> Nothing - _ -> Nothing - + _ -> Nothing + _ -> Nothing -- Older installed package info files did not have the installedUnitId -- field, so if it is missing then we fill it as the source package ID. -- NB: Internal libraries not supported. setUnitId :: InstalledPackageInfo -> InstalledPackageInfo -setUnitId pkginfo@InstalledPackageInfo { - installedUnitId = uid, - sourcePackageId = pid - } | unUnitId uid == "" - = pkginfo { - installedUnitId = mkLegacyUnitId pid, - installedComponentId_ = mkComponentId (prettyShow pid) - } +setUnitId + pkginfo@InstalledPackageInfo + { installedUnitId = uid + , sourcePackageId = pid + } + | unUnitId uid == "" = + pkginfo + { installedUnitId = mkLegacyUnitId pid + , installedComponentId_ = mkComponentId (prettyShow pid) + } setUnitId pkginfo = pkginfo - -- | Call @hc-pkg@ to get the source package Id of all the packages in the -- given package database. -- -- This is much less information than with 'dump', but also rather quicker. -- 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 -> Verbosity -> PackageDB - -> IO [PackageId] +list + :: HcPkgInfo + -> Verbosity + -> PackageDB + -> IO [PackageId] list hpi verbosity packagedb = do - - output <- getProgramInvocationOutput verbosity - (listInvocation hpi verbosity packagedb) - `catchIO` \_ -> die' verbosity $ programId (hcPkgProgram hpi) ++ " list failed" + output <- + getProgramInvocationOutput + verbosity + (listInvocation hpi verbosity packagedb) + `catchIO` \_ -> dieWithException verbosity $ ListFailed (programId (hcPkgProgram hpi)) case parsePackageIds output of Just ok -> return ok - _ -> die' verbosity $ "failed to parse output of '" - ++ programId (hcPkgProgram hpi) ++ " list'" - + _ -> dieWithException verbosity $ FailedToParseOutputList (programId (hcPkgProgram hpi)) where parsePackageIds = traverse simpleParsec . words @@ -388,130 +385,157 @@ initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation initInvocation hpi verbosity path = - programInvocation (hcPkgProgram hpi) args + programInvocation (hcPkgProgram hpi) args where - args = ["init", path] + args = + ["init", path] ++ verbosityOpts hpi verbosity registerInvocation - :: HcPkgInfo -> Verbosity -> PackageDBStack + :: HcPkgInfo + -> Verbosity + -> PackageDBStack -> InstalledPackageInfo -> RegisterOptions -> ProgramInvocation registerInvocation hpi verbosity packagedbs pkgInfo registerOptions = - (programInvocation (hcPkgProgram hpi) (args "-")) { - progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo, - progInvokeInputEncoding = IOEncodingUTF8 + (programInvocation (hcPkgProgram hpi) (args "-")) + { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo + , progInvokeInputEncoding = IOEncodingUTF8 } where cmdname | registerAllowOverwrite registerOptions = "update" - | registerMultiInstance registerOptions = "update" - | otherwise = "register" + | registerMultiInstance registerOptions = "update" + | otherwise = "register" - args file = [cmdname, file] - ++ packageDbStackOpts hpi packagedbs - ++ [ "--enable-multi-instance" - | registerMultiInstance registerOptions ] - ++ [ "--force-files" - | registerSuppressFilesCheck registerOptions ] - ++ verbosityOpts hpi verbosity + args file = + [cmdname, file] + ++ packageDbStackOpts hpi packagedbs + ++ [ "--enable-multi-instance" + | registerMultiInstance registerOptions + ] + ++ [ "--force-files" + | registerSuppressFilesCheck registerOptions + ] + ++ verbosityOpts hpi verbosity -unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId - -> ProgramInvocation +unregisterInvocation + :: HcPkgInfo + -> Verbosity + -> PackageDB + -> PackageId + -> ProgramInvocation unregisterInvocation hpi verbosity packagedb pkgid = programInvocation (hcPkgProgram hpi) $ - ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity - + ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity -recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB - -> ProgramInvocation +recacheInvocation + :: HcPkgInfo + -> Verbosity + -> PackageDB + -> ProgramInvocation recacheInvocation hpi verbosity packagedb = programInvocation (hcPkgProgram hpi) $ - ["recache", packageDbOpts hpi packagedb] - ++ verbosityOpts hpi verbosity - + ["recache", packageDbOpts hpi packagedb] + ++ verbosityOpts hpi verbosity -exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId - -> ProgramInvocation +exposeInvocation + :: HcPkgInfo + -> Verbosity + -> PackageDB + -> PackageId + -> ProgramInvocation exposeInvocation hpi verbosity packagedb pkgid = programInvocation (hcPkgProgram hpi) $ - ["expose", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity + ["expose", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity -describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId - -> ProgramInvocation +describeInvocation + :: HcPkgInfo + -> Verbosity + -> PackageDBStack + -> PackageId + -> ProgramInvocation describeInvocation hpi verbosity packagedbs pkgid = programInvocation (hcPkgProgram hpi) $ - ["describe", prettyShow pkgid] - ++ packageDbStackOpts hpi packagedbs - ++ verbosityOpts hpi verbosity + ["describe", prettyShow pkgid] + ++ packageDbStackOpts hpi packagedbs + ++ verbosityOpts hpi verbosity -hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId - -> ProgramInvocation +hideInvocation + :: HcPkgInfo + -> Verbosity + -> PackageDB + -> PackageId + -> ProgramInvocation hideInvocation hpi verbosity packagedb pkgid = programInvocation (hcPkgProgram hpi) $ - ["hide", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity - + ["hide", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation dumpInvocation hpi _verbosity packagedb = - (programInvocation (hcPkgProgram hpi) args) { - progInvokeOutputEncoding = IOEncodingUTF8 + (programInvocation (hcPkgProgram hpi) args) + { progInvokeOutputEncoding = IOEncodingUTF8 } where - args = ["dump", packageDbOpts hpi packagedb] + args = + ["dump", packageDbOpts hpi packagedb] ++ verbosityOpts hpi silent - -- We use verbosity level 'silent' because it is important that we - -- do not contaminate the output with info/debug messages. +-- We use verbosity level 'silent' because it is important that we +-- do not contaminate the output with info/debug messages. + listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation listInvocation hpi _verbosity packagedb = - (programInvocation (hcPkgProgram hpi) args) { - progInvokeOutputEncoding = IOEncodingUTF8 + (programInvocation (hcPkgProgram hpi) args) + { progInvokeOutputEncoding = IOEncodingUTF8 } where - args = ["list", "--simple-output", packageDbOpts hpi packagedb] + args = + ["list", "--simple-output", packageDbOpts hpi packagedb] ++ verbosityOpts hpi silent - -- We use verbosity level 'silent' because it is important that we - -- do not contaminate the output with info/debug messages. +-- We use verbosity level 'silent' because it is important that we +-- do not contaminate the output with info/debug messages. packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [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 - where - specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db - specific _ = ierror - ierror :: a - ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + | otherwise = case dbstack of + (GlobalPackageDB : UserPackageDB : dbs) -> + "--global" + : "--user" + : map specific dbs + (GlobalPackageDB : dbs) -> + "--global" + : ("--no-user-" ++ packageDbFlag hpi) + : map specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db + specific _ = ierror + ierror :: a + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) packageDbFlag :: HcPkgInfo -> String packageDbFlag hpi - | flagPackageConf hpi - = "package-conf" - | otherwise - = "package-db" + | flagPackageConf hpi = + "package-conf" + | otherwise = + "package-db" packageDbOpts :: HcPkgInfo -> PackageDB -> String -packageDbOpts _ GlobalPackageDB = "--global" -packageDbOpts _ UserPackageDB = "--user" +packageDbOpts _ GlobalPackageDB = "--global" +packageDbOpts _ UserPackageDB = "--user" packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db verbosityOpts :: HcPkgInfo -> Verbosity -> [String] verbosityOpts hpi v - | noVerboseFlag hpi - = [] + | noVerboseFlag hpi = + [] | v >= deafening = ["-v2"] - | v == silent = ["-v0"] - | otherwise = [] + | v == silent = ["-v0"] + | otherwise = [] diff --git a/src/Distribution/Simple/Program/Hpc.hs b/src/Distribution/Simple/Program/Hpc.hs --- a/src/Distribution/Simple/Program/Hpc.hs +++ b/src/Distribution/Simple/Program/Hpc.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Hpc -- Copyright : Thomas Tuegel 2011 @@ -10,21 +11,20 @@ -- Portability : portable -- -- This module provides an library interface to the @hpc@ program. - module Distribution.Simple.Program.Hpc - ( markup - , union - ) where + ( markup + , union + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import System.Directory (makeRelativeToCurrentDirectory) import Distribution.ModuleName +import Distribution.Pretty import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types -import Distribution.Pretty import Distribution.Simple.Utils import Distribution.Verbosity import Distribution.Version @@ -36,74 +36,103 @@ -- first path in the list. This means that e.g. test suites that import their -- library as a dependency can still work, but those that include the library -- modules directly (in other-modules) don't. -markup :: ConfiguredProgram - -> Version - -> Verbosity - -> FilePath -- ^ Path to .tix file - -> [FilePath] -- ^ Paths to .mix file directories - -> FilePath -- ^ Path where html output should be located - -> [ModuleName] -- ^ List of modules to include in the report - -> IO () +markup + :: ConfiguredProgram + -> Version + -> Verbosity + -> FilePath + -- ^ Path to .tix file + -> [FilePath] + -- ^ Paths to .mix file directories + -> FilePath + -- ^ Path where html output should be located + -> [ModuleName] + -- ^ List of modules to include in the report + -> IO () markup hpc hpcVer verbosity tixFile hpcDirs destDir included = do - hpcDirs' <- if withinRange hpcVer (orLaterVersion version07) - then return hpcDirs - else do - warn verbosity $ "Your version of HPC (" ++ prettyShow hpcVer - ++ ") does not properly handle multiple search paths. " - ++ "Coverage report generation may fail unexpectedly. These " - ++ "issues are addressed in version 0.7 or later (GHC 7.8 or " - ++ "later)." - ++ if null droppedDirs - then "" - else " The following search paths have been abandoned: " - ++ show droppedDirs - return passedDirs + hpcDirs' <- + if withinRange hpcVer (orLaterVersion version07) + then return hpcDirs + else do + warn verbosity $ + "Your version of HPC (" + ++ prettyShow hpcVer + ++ ") does not properly handle multiple search paths. " + ++ "Coverage report generation may fail unexpectedly. These " + ++ "issues are addressed in version 0.7 or later (GHC 7.8 or " + ++ "later)." + ++ if null droppedDirs + then "" + else + " The following search paths have been abandoned: " + ++ show droppedDirs + return passedDirs - -- Prior to GHC 8.0, hpc assumes all .mix paths are relative. - hpcDirs'' <- traverse makeRelativeToCurrentDirectory hpcDirs' + -- Prior to GHC 8.0, hpc assumes all .mix paths are relative. + hpcDirs'' <- traverse makeRelativeToCurrentDirectory hpcDirs' - runProgramInvocation verbosity - (markupInvocation hpc tixFile hpcDirs'' destDir included) + runProgramInvocation + verbosity + (markupInvocation hpc tixFile hpcDirs'' destDir included) where version07 = mkVersion [0, 7] (passedDirs, droppedDirs) = splitAt 1 hpcDirs -markupInvocation :: ConfiguredProgram - -> FilePath -- ^ Path to .tix file - -> [FilePath] -- ^ Paths to .mix file directories - -> FilePath -- ^ Path where html output should be - -- located - -> [ModuleName] -- ^ List of modules to include - -> ProgramInvocation +markupInvocation + :: ConfiguredProgram + -> FilePath + -- ^ Path to .tix file + -> [FilePath] + -- ^ Paths to .mix file directories + -> FilePath + -- ^ Path where html output should be + -- located + -> [ModuleName] + -- ^ List of modules to include + -> ProgramInvocation markupInvocation hpc tixFile hpcDirs destDir included = - let args = [ "markup", tixFile - , "--destdir=" ++ destDir - ] - ++ map ("--hpcdir=" ++) hpcDirs - ++ ["--include=" ++ prettyShow moduleName - | moduleName <- included ] - in programInvocation hpc args + let args = + [ "markup" + , tixFile + , "--destdir=" ++ destDir + ] + ++ map ("--hpcdir=" ++) hpcDirs + ++ [ "--include=" ++ prettyShow moduleName + | moduleName <- included + ] + in programInvocation hpc args -union :: ConfiguredProgram - -> Verbosity - -> [FilePath] -- ^ Paths to .tix files - -> FilePath -- ^ Path to resultant .tix file - -> [ModuleName] -- ^ List of modules to exclude from union - -> IO () +union + :: ConfiguredProgram + -> Verbosity + -> [FilePath] + -- ^ Paths to .tix files + -> FilePath + -- ^ Path to resultant .tix file + -> [ModuleName] + -- ^ List of modules to exclude from union + -> IO () union hpc verbosity tixFiles outFile excluded = - runProgramInvocation verbosity - (unionInvocation hpc tixFiles outFile excluded) + runProgramInvocation + verbosity + (unionInvocation hpc tixFiles outFile excluded) -unionInvocation :: ConfiguredProgram - -> [FilePath] -- ^ Paths to .tix files - -> FilePath -- ^ Path to resultant .tix file - -> [ModuleName] -- ^ List of modules to exclude from union - -> ProgramInvocation +unionInvocation + :: ConfiguredProgram + -> [FilePath] + -- ^ Paths to .tix files + -> FilePath + -- ^ Path to resultant .tix file + -> [ModuleName] + -- ^ List of modules to exclude from union + -> ProgramInvocation unionInvocation hpc tixFiles outFile excluded = - programInvocation hpc $ concat - [ ["sum", "--union"] - , tixFiles - , ["--output=" ++ outFile] - , ["--exclude=" ++ prettyShow moduleName - | moduleName <- excluded ] + programInvocation hpc $ + concat + [ ["sum", "--union"] + , tixFiles + , ["--output=" ++ outFile] + , [ "--exclude=" ++ prettyShow moduleName + | moduleName <- excluded ] + ] 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 @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Internal -- @@ -6,14 +7,13 @@ -- Portability : portable -- -- Internal utilities used by Distribution.Simple.Program.*. - -module Distribution.Simple.Program.Internal ( - stripExtractVersion, +module Distribution.Simple.Program.Internal + ( stripExtractVersion ) where -import Prelude () import Distribution.Compat.Prelude -import Distribution.Utils.Generic(safeTail) +import Distribution.Utils.Generic (safeTail) +import Prelude () -- | Extract the version number from the output of 'strip --version'. -- @@ -23,25 +23,24 @@ -- 'strip' doesn't appear to have a version flag. stripExtractVersion :: String -> String stripExtractVersion str = - let numeric "" = False - numeric (x:_) = isDigit x + let numeric "" = False + numeric (x : _) = isDigit x -- 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 = filterPar' n xs - | otherwise = x:filterPar' n xs + 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 = filterPar' n xs + | otherwise = x : filterPar' n xs filterPar = filterPar' 0 - - in case dropWhile (not . numeric) (filterPar . words $ str) of - (ver:_) -> - -- take the first two version components - let isDot = (== '.') - (major, rest) = break isDot ver - minor = takeWhile isDigit (dropWhile isDot rest) - in major ++ "." ++ minor - _ -> "" + in case dropWhile (not . numeric) (filterPar . words $ str) of + (ver : _) -> + -- take the first two version components + let isDot = (== '.') + (major, rest) = break isDot ver + minor = takeWhile isDigit (dropWhile isDot rest) + in major ++ "." ++ minor + _ -> "" 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 @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Ld -- Copyright : Duncan Coutts 2009 @@ -10,58 +11,74 @@ -- Portability : portable -- -- This module provides an library interface to the @ld@ linker program. - -module Distribution.Simple.Program.Ld ( - combineObjectFiles, +module Distribution.Simple.Program.Ld + ( combineObjectFiles ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Compiler (arResponseFilesSupported) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Flag + ( fromFlagOrDefault + ) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..)) import Distribution.Simple.Program.ResponseFile - ( withResponseFile ) + ( withResponseFile + ) import Distribution.Simple.Program.Run - ( ProgramInvocation, programInvocation, multiStageProgramInvocation - , runProgramInvocation ) + ( ProgramInvocation + , multiStageProgramInvocation + , programInvocation + , runProgramInvocation + ) import Distribution.Simple.Program.Types - ( ConfiguredProgram(..) ) -import Distribution.Simple.Setup - ( fromFlagOrDefault, configUseResponseFiles ) + ( ConfiguredProgram (..) + ) +import Distribution.Simple.Setup.Config + ( configUseResponseFiles + ) import Distribution.Simple.Utils - ( defaultTempFileOptions ) + ( defaultTempFileOptions + ) import Distribution.Verbosity - ( Verbosity ) + ( Verbosity + ) import System.Directory - ( renameFile ) + ( renameFile + ) import System.FilePath - ( (<.>), takeDirectory ) + ( takeDirectory + , (<.>) + ) -- | Call @ld -r@ to link a bunch of object files together. --- -combineObjectFiles :: Verbosity -> LocalBuildInfo -> ConfiguredProgram - -> FilePath -> [FilePath] -> IO () +combineObjectFiles + :: Verbosity + -> LocalBuildInfo + -> ConfiguredProgram + -> FilePath + -> [FilePath] + -> IO () combineObjectFiles verbosity lbi ld target files = do - -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is, -- if we have more object files than fit on a single command line then we -- have a slight problem. What we have to do is link files in batches into -- a temp object file and then include that one in the next batch. - let simpleArgs = ["-r", "-o", target] + let simpleArgs = ["-r", "-o", target] initialArgs = ["-r", "-o", target] - middleArgs = ["-r", "-o", target, tmpfile] - finalArgs = middleArgs + middleArgs = ["-r", "-o", target, tmpfile] + finalArgs = middleArgs - simple = programInvocation ld simpleArgs - initial = programInvocation ld initialArgs - middle = programInvocation ld middleArgs - final = programInvocation ld finalArgs + simple = programInvocation ld simpleArgs + initial = programInvocation ld initialArgs + middle = programInvocation ld middleArgs + final = programInvocation ld finalArgs - targetDir = takeDirectory target + targetDir = takeDirectory target invokeWithResponesFile :: FilePath -> ProgramInvocation invokeWithResponesFile atFile = @@ -71,22 +88,19 @@ fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi -- Whether ghc's ar supports response files is a good proxy for -- whether ghc's ld supports them as well. - responseArgumentsNotSupported = + responseArgumentsNotSupported = not (arResponseFilesSupported (compiler lbi)) if oldVersionManualOverride || responseArgumentsNotSupported - then - run $ multiStageProgramInvocation simple (initial, middle, final) files - else - withResponseFile verbosity defaultTempFileOptions targetDir "ld.rsp" Nothing files $ - \path -> runProgramInvocation verbosity $ invokeWithResponesFile path - + then run $ multiStageProgramInvocation simple (initial, middle, final) files + else withResponseFile verbosity defaultTempFileOptions targetDir "ld.rsp" Nothing files $ + \path -> runProgramInvocation verbosity $ invokeWithResponesFile path where - tmpfile = target <.> "tmp" -- perhaps should use a proper temp file - + tmpfile = target <.> "tmp" -- perhaps should use a proper temp file run :: [ProgramInvocation] -> IO () - run [] = return () - run [inv] = runProgramInvocation verbosity inv - run (inv:invs) = do runProgramInvocation verbosity inv - renameFile target tmpfile - run invs + run [] = return () + run [inv] = runProgramInvocation verbosity inv + run (inv : invs) = do + runProgramInvocation verbosity inv + renameFile target tmpfile + run invs 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,6 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} + ---------------------------------------------------------------------------- + +---------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.ResponseFile -- Copyright : (c) Sergey Vinokurov 2017 @@ -8,24 +12,26 @@ -- -- Maintainer : cabal-devel@haskell.org -- Created : 23 July 2017 ----------------------------------------------------------------------------- - module Distribution.Simple.Program.ResponseFile (withResponseFile) where +import System.IO (TextEncoding, hClose, hPutStr, hSetEncoding) import Prelude () -import System.IO (TextEncoding, hSetEncoding, hPutStr, hClose) import Distribution.Compat.Prelude -import Distribution.Simple.Utils (TempFileOptions, withTempFileEx, debug) +import Distribution.Simple.Utils (TempFileOptions, debug, withTempFileEx) import Distribution.Verbosity withResponseFile :: Verbosity -> TempFileOptions - -> FilePath -- ^ Working directory to create response file in. - -> FilePath -- ^ Template for response file name. - -> Maybe TextEncoding -- ^ Encoding to use for response file contents. - -> [String] -- ^ Arguments to put into response file. + -> FilePath + -- ^ Working directory to create response file in. + -> FilePath + -- ^ Template for response file name. + -> Maybe TextEncoding + -- ^ Encoding to use for response file contents. + -> [String] + -- ^ Arguments to put into response file. -> (FilePath -> IO a) -> IO a withResponseFile verbosity tmpFileOpts workDir fileNameTemplate encoding arguments f = @@ -51,9 +57,9 @@ escape :: String -> Char -> String escape cs c = case c of - '\\' -> c:'\\':cs - '\'' -> c:'\\':cs - '"' -> c:'\\':cs - _ | isSpace c -> c:'\\':cs - | otherwise -> c:cs - + '\\' -> c : '\\' : cs + '\'' -> c : '\\' : cs + '"' -> c : '\\' : cs + _ + | isSpace c -> c : '\\' : cs + | otherwise -> c : cs 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 @@ -1,8 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Run -- Copyright : Duncan Coutts 2009 @@ -12,7 +13,6 @@ -- -- This module provides a data type for program invocations and functions to -- run them. - module Distribution.Simple.Program.Run ( ProgramInvocation (..) , IOEncoding (..) @@ -32,13 +32,14 @@ import Prelude () import Distribution.Compat.Environment +import Distribution.Simple.Errors import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.Utils.Generic import Distribution.Verbosity import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map +import qualified Data.Map as Map -- | Represents a specific invocation of a specific program. -- @@ -46,122 +47,140 @@ -- and actually doing it. This provides the opportunity to the caller to -- adjust how the program will be called. These invocations can either be run -- directly or turned into shell or batch scripts. --- -data ProgramInvocation = ProgramInvocation { - progInvokePath :: FilePath, - progInvokeArgs :: [String], - progInvokeEnv :: [(String, Maybe String)], - progInvokeCwd :: Maybe FilePath, - progInvokeInput :: Maybe IOData, - progInvokeInputEncoding :: IOEncoding, -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. - progInvokeOutputEncoding :: IOEncoding - } +data ProgramInvocation = ProgramInvocation + { progInvokePath :: FilePath + , progInvokeArgs :: [String] + , progInvokeEnv :: [(String, Maybe String)] + , progInvokeCwd :: Maybe FilePath + , progInvokeInput :: Maybe IOData + , progInvokeInputEncoding :: IOEncoding + -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. + , progInvokeOutputEncoding :: IOEncoding + } -data IOEncoding = IOEncodingText -- locale mode text - | IOEncodingUTF8 -- always utf8 +data IOEncoding + = IOEncodingText -- locale mode text + | IOEncodingUTF8 -- always utf8 encodeToIOData :: IOEncoding -> IOData -> IOData -encodeToIOData _ iod@(IODataBinary _) = iod -encodeToIOData IOEncodingText iod@(IODataText _) = iod -encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str) +encodeToIOData _ iod@(IODataBinary _) = iod +encodeToIOData IOEncodingText iod@(IODataText _) = iod +encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str) emptyProgramInvocation :: ProgramInvocation emptyProgramInvocation = - ProgramInvocation { - progInvokePath = "", - progInvokeArgs = [], - progInvokeEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Nothing, - progInvokeInputEncoding = IOEncodingText, - progInvokeOutputEncoding = IOEncodingText - } + ProgramInvocation + { progInvokePath = "" + , progInvokeArgs = [] + , progInvokeEnv = [] + , progInvokeCwd = Nothing + , progInvokeInput = Nothing + , progInvokeInputEncoding = IOEncodingText + , progInvokeOutputEncoding = IOEncodingText + } simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation simpleProgramInvocation path args = - emptyProgramInvocation { - progInvokePath = path, - progInvokeArgs = args - } + emptyProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + } programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation programInvocation prog args = - emptyProgramInvocation { - progInvokePath = programPath prog, - progInvokeArgs = programDefaultArgs prog - ++ args - ++ programOverrideArgs prog, - progInvokeEnv = programOverrideEnv prog - } - + emptyProgramInvocation + { progInvokePath = programPath prog + , progInvokeArgs = + programDefaultArgs prog + ++ args + ++ programOverrideArgs prog + , progInvokeEnv = programOverrideEnv prog + } runProgramInvocation :: Verbosity -> ProgramInvocation -> IO () -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Nothing - } = - rawSystemExit verbosity path args - -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envOverrides, - progInvokeCwd = mcwd, - progInvokeInput = Nothing - } = do +runProgramInvocation + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = [] + , progInvokeCwd = Nothing + , progInvokeInput = Nothing + } = + rawSystemExit verbosity path args +runProgramInvocation + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envOverrides + , progInvokeCwd = mcwd + , progInvokeInput = Nothing + } = do menv <- getEffectiveEnvironment envOverrides - maybeExit $ rawSystemIOWithEnv verbosity - path args - mcwd menv - Nothing Nothing Nothing - -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envOverrides, - progInvokeCwd = mcwd, - progInvokeInput = Just inputStr, - progInvokeInputEncoding = encoding - } = do + maybeExit $ + rawSystemIOWithEnv + verbosity + path + args + mcwd + menv + Nothing + Nothing + Nothing +runProgramInvocation + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envOverrides + , progInvokeCwd = mcwd + , progInvokeInput = Just inputStr + , progInvokeInputEncoding = encoding + } = do menv <- getEffectiveEnvironment envOverrides - (_, errors, exitCode) <- rawSystemStdInOut verbosity - path args - mcwd menv - (Just input) IODataModeBinary + (_, errors, exitCode) <- + rawSystemStdInOut + verbosity + path + args + mcwd + menv + (Just input) + IODataModeBinary when (exitCode /= ExitSuccess) $ - die' verbosity $ "'" ++ path ++ "' exited with an error:\n" ++ errors - where - input = encodeToIOData encoding inputStr + dieWithException verbosity $ + RunProgramInvocationException path errors + where + input = encodeToIOData encoding inputStr getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String getProgramInvocationOutput verbosity inv = do - (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv - when (exitCode /= ExitSuccess) $ - die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors - return output + (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv + when (exitCode /= ExitSuccess) $ + die' verbosity $ + "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors + return output getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO LBS.ByteString getProgramInvocationLBS verbosity inv = do - (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary - when (exitCode /= ExitSuccess) $ - die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors - return output + (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + when (exitCode /= ExitSuccess) $ + dieWithException verbosity $ + GetProgramInvocationLBSException (progInvokePath inv) errors + return output -getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation - -> IO (String, String, ExitCode) +getProgramInvocationOutputAndErrors + :: Verbosity + -> ProgramInvocation + -> IO (String, String, ExitCode) getProgramInvocationOutputAndErrors verbosity inv = case progInvokeOutputEncoding inv of - IOEncodingText -> do - (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText - return (output, errors, exitCode) - IOEncodingUTF8 -> do - (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary - return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode) + IOEncodingText -> do + (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText + return (output, errors, exitCode) + IOEncodingUTF8 -> do + (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode) getProgramInvocationLBSAndErrors :: Verbosity @@ -171,36 +190,39 @@ getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary getProgramInvocationIODataAndErrors - :: KnownIODataMode mode => Verbosity -> ProgramInvocation -> IODataMode mode - -> IO (mode, String, ExitCode) + :: KnownIODataMode mode + => Verbosity + -> ProgramInvocation + -> IODataMode mode + -> IO (mode, String, ExitCode) getProgramInvocationIODataAndErrors verbosity ProgramInvocation - { progInvokePath = path - , progInvokeArgs = args - , progInvokeEnv = envOverrides - , progInvokeCwd = mcwd - , progInvokeInput = minputStr + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envOverrides + , progInvokeCwd = mcwd + , progInvokeInput = minputStr , progInvokeInputEncoding = encoding } mode = do menv <- getEffectiveEnvironment envOverrides rawSystemStdInOut verbosity path args mcwd menv input mode - where - input = encodeToIOData encoding <$> minputStr + where + input = encodeToIOData encoding <$> minputStr -- | Return the current environment extended with the given overrides. -- If an entry is specified twice in @overrides@, the second entry takes -- precedence. --- -getEffectiveEnvironment :: [(String, Maybe String)] - -> IO (Maybe [(String, String)]) -getEffectiveEnvironment [] = return Nothing +getEffectiveEnvironment + :: [(String, Maybe String)] + -> IO (Maybe [(String, String)]) +getEffectiveEnvironment [] = return Nothing getEffectiveEnvironment overrides = - fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment + fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment where apply os env = foldl' (flip update) env os - update (var, Nothing) = Map.delete var + update (var, Nothing) = Map.delete var update (var, Just val) = Map.insert var val -- | Like the unix xargs program. Useful for when we've got very long command @@ -222,53 +244,51 @@ -- > $ middle args_2 -- > ... -- > $ final args_n --- multiStageProgramInvocation :: ProgramInvocation -> (ProgramInvocation, ProgramInvocation, ProgramInvocation) -> [String] -> [ProgramInvocation] multiStageProgramInvocation simple (initial, middle, final) args = - - let argSize inv = length (progInvokePath inv) - + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) + let argSize inv = + length (progInvokePath inv) + + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) fixedArgSize = maximum (map argSize [simple, initial, middle, final]) - chunkSize = maxCommandLineSize - fixedArgSize - + chunkSize = maxCommandLineSize - fixedArgSize in case splitChunks chunkSize args of - [] -> [ simple ] - - [c] -> [ simple `appendArgs` c ] - - (c:c2:cs) | (xs, x) <- unsnocNE (c2:|cs) -> - [ initial `appendArgs` c ] - ++ [ middle `appendArgs` c'| c' <- xs ] - ++ [ final `appendArgs` x ] - + [] -> [simple] + [c] -> [simple `appendArgs` c] + (c : c2 : cs) + | (xs, x) <- unsnocNE (c2 :| cs) -> + [initial `appendArgs` c] + ++ [middle `appendArgs` c' | c' <- xs] + ++ [final `appendArgs` x] where appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation - inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as } + inv `appendArgs` as = inv{progInvokeArgs = progInvokeArgs inv ++ as} splitChunks :: Int -> [[a]] -> [[[a]]] splitChunks len = unfoldr $ \s -> - if null s then Nothing - else Just (chunk len s) + if null s + then Nothing + else Just (chunk len s) chunk :: Int -> [[a]] -> ([[a]], [[a]]) - chunk len (s:_) | length s >= len = error toolong - chunk len ss = chunk' [] len ss + chunk len (s : _) | length s >= len = error toolong + chunk len ss = chunk' [] len ss chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]]) - chunk' acc len (s:ss) - | len' < len = chunk' (s:acc) (len-len'-1) ss - where len' = length s - chunk' acc _ ss = (reverse acc, ss) - - toolong = "multiStageProgramInvocation: a single program arg is larger " - ++ "than the maximum command line length!" + chunk' acc len (s : ss) + | len' < len = chunk' (s : acc) (len - len' - 1) ss + where + len' = length s + chunk' acc _ ss = (reverse acc, ss) + toolong = + "multiStageProgramInvocation: a single program arg is larger " + ++ "than the maximum command line length!" ---FIXME: discover this at configure time or runtime on unix +-- FIXME: discover this at configure time or runtime on unix -- The value is 32k on Windows and posix specifies a minimum of 4k -- but all sensible unixes use more than 4k. -- we could use getSysVar ArgumentLimit but that's in the unix lib 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 @@ -1,5 +1,7 @@ {-# LANGUAGE GADTs #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Script -- Copyright : Duncan Coutts 2009 @@ -9,16 +11,14 @@ -- -- This module provides an library interface to the @hc-pkg@ program. -- Currently only GHC and LHC have hc-pkg programs. - -module Distribution.Simple.Program.Script ( - - invocationAsSystemScript, - invocationAsShellScript, - invocationAsBatchFile, +module Distribution.Simple.Program.Script + ( invocationAsSystemScript + , invocationAsShellScript + , invocationAsBatchFile ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Program.Run import Distribution.Simple.Utils @@ -26,89 +26,89 @@ -- | Generate a system script, either POSIX shell script or Windows batch file -- as appropriate for the given system. --- invocationAsSystemScript :: OS -> ProgramInvocation -> String invocationAsSystemScript Windows = invocationAsBatchFile -invocationAsSystemScript _ = invocationAsShellScript - +invocationAsSystemScript _ = invocationAsShellScript -- | Generate a POSIX shell script that invokes a program. --- invocationAsShellScript :: ProgramInvocation -> String invocationAsShellScript - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envExtra, - progInvokeCwd = mcwd, - progInvokeInput = minput - } = unlines $ - [ "#!/bin/sh" ] - ++ concatMap setEnv envExtra - ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ] - ++ [ (case minput of - Nothing -> "" - Just input -> "printf '%s' " ++ quote (iodataToText input) ++ " | ") - ++ unwords (map quote $ path : args) ++ " \"$@\""] - - where - setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var] - setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val] + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envExtra + , progInvokeCwd = mcwd + , progInvokeInput = minput + } = + unlines $ + ["#!/bin/sh"] + ++ concatMap setEnv envExtra + ++ ["cd " ++ quote cwd | cwd <- maybeToList mcwd] + ++ [ ( case minput of + Nothing -> "" + Just input -> "printf '%s' " ++ quote (iodataToText input) ++ " | " + ) + ++ unwords (map quote $ path : args) + ++ " \"$@\"" + ] + where + setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var] + setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val] - quote :: String -> String - quote s = "'" ++ escape s ++ "'" + quote :: String -> String + quote s = "'" ++ escape s ++ "'" - escape [] = [] - escape ('\'':cs) = "'\\''" ++ escape cs - escape (c :cs) = c : escape cs + escape [] = [] + escape ('\'' : cs) = "'\\''" ++ escape cs + escape (c : cs) = c : escape cs iodataToText :: IOData -> String -iodataToText (IODataText str) = str +iodataToText (IODataText str) = str iodataToText (IODataBinary lbs) = fromUTF8LBS lbs - -- | Generate a Windows batch file that invokes a program. --- invocationAsBatchFile :: ProgramInvocation -> String invocationAsBatchFile - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envExtra, - progInvokeCwd = mcwd, - progInvokeInput = minput - } = unlines $ - [ "@echo off" ] - ++ map setEnv envExtra - ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ] - ++ case minput of - Nothing -> - [ path ++ concatMap (' ':) args ] - - Just input -> - [ "(" ] - ++ [ "echo " ++ escape line | line <- lines $ iodataToText input ] - ++ [ ") | " - ++ "\"" ++ path ++ "\"" - ++ concatMap (\arg -> ' ':quote arg) args ] - - where - setEnv (var, Nothing) = "set " ++ var ++ "=" - setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envExtra + , progInvokeCwd = mcwd + , progInvokeInput = minput + } = + unlines $ + ["@echo off"] + ++ map setEnv envExtra + ++ ["cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd] + ++ case minput of + Nothing -> + [path ++ concatMap (' ' :) args] + Just input -> + ["("] + ++ ["echo " ++ escape line | line <- lines $ iodataToText input] + ++ [ ") | " + ++ "\"" + ++ path + ++ "\"" + ++ concatMap (\arg -> ' ' : quote arg) args + ] + where + setEnv (var, Nothing) = "set " ++ var ++ "=" + setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val - quote :: String -> String - quote s = "\"" ++ escapeQ s ++ "\"" + quote :: String -> String + quote s = "\"" ++ escapeQ s ++ "\"" - escapeQ [] = [] - escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs - escapeQ (c :cs) = c : escapeQ cs + escapeQ [] = [] + escapeQ ('"' : cs) = "\"\"\"" ++ escapeQ cs + escapeQ (c : cs) = c : escapeQ cs - escape [] = [] - escape ('|':cs) = "^|" ++ escape cs - escape ('<':cs) = "^<" ++ escape cs - escape ('>':cs) = "^>" ++ escape cs - escape ('&':cs) = "^&" ++ escape cs - escape ('(':cs) = "^(" ++ escape cs - escape (')':cs) = "^)" ++ escape cs - escape ('^':cs) = "^^" ++ escape cs - escape (c :cs) = c : escape cs + escape [] = [] + escape ('|' : cs) = "^|" ++ escape cs + escape ('<' : cs) = "^<" ++ escape cs + escape ('>' : cs) = "^>" ++ escape cs + escape ('&' : cs) = "^&" ++ escape cs + escape ('(' : cs) = "^(" ++ escape cs + escape (')' : cs) = "^)" ++ escape cs + escape ('^' : cs) = "^^" ++ escape cs + escape (c : cs) = c : escape cs 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 @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Strip -- @@ -9,12 +10,11 @@ -- Portability : portable -- -- This module provides an library interface to the @strip@ program. - module Distribution.Simple.Program.Strip (stripLib, stripExe) - where +where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Program import Distribution.Simple.Utils @@ -22,54 +22,62 @@ import Distribution.Verbosity import Distribution.Version -import System.FilePath (takeBaseName) +import System.FilePath (takeBaseName) runStrip :: Verbosity -> ProgramDb -> FilePath -> [String] -> IO () runStrip verbosity progDb path args = case lookupProgram stripProgram progDb of Just strip -> runProgram verbosity strip (args ++ [path]) - Nothing -> unless (buildOS == Windows) $ - -- Don't bother warning on windows, we don't expect them to - -- have the strip program anyway. - warn verbosity $ "Unable to strip executable or library '" - ++ (takeBaseName path) - ++ "' (missing the 'strip' program)" + Nothing -> + unless (buildOS == Windows) $ + -- Don't bother warning on windows, we don't expect them to + -- have the strip program anyway. + warn verbosity $ + "Unable to strip executable or library '" + ++ (takeBaseName path) + ++ "' (missing the 'strip' program)" stripExe :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () stripExe verbosity (Platform _arch os) progdb path = runStrip verbosity progdb path args where args = case os of - OSX -> ["-x"] -- By default, stripping the ghc binary on at least - -- some OS X installations causes: - -- HSbase-3.0.o: unknown symbol `_environ'" - -- The -x flag fixes that. - _ -> [] + OSX -> ["-x"] -- By default, stripping the ghc binary on at least + -- some OS X installations causes: + -- HSbase-3.0.o: unknown symbol `_environ'" + -- The -x flag fixes that. + _ -> [] stripLib :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () stripLib verbosity (Platform arch os) progdb path = do case os of - OSX -> -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or - -- Solaris. See #1630. - return () + OSX -> + -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or + -- Solaris. See #1630. + return () IOS -> return () AIX -> return () Solaris -> return () - Windows -> -- Stripping triggers a bug in 'strip.exe' for - -- libraries with lots identically named modules. See - -- #1784. - return() - Linux | arch == I386 -> - -- Versions of 'strip' on 32-bit Linux older than 2.18 are - -- broken. See #2339. - let okVersion = orLaterVersion (mkVersion [2,18]) - in case programVersion =<< lookupProgram stripProgram progdb of - Just v | withinRange v okVersion -> - runStrip verbosity progdb path args - _ -> warn verbosity $ "Unable to strip library '" - ++ (takeBaseName path) - ++ "' (version of 'strip' too old; " - ++ "requires >= 2.18 on 32-bit Linux)" - _ -> runStrip verbosity progdb path args + Windows -> + -- Stripping triggers a bug in 'strip.exe' for + -- libraries with lots identically named modules. See + -- #1784. + return () + Linux + | arch == I386 -> + -- Versions of 'strip' on 32-bit Linux older than 2.18 are + -- broken. See #2339. + let okVersion = orLaterVersion (mkVersion [2, 18]) + in case programVersion =<< lookupProgram stripProgram progdb of + Just v + | withinRange v okVersion -> + runStrip verbosity progdb path args + _ -> + warn verbosity $ + "Unable to strip library '" + ++ (takeBaseName path) + ++ "' (version of 'strip' too old; " + ++ "requires >= 2.18 on 32-bit Linux)" + _ -> runStrip verbosity progdb path args where args = ["--strip-unneeded"] 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 @@ -2,9 +2,9 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Types -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 @@ -19,28 +19,27 @@ -- args). Configuring a program involves finding its location and if necessary -- finding its version. There's reasonable default behavior for trying to find -- \"foo\" in PATH, being able to override its location, etc. --- -module Distribution.Simple.Program.Types ( - -- * Program and functions for constructing them - Program(..), - ProgramSearchPath, - ProgramSearchPathEntry(..), +module Distribution.Simple.Program.Types + ( -- * Program and functions for constructing them + Program (..) + , ProgramSearchPath + , ProgramSearchPathEntry (..) -- * Configured program and related functions - ConfiguredProgram(..), - programPath, - suppressOverrideArgs, - ProgArg, - ProgramLocation(..), - simpleConfiguredProgram, + , ConfiguredProgram (..) + , programPath + , suppressOverrideArgs + , ProgArg + , ProgramLocation (..) + , simpleConfiguredProgram ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.PackageDescription -import Distribution.Version import Distribution.Verbosity +import Distribution.Version import qualified Data.Map as Map @@ -48,38 +47,36 @@ -- -- Note: rather than constructing this directly, start with 'simpleProgram' and -- override any extra fields. --- -data Program = Program { - -- | The simple name of the program, eg. ghc - programName :: String, - - -- | A function to search for the program if its location was not - -- specified by the user. Usually this will just be a call to - -- 'findProgramOnSearchPath'. - -- - -- It is supplied with the prevailing search path which will typically - -- just be used as-is, but can be extended or ignored as needed. - -- - -- For the purpose of change monitoring, in addition to the location - -- where the program was found, it returns all the other places that - -- were tried. - -- - programFindLocation :: Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])), - - -- | Try to find the version of the program. For many programs this is - -- not possible or is not necessary so it's OK to return Nothing. - programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version), +data Program = Program + { programName :: String + -- ^ The simple name of the program, eg. ghc + , programFindLocation + :: Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) + -- ^ A function to search for the program if its location was not + -- specified by the user. Usually this will just be a call to + -- 'findProgramOnSearchPath'. + -- + -- It is supplied with the prevailing search path which will typically + -- just be used as-is, but can be extended or ignored as needed. + -- + -- For the purpose of change monitoring, in addition to the location + -- where the program was found, it returns all the other places that + -- were tried. + , programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version) + -- ^ Try to find the version of the program. For many programs this is + -- not possible or is not necessary so it's OK to return Nothing. + , programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + -- ^ A function to do any additional configuration after we have + -- located the program (and perhaps identified its version). For example + -- it could add args, or environment vars. + , programNormaliseArgs :: Maybe Version -> PackageDescription -> [String] -> [String] + -- ^ A function that filters any arguments that don't impact the output + -- from a commandline. Used to limit the volatility of dependency hashes + -- when using new-build. + } - -- | A function to do any additional configuration after we have - -- located the program (and perhaps identified its version). For example - -- it could add args, or environment vars. - programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram, - -- | A function that filters any arguments that don't impact the output - -- from a commandline. Used to limit the volatility of dependency hashes - -- when using new-build. - programNormaliseArgs :: Maybe Version -> PackageDescription -> [String] -> [String] - } instance Show Program where show (Program name _ _ _ _) = "Program: " ++ name @@ -100,7 +97,7 @@ -- We also use this path to set the environment when running child processes. -- -- The @ProgramDb@ is created with a @ProgramSearchPath@ to which we --- @appendProgramSearchPath@ to add the ones that come from cli flags and from +-- @prependProgramSearchPath@ to add the ones that come from cli flags and from -- configurations. Then each of the programs that are configured in the db -- inherits the same path as part of @configureProgram@. type ProgramSearchPath = [ProgramSearchPathEntry] @@ -120,45 +117,36 @@ -- These are usually made by configuring a 'Program', but if you have to -- construct one directly then start with 'simpleConfiguredProgram' and -- override any extra fields. --- -data ConfiguredProgram = ConfiguredProgram { - -- | Just the name again - programId :: String, - - -- | The version of this program, if it is known. - programVersion :: Maybe Version, - - -- | Default command-line args for this program. - -- These flags will appear first on the command line, so they can be - -- overridden by subsequent flags. - programDefaultArgs :: [String], - - -- | Override command-line args for this program. - -- These flags will appear last on the command line, so they override - -- all earlier flags. - programOverrideArgs :: [String], - - -- | Override environment variables for this program. - -- These env vars will extend\/override the prevailing environment of - -- the current to form the environment for the new process. - programOverrideEnv :: [(String, Maybe String)], - - -- | A key-value map listing various properties of the program, useful - -- for feature detection. Populated during the configuration step, key - -- names depend on the specific program. - programProperties :: Map.Map String String, - - -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ - programLocation :: ProgramLocation, - - -- | 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 - -- monitor to detect when the re-configuring the program might give a - -- different result (e.g. found in a different location). - -- - programMonitorFiles :: [FilePath] - } +data ConfiguredProgram = ConfiguredProgram + { programId :: String + -- ^ Just the name again + , programVersion :: Maybe Version + -- ^ The version of this program, if it is known. + , programDefaultArgs :: [String] + -- ^ Default command-line args for this program. + -- These flags will appear first on the command line, so they can be + -- overridden by subsequent flags. + , programOverrideArgs :: [String] + -- ^ Override command-line args for this program. + -- These flags will appear last on the command line, so they override + -- all earlier flags. + , programOverrideEnv :: [(String, Maybe String)] + -- ^ Override environment variables for this program. + -- These env vars will extend\/override the prevailing environment of + -- the current to form the environment for the new process. + , programProperties :: Map.Map String String + -- ^ A key-value map listing various properties of the program, useful + -- for feature detection. Populated during the configuration step, key + -- names depend on the specific program. + , programLocation :: ProgramLocation + -- ^ Location of the program. eg. @\/usr\/bin\/ghc-6.4@ + , 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 + -- monitor to detect when the re-configuring the program might give a + -- different result (e.g. found in a different location). + } deriving (Eq, Generic, Read, Show, Typeable) instance Binary ConfiguredProgram @@ -167,12 +155,12 @@ -- | Where a program was found. Also tells us whether it's specified by user or -- not. This includes not just the path, but the program as well. data ProgramLocation - = UserSpecified { locationPath :: FilePath } - -- ^The user gave the path to this program, - -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 - | FoundOnSystem { locationPath :: FilePath } - -- ^The program was found automatically. - deriving (Eq, Generic, Read, Show, Typeable) + = -- | The user gave the path to this program, + -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 + UserSpecified {locationPath :: FilePath} + | -- | The program was found automatically. + FoundOnSystem {locationPath :: FilePath} + deriving (Eq, Generic, Read, Show, Typeable) instance Binary ProgramLocation instance Structured ProgramLocation @@ -183,20 +171,20 @@ -- | Suppress any extra arguments added by the user. suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram -suppressOverrideArgs prog = prog { programOverrideArgs = [] } +suppressOverrideArgs prog = prog{programOverrideArgs = []} -- | Make a simple 'ConfiguredProgram'. -- -- > simpleConfiguredProgram "foo" (FoundOnSystem path) --- simpleConfiguredProgram :: String -> ProgramLocation -> ConfiguredProgram -simpleConfiguredProgram name loc = ConfiguredProgram { - programId = name, - programVersion = Nothing, - programDefaultArgs = [], - programOverrideArgs = [], - programOverrideEnv = [], - programProperties = Map.empty, - programLocation = loc, - programMonitorFiles = [] -- did not look in any other locations - } +simpleConfiguredProgram name loc = + ConfiguredProgram + { programId = name + , programVersion = Nothing + , programDefaultArgs = [] + , programOverrideArgs = [] + , programOverrideEnv = [] + , programProperties = Map.empty + , programLocation = loc + , programMonitorFiles = [] -- did not look in any other locations + } 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 @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Register -- Copyright : Isaac Jones 2003-2004 @@ -25,163 +26,194 @@ -- This module does not delegate anything to the per-compiler modules but just -- mixes it all in this module, which is rather unsatisfactory. The script -- generation and the unregister feature are not well used or tested. - -module Distribution.Simple.Register ( - register, - unregister, - - internalPackageDBPath, - - initPackageDB, - doesPackageDBExist, - createPackageDB, - deletePackageDB, - - abiHash, - invokeHcPkg, - registerPackage, - HcPkg.RegisterOptions(..), - HcPkg.defaultRegisterOptions, - generateRegistrationInfo, - inplaceInstalledPackageInfo, - absoluteInstalledPackageInfo, - generalInstalledPackageInfo, +module Distribution.Simple.Register + ( register + , unregister + , internalPackageDBPath + , initPackageDB + , doesPackageDBExist + , createPackageDB + , deletePackageDB + , abiHash + , invokeHcPkg + , registerPackage + , HcPkg.RegisterOptions (..) + , HcPkg.defaultRegisterOptions + , generateRegistrationInfo + , inplaceInstalledPackageInfo + , absoluteInstalledPackageInfo + , generalInstalledPackageInfo ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.TargetInfo -import Distribution.Types.LocalBuildInfo import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo -import Distribution.Simple.LocalBuildInfo import Distribution.Simple.BuildPaths import Distribution.Simple.BuildTarget +import Distribution.Simple.LocalBuildInfo -import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC import qualified Distribution.Simple.HaskellSuite as HaskellSuite import qualified Distribution.Simple.PackageIndex as Index +import qualified Distribution.Simple.UHC as UHC import Distribution.Backpack.DescribeUnitId +import Distribution.Compat.Graph (IsNode (nodeKey)) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.License (licenseFromSPDX, licenseToSPDX) +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Pretty import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Flag import Distribution.Simple.Program -import Distribution.Simple.Program.Script import qualified Distribution.Simple.Program.HcPkg as HcPkg -import Distribution.Simple.Setup -import Distribution.PackageDescription -import Distribution.Package -import Distribution.License (licenseToSPDX, licenseFromSPDX) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Simple.Program.Script +import Distribution.Simple.Setup.Register import Distribution.Simple.Utils -import Distribution.Utils.MapAccum import Distribution.System -import Distribution.Pretty +import Distribution.Utils.MapAccum import Distribution.Verbosity as Verbosity import Distribution.Version -import Distribution.Compat.Graph (IsNode(nodeKey)) - -import System.FilePath ((), (<.>), isAbsolute) import System.Directory +import System.FilePath (isAbsolute, (<.>), ()) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -- ----------------------------------------------------------------------------- -- Registration -register :: PackageDescription -> LocalBuildInfo - -> RegisterFlags -- ^Install in the user's database?; verbose - -> IO () +register + :: PackageDescription + -> LocalBuildInfo + -> RegisterFlags + -- ^ Install in the user's database?; verbose + -> IO () register pkg_descr lbi0 flags = - -- Duncan originally asked for us to not register/install files - -- when there was no public library. But with per-component - -- configure, we legitimately need to install internal libraries - -- so that we can get them. So just unconditionally install. - doRegister - where - doRegister = do - targets <- readTargetInfos verbosity pkg_descr lbi0 (regArgs flags) + -- Duncan originally asked for us to not register/install files + -- when there was no public library. But with per-component + -- configure, we legitimately need to install internal libraries + -- so that we can get them. So just unconditionally install. + doRegister + where + doRegister = do + targets <- readTargetInfos verbosity pkg_descr lbi0 (regArgs flags) - -- It's important to register in build order, because ghc-pkg - -- will complain if a dependency is not registered. - let componentsToRegister - = neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets) + -- It's important to register in build order, because ghc-pkg + -- will complain if a dependency is not registered. + let componentsToRegister = + neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets) - (_, ipi_mbs) <- + (_, ipi_mbs) <- mapAccumM `flip` installedPkgs lbi0 `flip` componentsToRegister $ \index tgt -> - case targetComponent tgt of - CLib lib -> do - let clbi = targetCLBI tgt - lbi = lbi0 { installedPkgs = index } - ipi <- generateOne pkg_descr lib lbi clbi flags - return (Index.insert ipi index, Just ipi) - _ -> return (index, Nothing) + case targetComponent tgt of + CLib lib -> do + let clbi = targetCLBI tgt + lbi = lbi0{installedPkgs = index} + ipi <- generateOne pkg_descr lib lbi clbi flags + return (Index.insert ipi index, Just ipi) + _ -> return (index, Nothing) - registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs) - where - verbosity = fromFlag (regVerbosity flags) + registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs) + where + verbosity = fromFlag (regVerbosity flags) -generateOne :: PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo - -> RegisterFlags - -> IO InstalledPackageInfo -generateOne pkg lib lbi clbi regFlags - = do - absPackageDBs <- absolutePackageDBPaths packageDbs - installedPkgInfo <- generateRegistrationInfo - verbosity pkg lib lbi clbi inplace reloc distPref - (registrationPackageDB absPackageDBs) +generateOne + :: PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> RegisterFlags + -> IO InstalledPackageInfo +generateOne pkg lib lbi clbi regFlags = + do + absPackageDBs <- absolutePackageDBPaths packageDbs + installedPkgInfo <- + generateRegistrationInfo + verbosity + pkg + lib + lbi + clbi + inplace + reloc + distPref + (registrationPackageDB absPackageDBs) info verbosity (IPI.showInstalledPackageInfo installedPkgInfo) return installedPkgInfo where - inplace = fromFlag (regInPlace regFlags) - reloc = relocatable lbi + inplace = fromFlag (regInPlace regFlags) + reloc = relocatable lbi -- FIXME: there's really no guarantee this will work. -- registering into a totally different db stack can -- fail if dependencies cannot be satisfied. - packageDbs = nub $ withPackageDB lbi - ++ maybeToList (flagToMaybe (regPackageDB regFlags)) - distPref = fromFlag (regDistPref regFlags) + packageDbs = + nub $ + withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + distPref = fromFlag (regDistPref regFlags) verbosity = fromFlag (regVerbosity regFlags) -registerAll :: PackageDescription -> LocalBuildInfo -> RegisterFlags - -> [InstalledPackageInfo] - -> IO () -registerAll pkg lbi regFlags ipis - = do +registerAll + :: PackageDescription + -> LocalBuildInfo + -> RegisterFlags + -> [InstalledPackageInfo] + -> IO () +registerAll pkg lbi regFlags ipis = + do when (fromFlag (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)) + when + ( packageId installedPkgInfo == packageId pkg + && IPI.sourceLibName installedPkgInfo == LMainLibName + ) + $ putStrLn (prettyShow (IPI.installedUnitId installedPkgInfo)) - -- Three different modes: + -- Three different modes: case () of - _ | modeGenerateRegFile -> writeRegistrationFileOrDirectory - | modeGenerateRegScript -> writeRegisterScript - | otherwise -> do - for_ ipis $ \ipi -> do - setupMessage' verbosity "Registering" (packageId pkg) - (CLibName (IPI.sourceLibName ipi)) - (Just (IPI.instantiatedWith ipi)) - registerPackage verbosity (compiler lbi) (withPrograms lbi) - packageDbs ipi HcPkg.defaultRegisterOptions - + _ + | modeGenerateRegFile -> writeRegistrationFileOrDirectory + | modeGenerateRegScript -> writeRegisterScript + | otherwise -> do + for_ ipis $ \ipi -> do + setupMessage' + verbosity + "Registering" + (packageId pkg) + (CLibName (IPI.sourceLibName ipi)) + (Just (IPI.instantiatedWith ipi)) + registerPackage + verbosity + (compiler lbi) + (withPrograms lbi) + packageDbs + ipi + HcPkg.defaultRegisterOptions where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) - regFile = fromMaybe (prettyShow (packageId pkg) <.> "conf") - (fromFlag (regGenPkgConf regFlags)) + regFile = + fromMaybe + (prettyShow (packageId pkg) <.> "conf") + (fromFlag (regGenPkgConf regFlags)) modeGenerateRegScript = fromFlag (regGenScript regFlags) -- FIXME: there's really no guarantee this will work. -- registering into a totally different db stack can -- fail if dependencies cannot be satisfied. - packageDbs = nub $ withPackageDB lbi - ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + packageDbs = + nub $ + withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) verbosity = fromFlag (regVerbosity regFlags) writeRegistrationFileOrDirectory = do @@ -196,172 +228,233 @@ createDirectory regFile let num_ipis = length ipis lpad m xs = replicate (m - length ys) '0' ++ ys - where ys = take m xs + where + ys = take m xs number i = lpad (length (show num_ipis)) (show i) - for_ (zip ([1..] :: [Int]) ipis) $ \(i, installedPkgInfo) -> - writeUTF8File (regFile (number i ++ "-" ++ prettyShow (IPI.installedUnitId installedPkgInfo))) - (IPI.showInstalledPackageInfo installedPkgInfo) + for_ (zip ([1 ..] :: [Int]) ipis) $ \(i, installedPkgInfo) -> + writeUTF8File + (regFile (number i ++ "-" ++ prettyShow (IPI.installedUnitId installedPkgInfo))) + (IPI.showInstalledPackageInfo installedPkgInfo) writeRegisterScript = case compilerFlavor (compiler lbi) of UHC -> notice verbosity "Registration scripts not needed for uhc" - _ -> withHcPkg verbosity - "Registration scripts are not implemented for this compiler" - (compiler lbi) (withPrograms lbi) - (writeHcPkgRegisterScript verbosity ipis packageDbs) - + _ -> + withHcPkg + verbosity + "Registration scripts are not implemented for this compiler" + (compiler lbi) + (withPrograms lbi) + (writeHcPkgRegisterScript verbosity ipis packageDbs) -generateRegistrationInfo :: Verbosity - -> PackageDescription - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Bool - -> Bool - -> FilePath - -> PackageDB - -> IO InstalledPackageInfo +generateRegistrationInfo + :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Bool + -> Bool + -> FilePath + -> PackageDB + -> IO InstalledPackageInfo generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do - --TODO: eliminate pwd! + -- TODO: eliminate pwd! pwd <- getCurrentDirectory installedPkgInfo <- if inplace - -- NB: With an inplace installation, the user may run './Setup + then -- NB: With an inplace installation, the user may run './Setup -- build' to update the library files, without reregistering. -- In this case, it is critical that the ABI hash not flip. - then return (inplaceInstalledPackageInfo pwd distPref - pkg (mkAbiHash "inplace") lib lbi clbi) - else do + + return + ( inplaceInstalledPackageInfo + pwd + distPref + pkg + (mkAbiHash "inplace") + lib + lbi + clbi + ) + else do abi_hash <- abiHash verbosity pkg distPref lbi lib clbi if reloc - then relocRegistrationInfo verbosity - pkg lib lbi clbi abi_hash packageDb - else return (absoluteInstalledPackageInfo - pkg abi_hash lib lbi clbi) - + then + relocRegistrationInfo + verbosity + pkg + lib + lbi + clbi + abi_hash + packageDb + else + return + ( absoluteInstalledPackageInfo + pkg + abi_hash + lib + lbi + clbi + ) return installedPkgInfo -- | Compute the 'AbiHash' of a library that we built inplace. -abiHash :: Verbosity - -> PackageDescription - -> FilePath - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO AbiHash +abiHash + :: Verbosity + -> PackageDescription + -> FilePath + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO AbiHash abiHash verbosity pkg distPref lbi lib clbi = - case compilerFlavor comp of - GHC -> do - fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi - GHCJS -> do - fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi - _ -> return (mkAbiHash "") + case compilerFlavor comp of + GHC -> do + fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi + GHCJS -> do + fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi + _ -> return (mkAbiHash "") where comp = compiler lbi - lbi' = lbi { - withPackageDB = withPackageDB lbi - ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)] - } + lbi' = + lbi + { withPackageDB = + withPackageDB lbi + ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)] + } -relocRegistrationInfo :: Verbosity - -> PackageDescription - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> AbiHash - -> PackageDB - -> IO InstalledPackageInfo +relocRegistrationInfo + :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> AbiHash + -> PackageDB + -> IO InstalledPackageInfo relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb = case (compilerFlavor (compiler lbi)) of - GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb - return (relocatableInstalledPackageInfo - pkg abi_hash lib lbi clbi fs) - _ -> die' verbosity - "Distribution.Simple.Register.relocRegistrationInfo: \ - \not implemented for this compiler" + GHC -> do + fs <- GHC.pkgRoot verbosity lbi packageDb + return + ( relocatableInstalledPackageInfo + pkg + abi_hash + lib + lbi + clbi + fs + ) + _ -> dieWithException verbosity RelocRegistrationInfo initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO () initPackageDB verbosity comp progdb dbPath = - createPackageDB verbosity comp progdb False dbPath + createPackageDB verbosity comp progdb False dbPath -- | Create an empty package DB at the specified location. -createPackageDB :: Verbosity -> Compiler -> ProgramDb -> Bool - -> FilePath -> IO () +createPackageDB + :: Verbosity + -> Compiler + -> ProgramDb + -> Bool + -> FilePath + -> IO () createPackageDB verbosity comp progdb preferCompat dbPath = - case compilerFlavor comp of - GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath - GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath - UHC -> return () - HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath - _ -> die' verbosity $ - "Distribution.Simple.Register.createPackageDB: " - ++ "not implemented for this compiler" + case compilerFlavor comp of + GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath + GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath + UHC -> return () + HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath + _ -> dieWithException verbosity CreatePackageDB doesPackageDBExist :: FilePath -> IO Bool doesPackageDBExist dbPath = do - -- currently one impl for all compiler flavours, but could change if needed - dir_exists <- doesDirectoryExist dbPath - if dir_exists - then return True - else doesFileExist dbPath + -- currently one impl for all compiler flavours, but could change if needed + dir_exists <- doesDirectoryExist dbPath + if dir_exists + then return True + else doesFileExist dbPath deletePackageDB :: FilePath -> IO () deletePackageDB dbPath = do - -- 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 + -- 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 -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. -invokeHcPkg :: Verbosity -> Compiler -> ProgramDb -> PackageDBStack - -> [String] -> IO () +invokeHcPkg + :: Verbosity + -> Compiler + -> ProgramDb + -> PackageDBStack + -> [String] + -> IO () invokeHcPkg verbosity comp progdb dbStack extraArgs = - withHcPkg verbosity "invokeHcPkg" comp progdb + withHcPkg + verbosity + "invokeHcPkg" + comp + progdb (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs) -withHcPkg :: Verbosity -> String -> Compiler -> ProgramDb - -> (HcPkg.HcPkgInfo -> IO a) -> IO a +withHcPkg + :: Verbosity + -> String + -> Compiler + -> ProgramDb + -> (HcPkg.HcPkgInfo -> IO a) + -> IO a withHcPkg verbosity name comp progdb f = case compilerFlavor comp of - GHC -> f (GHC.hcPkgInfo progdb) + GHC -> f (GHC.hcPkgInfo progdb) GHCJS -> f (GHCJS.hcPkgInfo progdb) - _ -> die' verbosity ("Distribution.Simple.Register." ++ name ++ ":\ - \not implemented for this compiler") + _ -> dieWithException verbosity $ WithHcPkg name -registerPackage :: Verbosity - -> Compiler - -> ProgramDb - -> PackageDBStack - -> InstalledPackageInfo - -> HcPkg.RegisterOptions - -> IO () +registerPackage + :: Verbosity + -> Compiler + -> ProgramDb + -> PackageDBStack + -> InstalledPackageInfo + -> HcPkg.RegisterOptions + -> IO () registerPackage verbosity comp progdb packageDbs installedPkgInfo registerOptions = case compilerFlavor comp of - GHC -> GHC.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions + GHC -> GHC.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions GHCJS -> GHCJS.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions - HaskellSuite {} -> - HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo - _ | HcPkg.registerMultiInstance registerOptions - -> die' verbosity "Registering multiple package instances is not yet supported for this compiler" - UHC -> UHC.registerPackage verbosity comp progdb packageDbs installedPkgInfo - _ -> die' verbosity "Registering is not implemented for this compiler" + HaskellSuite{} -> + HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo + _ + | HcPkg.registerMultiInstance registerOptions -> + dieWithException verbosity RegisMultiplePkgNotSupported + UHC -> UHC.registerPackage verbosity comp progdb packageDbs installedPkgInfo + _ -> dieWithException verbosity RegisteringNotImplemented -writeHcPkgRegisterScript :: Verbosity - -> [InstalledPackageInfo] - -> PackageDBStack - -> HcPkg.HcPkgInfo - -> IO () +writeHcPkgRegisterScript + :: Verbosity + -> [InstalledPackageInfo] + -> PackageDBStack + -> HcPkg.HcPkgInfo + -> IO () writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do let genScript installedPkgInfo = - let invocation = HcPkg.registerInvocation hpi Verbosity.normal - packageDbs installedPkgInfo - HcPkg.defaultRegisterOptions - in invocationAsSystemScript buildOS invocation + let invocation = + HcPkg.registerInvocation + hpi + Verbosity.normal + packageDbs + installedPkgInfo + HcPkg.defaultRegisterOptions + in invocationAsSystemScript buildOS invocation scripts = map genScript ipis -- TODO: Do something more robust here regScript = unlines scripts @@ -372,19 +465,18 @@ regScriptFileName :: FilePath regScriptFileName = case buildOS of - Windows -> "register.bat" - _ -> "register.sh" - + Windows -> "register.bat" + _ -> "register.sh" -- ----------------------------------------------------------------------------- -- Making the InstalledPackageInfo -- | Construct 'InstalledPackageInfo' for a library in a package, given a set -- of installation directories. --- generalInstalledPackageInfo - :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to - -- absolute paths. + :: ([FilePath] -> [FilePath]) + -- ^ Translate relative include dir paths to + -- absolute paths. -> PackageDescription -> AbiHash -> Library @@ -393,87 +485,94 @@ -> InstallDirs FilePath -> InstalledPackageInfo generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDirs = - IPI.InstalledPackageInfo { - IPI.sourcePackageId = packageId pkg, - IPI.installedUnitId = componentUnitId clbi, - IPI.installedComponentId_ = componentComponentId clbi, - IPI.instantiatedWith = componentInstantiatedWith clbi, - IPI.sourceLibName = libName lib, - IPI.compatPackageKey = componentCompatPackageKey clbi, - -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license - IPI.license = + IPI.InstalledPackageInfo + { IPI.sourcePackageId = packageId pkg + , IPI.installedUnitId = componentUnitId clbi + , IPI.installedComponentId_ = componentComponentId clbi + , IPI.instantiatedWith = componentInstantiatedWith clbi + , IPI.sourceLibName = libName lib + , IPI.compatPackageKey = componentCompatPackageKey clbi + , -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license + IPI.license = if ghc84 - then Left $ either id licenseToSPDX $ licenseRaw pkg - else Right $ either licenseFromSPDX id $ licenseRaw pkg, - IPI.copyright = copyright pkg, - IPI.maintainer = maintainer pkg, - IPI.author = author pkg, - IPI.stability = stability pkg, - IPI.homepage = homepage pkg, - IPI.pkgUrl = pkgUrl pkg, - IPI.synopsis = synopsis pkg, - IPI.description = description pkg, - IPI.category = category pkg, - IPI.abiHash = abi_hash, - IPI.indefinite = componentIsIndefinite clbi, - IPI.exposed = libExposed lib, - IPI.exposedModules = componentExposedModules clbi - -- add virtual modules into the list of exposed modules for the - -- package database as well. - ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi), - IPI.hiddenModules = otherModules bi, - IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo, - IPI.importDirs = [ libdir installDirs | hasModules ], - IPI.libraryDirs = libdirs, - IPI.libraryDirsStatic = libdirsStatic, - IPI.libraryDynDirs = dynlibdirs, - IPI.dataDir = datadir installDirs, - IPI.hsLibraries = (if hasLibrary - then [getHSLibraryName (componentUnitId clbi)] - else []) ++ extraBundledLibs bi, - IPI.extraLibraries = extraLibs bi, - IPI.extraLibrariesStatic = extraLibsStatic bi, - IPI.extraGHCiLibraries = extraGHCiLibs bi, - IPI.includeDirs = absinc ++ adjustRelIncDirs relinc, - IPI.includes = includes bi, - IPI.depends = depends, - IPI.abiDepends = [], -- due to #5465 - IPI.ccOptions = [], -- Note. NOT ccOptions bi! - -- We don't want cc-options to be propagated - -- to C compilations in other packages. - IPI.cxxOptions = [], -- Also. NOT cxxOptions bi! - IPI.ldOptions = ldOptions bi, - IPI.frameworks = frameworks bi, - IPI.frameworkDirs = extraFrameworkDirs bi, - IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg], - IPI.haddockHTMLs = [htmldir installDirs], - IPI.pkgRoot = Nothing, - IPI.libVisibility = libVisibility lib - } + then Left $ either id licenseToSPDX $ licenseRaw pkg + else Right $ either licenseFromSPDX id $ licenseRaw pkg + , IPI.copyright = copyright pkg + , IPI.maintainer = maintainer pkg + , IPI.author = author pkg + , IPI.stability = stability pkg + , IPI.homepage = homepage pkg + , IPI.pkgUrl = pkgUrl pkg + , IPI.synopsis = synopsis pkg + , IPI.description = description pkg + , IPI.category = category pkg + , IPI.abiHash = abi_hash + , IPI.indefinite = componentIsIndefinite clbi + , IPI.exposed = libExposed lib + , IPI.exposedModules = + componentExposedModules clbi + -- add virtual modules into the list of exposed modules for the + -- package database as well. + ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi) + , IPI.hiddenModules = otherModules bi + , IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo + , IPI.importDirs = [libdir installDirs | hasModules] + , IPI.libraryDirs = libdirs + , IPI.libraryDirsStatic = libdirsStatic + , IPI.libraryDynDirs = dynlibdirs + , IPI.dataDir = datadir installDirs + , IPI.hsLibraries = + ( if hasLibrary + then [getHSLibraryName (componentUnitId clbi)] + else [] + ) + ++ extraBundledLibs bi + , IPI.extraLibraries = extraLibs bi + , IPI.extraLibrariesStatic = extraLibsStatic bi + , IPI.extraGHCiLibraries = extraGHCiLibs bi + , IPI.includeDirs = absinc ++ adjustRelIncDirs relinc + , IPI.includes = includes bi + , IPI.depends = depends + , IPI.abiDepends = [] -- due to #5465 + , IPI.ccOptions = [] -- Note. NOT ccOptions bi! + -- We don't want cc-options to be propagated + -- to C compilations in other packages. + , IPI.cxxOptions = [] -- Also. NOT cxxOptions bi! + , IPI.ldOptions = ldOptions bi + , IPI.frameworks = frameworks bi + , IPI.frameworkDirs = extraFrameworkDirs bi + , IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg] + , IPI.haddockHTMLs = [htmldir installDirs] + , IPI.pkgRoot = Nothing + , IPI.libVisibility = libVisibility lib + } where ghc84 = case compilerId $ compiler lbi of - CompilerId GHC v -> v >= mkVersion [8, 4] - _ -> False + CompilerId GHC v -> v >= mkVersion [8, 4] + _ -> False bi = libBuildInfo lib - --TODO: unclear what the root cause of the + -- TODO: unclear what the root cause of the -- duplication is, but we nub it here for now: depends = ordNub $ map fst (componentPackageDeps clbi) (absinc, relinc) = partition isAbsolute (includeDirs bi) hasModules = not $ null (allLibModules lib clbi) comp = compiler lbi - hasLibrary = (hasModules || not (null (cSources bi)) - || not (null (asmSources bi)) - || not (null (cmmSources bi)) - || not (null (cxxSources bi)) - || (not (null (jsSources bi)) && hasJsSupport)) - && not (componentIsIndefinite clbi) + hasLibrary = + ( hasModules + || not (null (cSources bi)) + || not (null (asmSources bi)) + || not (null (cmmSources bi)) + || not (null (cxxSources bi)) + || (not (null (jsSources bi)) && hasJsSupport) + ) + && not (componentIsIndefinite clbi) hasJsSupport = case hostPlatform lbi of Platform JavaScript _ -> True - _ -> False + _ -> False libdirsStatic | hasLibrary = libdir installDirs : extraLibDirsStaticOrFallback - | otherwise = extraLibDirsStaticOrFallback + | otherwise = extraLibDirsStaticOrFallback where -- If no static library dirs were given, the package likely makes no -- distinction between fully static linking and otherwise. @@ -482,128 +581,161 @@ [] -> extraLibDirs bi dirs -> dirs (libdirs, dynlibdirs) - | not hasLibrary - = (extraLibDirs bi, []) + | not hasLibrary = + (extraLibDirs bi, []) -- the dynamic-library-dirs defaults to the library-dirs if not specified, -- so this works whether the dynamic-library-dirs field is supported or not - | libraryDynDirSupported comp - = (libdir installDirs : extraLibDirs bi, - dynlibdir installDirs : extraLibDirs bi) + | libraryDynDirSupported comp = + ( libdir installDirs : extraLibDirs bi + , dynlibdir installDirs : extraLibDirs bi + ) + | otherwise = + (libdir installDirs : dynlibdir installDirs : extraLibDirs bi, []) - | otherwise - = (libdir installDirs : dynlibdir installDirs : extraLibDirs bi, []) - -- 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 +-- 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 -- | Construct 'InstalledPackageInfo' for a library that is in place in the -- build tree. -- -- This function knows about the layout of in place packages. --- -inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree - -> FilePath -- ^ location of the dist tree - -> PackageDescription - -> AbiHash - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> InstalledPackageInfo +inplaceInstalledPackageInfo + :: FilePath + -- ^ top of the build tree + -> FilePath + -- ^ location of the dist tree + -> PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo inplaceInstalledPackageInfo inplaceDir distPref pkg abi_hash lib lbi clbi = - generalInstalledPackageInfo adjustRelativeIncludeDirs - pkg abi_hash lib lbi clbi installDirs + generalInstalledPackageInfo + adjustRelativeIncludeDirs + pkg + abi_hash + lib + lbi + clbi + installDirs where adjustRelativeIncludeDirs = concatMap $ \d -> - [ inplaceDir d -- local include-dir - , inplaceDir libTargetDir d -- autogen include-dir + [ inplaceDir d -- local include-dir + , inplaceDir libTargetDir d -- autogen include-dir ] libTargetDir = componentBuildDir lbi clbi installDirs = - (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) { - libdir = inplaceDir libTargetDir, - dynlibdir = inplaceDir libTargetDir, - datadir = inplaceDir dataDir pkg, - docdir = inplaceDocdir, - htmldir = inplaceHtmldir, - haddockdir = inplaceHtmldir - } - inplaceDocdir = inplaceDir distPref "doc" + (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) + { libdir = inplaceDir libTargetDir + , dynlibdir = inplaceDir libTargetDir + , datadir = inplaceDir dataDir pkg + , docdir = inplaceDocdir + , htmldir = inplaceHtmldir + , haddockdir = inplaceHtmldir + } + inplaceDocdir = inplaceDir distPref "doc" inplaceHtmldir = inplaceDocdir "html" prettyShow (packageName pkg) - -- | Construct 'InstalledPackageInfo' for the final install location of a -- library package. -- -- This function knows about the layout of installed packages. --- -absoluteInstalledPackageInfo :: PackageDescription - -> AbiHash - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> InstalledPackageInfo +absoluteInstalledPackageInfo + :: PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo absoluteInstalledPackageInfo pkg abi_hash lib lbi clbi = - generalInstalledPackageInfo adjustReativeIncludeDirs - pkg abi_hash lib lbi clbi installDirs + generalInstalledPackageInfo + adjustReativeIncludeDirs + pkg + abi_hash + lib + lbi + clbi + installDirs where -- For installed packages we install all include files into one dir, -- whereas in the build tree they may live in multiple local dirs. adjustReativeIncludeDirs _ | null (installIncludes bi) = [] - | otherwise = [includedir installDirs] + | otherwise = [includedir installDirs] bi = libBuildInfo lib installDirs = absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest - -relocatableInstalledPackageInfo :: PackageDescription - -> AbiHash - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> FilePath - -> InstalledPackageInfo +relocatableInstalledPackageInfo + :: PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> InstalledPackageInfo relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi pkgroot = - generalInstalledPackageInfo adjustReativeIncludeDirs - pkg abi_hash lib lbi clbi installDirs + generalInstalledPackageInfo + adjustReativeIncludeDirs + pkg + abi_hash + lib + lbi + clbi + installDirs where -- For installed packages we install all include files into one dir, -- whereas in the build tree they may live in multiple local dirs. adjustReativeIncludeDirs _ | null (installIncludes bi) = [] - | otherwise = [includedir installDirs] + | otherwise = [includedir installDirs] bi = libBuildInfo lib - installDirs = fmap (("${pkgroot}" ) . shortRelativePath pkgroot) - $ absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest + installDirs = + fmap (("${pkgroot}" ) . shortRelativePath pkgroot) $ + absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest -- ----------------------------------------------------------------------------- -- Unregistration unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () unregister pkg lbi regFlags = do - let pkgid = packageId pkg + let pkgid = packageId pkg genScript = fromFlag (regGenScript regFlags) verbosity = fromFlag (regVerbosity regFlags) - packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) - (regPackageDB regFlags) + packageDb = + fromFlagOrDefault + (registrationPackageDB (withPackageDB lbi)) + (regPackageDB regFlags) unreg hpi = - let invocation = HcPkg.unregisterInvocation - hpi Verbosity.normal packageDb pkgid - in if genScript - then writeFileAtomic unregScriptFileName - (BS.Char8.pack $ invocationAsSystemScript buildOS invocation) - else runProgramInvocation verbosity invocation + let invocation = + HcPkg.unregisterInvocation + hpi + Verbosity.normal + packageDb + pkgid + in if genScript + then + writeFileAtomic + unregScriptFileName + (BS.Char8.pack $ invocationAsSystemScript buildOS invocation) + else runProgramInvocation verbosity invocation setupMessage verbosity "Unregistering" pkgid - withHcPkg verbosity "unregistering is only implemented for GHC and GHCJS" - (compiler lbi) (withPrograms lbi) unreg + withHcPkg + verbosity + "unregistering is only implemented for GHC and GHCJS" + (compiler lbi) + (withPrograms lbi) + unreg unregScriptFileName :: FilePath unregScriptFileName = case buildOS of - Windows -> "unregister.bat" - _ -> "unregister.sh" + Windows -> "unregister.bat" + _ -> "unregister.sh" internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath internalPackageDBPath lbi distPref = - case compilerFlavor (compiler lbi) of - UHC -> UHC.inplacePackageDbPath lbi - _ -> distPref "package.conf.inplace" + case compilerFlavor (compiler lbi) of + UHC -> UHC.inplacePackageDbPath lbi + _ -> distPref "package.conf.inplace" 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 @@ -2,2563 +2,197 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Setup --- Copyright : Isaac Jones 2003-2004 --- Duncan Coutts 2007 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is a big module, but not very complicated. The code is very regular --- and repetitive. It defines the command line interface for all the Cabal --- commands. For each command (like @configure@, @build@ etc) it defines a type --- that holds all the flags, the default set of flags and a 'CommandUI' that --- maps command line flags to and from the corresponding flags type. --- --- All the flags types are instances of 'Monoid', see --- --- for an explanation. --- --- The types defined here get used in the front end and especially in --- @cabal-install@ which has to do quite a bit of manipulating sets of command --- line flags. --- --- This is actually relatively nice, it works quite well. The main change it --- needs is to unify it with the code for managing sets of fields that can be --- read and written from files. This would allow us to save configure flags in --- config files. - -module Distribution.Simple.Setup ( - - GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, - ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, - configPrograms, - configAbsolutePaths, readPackageDb, readPackageDbList, showPackageDb, showPackageDbList, - CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, - InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, - HaddockTarget(..), - HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, - Visibility(..), - HaddockProjectFlags(..), emptyHaddockProjectFlags, defaultHaddockProjectFlags, haddockProjectCommand, - HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, - BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, - DumpBuildInfo(..), - ReplFlags(..), defaultReplFlags, replCommand, - ReplOptions(..), - CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, - RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, - unregisterCommand, - SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, - TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, - TestShowDetails(..), - BenchmarkFlags(..), emptyBenchmarkFlags, - defaultBenchmarkFlags, benchmarkCommand, - CopyDest(..), - configureArgs, configureOptions, configureCCompiler, configureLinker, - buildOptions, haddockOptions, haddockProjectOptions, installDirsOptions, - testOptions', benchmarkOptions', - programDbOptions, programDbPaths', - programFlagsDescription, - replOptions, - splitArgs, - - defaultDistPref, optionDistPref, - - Flag(..), - toFlag, - fromFlag, - fromFlagOrDefault, - flagToMaybe, - flagToList, - maybeToFlag, - BooleanFlag(..), - boolOpt, boolOpt', trueArg, falseArg, - optionVerbosity, optionNumJobs) where - -import Prelude () -import Distribution.Compat.Prelude hiding (get) - -import Distribution.Compiler -import Distribution.ReadE -import Distribution.Parsec -import Distribution.Pretty -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import Distribution.ModuleName -import Distribution.PackageDescription -import Distribution.Simple.Command hiding (boolOpt, boolOpt') -import qualified Distribution.Simple.Command as Command -import Distribution.Simple.Compiler -import Distribution.Simple.Flag -import Distribution.Simple.Utils -import Distribution.Simple.Program -import Distribution.Simple.InstallDirs -import Distribution.Verbosity -import Distribution.Utils.NubList -import Distribution.Types.ComponentId -import Distribution.Types.DumpBuildInfo -import Distribution.Types.GivenComponent -import Distribution.Types.Module -import Distribution.Types.PackageVersionConstraint - -import Distribution.Compat.Stack -import Distribution.Compat.Semigroup (Last' (..), Option' (..)) - --- FIXME Not sure where this should live -defaultDistPref :: FilePath -defaultDistPref = "dist" - --- ------------------------------------------------------------ --- * Global flags --- ------------------------------------------------------------ - --- In fact since individual flags types are monoids and these are just sets of --- flags then they are also monoids pointwise. This turns out to be really --- useful. The mempty is the set of empty flags and mappend allows us to --- override specific flags. For example we can start with default flags and --- override with the ones we get from a file or the command line, or both. - --- | Flags that apply at the top level, not to any sub-command. -data GlobalFlags = GlobalFlags { - globalVersion :: Flag Bool, - globalNumericVersion :: Flag Bool - } deriving (Generic, Typeable) - -defaultGlobalFlags :: GlobalFlags -defaultGlobalFlags = GlobalFlags { - globalVersion = Flag False, - globalNumericVersion = Flag False - } - -globalCommand :: [Command action] -> CommandUI GlobalFlags -globalCommand commands = CommandUI - { commandName = "" - , commandSynopsis = "" - , commandUsage = \pname -> - "This Setup program uses the Haskell Cabal Infrastructure.\n" - ++ "See http://www.haskell.org/cabal/ for more information.\n" - ++ "\n" - ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n" - , commandDescription = Just $ \pname -> - let - commands' = commands ++ [commandAddAction helpCommandUI undefined] - cmdDescs = getNormalCommandDescriptions commands' - maxlen = maximum $ [length name | (name, _) <- cmdDescs] - align str = str ++ replicate (maxlen - length str) ' ' - in - "Commands:\n" - ++ unlines [ " " ++ align name ++ " " ++ descr - | (name, descr) <- cmdDescs ] - ++ "\n" - ++ "For more information about a command use\n" - ++ " " ++ pname ++ " COMMAND --help\n\n" - ++ "Typical steps for installing Cabal packages:\n" - ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" - | x <- ["configure", "build", "install"]] - , commandNotes = Nothing - , commandDefaultFlags = defaultGlobalFlags - , commandOptions = \_ -> - [option ['V'] ["version"] - "Print version information" - globalVersion (\v flags -> flags { globalVersion = v }) - trueArg - ,option [] ["numeric-version"] - "Print just the version number" - globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) - trueArg - ] - } - -emptyGlobalFlags :: GlobalFlags -emptyGlobalFlags = mempty - -instance Monoid GlobalFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup GlobalFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Config flags --- ------------------------------------------------------------ - --- | Flags to @configure@ command. --- --- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags' --- should be updated. --- IMPORTANT: every time a new flag is added, it should be added to the Eq instance -data ConfigFlags = ConfigFlags { - -- This is the same hack as in 'buildArgs' and 'copyArgs'. - -- TODO: Stop using this eventually when 'UserHooks' gets changed - configArgs :: [String], - - --FIXME: the configPrograms is only here to pass info through to configure - -- 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), -- ^All programs that - -- @cabal@ may run - configProgramPaths :: [(String, FilePath)], -- ^user specified programs paths - configProgramArgs :: [(String, [String])], -- ^user specified programs args - configProgramPathExtra :: NubList FilePath, -- ^Extend the $PATH - configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the - -- compiler, e.g. GHC. - configHcPath :: Flag FilePath, -- ^given compiler location - configHcPkg :: Flag FilePath, -- ^given hc-pkg location - configVanillaLib :: Flag Bool, -- ^Enable vanilla library - configProfLib :: Flag Bool, -- ^Enable profiling in the library - configSharedLib :: Flag Bool, -- ^Build shared library - configStaticLib :: Flag Bool, -- ^Build static library - configDynExe :: Flag Bool, -- ^Enable dynamic linking of the - -- executables. - configFullyStaticExe :: Flag Bool, -- ^Enable fully static linking of the - -- executables. - configProfExe :: Flag Bool, -- ^Enable profiling in the - -- executables. - configProf :: Flag Bool, -- ^Enable profiling in the library - -- and executables. - configProfDetail :: Flag ProfDetailLevel, -- ^Profiling detail level - -- in the library and executables. - configProfLibDetail :: Flag ProfDetailLevel, -- ^Profiling detail level - -- in the library - configConfigureArgs :: [String], -- ^Extra arguments to @configure@ - configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. - configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. - configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix. - configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation - -- paths - configScratchDir :: Flag FilePath, - configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries - configExtraLibDirsStatic :: [FilePath], -- ^ path to search for extra - -- libraries when linking - -- fully static executables - configExtraFrameworkDirs :: [FilePath], -- ^ path to search for extra - -- frameworks (OS X only) - configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files - configIPID :: Flag String, -- ^ explicit IPID to be used - configCID :: Flag ComponentId, -- ^ explicit CID to be used - configDeterministic :: Flag Bool, -- ^ be as deterministic as possible - -- (e.g., invariant over GHC, database, - -- etc). Used by the test suite - - configDistPref :: Flag FilePath, -- ^"dist" prefix - configCabalFilePath :: Flag FilePath, -- ^ Cabal file to use - configVerbosity :: Flag Verbosity, -- ^verbosity level - configUserInstall :: Flag Bool, -- ^The --user\/--global flag - configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use - configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi - configSplitSections :: Flag Bool, -- ^Enable -split-sections with GHC - configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC - configStripExes :: Flag Bool, -- ^Enable executable stripping - configStripLibs :: Flag Bool, -- ^Enable library stripping - configConstraints :: [PackageVersionConstraint], -- ^Additional constraints for - -- dependencies. - configDependencies :: [GivenComponent], - -- ^The packages depended on. - configInstantiateWith :: [(ModuleName, Module)], - -- ^ The requested Backpack instantiation. If empty, either this - -- package does not use Backpack, or we just want to typecheck - -- the indefinite package. - configConfigurationsFlags :: FlagAssignment, - configTests :: Flag Bool, -- ^Enable test suite compilation - configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation - configCoverage :: Flag Bool, -- ^Enable program coverage - configLibCoverage :: Flag Bool, -- ^Enable program coverage (deprecated) - configExactConfiguration :: Flag Bool, - -- ^All direct dependencies and flags are provided on the command line by - -- the user via the '--dependency' and '--flags' options. - configFlagError :: Flag String, - -- ^Halt and show an error message indicating an error in flag assignment - configRelocatable :: Flag Bool, -- ^ Enable relocatable package built - configDebugInfo :: Flag DebugInfoLevel, -- ^ Emit debug info. - configDumpBuildInfo :: Flag DumpBuildInfo, - -- ^ Should we dump available build information on build? - -- Dump build information to disk before attempting to build, - -- tooling can parse these files and use them to compile the - -- source files themselves. - configUseResponseFiles :: Flag Bool, - -- ^ Whether to use response files at all. They're used for such tools - -- as haddock, or ld. - configAllowDependingOnPrivateLibs :: Flag Bool - -- ^ Allow depending on private sublibraries. This is used by external - -- tools (like cabal-install) so they can add multiple-public-libraries - -- compatibility to older ghcs by checking visibility externally. - } - deriving (Generic, Read, Show, Typeable) - -instance Binary ConfigFlags -instance Structured ConfigFlags - --- | More convenient version of 'configPrograms'. Results in an --- 'error' if internal invariant is violated. -configPrograms :: WithCallStack (ConfigFlags -> ProgramDb) -configPrograms = fromMaybe (error "FIXME: remove configPrograms") . fmap getLast' - . getOption' . configPrograms_ - -instance Eq ConfigFlags where - (==) a b = - -- configPrograms skipped: not user specified, has no Eq instance - equal configProgramPaths - && equal configProgramArgs - && equal configProgramPathExtra - && equal configHcFlavor - && equal configHcPath - && equal configHcPkg - && equal configVanillaLib - && equal configProfLib - && equal configSharedLib - && equal configStaticLib - && equal configDynExe - && equal configFullyStaticExe - && equal configProfExe - && equal configProf - && equal configProfDetail - && equal configProfLibDetail - && equal configConfigureArgs - && equal configOptimization - && equal configProgPrefix - && equal configProgSuffix - && equal configInstallDirs - && equal configScratchDir - && equal configExtraLibDirs - && equal configExtraLibDirsStatic - && equal configExtraIncludeDirs - && equal configIPID - && equal configDeterministic - && equal configDistPref - && equal configVerbosity - && equal configUserInstall - && equal configPackageDBs - && equal configGHCiLib - && equal configSplitSections - && equal configSplitObjs - && equal configStripExes - && equal configStripLibs - && equal configConstraints - && equal configDependencies - && equal configConfigurationsFlags - && equal configTests - && equal configBenchmarks - && equal configCoverage - && equal configLibCoverage - && equal configExactConfiguration - && equal configFlagError - && equal configRelocatable - && equal configDebugInfo - && equal configDumpBuildInfo - && equal configUseResponseFiles - where - equal f = on (==) f a b - -configAbsolutePaths :: ConfigFlags -> IO ConfigFlags -configAbsolutePaths f = - (\v -> f { configPackageDBs = v }) - `liftM` traverse (maybe (return Nothing) (liftM Just . absolutePackageDBPath)) - (configPackageDBs f) - -defaultConfigFlags :: ProgramDb -> ConfigFlags -defaultConfigFlags progDb = emptyConfigFlags { - configArgs = [], - configPrograms_ = Option' (Just (Last' progDb)), - configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, - configVanillaLib = Flag True, - configProfLib = NoFlag, - configSharedLib = NoFlag, - configStaticLib = NoFlag, - configDynExe = Flag False, - configFullyStaticExe = Flag False, - configProfExe = NoFlag, - configProf = NoFlag, - configProfDetail = NoFlag, - configProfLibDetail= NoFlag, - configOptimization = Flag NormalOptimisation, - configProgPrefix = Flag (toPathTemplate ""), - configProgSuffix = Flag (toPathTemplate ""), - configDistPref = NoFlag, - configCabalFilePath = NoFlag, - configVerbosity = Flag normal, - configUserInstall = Flag False, --TODO: reverse this -#if defined(mingw32_HOST_OS) - -- See #8062 and GHC #21019. - configGHCiLib = Flag False, -#else - configGHCiLib = NoFlag, -#endif - configSplitSections = Flag False, - configSplitObjs = Flag False, -- takes longer, so turn off by default - configStripExes = NoFlag, - configStripLibs = NoFlag, - configTests = Flag False, - configBenchmarks = Flag False, - configCoverage = Flag False, - configLibCoverage = NoFlag, - configExactConfiguration = Flag False, - configFlagError = NoFlag, - configRelocatable = Flag False, - configDebugInfo = Flag NoDebugInfo, - configDumpBuildInfo = NoFlag, - configUseResponseFiles = NoFlag - } - -configureCommand :: ProgramDb -> CommandUI ConfigFlags -configureCommand progDb = CommandUI - { commandName = "configure" - , commandSynopsis = "Prepare to build the package." - , commandDescription = Just $ \_ -> wrapText $ - "Configure how the package is built by setting " - ++ "package (and other) flags.\n" - ++ "\n" - ++ "The configuration affects several other commands, " - ++ "including build, test, bench, run, repl.\n" - , commandNotes = Just $ \_pname -> programFlagsDescription progDb - , commandUsage = \pname -> - "Usage: " ++ pname ++ " configure [FLAGS]\n" - , commandDefaultFlags = defaultConfigFlags progDb - , commandOptions = \showOrParseArgs -> - configureOptions showOrParseArgs - ++ programDbPaths progDb showOrParseArgs - configProgramPaths (\v fs -> fs { configProgramPaths = v }) - ++ programDbOption progDb showOrParseArgs - configProgramArgs (\v fs -> fs { configProgramArgs = v }) - ++ programDbOptions progDb showOrParseArgs - configProgramArgs (\v fs -> fs { configProgramArgs = v }) - } - --- | Inverse to 'dispModSubstEntry'. -parsecModSubstEntry :: ParsecParser (ModuleName, Module) -parsecModSubstEntry = do - k <- parsec - _ <- P.char '=' - v <- parsec - return (k, v) - --- | Pretty-print a single entry of a module substitution. -dispModSubstEntry :: (ModuleName, Module) -> Disp.Doc -dispModSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v - -configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] -configureOptions showOrParseArgs = - [optionVerbosity configVerbosity - (\v flags -> flags { configVerbosity = v }) - ,optionDistPref - configDistPref (\d flags -> flags { configDistPref = d }) - showOrParseArgs - - ,option [] ["compiler"] "compiler" - configHcFlavor (\v flags -> flags { configHcFlavor = v }) - (choiceOpt [ (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 "" ["cabal-file"] - "use this Cabal file" - configCabalFilePath (\v flags -> flags { configCabalFilePath = v }) - (reqArgFlag "PATH") - - ,option "w" ["with-compiler"] - "give the path to a particular compiler" - configHcPath (\v flags -> flags { configHcPath = v }) - (reqArgFlag "PATH") - - ,option "" ["with-hc-pkg"] - "give the path to the package tool" - configHcPkg (\v flags -> flags { configHcPkg = v }) - (reqArgFlag "PATH") - ] - ++ map liftInstallDirs installDirsOptions - ++ [option "" ["program-prefix"] - "prefix to be applied to installed executables" - configProgPrefix - (\v flags -> flags { configProgPrefix = v }) - (reqPathTemplateArgFlag "PREFIX") - - ,option "" ["program-suffix"] - "suffix to be applied to installed executables" - configProgSuffix (\v flags -> flags { configProgSuffix = v } ) - (reqPathTemplateArgFlag "SUFFIX") - - ,option "" ["library-vanilla"] - "Vanilla libraries" - configVanillaLib (\v flags -> flags { configVanillaLib = v }) - (boolOpt [] []) - - ,option "p" ["library-profiling"] - "Library profiling" - configProfLib (\v flags -> flags { configProfLib = v }) - (boolOpt "p" []) - - ,option "" ["shared"] - "Shared library" - configSharedLib (\v flags -> flags { configSharedLib = v }) - (boolOpt [] []) - - ,option "" ["static"] - "Static library" - configStaticLib (\v flags -> flags { configStaticLib = v }) - (boolOpt [] []) - - ,option "" ["executable-dynamic"] - "Executable dynamic linking" - configDynExe (\v flags -> flags { configDynExe = v }) - (boolOpt [] []) - - ,option "" ["executable-static"] - "Executable fully static linking" - configFullyStaticExe (\v flags -> flags { configFullyStaticExe = v }) - (boolOpt [] []) - - ,option "" ["profiling"] - "Executable and library profiling" - configProf (\v flags -> flags { configProf = v }) - (boolOpt [] []) - - ,option "" ["executable-profiling"] - "Executable profiling (DEPRECATED)" - configProfExe (\v flags -> flags { configProfExe = v }) - (boolOpt [] []) - - ,option "" ["profiling-detail"] - ("Profiling detail level for executable and library (default, " ++ - "none, exported-functions, toplevel-functions, all-functions, late).") - configProfDetail (\v flags -> flags { configProfDetail = v }) - (reqArg' "level" (Flag . flagToProfDetailLevel) - showProfDetailLevelFlag) - - ,option "" ["library-profiling-detail"] - "Profiling detail level for libraries only." - configProfLibDetail (\v flags -> flags { configProfLibDetail = v }) - (reqArg' "level" (Flag . flagToProfDetailLevel) - showProfDetailLevelFlag) - - ,multiOption "optimization" - configOptimization (\v flags -> flags { configOptimization = v }) - [optArg' "n" (Flag . flagToOptimisationLevel) - (\f -> case f of - Flag NoOptimisation -> [] - Flag NormalOptimisation -> [Nothing] - Flag MaximumOptimisation -> [Just "2"] - _ -> []) - "O" ["enable-optimization","enable-optimisation"] - "Build with optimization (n is 0--2, default is 1)", - noArg (Flag NoOptimisation) [] - ["disable-optimization","disable-optimisation"] - "Build without optimization" - ] - - ,multiOption "debug-info" - configDebugInfo (\v flags -> flags { configDebugInfo = v }) - [optArg' "n" (Flag . flagToDebugInfoLevel) - (\f -> case f of - Flag NoDebugInfo -> [] - Flag MinimalDebugInfo -> [Just "1"] - Flag NormalDebugInfo -> [Nothing] - Flag MaximalDebugInfo -> [Just "3"] - _ -> []) - "" ["enable-debug-info"] - "Emit debug info (n is 0--3, default is 0)", - noArg (Flag NoDebugInfo) [] - ["disable-debug-info"] - "Don't emit debug info" - ] - - , multiOption "build-info" - configDumpBuildInfo - (\v flags -> flags { configDumpBuildInfo = v }) - [noArg (Flag DumpBuildInfo) [] - ["enable-build-info"] - "Enable build information generation during project building", - noArg (Flag NoDumpBuildInfo) [] - ["disable-build-info"] - "Disable build information generation during project building" - ] - - ,option "" ["library-for-ghci"] - "compile library for use with GHCi" - configGHCiLib (\v flags -> flags { configGHCiLib = v }) - (boolOpt [] []) - - ,option "" ["split-sections"] - "compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)" - configSplitSections (\v flags -> flags { configSplitSections = v }) - (boolOpt [] []) - - ,option "" ["split-objs"] - "split library into smaller objects to reduce binary sizes (GHC 6.6+)" - configSplitObjs (\v flags -> flags { configSplitObjs = v }) - (boolOpt [] []) - - ,option "" ["executable-stripping"] - "strip executables upon installation to reduce binary sizes" - configStripExes (\v flags -> flags { configStripExes = v }) - (boolOpt [] []) - - ,option "" ["library-stripping"] - "strip libraries upon installation to reduce binary sizes" - configStripLibs (\v flags -> flags { configStripLibs = v }) - (boolOpt [] []) - - ,option "" ["configure-option"] - "Extra option for configure" - configConfigureArgs (\v flags -> flags { configConfigureArgs = v }) - (reqArg' "OPT" (\x -> [x]) id) - - ,option "" ["user-install"] - "doing a per-user installation" - configUserInstall (\v flags -> flags { configUserInstall = v }) - (boolOpt' ([],["user"]) ([], ["global"])) - - ,option "" ["package-db"] - ( "Append the given package database to the list of package" - ++ " databases used (to satisfy dependencies and register into)." - ++ " May be a specific file, 'global' or 'user'. The initial list" - ++ " is ['global'], ['global', 'user'], or ['global', $sandbox]," - ++ " depending on context. Use 'clear' to reset the list to empty." - ++ " See the user guide for details.") - configPackageDBs (\v flags -> flags { configPackageDBs = v }) - (reqArg' "DB" readPackageDbList showPackageDbList) - - ,option "f" ["flags"] - "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." - configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) - (reqArg "FLAGS" - (parsecToReadE (\err -> "Invalid flag assignment: " ++ err) legacyParsecFlagAssignment) - legacyShowFlagAssignment') - - ,option "" ["extra-include-dirs"] - "A list of directories to search for header files" - configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["deterministic"] - "Try to be as deterministic as possible (used by the test suite)" - configDeterministic (\v flags -> flags {configDeterministic = v}) - (boolOpt [] []) - - ,option "" ["ipid"] - "Installed package ID to compile this package as" - configIPID (\v flags -> flags {configIPID = v}) - (reqArgFlag "IPID") - - ,option "" ["cid"] - "Installed component ID to compile this component as" - (fmap prettyShow . configCID) (\v flags -> flags {configCID = fmap mkComponentId v}) - (reqArgFlag "CID") - - ,option "" ["extra-lib-dirs"] - "A list of directories to search for external libraries" - configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-lib-dirs-static"] - "A list of directories to search for external libraries when linking fully static executables" - configExtraLibDirsStatic (\v flags -> flags {configExtraLibDirsStatic = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-framework-dirs"] - "A list of directories to search for external frameworks (OS X only)" - configExtraFrameworkDirs - (\v flags -> flags {configExtraFrameworkDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-prog-path"] - "A list of directories to search for required programs (in addition to the normal search locations)" - configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v}) - (reqArg' "PATH" (\x -> toNubList [x]) fromNubList) - - ,option "" ["constraint"] - "A list of additional constraints on the dependencies." - configConstraints (\v flags -> flags { configConstraints = v}) - (reqArg "DEPENDENCY" - (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec)) - (map prettyShow)) - - ,option "" ["dependency"] - "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" - configDependencies (\v flags -> flags { configDependencies = v}) - (reqArg "NAME[:COMPONENT_NAME]=CID" - (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent)) - (map (\(GivenComponent pn cn cid) -> - prettyShow pn - ++ case cn of LMainLibName -> "" - LSubLibName n -> ":" ++ prettyShow n - ++ "=" ++ prettyShow cid))) - - ,option "" ["instantiate-with"] - "A mapping of signature names to concrete module instantiations." - configInstantiateWith (\v flags -> flags { configInstantiateWith = v }) - (reqArg "NAME=MOD" - (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (:[]) parsecModSubstEntry)) - (map (Disp.renderStyle defaultStyle . dispModSubstEntry))) - - ,option "" ["tests"] - "dependency checking and compilation for test suites listed in the package description file." - configTests (\v flags -> flags { configTests = v }) - (boolOpt [] []) - - ,option "" ["coverage"] - "build package with Haskell Program Coverage. (GHC only)" - configCoverage (\v flags -> flags { configCoverage = v }) - (boolOpt [] []) - - ,option "" ["library-coverage"] - "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" - configLibCoverage (\v flags -> flags { configLibCoverage = v }) - (boolOpt [] []) - - ,option "" ["exact-configuration"] - "All direct dependencies and flags are provided on the command line." - configExactConfiguration - (\v flags -> flags { configExactConfiguration = v }) - trueArg - - ,option "" ["benchmarks"] - "dependency checking and compilation for benchmarks listed in the package description file." - configBenchmarks (\v flags -> flags { configBenchmarks = v }) - (boolOpt [] []) - - ,option "" ["relocatable"] - "building a package that is relocatable. (GHC only)" - configRelocatable (\v flags -> flags { configRelocatable = v}) - (boolOpt [] []) - - ,option "" ["response-files"] - "enable workaround for old versions of programs like \"ar\" that do not support @file arguments" - configUseResponseFiles - (\v flags -> flags { configUseResponseFiles = v }) - (boolOpt' ([], ["disable-response-files"]) ([], [])) - - ,option "" ["allow-depending-on-private-libs"] - ( "Allow depending on private libraries. " - ++ "If set, the library visibility check MUST be done externally." ) - configAllowDependingOnPrivateLibs - (\v flags -> flags { configAllowDependingOnPrivateLibs = v }) - trueArg - ] - where - liftInstallDirs = - liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) - - reqPathTemplateArgFlag title _sf _lf d get set = - reqArgFlag title _sf _lf d - (fmap fromPathTemplate . get) (set . fmap toPathTemplate) - -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 other) - -showPackageDbList :: [Maybe PackageDB] -> [String] -showPackageDbList = map showPackageDb - --- | Show a PackageDB stack entry --- --- @since 3.7.0.0 -showPackageDb :: Maybe PackageDB -> String -showPackageDb Nothing = "clear" -showPackageDb (Just GlobalPackageDB) = "global" -showPackageDb (Just UserPackageDB) = "user" -showPackageDb (Just (SpecificPackageDB db)) = db - -showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String] -showProfDetailLevelFlag NoFlag = [] -showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] - -parsecGivenComponent :: ParsecParser GivenComponent -parsecGivenComponent = do - pn <- parsec - ln <- P.option LMainLibName $ do - _ <- P.char ':' - ucn <- parsec - return $ if unUnqualComponentName ucn == unPackageName pn - then LMainLibName - else LSubLibName ucn - _ <- P.char '=' - cid <- parsec - return $ GivenComponent pn ln cid - -installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] -installDirsOptions = - [ option "" ["prefix"] - "bake this prefix in preparation of installation" - prefix (\v flags -> flags { prefix = v }) - installDirArg - - , option "" ["bindir"] - "installation directory for executables" - bindir (\v flags -> flags { bindir = v }) - installDirArg - - , option "" ["libdir"] - "installation directory for libraries" - libdir (\v flags -> flags { libdir = v }) - installDirArg - - , option "" ["libsubdir"] - "subdirectory of libdir in which libs are installed" - libsubdir (\v flags -> flags { libsubdir = v }) - installDirArg - - , option "" ["dynlibdir"] - "installation directory for dynamic libraries" - dynlibdir (\v flags -> flags { dynlibdir = v }) - installDirArg - - , option "" ["libexecdir"] - "installation directory for program executables" - libexecdir (\v flags -> flags { libexecdir = v }) - installDirArg - - , option "" ["libexecsubdir"] - "subdirectory of libexecdir in which private executables are installed" - libexecsubdir (\v flags -> flags { libexecsubdir = v }) - installDirArg - - , option "" ["datadir"] - "installation directory for read-only data" - datadir (\v flags -> flags { datadir = v }) - installDirArg - - , option "" ["datasubdir"] - "subdirectory of datadir in which data files are installed" - datasubdir (\v flags -> flags { datasubdir = v }) - installDirArg - - , option "" ["docdir"] - "installation directory for documentation" - docdir (\v flags -> flags { docdir = v }) - installDirArg - - , option "" ["htmldir"] - "installation directory for HTML documentation" - htmldir (\v flags -> flags { htmldir = v }) - installDirArg - - , option "" ["haddockdir"] - "installation directory for haddock interfaces" - haddockdir (\v flags -> flags { haddockdir = v }) - installDirArg - - , option "" ["sysconfdir"] - "installation directory for configuration files" - sysconfdir (\v flags -> flags { sysconfdir = v }) - installDirArg - ] - where - installDirArg _sf _lf d get set = - reqArgFlag "DIR" _sf _lf d - (fmap fromPathTemplate . get) (set . fmap toPathTemplate) - -emptyConfigFlags :: ConfigFlags -emptyConfigFlags = mempty - -instance Monoid ConfigFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ConfigFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Copy flags --- ------------------------------------------------------------ - --- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) -data CopyFlags = CopyFlags { - copyDest :: Flag CopyDest, - copyDistPref :: Flag FilePath, - copyVerbosity :: Flag Verbosity, - -- This is the same hack as in 'buildArgs'. But I (ezyang) don't - -- think it's a hack, it's the right way to make hooks more robust - -- TODO: Stop using this eventually when 'UserHooks' gets changed - copyArgs :: [String], - copyCabalFilePath :: Flag FilePath - } - deriving (Show, Generic) - -defaultCopyFlags :: CopyFlags -defaultCopyFlags = CopyFlags { - copyDest = Flag NoCopyDest, - copyDistPref = NoFlag, - copyVerbosity = Flag normal, - copyArgs = [], - copyCabalFilePath = mempty - } - -copyCommand :: CommandUI CopyFlags -copyCommand = CommandUI - { commandName = "copy" - , commandSynopsis = "Copy the files of all/specific components to install locations." - , commandDescription = Just $ \_ -> wrapText $ - "Components encompass executables and libraries. " - ++ "Does not call register, and allows a prefix at install time. " - ++ "Without the --destdir flag, configure determines location.\n" - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " copy " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " copy foo " - ++ " A component (i.e. lib, exe, test suite)" - , commandUsage = usageAlternatives "copy" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultCopyFlags - , commandOptions = \showOrParseArgs -> case showOrParseArgs of - ShowArgs -> filter ((`notElem` ["target-package-db"]) - . optionName) $ copyOptions ShowArgs - ParseArgs -> copyOptions ParseArgs -} - -copyOptions :: ShowOrParseArgs -> [OptionField CopyFlags] -copyOptions showOrParseArgs = - [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v }) - - ,optionDistPref - copyDistPref (\d flags -> flags { copyDistPref = d }) - showOrParseArgs - - ,option "" ["destdir"] - "directory to copy files to, prepended to installation directories" - copyDest (\v flags -> case copyDest flags of - Flag (CopyToDb _) -> error "Use either 'destdir' or 'target-package-db'." - _ -> flags { copyDest = v }) - (reqArg "DIR" (succeedReadE (Flag . CopyTo)) - (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) - - ,option "" ["target-package-db"] - "package database to copy files into. Required when using ${pkgroot} prefix." - copyDest (\v flags -> case copyDest flags of - NoFlag -> flags { copyDest = v } - Flag NoCopyDest -> flags { copyDest = v } - _ -> error "Use either 'destdir' or 'target-package-db'.") - (reqArg "DATABASE" (succeedReadE (Flag . CopyToDb)) - (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])) - ] - -emptyCopyFlags :: CopyFlags -emptyCopyFlags = mempty - -instance Monoid CopyFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup CopyFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Install flags --- ------------------------------------------------------------ - --- | Flags to @install@: (package db, verbosity) -data InstallFlags = InstallFlags { - installPackageDB :: Flag PackageDB, - installDest :: Flag CopyDest, - installDistPref :: Flag FilePath, - installUseWrapper :: Flag Bool, - installInPlace :: Flag Bool, - installVerbosity :: Flag Verbosity, - -- this is only here, because we can not - -- change the hooks API. - installCabalFilePath :: Flag FilePath - } - deriving (Show, Generic) - -defaultInstallFlags :: InstallFlags -defaultInstallFlags = InstallFlags { - installPackageDB = NoFlag, - installDest = Flag NoCopyDest, - installDistPref = NoFlag, - installUseWrapper = Flag False, - installInPlace = Flag False, - installVerbosity = Flag normal, - installCabalFilePath = mempty - } - -installCommand :: CommandUI InstallFlags -installCommand = CommandUI - { commandName = "install" - , commandSynopsis = - "Copy the files into the install locations. Run register." - , commandDescription = Just $ \_ -> wrapText $ - "Unlike the copy command, install calls the register command." - ++ "If you want to install into a location that is not what was" - ++ "specified in the configure step, use the copy command.\n" - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " install [FLAGS]\n" - , commandDefaultFlags = defaultInstallFlags - , commandOptions = \showOrParseArgs -> case showOrParseArgs of - ShowArgs -> filter ((`notElem` ["target-package-db"]) - . optionName) $ installOptions ShowArgs - ParseArgs -> installOptions ParseArgs - } - -installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] -installOptions showOrParseArgs = - [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v }) - ,optionDistPref - installDistPref (\d flags -> flags { installDistPref = d }) - showOrParseArgs - - ,option "" ["inplace"] - "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" - installInPlace (\v flags -> flags { installInPlace = v }) - trueArg - - ,option "" ["shell-wrappers"] - "using shell script wrappers around executables" - installUseWrapper (\v flags -> flags { installUseWrapper = v }) - (boolOpt [] []) - - ,option "" ["package-db"] "" - installPackageDB (\v flags -> flags { installPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "upon configuration register this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default) upon configuration register this package in the system-wide package database")]) - ,option "" ["target-package-db"] - "package database to install into. Required when using ${pkgroot} prefix." - installDest (\v flags -> flags { installDest = v }) - (reqArg "DATABASE" (succeedReadE (Flag . CopyToDb)) - (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])) - ] - -emptyInstallFlags :: InstallFlags -emptyInstallFlags = mempty - -instance Monoid InstallFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup InstallFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * SDist flags --- ------------------------------------------------------------ - --- | Flags to @sdist@: (snapshot, verbosity) -data SDistFlags = SDistFlags { - sDistSnapshot :: Flag Bool, - sDistDirectory :: Flag FilePath, - sDistDistPref :: Flag FilePath, - sDistListSources :: Flag FilePath, - sDistVerbosity :: Flag Verbosity - } - deriving (Show, Generic, Typeable) - -defaultSDistFlags :: SDistFlags -defaultSDistFlags = SDistFlags { - sDistSnapshot = Flag False, - sDistDirectory = mempty, - sDistDistPref = NoFlag, - sDistListSources = mempty, - sDistVerbosity = Flag normal - } - -sdistCommand :: CommandUI SDistFlags -sdistCommand = CommandUI - { commandName = "sdist" - , commandSynopsis = - "Generate a source distribution file (.tar.gz)." - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " sdist [FLAGS]\n" - , commandDefaultFlags = defaultSDistFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v }) - ,optionDistPref - sDistDistPref (\d flags -> flags { sDistDistPref = d }) - showOrParseArgs - - ,option "" ["list-sources"] - "Just write a list of the package's sources to a file" - sDistListSources (\v flags -> flags { sDistListSources = v }) - (reqArgFlag "FILE") - - ,option "" ["snapshot"] - "Produce a snapshot source distribution" - sDistSnapshot (\v flags -> flags { sDistSnapshot = v }) - trueArg - - ,option "" ["output-directory"] - ("Generate a source distribution in the given directory, " - ++ "without creating a tarball") - sDistDirectory (\v flags -> flags { sDistDirectory = v }) - (reqArgFlag "DIR") - ] - } - -emptySDistFlags :: SDistFlags -emptySDistFlags = mempty - -instance Monoid SDistFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup SDistFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Register flags --- ------------------------------------------------------------ - --- | Flags to @register@ and @unregister@: (user package, gen-script, --- in-place, verbosity) -data RegisterFlags = RegisterFlags { - regPackageDB :: Flag PackageDB, - regGenScript :: Flag Bool, - regGenPkgConf :: Flag (Maybe FilePath), - regInPlace :: Flag Bool, - regDistPref :: Flag FilePath, - regPrintId :: Flag Bool, - regVerbosity :: Flag Verbosity, - -- Same as in 'buildArgs' and 'copyArgs' - regArgs :: [String], - regCabalFilePath :: Flag FilePath - } - deriving (Show, Generic, Typeable) - -defaultRegisterFlags :: RegisterFlags -defaultRegisterFlags = RegisterFlags { - regPackageDB = NoFlag, - regGenScript = Flag False, - regGenPkgConf = NoFlag, - regInPlace = Flag False, - regDistPref = NoFlag, - regPrintId = Flag False, - regArgs = [], - regCabalFilePath = mempty, - regVerbosity = Flag normal - } - -registerCommand :: CommandUI RegisterFlags -registerCommand = CommandUI - { commandName = "register" - , commandSynopsis = - "Register this package with the compiler." - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " register [FLAGS]\n" - , commandDefaultFlags = defaultRegisterFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref - regDistPref (\d flags -> flags { regDistPref = d }) - 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 flagToList) - - ,option "" ["print-ipid"] - "print the installed package ID calculated for this package" - regPrintId (\v flags -> flags { regPrintId = v }) - trueArg - ] - } - -unregisterCommand :: CommandUI RegisterFlags -unregisterCommand = CommandUI - { commandName = "unregister" - , commandSynopsis = - "Unregister this package with the compiler." - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " unregister [FLAGS]\n" - , commandDefaultFlags = defaultRegisterFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref - regDistPref (\d flags -> flags { regDistPref = d }) - 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 - ] - } - -emptyRegisterFlags :: RegisterFlags -emptyRegisterFlags = mempty - -instance Monoid RegisterFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup RegisterFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * HsColour flags --- ------------------------------------------------------------ - -data HscolourFlags = HscolourFlags { - hscolourCSS :: Flag FilePath, - hscolourExecutables :: Flag Bool, - hscolourTestSuites :: Flag Bool, - hscolourBenchmarks :: Flag Bool, - hscolourForeignLibs :: Flag Bool, - hscolourDistPref :: Flag FilePath, - hscolourVerbosity :: Flag Verbosity, - hscolourCabalFilePath :: Flag FilePath - } - deriving (Show, Generic, Typeable) - -emptyHscolourFlags :: HscolourFlags -emptyHscolourFlags = mempty - -defaultHscolourFlags :: HscolourFlags -defaultHscolourFlags = HscolourFlags { - hscolourCSS = NoFlag, - hscolourExecutables = Flag False, - hscolourTestSuites = Flag False, - hscolourBenchmarks = Flag False, - hscolourDistPref = NoFlag, - hscolourForeignLibs = Flag False, - hscolourVerbosity = Flag normal, - hscolourCabalFilePath = mempty - } - -instance Monoid HscolourFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup HscolourFlags where - (<>) = gmappend - -hscolourCommand :: CommandUI HscolourFlags -hscolourCommand = CommandUI - { commandName = "hscolour" - , commandSynopsis = - "Generate HsColour colourised code, in HTML format." - , commandDescription = Just (\_ -> "Requires the hscolour program.\n") - , commandNotes = Just $ \_ -> - "Deprecated in favour of 'cabal haddock --hyperlink-source'." - , commandUsage = \pname -> - "Usage: " ++ pname ++ " hscolour [FLAGS]\n" - , commandDefaultFlags = defaultHscolourFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity hscolourVerbosity - (\v flags -> flags { hscolourVerbosity = v }) - ,optionDistPref - hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) - showOrParseArgs - - ,option "" ["executables"] - "Run hscolour for Executables targets" - hscolourExecutables (\v flags -> flags { hscolourExecutables = v }) - trueArg - - ,option "" ["tests"] - "Run hscolour for Test Suite targets" - hscolourTestSuites (\v flags -> flags { hscolourTestSuites = v }) - trueArg - - ,option "" ["benchmarks"] - "Run hscolour for Benchmark targets" - hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v }) - trueArg - - ,option "" ["foreign-libraries"] - "Run hscolour for Foreign Library targets" - hscolourForeignLibs (\v flags -> flags { hscolourForeignLibs = v }) - trueArg - - ,option "" ["all"] - "Run hscolour for all targets" - (\f -> allFlags [ hscolourExecutables f - , hscolourTestSuites f - , hscolourBenchmarks f - , hscolourForeignLibs f - ]) - (\v flags -> flags { hscolourExecutables = v - , hscolourTestSuites = v - , hscolourBenchmarks = v - , hscolourForeignLibs = v - }) - trueArg - - ,option "" ["css"] - "Use a cascading style sheet" - hscolourCSS (\v flags -> flags { hscolourCSS = v }) - (reqArgFlag "PATH") - ] - } - --- ------------------------------------------------------------ --- * Haddock flags --- ------------------------------------------------------------ - - --- | When we build haddock documentation, there are two cases: --- --- 1. We build haddocks only for the current development version, --- intended for local use and not for distribution. In this case, --- we store the generated documentation in @/doc/html/@. --- --- 2. We build haddocks for intended for uploading them to hackage. --- In this case, we need to follow the layout that hackage expects --- from documentation tarballs, and we might also want to use different --- flags than for development builds, so in this case we store the generated --- documentation in @/doc/html/-docs@. -data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic, Typeable) - -instance Binary HaddockTarget -instance Structured HaddockTarget - -instance Pretty HaddockTarget where - pretty ForHackage = Disp.text "for-hackage" - pretty ForDevelopment = Disp.text "for-development" - -instance Parsec HaddockTarget where - parsec = P.choice [ P.try $ P.string "for-hackage" >> return ForHackage - , P.string "for-development" >> return ForDevelopment] - -data HaddockFlags = HaddockFlags { - haddockProgramPaths :: [(String, FilePath)], - haddockProgramArgs :: [(String, [String])], - haddockHoogle :: Flag Bool, - haddockHtml :: Flag Bool, - haddockHtmlLocation :: Flag String, - haddockForHackage :: Flag HaddockTarget, - haddockExecutables :: Flag Bool, - haddockTestSuites :: Flag Bool, - haddockBenchmarks :: Flag Bool, - haddockForeignLibs :: Flag Bool, - haddockInternal :: Flag Bool, - haddockCss :: Flag FilePath, - haddockLinkedSource :: Flag Bool, - haddockQuickJump :: Flag Bool, - haddockHscolourCss :: Flag FilePath, - haddockContents :: Flag PathTemplate, - haddockIndex :: Flag PathTemplate, - haddockDistPref :: Flag FilePath, - haddockKeepTempFiles:: Flag Bool, - haddockVerbosity :: Flag Verbosity, - haddockCabalFilePath :: Flag FilePath, - haddockBaseUrl :: Flag String, - haddockLib :: Flag String, - haddockArgs :: [String] - } - deriving (Show, Generic, Typeable) - -defaultHaddockFlags :: HaddockFlags -defaultHaddockFlags = HaddockFlags { - haddockProgramPaths = mempty, - haddockProgramArgs = [], - haddockHoogle = Flag False, - haddockHtml = Flag False, - haddockHtmlLocation = NoFlag, - haddockForHackage = NoFlag, - haddockExecutables = Flag False, - haddockTestSuites = Flag False, - haddockBenchmarks = Flag False, - haddockForeignLibs = Flag False, - haddockInternal = Flag False, - haddockCss = NoFlag, - haddockLinkedSource = Flag False, - haddockQuickJump = Flag False, - haddockHscolourCss = NoFlag, - haddockContents = NoFlag, - haddockDistPref = NoFlag, - haddockKeepTempFiles= Flag False, - haddockVerbosity = Flag normal, - haddockCabalFilePath = mempty, - haddockIndex = NoFlag, - haddockBaseUrl = NoFlag, - haddockLib = NoFlag, - haddockArgs = mempty - } - -haddockCommand :: CommandUI HaddockFlags -haddockCommand = CommandUI - { commandName = "haddock" - , commandSynopsis = "Generate Haddock HTML documentation." - , commandDescription = Just $ \_ -> - "Requires the program haddock, version 2.x.\n" - , commandNotes = Nothing - , commandUsage = usageAlternatives "haddock" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultHaddockFlags - , commandOptions = \showOrParseArgs -> - haddockOptions showOrParseArgs - ++ programDbPaths progDb ParseArgs - haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v}) - ++ programDbOption progDb showOrParseArgs - haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v }) - ++ programDbOptions progDb ParseArgs - haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v}) - } - where - progDb = addKnownProgram haddockProgram - $ addKnownProgram ghcProgram - $ emptyProgramDb - -haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] -haddockOptions showOrParseArgs = - [optionVerbosity haddockVerbosity - (\v flags -> flags { haddockVerbosity = v }) - ,optionDistPref - haddockDistPref (\d flags -> flags { haddockDistPref = d }) - showOrParseArgs - - ,option "" ["keep-temp-files"] - "Keep temporary files" - haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b }) - trueArg - - ,option "" ["hoogle"] - "Generate a hoogle database" - haddockHoogle (\v flags -> flags { haddockHoogle = v }) - trueArg - - ,option "" ["html"] - "Generate HTML documentation (the default)" - haddockHtml (\v flags -> flags { haddockHtml = v }) - trueArg - - ,option "" ["html-location"] - "Location of HTML documentation for pre-requisite packages" - haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v }) - (reqArgFlag "URL") - - ,option "" ["for-hackage"] - "Collection of flags to generate documentation suitable for upload to hackage" - haddockForHackage (\v flags -> flags { haddockForHackage = v }) - (noArg (Flag ForHackage)) - - ,option "" ["executables"] - "Run haddock for Executables targets" - haddockExecutables (\v flags -> flags { haddockExecutables = v }) - trueArg - - ,option "" ["tests"] - "Run haddock for Test Suite targets" - haddockTestSuites (\v flags -> flags { haddockTestSuites = v }) - trueArg - - ,option "" ["benchmarks"] - "Run haddock for Benchmark targets" - haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v }) - trueArg - - ,option "" ["foreign-libraries"] - "Run haddock for Foreign Library targets" - haddockForeignLibs (\v flags -> flags { haddockForeignLibs = v }) - trueArg - - ,option "" ["all"] - "Run haddock for all targets" - (\f -> allFlags [ haddockExecutables f - , haddockTestSuites f - , haddockBenchmarks f - , haddockForeignLibs f - ]) - (\v flags -> flags { haddockExecutables = v - , haddockTestSuites = v - , haddockBenchmarks = v - , haddockForeignLibs = v - }) - trueArg - - ,option "" ["internal"] - "Run haddock for internal modules and include all symbols" - haddockInternal (\v flags -> flags { haddockInternal = v }) - trueArg - - ,option "" ["css"] - "Use PATH as the haddock stylesheet" - haddockCss (\v flags -> flags { haddockCss = v }) - (reqArgFlag "PATH") - - ,option "" ["hyperlink-source","hyperlink-sources","hyperlinked-source"] - "Hyperlink the documentation to the source code" - haddockLinkedSource (\v flags -> flags { haddockLinkedSource = v }) - trueArg - - ,option "" ["quickjump"] - "Generate an index for interactive documentation navigation" - haddockQuickJump (\v flags -> flags { haddockQuickJump = v }) - trueArg - - ,option "" ["hscolour-css"] - "Use PATH as the HsColour stylesheet" - haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v }) - (reqArgFlag "PATH") - - ,option "" ["contents-location"] - "Bake URL in as the location for the contents page" - haddockContents (\v flags -> flags { haddockContents = v }) - (reqArg' "URL" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - - ,option "" ["index-location"] - "Use a separately-generated HTML index" - haddockIndex (\v flags -> flags { haddockIndex = v}) - (reqArg' "URL" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - - ,option "" ["base-url"] - "Base URL for static files." - haddockBaseUrl (\v flags -> flags { haddockBaseUrl = v}) - (reqArgFlag "URL") - - ,option "" ["lib"] - "location of Haddocks static / auxiliary files" - haddockLib (\v flags -> flags { haddockLib = v}) - (reqArgFlag "DIR") - ] - -emptyHaddockFlags :: HaddockFlags -emptyHaddockFlags = mempty - -instance Monoid HaddockFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup HaddockFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * HaddocksFlags flags --- ------------------------------------------------------------ - --- | Governs whether modules from a given interface should be visible or --- hidden in the Haddock generated content page. We don't expose this --- functionality to the user, but simply use 'Visible' for only local packages. --- Visibility of modules is available since @haddock-2.26.1@. --- -data Visibility = Visible | Hidden - deriving (Eq, Show) - -data HaddockProjectFlags = HaddockProjectFlags { - 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` - -- * `--gen-index` - -- * `--gen-contents` - -- * `--hyperlinked-source` - haddockProjectLocal :: Flag Bool, - -- ^ a shortcut option which builds self contained directory which contains - -- all the documentation, it implies: - -- * `--quickjump` - -- * `--gen-index` - -- * `--gen-contents` - -- * `--hyperlinked-source` - -- - -- And it will also pass `--base-url` option to `haddock`. - - -- options passed to @haddock@ via 'createHaddockIndex' - haddockProjectDir :: Flag String, - -- ^ output directory of combined haddocks, the default is './haddocks' - haddockProjectPrologue :: Flag String, - haddockProjectGenIndex :: Flag Bool, - haddockProjectGenContents :: Flag Bool, - haddockProjectInterfaces :: Flag [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)], - -- ^ 'haddocksInterfaces' is inferred by the 'haddocksAction'; currently not - -- exposed to the user. - - -- options passed to @haddock@ via 'HaddockFlags' when building - -- documentation - - haddockProjectProgramPaths :: [(String, FilePath)], - haddockProjectProgramArgs :: [(String, [String])], - haddockProjectHoogle :: Flag Bool, - -- haddockHtml is not supported - haddockProjectHtmlLocation :: Flag String, - -- haddockForHackage is not supported - haddockProjectExecutables :: Flag Bool, - haddockProjectTestSuites :: Flag Bool, - haddockProjectBenchmarks :: Flag Bool, - haddockProjectForeignLibs :: Flag Bool, - haddockProjectInternal :: Flag Bool, - haddockProjectCss :: Flag FilePath, - haddockProjectLinkedSource :: Flag Bool, - haddockProjectQuickJump :: Flag Bool, - haddockProjectHscolourCss :: Flag FilePath, - -- 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 - haddockProjectLib :: Flag String - } - deriving (Show, Generic, Typeable) - -defaultHaddockProjectFlags :: HaddockProjectFlags -defaultHaddockProjectFlags = HaddockProjectFlags { - haddockProjectHackage = Flag False, - haddockProjectLocal = Flag False, - haddockProjectDir = Flag "./haddocks", - haddockProjectPrologue = NoFlag, - haddockProjectGenIndex = Flag False, - haddockProjectGenContents = Flag False, - haddockProjectTestSuites = Flag False, - haddockProjectProgramPaths = mempty, - haddockProjectProgramArgs = mempty, - haddockProjectHoogle = Flag False, - haddockProjectHtmlLocation = NoFlag, - haddockProjectExecutables = Flag False, - haddockProjectBenchmarks = Flag False, - haddockProjectForeignLibs = Flag False, - haddockProjectInternal = Flag False, - haddockProjectCss = NoFlag, - haddockProjectLinkedSource = Flag False, - haddockProjectQuickJump = Flag False, - haddockProjectHscolourCss = NoFlag, - haddockProjectKeepTempFiles= Flag False, - haddockProjectVerbosity = Flag normal, - haddockProjectLib = NoFlag, - haddockProjectInterfaces = NoFlag - } - -haddockProjectCommand :: CommandUI HaddockProjectFlags -haddockProjectCommand = CommandUI - { commandName = "v2-haddock-project" - , commandSynopsis = "Generate Haddocks HTML documentation for the cabal project." - , commandDescription = Just $ \_ -> - "Require the programm haddock, version 2.26.\n" - , commandNotes = Nothing - , commandUsage = usageAlternatives "haddocks" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultHaddockProjectFlags - , commandOptions = \showOrParseArgs -> - haddockProjectOptions showOrParseArgs - ++ programDbPaths progDb ParseArgs - haddockProjectProgramPaths (\v flags -> flags { haddockProjectProgramPaths = v}) - ++ programDbOption progDb showOrParseArgs - haddockProjectProgramArgs (\v fs -> fs { haddockProjectProgramArgs = v }) - ++ programDbOptions progDb ParseArgs - haddockProjectProgramArgs (\v flags -> flags { haddockProjectProgramArgs = v}) - } - where - progDb = addKnownProgram haddockProgram - $ addKnownProgram ghcProgram - $ emptyProgramDb - -haddockProjectOptions :: ShowOrParseArgs -> [OptionField HaddockProjectFlags] -haddockProjectOptions _showOrParseArgs = - [option "" ["hackage"] - (concat ["A short-cut option to build documentation linked to hackage; " - ,"it implies --quickjump, --gen-index, --gen-contents, " - ,"--hyperlinked-source and --html-location" - ]) - haddockProjectHackage (\v flags -> flags { haddockProjectHackage = v }) - trueArg - - ,option "" ["local"] - (concat ["A short-cut option to build self contained documentation; " - ,"it implies --quickjump, --gen-index, --gen-contents " - ,"and --hyperlinked-source." - ]) - haddockProjectLocal (\v flags -> flags { haddockProjectLocal = 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 "" ["gen-index"] - "Generate index" - haddockProjectGenIndex (\v flags -> flags { haddockProjectGenIndex = v}) - trueArg - - ,option "" ["gen-contents"] - "Generate contents" - haddockProjectGenContents (\v flags -> flags { haddockProjectGenContents = v}) - trueArg - - ,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 "" ["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 "" ["hyperlink-source","hyperlink-sources","hyperlinked-source"] - "Hyperlink the documentation to the source code" - haddockProjectLinkedSource (\v flags -> flags { haddockProjectLinkedSource = v }) - trueArg - - ,option "" ["quickjump"] - "Generate an index for interactive documentation navigation" - haddockProjectQuickJump (\v flags -> flags { haddockProjectQuickJump = v }) - trueArg - - ,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 "" ["lib"] - "location of Haddocks static / auxiliary files" - haddockProjectLib (\v flags -> flags { haddockProjectLib = v}) - (reqArgFlag "DIR") - ] - - -emptyHaddockProjectFlags :: HaddockProjectFlags -emptyHaddockProjectFlags = mempty - -instance Monoid HaddockProjectFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup HaddockProjectFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Clean flags --- ------------------------------------------------------------ - -data CleanFlags = CleanFlags { - cleanSaveConf :: Flag Bool, - cleanDistPref :: Flag FilePath, - cleanVerbosity :: Flag Verbosity, - cleanCabalFilePath :: Flag FilePath - } - deriving (Show, Generic, Typeable) - -defaultCleanFlags :: CleanFlags -defaultCleanFlags = CleanFlags { - cleanSaveConf = Flag False, - cleanDistPref = NoFlag, - cleanVerbosity = Flag normal, - cleanCabalFilePath = mempty - } - -cleanCommand :: CommandUI CleanFlags -cleanCommand = CommandUI - { commandName = "clean" - , commandSynopsis = "Clean up after a build." - , commandDescription = Just $ \_ -> - "Removes .hi, .o, preprocessed sources, etc.\n" - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " clean [FLAGS]\n" - , commandDefaultFlags = defaultCleanFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) - ,optionDistPref - cleanDistPref (\d flags -> flags { cleanDistPref = d }) - showOrParseArgs - - ,option "s" ["save-configure"] - "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." - cleanSaveConf (\v flags -> flags { cleanSaveConf = v }) - trueArg - ] - } - -emptyCleanFlags :: CleanFlags -emptyCleanFlags = mempty - -instance Monoid CleanFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup CleanFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Build flags --- ------------------------------------------------------------ - -data BuildFlags = BuildFlags { - buildProgramPaths :: [(String, FilePath)], - buildProgramArgs :: [(String, [String])], - buildDistPref :: Flag FilePath, - buildVerbosity :: Flag Verbosity, - buildNumJobs :: Flag (Maybe Int), - -- TODO: this one should not be here, it's just that the silly - -- UserHooks stop us from passing extra info in other ways - buildArgs :: [String], - buildCabalFilePath :: Flag FilePath - } - deriving (Read, Show, Generic, Typeable) - -defaultBuildFlags :: BuildFlags -defaultBuildFlags = BuildFlags { - buildProgramPaths = mempty, - buildProgramArgs = [], - buildDistPref = mempty, - buildVerbosity = Flag normal, - buildNumJobs = mempty, - buildArgs = [], - buildCabalFilePath = mempty - } - -buildCommand :: ProgramDb -> CommandUI BuildFlags -buildCommand progDb = CommandUI - { commandName = "build" - , commandSynopsis = "Compile all/specific components." - , commandDescription = Just $ \_ -> wrapText $ - "Components encompass executables, tests, and benchmarks.\n" - ++ "\n" - ++ "Affected by configuration options, see `configure`.\n" - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " build " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " build foo " - ++ " A component (i.e. lib, exe, test suite)\n\n" - ++ programFlagsDescription progDb ---TODO: re-enable once we have support for module/file targets --- ++ " " ++ pname ++ " build Foo.Bar " --- ++ " A module\n" --- ++ " " ++ pname ++ " build Foo/Bar.hs" --- ++ " A file\n\n" --- ++ "If a target is ambiguous it can be qualified with the component " --- ++ "name, e.g.\n" --- ++ " " ++ pname ++ " build foo:Foo.Bar\n" --- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n" - , commandUsage = usageAlternatives "build" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultBuildFlags - , commandOptions = \showOrParseArgs -> - [ optionVerbosity - buildVerbosity (\v flags -> flags { buildVerbosity = v }) - - , optionDistPref - buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs - ] - ++ buildOptions progDb showOrParseArgs - } - -buildOptions :: ProgramDb -> ShowOrParseArgs - -> [OptionField BuildFlags] -buildOptions progDb showOrParseArgs = - [ optionNumJobs - buildNumJobs (\v flags -> flags { buildNumJobs = v }) - ] - - ++ programDbPaths progDb showOrParseArgs - buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) - - ++ programDbOption progDb showOrParseArgs - buildProgramArgs (\v fs -> fs { buildProgramArgs = v }) - - ++ programDbOptions progDb showOrParseArgs - buildProgramArgs (\v flags -> flags { buildProgramArgs = v}) - -emptyBuildFlags :: BuildFlags -emptyBuildFlags = mempty - -instance Monoid BuildFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup BuildFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * REPL Flags --- ------------------------------------------------------------ - -data ReplOptions = ReplOptions { - replOptionsFlags :: [String], - replOptionsNoLoad :: Flag Bool - } - deriving (Show, Generic, Typeable) - -instance Binary ReplOptions -instance Structured ReplOptions - - -instance Monoid ReplOptions where - mempty = ReplOptions mempty (Flag False) - mappend = (<>) - -instance Semigroup ReplOptions where - (<>) = gmappend - -data ReplFlags = ReplFlags { - replProgramPaths :: [(String, FilePath)], - replProgramArgs :: [(String, [String])], - replDistPref :: Flag FilePath, - replVerbosity :: Flag Verbosity, - replReload :: Flag Bool, - replReplOptions :: ReplOptions - } - deriving (Show, Generic, Typeable) - -defaultReplFlags :: ReplFlags -defaultReplFlags = ReplFlags { - replProgramPaths = mempty, - replProgramArgs = [], - replDistPref = NoFlag, - replVerbosity = Flag normal, - replReload = Flag False, - replReplOptions = mempty - } - -instance Monoid ReplFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ReplFlags where - (<>) = gmappend - -replCommand :: ProgramDb -> CommandUI ReplFlags -replCommand progDb = CommandUI - { commandName = "repl" - , commandSynopsis = - "Open an interpreter session for the given component." - , commandDescription = Just $ \pname -> wrapText $ - "If the current directory contains no package, ignores COMPONENT " - ++ "parameters and opens an interactive interpreter session; if a " - ++ "sandbox is present, its package database will be used.\n" - ++ "\n" - ++ "Otherwise, (re)configures with the given or default flags, and " - ++ "loads the interpreter with the relevant modules. For executables, " - ++ "tests and benchmarks, loads the main module (and its " - ++ "dependencies); for libraries all exposed/other modules.\n" - ++ "\n" - ++ "The default component is the library itself, or the executable " - ++ "if that is the only component.\n" - ++ "\n" - ++ "Support for loading specific modules is planned but not " - ++ "implemented yet. For certain scenarios, `" ++ pname - ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will " - ++ "not (re)configure and you will have to specify the location of " - ++ "other modules, if required.\n" - - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " repl " - ++ " The first component in the package\n" - ++ " " ++ pname ++ " repl foo " - ++ " A named component (i.e. lib, exe, test suite)\n" - ++ " " ++ pname ++ " repl --repl-options=\"-lstdc++\"" - ++ " Specifying flags for interpreter\n" ---TODO: re-enable once we have support for module/file targets --- ++ " " ++ pname ++ " repl Foo.Bar " --- ++ " A module\n" --- ++ " " ++ pname ++ " repl Foo/Bar.hs" --- ++ " A file\n\n" --- ++ "If a target is ambiguous it can be qualified with the component " --- ++ "name, e.g.\n" --- ++ " " ++ pname ++ " repl foo:Foo.Bar\n" --- ++ " " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n" - , commandUsage = \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n" - , commandDefaultFlags = defaultReplFlags - , commandOptions = \showOrParseArgs -> - optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v }) - : optionDistPref - replDistPref (\d flags -> flags { replDistPref = d }) - showOrParseArgs - - : programDbPaths progDb showOrParseArgs - replProgramPaths (\v flags -> flags { replProgramPaths = v}) - - ++ programDbOption progDb showOrParseArgs - replProgramArgs (\v flags -> flags { replProgramArgs = v}) - - ++ programDbOptions progDb showOrParseArgs - replProgramArgs (\v flags -> flags { replProgramArgs = v}) - - ++ case showOrParseArgs of - ParseArgs -> - [ option "" ["reload"] - "Used from within an interpreter to update files." - replReload (\v flags -> flags { replReload = v }) - trueArg - ] - _ -> [] - ++ map liftReplOption (replOptions showOrParseArgs) - } - where - liftReplOption = liftOption replReplOptions (\v flags -> flags { replReplOptions = v }) - -replOptions :: ShowOrParseArgs -> [OptionField ReplOptions] -replOptions _ = - [ option [] ["repl-no-load"] - "Disable loading of project modules at REPL startup." - replOptionsNoLoad (\p flags -> flags { replOptionsNoLoad = p }) - trueArg - , option [] ["repl-options"] - "Use the option(s) for the repl" - replOptionsFlags (\p flags -> flags { replOptionsFlags = p }) - (reqArg "FLAG" (succeedReadE words) id) - ] - --- ------------------------------------------------------------ --- * Test flags --- ------------------------------------------------------------ - -data TestShowDetails = Never | Failures | Always | Streaming | Direct - deriving (Eq, Ord, Enum, Bounded, Generic, Show, Typeable) - -instance Binary TestShowDetails -instance Structured TestShowDetails - -knownTestShowDetails :: [TestShowDetails] -knownTestShowDetails = [minBound..maxBound] - -instance Pretty TestShowDetails where - pretty = Disp.text . lowercase . show - -instance Parsec TestShowDetails where - parsec = maybe (fail "invalid TestShowDetails") return . classify =<< ident - where - ident = P.munch1 (\c -> isAlpha c || c == '_' || c == '-') - classify str = lookup (lowercase str) enumMap - enumMap :: [(String, TestShowDetails)] - enumMap = [ (prettyShow x, x) - | x <- knownTestShowDetails ] - ---TODO: do we need this instance? -instance Monoid TestShowDetails where - mempty = Never - mappend = (<>) - -instance Semigroup TestShowDetails where - a <> b = if a < b then b else a - -data TestFlags = TestFlags { - testDistPref :: Flag FilePath, - testVerbosity :: Flag Verbosity, - testHumanLog :: Flag PathTemplate, - testMachineLog :: Flag PathTemplate, - testShowDetails :: Flag TestShowDetails, - testKeepTix :: Flag Bool, - testWrapper :: Flag FilePath, - testFailWhenNoTestSuites :: Flag Bool, - -- TODO: think about if/how options are passed to test exes - testOptions :: [PathTemplate] - } deriving (Show, Generic, Typeable) - -defaultTestFlags :: TestFlags -defaultTestFlags = TestFlags { - testDistPref = NoFlag, - testVerbosity = Flag normal, - testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", - testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", - testShowDetails = toFlag Failures, - testKeepTix = toFlag False, - testWrapper = NoFlag, - testFailWhenNoTestSuites = toFlag False, - testOptions = [] - } - -testCommand :: CommandUI TestFlags -testCommand = CommandUI - { commandName = "test" - , commandSynopsis = - "Run all/specific tests in the test suite." - , commandDescription = Just $ \ _pname -> wrapText $ - testOrBenchmarkHelpText "test" - , commandNotes = Nothing - , commandUsage = usageAlternatives "test" - [ "[FLAGS]" - , "TESTCOMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultTestFlags - , commandOptions = testOptions' - } - --- | Help text for @test@ and @bench@ commands. -testOrBenchmarkHelpText - :: String -- ^ Either @"test"@ or @"benchmark"@. - -> String -- ^ Help text. -testOrBenchmarkHelpText s = unlines $ map unwords - [ [ "The package must have been build with configuration" - , concat [ "flag `--enable-", s, "s`." ] - ] - , [] -- blank line - , [ concat [ "Note that additional dependencies of the ", s, "s" ] - , "must have already been installed." - ] - , [] - , [ "By defining UserHooks in a custom Setup.hs, the package can define" - , concat [ "actions to be executed before and after running ", s, "s." ] - ] - ] - -testOptions' :: ShowOrParseArgs -> [OptionField TestFlags] -testOptions' showOrParseArgs = - [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) - , optionDistPref - testDistPref (\d flags -> flags { testDistPref = d }) - showOrParseArgs - , option [] ["log"] - ("Log all test suite results to file (name template can use " - ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)") - testHumanLog (\v flags -> flags { testHumanLog = v }) - (reqArg' "TEMPLATE" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - , option [] ["machine-log"] - ("Produce a machine-readable log file (name template can use " - ++ "$pkgid, $compiler, $os, $arch, $result)") - testMachineLog (\v flags -> flags { testMachineLog = v }) - (reqArg' "TEMPLATE" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - , option [] ["show-details"] - ("'always': always show results of individual test cases. " - ++ "'never': never show results of individual test cases. " - ++ "'failures': show results of failing test cases. " - ++ "'streaming': show results of test cases in real time." - ++ "'direct': send results of test cases in real time; no log file.") - testShowDetails (\v flags -> flags { testShowDetails = v }) - (reqArg "FILTER" - (parsecToReadE (\_ -> "--show-details flag expects one of " - ++ intercalate ", " - (map prettyShow knownTestShowDetails)) - (fmap toFlag parsec)) - (flagToList . fmap prettyShow)) - , option [] ["keep-tix-files"] - "keep .tix files for HPC between test runs" - testKeepTix (\v flags -> flags { testKeepTix = v}) - trueArg - , option [] ["test-wrapper"] - "Run test through a wrapper." - testWrapper (\v flags -> flags { testWrapper = v }) - (reqArg' "FILE" (toFlag :: FilePath -> Flag FilePath) - (flagToList :: Flag FilePath -> [FilePath])) - , option [] ["fail-when-no-test-suites"] - ("Exit with failure when no test suites are found.") - testFailWhenNoTestSuites (\v flags -> flags { testFailWhenNoTestSuites = v}) - trueArg - , option [] ["test-options"] - ("give extra options to test executables " - ++ "(name templates can use $pkgid, $compiler, " - ++ "$os, $arch, $test-suite)") - testOptions (\v flags -> flags { testOptions = v }) - (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) - (const [])) - , option [] ["test-option"] - ("give extra option to test executables " - ++ "(no need to quote options containing spaces, " - ++ "name template can use $pkgid, $compiler, " - ++ "$os, $arch, $test-suite)") - testOptions (\v flags -> flags { testOptions = v }) - (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) - (map fromPathTemplate)) - ] - -emptyTestFlags :: TestFlags -emptyTestFlags = mempty - -instance Monoid TestFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup TestFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Benchmark flags --- ------------------------------------------------------------ - -data BenchmarkFlags = BenchmarkFlags { - benchmarkDistPref :: Flag FilePath, - benchmarkVerbosity :: Flag Verbosity, - benchmarkOptions :: [PathTemplate] - } deriving (Show, Generic, Typeable) - -defaultBenchmarkFlags :: BenchmarkFlags -defaultBenchmarkFlags = BenchmarkFlags { - benchmarkDistPref = NoFlag, - benchmarkVerbosity = Flag normal, - benchmarkOptions = [] - } - -benchmarkCommand :: CommandUI BenchmarkFlags -benchmarkCommand = CommandUI - { commandName = "bench" - , commandSynopsis = - "Run all/specific benchmarks." - , commandDescription = Just $ \ _pname -> wrapText $ - testOrBenchmarkHelpText "benchmark" - , commandNotes = Nothing - , commandUsage = usageAlternatives "bench" - [ "[FLAGS]" - , "BENCHCOMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultBenchmarkFlags - , commandOptions = benchmarkOptions' - } - -benchmarkOptions' :: ShowOrParseArgs -> [OptionField BenchmarkFlags] -benchmarkOptions' showOrParseArgs = - [ optionVerbosity benchmarkVerbosity - (\v flags -> flags { benchmarkVerbosity = v }) - , optionDistPref - benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d }) - showOrParseArgs - , option [] ["benchmark-options"] - ("give extra options to benchmark executables " - ++ "(name templates can use $pkgid, $compiler, " - ++ "$os, $arch, $benchmark)") - benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) - (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) - (const [])) - , option [] ["benchmark-option"] - ("give extra option to benchmark executables " - ++ "(no need to quote options containing spaces, " - ++ "name template can use $pkgid, $compiler, " - ++ "$os, $arch, $benchmark)") - benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) - (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) - (map fromPathTemplate)) - ] - -emptyBenchmarkFlags :: BenchmarkFlags -emptyBenchmarkFlags = mempty - -instance Monoid BenchmarkFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup BenchmarkFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Shared options utils --- ------------------------------------------------------------ - -programFlagsDescription :: ProgramDb -> String -programFlagsDescription progDb = - "The flags --with-PROG and --PROG-option(s) can be used with" - ++ " the following programs:" - ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) - [ programName prog | (prog, _) <- knownPrograms progDb ] - ++ "\n" - --- | For each known program @PROG@ in 'progDb', produce a @with-PROG@ --- 'OptionField'. -programDbPaths - :: ProgramDb - -> ShowOrParseArgs - -> (flags -> [(String, FilePath)]) - -> ([(String, FilePath)] -> (flags -> flags)) - -> [OptionField flags] -programDbPaths progDb showOrParseArgs get set = - programDbPaths' ("with-" ++) progDb showOrParseArgs get set - --- | Like 'programDbPaths', but allows to customise the option name. -programDbPaths' - :: (String -> String) - -> ProgramDb - -> ShowOrParseArgs - -> (flags -> [(String, FilePath)]) - -> ([(String, FilePath)] -> (flags -> flags)) - -> [OptionField flags] -programDbPaths' mkName progDb showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [withProgramPath "PROG"] - ParseArgs -> map (withProgramPath . programName . fst) - (knownPrograms progDb) - where - withProgramPath prog = - option "" [mkName prog] - ("give the path to " ++ prog) - get set - (reqArg' "PATH" (\path -> [(prog, path)]) - (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) - --- | For each known program @PROG@ in 'progDb', produce a @PROG-option@ --- 'OptionField'. -programDbOption - :: ProgramDb - -> ShowOrParseArgs - -> (flags -> [(String, [String])]) - -> ([(String, [String])] -> (flags -> flags)) - -> [OptionField flags] -programDbOption progDb showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [programOption "PROG"] - ParseArgs -> map (programOption . programName . fst) - (knownPrograms progDb) - where - programOption prog = - option "" [prog ++ "-option"] - ("give an extra option to " ++ prog ++ - " (no need to quote options containing spaces)") - get set - (reqArg' "OPT" (\arg -> [(prog, [arg])]) - (\progArgs -> concat [ args - | (prog', args) <- progArgs, prog==prog' ])) - - --- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ --- 'OptionField'. -programDbOptions - :: ProgramDb - -> ShowOrParseArgs - -> (flags -> [(String, [String])]) - -> ([(String, [String])] -> (flags -> flags)) - -> [OptionField flags] -programDbOptions progDb showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [programOptions "PROG"] - ParseArgs -> map (programOptions . programName . fst) - (knownPrograms progDb) - where - programOptions prog = - option "" [prog ++ "-options"] - ("give extra options to " ++ prog) - get set - (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) - --- ------------------------------------------------------------ --- * GetOpt Utils --- ------------------------------------------------------------ - -boolOpt :: SFlags -> SFlags - -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -boolOpt = Command.boolOpt flagToMaybe Flag - -boolOpt' :: OptFlags -> OptFlags - -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -boolOpt' = Command.boolOpt' flagToMaybe Flag - -trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -trueArg sfT lfT = boolOpt' (sfT, lfT) ([], []) sfT lfT -falseArg sfF lfF = boolOpt' ([], []) (sfF, lfF) sfF lfF - -reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> - (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b -reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList - -optionDistPref :: (flags -> Flag FilePath) - -> (Flag FilePath -> flags -> flags) - -> ShowOrParseArgs - -> OptionField flags -optionDistPref get set = \showOrParseArgs -> - option "" (distPrefFlagName showOrParseArgs) - ( "The directory where Cabal puts generated build files " - ++ "(default " ++ defaultDistPref ++ ")") - get set - (reqArgFlag "DIR") - where - distPrefFlagName ShowArgs = ["builddir"] - distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] - -optionVerbosity :: (flags -> Flag Verbosity) - -> (Flag Verbosity -> flags -> flags) - -> OptionField flags -optionVerbosity get set = - option "v" ["verbose"] - "Control verbosity (n is 0--3, default verbosity level is 1)" - get set - (optArg "n" (fmap Flag flagToVerbosity) - (Flag verbose) -- default Value if no n is given - (fmap (Just . showForCabal) . flagToList)) - -optionNumJobs :: (flags -> Flag (Maybe Int)) - -> (Flag (Maybe Int) -> flags -> flags) - -> OptionField flags -optionNumJobs get set = - option "j" ["jobs"] - "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)." - get set - (optArg "NUM" (fmap Flag numJobsParser) - (Flag Nothing) - (map (Just . maybe "$ncpus" show) . flagToList)) - where - numJobsParser :: ReadE (Maybe Int) - numJobsParser = ReadE $ \s -> - case s of - "$ncpus" -> Right Nothing - _ -> case reads s of - [(n, "")] - | n < 1 -> Left "The number of jobs should be 1 or more." - | otherwise -> Right (Just n) - _ -> Left "The jobs value should be a number or '$ncpus'" - --- ------------------------------------------------------------ --- * Other Utils --- ------------------------------------------------------------ - --- | Arguments to pass to a @configure@ script, e.g. generated by --- @autoconf@. -configureArgs :: Bool -> ConfigFlags -> [String] -configureArgs bcHack flags - = hc_flag - ++ optFlag "with-hc-pkg" configHcPkg - ++ optFlag' "prefix" prefix - ++ optFlag' "bindir" bindir - ++ optFlag' "libdir" libdir - ++ optFlag' "libexecdir" libexecdir - ++ optFlag' "datadir" datadir - ++ optFlag' "sysconfdir" sysconfdir - ++ configConfigureArgs flags - where - hc_flag = case (configHcFlavor flags, configHcPath flags) of - (_, Flag hc_path) -> [hc_flag_name ++ hc_path] - (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc] - (NoFlag,NoFlag) -> [] - hc_flag_name - --TODO kill off thic bc hack when defaultUserHooks is removed. - | bcHack = "--with-hc=" - | otherwise = "--with-compiler=" - optFlag name config_field = case config_field flags of - Flag p -> ["--" ++ name ++ "=" ++ p] - NoFlag -> [] - optFlag' name config_field = optFlag name (fmap fromPathTemplate - . config_field - . configInstallDirs) - -configureCCompiler :: Verbosity -> ProgramDb - -> IO (FilePath, [String]) -configureCCompiler verbosity progdb = configureProg verbosity progdb gccProgram - -configureLinker :: Verbosity -> ProgramDb -> IO (FilePath, [String]) -configureLinker verbosity progdb = configureProg verbosity progdb ldProgram - -configureProg :: Verbosity -> ProgramDb -> Program - -> IO (FilePath, [String]) -configureProg verbosity programDb prog = do - (p, _) <- requireProgram verbosity prog programDb - let pInv = programInvocation p [] - return (progInvokePath pInv, progInvokeArgs pInv) - --- | Helper function to split a string into a list of arguments. --- It's supposed to handle quoted things sensibly, eg: --- --- > splitArgs "--foo=\"C:/Program Files/Bar/" --baz" --- > = ["--foo=C:/Program Files/Bar", "--baz"] --- --- > splitArgs "\"-DMSGSTR=\\\"foo bar\\\"\" --baz" --- > = ["-DMSGSTR=\"foo bar\"","--baz"] --- -splitArgs :: String -> [String] -splitArgs = space [] - where - space :: String -> String -> [String] - space w [] = word w [] - space w ( c :s) - | isSpace c = word w (space [] s) - space w ('"':s) = string w s - space w s = nonstring w s - - string :: String -> String -> [String] - string w [] = word w [] - string w ('"':s) = space w s - string w ('\\':'"':s) = string ('"':w) s - string w ( c :s) = string (c:w) s - - nonstring :: String -> String -> [String] - nonstring w [] = word w [] - nonstring w ('"':s) = string w s - nonstring w ( c :s) = space (c:w) s - - word [] s = s - word w s = reverse w : s - --- The test cases kinda have to be rewritten from the ground up... :/ ---hunitTests :: [Test] ---hunitTests = +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Setup +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module defines the command line interface for all the Cabal +-- commands. For each command (like @configure@, @build@ etc) it defines a type +-- that holds all the flags, the default set of flags and a 'CommandUI' that +-- maps command line flags to and from the corresponding flags type. +-- +-- All the flags types are instances of 'Monoid', see +-- +-- for an explanation. +-- +-- The types defined here get used in the front end and especially in +-- @cabal-install@ which has to do quite a bit of manipulating sets of command +-- line flags. +-- +-- This is actually relatively nice, it works quite well. The main change it +-- needs is to unify it with the code for managing sets of fields that can be +-- read and written from files. This would allow us to save configure flags in +-- config files. +module Distribution.Simple.Setup + ( GlobalFlags (..) + , emptyGlobalFlags + , defaultGlobalFlags + , globalCommand + , ConfigFlags (..) + , emptyConfigFlags + , defaultConfigFlags + , configureCommand + , configPrograms + , configAbsolutePaths + , readPackageDb + , readPackageDbList + , showPackageDb + , showPackageDbList + , CopyFlags (..) + , emptyCopyFlags + , defaultCopyFlags + , copyCommand + , InstallFlags (..) + , emptyInstallFlags + , defaultInstallFlags + , installCommand + , HaddockTarget (..) + , HaddockFlags (..) + , emptyHaddockFlags + , defaultHaddockFlags + , haddockCommand + , Visibility (..) + , HaddockProjectFlags (..) + , emptyHaddockProjectFlags + , defaultHaddockProjectFlags + , haddockProjectCommand + , HscolourFlags (..) + , emptyHscolourFlags + , defaultHscolourFlags + , hscolourCommand + , BuildFlags (..) + , emptyBuildFlags + , defaultBuildFlags + , buildCommand + , DumpBuildInfo (..) + , ReplFlags (..) + , defaultReplFlags + , replCommand + , ReplOptions (..) + , CleanFlags (..) + , emptyCleanFlags + , defaultCleanFlags + , cleanCommand + , RegisterFlags (..) + , emptyRegisterFlags + , defaultRegisterFlags + , registerCommand + , unregisterCommand + , SDistFlags (..) + , emptySDistFlags + , defaultSDistFlags + , sdistCommand + , TestFlags (..) + , emptyTestFlags + , defaultTestFlags + , testCommand + , TestShowDetails (..) + , BenchmarkFlags (..) + , emptyBenchmarkFlags + , defaultBenchmarkFlags + , benchmarkCommand + , CopyDest (..) + , configureArgs + , configureOptions + , configureCCompiler + , configureLinker + , buildOptions + , haddockOptions + , haddockProjectOptions + , installDirsOptions + , testOptions' + , benchmarkOptions' + , programDbOptions + , programDbPaths' + , programFlagsDescription + , replOptions + , splitArgs + , defaultDistPref + , optionDistPref + , Flag (..) + , toFlag + , fromFlag + , fromFlagOrDefault + , flagToMaybe + , flagToList + , maybeToFlag + , BooleanFlag (..) + , boolOpt + , boolOpt' + , trueArg + , falseArg + , optionVerbosity + , BuildingWhat (..) + , buildingWhatVerbosity + , buildingWhatDistPref + ) where + +import GHC.Generics (Generic) +import Prelude (FilePath, Show, ($)) + +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs +import Distribution.Types.DumpBuildInfo + +import Distribution.Simple.Setup.Benchmark +import Distribution.Simple.Setup.Build +import Distribution.Simple.Setup.Clean +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Config +import Distribution.Simple.Setup.Copy +import Distribution.Simple.Setup.Global +import Distribution.Simple.Setup.Haddock +import Distribution.Simple.Setup.Hscolour +import Distribution.Simple.Setup.Install +import Distribution.Simple.Setup.Register +import Distribution.Simple.Setup.Repl +import Distribution.Simple.Setup.SDist +import Distribution.Simple.Setup.Test + +import Distribution.Verbosity (Verbosity) + +-- | What kind of build are we doing? +-- +-- Is this a normal build, or is it perhaps for running an interactive +-- session or Haddock? +data BuildingWhat + = -- | A normal build. + BuildNormal BuildFlags + | -- | Build steps for an interactive session. + BuildRepl ReplFlags + | -- | Build steps for generating documentation. + BuildHaddock HaddockFlags + | -- | Build steps for Hscolour. + BuildHscolour HscolourFlags + deriving (Generic, Show) + +buildingWhatVerbosity :: BuildingWhat -> Verbosity +buildingWhatVerbosity = \case + BuildNormal flags -> fromFlag $ buildVerbosity flags + BuildRepl flags -> fromFlag $ replVerbosity flags + BuildHaddock flags -> fromFlag $ haddockVerbosity flags + BuildHscolour flags -> fromFlag $ hscolourVerbosity flags + +buildingWhatDistPref :: BuildingWhat -> FilePath +buildingWhatDistPref = \case + BuildNormal flags -> fromFlag $ buildDistPref flags + BuildRepl flags -> fromFlag $ replDistPref flags + BuildHaddock flags -> fromFlag $ haddockDistPref flags + BuildHscolour flags -> fromFlag $ hscolourDistPref flags + +-- The test cases kinda have to be rewritten from the ground up... :/ +-- hunitTests :: [Test] +-- hunitTests = -- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)] -- (flags, commands', unkFlags, ers) -- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"] diff --git a/src/Distribution/Simple/Setup/Benchmark.hs b/src/Distribution/Simple/Setup/Benchmark.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Benchmark.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Benchmark +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Definition of the benchmarking command-line options. +-- See: @Distribution.Simple.Setup@ +module Distribution.Simple.Setup.Benchmark + ( BenchmarkFlags (..) + , emptyBenchmarkFlags + , defaultBenchmarkFlags + , benchmarkCommand + , benchmarkOptions' + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs +import Distribution.Simple.Utils +import Distribution.Verbosity + +import Distribution.Simple.Setup.Common + +-- ------------------------------------------------------------ + +-- * Benchmark flags + +-- ------------------------------------------------------------ + +data BenchmarkFlags = BenchmarkFlags + { benchmarkDistPref :: Flag FilePath + , benchmarkVerbosity :: Flag Verbosity + , benchmarkOptions :: [PathTemplate] + } + deriving (Show, Generic, Typeable) + +instance Binary BenchmarkFlags +instance Structured BenchmarkFlags + +defaultBenchmarkFlags :: BenchmarkFlags +defaultBenchmarkFlags = + BenchmarkFlags + { benchmarkDistPref = NoFlag + , benchmarkVerbosity = Flag normal + , benchmarkOptions = [] + } + +benchmarkCommand :: CommandUI BenchmarkFlags +benchmarkCommand = + CommandUI + { commandName = "bench" + , commandSynopsis = + "Run all/specific benchmarks." + , commandDescription = Just $ \_pname -> + wrapText $ + testOrBenchmarkHelpText "benchmark" + , commandNotes = Nothing + , commandUsage = + usageAlternatives + "bench" + [ "[FLAGS]" + , "BENCHCOMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultBenchmarkFlags + , commandOptions = benchmarkOptions' + } + +benchmarkOptions' :: ShowOrParseArgs -> [OptionField BenchmarkFlags] +benchmarkOptions' showOrParseArgs = + [ optionVerbosity + benchmarkVerbosity + (\v flags -> flags{benchmarkVerbosity = v}) + , optionDistPref + benchmarkDistPref + (\d flags -> flags{benchmarkDistPref = d}) + showOrParseArgs + , option + [] + ["benchmark-options"] + ( "give extra options to benchmark executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)" + ) + benchmarkOptions + (\v flags -> flags{benchmarkOptions = v}) + ( reqArg' + "TEMPLATES" + (map toPathTemplate . splitArgs) + (const []) + ) + , option + [] + ["benchmark-option"] + ( "give extra option to benchmark executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)" + ) + benchmarkOptions + (\v flags -> flags{benchmarkOptions = v}) + ( reqArg' + "TEMPLATE" + (\x -> [toPathTemplate x]) + (map fromPathTemplate) + ) + ] + +emptyBenchmarkFlags :: BenchmarkFlags +emptyBenchmarkFlags = mempty + +instance Monoid BenchmarkFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup BenchmarkFlags where + (<>) = gmappend diff --git a/src/Distribution/Simple/Setup/Build.hs b/src/Distribution/Simple/Setup/Build.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Build.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Setup.Build +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Definition of the build command-line options. +-- See: @Distribution.Simple.Setup@ +module Distribution.Simple.Setup.Build + ( BuildFlags (..) + , emptyBuildFlags + , defaultBuildFlags + , buildCommand + , DumpBuildInfo (..) + , buildOptions + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import Distribution.Simple.Flag +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Types.DumpBuildInfo +import Distribution.Verbosity + +import Distribution.Simple.Setup.Common + +-- ------------------------------------------------------------ + +-- * Build flags + +-- ------------------------------------------------------------ + +data BuildFlags = BuildFlags + { buildProgramPaths :: [(String, FilePath)] + , buildProgramArgs :: [(String, [String])] + , buildDistPref :: Flag FilePath + , buildVerbosity :: Flag Verbosity + , buildNumJobs :: Flag (Maybe Int) + , buildUseSemaphore :: Flag String + , -- TODO: this one should not be here, it's just that the silly + -- UserHooks stop us from passing extra info in other ways + buildArgs :: [String] + , buildCabalFilePath :: Flag FilePath + } + deriving (Read, Show, Generic, Typeable) + +instance Binary BuildFlags +instance Structured BuildFlags + +defaultBuildFlags :: BuildFlags +defaultBuildFlags = + BuildFlags + { buildProgramPaths = mempty + , buildProgramArgs = [] + , buildDistPref = mempty + , buildVerbosity = Flag normal + , buildNumJobs = mempty + , buildUseSemaphore = NoFlag + , buildArgs = [] + , buildCabalFilePath = mempty + } + +buildCommand :: ProgramDb -> CommandUI BuildFlags +buildCommand progDb = + CommandUI + { commandName = "build" + , commandSynopsis = "Compile all/specific components." + , commandDescription = Just $ \_ -> + wrapText $ + "Components encompass executables, tests, and benchmarks.\n" + ++ "\n" + ++ "Affected by configuration options, see `configure`.\n" + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " build " + ++ " All the components in the package\n" + ++ " " + ++ pname + ++ " build foo " + ++ " A component (i.e. lib, exe, test suite)\n\n" + ++ programFlagsDescription progDb + , -- TODO: re-enable once we have support for module/file targets + -- ++ " " ++ pname ++ " build Foo.Bar " + -- ++ " A module\n" + -- ++ " " ++ pname ++ " build Foo/Bar.hs" + -- ++ " A file\n\n" + -- ++ "If a target is ambiguous it can be qualified with the component " + -- ++ "name, e.g.\n" + -- ++ " " ++ pname ++ " build foo:Foo.Bar\n" + -- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n" + commandUsage = + usageAlternatives "build" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultBuildFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity + buildVerbosity + (\v flags -> flags{buildVerbosity = v}) + , optionDistPref + buildDistPref + (\d flags -> flags{buildDistPref = d}) + showOrParseArgs + ] + ++ buildOptions progDb showOrParseArgs + } + +buildOptions + :: ProgramDb + -> ShowOrParseArgs + -> [OptionField BuildFlags] +buildOptions progDb showOrParseArgs = + [ optionNumJobs + buildNumJobs + (\v flags -> flags{buildNumJobs = v}) + , option + [] + ["semaphore"] + "semaphore" + buildUseSemaphore + (\v flags -> flags{buildUseSemaphore = v}) + (reqArg' "SEMAPHORE" Flag flagToList) + ] + ++ programDbPaths + progDb + showOrParseArgs + buildProgramPaths + (\v flags -> flags{buildProgramPaths = v}) + ++ programDbOption + progDb + showOrParseArgs + buildProgramArgs + (\v fs -> fs{buildProgramArgs = v}) + ++ programDbOptions + progDb + showOrParseArgs + buildProgramArgs + (\v flags -> flags{buildProgramArgs = v}) + +emptyBuildFlags :: BuildFlags +emptyBuildFlags = mempty + +instance Monoid BuildFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup BuildFlags where + (<>) = gmappend diff --git a/src/Distribution/Simple/Setup/Clean.hs b/src/Distribution/Simple/Setup/Clean.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Clean.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Setup.Clean +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Definition of the clean command-line options. +-- See: @Distribution.Simple.Setup@ +module Distribution.Simple.Setup.Clean + ( CleanFlags (..) + , emptyCleanFlags + , defaultCleanFlags + , cleanCommand + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import Distribution.Simple.Flag +import Distribution.Verbosity + +import Distribution.Simple.Setup.Common + +-- ------------------------------------------------------------ + +-- * Clean flags + +-- ------------------------------------------------------------ + +data CleanFlags = CleanFlags + { cleanSaveConf :: Flag Bool + , cleanDistPref :: Flag FilePath + , cleanVerbosity :: Flag Verbosity + , cleanCabalFilePath :: Flag FilePath + } + deriving (Show, Generic, Typeable) + +instance Binary CleanFlags +instance Structured CleanFlags + +defaultCleanFlags :: CleanFlags +defaultCleanFlags = + CleanFlags + { cleanSaveConf = Flag False + , cleanDistPref = NoFlag + , cleanVerbosity = Flag normal + , cleanCabalFilePath = mempty + } + +cleanCommand :: CommandUI CleanFlags +cleanCommand = + CommandUI + { commandName = "clean" + , commandSynopsis = "Clean up after a build." + , commandDescription = Just $ \_ -> + "Removes .hi, .o, preprocessed sources, etc.\n" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " clean [FLAGS]\n" + , commandDefaultFlags = defaultCleanFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity cleanVerbosity (\v flags -> flags{cleanVerbosity = v}) + , optionDistPref + cleanDistPref + (\d flags -> flags{cleanDistPref = d}) + showOrParseArgs + , option + "s" + ["save-configure"] + "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." + cleanSaveConf + (\v flags -> flags{cleanSaveConf = v}) + trueArg + ] + } + +emptyCleanFlags :: CleanFlags +emptyCleanFlags = mempty + +instance Monoid CleanFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup CleanFlags where + (<>) = gmappend diff --git a/src/Distribution/Simple/Setup/Common.hs b/src/Distribution/Simple/Setup/Common.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Common.hs @@ -0,0 +1,372 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Setup.Common +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Common utilities for defining command-line options. +-- See: @Distribution.Simple.Setup@ +module Distribution.Simple.Setup.Common + ( CopyDest (..) + , configureCCompiler + , configureLinker + , programDbOption + , programDbOptions + , programDbPaths + , programDbPaths' + , programFlagsDescription + , splitArgs + , testOrBenchmarkHelpText + , defaultDistPref + , extraCompilationArtifacts + , optionDistPref + , Flag (..) + , toFlag + , fromFlag + , fromFlagOrDefault + , flagToMaybe + , flagToList + , maybeToFlag + , BooleanFlag (..) + , boolOpt + , boolOpt' + , trueArg + , falseArg + , reqArgFlag + , optionVerbosity + , optionNumJobs + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.ReadE +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import qualified Distribution.Simple.Command as Command +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Verbosity + +-- FIXME Not sure where this should live +defaultDistPref :: FilePath +defaultDistPref = "dist" + +-- | The name of the directory where optional compilation artifacts +-- go, such as ghc plugins and .hie files. +extraCompilationArtifacts :: FilePath +extraCompilationArtifacts = "extra-compilation-artifacts" + +-- | Help text for @test@ and @bench@ commands. +testOrBenchmarkHelpText + :: String + -- ^ Either @"test"@ or @"benchmark"@. + -> String + -- ^ Help text. +testOrBenchmarkHelpText s = + unlines $ + map + unwords + [ + [ "The package must have been build with configuration" + , concat ["flag `--enable-", s, "s`."] + ] + , [] -- blank line + , + [ concat ["Note that additional dependencies of the ", s, "s"] + , "must have already been installed." + ] + , [] + , + [ "By defining UserHooks in a custom Setup.hs, the package can define" + , concat ["actions to be executed before and after running ", s, "s."] + ] + ] + +-- ------------------------------------------------------------ + +-- * Shared options utils + +-- ------------------------------------------------------------ + +programFlagsDescription :: ProgramDb -> String +programFlagsDescription progDb = + "The flags --with-PROG and --PROG-option(s) can be used with" + ++ " the following programs:" + ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) + [programName prog | (prog, _) <- knownPrograms progDb] + ++ "\n" + +-- | For each known program @PROG@ in 'progDb', produce a @with-PROG@ +-- 'OptionField'. +programDbPaths + :: ProgramDb + -> ShowOrParseArgs + -> (flags -> [(String, FilePath)]) + -> ([(String, FilePath)] -> (flags -> flags)) + -> [OptionField flags] +programDbPaths progDb showOrParseArgs get set = + programDbPaths' ("with-" ++) progDb showOrParseArgs get set + +-- | Like 'programDbPaths', but allows to customise the option name. +programDbPaths' + :: (String -> String) + -> ProgramDb + -> ShowOrParseArgs + -> (flags -> [(String, FilePath)]) + -> ([(String, FilePath)] -> (flags -> flags)) + -> [OptionField flags] +programDbPaths' mkName progDb showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [withProgramPath "PROG"] + ParseArgs -> + map + (withProgramPath . programName . fst) + (knownPrograms progDb) + where + withProgramPath prog = + option + "" + [mkName prog] + ("give the path to " ++ prog) + get + set + ( reqArg' + "PATH" + (\path -> [(prog, path)]) + (\progPaths -> [path | (prog', path) <- progPaths, prog == prog']) + ) + +-- | For each known program @PROG@ in 'progDb', produce a @PROG-option@ +-- 'OptionField'. +programDbOption + :: ProgramDb + -> ShowOrParseArgs + -> (flags -> [(String, [String])]) + -> ([(String, [String])] -> (flags -> flags)) + -> [OptionField flags] +programDbOption progDb showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [programOption "PROG"] + ParseArgs -> + map + (programOption . programName . fst) + (knownPrograms progDb) + where + programOption prog = + option + "" + [prog ++ "-option"] + ( "give an extra option to " + ++ prog + ++ " (no need to quote options containing spaces)" + ) + get + set + ( reqArg' + "OPT" + (\arg -> [(prog, [arg])]) + ( \progArgs -> + concat + [ args + | (prog', args) <- progArgs + , prog == prog' + ] + ) + ) + +-- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ +-- 'OptionField'. +programDbOptions + :: ProgramDb + -> ShowOrParseArgs + -> (flags -> [(String, [String])]) + -> ([(String, [String])] -> (flags -> flags)) + -> [OptionField flags] +programDbOptions progDb showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [programOptions "PROG"] + ParseArgs -> + map + (programOptions . programName . fst) + (knownPrograms progDb) + where + programOptions prog = + option + "" + [prog ++ "-options"] + ("give extra options to " ++ prog) + get + set + (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) + +-- ------------------------------------------------------------ + +-- * GetOpt Utils + +-- ------------------------------------------------------------ + +boolOpt + :: SFlags + -> SFlags + -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt = Command.boolOpt flagToMaybe Flag + +boolOpt' + :: OptFlags + -> OptFlags + -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt' = Command.boolOpt' flagToMaybe Flag + +trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +trueArg sfT lfT = boolOpt' (sfT, lfT) ([], []) sfT lfT +falseArg sfF lfF = boolOpt' ([], []) (sfF, lfF) sfF lfF + +reqArgFlag + :: ArgPlaceHolder + -> SFlags + -> LFlags + -> Description + -> (b -> Flag String) + -> (Flag String -> b -> b) + -> OptDescr b +reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList + +optionDistPref + :: (flags -> Flag FilePath) + -> (Flag FilePath -> flags -> flags) + -> ShowOrParseArgs + -> OptionField flags +optionDistPref get set = \showOrParseArgs -> + option + "" + (distPrefFlagName showOrParseArgs) + ( "The directory where Cabal puts generated build files " + ++ "(default " + ++ defaultDistPref + ++ ")" + ) + get + set + (reqArgFlag "DIR") + where + distPrefFlagName ShowArgs = ["builddir"] + distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] + +optionVerbosity + :: (flags -> Flag Verbosity) + -> (Flag Verbosity -> flags -> flags) + -> OptionField flags +optionVerbosity get set = + option + "v" + ["verbose"] + "Control verbosity (n is 0--3, default verbosity level is 1)" + get + set + ( optArg + "n" + (fmap Flag flagToVerbosity) + (show verbose, Flag verbose) -- default Value if no n is given + (fmap (Just . showForCabal) . flagToList) + ) + +optionNumJobs + :: (flags -> Flag (Maybe Int)) + -> (Flag (Maybe Int) -> flags -> flags) + -> OptionField flags +optionNumJobs get set = + option + "j" + ["jobs"] + "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)." + get + set + ( optArg + "NUM" + (fmap Flag numJobsParser) + ("$ncpus", Flag Nothing) + (map (Just . maybe "$ncpus" show) . flagToList) + ) + where + numJobsParser :: ReadE (Maybe Int) + numJobsParser = ReadE $ \s -> + case s of + "$ncpus" -> Right Nothing + _ -> case reads s of + [(n, "")] + | n < 1 -> Left "The number of jobs should be 1 or more." + | otherwise -> Right (Just n) + _ -> Left "The jobs value should be a number or '$ncpus'" + +-- ------------------------------------------------------------ + +-- * Other Utils + +-- ------------------------------------------------------------ + +configureCCompiler + :: Verbosity + -> ProgramDb + -> IO (FilePath, [String]) +configureCCompiler verbosity progdb = configureProg verbosity progdb gccProgram + +configureLinker :: Verbosity -> ProgramDb -> IO (FilePath, [String]) +configureLinker verbosity progdb = configureProg verbosity progdb ldProgram + +configureProg + :: Verbosity + -> ProgramDb + -> Program + -> IO (FilePath, [String]) +configureProg verbosity programDb prog = do + (p, _) <- requireProgram verbosity prog programDb + let pInv = programInvocation p [] + return (progInvokePath pInv, progInvokeArgs pInv) + +-- | Helper function to split a string into a list of arguments. +-- It's supposed to handle quoted things sensibly, eg: +-- +-- > splitArgs "--foo=\"C:/Program Files/Bar/" --baz" +-- > = ["--foo=C:/Program Files/Bar", "--baz"] +-- +-- > splitArgs "\"-DMSGSTR=\\\"foo bar\\\"\" --baz" +-- > = ["-DMSGSTR=\"foo bar\"","--baz"] +splitArgs :: String -> [String] +splitArgs = space [] + where + space :: String -> String -> [String] + space w [] = word w [] + space w (c : s) + | isSpace c = word w (space [] s) + space w ('"' : s) = string w s + space w s = nonstring w s + + string :: String -> String -> [String] + string w [] = word w [] + string w ('"' : s) = space w s + string w ('\\' : '"' : s) = string ('"' : w) s + string w (c : s) = string (c : w) s + + nonstring :: String -> String -> [String] + nonstring w [] = word w [] + nonstring w ('"' : s) = string w s + nonstring w (c : s) = space (c : w) s + + word [] s = s + word w s = reverse w : s diff --git a/src/Distribution/Simple/Setup/Config.hs b/src/Distribution/Simple/Setup/Config.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Config.hs @@ -0,0 +1,1064 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Setup.Config +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Definition of the configure command-line options. +-- See: @Distribution.Simple.Setup@ +module Distribution.Simple.Setup.Config + ( ConfigFlags (..) + , emptyConfigFlags + , defaultConfigFlags + , configureCommand + , configPrograms + , configAbsolutePaths + , readPackageDb + , readPackageDbList + , showPackageDb + , showPackageDbList + , configureArgs + , configureOptions + , installDirsOptions + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import qualified Distribution.Compat.CharParsing as P +import Distribution.Compiler +import Distribution.ModuleName +import Distribution.PackageDescription +import Distribution.Parsec +import Distribution.Pretty +import Distribution.ReadE +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Types.ComponentId +import Distribution.Types.DumpBuildInfo +import Distribution.Types.GivenComponent +import Distribution.Types.Module +import Distribution.Types.PackageVersionConstraint +import Distribution.Types.UnitId +import Distribution.Utils.NubList +import Distribution.Verbosity +import qualified Text.PrettyPrint as Disp + +import Distribution.Compat.Semigroup (Last' (..), Option' (..)) +import Distribution.Compat.Stack + +import Distribution.Simple.Setup.Common + +-- ------------------------------------------------------------ + +-- * Config flags + +-- ------------------------------------------------------------ + +-- | Flags to @configure@ command. +-- +-- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags' +-- should be updated. +-- IMPORTANT: every time a new flag is added, it should be added to the Eq instance +data ConfigFlags = ConfigFlags + { -- This is the same hack as in 'buildArgs' and 'copyArgs'. + -- TODO: Stop using this eventually when 'UserHooks' gets changed + configArgs :: [String] + , -- FIXME: the configPrograms is only here to pass info through to configure + -- 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) + -- ^ All programs that + -- @cabal@ may run + , configProgramPaths :: [(String, FilePath)] + -- ^ user specified programs paths + , configProgramArgs :: [(String, [String])] + -- ^ user specified programs args + , configProgramPathExtra :: NubList FilePath + -- ^ Extend the $PATH + , configHcFlavor :: Flag CompilerFlavor + -- ^ The \"flavor\" of the + -- compiler, e.g. GHC. + , configHcPath :: Flag FilePath + -- ^ given compiler location + , configHcPkg :: Flag FilePath + -- ^ given hc-pkg location + , configVanillaLib :: Flag Bool + -- ^ Enable vanilla library + , configProfLib :: Flag Bool + -- ^ Enable profiling in the library + , configSharedLib :: Flag Bool + -- ^ Build shared library + , configStaticLib :: Flag Bool + -- ^ Build static library + , configDynExe :: Flag Bool + -- ^ Enable dynamic linking of the + -- executables. + , configFullyStaticExe :: Flag Bool + -- ^ Enable fully static linking of the + -- executables. + , configProfExe :: Flag Bool + -- ^ Enable profiling in the + -- executables. + , configProf :: Flag Bool + -- ^ Enable profiling in the library + -- and executables. + , configProfDetail :: Flag ProfDetailLevel + -- ^ Profiling detail level + -- in the library and executables. + , configProfLibDetail :: Flag ProfDetailLevel + -- ^ Profiling detail level + -- in the library + , configConfigureArgs :: [String] + -- ^ Extra arguments to @configure@ + , configOptimization :: Flag OptimisationLevel + -- ^ Enable optimization. + , configProgPrefix :: Flag PathTemplate + -- ^ Installed executable prefix. + , configProgSuffix :: Flag PathTemplate + -- ^ Installed executable suffix. + , configInstallDirs :: InstallDirs (Flag PathTemplate) + -- ^ Installation + -- paths + , configScratchDir :: Flag FilePath + , configExtraLibDirs :: [FilePath] + -- ^ path to search for extra libraries + , configExtraLibDirsStatic :: [FilePath] + -- ^ path to search for extra + -- libraries when linking + -- fully static executables + , configExtraFrameworkDirs :: [FilePath] + -- ^ path to search for extra + -- frameworks (OS X only) + , configExtraIncludeDirs :: [FilePath] + -- ^ path to search for header files + , configIPID :: Flag String + -- ^ explicit IPID to be used + , configCID :: Flag ComponentId + -- ^ explicit CID to be used + , configDeterministic :: Flag Bool + -- ^ be as deterministic as possible + -- (e.g., invariant over GHC, database, + -- etc). Used by the test suite + , configDistPref :: Flag FilePath + -- ^ "dist" prefix + , configCabalFilePath :: Flag FilePath + -- ^ Cabal file to use + , configVerbosity :: Flag Verbosity + -- ^ verbosity level + , configUserInstall :: Flag Bool + -- ^ The --user\/--global flag + , configPackageDBs :: [Maybe PackageDB] + -- ^ Which package DBs to use + , configGHCiLib :: Flag Bool + -- ^ Enable compiling library for GHCi + , configSplitSections :: Flag Bool + -- ^ Enable -split-sections with GHC + , configSplitObjs :: Flag Bool + -- ^ Enable -split-objs with GHC + , configStripExes :: Flag Bool + -- ^ Enable executable stripping + , configStripLibs :: Flag Bool + -- ^ Enable library stripping + , configConstraints :: [PackageVersionConstraint] + -- ^ Additional constraints for + -- dependencies. + , configDependencies :: [GivenComponent] + -- ^ The packages depended on which already exist + , configPromisedDependencies :: [GivenComponent] + -- ^ The packages depended on which doesn't yet exist (i.e. promised). + -- Promising dependencies enables us to configure components in parallel, + -- and avoids expensive builds if they are not necessary. + -- For example, in multi-repl mode, we don't want to build dependencies that + -- are loaded into the interactive session, since we have to build them again. + , configInstantiateWith :: [(ModuleName, Module)] + -- ^ The requested Backpack instantiation. If empty, either this + -- package does not use Backpack, or we just want to typecheck + -- the indefinite package. + , configConfigurationsFlags :: FlagAssignment + , configTests :: Flag Bool + -- ^ Enable test suite compilation + , configBenchmarks :: Flag Bool + -- ^ Enable benchmark compilation + , configCoverage :: Flag Bool + -- ^ Enable program coverage + , configLibCoverage :: Flag Bool + -- ^ Enable program coverage (deprecated) + , configExactConfiguration :: Flag Bool + -- ^ All direct dependencies and flags are provided on the command line by + -- the user via the '--dependency' and '--flags' options. + , configFlagError :: Flag String + -- ^ Halt and show an error message indicating an error in flag assignment + , configRelocatable :: Flag Bool + -- ^ Enable relocatable package built + , configDebugInfo :: Flag DebugInfoLevel + -- ^ Emit debug info. + , configDumpBuildInfo :: Flag DumpBuildInfo + -- ^ Should we dump available build information on build? + -- Dump build information to disk before attempting to build, + -- tooling can parse these files and use them to compile the + -- source files themselves. + , configUseResponseFiles :: Flag Bool + -- ^ Whether to use response files at all. They're used for such tools + -- as haddock, or ld. + , configAllowDependingOnPrivateLibs :: Flag Bool + -- ^ Allow depending on private sublibraries. This is used by external + -- tools (like cabal-install) so they can add multiple-public-libraries + -- compatibility to older ghcs by checking visibility externally. + , configCoverageFor :: Flag [UnitId] + -- ^ The list of libraries to be included in the hpc coverage report for + -- testsuites run with @--enable-coverage@. Notably, this list must exclude + -- indefinite libraries and instantiations because HPC does not support + -- backpack (Nov. 2023). + } + deriving (Generic, Read, Show, Typeable) + +instance Binary ConfigFlags +instance Structured ConfigFlags + +-- | More convenient version of 'configPrograms'. Results in an +-- 'error' if internal invariant is violated. +configPrograms :: WithCallStack (ConfigFlags -> ProgramDb) +configPrograms = + fromMaybe (error "FIXME: remove configPrograms") + . fmap getLast' + . getOption' + . configPrograms_ + +instance Eq ConfigFlags where + (==) a b = + -- configPrograms skipped: not user specified, has no Eq instance + equal configProgramPaths + && equal configProgramArgs + && equal configProgramPathExtra + && equal configHcFlavor + && equal configHcPath + && equal configHcPkg + && equal configVanillaLib + && equal configProfLib + && equal configSharedLib + && equal configStaticLib + && equal configDynExe + && equal configFullyStaticExe + && equal configProfExe + && equal configProf + && equal configProfDetail + && equal configProfLibDetail + && equal configConfigureArgs + && equal configOptimization + && equal configProgPrefix + && equal configProgSuffix + && equal configInstallDirs + && equal configScratchDir + && equal configExtraLibDirs + && equal configExtraLibDirsStatic + && equal configExtraIncludeDirs + && equal configIPID + && equal configDeterministic + && equal configDistPref + && equal configVerbosity + && equal configUserInstall + && equal configPackageDBs + && equal configGHCiLib + && equal configSplitSections + && equal configSplitObjs + && equal configStripExes + && equal configStripLibs + && equal configConstraints + && equal configDependencies + && equal configPromisedDependencies + && equal configConfigurationsFlags + && equal configTests + && equal configBenchmarks + && equal configCoverage + && equal configLibCoverage + && equal configExactConfiguration + && equal configFlagError + && equal configRelocatable + && equal configDebugInfo + && equal configDumpBuildInfo + && equal configUseResponseFiles + && equal configCoverageFor + where + equal f = on (==) f a b + +configAbsolutePaths :: ConfigFlags -> IO ConfigFlags +configAbsolutePaths f = + (\v -> f{configPackageDBs = v}) + `liftM` traverse + (maybe (return Nothing) (liftM Just . absolutePackageDBPath)) + (configPackageDBs f) + +{- FOURMOLU_DISABLE -} +defaultConfigFlags :: ProgramDb -> ConfigFlags +defaultConfigFlags progDb = + emptyConfigFlags + { configArgs = [] + , configPrograms_ = Option' (Just (Last' progDb)) + , configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor + , configVanillaLib = Flag True + , configProfLib = NoFlag + , configSharedLib = NoFlag + , configStaticLib = NoFlag + , configDynExe = Flag False + , configFullyStaticExe = Flag False + , configProfExe = NoFlag + , configProf = NoFlag + , configProfDetail = NoFlag + , configProfLibDetail = NoFlag + , configOptimization = Flag NormalOptimisation + , configProgPrefix = Flag (toPathTemplate "") + , configProgSuffix = Flag (toPathTemplate "") + , configDistPref = NoFlag + , configCabalFilePath = NoFlag + , configVerbosity = Flag normal + , configUserInstall = Flag False -- TODO: reverse this +#if defined(mingw32_HOST_OS) + -- See #8062 and GHC #21019. + , configGHCiLib = Flag False +#else + , configGHCiLib = NoFlag +#endif + , configSplitSections = Flag False + , configSplitObjs = Flag False -- takes longer, so turn off by default + , configStripExes = NoFlag + , configStripLibs = NoFlag + , configTests = Flag False + , configBenchmarks = Flag False + , configCoverage = Flag False + , configLibCoverage = NoFlag + , configExactConfiguration = Flag False + , configFlagError = NoFlag + , configRelocatable = Flag False + , configDebugInfo = Flag NoDebugInfo + , configDumpBuildInfo = NoFlag + , configUseResponseFiles = NoFlag + } +{- FOURMOLU_ENABLE -} + +configureCommand :: ProgramDb -> CommandUI ConfigFlags +configureCommand progDb = + CommandUI + { commandName = "configure" + , commandSynopsis = "Prepare to build the package." + , commandDescription = Just $ \_ -> + wrapText $ + "Configure how the package is built by setting " + ++ "package (and other) flags.\n" + ++ "\n" + ++ "The configuration affects several other commands, " + ++ "including build, test, bench, run, repl.\n" + , commandNotes = Just $ \_pname -> programFlagsDescription progDb + , commandUsage = \pname -> + "Usage: " ++ pname ++ " configure [FLAGS]\n" + , commandDefaultFlags = defaultConfigFlags progDb + , commandOptions = \showOrParseArgs -> + configureOptions showOrParseArgs + ++ programDbPaths + progDb + showOrParseArgs + configProgramPaths + (\v fs -> fs{configProgramPaths = v}) + ++ programDbOption + progDb + showOrParseArgs + configProgramArgs + (\v fs -> fs{configProgramArgs = v}) + ++ programDbOptions + progDb + showOrParseArgs + configProgramArgs + (\v fs -> fs{configProgramArgs = v}) + } + +-- | Inverse to 'dispModSubstEntry'. +parsecModSubstEntry :: ParsecParser (ModuleName, Module) +parsecModSubstEntry = do + k <- parsec + _ <- P.char '=' + v <- parsec + return (k, v) + +-- | Pretty-print a single entry of a module substitution. +dispModSubstEntry :: (ModuleName, Module) -> Disp.Doc +dispModSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v + +configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] +configureOptions showOrParseArgs = + [ optionVerbosity + configVerbosity + (\v flags -> flags{configVerbosity = v}) + , optionDistPref + configDistPref + (\d flags -> flags{configDistPref = d}) + showOrParseArgs + , option + [] + ["compiler"] + "compiler" + configHcFlavor + (\v flags -> flags{configHcFlavor = v}) + ( choiceOpt + [ (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 + "" + ["cabal-file"] + "use this Cabal file" + configCabalFilePath + (\v flags -> flags{configCabalFilePath = v}) + (reqArgFlag "PATH") + , option + "w" + ["with-compiler"] + "give the path to a particular compiler" + configHcPath + (\v flags -> flags{configHcPath = v}) + (reqArgFlag "PATH") + , option + "" + ["with-hc-pkg"] + "give the path to the package tool" + configHcPkg + (\v flags -> flags{configHcPkg = v}) + (reqArgFlag "PATH") + ] + ++ map liftInstallDirs installDirsOptions + ++ [ option + "" + ["program-prefix"] + "prefix to be applied to installed executables" + configProgPrefix + (\v flags -> flags{configProgPrefix = v}) + (reqPathTemplateArgFlag "PREFIX") + , option + "" + ["program-suffix"] + "suffix to be applied to installed executables" + configProgSuffix + (\v flags -> flags{configProgSuffix = v}) + (reqPathTemplateArgFlag "SUFFIX") + , option + "" + ["library-vanilla"] + "Vanilla libraries" + configVanillaLib + (\v flags -> flags{configVanillaLib = v}) + (boolOpt [] []) + , option + "p" + ["library-profiling"] + "Library profiling" + configProfLib + (\v flags -> flags{configProfLib = v}) + (boolOpt "p" []) + , option + "" + ["shared"] + "Shared library" + configSharedLib + (\v flags -> flags{configSharedLib = v}) + (boolOpt [] []) + , option + "" + ["static"] + "Static library" + configStaticLib + (\v flags -> flags{configStaticLib = v}) + (boolOpt [] []) + , option + "" + ["executable-dynamic"] + "Executable dynamic linking" + configDynExe + (\v flags -> flags{configDynExe = v}) + (boolOpt [] []) + , option + "" + ["executable-static"] + "Executable fully static linking" + configFullyStaticExe + (\v flags -> flags{configFullyStaticExe = v}) + (boolOpt [] []) + , option + "" + ["profiling"] + "Executable and library profiling" + configProf + (\v flags -> flags{configProf = v}) + (boolOpt [] []) + , option + "" + ["executable-profiling"] + "Executable profiling (DEPRECATED)" + configProfExe + (\v flags -> flags{configProfExe = v}) + (boolOpt [] []) + , option + "" + ["profiling-detail"] + ( "Profiling detail level for executable and library (default, " + ++ "none, exported-functions, toplevel-functions, all-functions, late)." + ) + configProfDetail + (\v flags -> flags{configProfDetail = v}) + ( reqArg' + "level" + (Flag . flagToProfDetailLevel) + showProfDetailLevelFlag + ) + , option + "" + ["library-profiling-detail"] + "Profiling detail level for libraries only." + configProfLibDetail + (\v flags -> flags{configProfLibDetail = v}) + ( reqArg' + "level" + (Flag . flagToProfDetailLevel) + showProfDetailLevelFlag + ) + , multiOption + "optimization" + configOptimization + (\v flags -> flags{configOptimization = v}) + [ optArgDef' + "n" + (show NoOptimisation, Flag . flagToOptimisationLevel) + ( \f -> case f of + Flag NoOptimisation -> [] + Flag NormalOptimisation -> [Nothing] + Flag MaximumOptimisation -> [Just "2"] + _ -> [] + ) + "O" + ["enable-optimization", "enable-optimisation"] + "Build with optimization (n is 0--2, default is 1)" + , noArg + (Flag NoOptimisation) + [] + ["disable-optimization", "disable-optimisation"] + "Build without optimization" + ] + , multiOption + "debug-info" + configDebugInfo + (\v flags -> flags{configDebugInfo = v}) + [ optArg' + "n" + (Flag . flagToDebugInfoLevel) + ( \f -> case f of + Flag NoDebugInfo -> [] + Flag MinimalDebugInfo -> [Just "1"] + Flag NormalDebugInfo -> [Nothing] + Flag MaximalDebugInfo -> [Just "3"] + _ -> [] + ) + "" + ["enable-debug-info"] + "Emit debug info (n is 0--3, default is 0)" + , noArg + (Flag NoDebugInfo) + [] + ["disable-debug-info"] + "Don't emit debug info" + ] + , multiOption + "build-info" + configDumpBuildInfo + (\v flags -> flags{configDumpBuildInfo = v}) + [ noArg + (Flag DumpBuildInfo) + [] + ["enable-build-info"] + "Enable build information generation during project building" + , noArg + (Flag NoDumpBuildInfo) + [] + ["disable-build-info"] + "Disable build information generation during project building" + ] + , option + "" + ["library-for-ghci"] + "compile library for use with GHCi" + configGHCiLib + (\v flags -> flags{configGHCiLib = v}) + (boolOpt [] []) + , option + "" + ["split-sections"] + "compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)" + configSplitSections + (\v flags -> flags{configSplitSections = v}) + (boolOpt [] []) + , option + "" + ["split-objs"] + "split library into smaller objects to reduce binary sizes (GHC 6.6+)" + configSplitObjs + (\v flags -> flags{configSplitObjs = v}) + (boolOpt [] []) + , option + "" + ["executable-stripping"] + "strip executables upon installation to reduce binary sizes" + configStripExes + (\v flags -> flags{configStripExes = v}) + (boolOpt [] []) + , option + "" + ["library-stripping"] + "strip libraries upon installation to reduce binary sizes" + configStripLibs + (\v flags -> flags{configStripLibs = v}) + (boolOpt [] []) + , option + "" + ["configure-option"] + "Extra option for configure" + configConfigureArgs + (\v flags -> flags{configConfigureArgs = v}) + (reqArg' "OPT" (\x -> [x]) id) + , option + "" + ["user-install"] + "doing a per-user installation" + configUserInstall + (\v flags -> flags{configUserInstall = v}) + (boolOpt' ([], ["user"]) ([], ["global"])) + , option + "" + ["package-db"] + ( "Append the given package database to the list of package" + ++ " databases used (to satisfy dependencies and register into)." + ++ " May be a specific file, 'global' or 'user'. The initial list" + ++ " is ['global'], ['global', 'user'], or ['global', $sandbox]," + ++ " depending on context. Use 'clear' to reset the list to empty." + ++ " See the user guide for details." + ) + configPackageDBs + (\v flags -> flags{configPackageDBs = v}) + (reqArg' "DB" readPackageDbList showPackageDbList) + , option + "f" + ["flags"] + "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." + configConfigurationsFlags + (\v flags -> flags{configConfigurationsFlags = v}) + ( reqArg + "FLAGS" + (parsecToReadE (\err -> "Invalid flag assignment: " ++ err) legacyParsecFlagAssignment) + legacyShowFlagAssignment' + ) + , option + "" + ["extra-include-dirs"] + "A list of directories to search for header files" + configExtraIncludeDirs + (\v flags -> flags{configExtraIncludeDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + , option + "" + ["deterministic"] + "Try to be as deterministic as possible (used by the test suite)" + configDeterministic + (\v flags -> flags{configDeterministic = v}) + (boolOpt [] []) + , option + "" + ["ipid"] + "Installed package ID to compile this package as" + configIPID + (\v flags -> flags{configIPID = v}) + (reqArgFlag "IPID") + , option + "" + ["cid"] + "Installed component ID to compile this component as" + (fmap prettyShow . configCID) + (\v flags -> flags{configCID = fmap mkComponentId v}) + (reqArgFlag "CID") + , option + "" + ["extra-lib-dirs"] + "A list of directories to search for external libraries" + configExtraLibDirs + (\v flags -> flags{configExtraLibDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + , option + "" + ["extra-lib-dirs-static"] + "A list of directories to search for external libraries when linking fully static executables" + configExtraLibDirsStatic + (\v flags -> flags{configExtraLibDirsStatic = v}) + (reqArg' "PATH" (\x -> [x]) id) + , option + "" + ["extra-framework-dirs"] + "A list of directories to search for external frameworks (OS X only)" + configExtraFrameworkDirs + (\v flags -> flags{configExtraFrameworkDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + , option + "" + ["extra-prog-path"] + "A list of directories to search for required programs (in addition to the normal search locations)" + configProgramPathExtra + (\v flags -> flags{configProgramPathExtra = v}) + (reqArg' "PATH" (\x -> toNubList [x]) fromNubList) + , option + "" + ["constraint"] + "A list of additional constraints on the dependencies." + configConstraints + (\v flags -> flags{configConstraints = v}) + ( reqArg + "DEPENDENCY" + (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec)) + (map prettyShow) + ) + , option + "" + ["dependency"] + "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" + configDependencies + (\v flags -> flags{configDependencies = v}) + ( reqArg + "NAME[:COMPONENT_NAME]=CID" + (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent)) + (map prettyGivenComponent) + ) + , option + "" + ["promised-dependency"] + "A list of promised dependencies. E.g., --promised-dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" + configPromisedDependencies + (\v flags -> flags{configPromisedDependencies = v}) + ( reqArg + "NAME[:COMPONENT_NAME]=CID" + (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent)) + (map prettyGivenComponent) + ) + , option + "" + ["instantiate-with"] + "A mapping of signature names to concrete module instantiations." + configInstantiateWith + (\v flags -> flags{configInstantiateWith = v}) + ( reqArg + "NAME=MOD" + (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (: []) parsecModSubstEntry)) + (map (Disp.renderStyle defaultStyle . dispModSubstEntry)) + ) + , option + "" + ["tests"] + "dependency checking and compilation for test suites listed in the package description file." + configTests + (\v flags -> flags{configTests = v}) + (boolOpt [] []) + , option + "" + ["coverage"] + "build package with Haskell Program Coverage. (GHC only)" + configCoverage + (\v flags -> flags{configCoverage = v}) + (boolOpt [] []) + , option + "" + ["library-coverage"] + "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" + configLibCoverage + (\v flags -> flags{configLibCoverage = v}) + (boolOpt [] []) + , option + "" + ["exact-configuration"] + "All direct dependencies and flags are provided on the command line." + configExactConfiguration + (\v flags -> flags{configExactConfiguration = v}) + trueArg + , option + "" + ["benchmarks"] + "dependency checking and compilation for benchmarks listed in the package description file." + configBenchmarks + (\v flags -> flags{configBenchmarks = v}) + (boolOpt [] []) + , option + "" + ["relocatable"] + "building a package that is relocatable. (GHC only)" + configRelocatable + (\v flags -> flags{configRelocatable = v}) + (boolOpt [] []) + , option + "" + ["response-files"] + "enable workaround for old versions of programs like \"ar\" that do not support @file arguments" + configUseResponseFiles + (\v flags -> flags{configUseResponseFiles = v}) + (boolOpt' ([], ["disable-response-files"]) ([], [])) + , option + "" + ["allow-depending-on-private-libs"] + ( "Allow depending on private libraries. " + ++ "If set, the library visibility check MUST be done externally." + ) + configAllowDependingOnPrivateLibs + (\v flags -> flags{configAllowDependingOnPrivateLibs = v}) + trueArg + , option + "" + ["coverage-for"] + "A list of unit-ids of libraries to include in the Haskell Program Coverage report." + configCoverageFor + ( \v flags -> + flags + { configCoverageFor = + mergeListFlag (configCoverageFor flags) v + } + ) + ( reqArg' + "UNITID" + (Flag . (: []) . fromString) + (fmap prettyShow . fromFlagOrDefault []) + ) + ] + where + liftInstallDirs = + liftOption configInstallDirs (\v flags -> flags{configInstallDirs = v}) + + reqPathTemplateArgFlag title _sf _lf d get set = + reqArgFlag + title + _sf + _lf + d + (fmap fromPathTemplate . get) + (set . fmap toPathTemplate) + +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 other) + +showPackageDbList :: [Maybe PackageDB] -> [String] +showPackageDbList = map showPackageDb + +-- | Show a PackageDB stack entry +-- +-- @since 3.7.0.0 +showPackageDb :: Maybe PackageDB -> String +showPackageDb Nothing = "clear" +showPackageDb (Just GlobalPackageDB) = "global" +showPackageDb (Just UserPackageDB) = "user" +showPackageDb (Just (SpecificPackageDB db)) = db + +showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String] +showProfDetailLevelFlag NoFlag = [] +showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] + +parsecGivenComponent :: ParsecParser GivenComponent +parsecGivenComponent = do + pn <- parsec + ln <- P.option LMainLibName $ do + _ <- P.char ':' + ucn <- parsec + return $ + if unUnqualComponentName ucn == unPackageName pn + then LMainLibName + else LSubLibName ucn + _ <- P.char '=' + cid <- parsec + return $ GivenComponent pn ln cid + +prettyGivenComponent :: GivenComponent -> String +prettyGivenComponent (GivenComponent pn cn cid) = + prettyShow pn + ++ case cn of + LMainLibName -> "" + LSubLibName n -> ":" ++ prettyShow n + ++ "=" + ++ prettyShow cid + +installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] +installDirsOptions = + [ option + "" + ["prefix"] + "bake this prefix in preparation of installation" + prefix + (\v flags -> flags{prefix = v}) + installDirArg + , option + "" + ["bindir"] + "installation directory for executables" + bindir + (\v flags -> flags{bindir = v}) + installDirArg + , option + "" + ["libdir"] + "installation directory for libraries" + libdir + (\v flags -> flags{libdir = v}) + installDirArg + , option + "" + ["libsubdir"] + "subdirectory of libdir in which libs are installed" + libsubdir + (\v flags -> flags{libsubdir = v}) + installDirArg + , option + "" + ["dynlibdir"] + "installation directory for dynamic libraries" + dynlibdir + (\v flags -> flags{dynlibdir = v}) + installDirArg + , option + "" + ["libexecdir"] + "installation directory for program executables" + libexecdir + (\v flags -> flags{libexecdir = v}) + installDirArg + , option + "" + ["libexecsubdir"] + "subdirectory of libexecdir in which private executables are installed" + libexecsubdir + (\v flags -> flags{libexecsubdir = v}) + installDirArg + , option + "" + ["datadir"] + "installation directory for read-only data" + datadir + (\v flags -> flags{datadir = v}) + installDirArg + , option + "" + ["datasubdir"] + "subdirectory of datadir in which data files are installed" + datasubdir + (\v flags -> flags{datasubdir = v}) + installDirArg + , option + "" + ["docdir"] + "installation directory for documentation" + docdir + (\v flags -> flags{docdir = v}) + installDirArg + , option + "" + ["htmldir"] + "installation directory for HTML documentation" + htmldir + (\v flags -> flags{htmldir = v}) + installDirArg + , option + "" + ["haddockdir"] + "installation directory for haddock interfaces" + haddockdir + (\v flags -> flags{haddockdir = v}) + installDirArg + , option + "" + ["sysconfdir"] + "installation directory for configuration files" + sysconfdir + (\v flags -> flags{sysconfdir = v}) + installDirArg + ] + where + installDirArg _sf _lf d get set = + reqArgFlag + "DIR" + _sf + _lf + d + (fmap fromPathTemplate . get) + (set . fmap toPathTemplate) + +emptyConfigFlags :: ConfigFlags +emptyConfigFlags = mempty + +instance Monoid ConfigFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ConfigFlags where + (<>) = gmappend + +-- | Arguments to pass to a @configure@ script, e.g. generated by +-- @autoconf@. +configureArgs :: Bool -> ConfigFlags -> [String] +configureArgs bcHack flags = + hc_flag + ++ optFlag "with-hc-pkg" configHcPkg + ++ optFlag' "prefix" prefix + ++ optFlag' "bindir" bindir + ++ optFlag' "libdir" libdir + ++ optFlag' "libexecdir" libexecdir + ++ optFlag' "datadir" datadir + ++ optFlag' "sysconfdir" sysconfdir + ++ configConfigureArgs flags + where + hc_flag = case (configHcFlavor flags, configHcPath flags) of + (_, Flag hc_path) -> [hc_flag_name ++ hc_path] + (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc] + (NoFlag, NoFlag) -> [] + hc_flag_name + -- TODO kill off thic bc hack when defaultUserHooks is removed. + | bcHack = "--with-hc=" + | otherwise = "--with-compiler=" + optFlag name config_field = case config_field flags of + Flag p -> ["--" ++ name ++ "=" ++ p] + NoFlag -> [] + optFlag' name config_field = + optFlag + name + ( fmap fromPathTemplate + . config_field + . configInstallDirs + ) diff --git a/src/Distribution/Simple/Setup/Copy.hs b/src/Distribution/Simple/Setup/Copy.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Copy.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Setup.Copy +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Definition of the copy command-line options. +-- See: @Distribution.Simple.Setup@ +module Distribution.Simple.Setup.Copy + ( CopyFlags (..) + , emptyCopyFlags + , defaultCopyFlags + , copyCommand + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.ReadE +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs +import Distribution.Simple.Utils +import Distribution.Verbosity + +import Distribution.Simple.Setup.Common + +-- ------------------------------------------------------------ + +-- * Copy flags + +-- ------------------------------------------------------------ + +-- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) +data CopyFlags = CopyFlags + { copyDest :: Flag CopyDest + , copyDistPref :: Flag FilePath + , copyVerbosity :: Flag Verbosity + , -- This is the same hack as in 'buildArgs'. But I (ezyang) don't + -- think it's a hack, it's the right way to make hooks more robust + -- TODO: Stop using this eventually when 'UserHooks' gets changed + copyArgs :: [String] + , copyCabalFilePath :: Flag FilePath + } + deriving (Show, Generic) + +instance Binary CopyFlags +instance Structured CopyFlags + +defaultCopyFlags :: CopyFlags +defaultCopyFlags = + CopyFlags + { copyDest = Flag NoCopyDest + , copyDistPref = NoFlag + , copyVerbosity = Flag normal + , copyArgs = [] + , copyCabalFilePath = mempty + } + +copyCommand :: CommandUI CopyFlags +copyCommand = + CommandUI + { commandName = "copy" + , commandSynopsis = "Copy the files of all/specific components to install locations." + , commandDescription = Just $ \_ -> + wrapText $ + "Components encompass executables and libraries. " + ++ "Does not call register, and allows a prefix at install time. " + ++ "Without the --destdir flag, configure determines location.\n" + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " copy " + ++ " All the components in the package\n" + ++ " " + ++ pname + ++ " copy foo " + ++ " A component (i.e. lib, exe, test suite)" + , commandUsage = + usageAlternatives "copy" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultCopyFlags + , commandOptions = \showOrParseArgs -> case showOrParseArgs of + ShowArgs -> + filter + ( (`notElem` ["target-package-db"]) + . optionName + ) + $ copyOptions ShowArgs + ParseArgs -> copyOptions ParseArgs + } + +copyOptions :: ShowOrParseArgs -> [OptionField CopyFlags] +copyOptions showOrParseArgs = + [ optionVerbosity copyVerbosity (\v flags -> flags{copyVerbosity = v}) + , optionDistPref + copyDistPref + (\d flags -> flags{copyDistPref = d}) + showOrParseArgs + , option + "" + ["destdir"] + "directory to copy files to, prepended to installation directories" + copyDest + ( \v flags -> case copyDest flags of + Flag (CopyToDb _) -> error "Use either 'destdir' or 'target-package-db'." + _ -> flags{copyDest = v} + ) + ( reqArg + "DIR" + (succeedReadE (Flag . CopyTo)) + (\f -> case f of Flag (CopyTo p) -> [p]; _ -> []) + ) + , option + "" + ["target-package-db"] + "package database to copy files into. Required when using ${pkgroot} prefix." + copyDest + ( \v flags -> case copyDest flags of + NoFlag -> flags{copyDest = v} + Flag NoCopyDest -> flags{copyDest = v} + _ -> error "Use either 'destdir' or 'target-package-db'." + ) + ( reqArg + "DATABASE" + (succeedReadE (Flag . CopyToDb)) + (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> []) + ) + ] + +emptyCopyFlags :: CopyFlags +emptyCopyFlags = mempty + +instance Monoid CopyFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup CopyFlags where + (<>) = gmappend diff --git a/src/Distribution/Simple/Setup/Global.hs b/src/Distribution/Simple/Setup/Global.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Global.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Setup.Global +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Definition of the global command-line options. +-- See: @Distribution.Simple.Setup@ +module Distribution.Simple.Setup.Global + ( GlobalFlags (..) + , emptyGlobalFlags + , defaultGlobalFlags + , globalCommand + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import Distribution.Simple.Flag +import Distribution.Simple.Setup.Common + +-- ------------------------------------------------------------ + +-- * Global flags + +-- ------------------------------------------------------------ + +-- In fact since individual flags types are monoids and these are just sets of +-- flags then they are also monoids pointwise. This turns out to be really +-- useful. The mempty is the set of empty flags and mappend allows us to +-- override specific flags. For example we can start with default flags and +-- override with the ones we get from a file or the command line, or both. + +-- | Flags that apply at the top level, not to any sub-command. +data GlobalFlags = GlobalFlags + { globalVersion :: Flag Bool + , globalNumericVersion :: Flag Bool + } + deriving (Generic, Typeable) + +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = + GlobalFlags + { globalVersion = Flag False + , globalNumericVersion = Flag False + } + +globalCommand :: [Command action] -> CommandUI GlobalFlags +globalCommand commands = + CommandUI + { commandName = "" + , commandSynopsis = "" + , commandUsage = \pname -> + "This Setup program uses the Haskell Cabal Infrastructure.\n" + ++ "See http://www.haskell.org/cabal/ for more information.\n" + ++ "\n" + ++ "Usage: " + ++ pname + ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n" + , commandDescription = Just $ \pname -> + let + commands' = commands ++ [commandAddAction helpCommandUI undefined] + cmdDescs = getNormalCommandDescriptions commands' + maxlen = maximum $ [length name | (name, _) <- cmdDescs] + align str = str ++ replicate (maxlen - length str) ' ' + in + "Commands:\n" + ++ unlines + [ " " ++ align name ++ " " ++ descr + | (name, descr) <- cmdDescs + ] + ++ "\n" + ++ "For more information about a command use\n" + ++ " " + ++ pname + ++ " COMMAND --help\n\n" + ++ "Typical steps for installing Cabal packages:\n" + ++ concat + [ " " ++ pname ++ " " ++ x ++ "\n" + | x <- ["configure", "build", "install"] + ] + , commandNotes = Nothing + , commandDefaultFlags = defaultGlobalFlags + , commandOptions = \_ -> + [ option + ['V'] + ["version"] + "Print version information" + globalVersion + (\v flags -> flags{globalVersion = v}) + trueArg + , option + [] + ["numeric-version"] + "Print just the version number" + globalNumericVersion + (\v flags -> flags{globalNumericVersion = v}) + trueArg + ] + } + +emptyGlobalFlags :: GlobalFlags +emptyGlobalFlags = mempty + +instance Monoid GlobalFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup GlobalFlags where + (<>) = gmappend diff --git a/src/Distribution/Simple/Setup/Haddock.hs b/src/Distribution/Simple/Setup/Haddock.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Haddock.hs @@ -0,0 +1,606 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Setup.Haddock +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Definition of the haddock command-line options. +-- See: @Distribution.Simple.Setup@ +module Distribution.Simple.Setup.Haddock + ( HaddockTarget (..) + , HaddockFlags (..) + , emptyHaddockFlags + , defaultHaddockFlags + , haddockCommand + , Visibility (..) + , HaddockProjectFlags (..) + , emptyHaddockProjectFlags + , defaultHaddockProjectFlags + , haddockProjectCommand + , haddockOptions + , haddockProjectOptions + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import qualified Distribution.Compat.CharParsing as P +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs +import Distribution.Simple.Program +import Distribution.Verbosity +import qualified Text.PrettyPrint as Disp + +import Distribution.Simple.Setup.Common + +-- ------------------------------------------------------------ + +-- * Haddock flags + +-- ------------------------------------------------------------ + +-- | When we build haddock documentation, there are two cases: +-- +-- 1. We build haddocks only for the current development version, +-- intended for local use and not for distribution. In this case, +-- we store the generated documentation in @/doc/html/@. +-- +-- 2. We build haddocks for intended for uploading them to hackage. +-- In this case, we need to follow the layout that hackage expects +-- from documentation tarballs, and we might also want to use different +-- flags than for development builds, so in this case we store the generated +-- documentation in @/doc/html/-docs@. +data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic, Typeable) + +instance Binary HaddockTarget +instance Structured HaddockTarget + +instance Pretty HaddockTarget where + pretty ForHackage = Disp.text "for-hackage" + pretty ForDevelopment = Disp.text "for-development" + +instance Parsec HaddockTarget where + parsec = + P.choice + [ P.try $ P.string "for-hackage" >> return ForHackage + , P.string "for-development" >> return ForDevelopment + ] + +data HaddockFlags = HaddockFlags + { haddockProgramPaths :: [(String, FilePath)] + , haddockProgramArgs :: [(String, [String])] + , haddockHoogle :: Flag Bool + , haddockHtml :: Flag Bool + , haddockHtmlLocation :: Flag String + , haddockForHackage :: Flag HaddockTarget + , haddockExecutables :: Flag Bool + , haddockTestSuites :: Flag Bool + , haddockBenchmarks :: Flag Bool + , haddockForeignLibs :: Flag Bool + , haddockInternal :: Flag Bool + , haddockCss :: Flag FilePath + , haddockLinkedSource :: Flag Bool + , haddockQuickJump :: Flag Bool + , haddockHscolourCss :: Flag FilePath + , haddockContents :: Flag PathTemplate + , haddockIndex :: Flag PathTemplate + , haddockDistPref :: Flag FilePath + , haddockKeepTempFiles :: Flag Bool + , haddockVerbosity :: Flag Verbosity + , haddockCabalFilePath :: Flag FilePath + , haddockBaseUrl :: Flag String + , haddockLib :: Flag String + , haddockOutputDir :: Flag FilePath + , haddockArgs :: [String] + } + deriving (Show, Generic, Typeable) + +instance Binary HaddockFlags +instance Structured HaddockFlags + +defaultHaddockFlags :: HaddockFlags +defaultHaddockFlags = + HaddockFlags + { haddockProgramPaths = mempty + , haddockProgramArgs = [] + , haddockHoogle = Flag False + , haddockHtml = Flag False + , haddockHtmlLocation = NoFlag + , haddockForHackage = NoFlag + , haddockExecutables = Flag False + , haddockTestSuites = Flag False + , haddockBenchmarks = Flag False + , haddockForeignLibs = Flag False + , haddockInternal = Flag False + , haddockCss = NoFlag + , haddockLinkedSource = Flag False + , haddockQuickJump = Flag False + , haddockHscolourCss = NoFlag + , haddockContents = NoFlag + , haddockDistPref = NoFlag + , haddockKeepTempFiles = Flag False + , haddockVerbosity = Flag normal + , haddockCabalFilePath = mempty + , haddockIndex = NoFlag + , haddockBaseUrl = NoFlag + , haddockLib = NoFlag + , haddockOutputDir = NoFlag + , haddockArgs = mempty + } + +haddockCommand :: CommandUI HaddockFlags +haddockCommand = + CommandUI + { commandName = "haddock" + , commandSynopsis = "Generate Haddock HTML documentation." + , commandDescription = Just $ \_ -> + "Requires the program haddock, version 2.x.\n" + , commandNotes = Nothing + , commandUsage = + usageAlternatives "haddock" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultHaddockFlags + , commandOptions = \showOrParseArgs -> + haddockOptions showOrParseArgs + ++ programDbPaths + progDb + ParseArgs + haddockProgramPaths + (\v flags -> flags{haddockProgramPaths = v}) + ++ programDbOption + progDb + showOrParseArgs + haddockProgramArgs + (\v fs -> fs{haddockProgramArgs = v}) + ++ programDbOptions + progDb + ParseArgs + haddockProgramArgs + (\v flags -> flags{haddockProgramArgs = v}) + } + where + progDb = + addKnownProgram haddockProgram $ + addKnownProgram ghcProgram $ + emptyProgramDb + +haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] +haddockOptions showOrParseArgs = + [ optionVerbosity + haddockVerbosity + (\v flags -> flags{haddockVerbosity = v}) + , optionDistPref + haddockDistPref + (\d flags -> flags{haddockDistPref = d}) + showOrParseArgs + , option + "" + ["keep-temp-files"] + "Keep temporary files" + haddockKeepTempFiles + (\b flags -> flags{haddockKeepTempFiles = b}) + trueArg + , option + "" + ["hoogle"] + "Generate a hoogle database" + haddockHoogle + (\v flags -> flags{haddockHoogle = v}) + trueArg + , option + "" + ["html"] + "Generate HTML documentation (the default)" + haddockHtml + (\v flags -> flags{haddockHtml = v}) + trueArg + , option + "" + ["html-location"] + "Location of HTML documentation for pre-requisite packages" + haddockHtmlLocation + (\v flags -> flags{haddockHtmlLocation = v}) + (reqArgFlag "URL") + , option + "" + ["for-hackage"] + "Collection of flags to generate documentation suitable for upload to hackage" + haddockForHackage + (\v flags -> flags{haddockForHackage = v}) + (noArg (Flag ForHackage)) + , option + "" + ["executables"] + "Run haddock for Executables targets" + haddockExecutables + (\v flags -> flags{haddockExecutables = v}) + trueArg + , option + "" + ["tests"] + "Run haddock for Test Suite targets" + haddockTestSuites + (\v flags -> flags{haddockTestSuites = v}) + trueArg + , option + "" + ["benchmarks"] + "Run haddock for Benchmark targets" + haddockBenchmarks + (\v flags -> flags{haddockBenchmarks = v}) + trueArg + , option + "" + ["foreign-libraries"] + "Run haddock for Foreign Library targets" + haddockForeignLibs + (\v flags -> flags{haddockForeignLibs = v}) + trueArg + , option + "" + ["all"] + "Run haddock for all targets" + ( \f -> + allFlags + [ haddockExecutables f + , haddockTestSuites f + , haddockBenchmarks f + , haddockForeignLibs f + ] + ) + ( \v flags -> + flags + { haddockExecutables = v + , haddockTestSuites = v + , haddockBenchmarks = v + , haddockForeignLibs = v + } + ) + trueArg + , option + "" + ["internal"] + "Run haddock for internal modules and include all symbols" + haddockInternal + (\v flags -> flags{haddockInternal = v}) + trueArg + , option + "" + ["css"] + "Use PATH as the haddock stylesheet" + haddockCss + (\v flags -> flags{haddockCss = v}) + (reqArgFlag "PATH") + , option + "" + ["hyperlink-source", "hyperlink-sources", "hyperlinked-source"] + "Hyperlink the documentation to the source code" + haddockLinkedSource + (\v flags -> flags{haddockLinkedSource = v}) + trueArg + , option + "" + ["quickjump"] + "Generate an index for interactive documentation navigation" + haddockQuickJump + (\v flags -> flags{haddockQuickJump = v}) + trueArg + , option + "" + ["hscolour-css"] + "Use PATH as the HsColour stylesheet" + haddockHscolourCss + (\v flags -> flags{haddockHscolourCss = v}) + (reqArgFlag "PATH") + , option + "" + ["contents-location"] + "Bake URL in as the location for the contents page" + haddockContents + (\v flags -> flags{haddockContents = v}) + ( reqArg' + "URL" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate) + ) + , option + "" + ["index-location"] + "Use a separately-generated HTML index" + haddockIndex + (\v flags -> flags{haddockIndex = v}) + ( reqArg' + "URL" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate) + ) + , option + "" + ["base-url"] + "Base URL for static files." + haddockBaseUrl + (\v flags -> flags{haddockBaseUrl = v}) + (reqArgFlag "URL") + , option + "" + ["lib"] + "location of Haddocks static / auxiliary files" + haddockLib + (\v flags -> flags{haddockLib = v}) + (reqArgFlag "DIR") + , option + "" + ["output-dir"] + "Generate haddock documentation into this directory. This flag is provided as a technology preview and is subject to change in the next releases." + haddockOutputDir + (\v flags -> flags{haddockOutputDir = v}) + (reqArgFlag "DIR") + ] + +emptyHaddockFlags :: HaddockFlags +emptyHaddockFlags = mempty + +instance Monoid HaddockFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup HaddockFlags where + (<>) = gmappend + +-- ------------------------------------------------------------ + +-- * HaddocksFlags flags + +-- ------------------------------------------------------------ + +-- | Governs whether modules from a given interface should be visible or +-- hidden in the Haddock generated content page. We don't expose this +-- functionality to the user, but simply use 'Visible' for only local packages. +-- Visibility of modules is available since @haddock-2.26.1@. +data Visibility = Visible | Hidden + deriving (Eq, Show) + +data HaddockProjectFlags = HaddockProjectFlags + { 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` + -- * `--gen-index` + -- * `--gen-contents` + -- * `--hyperlinked-source` + , -- options passed to @haddock@ via 'createHaddockIndex' + haddockProjectDir :: Flag String + -- ^ output directory of combined haddocks, the default is './haddocks' + , haddockProjectPrologue :: Flag String + , haddockProjectInterfaces :: Flag [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)] + -- ^ 'haddocksInterfaces' is inferred by the 'haddocksAction'; currently not + -- exposed to the user. + , -- options passed to @haddock@ via 'HaddockFlags' when building + -- documentation + + haddockProjectProgramPaths :: [(String, FilePath)] + , haddockProjectProgramArgs :: [(String, [String])] + , haddockProjectHoogle :: Flag Bool + , -- haddockHtml is not supported + haddockProjectHtmlLocation :: Flag String + , -- haddockForHackage is not supported + haddockProjectExecutables :: Flag Bool + , haddockProjectTestSuites :: Flag Bool + , haddockProjectBenchmarks :: Flag Bool + , haddockProjectForeignLibs :: Flag Bool + , haddockProjectInternal :: Flag Bool + , haddockProjectCss :: Flag FilePath + , haddockProjectHscolourCss :: Flag FilePath + , -- 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 + haddockProjectLib :: Flag String + , haddockProjectOutputDir :: Flag FilePath + } + deriving (Show, Generic, Typeable) + +defaultHaddockProjectFlags :: HaddockProjectFlags +defaultHaddockProjectFlags = + HaddockProjectFlags + { haddockProjectHackage = Flag False + , haddockProjectDir = Flag "./haddocks" + , haddockProjectPrologue = NoFlag + , haddockProjectTestSuites = Flag False + , haddockProjectProgramPaths = mempty + , haddockProjectProgramArgs = mempty + , haddockProjectHoogle = Flag False + , haddockProjectHtmlLocation = NoFlag + , haddockProjectExecutables = Flag False + , haddockProjectBenchmarks = Flag False + , haddockProjectForeignLibs = Flag False + , haddockProjectInternal = Flag False + , haddockProjectCss = NoFlag + , haddockProjectHscolourCss = NoFlag + , haddockProjectKeepTempFiles = Flag False + , haddockProjectVerbosity = Flag normal + , haddockProjectLib = NoFlag + , haddockProjectOutputDir = NoFlag + , haddockProjectInterfaces = NoFlag + } + +haddockProjectCommand :: CommandUI HaddockProjectFlags +haddockProjectCommand = + CommandUI + { commandName = "v2-haddock-project" + , commandSynopsis = "Generate Haddocks HTML documentation for the cabal project." + , commandDescription = Just $ \_ -> + "Requires the program haddock, version 2.26.\n" + , commandNotes = Nothing + , commandUsage = + usageAlternatives "haddock-project" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultHaddockProjectFlags + , commandOptions = \showOrParseArgs -> + haddockProjectOptions showOrParseArgs + ++ programDbPaths + progDb + ParseArgs + haddockProjectProgramPaths + (\v flags -> flags{haddockProjectProgramPaths = v}) + ++ programDbOption + progDb + showOrParseArgs + haddockProjectProgramArgs + (\v fs -> fs{haddockProjectProgramArgs = v}) + ++ programDbOptions + progDb + ParseArgs + haddockProjectProgramArgs + (\v flags -> flags{haddockProjectProgramArgs = v}) + } + where + progDb = + addKnownProgram haddockProgram $ + 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 + "" + ["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 + "" + ["lib"] + "location of Haddocks static / auxiliary files" + haddockProjectLib + (\v flags -> flags{haddockProjectLib = v}) + (reqArgFlag "DIR") + , option + "" + ["output-dir"] + "Generate haddock documentation into this directory. This flag is provided as a technology preview and is subject to change in the next releases." + haddockProjectOutputDir + (\v flags -> flags{haddockProjectOutputDir = v}) + (reqArgFlag "DIR") + ] + +emptyHaddockProjectFlags :: HaddockProjectFlags +emptyHaddockProjectFlags = mempty + +instance Monoid HaddockProjectFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup HaddockProjectFlags where + (<>) = gmappend diff --git a/src/Distribution/Simple/Setup/Hscolour.hs b/src/Distribution/Simple/Setup/Hscolour.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Hscolour.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Setup.Hscolour +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Definition of the hscolour command-line options. +-- See: @Distribution.Simple.Setup@ +module Distribution.Simple.Setup.Hscolour + ( HscolourFlags (..) + , emptyHscolourFlags + , defaultHscolourFlags + , hscolourCommand + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import Distribution.Simple.Flag +import Distribution.Verbosity + +import Distribution.Simple.Setup.Common + +-- ------------------------------------------------------------ + +-- * HsColour flags + +-- ------------------------------------------------------------ + +data HscolourFlags = HscolourFlags + { hscolourCSS :: Flag FilePath + , hscolourExecutables :: Flag Bool + , hscolourTestSuites :: Flag Bool + , hscolourBenchmarks :: Flag Bool + , hscolourForeignLibs :: Flag Bool + , hscolourDistPref :: Flag FilePath + , hscolourVerbosity :: Flag Verbosity + , hscolourCabalFilePath :: Flag FilePath + } + deriving (Show, Generic, Typeable) + +instance Binary HscolourFlags +instance Structured HscolourFlags + +emptyHscolourFlags :: HscolourFlags +emptyHscolourFlags = mempty + +defaultHscolourFlags :: HscolourFlags +defaultHscolourFlags = + HscolourFlags + { hscolourCSS = NoFlag + , hscolourExecutables = Flag False + , hscolourTestSuites = Flag False + , hscolourBenchmarks = Flag False + , hscolourDistPref = NoFlag + , hscolourForeignLibs = Flag False + , hscolourVerbosity = Flag normal + , hscolourCabalFilePath = mempty + } + +instance Monoid HscolourFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup HscolourFlags where + (<>) = gmappend + +hscolourCommand :: CommandUI HscolourFlags +hscolourCommand = + CommandUI + { commandName = "hscolour" + , commandSynopsis = + "Generate HsColour colourised code, in HTML format." + , commandDescription = Just (\_ -> "Requires the hscolour program.\n") + , commandNotes = Just $ \_ -> + "Deprecated in favour of 'cabal haddock --hyperlink-source'." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " hscolour [FLAGS]\n" + , commandDefaultFlags = defaultHscolourFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity + hscolourVerbosity + (\v flags -> flags{hscolourVerbosity = v}) + , optionDistPref + hscolourDistPref + (\d flags -> flags{hscolourDistPref = d}) + showOrParseArgs + , option + "" + ["executables"] + "Run hscolour for Executables targets" + hscolourExecutables + (\v flags -> flags{hscolourExecutables = v}) + trueArg + , option + "" + ["tests"] + "Run hscolour for Test Suite targets" + hscolourTestSuites + (\v flags -> flags{hscolourTestSuites = v}) + trueArg + , option + "" + ["benchmarks"] + "Run hscolour for Benchmark targets" + hscolourBenchmarks + (\v flags -> flags{hscolourBenchmarks = v}) + trueArg + , option + "" + ["foreign-libraries"] + "Run hscolour for Foreign Library targets" + hscolourForeignLibs + (\v flags -> flags{hscolourForeignLibs = v}) + trueArg + , option + "" + ["all"] + "Run hscolour for all targets" + ( \f -> + allFlags + [ hscolourExecutables f + , hscolourTestSuites f + , hscolourBenchmarks f + , hscolourForeignLibs f + ] + ) + ( \v flags -> + flags + { hscolourExecutables = v + , hscolourTestSuites = v + , hscolourBenchmarks = v + , hscolourForeignLibs = v + } + ) + trueArg + , option + "" + ["css"] + "Use a cascading style sheet" + hscolourCSS + (\v flags -> flags{hscolourCSS = v}) + (reqArgFlag "PATH") + ] + } diff --git a/src/Distribution/Simple/Setup/Install.hs b/src/Distribution/Simple/Setup/Install.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Install.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Setup.Install +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Definition of the install command-line options. +-- See: @Distribution.Simple.Setup@ +module Distribution.Simple.Setup.Install + ( InstallFlags (..) + , emptyInstallFlags + , defaultInstallFlags + , installCommand + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.ReadE +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs +import Distribution.Simple.Utils +import Distribution.Verbosity + +import Distribution.Simple.Setup.Common + +-- ------------------------------------------------------------ + +-- * Install flags + +-- ------------------------------------------------------------ + +-- | Flags to @install@: (package db, verbosity) +data InstallFlags = InstallFlags + { installPackageDB :: Flag PackageDB + , installDest :: Flag CopyDest + , installDistPref :: Flag FilePath + , installUseWrapper :: Flag Bool + , installInPlace :: Flag Bool + , installVerbosity :: Flag Verbosity + , -- this is only here, because we can not + -- change the hooks API. + installCabalFilePath :: Flag FilePath + } + deriving (Show, Generic) + +defaultInstallFlags :: InstallFlags +defaultInstallFlags = + InstallFlags + { installPackageDB = NoFlag + , installDest = Flag NoCopyDest + , installDistPref = NoFlag + , installUseWrapper = Flag False + , installInPlace = Flag False + , installVerbosity = Flag normal + , installCabalFilePath = mempty + } + +installCommand :: CommandUI InstallFlags +installCommand = + CommandUI + { commandName = "install" + , commandSynopsis = + "Copy the files into the install locations. Run register." + , commandDescription = Just $ \_ -> + wrapText $ + "Unlike the copy command, install calls the register command. " + ++ "If you want to install into a location that is not what was " + ++ "specified in the configure step, use the copy command.\n" + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " install [FLAGS]\n" + , commandDefaultFlags = defaultInstallFlags + , commandOptions = \showOrParseArgs -> case showOrParseArgs of + ShowArgs -> + filter + ( (`notElem` ["target-package-db"]) + . optionName + ) + $ installOptions ShowArgs + ParseArgs -> installOptions ParseArgs + } + +installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] +installOptions showOrParseArgs = + [ optionVerbosity installVerbosity (\v flags -> flags{installVerbosity = v}) + , optionDistPref + installDistPref + (\d flags -> flags{installDistPref = d}) + showOrParseArgs + , option + "" + ["inplace"] + "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" + installInPlace + (\v flags -> flags{installInPlace = v}) + trueArg + , option + "" + ["shell-wrappers"] + "using shell script wrappers around executables" + installUseWrapper + (\v flags -> flags{installUseWrapper = v}) + (boolOpt [] []) + , option + "" + ["package-db"] + "" + installPackageDB + (\v flags -> flags{installPackageDB = v}) + ( choiceOpt + [ + ( Flag UserPackageDB + , ([], ["user"]) + , "upon configuration register this package in the user's local package database" + ) + , + ( Flag GlobalPackageDB + , ([], ["global"]) + , "(default) upon configuration register this package in the system-wide package database" + ) + ] + ) + , option + "" + ["target-package-db"] + "package database to install into. Required when using ${pkgroot} prefix." + installDest + (\v flags -> flags{installDest = v}) + ( reqArg + "DATABASE" + (succeedReadE (Flag . CopyToDb)) + (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> []) + ) + ] + +emptyInstallFlags :: InstallFlags +emptyInstallFlags = mempty + +instance Monoid InstallFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup InstallFlags where + (<>) = gmappend diff --git a/src/Distribution/Simple/Setup/Register.hs b/src/Distribution/Simple/Setup/Register.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Register.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Setup.Register +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Definition of the register command-line options. +-- See: @Distribution.Simple.Setup@ +module Distribution.Simple.Setup.Register + ( RegisterFlags (..) + , emptyRegisterFlags + , defaultRegisterFlags + , registerCommand + , unregisterCommand + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Verbosity + +import Distribution.Simple.Setup.Common + +-- ------------------------------------------------------------ + +-- * Register flags + +-- ------------------------------------------------------------ + +-- | Flags to @register@ and @unregister@: (user package, gen-script, +-- in-place, verbosity) +data RegisterFlags = RegisterFlags + { regPackageDB :: Flag PackageDB + , regGenScript :: Flag Bool + , regGenPkgConf :: Flag (Maybe FilePath) + , regInPlace :: Flag Bool + , regDistPref :: Flag FilePath + , regPrintId :: Flag Bool + , regVerbosity :: Flag Verbosity + , -- Same as in 'buildArgs' and 'copyArgs' + regArgs :: [String] + , regCabalFilePath :: Flag FilePath + } + deriving (Show, Generic, Typeable) + +defaultRegisterFlags :: RegisterFlags +defaultRegisterFlags = + RegisterFlags + { regPackageDB = NoFlag + , regGenScript = Flag False + , regGenPkgConf = NoFlag + , regInPlace = Flag False + , regDistPref = NoFlag + , regPrintId = Flag False + , regArgs = [] + , regCabalFilePath = mempty + , regVerbosity = Flag normal + } + +registerCommand :: CommandUI RegisterFlags +registerCommand = + CommandUI + { commandName = "register" + , commandSynopsis = + "Register this package with the compiler." + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " register [FLAGS]\n" + , commandDefaultFlags = defaultRegisterFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity regVerbosity (\v flags -> flags{regVerbosity = v}) + , optionDistPref + regDistPref + (\d flags -> flags{regDistPref = d}) + 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 flagToList) + , option + "" + ["print-ipid"] + "print the installed package ID calculated for this package" + regPrintId + (\v flags -> flags{regPrintId = v}) + trueArg + ] + } + +unregisterCommand :: CommandUI RegisterFlags +unregisterCommand = + CommandUI + { commandName = "unregister" + , commandSynopsis = + "Unregister this package with the compiler." + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " unregister [FLAGS]\n" + , commandDefaultFlags = defaultRegisterFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity regVerbosity (\v flags -> flags{regVerbosity = v}) + , optionDistPref + regDistPref + (\d flags -> flags{regDistPref = d}) + 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 + ] + } + +emptyRegisterFlags :: RegisterFlags +emptyRegisterFlags = mempty + +instance Monoid RegisterFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup RegisterFlags where + (<>) = gmappend diff --git a/src/Distribution/Simple/Setup/Repl.hs b/src/Distribution/Simple/Setup/Repl.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Repl.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Setup.Repl +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Definition of the repl command-line options. +-- See: @Distribution.Simple.Setup@ +module Distribution.Simple.Setup.Repl + ( ReplFlags (..) + , defaultReplFlags + , replCommand + , ReplOptions (..) + , replOptions + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.ReadE +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import Distribution.Simple.Flag +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Verbosity + +import Distribution.Simple.Setup.Common + +-- ------------------------------------------------------------ + +-- * REPL Flags + +-- ------------------------------------------------------------ + +data ReplOptions = ReplOptions + { replOptionsFlags :: [String] + , replOptionsNoLoad :: Flag Bool + , replOptionsFlagOutput :: Flag FilePath + } + deriving (Show, Generic, Typeable) + +instance Binary ReplOptions +instance Structured ReplOptions + +instance Monoid ReplOptions where + mempty = ReplOptions mempty (Flag False) NoFlag + mappend = (<>) + +instance Semigroup ReplOptions where + (<>) = gmappend + +data ReplFlags = ReplFlags + { replProgramPaths :: [(String, FilePath)] + , replProgramArgs :: [(String, [String])] + , replDistPref :: Flag FilePath + , replVerbosity :: Flag Verbosity + , replReload :: Flag Bool + , replReplOptions :: ReplOptions + } + deriving (Show, Generic, Typeable) + +instance Binary ReplFlags +instance Structured ReplFlags + +defaultReplFlags :: ReplFlags +defaultReplFlags = + ReplFlags + { replProgramPaths = mempty + , replProgramArgs = [] + , replDistPref = NoFlag + , replVerbosity = Flag normal + , replReload = Flag False + , replReplOptions = mempty + } + +instance Monoid ReplFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ReplFlags where + (<>) = gmappend + +replCommand :: ProgramDb -> CommandUI ReplFlags +replCommand progDb = + CommandUI + { commandName = "repl" + , commandSynopsis = + "Open an interpreter session for the given component." + , commandDescription = Just $ \pname -> + wrapText $ + "If the current directory contains no package, ignores COMPONENT " + ++ "parameters and opens an interactive interpreter session; if a " + ++ "sandbox is present, its package database will be used.\n" + ++ "\n" + ++ "Otherwise, (re)configures with the given or default flags, and " + ++ "loads the interpreter with the relevant modules. For executables, " + ++ "tests and benchmarks, loads the main module (and its " + ++ "dependencies); for libraries all exposed/other modules.\n" + ++ "\n" + ++ "The default component is the library itself, or the executable " + ++ "if that is the only component.\n" + ++ "\n" + ++ "Support for loading specific modules is planned but not " + ++ "implemented yet. For certain scenarios, `" + ++ pname + ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will " + ++ "not (re)configure and you will have to specify the location of " + ++ "other modules, if required.\n" + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " repl " + ++ " The first component in the package\n" + ++ " " + ++ pname + ++ " repl foo " + ++ " A named component (i.e. lib, exe, test suite)\n" + ++ " " + ++ pname + ++ " repl --repl-options=\"-lstdc++\"" + ++ " Specifying flags for interpreter\n" + , -- TODO: re-enable once we have support for module/file targets + -- ++ " " ++ pname ++ " repl Foo.Bar " + -- ++ " A module\n" + -- ++ " " ++ pname ++ " repl Foo/Bar.hs" + -- ++ " A file\n\n" + -- ++ "If a target is ambiguous it can be qualified with the component " + -- ++ "name, e.g.\n" + -- ++ " " ++ pname ++ " repl foo:Foo.Bar\n" + -- ++ " " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n" + commandUsage = \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n" + , commandDefaultFlags = defaultReplFlags + , commandOptions = \showOrParseArgs -> + optionVerbosity replVerbosity (\v flags -> flags{replVerbosity = v}) + : optionDistPref + replDistPref + (\d flags -> flags{replDistPref = d}) + showOrParseArgs + : programDbPaths + progDb + showOrParseArgs + replProgramPaths + (\v flags -> flags{replProgramPaths = v}) + ++ programDbOption + progDb + showOrParseArgs + replProgramArgs + (\v flags -> flags{replProgramArgs = v}) + ++ programDbOptions + progDb + showOrParseArgs + replProgramArgs + (\v flags -> flags{replProgramArgs = v}) + ++ case showOrParseArgs of + ParseArgs -> + [ option + "" + ["reload"] + "Used from within an interpreter to update files." + replReload + (\v flags -> flags{replReload = v}) + trueArg + ] + _ -> [] + ++ map liftReplOption (replOptions showOrParseArgs) + } + where + liftReplOption = liftOption replReplOptions (\v flags -> flags{replReplOptions = v}) + +replOptions :: ShowOrParseArgs -> [OptionField ReplOptions] +replOptions _ = + [ option + [] + ["repl-no-load"] + "Disable loading of project modules at REPL startup." + replOptionsNoLoad + (\p flags -> flags{replOptionsNoLoad = p}) + trueArg + , option + [] + ["repl-options"] + "Use the option(s) for the repl" + replOptionsFlags + (\p flags -> flags{replOptionsFlags = p}) + (reqArg "FLAG" (succeedReadE words) id) + , option + [] + ["repl-multi-file"] + "Write repl options to this directory rather than starting repl mode" + replOptionsFlagOutput + (\p flags -> flags{replOptionsFlagOutput = p}) + (reqArg "DIR" (succeedReadE Flag) flagToList) + ] diff --git a/src/Distribution/Simple/Setup/SDist.hs b/src/Distribution/Simple/Setup/SDist.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/SDist.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Setup.SDist +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Definition of the sdist command-line options. +-- See: @Distribution.Simple.Setup@ +module Distribution.Simple.Setup.SDist + ( SDistFlags (..) + , emptySDistFlags + , defaultSDistFlags + , sdistCommand + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import Distribution.Simple.Flag +import Distribution.Verbosity + +import Distribution.Simple.Setup.Common + +-- ------------------------------------------------------------ + +-- * SDist flags + +-- ------------------------------------------------------------ + +-- | Flags to @sdist@: (snapshot, verbosity) +data SDistFlags = SDistFlags + { sDistSnapshot :: Flag Bool + , sDistDirectory :: Flag FilePath + , sDistDistPref :: Flag FilePath + , sDistListSources :: Flag FilePath + , sDistVerbosity :: Flag Verbosity + } + deriving (Show, Generic, Typeable) + +defaultSDistFlags :: SDistFlags +defaultSDistFlags = + SDistFlags + { sDistSnapshot = Flag False + , sDistDirectory = mempty + , sDistDistPref = NoFlag + , sDistListSources = mempty + , sDistVerbosity = Flag normal + } + +sdistCommand :: CommandUI SDistFlags +sdistCommand = + CommandUI + { commandName = "sdist" + , commandSynopsis = + "Generate a source distribution file (.tar.gz)." + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = \pname -> + "Usage: " ++ pname ++ " sdist [FLAGS]\n" + , commandDefaultFlags = defaultSDistFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity sDistVerbosity (\v flags -> flags{sDistVerbosity = v}) + , optionDistPref + sDistDistPref + (\d flags -> flags{sDistDistPref = d}) + showOrParseArgs + , option + "" + ["list-sources"] + "Just write a list of the package's sources to a file" + sDistListSources + (\v flags -> flags{sDistListSources = v}) + (reqArgFlag "FILE") + , option + "" + ["snapshot"] + "Produce a snapshot source distribution" + sDistSnapshot + (\v flags -> flags{sDistSnapshot = v}) + trueArg + , option + "" + ["output-directory"] + ( "Generate a source distribution in the given directory, " + ++ "without creating a tarball" + ) + sDistDirectory + (\v flags -> flags{sDistDirectory = v}) + (reqArgFlag "DIR") + ] + } + +emptySDistFlags :: SDistFlags +emptySDistFlags = mempty + +instance Monoid SDistFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup SDistFlags where + (<>) = gmappend diff --git a/src/Distribution/Simple/Setup/Test.hs b/src/Distribution/Simple/Setup/Test.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Test.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Test +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Definition of the testing command-line options. +-- See: @Distribution.Simple.Setup@ +module Distribution.Simple.Setup.Test + ( TestFlags (..) + , emptyTestFlags + , defaultTestFlags + , testCommand + , TestShowDetails (..) + , testOptions' + ) where + +import Distribution.Compat.Prelude hiding (get) +import Prelude () + +import qualified Distribution.Compat.CharParsing as P +import Distribution.Parsec +import Distribution.Pretty +import Distribution.ReadE +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs +import Distribution.Simple.Utils +import Distribution.Verbosity +import qualified Text.PrettyPrint as Disp + +import Distribution.Simple.Setup.Common + +-- ------------------------------------------------------------ + +-- * Test flags + +-- ------------------------------------------------------------ + +data TestShowDetails = Never | Failures | Always | Streaming | Direct + deriving (Eq, Ord, Enum, Bounded, Generic, Show, Typeable) + +instance Binary TestShowDetails +instance Structured TestShowDetails + +knownTestShowDetails :: [TestShowDetails] +knownTestShowDetails = [minBound .. maxBound] + +instance Pretty TestShowDetails where + pretty = Disp.text . lowercase . show + +instance Parsec TestShowDetails where + parsec = maybe (fail "invalid TestShowDetails") return . classify =<< ident + where + ident = P.munch1 (\c -> isAlpha c || c == '_' || c == '-') + classify str = lookup (lowercase str) enumMap + enumMap :: [(String, TestShowDetails)] + enumMap = + [ (prettyShow x, x) + | x <- knownTestShowDetails + ] + +-- TODO: do we need this instance? +instance Monoid TestShowDetails where + mempty = Never + mappend = (<>) + +instance Semigroup TestShowDetails where + a <> b = if a < b then b else a + +data TestFlags = TestFlags + { testDistPref :: Flag FilePath + , testVerbosity :: Flag Verbosity + , testHumanLog :: Flag PathTemplate + , testMachineLog :: Flag PathTemplate + , testShowDetails :: Flag TestShowDetails + , testKeepTix :: Flag Bool + , testWrapper :: Flag FilePath + , testFailWhenNoTestSuites :: Flag Bool + , -- TODO: think about if/how options are passed to test exes + testOptions :: [PathTemplate] + } + deriving (Show, Generic, Typeable) + +instance Binary TestFlags +instance Structured TestFlags + +defaultTestFlags :: TestFlags +defaultTestFlags = + TestFlags + { testDistPref = NoFlag + , testVerbosity = Flag normal + , testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log" + , testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log" + , testShowDetails = toFlag Direct + , testKeepTix = toFlag False + , testWrapper = NoFlag + , testFailWhenNoTestSuites = toFlag False + , testOptions = [] + } + +testCommand :: CommandUI TestFlags +testCommand = + CommandUI + { commandName = "test" + , commandSynopsis = + "Run all/specific tests in the test suite." + , commandDescription = Just $ \_pname -> + wrapText $ + testOrBenchmarkHelpText "test" + , commandNotes = Nothing + , commandUsage = + usageAlternatives + "test" + [ "[FLAGS]" + , "TESTCOMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultTestFlags + , commandOptions = testOptions' + } + +testOptions' :: ShowOrParseArgs -> [OptionField TestFlags] +testOptions' showOrParseArgs = + [ optionVerbosity testVerbosity (\v flags -> flags{testVerbosity = v}) + , optionDistPref + testDistPref + (\d flags -> flags{testDistPref = d}) + showOrParseArgs + , option + [] + ["log"] + ( "Log all test suite results to file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)" + ) + testHumanLog + (\v flags -> flags{testHumanLog = v}) + ( reqArg' + "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate) + ) + , option + [] + ["machine-log"] + ( "Produce a machine-readable log file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $result)" + ) + testMachineLog + (\v flags -> flags{testMachineLog = v}) + ( reqArg' + "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate) + ) + , option + [] + ["show-details"] + ( "'always': always show results of individual test cases. " + ++ "'never': never show results of individual test cases. " + ++ "'failures': show results of failing test cases. " + ++ "'streaming': show results of test cases in real time." + ++ "'direct': send results of test cases in real time; no log file." + ) + testShowDetails + (\v flags -> flags{testShowDetails = v}) + ( reqArg + "FILTER" + ( parsecToReadE + ( \_ -> + "--show-details flag expects one of " + ++ intercalate + ", " + (map prettyShow knownTestShowDetails) + ) + (fmap toFlag parsec) + ) + (flagToList . fmap prettyShow) + ) + , option + [] + ["keep-tix-files"] + "keep .tix files for HPC between test runs" + testKeepTix + (\v flags -> flags{testKeepTix = v}) + trueArg + , option + [] + ["test-wrapper"] + "Run test through a wrapper." + testWrapper + (\v flags -> flags{testWrapper = v}) + ( reqArg' + "FILE" + (toFlag :: FilePath -> Flag FilePath) + (flagToList :: Flag FilePath -> [FilePath]) + ) + , option + [] + ["fail-when-no-test-suites"] + ("Exit with failure when no test suites are found.") + testFailWhenNoTestSuites + (\v flags -> flags{testFailWhenNoTestSuites = v}) + trueArg + , option + [] + ["test-options"] + ( "give extra options to test executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $test-suite)" + ) + testOptions + (\v flags -> flags{testOptions = v}) + ( reqArg' + "TEMPLATES" + (map toPathTemplate . splitArgs) + (const []) + ) + , option + [] + ["test-option"] + ( "give extra option to test executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $test-suite)" + ) + testOptions + (\v flags -> flags{testOptions = v}) + ( reqArg' + "TEMPLATE" + (\x -> [toPathTemplate x]) + (map fromPathTemplate) + ) + ] + +emptyTestFlags :: TestFlags +emptyTestFlags = mempty + +instance Monoid TestFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup TestFlags where + (<>) = gmappend 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,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | -- This module defines a simple JSON-based format for exporting basic -- information about a Cabal package and the compiler configuration Cabal @@ -55,12 +57,11 @@ -- * @src-files@: any other Haskell sources needed by the component -- -- Note: At the moment this is only supported when using the GHC compiler. --- - -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Simple.ShowBuildInfo ( - mkBuildInfo, mkBuildInfo', mkCompilerInfo, mkComponentInfo +module Distribution.Simple.ShowBuildInfo + ( mkBuildInfo + , mkBuildInfo' + , mkCompilerInfo + , mkComponentInfo ) where import System.FilePath @@ -68,37 +69,42 @@ import Distribution.Compat.Prelude import Prelude () -import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.Program.GHC as GHC -import Distribution.PackageDescription import Distribution.Compiler -import Distribution.Verbosity -import Distribution.Simple.Compiler (Compiler, showCompilerId, compilerFlavor) +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Simple.Compiler (Compiler, compilerFlavor, showCompilerId) import Distribution.Simple.Program -import Distribution.Simple.Setup +import Distribution.Simple.Setup.Build (BuildFlags) import Distribution.Simple.Utils (cabalVersion) -import Distribution.Utils.Json +import Distribution.Text import Distribution.Types.Component import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.LocalBuildInfo import Distribution.Types.TargetInfo -import Distribution.Text -import Distribution.Pretty +import Distribution.Utils.Json +import Distribution.Verbosity -- | Construct a JSON document describing the build information for a -- package. mkBuildInfo - :: FilePath -- ^ The source directory of the package - -> PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build + :: FilePath + -- ^ The source directory of the package + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build -> (ConfiguredProgram, Compiler) -- ^ Compiler information. -- Needs to be passed explicitly, as we can't extract that information here -- without some partial function. -> [TargetInfo] - -> ([String], Json) -- ^ Json representation of buildinfo alongside generated warnings + -> ([String], Json) + -- ^ Json representation of buildinfo alongside generated warnings mkBuildInfo wdir pkg_descr lbi _flags compilerInfo targetsToBuild = (warnings, JsonObject buildInfoFields) where buildInfoFields = mkBuildInfo' (uncurry mkCompilerInfo compilerInfo) componentInfos @@ -113,33 +119,40 @@ -- the schema at @\/doc\/json-schemas\/build-info.schema.json@ and the docs of -- @--enable-build-info@\/@--disable-build-info@. mkBuildInfo' - :: Json -- ^ The 'Json' from 'mkCompilerInfo' - -> [Json] -- ^ The 'Json' from 'mkComponentInfo' + :: Json + -- ^ The 'Json' from 'mkCompilerInfo' + -> [Json] + -- ^ The 'Json' from 'mkComponentInfo' -> [(String, Json)] mkBuildInfo' compilerInfo componentInfos = [ "cabal-lib-version" .= JsonString (display cabalVersion) - , "compiler" .= compilerInfo - , "components" .= JsonArray componentInfos + , "compiler" .= compilerInfo + , "components" .= JsonArray componentInfos ] mkCompilerInfo :: ConfiguredProgram -> Compiler -> Json -mkCompilerInfo compilerProgram compilerInfo = JsonObject - [ "flavour" .= JsonString (prettyShow $ compilerFlavor compilerInfo) - , "compiler-id" .= JsonString (showCompilerId compilerInfo) - , "path" .= JsonString (programPath compilerProgram) - ] +mkCompilerInfo compilerProgram compilerInfo = + JsonObject + [ "flavour" .= JsonString (prettyShow $ compilerFlavor compilerInfo) + , "compiler-id" .= JsonString (showCompilerId compilerInfo) + , "path" .= JsonString (programPath compilerProgram) + ] mkComponentInfo :: FilePath -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> ([String], Json) -mkComponentInfo wdir pkg_descr lbi clbi = (warnings, JsonObject $ - [ "type" .= JsonString compType - , "name" .= JsonString (prettyShow name) - , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) - , "compiler-args" .= JsonArray (map JsonString compilerArgs) - , "modules" .= JsonArray (map (JsonString . display) modules) - , "src-files" .= JsonArray (map JsonString sourceFiles) - , "hs-src-dirs" .= JsonArray (map (JsonString . prettyShow) $ hsSourceDirs bi) - , "src-dir" .= JsonString (addTrailingPathSeparator wdir) - ] <> cabalFile) +mkComponentInfo wdir pkg_descr lbi clbi = + ( warnings + , JsonObject $ + [ "type" .= JsonString compType + , "name" .= JsonString (prettyShow name) + , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) + , "compiler-args" .= JsonArray (map JsonString compilerArgs) + , "modules" .= JsonArray (map (JsonString . display) modules) + , "src-files" .= JsonArray (map JsonString sourceFiles) + , "hs-src-dirs" .= JsonArray (map (JsonString . prettyShow) $ hsSourceDirs bi) + , "src-dir" .= JsonString (addTrailingPathSeparator wdir) + ] + <> cabalFile + ) where (warnings, compilerArgs) = getCompilerArgs bi lbi clbi name = componentLocalName clbi @@ -147,11 +160,11 @@ -- If this error happens, a cabal invariant has been violated comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name compType = case comp of - CLib _ -> "lib" - CExe _ -> "exe" - CTest _ -> "test" + CLib _ -> "lib" + CExe _ -> "exe" + CTest _ -> "test" CBench _ -> "bench" - CFLib _ -> "flib" + CFLib _ -> "flib" modules = case comp of CLib lib -> explicitLibModules lib CExe exe -> exeModules exe @@ -163,7 +176,7 @@ CBench bench -> benchmarkModules bench CFLib flib -> foreignLibModules flib sourceFiles = case comp of - CLib _ -> [] + CLib _ -> [] CExe exe -> [modulePath exe] CTest test -> case testInterface test of @@ -173,11 +186,10 @@ CBench bench -> case benchmarkInterface bench of BenchmarkExeV10 _ fp -> [fp] BenchmarkUnsupported _ -> [] - CFLib _ -> [] cabalFile | Just fp <- pkgDescrFile lbi = [("cabal-file", JsonString fp)] - | otherwise = [] + | otherwise = [] -- | Get the command-line arguments that would be passed -- to the compiler to build the given component. @@ -188,12 +200,16 @@ -> ([String], [String]) getCompilerArgs bi lbi clbi = case compilerFlavor $ compiler lbi of - GHC -> ([], ghc) - GHCJS -> ([], ghc) - c -> - ( ["ShowBuildInfo.getCompilerArgs: Don't know how to get build " - ++ " arguments for compiler " ++ show c] - , []) + GHC -> ([], ghc) + GHCJS -> ([], ghc) + c -> + ( + [ "ShowBuildInfo.getCompilerArgs: Don't know how to get build " + ++ " arguments for compiler " + ++ show c + ] + , [] + ) where -- This is absolutely awful ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts 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 @@ -2,6 +2,10 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + +-- NOTE: FIX: we don't have a great way of testing this module, since +-- we can't easily look inside a tarball once its created. + -- | -- Module : Distribution.Simple.SrcDist -- Copyright : Simon Marlow 2004 @@ -19,67 +23,68 @@ -- The 'createArchive' action uses the external @tar@ program and assumes that -- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows. -- The 'sdist' action now also does some distribution QA checks. - --- NOTE: FIX: we don't have a great way of testing this module, since --- we can't easily look inside a tarball once its created. - -module Distribution.Simple.SrcDist ( - -- * The top level action - sdist, - - -- ** Parts of 'sdist' - printPackageProblems, - prepareTree, - createArchive, +module Distribution.Simple.SrcDist + ( -- * The top level action + sdist - -- ** Snapshots - prepareSnapshotTree, - snapshotPackage, - snapshotVersion, - dateToSnapshotNumber, + -- ** Parts of 'sdist' + , printPackageProblems + , prepareTree + , createArchive - -- * Extracting the source files - listPackageSources, - listPackageSourcesWithDie, + -- ** Snapshots + , prepareSnapshotTree + , snapshotPackage + , snapshotVersion + , dateToSnapshotNumber - ) where + -- * Extracting the source files + , listPackageSources + , listPackageSourcesWithDie + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.PackageDescription -import Distribution.PackageDescription.Check hiding (doesFileExist) -import Distribution.Package import Distribution.ModuleName import qualified Distribution.ModuleName as ModuleName -import Distribution.Version +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Check hiding (doesFileExist) +import Distribution.Pretty +import Distribution.Simple.BuildPaths import Distribution.Simple.Configure (findDistPrefOrDefault) +import Distribution.Simple.Flag import Distribution.Simple.Glob (matchDirFileGlobWithDie) -import Distribution.Simple.Utils -import Distribution.Simple.Setup import Distribution.Simple.PreProcess -import Distribution.Simple.BuildPaths import Distribution.Simple.Program -import Distribution.Pretty -import Distribution.Verbosity +import Distribution.Simple.Setup.SDist +import Distribution.Simple.Utils import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version import qualified Data.Map as Map import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay) -import System.Directory ( doesFileExist ) -import System.IO (IOMode(WriteMode), hPutStrLn, withFile) -import System.FilePath ((), (<.>), dropExtension, isRelative) +import Distribution.Simple.Errors +import System.Directory (doesFileExist) +import System.FilePath (dropExtension, isRelative, (<.>), ()) +import System.IO (IOMode (WriteMode), hPutStrLn, withFile) --- |Create a source distribution. -sdist :: PackageDescription -- ^ information from the tarball - -> SDistFlags -- ^ verbosity & snapshot - -> (FilePath -> FilePath) -- ^ build prefix (temp dir) - -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) - -> IO () +-- | Create a source distribution. +sdist + :: PackageDescription + -- ^ information from the tarball + -> SDistFlags + -- ^ verbosity & snapshot + -> (FilePath -> FilePath) + -- ^ build prefix (temp dir) + -> [PPSuffixHandler] + -- ^ extra preprocessors (includes suffixes) + -> IO () sdist pkg flags mkTmpDir pps = do - distPref <- findDistPrefOrDefault $ sDistDistPref flags - let targetPref = distPref + let targetPref = distPref tmpTargetDir = mkTmpDir distPref -- When given --list-sources, just output the list of sources to a file. @@ -88,20 +93,19 @@ ordinary <- listPackageSources verbosity "." pkg pps traverse_ (hPutStrLn outHandle) ordinary notice verbosity $ "List of package sources written to file '" ++ path ++ "'" - - NoFlag -> do + NoFlag -> do -- do some QA printPackageProblems verbosity pkg date <- getCurrentTime - let pkg' | snapshot = snapshotPackage date pkg - | otherwise = pkg + let pkg' + | snapshot = snapshotPackage date pkg + | otherwise = pkg case flagToMaybe (sDistDirectory flags) of Just targetDir -> do generateSourceDir targetDir pkg' info verbosity $ "Source directory created: " ++ targetDir - Nothing -> do createDirectoryIfMissingVerbose verbosity True tmpTargetDir withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do @@ -109,7 +113,6 @@ generateSourceDir targetDir pkg' targzFile <- createArchive verbosity pkg' tmpDir targetPref notice verbosity $ "Source tarball created: " ++ targzFile - where generateSourceDir :: FilePath -> PackageDescription -> IO () generateSourceDir targetDir pkg' = do @@ -119,22 +122,26 @@ overwriteSnapshotPackageDesc verbosity pkg' targetDir verbosity = fromFlag (sDistVerbosity flags) - snapshot = fromFlag (sDistSnapshot flags) + snapshot = fromFlag (sDistSnapshot flags) -- | List all source files of a package. -- -- Since @Cabal-3.4@ returns a single list. There shouldn't be any -- executable files, they are hardly portable. --- listPackageSources - :: Verbosity -- ^ verbosity - -> FilePath -- ^ directory with cabal file - -> PackageDescription -- ^ info from the cabal file - -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes) - -> IO [FilePath] -- ^ relative paths + :: Verbosity + -- ^ verbosity + -> FilePath + -- ^ directory with cabal file + -> PackageDescription + -- ^ info from the cabal file + -> [PPSuffixHandler] + -- ^ extra preprocessors (include suffixes) + -> IO [FilePath] + -- ^ relative paths listPackageSources verbosity cwd pkg_descr0 pps = do - -- Call helpers that actually do all work. - listPackageSources' verbosity die' cwd pkg_descr pps + -- Call helpers that actually do all work. + listPackageSources' verbosity dieWithException cwd pkg_descr pps where pkg_descr = filterAutogenModules pkg_descr0 @@ -144,163 +151,171 @@ -- -- Since @3.4.0.0 listPackageSourcesWithDie - :: Verbosity -- ^ verbosity - -> (Verbosity -> String -> IO [FilePath]) - -- ^ 'die'' alternative. - -- Since 'die'' prefixes the error message with 'errorPrefix', - -- whatever is passed in here and wants to die should do the same. - -- See issue #7331. - -> FilePath -- ^ directory with cabal file - -> PackageDescription -- ^ info from the cabal file - -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes) - -> IO [FilePath] -- ^ relative paths + :: Verbosity + -- ^ verbosity + -> (Verbosity -> CabalException -> IO [FilePath]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. + -> FilePath + -- ^ directory with cabal file + -> PackageDescription + -- ^ info from the cabal file + -> [PPSuffixHandler] + -- ^ extra preprocessors (include suffixes) + -> IO [FilePath] + -- ^ relative paths listPackageSourcesWithDie verbosity rip cwd pkg_descr0 pps = do - -- Call helpers that actually do all work. - listPackageSources' verbosity rip cwd pkg_descr pps + -- Call helpers that actually do all work. + listPackageSources' verbosity rip cwd pkg_descr pps where pkg_descr = filterAutogenModules pkg_descr0 - listPackageSources' :: Verbosity - -- ^ verbosity - -> (Verbosity -> String -> IO [FilePath]) - -- ^ 'die'' alternative. - -- Since 'die'' prefixes the error message with 'errorPrefix', - -- whatever is passed in here and wants to die should do the same. - -- See issue #7331. + -- ^ verbosity + -> (Verbosity -> CabalException -> IO [FilePath]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. -> FilePath - -- ^ directory with cabal file + -- ^ directory with cabal file -> PackageDescription - -- ^ info from the cabal file + -- ^ info from the cabal file -> [PPSuffixHandler] - -- ^ extra preprocessors (include suffixes) + -- ^ extra preprocessors (include suffixes) -> IO [FilePath] - -- ^ relative paths + -- ^ relative paths listPackageSources' verbosity rip cwd pkg_descr pps = fmap concat . sequenceA $ - [ - -- Library sources. - fmap concat - . withAllLib $ \Library { - exposedModules = modules, - signatures = sigs, - libBuildInfo = libBi - } -> - allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs) - - -- Executables sources. - , fmap concat - . withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd exeBi pps [] - mainSrc <- findMainExeFile verbosity cwd exeBi pps mainPath - return (mainSrc:biSrcs) - - -- Foreign library sources - , fmap concat - . withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd flibBi pps [] - defFiles <- traverse (findModDefFile verbosity cwd flibBi pps) - (foreignLibModDefFile flib) - return (defFiles ++ biSrcs) - - -- Test suites sources. - , fmap concat - . withAllTest $ \t -> do - let bi = testBuildInfo t - case testInterface t of - TestSuiteExeV10 _ mainPath -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps [] - srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath - return (srcMainFile:biSrcs) - TestSuiteLibV09 _ m -> - allSourcesBuildInfo verbosity rip cwd bi pps [m] - TestSuiteUnsupported tp -> - rip verbosity $ "Unsupported test suite type: " ++ show tp - - -- Benchmarks sources. - , fmap concat - . withAllBenchmark $ \bm -> do - let bi = benchmarkBuildInfo bm - case benchmarkInterface bm of - BenchmarkExeV10 _ mainPath -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps [] - srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath - return (srcMainFile:biSrcs) - BenchmarkUnsupported tp -> - rip verbosity $ "Unsupported benchmark type: " ++ show tp - - -- Data files. - , fmap concat - . for (dataFiles pkg_descr) $ \filename -> do - let srcDataDirRaw = dataDir pkg_descr - srcDataDir | null srcDataDirRaw = "." - | otherwise = srcDataDirRaw - matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir filename) - - -- Extra source files. - , fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> - matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath - - -- Extra doc files. - , fmap concat - . for (extraDocFiles pkg_descr) $ \ filename -> - matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd filename - - -- License file(s). - , return (map getSymbolicPath $ licenseFiles pkg_descr) - - -- Install-include files, without autogen-include files - , fmap concat - . withAllLib $ \ l -> do - let lbi = libBuildInfo l - incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi) - relincdirs = "." : filter isRelative (includeDirs lbi) - traverse (fmap snd . findIncludeFile verbosity cwd relincdirs) incls - - -- Setup script, if it exists. - , fmap (maybe [] (\f -> [f])) $ findSetupFile cwd - - -- The .cabal file itself. - , fmap (\d -> [d]) (tryFindPackageDescCwd verbosity cwd ".") - - ] + [ -- Library sources. + fmap concat + . withAllLib + $ \Library + { exposedModules = modules + , signatures = sigs + , libBuildInfo = libBi + } -> + allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs) + , -- Executables sources. + fmap concat + . withAllExe + $ \Executable{modulePath = mainPath, buildInfo = exeBi} -> do + biSrcs <- allSourcesBuildInfo verbosity rip cwd exeBi pps [] + mainSrc <- findMainExeFile verbosity cwd exeBi pps mainPath + return (mainSrc : biSrcs) + , -- Foreign library sources + fmap concat + . withAllFLib + $ \flib@(ForeignLib{foreignLibBuildInfo = flibBi}) -> do + biSrcs <- allSourcesBuildInfo verbosity rip cwd flibBi pps [] + defFiles <- + traverse + (findModDefFile verbosity cwd flibBi pps) + (foreignLibModDefFile flib) + return (defFiles ++ biSrcs) + , -- Test suites sources. + fmap concat + . withAllTest + $ \t -> do + let bi = testBuildInfo t + case testInterface t of + TestSuiteExeV10 _ mainPath -> do + biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps [] + srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath + return (srcMainFile : biSrcs) + TestSuiteLibV09 _ m -> + allSourcesBuildInfo verbosity rip cwd bi pps [m] + TestSuiteUnsupported tp -> + rip verbosity $ UnsupportedTestSuite (show tp) + , -- Benchmarks sources. + fmap concat + . withAllBenchmark + $ \bm -> do + let bi = benchmarkBuildInfo bm + case benchmarkInterface bm of + BenchmarkExeV10 _ mainPath -> do + biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps [] + srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath + return (srcMainFile : biSrcs) + BenchmarkUnsupported tp -> + rip verbosity $ UnsupportedBenchMark (show tp) + , -- Data files. + fmap concat + . for (dataFiles pkg_descr) + $ \filename -> + do + let srcDataDirRaw = dataDir pkg_descr + srcDataDir + | null srcDataDirRaw = "." + | otherwise = srcDataDirRaw + matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir filename) + , -- Extra source files. + fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> + matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath + , -- Extra doc files. + fmap concat + . for (extraDocFiles pkg_descr) + $ \filename -> + matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd filename + , -- License file(s). + return (map getSymbolicPath $ licenseFiles pkg_descr) + , -- Install-include files, without autogen-include files + fmap concat + . withAllLib + $ \l -> do + let lbi = libBuildInfo l + incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi) + relincdirs = "." : filter isRelative (includeDirs lbi) + traverse (fmap snd . findIncludeFile verbosity cwd relincdirs) incls + , -- Setup script, if it exists. + fmap (maybe [] (\f -> [f])) $ findSetupFile cwd + , -- The .cabal file itself. + fmap (\d -> [d]) (tryFindPackageDescCwd verbosity cwd ".") + ] where -- We have to deal with all libs and executables, so we have local -- versions of these functions that ignore the 'buildable' attribute: - withAllLib action = traverse action (allLibraries pkg_descr) - withAllFLib action = traverse action (foreignLibs pkg_descr) - withAllExe action = traverse action (executables pkg_descr) - withAllTest action = traverse action (testSuites pkg_descr) + withAllLib action = traverse action (allLibraries pkg_descr) + withAllFLib action = traverse action (foreignLibs pkg_descr) + withAllExe action = traverse action (executables pkg_descr) + withAllTest action = traverse action (testSuites pkg_descr) withAllBenchmark action = traverse action (benchmarks pkg_descr) - --- |Prepare a directory tree of source files. -prepareTree :: Verbosity -- ^ verbosity - -> PackageDescription -- ^ info from the cabal file - -> FilePath -- ^ source tree to populate - -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) - -> IO () +-- | Prepare a directory tree of source files. +prepareTree + :: Verbosity + -- ^ verbosity + -> PackageDescription + -- ^ info from the cabal file + -> FilePath + -- ^ source tree to populate + -> [PPSuffixHandler] + -- ^ extra preprocessors (includes suffixes) + -> IO () prepareTree verbosity pkg_descr0 targetDir pps = do - ordinary <- listPackageSources verbosity "." pkg_descr pps - installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary) - maybeCreateDefaultSetupScript targetDir + ordinary <- listPackageSources verbosity "." pkg_descr pps + installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary) + maybeCreateDefaultSetupScript targetDir where pkg_descr = filterAutogenModules pkg_descr0 -- | Find the setup script file, if it exists. findSetupFile :: FilePath -> IO (Maybe FilePath) findSetupFile targetDir = do - hsExists <- doesFileExist (targetDir setupHs) + hsExists <- doesFileExist (targetDir setupHs) lhsExists <- doesFileExist (targetDir setupLhs) if hsExists then return (Just setupHs) - else if lhsExists - then return (Just setupLhs) - else return Nothing - where - setupHs = "Setup.hs" - setupLhs = "Setup.lhs" + else + if lhsExists + then return (Just setupLhs) + else return Nothing + where + setupHs = "Setup.hs" + setupLhs = "Setup.lhs" -- | Create a default setup script in the target directory, if it doesn't exist. maybeCreateDefaultSetupScript :: FilePath -> IO () @@ -308,22 +323,30 @@ mSetupFile <- findSetupFile targetDir case mSetupFile of Just _setupFile -> return () - Nothing -> do - writeUTF8File (targetDir "Setup.hs") $ unlines [ - "import Distribution.Simple", - "main = defaultMain"] + Nothing -> do + writeUTF8File (targetDir "Setup.hs") $ + unlines + [ "import Distribution.Simple" + , "main = defaultMain" + ] -- | Find the main executable file. findMainExeFile :: Verbosity - -> FilePath -- ^ cwd + -> FilePath + -- ^ cwd -> BuildInfo -> [PPSuffixHandler] - -> FilePath -- ^ main-is + -> FilePath + -- ^ main-is -> IO FilePath findMainExeFile verbosity cwd exeBi pps mainPath = do - ppFile <- findFileCwdWithExtension cwd (ppSuffixes pps) (map getSymbolicPath (hsSourceDirs exeBi)) - (dropExtension mainPath) + ppFile <- + findFileCwdWithExtension + cwd + (ppSuffixes pps) + (map getSymbolicPath (hsSourceDirs exeBi)) + (dropExtension mainPath) case ppFile of Nothing -> findFileCwd verbosity cwd (map getSymbolicPath (hsSourceDirs exeBi)) mainPath Just pp -> return pp @@ -334,206 +357,236 @@ findModDefFile :: Verbosity -> FilePath -> BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath findModDefFile verbosity cwd flibBi _pps modDefPath = - findFileCwd verbosity cwd ("." : map getSymbolicPath (hsSourceDirs flibBi)) modDefPath + findFileCwd verbosity cwd ("." : map getSymbolicPath (hsSourceDirs flibBi)) modDefPath -- | Given a list of include paths, try to find the include file named -- @f@. Return the name of the file and the full path, or exit with error if -- there's no such file. findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath) -findIncludeFile verbosity _ [] f = die' verbosity ("can't find include file " ++ f) -findIncludeFile verbosity cwd (d:ds) f = do +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 + if b then return (f, path) else findIncludeFile verbosity cwd ds f -- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' -- and 'other-modules'. filterAutogenModules :: PackageDescription -> PackageDescription -filterAutogenModules pkg_descr0 = mapLib filterAutogenModuleLib $ - mapAllBuildInfo filterAutogenModuleBI pkg_descr0 +filterAutogenModules pkg_descr0 = + mapLib filterAutogenModuleLib $ + mapAllBuildInfo filterAutogenModuleBI pkg_descr0 where - mapLib f pkg = pkg { library = fmap f (library pkg) - , subLibraries = map f (subLibraries pkg) } - filterAutogenModuleLib lib = lib { - exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib) - } - filterAutogenModuleBI bi = bi { - otherModules = filter (filterFunction bi) (otherModules bi) - } + mapLib f pkg = + pkg + { library = fmap f (library pkg) + , subLibraries = map f (subLibraries pkg) + } + filterAutogenModuleLib lib = + lib + { exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib) + } + filterAutogenModuleBI bi = + bi + { otherModules = filter (filterFunction bi) (otherModules bi) + } pathsModule = autogenPathsModuleName pkg_descr0 packageInfoModule = autogenPackageInfoModuleName pkg_descr0 filterFunction bi = \mn -> - mn /= pathsModule - && mn /= packageInfoModule - && not (mn `elem` autogenModules bi) + mn /= pathsModule + && mn /= packageInfoModule + && not (mn `elem` autogenModules bi) -- | Prepare a directory tree of source files for a snapshot version. -- It is expected that the appropriate snapshot version has already been set -- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. --- prepareSnapshotTree - :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^source tree to populate - -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) + :: Verbosity + -- ^ verbosity + -> PackageDescription + -- ^ info from the cabal file + -> FilePath + -- ^ source tree to populate + -> [PPSuffixHandler] + -- ^ extra preprocessors (includes suffixes) -> IO () prepareSnapshotTree verbosity pkg targetDir pps = do prepareTree verbosity pkg targetDir pps overwriteSnapshotPackageDesc verbosity pkg targetDir -overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^source tree - -> IO () +overwriteSnapshotPackageDesc + :: Verbosity + -- ^ verbosity + -> PackageDescription + -- ^ info from the cabal file + -> FilePath + -- ^ source tree + -> IO () overwriteSnapshotPackageDesc verbosity pkg targetDir = do - -- We could just writePackageDescription targetDescFile pkg_descr, - -- but that would lose comments and formatting. - descFile <- defaultPackageDesc verbosity - withUTF8FileContents descFile $ - writeUTF8File (targetDir descFile) - . unlines . map (replaceVersion (packageVersion pkg)) . lines - + -- We could just writePackageDescription targetDescFile pkg_descr, + -- but that would lose comments and formatting. + descFile <- defaultPackageDesc verbosity + withUTF8FileContents descFile $ + writeUTF8File (targetDir descFile) + . unlines + . map (replaceVersion (packageVersion pkg)) + . lines where replaceVersion :: Version -> String -> String replaceVersion version line - | "version:" `isPrefixOf` map toLower line - = "version: " ++ prettyShow version + | "version:" `isPrefixOf` map toLower line = + "version: " ++ prettyShow version | otherwise = line -- | Modifies a 'PackageDescription' by appending a snapshot number -- corresponding to the given date. --- snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription snapshotPackage date pkg = - pkg { - package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) } - } - where pkgid = packageId pkg + pkg + { package = pkgid{pkgVersion = snapshotVersion date (pkgVersion pkgid)} + } + where + pkgid = packageId pkg -- | Modifies a 'Version' by appending a snapshot number corresponding -- to the given date. --- snapshotVersion :: UTCTime -> Version -> Version snapshotVersion date = alterVersion (++ [dateToSnapshotNumber date]) -- | Given a date produce a corresponding integer representation. -- For example given a date @18/03/2008@ produce the number @20080318@. --- dateToSnapshotNumber :: UTCTime -> Int dateToSnapshotNumber date = case toGregorian (utctDay date) of - (year, month, day) -> - fromIntegral year * 10000 - + month * 100 - + day + (year, month, day) -> + fromIntegral year * 10000 + + month * 100 + + day -- | Create an archive from a tree of source files, and clean up the tree. createArchive - :: Verbosity -- ^ verbosity - -> PackageDescription -- ^ info from cabal file - -> FilePath -- ^ source tree to archive - -> FilePath -- ^ name of archive to create - -> IO FilePath + :: Verbosity + -- ^ verbosity + -> PackageDescription + -- ^ info from cabal file + -> FilePath + -- ^ source tree to archive + -> FilePath + -- ^ name of archive to create + -> IO FilePath createArchive verbosity pkg_descr tmpDir targetPref = do let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" (tarProg, _) <- requireProgram verbosity tarProgram defaultProgramDb - let formatOptSupported = maybe False (== "YES") $ - Map.lookup "Supports --format" - (programProperties tarProg) + let formatOptSupported = + maybe False (== "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 -- prev. solution used pipes and sub-command sequences to set up the paths -- correctly, which is problematic in a Windows setting.] ["-czf", tarBallFilePath, "-C", tmpDir] - ++ (if formatOptSupported then ["--format", "ustar"] else []) - ++ [tarBallName pkg_descr] + ++ (if formatOptSupported then ["--format", "ustar"] else []) + ++ [tarBallName pkg_descr] return tarBallFilePath -- | Given a buildinfo, return the names of all source files. allSourcesBuildInfo - :: Verbosity - -> (Verbosity -> String -> IO [FilePath]) - -- ^ 'die'' alternative. - -- Since 'die'' prefixes the error message with 'errorPrefix', - -- whatever is passed in here and wants to die should do the same. - -- See issue #7331. - -> FilePath -- ^ cwd -- change me to 'BuildPath Absolute PackageDir' - -> BuildInfo - -> [PPSuffixHandler] -- ^ Extra preprocessors - -> [ModuleName] -- ^ Exposed modules - -> IO [FilePath] + :: Verbosity + -> (Verbosity -> CabalException -> IO [FilePath]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. + -> FilePath + -- ^ cwd -- change me to 'BuildPath Absolute PackageDir' + -> BuildInfo + -> [PPSuffixHandler] + -- ^ Extra preprocessors + -> [ModuleName] + -- ^ Exposed modules + -> IO [FilePath] allSourcesBuildInfo verbosity rip cwd bi pps modules = do let searchDirs = map getSymbolicPath (hsSourceDirs bi) - sources <- fmap concat $ sequenceA $ - [ let file = ModuleName.toFilePath module_ - -- NB: *Not* findFileWithExtension, because the same source - -- file may show up in multiple paths due to a conditional; - -- we need to package all of them. See #367. - in findAllFilesCwdWithExtension cwd suffixes searchDirs file - >>= nonEmpty' (notFound module_) return - | module_ <- modules ++ otherModules bi ] - bootFiles <- sequenceA - [ let file = ModuleName.toFilePath module_ - fileExts = ["hs-boot", "lhs-boot"] - in findFileCwdWithExtension cwd fileExts (map getSymbolicPath (hsSourceDirs bi)) file - | module_ <- modules ++ otherModules bi ] - - return $ sources ++ catMaybes bootFiles ++ cSources bi ++ cxxSources bi ++ - cmmSources bi ++ asmSources bi ++ jsSources bi + sources <- + fmap concat $ + sequenceA $ + [ let file = ModuleName.toFilePath module_ + in -- NB: *Not* findFileWithExtension, because the same source + -- file may show up in multiple paths due to a conditional; + -- we need to package all of them. See #367. + findAllFilesCwdWithExtension cwd suffixes searchDirs file + >>= nonEmpty' (notFound module_) return + | module_ <- modules ++ otherModules bi + ] + bootFiles <- + sequenceA + [ let file = ModuleName.toFilePath module_ + fileExts = builtinHaskellBootSuffixes + in findFileCwdWithExtension cwd fileExts (map getSymbolicPath (hsSourceDirs bi)) file + | module_ <- modules ++ otherModules bi + ] + return $ + sources + ++ catMaybes bootFiles + ++ cSources bi + ++ cxxSources bi + ++ cmmSources bi + ++ asmSources bi + ++ jsSources bi where nonEmpty' :: b -> ([a] -> b) -> [a] -> b nonEmpty' x _ [] = x nonEmpty' _ f xs = f xs - suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"] + suffixes = ppSuffixes pps ++ builtinHaskellSuffixes notFound :: ModuleName -> IO [FilePath] - notFound m = rip verbosity $ "Could not find module: " ++ prettyShow m - ++ " with any suffix: " ++ show suffixes ++ ". If the module " - ++ "is autogenerated it should be added to 'autogen-modules'." - + notFound m = + rip verbosity $ NoModuleFound m suffixes -- | Note: must be called with the CWD set to the directory containing -- the '.cabal' file. printPackageProblems :: Verbosity -> PackageDescription -> IO () printPackageProblems verbosity pkg_descr = do - ioChecks <- checkPackageFiles verbosity pkg_descr "." + ioChecks <- checkPackageFiles verbosity pkg_descr "." let pureChecks = checkConfiguredPackage pkg_descr - isDistError (PackageDistSuspicious _) = False - isDistError (PackageDistSuspiciousWarn _) = False - isDistError _ = True - (errors, warnings) = partition isDistError (pureChecks ++ ioChecks) + (errors, warnings) = partition isHackageDistError (pureChecks ++ ioChecks) unless (null errors) $ - notice verbosity $ "Distribution quality errors:\n" - ++ unlines (map ppPackageCheck errors) + notice verbosity $ + "Distribution quality errors:\n" + ++ unlines (map ppPackageCheck errors) unless (null warnings) $ - notice verbosity $ "Distribution quality warnings:\n" - ++ unlines (map ppPackageCheck warnings) + notice verbosity $ + "Distribution quality warnings:\n" + ++ unlines (map ppPackageCheck warnings) unless (null errors) $ - notice verbosity - "Note: the public hackage server would reject this package." + notice + verbosity + "Note: the public hackage server would reject this package." ------------------------------------------------------------ -- | The name of the tarball without extension --- tarBallName :: PackageDescription -> String tarBallName = prettyShow . packageId -mapAllBuildInfo :: (BuildInfo -> BuildInfo) - -> (PackageDescription -> PackageDescription) -mapAllBuildInfo f pkg = pkg { - library = fmap mapLibBi (library pkg), - subLibraries = fmap mapLibBi (subLibraries pkg), - foreignLibs = fmap mapFLibBi (foreignLibs pkg), - executables = fmap mapExeBi (executables pkg), - testSuites = fmap mapTestBi (testSuites pkg), - benchmarks = fmap mapBenchBi (benchmarks pkg) - } +mapAllBuildInfo + :: (BuildInfo -> BuildInfo) + -> (PackageDescription -> PackageDescription) +mapAllBuildInfo f pkg = + pkg + { library = fmap mapLibBi (library pkg) + , subLibraries = fmap mapLibBi (subLibraries pkg) + , foreignLibs = fmap mapFLibBi (foreignLibs pkg) + , executables = fmap mapExeBi (executables pkg) + , testSuites = fmap mapTestBi (testSuites pkg) + , benchmarks = fmap mapBenchBi (benchmarks pkg) + } where - mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } - mapFLibBi flib = flib { foreignLibBuildInfo = f (foreignLibBuildInfo flib) } - mapExeBi exe = exe { buildInfo = f (buildInfo exe) } - mapTestBi tst = tst { testBuildInfo = f (testBuildInfo tst) } - mapBenchBi bm = bm { benchmarkBuildInfo = f (benchmarkBuildInfo bm) } + mapLibBi lib = lib{libBuildInfo = f (libBuildInfo lib)} + mapFLibBi flib = flib{foreignLibBuildInfo = f (foreignLibBuildInfo flib)} + mapExeBi exe = exe{buildInfo = f (buildInfo exe)} + mapTestBi tst = tst{testBuildInfo = f (testBuildInfo tst)} + mapBenchBi bm = bm{benchmarkBuildInfo = f (benchmarkBuildInfo bm)} 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 @@ -1,7 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Test -- Copyright : Thomas Tuegel 2010 @@ -13,124 +16,178 @@ -- This is the entry point into testing a built package. It performs the -- \"@.\/setup test@\" action. It runs test suites designated in the package -- description and reports on the results. - module Distribution.Simple.Test - ( test - ) where + ( test + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD +import Distribution.Pretty import Distribution.Simple.Compiler +import Distribution.Simple.Flag (fromFlag) import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import qualified Distribution.Types.LocalBuildInfo as LBI -import Distribution.Simple.Setup -import Distribution.Simple.UserHooks +import Distribution.Simple.Setup.Test import qualified Distribution.Simple.Test.ExeV10 as ExeV10 import qualified Distribution.Simple.Test.LibV09 as LibV09 import Distribution.Simple.Test.Log +import Distribution.Simple.UserHooks import Distribution.Simple.Utils import Distribution.TestSuite -import Distribution.Pretty +import qualified Distribution.Types.LocalBuildInfo as LBI +import Distribution.Types.UnqualComponentName +import Distribution.Simple.Configure (getInstalledPackagesById) +import Distribution.Simple.Errors +import Distribution.Simple.Register +import Distribution.Simple.Setup (fromFlagOrDefault) +import Distribution.Simple.Setup.Common (extraCompilationArtifacts) +import Distribution.Simple.Setup.Config +import Distribution.Types.ExposedModule +import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (libraryDirs), exposedModules) +import Distribution.Types.LocalBuildInfo (LocalBuildInfo (..)) import System.Directory - ( createDirectoryIfMissing, doesFileExist, getDirectoryContents - , removeFile ) -import System.FilePath ( () ) - --- |Perform the \"@.\/setup test@\" action. -test :: Args -- ^positional command-line arguments - -> PD.PackageDescription -- ^information from the .cabal file - -> LBI.LocalBuildInfo -- ^information from the configure step - -> TestFlags -- ^flags sent to test - -> IO () -test args pkg_descr lbi flags = do - let verbosity = fromFlag $ testVerbosity flags - machineTemplate = fromFlag $ testMachineLog flags - distPref = fromFlag $ testDistPref flags - testLogDir = distPref "test" - testNames = args - pkgTests = PD.testSuites pkg_descr - enabledTests = LBI.enabledTestLBIs pkg_descr lbi - - doTest :: ((PD.TestSuite, LBI.ComponentLocalBuildInfo), - Maybe TestSuiteLog) -> IO TestSuiteLog - doTest ((suite, clbi), _) = - case PD.testInterface suite of - PD.TestSuiteExeV10 _ _ -> - ExeV10.runTest pkg_descr lbi clbi flags suite + ( createDirectoryIfMissing + , doesFileExist + , getDirectoryContents + , removeFile + ) +import System.FilePath (()) - PD.TestSuiteLibV09 _ _ -> - LibV09.runTest pkg_descr lbi clbi flags suite +-- | Perform the \"@.\/setup test@\" action. +test + :: Args + -- ^ positional command-line arguments + -> PD.PackageDescription + -- ^ information from the .cabal file + -> LBI.LocalBuildInfo + -- ^ information from the configure step + -> TestFlags + -- ^ flags sent to test + -> IO () +test args pkg_descr lbi0 flags = do + let verbosity = fromFlag $ testVerbosity flags + machineTemplate = fromFlag $ testMachineLog flags + distPref = fromFlag $ testDistPref flags + testLogDir = distPref "test" + testNames = args + pkgTests = PD.testSuites pkg_descr + enabledTests = LBI.enabledTestLBIs pkg_descr lbi + -- We must add the internalPkgDB to the package database stack to lookup + -- the path to HPC dirs of libraries local to this package + internalPkgDB = internalPackageDBPath lbi distPref + lbi = lbi0{withPackageDB = withPackageDB lbi0 ++ [SpecificPackageDB internalPkgDB]} - _ -> return TestSuiteLog - { testSuiteName = PD.testName suite - , testLogs = TestLog + doTest + :: HPCMarkupInfo + -> ( (PD.TestSuite, LBI.ComponentLocalBuildInfo) + , Maybe TestSuiteLog + ) + -> IO TestSuiteLog + doTest hpcMarkupInfo ((suite, clbi), _) = + case PD.testInterface suite of + PD.TestSuiteExeV10 _ _ -> + ExeV10.runTest pkg_descr lbi clbi hpcMarkupInfo flags suite + PD.TestSuiteLibV09 _ _ -> + LibV09.runTest pkg_descr lbi clbi hpcMarkupInfo flags suite + _ -> + return + TestSuiteLog + { testSuiteName = PD.testName suite + , testLogs = + TestLog { testName = unUnqualComponentName $ PD.testName suite , testOptionsReturned = [] , testResult = - Error $ "No support for running test suite type: " - ++ show (pretty $ PD.testType suite) + Error $ + "No support for running test suite type: " + ++ show (pretty $ PD.testType suite) } - , logFile = "" - } + , logFile = "" + } - unless (PD.hasTests pkg_descr) $ do - notice verbosity "Package has no test suites." - exitSuccess + unless (PD.hasTests pkg_descr) $ do + notice verbosity "Package has no test suites." + exitSuccess - when (PD.hasTests pkg_descr && null enabledTests) $ - die' verbosity $ - "No test suites enabled. Did you remember to configure with " - ++ "\'--enable-tests\'?" + when (PD.hasTests pkg_descr && null enabledTests) $ + dieWithException verbosity NoTestSuitesEnabled - testsToRun <- case testNames of - [] -> return $ zip enabledTests $ repeat Nothing - names -> for names $ \tName -> - let testMap = zip enabledNames enabledTests - enabledNames = map (PD.testName . fst) enabledTests - allNames = map PD.testName pkgTests - tCompName = mkUnqualComponentName tName - in case lookup tCompName testMap of - Just t -> return (t, Nothing) - _ | tCompName `elem` allNames -> - die' verbosity $ "Package configured with test suite " - ++ tName ++ " disabled." - | otherwise -> die' verbosity $ "no such test: " ++ tName + testsToRun <- case testNames of + [] -> return $ zip enabledTests $ repeat Nothing + names -> for names $ \tName -> + let testMap = zip enabledNames enabledTests + enabledNames = map (PD.testName . fst) enabledTests + allNames = map PD.testName pkgTests + tCompName = mkUnqualComponentName tName + in case lookup tCompName testMap of + Just t -> return (t, Nothing) + _ + | tCompName `elem` allNames -> + dieWithException verbosity $ TestNameDisabled tName + | otherwise -> dieWithException verbosity $ NoSuchTest tName - createDirectoryIfMissing True testLogDir + createDirectoryIfMissing True testLogDir - -- Delete ordinary files from test log directory. - getDirectoryContents testLogDir - >>= filterM doesFileExist . map (testLogDir ) - >>= traverse_ removeFile + -- Delete ordinary files from test log directory. + getDirectoryContents testLogDir + >>= filterM doesFileExist . map (testLogDir ) + >>= traverse_ removeFile - let totalSuites = length testsToRun - notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." - suites <- traverse doTest testsToRun - let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites } - packageLogFile = () testLogDir - $ packageLogPath machineTemplate pkg_descr lbi - allOk <- summarizePackage verbosity packageLog - writeFile packageLogFile $ show packageLog + -- 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 + -- the hpc artifacts into the extraCompilationArtifacts directory, which, at + -- install time, is copied into the ghc-pkg database files. + -- 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 $ + fromFlagOrDefault [] (configCoverageFor (configFlags lbi)) + <> extraCoverageFor lbi + ipkginfos <- getInstalledPackagesById verbosity lbi MissingCoveredInstalledLibrary coverageFor + let ( concat -> pathsToLibsArtifacts + , concat -> libsModulesToInclude + ) = + unzip $ + map + ( \ip -> + ( map ( extraCompilationArtifacts) $ libraryDirs ip + , map exposedName $ exposedModules ip + ) + ) + ipkginfos + hpcMarkupInfo = HPCMarkupInfo{pathsToLibsArtifacts, libsModulesToInclude} - when (LBI.testCoverage lbi) $ - markupPackage verbosity lbi distPref pkg_descr $ - map (fst . fst) testsToRun + let totalSuites = length testsToRun + notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." + suites <- traverse (doTest hpcMarkupInfo) testsToRun + let packageLog = (localPackageLog pkg_descr lbi){testSuites = suites} + packageLogFile = + () testLogDir $ + packageLogPath machineTemplate pkg_descr lbi + allOk <- summarizePackage verbosity packageLog + writeFile packageLogFile $ show packageLog - unless allOk exitFailure + when (LBI.testCoverage lbi) $ + markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr $ + map (fst . fst) testsToRun -packageLogPath :: PathTemplate - -> PD.PackageDescription - -> LBI.LocalBuildInfo - -> FilePath + unless allOk exitFailure + +packageLogPath + :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> FilePath packageLogPath template pkg_descr lbi = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) + fromPathTemplate $ substPathTemplate env template + where + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) 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 @@ -2,154 +2,194 @@ {-# LANGUAGE RankNTypes #-} module Distribution.Simple.Test.ExeV10 - ( runTest - ) where + ( runTest + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName import Distribution.Compat.Environment import qualified Distribution.PackageDescription as PD import Distribution.Simple.Build.PathsModule import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler +import Distribution.Simple.Flag import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import qualified Distribution.Types.LocalBuildInfo as LBI -import Distribution.Simple.Setup + ( ComponentLocalBuildInfo (..) + , buildDir + , depLibraryPaths + ) +import Distribution.Simple.Setup.Test import Distribution.Simple.Test.Log import Distribution.Simple.Utils import Distribution.System import Distribution.TestSuite -import Distribution.Pretty +import qualified Distribution.Types.LocalBuildInfo as LBI + ( LocalBuildInfo (..) + , localUnitId + , testCoverage + ) +import Distribution.Types.UnqualComponentName import Distribution.Verbosity import System.Directory - ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist - , getCurrentDirectory, removeDirectoryRecursive ) -import System.FilePath ( (), (<.>) ) -import System.IO ( stdout, stderr ) -import System.Process ( createPipe ) + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + , removeDirectoryRecursive + ) +import System.FilePath ((<.>), ()) +import System.IO (stderr, stdout) +import System.Process (createPipe) import qualified Data.ByteString.Lazy as LBS - -runTest :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> LBI.ComponentLocalBuildInfo - -> TestFlags - -> PD.TestSuite - -> IO TestSuiteLog -runTest pkg_descr lbi clbi flags suite = do - let isCoverageEnabled = LBI.testCoverage lbi - way = guessWay lbi - tixDir_ = tixDir distPref way testName' - - pwd <- getCurrentDirectory - existingEnv <- getEnvironment +import Distribution.Simple.Errors - let cmd = LBI.buildDir lbi testName' - testName' <.> exeExtension (LBI.hostPlatform lbi) - -- Check that the test executable exists. - exists <- doesFileExist cmd - unless exists $ die' verbosity $ "Could not find test program \"" ++ cmd - ++ "\". Did you build the package first?" +runTest + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> LBI.ComponentLocalBuildInfo + -> HPCMarkupInfo + -> TestFlags + -> PD.TestSuite + -> IO TestSuiteLog +runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do + let isCoverageEnabled = LBI.testCoverage lbi + way = guessWay lbi + tixDir_ = tixDir distPref way - -- Remove old .tix files if appropriate. - unless (fromFlag $ testKeepTix flags) $ do - exists' <- doesDirectoryExist tixDir_ - when exists' $ removeDirectoryRecursive tixDir_ + pwd <- getCurrentDirectory + existingEnv <- getEnvironment - -- Create directory for HPC files. - createDirectoryIfMissing True tixDir_ + let cmd = + LBI.buildDir lbi + testName' + testName' <.> exeExtension (LBI.hostPlatform lbi) + -- Check that the test executable exists. + exists <- doesFileExist cmd + unless exists $ + dieWithException verbosity $ + Couldn'tFindTestProgram cmd - -- Write summary notices indicating start of test suite - notice verbosity $ summarizeSuiteStart $ testName' + -- Remove old .tix files if appropriate. + unless (fromFlag $ testKeepTix flags) $ do + exists' <- doesDirectoryExist tixDir_ + when exists' $ removeDirectoryRecursive tixDir_ + -- Create directory for HPC files. + createDirectoryIfMissing True tixDir_ - -- Run the test executable - let opts = map (testOption pkg_descr lbi suite) - (testOptions flags) - dataDirPath = pwd PD.dataDir pkg_descr - tixFile = pwd tixFilePath distPref way (testName') - pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) - : existingEnv - shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart $ testName' - -- Add (DY)LD_LIBRARY_PATH if needed - shellEnv' <- if LBI.withDynExe lbi - then do let (Platform _ os) = LBI.hostPlatform lbi - paths <- LBI.depLibraryPaths True False lbi clbi - return (addLibraryPath os paths shellEnv) - else return shellEnv + -- Run the test executable + let opts = + map + (testOption pkg_descr lbi suite) + (testOptions flags) + dataDirPath = pwd PD.dataDir pkg_descr + tixFile = pwd tixFilePath distPref way (testName') + pkgPathEnv = + (pkgPathEnvVar pkg_descr "datadir", dataDirPath) + : existingEnv + shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv - -- Output logger - (wOut, wErr, getLogText) <- case details of - Direct -> return (stdout, stderr, return LBS.empty) - _ -> do - (rOut, wOut) <- createPipe + -- Add (DY)LD_LIBRARY_PATH if needed + shellEnv' <- + if LBI.withDynExe lbi + then do + let (Platform _ os) = LBI.hostPlatform lbi + paths <- LBI.depLibraryPaths True False lbi clbi + return (addLibraryPath os paths shellEnv) + else return shellEnv - return $ (,,) wOut wOut $ do - -- Read test executables' output - logText <- LBS.hGetContents rOut + -- Output logger + (wOut, wErr, getLogText) <- case details of + Direct -> return (stdout, stderr, return LBS.empty) + _ -> do + (rOut, wOut) <- createPipe - -- '--show-details=streaming': print the log output in another thread - when (details == Streaming) $ LBS.putStr logText + return $ (,,) wOut wOut $ do + -- Read test executables' output + logText <- LBS.hGetContents rOut - -- drain the output. - evaluate (force logText) + -- '--show-details=streaming': print the log output in another thread + when (details == Streaming) $ LBS.putStr logText - (exit, logText) <- case testWrapper flags of - Flag path -> rawSystemIOWithEnvAndAction - verbosity path (cmd:opts) Nothing (Just shellEnv') - getLogText - -- these handles are automatically closed - Nothing (Just wOut) (Just wErr) + -- drain the output. + evaluate (force logText) - NoFlag -> rawSystemIOWithEnvAndAction - verbosity cmd opts Nothing (Just shellEnv') - getLogText - -- these handles are automatically closed - Nothing (Just wOut) (Just wErr) + (exit, logText) <- case testWrapper flags of + Flag path -> + rawSystemIOWithEnvAndAction + verbosity + path + (cmd : opts) + Nothing + (Just shellEnv') + getLogText + -- these handles are automatically closed + Nothing + (Just wOut) + (Just wErr) + NoFlag -> + rawSystemIOWithEnvAndAction + verbosity + cmd + opts + Nothing + (Just shellEnv') + getLogText + -- these handles are automatically closed + Nothing + (Just wOut) + (Just wErr) - -- Generate TestSuiteLog from executable exit code and a machine- - -- readable test log. - let suiteLog = buildLog exit + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log. + let suiteLog = buildLog exit - -- Write summary notice to log file indicating start of test suite - appendFile (logFile suiteLog) $ summarizeSuiteStart testName' + -- Write summary notice to log file indicating start of test suite + appendFile (logFile suiteLog) $ summarizeSuiteStart testName' - -- Append contents of temporary log file to the final human- - -- readable log file - LBS.appendFile (logFile suiteLog) logText + -- Append contents of temporary log file to the final human- + -- readable log file + LBS.appendFile (logFile suiteLog) logText - -- Write end-of-suite summary notice to log file - appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog + -- Write end-of-suite summary notice to log file + appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog - -- Show the contents of the human-readable log file on the terminal - -- if there is a failure and/or detailed output is requested - let whenPrinting = when $ - ( details == Always || - details == Failures && not (suitePassed $ testLogs suiteLog)) + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let whenPrinting = + when $ + ( details == Always + || details == Failures && not (suitePassed $ testLogs suiteLog) + ) -- verbosity overrides show-details && verbosity >= normal - whenPrinting $ do - LBS.putStr logText - putChar '\n' + whenPrinting $ do + LBS.putStr logText + putChar '\n' - -- Write summary notice to terminal indicating end of test suite - notice verbosity $ summarizeSuiteFinish suiteLog + -- Write summary notice to terminal indicating end of test suite + notice verbosity $ summarizeSuiteFinish suiteLog - when isCoverageEnabled $ - case PD.library pkg_descr of - Nothing -> - die' verbosity "Test coverage is only supported for packages with a library component." + when isCoverageEnabled $ do + -- Until #9493 is fixed, we expect cabal-install to pass one dist dir per + -- library and there being at least one library in the package with the + -- testsuite. When it is fixed, we can remove this predicate and allow a + -- testsuite without a library to cover libraries in other packages of the + -- same project + when (null $ PD.allLibraries pkg_descr) $ + dieWithException verbosity TestCoverageSupport - Just library -> - markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library + markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr [suite] - return suiteLog + return suiteLog where testName' = unUnqualComponentName $ PD.testName suite @@ -159,35 +199,44 @@ testLogDir = distPref "test" buildLog exit = - let r = case exit of - ExitSuccess -> Pass - ExitFailure c -> Fail $ "exit code: " ++ show c - --n = unUnqualComponentName $ PD.testName suite - l = TestLog - { testName = testName' - , testOptionsReturned = [] - , testResult = r - } - in TestSuiteLog - { testSuiteName = PD.testName suite - , testLogs = l - , logFile = - testLogDir - testSuiteLogPath (fromFlag $ testHumanLog flags) - pkg_descr lbi testName' l - } + let r = case exit of + ExitSuccess -> Pass + ExitFailure c -> Fail $ "exit code: " ++ show c + -- n = unUnqualComponentName $ PD.testName suite + l = + TestLog + { testName = testName' + , testOptionsReturned = [] + , testResult = r + } + in TestSuiteLog + { testSuiteName = PD.testName suite + , testLogs = l + , logFile = + testLogDir + testSuiteLogPath + (fromFlag $ testHumanLog flags) + pkg_descr + lbi + testName' + l + } -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path. -testOption :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> PD.TestSuite - -> PathTemplate - -> String +testOption + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.TestSuite + -> PathTemplate + -> String testOption pkg_descr lbi suite template = - fromPathTemplate $ substPathTemplate env template + fromPathTemplate $ substPathTemplate env template where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] 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 @@ -2,197 +2,235 @@ {-# LANGUAGE RankNTypes #-} module Distribution.Simple.Test.LibV09 - ( runTest - -- Test stub - , simpleTestStub - , stubFilePath, stubMain, stubName, stubWriteLog - , writeSimpleTestStub - ) where + ( runTest + -- Test stub + , simpleTestStub + , stubFilePath + , stubMain + , stubName + , stubWriteLog + , writeSimpleTestStub + ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Types.UnqualComponentName +import Prelude () import Distribution.Compat.Environment import Distribution.Compat.Internal.TempFile import Distribution.ModuleName import qualified Distribution.PackageDescription as PD +import Distribution.Pretty import Distribution.Simple.Build.PathsModule import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler +import Distribution.Simple.Flag (Flag (Flag, NoFlag), fromFlag) import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import qualified Distribution.Types.LocalBuildInfo as LBI -import Distribution.Simple.Setup +import Distribution.Simple.Setup.Test import Distribution.Simple.Test.Log import Distribution.Simple.Utils import Distribution.System import Distribution.TestSuite -import Distribution.Pretty +import qualified Distribution.Types.LocalBuildInfo as LBI import Distribution.Verbosity import qualified Control.Exception as CE import qualified Data.ByteString.Lazy as LBS -import System.Directory - ( createDirectoryIfMissing, canonicalizePath - , doesDirectoryExist, doesFileExist - , getCurrentDirectory, removeDirectoryRecursive, removeFile - , setCurrentDirectory ) -import System.FilePath ( (), (<.>) ) -import System.IO ( hClose, hPutStr ) import Distribution.Compat.Process (proc) +import Distribution.Simple.Errors +import System.Directory + ( canonicalizePath + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + , removeDirectoryRecursive + , removeFile + , setCurrentDirectory + ) +import System.FilePath ((<.>), ()) +import System.IO (hClose, hPutStr) import qualified System.Process as Process -runTest :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> LBI.ComponentLocalBuildInfo - -> TestFlags - -> PD.TestSuite - -> IO TestSuiteLog -runTest pkg_descr lbi clbi flags suite = do - let isCoverageEnabled = LBI.testCoverage lbi - way = guessWay lbi +runTest + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> LBI.ComponentLocalBuildInfo + -> HPCMarkupInfo + -> TestFlags + -> PD.TestSuite + -> IO TestSuiteLog +runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do + let isCoverageEnabled = LBI.testCoverage lbi + way = guessWay lbi - pwd <- getCurrentDirectory - existingEnv <- getEnvironment + pwd <- getCurrentDirectory + existingEnv <- getEnvironment - let cmd = LBI.buildDir lbi stubName suite - stubName suite <.> exeExtension (LBI.hostPlatform lbi) - -- Check that the test executable exists. - exists <- doesFileExist cmd - unless exists $ - die' verbosity $ "Could not find test program \"" ++ cmd - ++ "\". Did you build the package first?" + let cmd = + LBI.buildDir lbi + stubName suite + stubName suite <.> exeExtension (LBI.hostPlatform lbi) + -- Check that the test executable exists. + exists <- doesFileExist cmd + unless exists $ + dieWithException verbosity $ + Couldn'tFindTestProgLibV09 cmd - -- Remove old .tix files if appropriate. - unless (fromFlag $ testKeepTix flags) $ do - let tDir = tixDir distPref way testName' - exists' <- doesDirectoryExist tDir - when exists' $ removeDirectoryRecursive tDir + -- Remove old .tix files if appropriate. + unless (fromFlag $ testKeepTix flags) $ do + let tDir = tixDir distPref way + exists' <- doesDirectoryExist tDir + when exists' $ removeDirectoryRecursive tDir - -- Create directory for HPC files. - createDirectoryIfMissing True $ tixDir distPref way testName' + -- Create directory for HPC files. + createDirectoryIfMissing True $ tixDir distPref way - -- Write summary notices indicating start of test suite - notice verbosity $ summarizeSuiteStart testName' + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart testName' - suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do + suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do + -- Run test executable + let opts = map (testOption pkg_descr lbi suite) $ testOptions flags + dataDirPath = pwd PD.dataDir pkg_descr + tixFile = pwd tixFilePath distPref way testName' + pkgPathEnv = + (pkgPathEnvVar pkg_descr "datadir", dataDirPath) + : existingEnv + shellEnv = + [("HPCTIXFILE", tixFile) | isCoverageEnabled] + ++ pkgPathEnv + -- Add (DY)LD_LIBRARY_PATH if needed + shellEnv' <- + if LBI.withDynExe lbi + then do + let (Platform _ os) = LBI.hostPlatform lbi + paths <- LBI.depLibraryPaths True False lbi clbi + cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi + return (addLibraryPath os (cpath : paths) shellEnv) + else return shellEnv + let (cmd', opts') = case testWrapper flags of + Flag path -> (path, cmd : opts) + NoFlag -> (cmd, opts) - -- Run test executable - let opts = map (testOption pkg_descr lbi suite) $ testOptions flags - dataDirPath = pwd PD.dataDir pkg_descr - tixFile = pwd tixFilePath distPref way testName' - pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) - : existingEnv - shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] - ++ pkgPathEnv - -- Add (DY)LD_LIBRARY_PATH if needed - shellEnv' <- - if LBI.withDynExe lbi - then do - let (Platform _ os) = LBI.hostPlatform lbi - paths <- LBI.depLibraryPaths True False lbi clbi - cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi - return (addLibraryPath os (cpath : paths) shellEnv) - else return shellEnv - let (cmd', opts') = case testWrapper flags of - Flag path -> (path, cmd:opts) - NoFlag -> (cmd, opts) + -- TODO: this setup is broken, + -- if the test output is too big, we will deadlock. + (rOut, wOut) <- Process.createPipe + (exitcode, logText) <- rawSystemProcAction + verbosity + (proc cmd' opts') + { Process.env = Just shellEnv' + , Process.std_in = Process.CreatePipe + , Process.std_out = Process.UseHandle wOut + , Process.std_err = Process.UseHandle wOut + } + $ \mIn _ _ -> do + let wIn = fromCreatePipe mIn + hPutStr wIn $ show (tempLog, PD.testName suite) + hClose wIn - -- TODO: this setup is broken, - -- if the test output is too big, we will deadlock. - (rOut, wOut) <- Process.createPipe - (exitcode, logText) <- rawSystemProcAction verbosity - (proc cmd' opts') { Process.env = Just shellEnv' - , Process.std_in = Process.CreatePipe - , Process.std_out = Process.UseHandle wOut - , Process.std_err = Process.UseHandle wOut - } $ \mIn _ _ -> do - let wIn = fromCreatePipe mIn - hPutStr wIn $ show (tempLog, PD.testName suite) - hClose wIn + -- Append contents of temporary log file to the final human- + -- readable log file + logText <- LBS.hGetContents rOut + -- Force the IO manager to drain the test output pipe + _ <- evaluate (force logText) + return logText + unless (exitcode == ExitSuccess) $ + debug verbosity $ + cmd ++ " returned " ++ show exitcode - -- Append contents of temporary log file to the final human- - -- readable log file - logText <- LBS.hGetContents rOut - -- Force the IO manager to drain the test output pipe - _ <- evaluate (force logText) - return logText - unless (exitcode == ExitSuccess) $ - debug verbosity $ cmd ++ " returned " ++ show exitcode + -- Generate final log file name + let finalLogName l = + testLogDir + testSuiteLogPath + (fromFlag $ testHumanLog flags) + pkg_descr + lbi + (unUnqualComponentName $ testSuiteName l) + (testLogs l) + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log + suiteLog <- + fmap + ( \s -> + (\l -> l{logFile = finalLogName l}) + . fromMaybe (error $ "panic! read @TestSuiteLog " ++ show s) + $ readMaybe s -- TODO: eradicateNoParse + ) + $ readFile tempLog - -- Generate final log file name - let finalLogName l = testLogDir - testSuiteLogPath - (fromFlag $ testHumanLog flags) pkg_descr lbi - (unUnqualComponentName $ testSuiteName l) (testLogs l) - -- Generate TestSuiteLog from executable exit code and a machine- - -- readable test log - suiteLog <- fmap (\s -> (\l -> l { logFile = finalLogName l }) - . fromMaybe (error $ "panic! read @TestSuiteLog " ++ show s) $ readMaybe s) -- TODO: eradicateNoParse - $ readFile tempLog + -- Write summary notice to log file indicating start of test suite + appendFile (logFile suiteLog) $ summarizeSuiteStart testName' - -- Write summary notice to log file indicating start of test suite - appendFile (logFile suiteLog) $ summarizeSuiteStart testName' + LBS.appendFile (logFile suiteLog) logText - LBS.appendFile (logFile suiteLog) logText + -- Write end-of-suite summary notice to log file + appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog - -- Write end-of-suite summary notice to log file - appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let details = fromFlag $ testShowDetails flags + whenPrinting = + when $ + (details > Never) + && (not (suitePassed $ testLogs suiteLog) || details == Always) + && verbosity >= normal + whenPrinting $ do + LBS.putStr logText + putChar '\n' - -- Show the contents of the human-readable log file on the terminal - -- if there is a failure and/or detailed output is requested - let details = fromFlag $ testShowDetails flags - whenPrinting = when $ (details > Never) - && (not (suitePassed $ testLogs suiteLog) || details == Always) - && verbosity >= normal - whenPrinting $ do - LBS.putStr logText - putChar '\n' + return suiteLog - return suiteLog + -- Write summary notice to terminal indicating end of test suite + notice verbosity $ summarizeSuiteFinish suiteLog - -- Write summary notice to terminal indicating end of test suite - notice verbosity $ summarizeSuiteFinish suiteLog + when isCoverageEnabled $ do + -- Until #9493 is fixed, we expect cabal-install to pass one dist dir per + -- library and there being at least one library in the package with the + -- testsuite. When it is fixed, we can remove this predicate and allow a + -- testsuite without a library to cover libraries in other packages of the + -- same project + when (null $ PD.allLibraries pkg_descr) $ + dieWithException verbosity TestCoverageSupport - when isCoverageEnabled $ - case PD.library pkg_descr of - Nothing -> - die' verbosity "Test coverage is only supported for packages with a library component." - Just library -> - markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library + markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr [suite] - return suiteLog + return suiteLog where testName' = unUnqualComponentName $ PD.testName suite deleteIfExists file = do - exists <- doesFileExist file - when exists $ removeFile file + exists <- doesFileExist file + when exists $ removeFile file testLogDir = distPref "test" openCabalTemp = do - (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log" - hClose h >> return f + (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log" + hClose h >> return f distPref = fromFlag $ testDistPref flags verbosity = fromFlag $ testVerbosity flags -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path. -testOption :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> PD.TestSuite - -> PathTemplate - -> String +testOption + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.TestSuite + -> PathTemplate + -> String testOption pkg_descr lbi suite template = - fromPathTemplate $ substPathTemplate env template + fromPathTemplate $ substPathTemplate env template where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] -- Test stub ---------- @@ -206,22 +244,26 @@ stubFilePath t = stubName t <.> "hs" -- | Write the source file for a library 'TestSuite' stub executable. -writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub - -- is being created - -> FilePath -- ^ path to directory where stub source - -- should be located - -> IO () +writeSimpleTestStub + :: PD.TestSuite + -- ^ library 'TestSuite' for which a stub + -- is being created + -> FilePath + -- ^ path to directory where stub source + -- should be located + -> IO () writeSimpleTestStub t dir = do - createDirectoryIfMissing True dir - let filename = dir stubFilePath t - m = case PD.testInterface t of - PD.TestSuiteLibV09 _ m' -> m' - _ -> error "writeSimpleTestStub: invalid TestSuite passed" - writeFile filename $ simpleTestStub m + createDirectoryIfMissing True dir + let filename = dir stubFilePath t + m = case PD.testInterface t of + PD.TestSuiteLibV09 _ m' -> m' + _ -> error "writeSimpleTestStub: invalid TestSuite passed" + writeFile filename $ simpleTestStub m -- | Source code for library test suite stub executable simpleTestStub :: ModuleName -> String -simpleTestStub m = unlines +simpleTestStub m = + unlines [ "module Main ( main ) where" , "import Distribution.Simple.Test.LibV09 ( stubMain )" , "import " ++ show (pretty m) ++ " ( tests )" @@ -234,18 +276,22 @@ -- of detectable errors when Cabal is compiled. stubMain :: IO [Test] -> IO () stubMain tests = do - (f, n) <- fmap (\s -> fromMaybe (error $ "panic! read " ++ show s) $ readMaybe s) getContents -- TODO: eradicateNoParse - dir <- getCurrentDirectory - results <- (tests >>= stubRunTests) `CE.catch` errHandler - setCurrentDirectory dir - stubWriteLog f n results + (f, n) <- fmap (\s -> fromMaybe (error $ "panic! read " ++ show s) $ readMaybe s) getContents -- TODO: eradicateNoParse + dir <- getCurrentDirectory + results <- (tests >>= stubRunTests) `CE.catch` errHandler + setCurrentDirectory dir + stubWriteLog f n results where errHandler :: CE.SomeException -> IO TestLogs errHandler e = case CE.fromException e of - Just CE.UserInterrupt -> CE.throwIO e - _ -> return $ TestLog { testName = "Cabal test suite exception", - testOptionsReturned = [], - testResult = Error $ show e } + Just CE.UserInterrupt -> CE.throwIO e + _ -> + return $ + TestLog + { testName = "Cabal test suite exception" + , testOptionsReturned = [] + , testResult = Error $ show e + } -- | The test runner used in library "TestSuite" stub executables. Runs a list -- of 'Test's. An executable calling this function is meant to be invoked as @@ -256,35 +302,36 @@ -- by the calling Cabal process. stubRunTests :: [Test] -> IO TestLogs stubRunTests tests = do - logs <- traverse stubRunTests' tests - return $ GroupLogs "Default" logs + logs <- traverse stubRunTests' tests + return $ GroupLogs "Default" logs where stubRunTests' (Test t) = do - l <- run t >>= finish - summarizeTest normal Always l - return l + l <- run t >>= finish + summarizeTest normal Always l + return l where finish (Finished result) = - return TestLog - { testName = name t - , testOptionsReturned = defaultOptions t - , testResult = result - } + return + TestLog + { testName = name t + , testOptionsReturned = defaultOptions t + , testResult = result + } finish (Progress _ next) = next >>= finish - stubRunTests' g@(Group {}) = do - logs <- traverse stubRunTests' $ groupTests g - return $ GroupLogs (groupName g) logs + stubRunTests' g@(Group{}) = do + logs <- traverse stubRunTests' $ groupTests g + return $ GroupLogs (groupName g) logs stubRunTests' (ExtraOptions _ t) = stubRunTests' t maybeDefaultOption opt = - maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt + maybe Nothing (\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 -- Cabal process to read. stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> IO () stubWriteLog f n logs = do - let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f } - writeFile (logFile testLog) $ show testLog - when (suiteError logs) $ exitWith $ ExitFailure 2 - when (suiteFailed logs) $ exitWith $ ExitFailure 1 - exitSuccess + let testLog = TestSuiteLog{testSuiteName = n, testLogs = logs, logFile = f} + writeFile (logFile testLog) $ show testLog + when (suiteError logs) $ exitWith $ ExitFailure 2 + when (suiteFailed logs) $ exitWith $ ExitFailure 1 + exitSuccess diff --git a/src/Distribution/Simple/Test/Log.hs b/src/Distribution/Simple/Test/Log.hs --- a/src/Distribution/Simple/Test/Log.hs +++ b/src/Distribution/Simple/Test/Log.hs @@ -2,49 +2,53 @@ {-# LANGUAGE RankNTypes #-} module Distribution.Simple.Test.Log - ( PackageLog(..) - , TestLogs(..) - , TestSuiteLog(..) - , countTestResults - , localPackageLog - , summarizePackage - , summarizeSuiteFinish, summarizeSuiteStart - , summarizeTest - , suiteError, suiteFailed, suitePassed - , testSuiteLogPath - ) where + ( PackageLog (..) + , TestLogs (..) + , TestSuiteLog (..) + , countTestResults + , localPackageLog + , summarizePackage + , summarizeSuiteFinish + , summarizeSuiteStart + , summarizeTest + , suiteError + , suiteFailed + , suitePassed + , testSuiteLogPath + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Package -import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD +import Distribution.Pretty import Distribution.Simple.Compiler import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.Setup +import Distribution.Simple.Setup.Test (TestShowDetails (Always, Never)) import Distribution.Simple.Utils import Distribution.System import Distribution.TestSuite +import Distribution.Types.UnqualComponentName import Distribution.Verbosity -import Distribution.Pretty import qualified Prelude (foldl1) -- | Logs all test results for a package, broken down first by test suite and -- then by test case. data PackageLog = PackageLog - { package :: PackageId - , compiler :: CompilerId - , platform :: Platform - , testSuites :: [TestSuiteLog] - } - deriving (Read, Show, Eq) + { package :: PackageId + , compiler :: CompilerId + , platform :: Platform + , testSuites :: [TestSuiteLog] + } + deriving (Read, Show, Eq) -- | A 'PackageLog' with package and platform information specified. localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog -localPackageLog pkg_descr lbi = PackageLog +localPackageLog pkg_descr lbi = + PackageLog { package = PD.package pkg_descr , compiler = compilerId $ LBI.compiler lbi , platform = LBI.hostPlatform lbi @@ -53,114 +57,137 @@ -- | Logs test suite results, itemized by test case. data TestSuiteLog = TestSuiteLog - { testSuiteName :: UnqualComponentName - , testLogs :: TestLogs - , logFile :: FilePath -- path to human-readable log file - } - deriving (Read, Show, Eq) + { testSuiteName :: UnqualComponentName + , testLogs :: TestLogs + , logFile :: FilePath -- path to human-readable log file + } + deriving (Read, Show, Eq) data TestLogs - = TestLog - { testName :: String - , testOptionsReturned :: Options - , testResult :: Result - } - | GroupLogs String [TestLogs] - deriving (Read, Show, Eq) + = TestLog + { testName :: String + , testOptionsReturned :: Options + , testResult :: Result + } + | GroupLogs String [TestLogs] + deriving (Read, Show, Eq) -- | Count the number of pass, fail, and error test results in a 'TestLogs' -- tree. -countTestResults :: TestLogs - -> (Int, Int, Int) -- ^ Passes, fails, and errors, - -- respectively. +countTestResults + :: TestLogs + -> (Int, Int, Int) + -- ^ Passes, fails, and errors, + -- respectively. countTestResults = go (0, 0, 0) where - go (p, f, e) (TestLog { testResult = r }) = - case r of - Pass -> (p + 1, f, e) - Fail _ -> (p, f + 1, e) - Error _ -> (p, f, e + 1) + go (p, f, e) (TestLog{testResult = r}) = + case r of + Pass -> (p + 1, f, e) + Fail _ -> (p, f + 1, e) + Error _ -> (p, f, e + 1) go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts -- | From a 'TestSuiteLog', determine if the test suite passed. suitePassed :: TestLogs -> Bool suitePassed l = - case countTestResults l of - (_, 0, 0) -> True - _ -> False + case countTestResults l of + (_, 0, 0) -> True + _ -> False -- | From a 'TestSuiteLog', determine if the test suite failed. suiteFailed :: TestLogs -> Bool suiteFailed l = - case countTestResults l of - (_, 0, _) -> False - _ -> True + case countTestResults l of + (_, 0, _) -> False + _ -> True -- | From a 'TestSuiteLog', determine if the test suite encountered errors. suiteError :: TestLogs -> Bool suiteError l = - case countTestResults l of - (_, _, 0) -> False - _ -> True + case countTestResults l of + (_, _, 0) -> False + _ -> True resultString :: TestLogs -> String -resultString l | suiteError l = "error" - | suiteFailed l = "fail" - | otherwise = "pass" +resultString l + | suiteError l = "error" + | suiteFailed l = "fail" + | otherwise = "pass" -testSuiteLogPath :: PathTemplate - -> PD.PackageDescription - -> LBI.LocalBuildInfo - -> String -- ^ test suite name - -> TestLogs -- ^ test suite results - -> FilePath +testSuiteLogPath + :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> String + -- ^ test suite name + -> TestLogs + -- ^ test suite results + -> FilePath testSuiteLogPath template pkg_descr lbi test_name result = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) - ++ [ (TestSuiteNameVar, toPathTemplate test_name) - , (TestSuiteResultVar, toPathTemplate $ resultString result) - ] + fromPathTemplate $ substPathTemplate env template + where + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [ (TestSuiteNameVar, toPathTemplate test_name) + , (TestSuiteResultVar, toPathTemplate $ resultString result) + ] -- | Print a summary to the console after all test suites have been run -- indicating the number of successful test suites and cases. Returns 'True' if -- all test suites passed and 'False' otherwise. summarizePackage :: Verbosity -> PackageLog -> IO Bool summarizePackage verbosity packageLog = do - let counts = map (countTestResults . testLogs) $ testSuites packageLog - (passed, failed, errors) = Prelude.foldl1 addTriple counts - totalCases = passed + failed + errors - passedSuites = length - $ filter (suitePassed . testLogs) - $ testSuites packageLog - totalSuites = length $ testSuites packageLog - notice verbosity $ show passedSuites ++ " of " ++ show totalSuites - ++ " test suites (" ++ show passed ++ " of " - ++ show totalCases ++ " test cases) passed." - return $! passedSuites == totalSuites + let counts = map (countTestResults . testLogs) $ testSuites packageLog + (passed, failed, errors) = Prelude.foldl1 addTriple counts + totalCases = passed + failed + errors + passedSuites = + length $ + filter (suitePassed . testLogs) $ + testSuites packageLog + totalSuites = length $ testSuites packageLog + notice verbosity $ + show passedSuites + ++ " of " + ++ show totalSuites + ++ " test suites (" + ++ show passed + ++ " of " + ++ show totalCases + ++ " test cases) passed." + return $! passedSuites == totalSuites where addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2) -- | Print a summary of a single test case's result to the console, suppressing -- output for certain verbosity or test filter levels. summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO () -summarizeTest _ _ (GroupLogs {}) = return () +summarizeTest _ _ (GroupLogs{}) = return () summarizeTest verbosity details t = - when shouldPrint $ notice verbosity $ "Test case " ++ testName t - ++ ": " ++ show (testResult t) - where shouldPrint = (details > Never) && (notPassed || details == Always) - notPassed = testResult t /= Pass + when shouldPrint $ + notice verbosity $ + "Test case " + ++ testName t + ++ ": " + ++ show (testResult t) + where + shouldPrint = (details > Never) && (notPassed || details == Always) + notPassed = testResult t /= Pass -- | Print a summary of the test suite's results on the console, suppressing -- output for certain verbosity or test filter levels. summarizeSuiteFinish :: TestSuiteLog -> String -summarizeSuiteFinish testLog = unlines +summarizeSuiteFinish testLog = + unlines [ "Test suite " ++ prettyShow (testSuiteName testLog) ++ ": " ++ resStr , "Test suite logged to: " ++ logFile testLog ] - where resStr = map toUpper (resultString $ testLogs testLog) + where + resStr = map toUpper (resultString $ testLogs testLog) summarizeSuiteStart :: String -> String summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n" 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 @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.UHC -- Copyright : Andres Loeh 2009 @@ -16,57 +17,67 @@ -- Thanks to the authors of the other implementation-specific files, in -- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for -- inspiration on how to design this module. - -module Distribution.Simple.UHC ( - configure, getInstalledPackages, - buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath +module Distribution.Simple.UHC + ( configure + , getInstalledPackages + , buildLib + , buildExe + , installLib + , registerPackage + , inplacePackageDbPath ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.InstalledPackageInfo import Distribution.Package hiding (installedUnitId) import Distribution.PackageDescription +import Distribution.Parsec +import Distribution.Pretty import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex import Distribution.Simple.Program import Distribution.Simple.Utils -import Distribution.Pretty -import Distribution.Parsec +import Distribution.System import Distribution.Types.MungedPackageId +import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version -import Distribution.System import Language.Haskell.Extension -import Distribution.Utils.Path -import qualified Data.Map as Map ( empty ) +import qualified Data.Map as Map (empty) import System.Directory import System.FilePath -- ----------------------------------------------------------------------------- -- Configuring -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) +configure + :: Verbosity + -> Maybe FilePath + -> Maybe FilePath + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) configure verbosity hcPath _hcPkgPath progdb = do - (_uhcProg, uhcVersion, progdb') <- - requireProgramVersion verbosity uhcProgram - (orLaterVersion (mkVersion [1,0,2])) - (userMaybeSpecifyPath "uhc" hcPath progdb) + requireProgramVersion + verbosity + uhcProgram + (orLaterVersion (mkVersion [1, 0, 2])) + (userMaybeSpecifyPath "uhc" hcPath progdb) - let comp = Compiler { - compilerId = CompilerId UHC uhcVersion, - compilerAbiTag = NoAbiTag, - compilerCompat = [], - compilerLanguages = uhcLanguages, - compilerExtensions = uhcLanguageExtensions, - compilerProperties = Map.empty - } + let comp = + Compiler + { compilerId = CompilerId UHC uhcVersion + , compilerAbiTag = NoAbiTag + , compilerCompat = [] + , compilerLanguages = uhcLanguages + , compilerExtensions = uhcLanguageExtensions + , compilerProperties = Map.empty + } compPlatform = Nothing return (comp, compPlatform, progdb') @@ -76,64 +87,78 @@ -- | The flags for the supported extensions. uhcLanguageExtensions :: [(Extension, Maybe CompilerFlag)] uhcLanguageExtensions = - let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), - (DisableExtension f, disable)] - alwaysOn = (Nothing, Nothing{- wrong -}) - in concatMap doFlag - [(CPP, (Just "--cpp", Nothing{- wrong -})), - (PolymorphicComponents, alwaysOn), - (ExistentialQuantification, alwaysOn), - (ForeignFunctionInterface, alwaysOn), - (UndecidableInstances, alwaysOn), - (MultiParamTypeClasses, alwaysOn), - (Rank2Types, alwaysOn), - (PatternSignatures, alwaysOn), - (EmptyDataDecls, alwaysOn), - (ImplicitPrelude, (Nothing, Just "--no-prelude"{- wrong -})), - (TypeOperators, alwaysOn), - (OverlappingInstances, alwaysOn), - (FlexibleInstances, alwaysOn)] + let doFlag (f, (enable, disable)) = + [ (EnableExtension f, enable) + , (DisableExtension f, disable) + ] + alwaysOn = (Nothing, Nothing {- wrong -}) + in concatMap + doFlag + [ (CPP, (Just "--cpp", Nothing {- wrong -})) + , (PolymorphicComponents, alwaysOn) + , (ExistentialQuantification, alwaysOn) + , (ForeignFunctionInterface, alwaysOn) + , (UndecidableInstances, alwaysOn) + , (MultiParamTypeClasses, alwaysOn) + , (Rank2Types, alwaysOn) + , (PatternSignatures, alwaysOn) + , (EmptyDataDecls, alwaysOn) + , (ImplicitPrelude, (Nothing, Just "--no-prelude" {- wrong -})) + , (TypeOperators, alwaysOn) + , (OverlappingInstances, alwaysOn) + , (FlexibleInstances, alwaysOn) + ] -getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex +getInstalledPackages + :: Verbosity + -> Compiler + -> PackageDBStack + -> ProgramDb + -> IO InstalledPackageIndex getInstalledPackages verbosity comp packagedbs progdb = do let compilerid = compilerId comp systemPkgDir <- getGlobalPackageDir verbosity progdb - userPkgDir <- getUserPackageDir - let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) + userPkgDir <- getUserPackageDir + let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) -- putStrLn $ "pkgdirs: " ++ show pkgDirs - pkgs <- liftM (map addBuiltinVersions . concat) $ - traverse (\ d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d)) - pkgDirs + pkgs <- + liftM (map addBuiltinVersions . concat) $ + traverse + (\d -> getDirectoryContents 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) getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath getGlobalPackageDir verbosity progdb = do - output <- getDbProgramOutput verbosity - uhcProgram progdb ["--meta-pkgdir-system"] - -- we need to trim because pkgdir contains an extra newline at the end - let pkgdir = trimEnd output - return pkgdir + output <- + getDbProgramOutput + verbosity + uhcProgram + progdb + ["--meta-pkgdir-system"] + -- we need to trim because pkgdir contains an extra newline at the end + let pkgdir = trimEnd output + return pkgdir where trimEnd = dropWhileEnd isSpace getUserPackageDir :: IO FilePath getUserPackageDir = do - homeDir <- getHomeDirectory - return $ homeDir ".cabal" "lib" -- TODO: determine in some other way + homeDir <- getHomeDirectory + return $ homeDir ".cabal" "lib" -- TODO: determine in some other way packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] packageDbPaths user system db = case db of - GlobalPackageDB -> [ system ] - UserPackageDB -> [ user ] - SpecificPackageDB path -> [ path ] + GlobalPackageDB -> [system] + UserPackageDB -> [user] + SpecificPackageDB path -> [path] -- | Hack to add version numbers to UHC-built-in packages. This should sooner or -- later be fixed on the UHC side. @@ -143,7 +168,7 @@ addBuiltinVersions "base" = "base-3.0" addBuiltinVersions "array" = "array-0.2" -} -addBuiltinVersions xs = xs +addBuiltinVersions xs = xs -- | Name of the installed package config file. installedPkgConfig :: String @@ -153,121 +178,164 @@ -- looking only for the presence of an installed package configuration. -- TODO: Actually make use of the information provided in the file. isPkgDir :: String -> String -> String -> IO Bool -isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . -isPkgDir c dir xs = do - let candidate = dir uhcPackageDir xs c - -- putStrLn $ "trying: " ++ candidate - doesFileExist (candidate installedPkgConfig) +isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . +isPkgDir c dir xs = do + let candidate = dir uhcPackageDir xs c + -- putStrLn $ "trying: " ++ candidate + doesFileExist (candidate installedPkgConfig) parsePackage :: String -> [PackageId] -parsePackage = toList . simpleParsec +parsePackage = toList . simpleParsec -- | Create a trivial package info from a directory name. mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo -mkInstalledPackageInfo p = emptyInstalledPackageInfo - { installedUnitId = mkLegacyUnitId p, - sourcePackageId = p } - +mkInstalledPackageInfo p = + emptyInstalledPackageInfo + { installedUnitId = mkLegacyUnitId p + , sourcePackageId = p + } -- ----------------------------------------------------------------------------- -- Building -buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () +buildLib + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () buildLib verbosity pkg_descr lbi lib clbi = do - systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) - userPkgDir <- getUserPackageDir + userPkgDir <- getUserPackageDir let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi) - let uhcArgs = -- set package name - ["--pkg-build=" ++ prettyShow (packageId pkg_descr)] - -- common flags lib/exe - ++ constructUHCCmdLine userPkgDir systemPkgDir - lbi (libBuildInfo lib) clbi - (buildDir lbi) verbosity - -- 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)) + let uhcArgs = + -- set package name + ["--pkg-build=" ++ prettyShow (packageId pkg_descr)] + -- common flags lib/exe + ++ constructUHCCmdLine + userPkgDir + systemPkgDir + lbi + (libBuildInfo lib) + clbi + (buildDir lbi) + verbosity + -- 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)) runUhcProg uhcArgs return () -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () buildExe verbosity _pkg_descr lbi exe clbi = do systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) - userPkgDir <- getUserPackageDir + userPkgDir <- getUserPackageDir let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi) - let uhcArgs = -- common flags lib/exe - constructUHCCmdLine userPkgDir systemPkgDir - lbi (buildInfo exe) clbi - (buildDir lbi) verbosity - -- output file - ++ ["--output", buildDir lbi prettyShow (exeName exe)] - -- main source module - ++ [modulePath exe] + let uhcArgs = + -- common flags lib/exe + constructUHCCmdLine + userPkgDir + systemPkgDir + lbi + (buildInfo exe) + clbi + (buildDir lbi) + verbosity + -- output file + ++ ["--output", buildDir lbi prettyShow (exeName exe)] + -- main source module + ++ [modulePath exe] runUhcProg uhcArgs -constructUHCCmdLine :: FilePath -> FilePath - -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> Verbosity -> [String] +constructUHCCmdLine + :: FilePath + -> FilePath + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> Verbosity + -> [String] constructUHCCmdLine user system lbi bi clbi odir verbosity = - -- verbosity - (if verbosity >= deafening then ["-v4"] - else if verbosity >= normal then [] - else ["-v0"]) - ++ hcOptions UHC bi - -- flags for language extensions - ++ languageToFlags (compiler lbi) (defaultLanguage bi) - ++ extensionsToFlags (compiler lbi) (usedExtensions bi) - -- packages - ++ ["--hide-all-packages"] - ++ uhcPackageDbOptions user system (withPackageDB lbi) - ++ ["--package=uhcbase"] - ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] - -- search paths - ++ ["-i" ++ odir] - ++ ["-i" ++ getSymbolicPath l | l <- nub (hsSourceDirs bi)] - ++ ["-i" ++ autogenComponentModulesDir lbi clbi] - ++ ["-i" ++ autogenPackageModulesDir lbi] - -- cpp options - ++ ["--optP=" ++ opt | opt <- cppOptions bi] - -- output path - ++ ["--odir=" ++ odir] - -- optimization - ++ (case withOptimization lbi of - NoOptimisation -> ["-O0"] - NormalOptimisation -> ["-O1"] - MaximumOptimisation -> ["-O2"]) + -- verbosity + ( if verbosity >= deafening + then ["-v4"] + else + if verbosity >= normal + then [] + else ["-v0"] + ) + ++ hcOptions UHC bi + -- flags for language extensions + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + -- packages + ++ ["--hide-all-packages"] + ++ uhcPackageDbOptions user system (withPackageDB lbi) + ++ ["--package=uhcbase"] + ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi] + -- search paths + ++ ["-i" ++ odir] + ++ ["-i" ++ getSymbolicPath l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ autogenComponentModulesDir lbi clbi] + ++ ["-i" ++ autogenPackageModulesDir lbi] + -- cpp options + ++ ["--optP=" ++ opt | opt <- cppOptions bi] + -- output path + ++ ["--odir=" ++ odir] + -- optimization + ++ ( case withOptimization lbi of + NoOptimisation -> ["-O0"] + NormalOptimisation -> ["-O1"] + MaximumOptimisation -> ["-O2"] + ) uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] -uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x) - (concatMap (packageDbPaths user system) db) +uhcPackageDbOptions user system db = + map + (\x -> "--pkg-searchpath=" ++ x) + (concatMap (packageDbPaths user system) db) -- ----------------------------------------------------------------------------- -- Installation -installLib :: Verbosity -> LocalBuildInfo - -> FilePath -> FilePath -> FilePath - -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO () +installLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -> FilePath + -> FilePath + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do - -- putStrLn $ "dest: " ++ targetDir - -- putStrLn $ "built: " ++ builtDir - installDirectoryContents verbosity (builtDir prettyShow (packageId pkg)) targetDir + -- putStrLn $ "dest: " ++ targetDir + -- putStrLn $ "built: " ++ builtDir + installDirectoryContents verbosity (builtDir prettyShow (packageId pkg)) targetDir -- currently hard-coded UHC code generator and variant to use uhcTarget, uhcTargetVariant :: String -uhcTarget = "bc" +uhcTarget = "bc" uhcTargetVariant = "plain" -- root directory for a package in UHC -uhcPackageDir :: String -> String -> FilePath -uhcPackageSubDir :: String -> FilePath -uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid -uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant +uhcPackageDir :: String -> String -> FilePath +uhcPackageSubDir :: String -> FilePath +uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid +uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant -- ----------------------------------------------------------------------------- -- Registering @@ -280,16 +348,17 @@ -> InstalledPackageInfo -> IO () registerPackage verbosity comp progdb packageDbs installedPkgInfo = do - dbdir <- case registrationPackageDB packageDbs of - GlobalPackageDB -> getGlobalPackageDir verbosity progdb - UserPackageDB -> getUserPackageDir - SpecificPackageDB dir -> return dir - let pkgdir = dbdir uhcPackageDir (prettyShow pkgid) (prettyShow compilerid) - createDirectoryIfMissingVerbose verbosity True pkgdir - writeUTF8File (pkgdir installedPkgConfig) - (showInstalledPackageInfo installedPkgInfo) + dbdir <- case registrationPackageDB packageDbs of + GlobalPackageDB -> getGlobalPackageDir verbosity progdb + UserPackageDB -> getUserPackageDir + SpecificPackageDB dir -> return dir + let pkgdir = dbdir uhcPackageDir (prettyShow pkgid) (prettyShow compilerid) + createDirectoryIfMissingVerbose verbosity True pkgdir + writeUTF8File + (pkgdir installedPkgConfig) + (showInstalledPackageInfo installedPkgInfo) where - pkgid = sourcePackageId installedPkgInfo + pkgid = sourcePackageId installedPkgInfo compilerid = compilerId comp inplacePackageDbPath :: LocalBuildInfo -> FilePath 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 @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.UserHooks -- Copyright : Isaac Jones 2003-2005 @@ -25,21 +26,21 @@ -- pass any extra parameters to most of the functions that implement the -- various phases because it would involve changing the types of the -- corresponding hook. At some point it will have to be replaced. - -module Distribution.Simple.UserHooks ( - UserHooks(..), Args, - emptyUserHooks, +module Distribution.Simple.UserHooks + ( UserHooks (..) + , Args + , emptyUserHooks ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.PackageDescription -import Distribution.Simple.Program import Distribution.Simple.Command +import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PreProcess +import Distribution.Simple.Program import Distribution.Simple.Setup -import Distribution.Simple.LocalBuildInfo type Args = [String] @@ -49,149 +50,137 @@ -- * WARNING: The hooks interface is under rather constant flux as we try to -- understand users needs. Setup files that depend on this interface may -- break in future releases. -data UserHooks = UserHooks { - - -- | Read the description file - readDesc :: IO (Maybe GenericPackageDescription), - -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. - hookedPreProcessors :: [ PPSuffixHandler ], - -- | These programs are detected at configure time. Arguments for them are - -- added to the configure command. - hookedPrograms :: [Program], - - -- |Hook to run before configure command - preConf :: Args -> ConfigFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during configure. - confHook :: (GenericPackageDescription, HookedBuildInfo) - -> ConfigFlags -> IO LocalBuildInfo, - -- |Hook to run after configure command - postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before build command. Second arg indicates verbosity level. - preBuild :: Args -> BuildFlags -> IO HookedBuildInfo, - - -- |Over-ride this hook to get different behavior during build. - buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (), - -- |Hook to run after build command. Second arg indicates verbosity level. - postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before repl command. Second arg indicates verbosity level. - preRepl :: Args -> ReplFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during interpretation. - replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO (), - -- |Hook to run after repl command. Second arg indicates verbosity level. - postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before clean command. Second arg indicates verbosity level. - preClean :: Args -> CleanFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during clean. - cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (), - -- |Hook to run after clean command. Second arg indicates verbosity level. - postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (), - - -- |Hook to run before copy command - preCopy :: Args -> CopyFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during copy. - copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (), - -- |Hook to run after copy command - postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before install command - preInst :: Args -> InstallFlags -> IO HookedBuildInfo, - - -- |Over-ride this hook to get different behavior during install. - instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (), - -- |Hook to run after install command. postInst should be run - -- on the target, not on the build machine. - postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before register command - preReg :: Args -> RegisterFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during registration. - regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), - -- |Hook to run after register command - postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before unregister command - preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during unregistration. - unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), - -- |Hook to run after unregister command - postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before hscolour command. Second arg indicates verbosity level. - preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during hscolour. - hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (), - -- |Hook to run after hscolour command. Second arg indicates verbosity level. - postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before haddock command. Second arg indicates verbosity level. - preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during haddock. - haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), - -- |Hook to run after haddock command. Second arg indicates verbosity level. - postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before test command. - preTest :: Args -> TestFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during test. - testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (), - -- |Hook to run after test command. - postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before bench command. - preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during bench. - benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO (), - -- |Hook to run after bench command. - postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO () +data UserHooks = UserHooks + { readDesc :: IO (Maybe GenericPackageDescription) + -- ^ Read the description file + , hookedPreProcessors :: [PPSuffixHandler] + -- ^ Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. + , hookedPrograms :: [Program] + -- ^ These programs are detected at configure time. Arguments for them are + -- added to the configure command. + , preConf :: Args -> ConfigFlags -> IO HookedBuildInfo + -- ^ Hook to run before configure command + , confHook + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo + -- ^ Over-ride this hook to get different behavior during configure. + , postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after configure command + , preBuild :: Args -> BuildFlags -> IO HookedBuildInfo + -- ^ Hook to run before build command. Second arg indicates verbosity level. + , buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () + -- ^ Over-ride this hook to get different behavior during build. + , postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after build command. Second arg indicates verbosity level. + , preRepl :: Args -> ReplFlags -> IO HookedBuildInfo + -- ^ Hook to run before repl command. Second arg indicates verbosity level. + , replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO () + -- ^ Over-ride this hook to get different behavior during interpretation. + , postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after repl command. Second arg indicates verbosity level. + , preClean :: Args -> CleanFlags -> IO HookedBuildInfo + -- ^ Hook to run before clean command. Second arg indicates verbosity level. + , cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO () + -- ^ Over-ride this hook to get different behavior during clean. + , postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO () + -- ^ Hook to run after clean command. Second arg indicates verbosity level. + , preCopy :: Args -> CopyFlags -> IO HookedBuildInfo + -- ^ Hook to run before copy command + , copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () + -- ^ Over-ride this hook to get different behavior during copy. + , postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after copy command + , preInst :: Args -> InstallFlags -> IO HookedBuildInfo + -- ^ Hook to run before install command + , instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () + -- ^ Over-ride this hook to get different behavior during install. + , postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after install command. postInst should be run + -- on the target, not on the build machine. + , preReg :: Args -> RegisterFlags -> IO HookedBuildInfo + -- ^ Hook to run before register command + , regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () + -- ^ Over-ride this hook to get different behavior during registration. + , postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after register command + , preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo + -- ^ Hook to run before unregister command + , unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () + -- ^ Over-ride this hook to get different behavior during unregistration. + , postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after unregister command + , preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo + -- ^ Hook to run before hscolour command. Second arg indicates verbosity level. + , hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO () + -- ^ Over-ride this hook to get different behavior during hscolour. + , postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after hscolour command. Second arg indicates verbosity level. + , preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo + -- ^ Hook to run before haddock command. Second arg indicates verbosity level. + , haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO () + -- ^ Over-ride this hook to get different behavior during haddock. + , postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after haddock command. Second arg indicates verbosity level. + , preTest :: Args -> TestFlags -> IO HookedBuildInfo + -- ^ Hook to run before test command. + , testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO () + -- ^ Over-ride this hook to get different behavior during test. + , postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after test command. + , preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo + -- ^ Hook to run before bench command. + , benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO () + -- ^ Over-ride this hook to get different behavior during bench. + , postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after bench command. } --- |Empty 'UserHooks' which do nothing. +-- | Empty 'UserHooks' which do nothing. emptyUserHooks :: UserHooks -emptyUserHooks - = UserHooks { - readDesc = return Nothing, - hookedPreProcessors = [], - hookedPrograms = [], - preConf = rn', - confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")), - postConf = ru, - preBuild = rn', - buildHook = ru, - postBuild = ru, - preRepl = \_ _ -> return emptyHookedBuildInfo, - replHook = \_ _ _ _ _ -> return (), - postRepl = ru, - preClean = rn, - cleanHook = ru, - postClean = ru, - preCopy = rn', - copyHook = ru, - postCopy = ru, - preInst = rn, - instHook = ru, - postInst = ru, - preReg = rn', - regHook = ru, - postReg = ru, - preUnreg = rn, - unregHook = ru, - postUnreg = ru, - preHscolour = rn, - hscolourHook = ru, - postHscolour = ru, - preHaddock = rn', - haddockHook = ru, - postHaddock = ru, - preTest = rn', - testHook = \_ -> ru, - postTest = ru, - preBench = rn', - benchHook = \_ -> ru, - postBench = ru +emptyUserHooks = + UserHooks + { readDesc = return Nothing + , hookedPreProcessors = [] + , hookedPrograms = [] + , preConf = rn' + , confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")) + , postConf = ru + , preBuild = rn' + , buildHook = ru + , postBuild = ru + , preRepl = \_ _ -> return emptyHookedBuildInfo + , replHook = \_ _ _ _ _ -> return () + , postRepl = ru + , preClean = rn + , cleanHook = ru + , postClean = ru + , preCopy = rn' + , copyHook = ru + , postCopy = ru + , preInst = rn + , instHook = ru + , postInst = ru + , preReg = rn' + , regHook = ru + , postReg = ru + , preUnreg = rn + , unregHook = ru + , postUnreg = ru + , preHscolour = rn + , hscolourHook = ru + , postHscolour = ru + , preHaddock = rn' + , haddockHook = ru + , postHaddock = ru + , preTest = rn' + , testHook = \_ -> ru + , postTest = ru + , preBench = rn' + , benchHook = \_ -> ru + , postBench = ru } - where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo - rn' _ _ = return emptyHookedBuildInfo - ru _ _ _ _ = return () + where + rn args _ = noExtraFlags args >> return emptyHookedBuildInfo + rn' _ _ = return emptyHookedBuildInfo + ru _ _ _ _ = return () 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,1621 +1,1870 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Utils --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- License : BSD3 --- portions Copyright (c) 2007, Galois Inc. --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- A large and somewhat miscellaneous collection of utility functions used --- throughout the rest of the Cabal lib and in other tools that use the Cabal --- lib like @cabal-install@. It has a very simple set of logging actions. It --- has low level functions for running programs, a bunch of wrappers for --- various directory and file functions that do extra logging. - -module Distribution.Simple.Utils ( - cabalVersion, - - -- * logging and errors - dieNoVerbosity, - die', dieWithLocation', - dieNoWrap, - topHandler, topHandlerWith, - warn, - notice, noticeNoWrap, noticeDoc, - setupMessage, - info, infoNoWrap, - debug, debugNoWrap, - chattyTry, - annotateIO, - withOutputMarker, - - -- * exceptions - handleDoesNotExist, - ignoreSigPipe, - - -- * running programs - rawSystemExit, - rawSystemExitCode, - rawSystemProc, - rawSystemProcAction, - rawSystemExitWithEnv, - rawSystemStdout, - rawSystemStdInOut, - rawSystemIOWithEnv, - rawSystemIOWithEnvAndAction, - fromCreatePipe, - maybeExit, - xargs, - findProgramVersion, - - -- ** 'IOData' re-export - -- - -- These types are re-exported from - -- "Distribution.Utils.IOData" for convenience as they're - -- exposed in the API of 'rawSystemStdInOut' - IOData(..), - KnownIODataMode (..), - IODataMode (..), - - -- * copying files - createDirectoryIfMissingVerbose, - copyFileVerbose, - copyFiles, - copyFileTo, - - -- * installing files - installOrdinaryFile, - installExecutableFile, - installMaybeExecutableFile, - installOrdinaryFiles, - installExecutableFiles, - installMaybeExecutableFiles, - installDirectoryContents, - copyDirectoryRecursive, - - -- * File permissions - doesExecutableExist, - setFileOrdinary, - setFileExecutable, - - -- * file names - currentDir, - shortRelativePath, - dropExeExtension, - exeExtensions, - - -- * finding files - findFileEx, - findFileCwd, - findFirstFile, - findFileWithExtension, - findFileCwdWithExtension, - findFileWithExtension', - findAllFilesWithExtension, - findAllFilesCwdWithExtension, - findModuleFileEx, - findModuleFilesEx, - getDirectoryContentsRecursive, - - -- * environment variables - isInSearchPath, - addLibraryPath, - - -- * modification time - moreRecentFile, - existsAndIsMoreRecentThan, - - -- * temp files and dirs - TempFileOptions(..), defaultTempFileOptions, - withTempFile, withTempFileEx, - withTempDirectory, withTempDirectoryEx, - createTempDirectory, - - -- * .cabal and .buildinfo files - defaultPackageDesc, - findPackageDesc, - findPackageDescCwd, - tryFindPackageDesc, - tryFindPackageDescCwd, - findHookedPackageDesc, - - -- * reading and writing files safely - withFileContents, - writeFileAtomic, - rewriteFileEx, - rewriteFileLBS, - - -- * Unicode - fromUTF8BS, - fromUTF8LBS, - toUTF8BS, - toUTF8LBS, - readUTF8File, - withUTF8FileContents, - writeUTF8File, - normaliseLineEndings, - - -- * BOM - ignoreBOM, - - -- * generic utils - dropWhileEndLE, - takeWhileEndLE, - equating, - comparing, - isInfixOf, - intercalate, - lowercase, - listUnion, - listUnionRight, - ordNub, - ordNubBy, - ordNubRight, - safeHead, - safeTail, - safeLast, - safeInit, - unintersperse, - wrapText, - wrapLine, - - -- * FilePath stuff - isAbsoluteOnAnyPlatform, - isRelativeOnAnyPlatform, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Utils.Generic -import Distribution.Utils.IOData (IOData(..), IODataMode (..), KnownIODataMode (..)) -import qualified Distribution.Utils.IOData as IOData -import Distribution.ModuleName as ModuleName -import Distribution.System -import Distribution.Version -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.Stack -import Distribution.Verbosity -import Distribution.Types.PackageId - -#ifdef CURRENT_PACKAGE_KEY -#define BOOTSTRAPPED_CABAL 1 -#endif - -#ifdef BOOTSTRAPPED_CABAL -import qualified Paths_Cabal (version) -#endif - -import Distribution.Pretty -import Distribution.Parsec - -import Data.Typeable - ( cast ) -import qualified Data.ByteString.Lazy as BS - -import System.Directory - ( Permissions(executable), getDirectoryContents, getPermissions - , doesDirectoryExist, doesFileExist, removeFile - , getModificationTime, createDirectory, removeDirectoryRecursive ) -import System.Environment - ( getProgName ) -import System.FilePath as FilePath - ( normalise, (), (<.>) - , getSearchPath, joinPath, takeDirectory, splitExtension - , splitDirectories, searchPathSeparator ) -import System.IO - ( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush - , hClose, hSetBuffering, BufferMode(..), hPutStrLn ) -import System.IO.Error -import System.IO.Unsafe - ( unsafeInterleaveIO ) -import qualified Control.Exception as Exception - -import Foreign.C.Error (Errno (..), ePIPE) -import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) -import Numeric (showFFloat) -import Distribution.Compat.Process (proc) -import qualified System.Process as Process -import qualified GHC.IO.Exception as GHC - -import qualified Text.PrettyPrint as Disp - --- We only get our own version number when we're building with ourselves -cabalVersion :: Version -#if defined(BOOTSTRAPPED_CABAL) -cabalVersion = mkVersion' Paths_Cabal.version -#elif defined(CABAL_VERSION) -cabalVersion = mkVersion [CABAL_VERSION] -#else -cabalVersion = mkVersion [3,0] --used when bootstrapping -#endif - --- ---------------------------------------------------------------------------- --- Exception and logging utils - --- Cabal's logging infrastructure has a few constraints: --- --- * We must make all logging formatting and emissions decisions based --- on the 'Verbosity' parameter, which is the only parameter that is --- plumbed to enough call-sites to actually be used for this matter. --- (One of Cabal's "big mistakes" is to have never have defined a --- monad of its own.) --- --- * When we 'die', we must raise an IOError. This a backwards --- compatibility consideration, because that's what we've raised --- previously, and if we change to any other exception type, --- exception handlers which match on IOError will no longer work. --- One case where it is known we rely on IOError being catchable --- is 'readPkgConfigDb' in cabal-install; there may be other --- user code that also assumes this. --- --- * The 'topHandler' does not know what 'Verbosity' is, because --- it gets called before we've done command line parsing (where --- the 'Verbosity' parameter would come from). --- --- This leads to two big architectural choices: --- --- * Although naively we might imagine 'Verbosity' to be a simple --- enumeration type, actually it is a full-on abstract data type --- that may contain arbitrarily complex information. At the --- moment, it is fully representable as a string, but we might --- eventually also use verbosity to let users register their --- own logging handler. --- --- * When we call 'die', we perform all the formatting and addition --- of extra information we need, and then ship this in the IOError --- to the top-level handler. Here are alternate designs that --- don't work: --- --- a) Ship the unformatted info to the handler. This doesn't --- work because at the point the handler gets the message, --- we've lost call stacks, and even if we did, we don't have access --- to 'Verbosity' to decide whether or not to render it. --- --- b) Print the information at the 'die' site, then raise an --- error. This means that if the exception is subsequently --- caught by a handler, we will still have emitted the output, --- which is not the correct behavior. --- --- For the top-level handler to "know" that an error message --- contains one of these fully formatted packets, we set a sentinel --- in one of IOError's extra fields. This is handled by --- 'ioeSetVerbatim' and 'ioeGetVerbatim'. --- - -dieNoVerbosity :: String -> IO a -dieNoVerbosity msg - = ioError (userError msg) - where - _ = callStack -- TODO: Attach CallStack to exception - --- | Tag an 'IOError' whose error string should be output to the screen --- verbatim. -ioeSetVerbatim :: IOError -> IOError -ioeSetVerbatim e = ioeSetLocation e "dieVerbatim" - --- | Check if an 'IOError' should be output verbatim to screen. -ioeGetVerbatim :: IOError -> Bool -ioeGetVerbatim e = ioeGetLocation e == "dieVerbatim" - --- | Create a 'userError' whose error text will be output verbatim -verbatimUserError :: String -> IOError -verbatimUserError = ioeSetVerbatim . userError - -dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a -dieWithLocation' verbosity filename mb_lineno msg = - die' verbosity $ - filename ++ (case mb_lineno of - Just lineno -> ":" ++ show lineno - Nothing -> "") ++ - ": " ++ msg - -die' :: Verbosity -> String -> IO a -die' verbosity msg = withFrozenCallStack $ do - ioError . verbatimUserError - =<< annotateErrorString verbosity - =<< pure . wrapTextVerbosity verbosity - =<< pure . addErrorPrefix - =<< prefixWithProgName msg - -dieNoWrap :: Verbosity -> String -> IO a -dieNoWrap verbosity msg = withFrozenCallStack $ do - -- TODO: should this have program name or not? - ioError . verbatimUserError - =<< annotateErrorString verbosity - (addErrorPrefix msg) - --- | Prefixing a message to indicate that it is a fatal error, --- if the 'errorPrefix' is not already present. -addErrorPrefix :: String -> String -addErrorPrefix msg - | errorPrefix `isPrefixOf` msg = msg - -- Backpack prefixes its errors already with "Error:", see - -- 'Distribution.Utils.LogProgress.dieProgress'. - -- Taking it away there destroys the layout, so we rather - -- check here whether the prefix is already present. - | otherwise = unwords [errorPrefix, msg] - --- | A prefix indicating that a message is a fatal error. -errorPrefix :: String -errorPrefix = "Error:" - --- | Prefix an error string with program name from 'getProgName' -prefixWithProgName :: String -> IO String -prefixWithProgName msg = do - pname <- getProgName - return $ pname ++ ": " ++ msg - --- | Annotate an error string with timestamp and 'withMetadata'. -annotateErrorString :: Verbosity -> String -> IO String -annotateErrorString verbosity msg = do - ts <- getPOSIXTime - return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg - --- | Given a block of IO code that may raise an exception, annotate --- it with the metadata from the current scope. Use this as close --- to external code that raises IO exceptions as possible, since --- this function unconditionally wraps the error message with a trace --- (so it is NOT idempotent.) -annotateIO :: Verbosity -> IO a -> IO a -annotateIO verbosity act = do - ts <- getPOSIXTime - flip modifyIOError act $ - ioeModifyErrorString $ withMetadata ts NeverMark VerboseTrace verbosity - --- | A semantic editor for the error message inside an 'IOError'. -ioeModifyErrorString :: (String -> String) -> IOError -> IOError -ioeModifyErrorString = over ioeErrorString - --- | A lens for the error message inside an 'IOError'. -ioeErrorString :: Lens' IOError String -ioeErrorString f ioe = ioeSetErrorString ioe <$> f (ioeGetErrorString ioe) - - -{-# NOINLINE topHandlerWith #-} -topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a -topHandlerWith cont prog = do - -- By default, stderr to a terminal device is NoBuffering. But this - -- is *really slow* - hSetBuffering stderr LineBuffering - Exception.catches prog [ - Exception.Handler rethrowAsyncExceptions - , Exception.Handler rethrowExitStatus - , Exception.Handler handle - ] - where - -- Let async exceptions rise to the top for the default top-handler - rethrowAsyncExceptions :: Exception.AsyncException -> IO a - rethrowAsyncExceptions a = throwIO a - - -- ExitCode gets thrown asynchronously too, and we don't want to print it - rethrowExitStatus :: ExitCode -> IO a - rethrowExitStatus = throwIO - - -- Print all other exceptions - handle :: Exception.SomeException -> IO a - handle se = do - hFlush stdout - pname <- getProgName - hPutStr stderr (message pname se) - cont se - - message :: String -> Exception.SomeException -> String - message pname (Exception.SomeException se) = - case cast se :: Maybe Exception.IOException of - Just ioe - | ioeGetVerbatim ioe -> - -- Use the message verbatim - ioeGetErrorString ioe ++ "\n" - | isUserError ioe -> - let file = case ioeGetFileName ioe of - Nothing -> "" - Just path -> path ++ location ++ ": " - location = case ioeGetLocation ioe of - l@(n:_) | isDigit n -> ':' : l - _ -> "" - detail = ioeGetErrorString ioe - in wrapText $ addErrorPrefix $ pname ++ ": " ++ file ++ detail - _ -> - displaySomeException se ++ "\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 - --- | Depending on 'isVerboseStderr', set the output handle to 'stderr' or 'stdout'. -verbosityHandle :: Verbosity -> Handle -verbosityHandle verbosity - | isVerboseStderr verbosity = stderr - | otherwise = stdout - --- | Non fatal conditions that may be indicative of an error or problem. --- --- We display these at the 'normal' verbosity level. --- -warn :: Verbosity -> String -> IO () -warn verbosity msg = withFrozenCallStack $ do - when ((verbosity >= normal) && not (isVerboseNoWarn verbosity)) $ do - ts <- getPOSIXTime - hFlush stdout - hPutStr stderr . withMetadata ts NormalMark FlagTrace verbosity - . wrapTextVerbosity verbosity - $ "Warning: " ++ msg - --- | Useful status messages. --- --- We display these at the 'normal' verbosity level. --- --- This is for the ordinary helpful status messages that users see. Just --- 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 - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NormalMark FlagTrace verbosity - $ wrapTextVerbosity verbosity - $ msg - --- | Display a message at 'normal' verbosity level, but without --- wrapping. --- -noticeNoWrap :: Verbosity -> String -> IO () -noticeNoWrap verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ msg - --- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity --- level. Use this if you need fancy formatting. --- -noticeDoc :: Verbosity -> Disp.Doc -> IO () -noticeDoc verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NormalMark FlagTrace verbosity - $ Disp.renderStyle defaultStyle - $ msg - --- | Display a "setup status message". Prefer using setupMessage' --- if possible. --- -setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () -setupMessage verbosity msg pkgid = withFrozenCallStack $ do - noticeNoWrap verbosity (msg ++ ' ': prettyShow pkgid ++ "...") - --- | More detail on the operation of some action. --- --- 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 - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NeverMark FlagTrace verbosity - $ wrapTextVerbosity verbosity - $ msg - -infoNoWrap :: Verbosity -> String -> IO () -infoNoWrap verbosity msg = withFrozenCallStack $ - when (verbosity >= verbose) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NeverMark FlagTrace verbosity - $ 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 - ts <- getPOSIXTime - hPutStr h $ withMetadata ts NeverMark FlagTrace verbosity - $ wrapTextVerbosity verbosity - $ msg - -- ensure that we don't lose output if we segfault/infinite loop - hFlush stdout - --- | A variant of 'debug' that doesn't perform the automatic line --- wrapping. Produces better output in some cases. -debugNoWrap :: Verbosity -> String -> IO () -debugNoWrap verbosity msg = withFrozenCallStack $ - when (verbosity >= deafening) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NeverMark FlagTrace verbosity - $ msg - -- ensure that we don't lose output if we segfault/infinite loop - hFlush stdout - --- | Perform an IO action, catching any IO exceptions and printing an error --- if one occurs. -chattyTry :: String -- ^ a description of the action we were attempting - -> IO () -- ^ the action itself - -> IO () -chattyTry desc action = - catchIO action $ \exception -> - hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception - --- | Run an IO computation, returning @e@ if it raises a "file --- does not exist" error. -handleDoesNotExist :: a -> IO a -> IO a -handleDoesNotExist e = - Exception.handleJust - (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing) - (\_ -> return e) - --- ----------------------------------------------------------------------------- --- Helper functions - --- | Wraps text unless the @+nowrap@ verbosity flag is active -wrapTextVerbosity :: Verbosity -> String -> String -wrapTextVerbosity verb - | isVerboseNoWrap verb = withTrailingNewline - | otherwise = withTrailingNewline . wrapText - - --- | Prepends a timestamp if @+timestamp@ verbosity flag is set --- --- This is used by 'withMetadata' --- -withTimestamp :: Verbosity -> POSIXTime -> String -> String -withTimestamp v ts msg - | isVerboseTimestamp v = msg' - | otherwise = msg -- no-op - where - msg' = case lines msg of - [] -> tsstr "\n" - l1:rest -> unlines (tsstr (' ':l1) : map (contpfx++) rest) - - -- format timestamp to be prepended to first line with msec precision - tsstr = showFFloat (Just 3) (realToFrac ts :: Double) - - -- continuation prefix for subsequent lines of msg - contpfx = replicate (length (tsstr " ")) ' ' - --- | Wrap output with a marker if @+markoutput@ verbosity flag is set. --- --- NB: Why is markoutput done with start/end markers, and not prefixes? --- Markers are more convenient to add (if we want to add prefixes, --- we have to 'lines' and then 'map'; here's it's just some --- concatenates). Note that even in the prefix case, we can't --- guarantee that the markers are unambiguous, because some of --- Cabal's output comes straight from external programs, where --- we don't have the ability to interpose on the output. --- --- This is used by 'withMetadata' --- -withOutputMarker :: Verbosity -> String -> String -withOutputMarker v xs | not (isVerboseMarkOutput v) = xs -withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly -withOutputMarker _ xs = - "-----BEGIN CABAL OUTPUT-----\n" ++ - withTrailingNewline xs ++ - "-----END CABAL OUTPUT-----\n" - --- | Append a trailing newline to a string if it does not --- already have a trailing newline. --- -withTrailingNewline :: String -> String -withTrailingNewline "" = "" -withTrailingNewline (x:xs) = x : go x xs - where - go _ (c:cs) = c : go c cs - go '\n' "" = "" - go _ "" = "\n" - --- | Prepend a call-site and/or call-stack based on Verbosity --- -withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String) -withCallStackPrefix tracer verbosity s = withFrozenCallStack $ - (if isVerboseCallSite verbosity - then parentSrcLocPrefix ++ - -- Hack: need a newline before starting output marker :( - if isVerboseMarkOutput verbosity - then "\n" - else "" - else "") ++ - (case traceWhen verbosity tracer of - Just pre -> pre ++ prettyCallStack callStack ++ "\n" - Nothing -> "") ++ - s - --- | When should we emit the call stack? We always emit --- for internal errors, emit the trace for errors when we --- are in verbose mode, and otherwise only emit it if --- explicitly asked for using the @+callstack@ verbosity --- flag. (At the moment, 'AlwaysTrace' is not used. --- -data TraceWhen - = AlwaysTrace - | VerboseTrace - | FlagTrace - deriving (Eq) - --- | Determine if we should emit a call stack. --- If we trace, it also emits any prefix we should append. -traceWhen :: Verbosity -> TraceWhen -> Maybe String -traceWhen _ AlwaysTrace = Just "" -traceWhen v VerboseTrace | v >= verbose = Just "" -traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n" -traceWhen _ _ = Nothing - --- | When should we output the marker? Things like 'die' --- always get marked, but a 'NormalMark' will only be --- output if we're not a quiet verbosity. --- -data MarkWhen = AlwaysMark | NormalMark | NeverMark - --- | Add all necessary metadata to a logging message --- -withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String) -withMetadata ts marker tracer verbosity x = withFrozenCallStack $ - -- NB: order matters. Output marker first because we - -- don't want to capture call stacks. - withTrailingNewline - . withCallStackPrefix tracer verbosity - . (case marker of - AlwaysMark -> withOutputMarker verbosity - NormalMark | not (isVerboseQuiet verbosity) - -> withOutputMarker verbosity - | otherwise - -> id - NeverMark -> id) - -- Clear out any existing markers - . clearMarkers - . withTimestamp verbosity ts - $ x - -clearMarkers :: String -> String -clearMarkers s = unlines . filter isMarker $ lines s - where - isMarker "-----BEGIN CABAL OUTPUT-----" = False - isMarker "-----END CABAL OUTPUT-----" = False - isMarker _ = True - --- ----------------------------------------------------------------------------- --- rawSystem variants --- --- These all use 'Distribution.Compat.Process.proc' to ensure we --- consistently use process jobs on Windows and Ctrl-C delegation --- on Unix. --- --- Additionally, they take care of logging command execution. --- - --- | Helper to use with one of the 'rawSystem' variants, and exit --- unless the command completes successfully. -maybeExit :: IO ExitCode -> IO () -maybeExit cmd = do - exitcode <- cmd - unless (exitcode == ExitSuccess) $ exitWith exitcode - --- | Log a command execution (that's typically about to happen) --- at info level, and log working directory and environment overrides --- at debug level if specified. --- -logCommand :: Verbosity -> Process.CreateProcess -> IO () -logCommand verbosity cp = do - infoNoWrap verbosity $ "Running: " <> case Process.cmdspec cp of - Process.ShellCommand sh -> sh - Process.RawCommand path args -> Process.showCommandForUser path args - case Process.env cp of - Just env -> debugNoWrap verbosity $ "with environment: " ++ show env - Nothing -> return () - case Process.cwd cp of - Just cwd -> debugNoWrap verbosity $ "with working directory: " ++ show cwd - Nothing -> return () - hFlush stdout - --- | Execute the given command with the given arguments, exiting --- with the same exit code if the command fails. --- -rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () -rawSystemExit verbosity path args = withFrozenCallStack $ - maybeExit $ rawSystemExitCode verbosity path args - --- | Execute the given command with the given arguments, returning --- the command's exit code. --- -rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode -rawSystemExitCode verbosity path args = withFrozenCallStack $ - rawSystemProc verbosity $ proc path args - --- | Execute the given command with the given arguments, returning --- the command's exit code. --- --- Create the process argument with 'Distribution.Compat.Process.proc' --- to ensure consistent options with other 'rawSystem' functions in this --- module. --- -rawSystemProc :: Verbosity -> Process.CreateProcess -> IO ExitCode -rawSystemProc verbosity cp = withFrozenCallStack $ do - (exitcode, _) <- rawSystemProcAction verbosity cp $ \_ _ _ -> return () - return exitcode - --- | Execute the given command with the given arguments, returning --- the command's exit code. 'action' is executed while the command --- is running, and would typically be used to communicate with the --- process through pipes. --- --- Create the process argument with 'Distribution.Compat.Process.proc' --- to ensure consistent options with other 'rawSystem' functions in this --- module. --- -rawSystemProcAction :: Verbosity -> Process.CreateProcess - -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a) - -> IO (ExitCode, a) -rawSystemProcAction verbosity cp action = withFrozenCallStack $ do - logCommand verbosity cp - (exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do - a <- action mStdin mStdout mStderr - exitcode <- Process.waitForProcess p - return (exitcode, a) - unless (exitcode == ExitSuccess) $ do - let cmd = case Process.cmdspec cp of - Process.ShellCommand sh -> sh - Process.RawCommand path _args -> path - debug verbosity $ cmd ++ " returned " ++ show exitcode - return (exitcode, a) - --- | 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 - --- | Execute the given command with the given arguments and --- environment, exiting with the same exit code if the command fails. --- -rawSystemExitWithEnv :: Verbosity - -> FilePath - -> [String] - -> [(String, String)] - -> IO () -rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ - maybeExit $ rawSystemProc verbosity $ - (proc path args) { Process.env = Just env - } - --- | Execute the given command with the given arguments, returning --- the command's exit code. --- --- Optional arguments allow setting working directory, environment --- and input and output handles. --- -rawSystemIOWithEnv :: Verbosity - -> FilePath - -> [String] - -> Maybe FilePath -- ^ New working dir or inherit - -> Maybe [(String, String)] -- ^ New environment or inherit - -> Maybe Handle -- ^ stdin - -> Maybe Handle -- ^ stdout - -> Maybe Handle -- ^ stderr - -> IO ExitCode -rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do - (exitcode, _) <- rawSystemIOWithEnvAndAction - verbosity path args mcwd menv action inp out err - return exitcode - where - action = return () - --- | Execute the given command with the given arguments, returning --- the command's exit code. 'action' is executed while the command --- is running, and would typically be used to communicate with the --- process through pipes. --- --- Optional arguments allow setting working directory, environment --- and input and output handles. --- -rawSystemIOWithEnvAndAction - :: Verbosity - -> FilePath - -> [String] - -> Maybe FilePath -- ^ New working dir or inherit - -> Maybe [(String, String)] -- ^ New environment or inherit - -> IO a -- ^ action to perform after process is created, but before 'waitForProcess'. - -> Maybe Handle -- ^ stdin - -> Maybe Handle -- ^ stdout - -> 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 - --- | Execute the given command with the given arguments, returning --- the command's output. Exits if the command exits with error. --- --- Provides control over the binary/text mode of the output. --- -rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode -rawSystemStdout verbosity path args = withFrozenCallStack $ do - (output, errors, exitCode) <- rawSystemStdInOut verbosity path args - Nothing Nothing Nothing (IOData.iodataMode :: IODataMode mode) - when (exitCode /= ExitSuccess) $ - die' verbosity errors - return output - --- | Execute the given command with the given arguments, returning --- the command's output, errors and exit code. --- --- Optional arguments allow setting working directory, environment --- and command input. --- --- Provides control over the binary/text mode of the input and output. --- -rawSystemStdInOut :: KnownIODataMode mode - => Verbosity - -> FilePath -- ^ Program location - -> [String] -- ^ Arguments - -> Maybe FilePath -- ^ New working dir or inherit - -> Maybe [(String, String)] -- ^ New environment or inherit - -> Maybe IOData -- ^ input text and binary mode - -> IODataMode mode -- ^ iodata mode, acts as proxy - -> IO (mode, String, ExitCode) -- ^ output, errors, exit -rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do - let cp = (proc path args) { Process.cwd = mcwd - , Process.env = menv - , Process.std_in = Process.CreatePipe - , Process.std_out = Process.CreatePipe - , Process.std_err = Process.CreatePipe - } - - (exitcode, (mberr1, mberr2)) <- rawSystemProcAction verbosity cp $ \mb_in mb_out mb_err -> do - let (inh, outh, errh) = (fromCreatePipe mb_in, fromCreatePipe mb_out, fromCreatePipe mb_err) - flip Exception.finally (hClose inh >> hClose outh >> hClose errh) $ do - -- output mode depends on what the caller wants - -- but the errors are always assumed to be text (in the current locale) - hSetBinaryMode errh False - - -- fork off a couple threads to pull on the stderr and stdout - -- so if the process writes to stderr we do not block. - - withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do - -- push all the input, if any - ignoreSigPipe $ case input of - Nothing -> hClose inh - Just inputData -> IOData.hPutContents inh inputData - - -- wait for both to finish - mberr1 <- waitCatch outA - mberr2 <- waitCatch errA - return (mberr1, mberr2) - - -- get the stderr, so it can be added to error message - err <- reportOutputIOError mberr2 - - unless (exitcode == ExitSuccess) $ - debug verbosity $ path ++ " returned " ++ show exitcode - ++ if null err then "" else - " with error message:\n" ++ err - ++ case input of - Nothing -> "" - Just d | IOData.null d -> "" - Just (IODataText inp) -> "\nstdin input:\n" ++ inp - Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp - - -- Check if we hit an exception while consuming the output - -- (e.g. a text decoding error) - out <- reportOutputIOError mberr1 - - return (out, err, exitcode) - where - reportOutputIOError :: Either Exception.SomeException a -> IO a - reportOutputIOError (Right x) = return x - reportOutputIOError (Left exc) = case fromException exc of - Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path)) - Nothing -> throwIO exc - --- | Ignore SIGPIPE in a subcomputation. --- -ignoreSigPipe :: IO () -> IO () -ignoreSigPipe = Exception.handle $ \case - GHC.IOError { GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe } - | Errno ioe == ePIPE -> return () - e -> throwIO e - --- | Look for a program and try to find it's version number. It can accept --- either an absolute path or the name of a program binary, in which case we --- will look for the program on the path. --- -findProgramVersion :: String -- ^ version args - -> (String -> String) -- ^ function to select version - -- number from program output - -> Verbosity - -> FilePath -- ^ location - -> IO (Maybe Version) -findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do - str <- rawSystemStdout verbosity path [versionArg] - `catchIO` (\_ -> return "") - `catchExit` (\_ -> return "") - let version :: Maybe Version - version = simpleParsec (selectVersion str) - case version of - Nothing -> warn verbosity $ "cannot determine version of " ++ path - ++ " :\n" ++ show str - Just v -> debug verbosity $ path ++ " is version " ++ prettyShow v - return version - - --- | 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 --- need to invoke a command multiple times to get all the args in. --- --- Use it with either of the rawSystem variants above. For example: --- --- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs --- -xargs :: Int -> ([String] -> IO ()) - -> [String] -> [String] -> IO () -xargs maxSize rawSystemFun fixedArgs bigArgs = - let fixedArgSize = sum (map length fixedArgs) + length fixedArgs - chunkSize = maxSize - fixedArgSize - in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) - - where chunks len = unfoldr $ \s -> - if null s then Nothing - else Just (chunk [] len s) - - chunk acc _ [] = (reverse acc,[]) - chunk acc len (s:ss) - | len' < len = chunk (s:acc) (len-len'-1) ss - | otherwise = (reverse acc, s:ss) - where len' = length s - --- ------------------------------------------------------------ --- * File Utilities --- ------------------------------------------------------------ - ----------------- --- Finding files - - --- | Find a file by looking in a search path. The file path must match exactly. --- --- @since 3.4.0.0 -findFileCwd - :: Verbosity - -> FilePath -- ^ cwd - -> [FilePath] -- ^ relative search location - -> FilePath -- ^ File Name - -> IO FilePath -findFileCwd verbosity cwd searchPath fileName = - findFirstFile (cwd ) - [ path fileName - | path <- nub searchPath] - >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return - --- | Find a file by looking in a search path. The file path must match exactly. --- -findFileEx :: Verbosity - -> [FilePath] -- ^search locations - -> FilePath -- ^File Name - -> IO FilePath -findFileEx verbosity searchPath fileName = - findFirstFile id - [ path fileName - | path <- nub searchPath] - >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return - --- | Find a file by looking in a search path with one of a list of possible --- file extensions. The file base name should be given and it will be tried --- with each of the extensions in each element of the search path. --- -findFileWithExtension :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe FilePath) -findFileWithExtension extensions searchPath baseName = - findFirstFile id - [ path baseName <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - --- | @since 3.4.0.0 -findFileCwdWithExtension - :: FilePath - -> [String] - -> [FilePath] - -> FilePath - -> IO (Maybe FilePath) -findFileCwdWithExtension cwd extensions searchPath baseName = - findFirstFile (cwd ) - [ path baseName <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - --- | @since 3.4.0.0 -findAllFilesCwdWithExtension - :: FilePath -- ^ cwd - -> [String] -- ^ extensions - -> [FilePath] -- ^ relative search locations - -> FilePath -- ^ basename - -> IO [FilePath] -findAllFilesCwdWithExtension cwd extensions searchPath basename = - findAllFiles (cwd ) - [ path basename <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - -findAllFilesWithExtension :: [String] - -> [FilePath] - -> FilePath - -> IO [FilePath] -findAllFilesWithExtension extensions searchPath basename = - findAllFiles id - [ path basename <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - --- | Like 'findFileWithExtension' but returns which element of the search path --- the file was found in, and the file path relative to that base directory. --- -findFileWithExtension' :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe (FilePath, FilePath)) -findFileWithExtension' extensions searchPath baseName = - findFirstFile (uncurry ()) - [ (path, baseName <.> ext) - | path <- nub searchPath - , ext <- nub extensions ] - -findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) -findFirstFile file = findFirst - where findFirst [] = return Nothing - findFirst (x:xs) = do exists <- doesFileExist (file x) - if exists - then return (Just x) - else findFirst xs - -findAllFiles :: (a -> FilePath) -> [a] -> IO [a] -findAllFiles file = filterM (doesFileExist . file) - - --- | Finds the files corresponding to a list of Haskell module names. --- --- As 'findModuleFile' but for a list of module names. --- -findModuleFilesEx :: Verbosity - -> [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> [ModuleName] -- ^ modules - -> IO [(FilePath, FilePath)] -findModuleFilesEx verbosity searchPath extensions moduleNames = - traverse (findModuleFileEx verbosity searchPath extensions) moduleNames - --- | Find the file corresponding to a Haskell module name. --- --- This is similar to 'findFileWithExtension'' but specialised to a module --- name. The function fails if the file corresponding to the module is missing. --- -findModuleFileEx :: Verbosity - -> [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> ModuleName -- ^ module - -> IO (FilePath, FilePath) -findModuleFileEx verbosity searchPath extensions mod_name = - maybe notFound return - =<< findFileWithExtension' extensions searchPath - (ModuleName.toFilePath mod_name) - where - notFound = die' verbosity $ - "Could not find module: " ++ prettyShow mod_name - ++ " with any suffix: " ++ show extensions - ++ " in the search path: " ++ show searchPath - --- | List all the files in a directory and all subdirectories. --- --- The order places files in sub-directories after all the files in their --- parent directories. The list is generated lazily so is not well defined if --- the source directory structure changes before the list is used. --- -getDirectoryContentsRecursive :: FilePath -> IO [FilePath] -getDirectoryContentsRecursive topdir = recurseDirectories [""] - where - recurseDirectories :: [FilePath] -> IO [FilePath] - recurseDirectories [] = return [] - recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) - files' <- recurseDirectories (dirs' ++ dirs) - return (files ++ files') - - where - collect files dirs' [] = return (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) - if isDirectory - then collect files (dirEntry:dirs') entries - else collect (dirEntry:files) dirs' entries - - ignore ['.'] = True - ignore ['.', '.'] = True - ignore _ = False - ------------------------- --- Environment variables - --- | Is this directory in the system search path? -isInSearchPath :: FilePath -> IO Bool -isInSearchPath path = fmap (elem path) getSearchPath - -addLibraryPath :: OS - -> [FilePath] - -> [(String,String)] - -> [(String,String)] -addLibraryPath os paths = addEnv - where - pathsString = intercalate [searchPathSeparator] paths - ldPath = case os of - OSX -> "DYLD_LIBRARY_PATH" - _ -> "LD_LIBRARY_PATH" - - addEnv [] = [(ldPath,pathsString)] - addEnv ((key,value):xs) - | key == ldPath = - if null value - then (key,pathsString):xs - else (key,value ++ (searchPathSeparator:pathsString)):xs - | otherwise = (key,value):addEnv xs - --------------------- --- Modification time - --- | Compare the modification times of two files to see if the first is newer --- than the second. The first file must exist but the second need not. --- The expected use case is when the second file is generated using the first. --- In this use case, if the result is True then the second file is out of date. --- -moreRecentFile :: FilePath -> FilePath -> IO Bool -moreRecentFile a b = do - exists <- doesFileExist b - if not exists - then return True - else do tb <- getModificationTime b - ta <- getModificationTime a - return (ta > tb) - --- | Like 'moreRecentFile', but also checks that the first file exists. -existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool -existsAndIsMoreRecentThan a b = do - exists <- doesFileExist a - if not exists - then return False - else a `moreRecentFile` b - ----------------------------------------- --- Copying and installing files and dirs - --- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. --- -createDirectoryIfMissingVerbose :: Verbosity - -> Bool -- ^ Create its parents too? - -> FilePath - -> IO () -createDirectoryIfMissingVerbose verbosity create_parents path0 - | create_parents = withFrozenCallStack $ createDirs (parents path0) - | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0)) - where - parents = reverse . scanl1 () . splitDirectories . normalise - - createDirs [] = return () - createDirs (dir:[]) = createDir dir throwIO - createDirs (dir:dirs) = - createDir dir $ \_ -> do - createDirs dirs - createDir dir throwIO - - createDir :: FilePath -> (IOException -> IO ()) -> IO () - createDir dir notExistHandler = do - r <- tryIO $ createDirectoryVerbose verbosity dir - case (r :: Either IOException ()) of - Right () -> return () - Left e - | isDoesNotExistError e -> notExistHandler e - -- createDirectory (and indeed POSIX mkdir) does not distinguish - -- between a dir already existing and a file already existing. So we - -- check for it here. Unfortunately there is a slight race condition - -- here, but we think it is benign. It could report an exception in - -- the case that the dir did exist but another process deletes the - -- directory and creates a file in its place before we can check - -- that the directory did indeed exist. - | isAlreadyExistsError e -> (do - isDir <- doesDirectoryExist dir - unless isDir $ throwIO e - ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) - | otherwise -> throwIO e - -createDirectoryVerbose :: Verbosity -> FilePath -> IO () -createDirectoryVerbose verbosity dir = withFrozenCallStack $ do - info verbosity $ "creating " ++ dir - createDirectory dir - setDirOrdinary dir - --- | Copies a file without copying file permissions. The target file is created --- with default permissions. Any existing target file is replaced. --- --- At higher verbosity levels it logs an info message. --- -copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () -copyFileVerbose verbosity src dest = withFrozenCallStack $ do - info verbosity ("copy " ++ src ++ " to " ++ dest) - copyFile src dest - --- | Install an ordinary file. This is like a file copy but the permissions --- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" --- while on Windows it uses the default permissions for the target directory. --- -installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () -installOrdinaryFile verbosity src dest = withFrozenCallStack $ do - info verbosity ("Installing " ++ src ++ " to " ++ dest) - copyOrdinaryFile src dest - --- | Install an executable file. This is like a file copy but the permissions --- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" --- while on Windows it uses the default permissions for the target directory. --- -installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () -installExecutableFile verbosity src dest = withFrozenCallStack $ do - info verbosity ("Installing executable " ++ src ++ " to " ++ dest) - copyExecutableFile src dest - --- | Install a file that may or not be executable, preserving permissions. -installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () -installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do - perms <- getPermissions src - if (executable perms) --only checks user x bit - then installExecutableFile verbosity src dest - else installOrdinaryFile verbosity src dest - --- | Given a relative path to a file, copy it to the given directory, preserving --- the relative path and creating the parent directories if needed. -copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () -copyFileTo verbosity dir file = withFrozenCallStack $ do - let targetFile = dir file - createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) - installOrdinaryFile verbosity file targetFile - --- | Common implementation of 'copyFiles', 'installOrdinaryFiles', --- 'installExecutableFiles' and 'installMaybeExecutableFiles'. -copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ()) - -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do - - -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles - traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs - - -- Copy all the files - sequence_ [ let src = srcBase srcFile - dest = targetDir srcFile - in doCopy verbosity src dest - | (srcBase, srcFile) <- srcFiles ] - --- | Copies a bunch of files to a target directory, preserving the directory --- structure in the target location. The target directories are created if they --- do not exist. --- --- The files are identified by a pair of base directory and a path relative to --- that base. It is only the relative part that is preserved in the --- destination. --- --- For example: --- --- > copyFiles normal "dist/src" --- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] --- --- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and --- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". --- --- This operation is not atomic. Any IO failure during the copy (including any --- missing source files) leaves the target in an unknown state so it is best to --- use it with a freshly created directory so that it can be simply deleted if --- anything goes wrong. --- -copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs) - --- | This is like 'copyFiles' but uses 'installOrdinaryFile'. --- -installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs) - --- | This is like 'copyFiles' but uses 'installExecutableFile'. --- -installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] - -> IO () -installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs) - --- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'. --- -installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] - -> IO () -installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs) - --- | This installs all the files in a directory to a target location, --- preserving the directory layout. All the files are assumed to be ordinary --- rather than executable files. --- -installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () -installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do - info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") - srcFiles <- getDirectoryContentsRecursive srcDir - installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] - --- | Recursively copy the contents of one directory to another path. -copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO () -copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do - info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") - srcFiles <- getDirectoryContentsRecursive srcDir - copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f) - | f <- srcFiles ] - -------------------- --- File permissions - --- | Like 'doesFileExist', but also checks that the file is executable. -doesExecutableExist :: FilePath -> IO Bool -doesExecutableExist f = do - exists <- doesFileExist f - if exists - then do perms <- getPermissions f - return (executable perms) - else return False - ---------------------------- --- Temporary files and dirs - --- | Advanced options for 'withTempFile' and 'withTempDirectory'. -data TempFileOptions = TempFileOptions { - optKeepTempFiles :: Bool -- ^ Keep temporary files? - } - -defaultTempFileOptions :: TempFileOptions -defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False } - --- | Use a temporary filename that doesn't already exist. --- -withTempFile :: FilePath -- ^ Temp dir to create the file in - -> String -- ^ File name template. See 'openTempFile'. - -> (FilePath -> Handle -> IO a) -> IO a -withTempFile tmpDir template action = - withTempFileEx defaultTempFileOptions tmpDir template action - --- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' --- argument. -withTempFileEx :: TempFileOptions - -> FilePath -- ^ Temp dir to create the file in - -> String -- ^ File name template. See 'openTempFile'. - -> (FilePath -> Handle -> IO a) -> IO a -withTempFileEx opts tmpDir template action = - Exception.bracket - (openTempFile tmpDir template) - (\(name, handle) -> do hClose handle - unless (optKeepTempFiles opts) $ - handleDoesNotExist () . removeFile $ name) - (withLexicalCallStack (\x -> uncurry action x)) - --- | Create and use a temporary directory. --- --- 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 ... --- --- The @tmpDir@ will be a new subdirectory of the given directory, e.g. --- @src/sdist.342@. --- -withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectory verbosity targetDir template f = withFrozenCallStack $ - withTempDirectoryEx verbosity defaultTempFileOptions targetDir template - (withLexicalCallStack (\x -> f x)) - --- | A version of 'withTempDirectory' that additionally takes a --- 'TempFileOptions' argument. -withTempDirectoryEx :: Verbosity -> TempFileOptions - -> FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectoryEx _verbosity opts targetDir template f = withFrozenCallStack $ - Exception.bracket - (createTempDirectory targetDir template) - (unless (optKeepTempFiles opts) - . handleDoesNotExist () . removeDirectoryRecursive) - (withLexicalCallStack (\x -> f x)) - ------------------------------------ --- Safely reading and writing files - --- | Write a file but only if it would have new content. If we would be writing --- the same as the existing content then leave the file as is so that we do not --- update the file's modification time. --- --- NB: Before Cabal-3.0 the file content was assumed to be --- ASCII-representable. Since Cabal-3.0 the file is assumed to be --- UTF-8 encoded. -rewriteFileEx :: Verbosity -> FilePath -> String -> IO () -rewriteFileEx verbosity path = - rewriteFileLBS verbosity path . toUTF8LBS - --- | Same as `rewriteFileEx` but for 'ByteString's. -rewriteFileLBS :: Verbosity -> FilePath -> BS.ByteString -> IO () -rewriteFileLBS verbosity path newContent = - flip catchIO mightNotExist $ do - existingContent <- annotateIO verbosity $ BS.readFile path - _ <- evaluate (BS.length existingContent) - unless (existingContent == newContent) $ - annotateIO verbosity $ - writeFileAtomic path newContent - where - mightNotExist e | isDoesNotExistError e - = annotateIO verbosity $ writeFileAtomic path newContent - | otherwise - = ioError e - - --- | The path name that represents the current directory. --- In Unix, it's @\".\"@, but this is system-specific. --- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) -currentDir :: FilePath -currentDir = "." - -shortRelativePath :: FilePath -> FilePath -> FilePath -shortRelativePath from to = - case dropCommonPrefix (splitDirectories from) (splitDirectories to) of - (stuff, path) -> joinPath (map (const "..") stuff ++ path) - where - dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a]) - dropCommonPrefix (x:xs) (y:ys) - | x == y = dropCommonPrefix xs ys - dropCommonPrefix xs ys = (xs,ys) - --- | Drop the extension if it's one of 'exeExtensions', or return the path --- unchanged. -dropExeExtension :: FilePath -> FilePath -dropExeExtension filepath = - -- System.FilePath's extension handling functions are horribly - -- inconsistent, consider: - -- - -- isExtensionOf "" "foo" == False but - -- isExtensionOf "" "foo." == True. - -- - -- On the other hand stripExtension doesn't remove the empty extension: - -- - -- stripExtension "" "foo." == Just "foo." - -- - -- Since by "" in exeExtensions we mean 'no extension' anyways we can - -- just always ignore it here. - let exts = [ ext | ext <- exeExtensions, ext /= "" ] in - fromMaybe filepath $ do - ext <- find (`FilePath.isExtensionOf` filepath) exts - ext `FilePath.stripExtension` filepath - --- | List of possible executable file extensions on the current build --- platform. -exeExtensions :: [String] -exeExtensions = case (buildArch, buildOS) of - -- Possible improvement: on Windows, read the list of extensions from the - -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat; - -- .cmd". - (_, Windows) -> ["", "exe"] - (_, Ghcjs) -> ["", "exe"] - (Wasm32, _) -> ["", "wasm"] - _ -> [""] - --- ------------------------------------------------------------ --- * Finding the description file --- ------------------------------------------------------------ - --- | Package description file (/pkgname/@.cabal@) -defaultPackageDesc :: Verbosity -> IO FilePath -defaultPackageDesc verbosity = tryFindPackageDesc verbosity currentDir - --- |Find a package description file in the given directory. Looks for --- @.cabal@ files. -findPackageDesc :: FilePath -- ^Where to look - -> IO (Either String FilePath) -- ^.cabal -findPackageDesc = findPackageDescCwd "." - --- | @since 3.4.0.0 -findPackageDescCwd - :: FilePath -- ^ project root - -> FilePath -- ^ relative directory - -> IO (Either String FilePath) -- ^ .cabal relative to the project root -findPackageDescCwd cwd dir - = do files <- getDirectoryContents (cwd 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 <- filterM (doesFileExist . snd) - [ (dir file, cwd dir file) - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == ".cabal" ] - case map fst cabalFiles of - [] -> return (Left noDesc) - [cabalFile] -> return (Right cabalFile) - multiple -> return (Left $ multiDesc multiple) - - where - noDesc :: String - noDesc = "No cabal file found.\n" - ++ "Please create a package description file .cabal" - - multiDesc :: [String] -> String - multiDesc l = "Multiple cabal files found.\n" - ++ "Please use only one of: " - ++ intercalate ", " l - --- |Like 'findPackageDesc', but calls 'die' in case of error. -tryFindPackageDesc :: Verbosity -> FilePath -> IO FilePath -tryFindPackageDesc verbosity dir = - either (die' verbosity) return =<< findPackageDesc dir - --- | Like 'findPackageDescCwd', but calls 'die' in case of error. --- --- @since 3.4.0.0 -tryFindPackageDescCwd :: Verbosity -> FilePath -> FilePath -> IO FilePath -tryFindPackageDescCwd verbosity cwd dir = - either (die' verbosity) return =<< findPackageDescCwd cwd dir - --- |Find auxiliary package information in the given directory. --- Looks for @.buildinfo@ files. -findHookedPackageDesc - :: Verbosity - -> FilePath -- ^Directory to search - -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present -findHookedPackageDesc verbosity dir = do - files <- getDirectoryContents dir - buildInfoFiles <- filterM doesFileExist - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == buildInfoExt ] - case buildInfoFiles of - [] -> return Nothing - [f] -> return (Just f) - _ -> die' verbosity ("Multiple files with extension " ++ buildInfoExt) - -buildInfoExt :: String +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Utils +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- License : BSD3 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A large and somewhat miscellaneous collection of utility functions used +-- throughout the rest of the Cabal lib and in other tools that use the Cabal +-- lib like @cabal-install@. It has a very simple set of logging actions. It +-- has low level functions for running programs, a bunch of wrappers for +-- various directory and file functions that do extra logging. +module Distribution.Simple.Utils + ( cabalVersion + + -- * logging and errors + , dieNoVerbosity + , die' + , dieWithException + , dieWithLocation' + , dieNoWrap + , topHandler + , topHandlerWith + , warn + , warnError + , notice + , noticeNoWrap + , noticeDoc + , setupMessage + , info + , infoNoWrap + , debug + , debugNoWrap + , chattyTry + , annotateIO + , exceptionWithMetadata + , withOutputMarker + + -- * exceptions + , handleDoesNotExist + , ignoreSigPipe + + -- * running programs + , rawSystemExit + , rawSystemExitCode + , rawSystemProc + , rawSystemProcAction + , rawSystemExitWithEnv + , rawSystemStdout + , rawSystemStdInOut + , rawSystemIOWithEnv + , rawSystemIOWithEnvAndAction + , fromCreatePipe + , maybeExit + , xargs + , findProgramVersion + + -- ** 'IOData' re-export + + -- + -- These types are re-exported from + -- "Distribution.Utils.IOData" for convenience as they're + -- exposed in the API of 'rawSystemStdInOut' + , IOData (..) + , KnownIODataMode (..) + , IODataMode (..) + , VerboseException (..) + + -- * copying files + , createDirectoryIfMissingVerbose + , copyFileVerbose + , copyFiles + , copyFileTo + + -- * installing files + , installOrdinaryFile + , installExecutableFile + , installMaybeExecutableFile + , installOrdinaryFiles + , installExecutableFiles + , installMaybeExecutableFiles + , installDirectoryContents + , copyDirectoryRecursive + + -- * File permissions + , doesExecutableExist + , setFileOrdinary + , setFileExecutable + + -- * file names + , currentDir + , shortRelativePath + , dropExeExtension + , exeExtensions + + -- * finding files + , findFileEx + , findFileCwd + , findFirstFile + , findFileWithExtension + , findFileCwdWithExtension + , findFileWithExtension' + , findAllFilesWithExtension + , findAllFilesCwdWithExtension + , findModuleFileEx + , findModuleFilesEx + , getDirectoryContentsRecursive + + -- * environment variables + , isInSearchPath + , addLibraryPath + + -- * modification time + , moreRecentFile + , existsAndIsMoreRecentThan + + -- * temp files and dirs + , TempFileOptions (..) + , defaultTempFileOptions + , withTempFile + , withTempFileEx + , withTempDirectory + , withTempDirectoryEx + , createTempDirectory + + -- * .cabal and .buildinfo files + , defaultPackageDesc + , findPackageDesc + , findPackageDescCwd + , tryFindPackageDesc + , tryFindPackageDescCwd + , findHookedPackageDesc + + -- * reading and writing files safely + , withFileContents + , writeFileAtomic + , rewriteFileEx + , rewriteFileLBS + + -- * Unicode + , fromUTF8BS + , fromUTF8LBS + , toUTF8BS + , toUTF8LBS + , readUTF8File + , withUTF8FileContents + , writeUTF8File + , normaliseLineEndings + + -- * BOM + , ignoreBOM + + -- * generic utils + , dropWhileEndLE + , takeWhileEndLE + , equating + , comparing + , isInfixOf + , intercalate + , lowercase + , listUnion + , listUnionRight + , ordNub + , ordNubBy + , ordNubRight + , safeHead + , safeTail + , safeLast + , safeInit + , unintersperse + , wrapText + , wrapLine + + -- * FilePath stuff + , isAbsoluteOnAnyPlatform + , isRelativeOnAnyPlatform + , exceptionWithCallStackPrefix + ) where + +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.ModuleName as ModuleName +import Distribution.Simple.Errors +import Distribution.Simple.PreProcess.Types +import Distribution.System +import Distribution.Types.PackageId +import Distribution.Utils.Generic +import Distribution.Utils.IOData (IOData (..), IODataMode (..), KnownIODataMode (..)) +import qualified Distribution.Utils.IOData as IOData +import Distribution.Verbosity +import Distribution.Version +import Prelude () + +#ifdef CURRENT_PACKAGE_KEY +#define BOOTSTRAPPED_CABAL 1 +#endif + +#ifdef BOOTSTRAPPED_CABAL +import qualified Paths_Cabal (version) +#endif + +import Distribution.Parsec +import Distribution.Pretty + +import qualified Data.ByteString.Lazy as BS +import Data.Typeable + ( cast + ) + +import qualified Control.Exception as Exception +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) +import Distribution.Compat.Process (proc) +import Foreign.C.Error (Errno (..), ePIPE) +import qualified GHC.IO.Exception as GHC +import GHC.Stack (HasCallStack) +import Numeric (showFFloat) +import System.Directory + ( Permissions (executable) + , createDirectory + , doesDirectoryExist + , doesFileExist + , getDirectoryContents + , getModificationTime + , getPermissions + , removeDirectoryRecursive + , removeFile + ) +import System.Environment + ( getProgName + ) +import System.FilePath as FilePath + ( getSearchPath + , joinPath + , normalise + , searchPathSeparator + , splitDirectories + , splitExtension + , takeDirectory + , (<.>) + , () + ) +import System.IO + ( BufferMode (..) + , Handle + , hClose + , hFlush + , hGetContents + , hPutStr + , hPutStrLn + , hSetBinaryMode + , hSetBuffering + , stderr + , stdout + ) +import System.IO.Error +import System.IO.Unsafe + ( unsafeInterleaveIO + ) +import qualified System.Process as Process +import qualified Text.PrettyPrint as Disp + +-- We only get our own version number when we're building with ourselves +cabalVersion :: Version +#if defined(BOOTSTRAPPED_CABAL) +cabalVersion = mkVersion' Paths_Cabal.version +#elif defined(CABAL_VERSION) +cabalVersion = mkVersion [CABAL_VERSION] +#else +cabalVersion = mkVersion [3,0] --used when bootstrapping +#endif + +-- ---------------------------------------------------------------------------- +-- Exception and logging utils + +-- Cabal's logging infrastructure has a few constraints: +-- +-- * We must make all logging formatting and emissions decisions based +-- on the 'Verbosity' parameter, which is the only parameter that is +-- plumbed to enough call-sites to actually be used for this matter. +-- (One of Cabal's "big mistakes" is to have never have defined a +-- monad of its own.) +-- +-- * When we 'die', we must raise an IOError. This a backwards +-- compatibility consideration, because that's what we've raised +-- previously, and if we change to any other exception type, +-- exception handlers which match on IOError will no longer work. +-- One case where it is known we rely on IOError being catchable +-- is 'readPkgConfigDb' in cabal-install; there may be other +-- user code that also assumes this. +-- +-- * The 'topHandler' does not know what 'Verbosity' is, because +-- it gets called before we've done command line parsing (where +-- the 'Verbosity' parameter would come from). +-- +-- This leads to two big architectural choices: +-- +-- * Although naively we might imagine 'Verbosity' to be a simple +-- enumeration type, actually it is a full-on abstract data type +-- that may contain arbitrarily complex information. At the +-- moment, it is fully representable as a string, but we might +-- eventually also use verbosity to let users register their +-- own logging handler. +-- +-- * When we call 'die', we perform all the formatting and addition +-- of extra information we need, and then ship this in the IOError +-- to the top-level handler. Here are alternate designs that +-- don't work: +-- +-- a) Ship the unformatted info to the handler. This doesn't +-- work because at the point the handler gets the message, +-- we've lost call stacks, and even if we did, we don't have access +-- to 'Verbosity' to decide whether or not to render it. +-- +-- b) Print the information at the 'die' site, then raise an +-- error. This means that if the exception is subsequently +-- caught by a handler, we will still have emitted the output, +-- which is not the correct behavior. +-- +-- For the top-level handler to "know" that an error message +-- contains one of these fully formatted packets, we set a sentinel +-- in one of IOError's extra fields. This is handled by +-- 'ioeSetVerbatim' and 'ioeGetVerbatim'. +-- + +dieNoVerbosity :: String -> IO a +dieNoVerbosity msg = + ioError (userError msg) + where + _ = callStack -- TODO: Attach CallStack to exception + +-- | Tag an 'IOError' whose error string should be output to the screen +-- verbatim. +ioeSetVerbatim :: IOError -> IOError +ioeSetVerbatim e = ioeSetLocation e "dieVerbatim" + +-- | Check if an 'IOError' should be output verbatim to screen. +ioeGetVerbatim :: IOError -> Bool +ioeGetVerbatim e = ioeGetLocation e == "dieVerbatim" + +-- | Create a 'userError' whose error text will be output verbatim +verbatimUserError :: String -> IOError +verbatimUserError = ioeSetVerbatim . userError + +dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a +dieWithLocation' verbosity filename mb_lineno msg = + die' verbosity $ + filename + ++ ( case mb_lineno of + Just lineno -> ":" ++ show lineno + Nothing -> "" + ) + ++ ": " + ++ msg + +die' :: Verbosity -> String -> IO a +die' verbosity msg = withFrozenCallStack $ do + ioError . verbatimUserError + =<< annotateErrorString verbosity + =<< pure . wrapTextVerbosity 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 + deriving (Show, Typeable) + +-- Function which will replace the existing die' call sites +dieWithException :: (HasCallStack, Show a1, Typeable a1, Exception (VerboseException a1)) => Verbosity -> a1 -> IO a +dieWithException verbosity exception = do + ts <- getPOSIXTime + throwIO $ VerboseException callStack ts verbosity exception + +-- Instance for Cabal Exception which will display error code and error message with callStack info +instance Exception (VerboseException CabalException) where + displayException :: VerboseException CabalException -> [Char] + displayException (VerboseException stack timestamp verb cabalexception) = + withOutputMarker + verb + ( concat + [ "Error: [Cabal-" + , show (exceptionCode cabalexception) + , "]\n" + ] + ) + ++ exceptionWithMetadata stack timestamp verb (exceptionMessage cabalexception) + +dieNoWrap :: Verbosity -> String -> IO a +dieNoWrap verbosity msg = withFrozenCallStack $ do + -- TODO: should this have program name or not? + ioError . verbatimUserError + =<< annotateErrorString + verbosity + (addErrorPrefix msg) + +-- | Prefixing a message to indicate that it is a fatal error, +-- if the 'errorPrefix' is not already present. +addErrorPrefix :: String -> String +addErrorPrefix msg + | errorPrefix `isPrefixOf` msg = msg + -- Backpack prefixes its errors already with "Error:", see + -- 'Distribution.Utils.LogProgress.dieProgress'. + -- Taking it away there destroys the layout, so we rather + -- check here whether the prefix is already present. + | otherwise = unwords [errorPrefix, msg] + +-- | A prefix indicating that a message is a fatal error. +errorPrefix :: String +errorPrefix = "Error:" + +-- | Prefix an error string with program name from 'getProgName' +prefixWithProgName :: String -> IO String +prefixWithProgName msg = do + pname <- getProgName + return $ pname ++ ": " ++ msg + +-- | Annotate an error string with timestamp and 'withMetadata'. +annotateErrorString :: Verbosity -> String -> IO String +annotateErrorString verbosity msg = do + ts <- getPOSIXTime + return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg + +-- | Given a block of IO code that may raise an exception, annotate +-- it with the metadata from the current scope. Use this as close +-- to external code that raises IO exceptions as possible, since +-- this function unconditionally wraps the error message with a trace +-- (so it is NOT idempotent.) +annotateIO :: Verbosity -> IO a -> IO a +annotateIO verbosity act = do + ts <- getPOSIXTime + flip modifyIOError act $ + ioeModifyErrorString $ + withMetadata ts NeverMark VerboseTrace verbosity + +-- | A semantic editor for the error message inside an 'IOError'. +ioeModifyErrorString :: (String -> String) -> IOError -> IOError +ioeModifyErrorString = over ioeErrorString + +-- | A lens for the error message inside an 'IOError'. +ioeErrorString :: Lens' IOError String +ioeErrorString f ioe = ioeSetErrorString ioe <$> f (ioeGetErrorString ioe) + +{-# NOINLINE topHandlerWith #-} +topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a +topHandlerWith cont prog = do + -- By default, stderr to a terminal device is NoBuffering. But this + -- is *really slow* + hSetBuffering stderr LineBuffering + Exception.catches + prog + [ Exception.Handler rethrowAsyncExceptions + , Exception.Handler rethrowExitStatus + , Exception.Handler handle + ] + where + -- Let async exceptions rise to the top for the default top-handler + rethrowAsyncExceptions :: Exception.AsyncException -> IO a + rethrowAsyncExceptions a = throwIO a + + -- ExitCode gets thrown asynchronously too, and we don't want to print it + rethrowExitStatus :: ExitCode -> IO a + rethrowExitStatus = throwIO + + -- Print all other exceptions + handle :: Exception.SomeException -> IO a + handle se = do + hFlush stdout + pname <- getProgName + hPutStr stderr (message pname se) + cont se + + message :: String -> Exception.SomeException -> String + message pname (Exception.SomeException se) = + case cast se :: Maybe Exception.IOException of + Just ioe + | ioeGetVerbatim ioe -> + -- Use the message verbatim + ioeGetErrorString ioe ++ "\n" + | isUserError ioe -> + let file = case ioeGetFileName ioe of + Nothing -> "" + Just path -> path ++ location ++ ": " + location = case ioeGetLocation ioe of + l@(n : _) | isDigit n -> ':' : l + _ -> "" + detail = ioeGetErrorString ioe + in wrapText $ addErrorPrefix $ pname ++ ": " ++ file ++ detail + _ -> + displaySomeException se ++ "\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 + +-- | Depending on 'isVerboseStderr', set the output handle to 'stderr' or 'stdout'. +verbosityHandle :: Verbosity -> Handle +verbosityHandle verbosity + | isVerboseStderr verbosity = stderr + | otherwise = stdout + +-- | Non fatal conditions that may be indicative of an error or problem. +-- +-- We display these at the 'normal' verbosity level. +warn :: Verbosity -> String -> IO () +warn verbosity msg = warnMessage "Warning" verbosity msg + +-- | Like 'warn', but prepend @Error: …@ instead of @Waring: …@ 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 () +warnError verbosity message = warnMessage "Error" verbosity message + +-- | Warning message, with a custom label. +warnMessage :: String -> Verbosity -> String -> IO () +warnMessage l verbosity msg = withFrozenCallStack $ do + when ((verbosity >= normal) && not (isVerboseNoWarn verbosity)) $ do + ts <- getPOSIXTime + hFlush stdout + hPutStr stderr + . withMetadata ts NormalMark FlagTrace verbosity + . wrapTextVerbosity verbosity + $ l ++ ": " ++ msg + +-- | Useful status messages. +-- +-- We display these at the 'normal' verbosity level. +-- +-- This is for the ordinary helpful status messages that users see. Just +-- 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 + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NormalMark FlagTrace verbosity $ + wrapTextVerbosity verbosity $ + msg + +-- | Display a message at 'normal' verbosity level, but without +-- wrapping. +noticeNoWrap :: Verbosity -> String -> IO () +noticeNoWrap verbosity msg = withFrozenCallStack $ do + when (verbosity >= normal) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ msg + +-- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity +-- level. Use this if you need fancy formatting. +noticeDoc :: Verbosity -> Disp.Doc -> IO () +noticeDoc verbosity msg = withFrozenCallStack $ do + when (verbosity >= normal) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NormalMark FlagTrace verbosity $ + Disp.renderStyle defaultStyle $ + msg + +-- | Display a "setup status message". Prefer using setupMessage' +-- if possible. +setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () +setupMessage verbosity msg pkgid = withFrozenCallStack $ do + noticeNoWrap verbosity (msg ++ ' ' : prettyShow pkgid ++ "...") + +-- | More detail on the operation of some action. +-- +-- 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 + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + wrapTextVerbosity verbosity $ + msg + +infoNoWrap :: Verbosity -> String -> IO () +infoNoWrap verbosity msg = withFrozenCallStack $ + when (verbosity >= verbose) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + 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 + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + wrapTextVerbosity verbosity $ + msg + -- ensure that we don't lose output if we segfault/infinite loop + hFlush stdout + +-- | A variant of 'debug' that doesn't perform the automatic line +-- wrapping. Produces better output in some cases. +debugNoWrap :: Verbosity -> String -> IO () +debugNoWrap verbosity msg = withFrozenCallStack $ + when (verbosity >= deafening) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + msg + -- ensure that we don't lose output if we segfault/infinite loop + hFlush stdout + +-- | Perform an IO action, catching any IO exceptions and printing an error +-- if one occurs. +chattyTry + :: String + -- ^ a description of the action we were attempting + -> IO () + -- ^ the action itself + -> IO () +chattyTry desc action = + catchIO action $ \exception -> + hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception + +-- | Run an IO computation, returning @e@ if it raises a "file +-- does not exist" error. +handleDoesNotExist :: a -> IO a -> IO a +handleDoesNotExist e = + Exception.handleJust + (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing) + (\_ -> return e) + +-- ----------------------------------------------------------------------------- +-- Helper functions + +-- | Wraps text unless the @+nowrap@ verbosity flag is active +wrapTextVerbosity :: Verbosity -> String -> String +wrapTextVerbosity verb + | isVerboseNoWrap verb = withTrailingNewline + | otherwise = withTrailingNewline . wrapText + +-- | Prepends a timestamp if @+timestamp@ verbosity flag is set +-- +-- This is used by 'withMetadata' +withTimestamp :: Verbosity -> POSIXTime -> String -> String +withTimestamp v ts msg + | isVerboseTimestamp v = msg' + | otherwise = msg -- no-op + where + msg' = case lines msg of + [] -> tsstr "\n" + l1 : rest -> unlines (tsstr (' ' : l1) : map (contpfx ++) rest) + + -- format timestamp to be prepended to first line with msec precision + tsstr = showFFloat (Just 3) (realToFrac ts :: Double) + + -- continuation prefix for subsequent lines of msg + contpfx = replicate (length (tsstr " ")) ' ' + +-- | Wrap output with a marker if @+markoutput@ verbosity flag is set. +-- +-- NB: Why is markoutput done with start/end markers, and not prefixes? +-- Markers are more convenient to add (if we want to add prefixes, +-- we have to 'lines' and then 'map'; here's it's just some +-- concatenates). Note that even in the prefix case, we can't +-- guarantee that the markers are unambiguous, because some of +-- Cabal's output comes straight from external programs, where +-- we don't have the ability to interpose on the output. +-- +-- This is used by 'withMetadata' +withOutputMarker :: Verbosity -> String -> String +withOutputMarker v xs | not (isVerboseMarkOutput v) = xs +withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly +withOutputMarker _ xs = + "-----BEGIN CABAL OUTPUT-----\n" + ++ withTrailingNewline xs + ++ "-----END CABAL OUTPUT-----\n" + +-- | Append a trailing newline to a string if it does not +-- already have a trailing newline. +withTrailingNewline :: String -> String +withTrailingNewline "" = "" +withTrailingNewline (x : xs) = x : go x xs + where + go _ (c : cs) = c : go c cs + go '\n' "" = "" + go _ "" = "\n" + +-- | Prepend a call-site and/or call-stack based on Verbosity +withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String) +withCallStackPrefix tracer verbosity s = + withFrozenCallStack $ + ( if isVerboseCallSite verbosity + then + parentSrcLocPrefix + ++ + -- Hack: need a newline before starting output marker :( + if isVerboseMarkOutput verbosity + then "\n" + else "" + else "" + ) + ++ ( case traceWhen verbosity tracer of + Just pre -> pre ++ prettyCallStack callStack ++ "\n" + Nothing -> "" + ) + ++ s + +-- | When should we emit the call stack? We always emit +-- for internal errors, emit the trace for errors when we +-- are in verbose mode, and otherwise only emit it if +-- explicitly asked for using the @+callstack@ verbosity +-- flag. (At the moment, 'AlwaysTrace' is not used. +data TraceWhen + = AlwaysTrace + | VerboseTrace + | FlagTrace + deriving (Eq) + +-- | Determine if we should emit a call stack. +-- If we trace, it also emits any prefix we should append. +traceWhen :: Verbosity -> TraceWhen -> Maybe String +traceWhen _ AlwaysTrace = Just "" +traceWhen v VerboseTrace | v >= verbose = Just "" +traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n" +traceWhen _ _ = Nothing + +-- | When should we output the marker? Things like 'die' +-- always get marked, but a 'NormalMark' will only be +-- output if we're not a quiet verbosity. +data MarkWhen = AlwaysMark | NormalMark | NeverMark + +-- | Add all necessary metadata to a logging message +withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String) +withMetadata ts marker tracer verbosity x = + withFrozenCallStack + $ + -- NB: order matters. Output marker first because we + -- don't want to capture call stacks. + withTrailingNewline + . withCallStackPrefix tracer verbosity + . ( case marker of + AlwaysMark -> withOutputMarker verbosity + NormalMark + | not (isVerboseQuiet verbosity) -> + withOutputMarker verbosity + | otherwise -> + id + NeverMark -> id + ) + -- Clear out any existing markers + . clearMarkers + . withTimestamp verbosity ts + $ x + +-- | Add all necessary metadata to a logging message +exceptionWithMetadata :: CallStack -> POSIXTime -> Verbosity -> String -> String +exceptionWithMetadata stack ts verbosity x = + withTrailingNewline + . exceptionWithCallStackPrefix stack verbosity + . withOutputMarker verbosity + . clearMarkers + . withTimestamp verbosity ts + $ x + +clearMarkers :: String -> String +clearMarkers s = unlines . filter isMarker $ lines s + where + isMarker "-----BEGIN CABAL OUTPUT-----" = False + isMarker "-----END CABAL OUTPUT-----" = False + isMarker _ = True + +-- | Append a call-site and/or call-stack based on Verbosity +exceptionWithCallStackPrefix :: CallStack -> Verbosity -> String -> String +exceptionWithCallStackPrefix stack verbosity s = + s + ++ withFrozenCallStack + ( ( if isVerboseCallSite verbosity + then + parentSrcLocPrefix + ++ + -- Hack: need a newline before starting output marker :( + if isVerboseMarkOutput verbosity + then "\n" + else "" + else "" + ) + ++ ( if verbosity >= verbose + then prettyCallStack stack ++ "\n" + else "" + ) + ) + +-- ----------------------------------------------------------------------------- +-- rawSystem variants +-- +-- These all use 'Distribution.Compat.Process.proc' to ensure we +-- consistently use process jobs on Windows and Ctrl-C delegation +-- on Unix. +-- +-- Additionally, they take care of logging command execution. +-- + +-- | Helper to use with one of the 'rawSystem' variants, and exit +-- unless the command completes successfully. +maybeExit :: IO ExitCode -> IO () +maybeExit cmd = do + exitcode <- cmd + unless (exitcode == ExitSuccess) $ exitWith exitcode + +-- | Log a command execution (that's typically about to happen) +-- at info level, and log working directory and environment overrides +-- at debug level if specified. +logCommand :: Verbosity -> Process.CreateProcess -> IO () +logCommand verbosity cp = do + infoNoWrap verbosity $ + "Running: " <> case Process.cmdspec cp of + Process.ShellCommand sh -> sh + Process.RawCommand path args -> Process.showCommandForUser path args + case Process.env cp of + Just env -> debugNoWrap verbosity $ "with environment: " ++ show env + Nothing -> return () + case Process.cwd cp of + Just cwd -> debugNoWrap verbosity $ "with working directory: " ++ show cwd + Nothing -> return () + hFlush stdout + +-- | Execute the given command with the given arguments, exiting +-- with the same exit code if the command fails. +rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () +rawSystemExit verbosity path args = + withFrozenCallStack $ + maybeExit $ + rawSystemExitCode verbosity path args + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. +rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode +rawSystemExitCode verbosity path args = + withFrozenCallStack $ + rawSystemProc verbosity $ + proc path args + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. +-- +-- Create the process argument with 'Distribution.Compat.Process.proc' +-- to ensure consistent options with other 'rawSystem' functions in this +-- module. +rawSystemProc :: Verbosity -> Process.CreateProcess -> IO ExitCode +rawSystemProc verbosity cp = withFrozenCallStack $ do + (exitcode, _) <- rawSystemProcAction verbosity cp $ \_ _ _ -> return () + return exitcode + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. 'action' is executed while the command +-- is running, and would typically be used to communicate with the +-- process through pipes. +-- +-- Create the process argument with 'Distribution.Compat.Process.proc' +-- to ensure consistent options with other 'rawSystem' functions in this +-- module. +rawSystemProcAction + :: Verbosity + -> Process.CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a) + -> IO (ExitCode, a) +rawSystemProcAction verbosity cp action = withFrozenCallStack $ do + logCommand verbosity cp + (exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do + a <- action mStdin mStdout mStderr + exitcode <- Process.waitForProcess p + return (exitcode, a) + unless (exitcode == ExitSuccess) $ do + let cmd = case Process.cmdspec cp of + Process.ShellCommand sh -> sh + Process.RawCommand path _args -> path + debug verbosity $ cmd ++ " returned " ++ show exitcode + return (exitcode, a) + +-- | 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 + +-- | Execute the given command with the given arguments and +-- environment, exiting with the same exit code if the command fails. +rawSystemExitWithEnv + :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +rawSystemExitWithEnv verbosity path args env = + withFrozenCallStack $ + maybeExit $ + rawSystemProc verbosity $ + (proc path args) + { Process.env = Just env + } + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. +-- +-- Optional arguments allow setting working directory, environment +-- and input and output handles. +rawSystemIOWithEnv + :: Verbosity + -> FilePath + -> [String] + -> Maybe FilePath + -- ^ New working dir or inherit + -> Maybe [(String, String)] + -- ^ New environment or inherit + -> Maybe Handle + -- ^ stdin + -> Maybe Handle + -- ^ stdout + -> Maybe Handle + -- ^ stderr + -> IO ExitCode +rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do + (exitcode, _) <- + rawSystemIOWithEnvAndAction + verbosity + path + args + mcwd + menv + action + inp + out + err + return exitcode + where + action = return () + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. 'action' is executed while the command +-- is running, and would typically be used to communicate with the +-- process through pipes. +-- +-- Optional arguments allow setting working directory, environment +-- and input and output handles. +rawSystemIOWithEnvAndAction + :: Verbosity + -> FilePath + -> [String] + -> Maybe FilePath + -- ^ New working dir or inherit + -> Maybe [(String, String)] + -- ^ New environment or inherit + -> IO a + -- ^ action to perform after process is created, but before 'waitForProcess'. + -> Maybe Handle + -- ^ stdin + -> Maybe Handle + -- ^ stdout + -> 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 + +-- | Execute the given command with the given arguments, returning +-- the command's output. Exits if the command exits with error. +-- +-- Provides control over the binary/text mode of the output. +rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode +rawSystemStdout verbosity path args = withFrozenCallStack $ do + (output, errors, exitCode) <- + rawSystemStdInOut + verbosity + path + args + Nothing + Nothing + Nothing + (IOData.iodataMode :: IODataMode mode) + when (exitCode /= ExitSuccess) $ + dieWithException verbosity $ + RawSystemStdout errors + return output + +-- | Execute the given command with the given arguments, returning +-- the command's output, errors and exit code. +-- +-- Optional arguments allow setting working directory, environment +-- and command input. +-- +-- Provides control over the binary/text mode of the input and output. +rawSystemStdInOut + :: KnownIODataMode mode + => Verbosity + -> FilePath + -- ^ Program location + -> [String] + -- ^ Arguments + -> Maybe FilePath + -- ^ New working dir or inherit + -> Maybe [(String, String)] + -- ^ New environment or inherit + -> Maybe IOData + -- ^ input text and binary mode + -> IODataMode mode + -- ^ iodata mode, acts as proxy + -> IO (mode, String, ExitCode) + -- ^ output, errors, exit +rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do + let cp = + (proc path args) + { Process.cwd = mcwd + , Process.env = menv + , Process.std_in = Process.CreatePipe + , Process.std_out = Process.CreatePipe + , Process.std_err = Process.CreatePipe + } + + (exitcode, (mberr1, mberr2)) <- rawSystemProcAction verbosity cp $ \mb_in mb_out mb_err -> do + let (inh, outh, errh) = (fromCreatePipe mb_in, fromCreatePipe mb_out, fromCreatePipe mb_err) + flip Exception.finally (hClose inh >> hClose outh >> hClose errh) $ do + -- output mode depends on what the caller wants + -- but the errors are always assumed to be text (in the current locale) + hSetBinaryMode errh False + + -- fork off a couple threads to pull on the stderr and stdout + -- so if the process writes to stderr we do not block. + + withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do + -- push all the input, if any + ignoreSigPipe $ case input of + Nothing -> hClose inh + Just inputData -> IOData.hPutContents inh inputData + + -- wait for both to finish + mberr1 <- waitCatch outA + mberr2 <- waitCatch errA + return (mberr1, mberr2) + + -- get the stderr, so it can be added to error message + err <- reportOutputIOError mberr2 + + unless (exitcode == ExitSuccess) $ + debug verbosity $ + path + ++ " returned " + ++ show exitcode + ++ if null err + then "" + else + " with error message:\n" + ++ err + ++ case input of + Nothing -> "" + Just d | IOData.null d -> "" + Just (IODataText inp) -> "\nstdin input:\n" ++ inp + Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp + + -- Check if we hit an exception while consuming the output + -- (e.g. a text decoding error) + out <- reportOutputIOError mberr1 + + return (out, err, exitcode) + where + reportOutputIOError :: Either Exception.SomeException a -> IO a + reportOutputIOError (Right x) = return x + reportOutputIOError (Left exc) = case fromException exc of + Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path)) + Nothing -> throwIO exc + +-- | Ignore SIGPIPE in a subcomputation. +ignoreSigPipe :: IO () -> IO () +ignoreSigPipe = Exception.handle $ \case + GHC.IOError{GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe} + | Errno ioe == ePIPE -> return () + e -> throwIO e + +-- | Look for a program and try to find it's version number. It can accept +-- either an absolute path or the name of a program binary, in which case we +-- will look for the program on the path. +findProgramVersion + :: String + -- ^ version args + -> (String -> String) + -- ^ function to select version + -- number from program output + -> Verbosity + -> FilePath + -- ^ location + -> IO (Maybe Version) +findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do + str <- + rawSystemStdout verbosity path [versionArg] + `catchIO` (\_ -> return "") + `catch` (\(_ :: VerboseException CabalException) -> return "") + `catchExit` (\_ -> return "") + let version :: Maybe Version + version = simpleParsec (selectVersion str) + case version of + Nothing -> + warn verbosity $ + "cannot determine version of " + ++ path + ++ " :\n" + ++ show str + Just v -> debug verbosity $ path ++ " is version " ++ prettyShow v + return version + +-- | 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 +-- need to invoke a command multiple times to get all the args in. +-- +-- Use it with either of the rawSystem variants above. For example: +-- +-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs +xargs + :: Int + -> ([String] -> IO ()) + -> [String] + -> [String] + -> IO () +xargs maxSize rawSystemFun fixedArgs bigArgs = + let fixedArgSize = sum (map length fixedArgs) + length fixedArgs + chunkSize = maxSize - fixedArgSize + in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) + where + chunks len = unfoldr $ \s -> + if null s + then Nothing + else Just (chunk [] len s) + + chunk acc _ [] = (reverse acc, []) + chunk acc len (s : ss) + | len' < len = chunk (s : acc) (len - len' - 1) ss + | otherwise = (reverse acc, s : ss) + where + len' = length s + +-- ------------------------------------------------------------ + +-- * File Utilities + +-- ------------------------------------------------------------ + +---------------- +-- Finding files + +-- | Find a file by looking in a search path. The file path must match exactly. +-- +-- @since 3.4.0.0 +findFileCwd + :: Verbosity + -> FilePath + -- ^ cwd + -> [FilePath] + -- ^ relative search location + -> FilePath + -- ^ File Name + -> IO FilePath +findFileCwd verbosity cwd searchPath fileName = + findFirstFile + (cwd ) + [ path fileName + | path <- ordNub searchPath + ] + >>= maybe (dieWithException verbosity $ FindFileCwd fileName) return + +-- | Find a file by looking in a search path. The file path must match exactly. +findFileEx + :: Verbosity + -> [FilePath] + -- ^ search locations + -> FilePath + -- ^ File Name + -> IO FilePath +findFileEx verbosity searchPath fileName = + findFirstFile + id + [ path fileName + | path <- ordNub searchPath + ] + >>= maybe (dieWithException verbosity $ FindFileEx fileName) return + +-- | Find a file by looking in a search path with one of a list of possible +-- file extensions. The file base name should be given and it will be tried +-- with each of the extensions in each element of the search path. +findFileWithExtension + :: [Suffix] + -> [FilePath] + -> FilePath + -> IO (Maybe FilePath) +findFileWithExtension extensions searchPath baseName = + findFirstFile + id + [ path baseName <.> ext + | path <- ordNub searchPath + , Suffix ext <- ordNub extensions + ] + +-- | @since 3.4.0.0 +findFileCwdWithExtension + :: FilePath + -> [Suffix] + -> [FilePath] + -> FilePath + -> IO (Maybe FilePath) +findFileCwdWithExtension cwd extensions searchPath baseName = + findFirstFile + (cwd ) + [ path baseName <.> ext + | path <- ordNub searchPath + , Suffix ext <- ordNub extensions + ] + +-- | @since 3.4.0.0 +findAllFilesCwdWithExtension + :: FilePath + -- ^ cwd + -> [Suffix] + -- ^ extensions + -> [FilePath] + -- ^ relative search locations + -> FilePath + -- ^ basename + -> IO [FilePath] +findAllFilesCwdWithExtension cwd extensions searchPath basename = + findAllFiles + (cwd ) + [ path basename <.> ext + | path <- ordNub searchPath + , Suffix ext <- ordNub extensions + ] + +findAllFilesWithExtension + :: [Suffix] + -> [FilePath] + -> FilePath + -> IO [FilePath] +findAllFilesWithExtension extensions searchPath basename = + findAllFiles + id + [ path basename <.> ext + | path <- ordNub searchPath + , Suffix ext <- ordNub extensions + ] + +-- | Like 'findFileWithExtension' but returns which element of the search path +-- the file was found in, and the file path relative to that base directory. +findFileWithExtension' + :: [Suffix] + -> [FilePath] + -> FilePath + -> IO (Maybe (FilePath, FilePath)) +findFileWithExtension' extensions searchPath baseName = + findFirstFile + (uncurry ()) + [ (path, baseName <.> ext) + | path <- ordNub searchPath + , Suffix ext <- ordNub extensions + ] + +findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) +findFirstFile file = findFirst + where + findFirst [] = return Nothing + findFirst (x : xs) = do + exists <- doesFileExist (file x) + if exists + then return (Just x) + else findFirst xs + +findAllFiles :: (a -> FilePath) -> [a] -> IO [a] +findAllFiles file = filterM (doesFileExist . file) + +-- | Finds the files corresponding to a list of Haskell module names. +-- +-- As 'findModuleFile' but for a list of module names. +findModuleFilesEx + :: Verbosity + -> [FilePath] + -- ^ build prefix (location of objects) + -> [Suffix] + -- ^ search suffixes + -> [ModuleName] + -- ^ modules + -> IO [(FilePath, FilePath)] +findModuleFilesEx verbosity searchPath extensions moduleNames = + traverse (findModuleFileEx verbosity searchPath extensions) moduleNames + +-- | Find the file corresponding to a Haskell module name. +-- +-- This is similar to 'findFileWithExtension'' but specialised to a module +-- name. The function fails if the file corresponding to the module is missing. +findModuleFileEx + :: Verbosity + -> [FilePath] + -- ^ build prefix (location of objects) + -> [Suffix] + -- ^ search suffixes + -> ModuleName + -- ^ module + -> IO (FilePath, FilePath) +findModuleFileEx verbosity searchPath extensions mod_name = + maybe notFound return + =<< findFileWithExtension' + extensions + searchPath + (ModuleName.toFilePath mod_name) + where + notFound = + dieWithException verbosity $ FindModuleFileEx mod_name extensions searchPath + +-- | List all the files in a directory and all subdirectories. +-- +-- The order places files in sub-directories after all the files in their +-- parent directories. The list is generated lazily so is not well defined if +-- the source directory structure changes before the list is used. +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive topdir = recurseDirectories [""] + where + recurseDirectories :: [FilePath] -> IO [FilePath] + recurseDirectories [] = return [] + recurseDirectories (dir : dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) + files' <- recurseDirectories (dirs' ++ dirs) + return (files ++ files') + where + collect files dirs' [] = + return + ( 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) + if isDirectory + then collect files (dirEntry : dirs') entries + else collect (dirEntry : files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + +------------------------ +-- Environment variables + +-- | Is this directory in the system search path? +isInSearchPath :: FilePath -> IO Bool +isInSearchPath path = fmap (elem path) getSearchPath + +addLibraryPath + :: OS + -> [FilePath] + -> [(String, String)] + -> [(String, String)] +addLibraryPath os paths = addEnv + where + pathsString = intercalate [searchPathSeparator] paths + ldPath = case os of + OSX -> "DYLD_LIBRARY_PATH" + _ -> "LD_LIBRARY_PATH" + + addEnv [] = [(ldPath, pathsString)] + addEnv ((key, value) : xs) + | key == ldPath = + if null value + then (key, pathsString) : xs + else (key, value ++ (searchPathSeparator : pathsString)) : xs + | otherwise = (key, value) : addEnv xs + +-------------------- +-- Modification time + +-- | Compare the modification times of two files to see if the first is newer +-- than the second. The first file must exist but the second need not. +-- The expected use case is when the second file is generated using the first. +-- In this use case, if the result is True then the second file is out of date. +moreRecentFile :: FilePath -> FilePath -> IO Bool +moreRecentFile a b = do + exists <- doesFileExist b + if not exists + then return True + else do + tb <- getModificationTime b + ta <- getModificationTime a + return (ta > tb) + +-- | Like 'moreRecentFile', but also checks that the first file exists. +existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool +existsAndIsMoreRecentThan a b = do + exists <- doesFileExist a + if not exists + then return False + else a `moreRecentFile` b + +---------------------------------------- +-- Copying and installing files and dirs + +-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. +createDirectoryIfMissingVerbose + :: Verbosity + -> Bool + -- ^ Create its parents too? + -> FilePath + -> IO () +createDirectoryIfMissingVerbose verbosity create_parents path0 + | create_parents = withFrozenCallStack $ createDirs (parents path0) + | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0)) + where + parents = reverse . scanl1 () . splitDirectories . normalise + + createDirs [] = return () + createDirs (dir : []) = createDir dir throwIO + createDirs (dir : dirs) = + createDir dir $ \_ -> do + createDirs dirs + createDir dir throwIO + + createDir :: FilePath -> (IOException -> IO ()) -> IO () + createDir dir notExistHandler = do + r <- tryIO $ createDirectoryVerbose verbosity dir + case (r :: Either IOException ()) of + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e + -- createDirectory (and indeed POSIX mkdir) does not distinguish + -- between a dir already existing and a file already existing. So we + -- check for it here. Unfortunately there is a slight race condition + -- here, but we think it is benign. It could report an exception in + -- the case that the dir did exist but another process deletes the + -- directory and creates a file in its place before we can check + -- that the directory did indeed exist. + | isAlreadyExistsError e -> + ( do + isDir <- doesDirectoryExist dir + unless isDir $ throwIO e + ) + `catchIO` ((\_ -> return ()) :: IOException -> IO ()) + | otherwise -> throwIO e + +createDirectoryVerbose :: Verbosity -> FilePath -> IO () +createDirectoryVerbose verbosity dir = withFrozenCallStack $ do + info verbosity $ "creating " ++ dir + createDirectory dir + setDirOrdinary dir + +-- | Copies a file without copying file permissions. The target file is created +-- with default permissions. Any existing target file is replaced. +-- +-- At higher verbosity levels it logs an info message. +copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyFileVerbose verbosity src dest = withFrozenCallStack $ do + info verbosity ("copy " ++ src ++ " to " ++ dest) + copyFile src dest + +-- | Install an ordinary file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" +-- while on Windows it uses the default permissions for the target directory. +installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () +installOrdinaryFile verbosity src dest = withFrozenCallStack $ do + info verbosity ("Installing " ++ src ++ " to " ++ dest) + copyOrdinaryFile src dest + +-- | Install an executable file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" +-- while on Windows it uses the default permissions for the target directory. +installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () +installExecutableFile verbosity src dest = withFrozenCallStack $ do + info verbosity ("Installing executable " ++ src ++ " to " ++ dest) + copyExecutableFile src dest + +-- | Install a file that may or not be executable, preserving permissions. +installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () +installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do + perms <- getPermissions src + if (executable perms) -- only checks user x bit + then installExecutableFile verbosity src dest + else installOrdinaryFile verbosity src dest + +-- | Given a relative path to a file, copy it to the given directory, preserving +-- the relative path and creating the parent directories if needed. +copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () +copyFileTo verbosity dir file = withFrozenCallStack $ do + let targetFile = dir file + createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) + installOrdinaryFile verbosity file targetFile + +-- | Common implementation of 'copyFiles', 'installOrdinaryFiles', +-- 'installExecutableFiles' and 'installMaybeExecutableFiles'. +copyFilesWith + :: (Verbosity -> FilePath -> FilePath -> IO ()) + -> Verbosity + -> FilePath + -> [(FilePath, FilePath)] + -> IO () +copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do + -- Create parent directories for everything + let dirs = map (targetDir ) . ordNub . map (takeDirectory . snd) $ srcFiles + traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs + + -- Copy all the files + sequence_ + [ let src = srcBase srcFile + dest = targetDir srcFile + in doCopy verbosity src dest + | (srcBase, srcFile) <- srcFiles + ] + +-- | Copies a bunch of files to a target directory, preserving the directory +-- structure in the target location. The target directories are created if they +-- do not exist. +-- +-- The files are identified by a pair of base directory and a path relative to +-- that base. It is only the relative part that is preserved in the +-- destination. +-- +-- For example: +-- +-- > copyFiles normal "dist/src" +-- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] +-- +-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and +-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". +-- +-- This operation is not atomic. Any IO failure during the copy (including any +-- missing source files) leaves the target in an unknown state so it is best to +-- use it with a freshly created directory so that it can be simply deleted if +-- anything goes wrong. +copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs) + +-- | This is like 'copyFiles' but uses 'installOrdinaryFile'. +installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs) + +-- | This is like 'copyFiles' but uses 'installExecutableFile'. +installExecutableFiles + :: Verbosity + -> FilePath + -> [(FilePath, FilePath)] + -> IO () +installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs) + +-- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'. +installMaybeExecutableFiles + :: Verbosity + -> FilePath + -> [(FilePath, FilePath)] + -> IO () +installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs) + +-- | This installs all the files in a directory to a target location, +-- preserving the directory layout. All the files are assumed to be ordinary +-- rather than executable files. +installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () +installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + installOrdinaryFiles verbosity destDir [(srcDir, f) | f <- srcFiles] + +-- | Recursively copy the contents of one directory to another path. +copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO () +copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + copyFilesWith + (const copyFile) + verbosity + destDir + [ (srcDir, f) + | f <- srcFiles + ] + +------------------- +-- File permissions + +-- | Like 'doesFileExist', but also checks that the file is executable. +doesExecutableExist :: FilePath -> IO Bool +doesExecutableExist f = do + exists <- doesFileExist f + if exists + then do + perms <- getPermissions f + return (executable perms) + else return False + +--------------------------- +-- Temporary files and dirs + +-- | Advanced options for 'withTempFile' and 'withTempDirectory'. +data TempFileOptions = TempFileOptions + { optKeepTempFiles :: Bool + -- ^ Keep temporary files? + } + +defaultTempFileOptions :: TempFileOptions +defaultTempFileOptions = TempFileOptions{optKeepTempFiles = False} + +-- | Use a temporary filename that doesn't already exist. +withTempFile + :: FilePath + -- ^ Temp dir to create the file in + -> String + -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) + -> IO a +withTempFile tmpDir template action = + withTempFileEx defaultTempFileOptions tmpDir template action + +-- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' +-- argument. +withTempFileEx + :: TempFileOptions + -> FilePath + -- ^ Temp dir to create the file in + -> String + -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) + -> IO a +withTempFileEx opts tmpDir template action = + Exception.bracket + (openTempFile tmpDir template) + ( \(name, handle) -> do + hClose handle + unless (optKeepTempFiles opts) $ + handleDoesNotExist () . removeFile $ + name + ) + (withLexicalCallStack (\x -> uncurry action x)) + +-- | Create and use a temporary directory. +-- +-- 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 ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a +withTempDirectory verbosity targetDir template f = + withFrozenCallStack $ + withTempDirectoryEx + verbosity + defaultTempFileOptions + targetDir + template + (withLexicalCallStack (\x -> f x)) + +-- | A version of 'withTempDirectory' that additionally takes a +-- 'TempFileOptions' argument. +withTempDirectoryEx + :: Verbosity + -> TempFileOptions + -> FilePath + -> String + -> (FilePath -> IO a) + -> IO a +withTempDirectoryEx _verbosity opts targetDir template f = + withFrozenCallStack $ + Exception.bracket + (createTempDirectory targetDir template) + ( unless (optKeepTempFiles opts) + . handleDoesNotExist () + . removeDirectoryRecursive + ) + (withLexicalCallStack (\x -> f x)) + +----------------------------------- +-- Safely reading and writing files + +-- | Write a file but only if it would have new content. If we would be writing +-- the same as the existing content then leave the file as is so that we do not +-- update the file's modification time. +-- +-- NB: Before Cabal-3.0 the file content was assumed to be +-- ASCII-representable. Since Cabal-3.0 the file is assumed to be +-- UTF-8 encoded. +rewriteFileEx :: Verbosity -> FilePath -> String -> IO () +rewriteFileEx verbosity path = + rewriteFileLBS verbosity path . toUTF8LBS + +-- | Same as `rewriteFileEx` but for 'ByteString's. +rewriteFileLBS :: Verbosity -> FilePath -> BS.ByteString -> IO () +rewriteFileLBS verbosity path newContent = + flip catchIO mightNotExist $ do + existingContent <- annotateIO verbosity $ BS.readFile path + _ <- evaluate (BS.length existingContent) + unless (existingContent == newContent) $ + annotateIO verbosity $ + writeFileAtomic path newContent + where + mightNotExist e + | isDoesNotExistError e = + annotateIO verbosity $ writeFileAtomic path newContent + | otherwise = + ioError e + +-- | The path name that represents the current directory. +-- In Unix, it's @\".\"@, but this is system-specific. +-- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) +currentDir :: FilePath +currentDir = "." + +shortRelativePath :: FilePath -> FilePath -> FilePath +shortRelativePath from to = + case dropCommonPrefix (splitDirectories from) (splitDirectories to) of + (stuff, path) -> joinPath (map (const "..") stuff ++ path) + where + dropCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a]) + dropCommonPrefix (x : xs) (y : ys) + | x == y = dropCommonPrefix xs ys + dropCommonPrefix xs ys = (xs, ys) + +-- | Drop the extension if it's one of 'exeExtensions', or return the path +-- unchanged. +dropExeExtension :: FilePath -> FilePath +dropExeExtension filepath = + -- System.FilePath's extension handling functions are horribly + -- inconsistent, consider: + -- + -- isExtensionOf "" "foo" == False but + -- isExtensionOf "" "foo." == True. + -- + -- On the other hand stripExtension doesn't remove the empty extension: + -- + -- stripExtension "" "foo." == Just "foo." + -- + -- Since by "" in exeExtensions we mean 'no extension' anyways we can + -- just always ignore it here. + let exts = [ext | ext <- exeExtensions, ext /= ""] + in fromMaybe filepath $ do + ext <- find (`FilePath.isExtensionOf` filepath) exts + ext `FilePath.stripExtension` filepath + +-- | List of possible executable file extensions on the current build +-- platform. +exeExtensions :: [String] +exeExtensions = case (buildArch, buildOS) of + -- Possible improvement: on Windows, read the list of extensions from the + -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat; + -- .cmd". + (_, Windows) -> ["", "exe"] + (_, Ghcjs) -> ["", "exe"] + (Wasm32, _) -> ["", "wasm"] + _ -> [""] + +-- ------------------------------------------------------------ + +-- * Finding the description file + +-- ------------------------------------------------------------ + +-- | Package description file (/pkgname/@.cabal@) +defaultPackageDesc :: Verbosity -> IO FilePath +defaultPackageDesc verbosity = tryFindPackageDesc verbosity currentDir + +-- | Find a package description file in the given directory. Looks for +-- @.cabal@ files. +findPackageDesc + :: FilePath + -- ^ Where to look + -> IO (Either CabalException FilePath) + -- ^ .cabal +findPackageDesc = findPackageDescCwd "." + +-- | @since 3.4.0.0 +findPackageDescCwd + :: FilePath + -- ^ project root + -> FilePath + -- ^ relative directory + -> IO (Either CabalException FilePath) + -- ^ .cabal relative to the project root +findPackageDescCwd cwd dir = + do + files <- getDirectoryContents (cwd 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 <- + filterM + (doesFileExist . snd) + [ (dir file, cwd dir file) + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == ".cabal" + ] + case map fst cabalFiles of + [] -> return (Left NoDesc) + [cabalFile] -> return (Right cabalFile) + multiple -> return (Left $ MultiDesc multiple) + +-- | Like 'findPackageDesc', but calls 'die' in case of error. +tryFindPackageDesc :: Verbosity -> FilePath -> IO FilePath +tryFindPackageDesc verbosity dir = + either (dieWithException verbosity) return =<< findPackageDesc dir + +-- | Like 'findPackageDescCwd', but calls 'die' in case of error. +-- +-- @since 3.4.0.0 +tryFindPackageDescCwd :: Verbosity -> FilePath -> FilePath -> IO FilePath +tryFindPackageDescCwd verbosity cwd dir = + either (dieWithException verbosity) return =<< findPackageDescCwd cwd dir + +-- | Find auxiliary package information in the given directory. +-- Looks for @.buildinfo@ files. +findHookedPackageDesc + :: Verbosity + -> FilePath + -- ^ Directory to search + -> IO (Maybe FilePath) + -- ^ /dir/@\/@/pkgname/@.buildinfo@, if present +findHookedPackageDesc verbosity dir = do + files <- getDirectoryContents dir + buildInfoFiles <- + filterM + doesFileExist + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == buildInfoExt + ] + case buildInfoFiles of + [] -> return Nothing + [f] -> return (Just f) + _ -> dieWithException verbosity $ MultipleFilesWithExtension buildInfoExt + +buildInfoExt :: String buildInfoExt = ".buildinfo" diff --git a/src/Distribution/TestSuite.hs b/src/Distribution/TestSuite.hs --- a/src/Distribution/TestSuite.hs +++ b/src/Distribution/TestSuite.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.TestSuite -- Copyright : Thomas Tuegel 2010 @@ -12,91 +13,97 @@ -- -- This module defines the detailed test suite interface which makes it -- possible to expose individual tests to Cabal or other test agents. - module Distribution.TestSuite - ( TestInstance(..) - , OptionDescr(..) - , OptionType(..) - , Test(..) - , Options - , Progress(..) - , Result(..) - , testGroup - ) where + ( TestInstance (..) + , OptionDescr (..) + , OptionType (..) + , Test (..) + , Options + , Progress (..) + , Result (..) + , testGroup + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () data TestInstance = TestInstance - { run :: IO Progress -- ^ Perform the test. - , name :: String -- ^ A name for the test, unique within a - -- test suite. - , tags :: [String] -- ^ Users can select groups of tests by - -- their tags. - , options :: [OptionDescr] -- ^ Descriptions of the options recognized - -- by this test. - , setOption :: String -> String -> Either String TestInstance - -- ^ Try to set the named option to the given value. Returns an error - -- message if the option is not supported or the value could not be - -- correctly parsed; otherwise, a 'TestInstance' with the option set to - -- the given value is returned. - } + { run :: IO Progress + -- ^ Perform the test. + , name :: String + -- ^ A name for the test, unique within a + -- test suite. + , tags :: [String] + -- ^ Users can select groups of tests by + -- their tags. + , options :: [OptionDescr] + -- ^ Descriptions of the options recognized + -- by this test. + , setOption :: String -> String -> Either String TestInstance + -- ^ Try to set the named option to the given value. Returns an error + -- message if the option is not supported or the value could not be + -- correctly parsed; otherwise, a 'TestInstance' with the option set to + -- the given value is returned. + } data OptionDescr = OptionDescr - { optionName :: String - , optionDescription :: String -- ^ A human-readable description of the - -- option to guide the user setting it. - , optionType :: OptionType - , optionDefault :: Maybe String - } + { optionName :: String + , optionDescription :: String + -- ^ A human-readable description of the + -- option to guide the user setting it. + , optionType :: OptionType + , optionDefault :: Maybe String + } deriving (Eq, Read, Show) data OptionType - = OptionFile - { optionFileMustExist :: Bool - , optionFileIsDir :: Bool - , optionFileExtensions :: [String] - } - | OptionString - { optionStringMultiline :: Bool - } - | OptionNumber - { optionNumberIsInt :: Bool - , optionNumberBounds :: (Maybe String, Maybe String) - } - | OptionBool - | OptionEnum [String] - | OptionSet [String] - | OptionRngSeed + = OptionFile + { optionFileMustExist :: Bool + , optionFileIsDir :: Bool + , optionFileExtensions :: [String] + } + | OptionString + { optionStringMultiline :: Bool + } + | OptionNumber + { optionNumberIsInt :: Bool + , optionNumberBounds :: (Maybe String, Maybe String) + } + | OptionBool + | OptionEnum [String] + | OptionSet [String] + | OptionRngSeed deriving (Eq, Read, Show) data Test - = Test TestInstance - | Group - { groupName :: String - , concurrently :: Bool - -- ^ If true, then children of this group may be run in parallel. - -- Note that this setting is not inherited by children. In - -- particular, consider a group F with "concurrently = False" that - -- has some children, including a group T with "concurrently = - -- True". The children of group T may be run concurrently with each - -- other, as long as none are run at the same time as any of the - -- direct children of group F. - , groupTests :: [Test] - } - | ExtraOptions [OptionDescr] Test + = Test TestInstance + | Group + { groupName :: String + , concurrently :: Bool + -- ^ If true, then children of this group may be run in parallel. + -- Note that this setting is not inherited by children. In + -- particular, consider a group F with "concurrently = False" that + -- has some children, including a group T with "concurrently = + -- True". The children of group T may be run concurrently with each + -- other, as long as none are run at the same time as any of the + -- direct children of group F. + , groupTests :: [Test] + } + | ExtraOptions [OptionDescr] Test type Options = [(String, String)] -data Progress = Finished Result - | Progress String (IO Progress) +data Progress + = Finished Result + | Progress String (IO Progress) -data Result = Pass - | Fail String - | Error String +data Result + = Pass + | Fail String + | Error String deriving (Eq, Read, Show) -- | Create a named group of tests, which are assumed to be safe to run in -- parallel. testGroup :: String -> [Test] -> Test -testGroup n ts = Group { groupName = n, concurrently = True, groupTests = ts } +testGroup n ts = Group{groupName = n, concurrently = True, groupTests = ts} diff --git a/src/Distribution/Types/AnnotatedId.hs b/src/Distribution/Types/AnnotatedId.hs --- a/src/Distribution/Types/AnnotatedId.hs +++ b/src/Distribution/Types/AnnotatedId.hs @@ -1,9 +1,11 @@ -module Distribution.Types.AnnotatedId ( - AnnotatedId(..) -) where +{-# LANGUAGE DeriveFunctor #-} -import Prelude () +module Distribution.Types.AnnotatedId + ( AnnotatedId (..) + ) where + import Distribution.Compat.Prelude +import Prelude () import Distribution.Package import Distribution.Types.ComponentName @@ -14,21 +16,18 @@ -- -- Invariant: if ann_id x == ann_id y, then ann_pid x == ann_pid y -- and ann_cname x == ann_cname y -data AnnotatedId id = AnnotatedId { - ann_pid :: PackageId, - ann_cname :: ComponentName, - ann_id :: id - } - deriving (Show) +data AnnotatedId id = AnnotatedId + { ann_pid :: PackageId + , ann_cname :: ComponentName + , ann_id :: id + } + deriving (Show, Functor) instance Eq id => Eq (AnnotatedId id) where - x == y = ann_id x == ann_id y + x == y = ann_id x == ann_id y instance Ord id => Ord (AnnotatedId id) where - compare x y = compare (ann_id x) (ann_id y) + compare x y = compare (ann_id x) (ann_id y) instance Package (AnnotatedId id) where - packageId = ann_pid - -instance Functor AnnotatedId where - fmap f (AnnotatedId pid cn x) = AnnotatedId pid cn (f x) + packageId = ann_pid diff --git a/src/Distribution/Types/ComponentInclude.hs b/src/Distribution/Types/ComponentInclude.hs --- a/src/Distribution/Types/ComponentInclude.hs +++ b/src/Distribution/Types/ComponentInclude.hs @@ -1,25 +1,25 @@ -module Distribution.Types.ComponentInclude ( - ComponentInclude(..), - ci_id, - ci_pkgid, - ci_cname -) where +module Distribution.Types.ComponentInclude + ( ComponentInclude (..) + , ci_id + , ci_pkgid + , ci_cname + ) where -import Distribution.Types.PackageId -import Distribution.Types.ComponentName import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentName +import Distribution.Types.PackageId -- Once ci_id is refined to an 'OpenUnitId' or 'DefUnitId', -- the 'includeRequiresRn' is not so useful (because it -- includes the requirements renaming that is no longer -- needed); use 'ci_prov_renaming' instead. -data ComponentInclude id rn = ComponentInclude { - ci_ann_id :: AnnotatedId id, - ci_renaming :: rn, - -- | Did this come from an entry in @mixins@, or - -- was implicitly generated by @build-depends@? - ci_implicit :: Bool - } +data ComponentInclude id rn = ComponentInclude + { ci_ann_id :: AnnotatedId id + , ci_renaming :: rn + , ci_implicit :: Bool + -- ^ Did this come from an entry in @mixins@, or + -- was implicitly generated by @build-depends@? + } ci_id :: ComponentInclude id rn -> id ci_id = ann_id . ci_ann_id 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 @@ -2,128 +2,127 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} -module Distribution.Types.ComponentLocalBuildInfo ( - ComponentLocalBuildInfo(..), - componentIsIndefinite, - maybeComponentInstantiatedWith, +module Distribution.Types.ComponentLocalBuildInfo + ( ComponentLocalBuildInfo (..) + , componentIsIndefinite + , maybeComponentInstantiatedWith ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.ModuleName +import Prelude () import Distribution.Backpack import Distribution.Compat.Graph import Distribution.Types.ComponentId -import Distribution.Types.MungedPackageId -import Distribution.Types.UnitId import Distribution.Types.ComponentName -import Distribution.Types.MungedPackageName import Distribution.Types.ModuleRenaming +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.UnitId import qualified Distribution.InstalledPackageInfo as Installed -- | The first five fields are common across all algebraic variants. data ComponentLocalBuildInfo - = LibComponentLocalBuildInfo { - -- | It would be very convenient to store the literal Library here, - -- but if we do that, it will get serialized (via the Binary) - -- instance twice. So instead we just provide the ComponentName, - -- which can be used to find the Component in the - -- PackageDescription. NB: eventually, this will NOT uniquely - -- identify the ComponentLocalBuildInfo. - componentLocalName :: ComponentName, - -- | The computed 'ComponentId' of this component. - componentComponentId :: ComponentId, - -- | The computed 'UnitId' which uniquely identifies this - -- component. Might be hashed. - componentUnitId :: UnitId, - -- | Is this an indefinite component (i.e. has unfilled holes)? - componentIsIndefinite_ :: Bool, - -- | How the component was instantiated - componentInstantiatedWith :: [(ModuleName, OpenModule)], - -- | Resolved internal and external package dependencies for this component. - -- The 'BuildInfo' specifies a set of build dependencies that must be - -- satisfied in terms of version ranges. This field fixes those dependencies - -- to the specific versions available on this machine for this compiler. - componentPackageDeps :: [(UnitId, MungedPackageId)], - -- | The set of packages that are brought into scope during - -- compilation, including a 'ModuleRenaming' which may used - -- to hide or rename modules. This is what gets translated into - -- @-package-id@ arguments. This is a modernized version of - -- 'componentPackageDeps', which is kept around for BC purposes. - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - -- | The internal dependencies which induce a graph on the - -- 'ComponentLocalBuildInfo' of this package. This does NOT - -- coincide with 'componentPackageDeps' because it ALSO records - -- 'build-tool' dependencies on executables. Maybe one day - -- @cabal-install@ will also handle these correctly too! - componentInternalDeps :: [UnitId], - -- | Compatibility "package key" that we pass to older versions of GHC. - componentCompatPackageKey :: String, - -- | Compatibility "package name" that we register this component as. - componentCompatPackageName :: MungedPackageName, - -- | A list of exposed modules (either defined in this component, - -- or reexported from another component.) - componentExposedModules :: [Installed.ExposedModule], - -- | Convenience field, specifying whether or not this is the - -- "public library" that has the same name as the package. - componentIsPublic :: Bool - } - -- TODO: refactor all these duplicates - | FLibComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - } - | ExeComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - } - | TestComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - - } - | BenchComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - } + = LibComponentLocalBuildInfo + { componentLocalName :: ComponentName + -- ^ It would be very convenient to store the literal Library here, + -- but if we do that, it will get serialized (via the Binary) + -- instance twice. So instead we just provide the ComponentName, + -- which can be used to find the Component in the + -- PackageDescription. NB: eventually, this will NOT uniquely + -- identify the ComponentLocalBuildInfo. + , componentComponentId :: ComponentId + -- ^ The computed 'ComponentId' of this component. + , componentUnitId :: UnitId + -- ^ The computed 'UnitId' which uniquely identifies this + -- component. Might be hashed. + , componentIsIndefinite_ :: Bool + -- ^ Is this an indefinite component (i.e. has unfilled holes)? + , componentInstantiatedWith :: [(ModuleName, OpenModule)] + -- ^ How the component was instantiated + , componentPackageDeps :: [(UnitId, MungedPackageId)] + -- ^ Resolved internal and external package dependencies for this component. + -- The 'BuildInfo' specifies a set of build dependencies that must be + -- satisfied in terms of version ranges. This field fixes those dependencies + -- to the specific versions available on this machine for this compiler. + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + -- ^ The set of packages that are brought into scope during + -- compilation, including a 'ModuleRenaming' which may used + -- to hide or rename modules. This is what gets translated into + -- @-package-id@ arguments. This is a modernized version of + -- 'componentPackageDeps', which is kept around for BC purposes. + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + -- ^ The internal dependencies which induce a graph on the + -- 'ComponentLocalBuildInfo' of this package. This does NOT + -- coincide with 'componentPackageDeps' because it ALSO records + -- 'build-tool' dependencies on executables. Maybe one day + -- @cabal-install@ will also handle these correctly too! + , componentCompatPackageKey :: String + -- ^ Compatibility "package key" that we pass to older versions of GHC. + , componentCompatPackageName :: MungedPackageName + -- ^ Compatibility "package name" that we register this component as. + , componentExposedModules :: [Installed.ExposedModule] + -- ^ A list of exposed modules (either defined in this component, + -- or reexported from another component.) + , componentIsPublic :: Bool + -- ^ Convenience field, specifying whether or not this is the + -- "public library" that has the same name as the package. + } + | -- TODO: refactor all these duplicates + FLibComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } + | ExeComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } + | TestComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } + | BenchComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } deriving (Generic, Read, Show, Typeable) instance Binary ComponentLocalBuildInfo instance Structured ComponentLocalBuildInfo instance IsNode ComponentLocalBuildInfo where - type Key ComponentLocalBuildInfo = UnitId - nodeKey = componentUnitId - nodeNeighbors = componentInternalDeps + type Key ComponentLocalBuildInfo = UnitId + nodeKey = componentUnitId + nodeNeighbors = componentInternalDeps componentIsIndefinite :: ComponentLocalBuildInfo -> Bool -componentIsIndefinite LibComponentLocalBuildInfo{ componentIsIndefinite_ = b } = b +componentIsIndefinite LibComponentLocalBuildInfo{componentIsIndefinite_ = b} = b componentIsIndefinite _ = False maybeComponentInstantiatedWith :: ComponentLocalBuildInfo -> Maybe [(ModuleName, OpenModule)] maybeComponentInstantiatedWith - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } = Just insts + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} = Just insts maybeComponentInstantiatedWith _ = 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 @@ -1,8 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} + module Distribution.Types.DumpBuildInfo - ( DumpBuildInfo(..) - ) where + ( DumpBuildInfo (..) + ) where import Distribution.Compat.Prelude diff --git a/src/Distribution/Types/GivenComponent.hs b/src/Distribution/Types/GivenComponent.hs --- a/src/Distribution/Types/GivenComponent.hs +++ b/src/Distribution/Types/GivenComponent.hs @@ -1,9 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.GivenComponent ( - GivenComponent(..) -) where +module Distribution.Types.GivenComponent + ( GivenComponent (..) + ) where + import Distribution.Compat.Prelude import Distribution.Types.ComponentId @@ -16,12 +17,12 @@ -- It enables Cabal to know which 'ComponentId' to associate with a library -- -- @since 2.3.0.0 -data GivenComponent = - GivenComponent - { givenComponentPackage :: PackageName - , givenComponentName :: LibraryName -- --dependency is for libraries - -- only, not for any component - , givenComponentId :: ComponentId } +data GivenComponent = GivenComponent + { givenComponentPackage :: PackageName + , givenComponentName :: LibraryName -- --dependency is for libraries + -- only, not for any component + , givenComponentId :: ComponentId + } deriving (Generic, Read, Show, Eq, Typeable) instance Binary GivenComponent diff --git a/src/Distribution/Types/LocalBuildConfig.hs b/src/Distribution/Types/LocalBuildConfig.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Types/LocalBuildConfig.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Distribution.Types.LocalBuildConfig + ( -- * The types + PackageBuildDescr (..) + , ComponentBuildDescr (..) + , LocalBuildDescr (..) + , LocalBuildConfig (..) + , BuildOptions (..) + + -- * Conversion functions + , buildOptionsConfigFlags + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.ComponentId +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.PackageDescription +import Distribution.Types.UnitId + +import Distribution.PackageDescription +import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs hiding + ( absoluteInstallDirs + , prefixRelativeInstallDirs + , substPathTemplate + ) +import Distribution.Simple.PackageIndex +import Distribution.Simple.Program +import Distribution.Simple.Setup.Config +import Distribution.System + +import Distribution.Compat.Graph (Graph) + +-- | 'PackageBuildDescr' contains the information Cabal determines after +-- performing package-wide configuration of a package, before doing any +-- per-component configuration. +data PackageBuildDescr = PackageBuildDescr + { configFlags :: ConfigFlags + -- ^ Options passed to the configuration step. + -- Needed to re-run configuration when .cabal is out of date + , flagAssignment :: FlagAssignment + -- ^ The final set of flags which were picked for this package + , componentEnabledSpec :: ComponentRequestedSpec + -- ^ What components were enabled during configuration, and why. + , compiler :: Compiler + -- ^ The compiler we're building with + , hostPlatform :: Platform + -- ^ The platform we're building for + , pkgDescrFile :: Maybe FilePath + -- ^ the filename containing the .cabal file, if available + , localPkgDescr :: PackageDescription + -- ^ WARNING WARNING WARNING Be VERY careful about using + -- this function; we haven't deprecated it but using it + -- could introduce subtle bugs related to + -- 'HookedBuildInfo'. + -- + -- In principle, this is supposed to contain the + -- resolved package description, that does not contain + -- any conditionals. However, it MAY NOT contain + -- the description with a 'HookedBuildInfo' applied + -- to it; see 'HookedBuildInfo' for the whole sordid saga. + -- As much as possible, Cabal library should avoid using + -- this parameter. + , installDirTemplates :: InstallDirTemplates + -- ^ The installation directories for the various different + -- kinds of files + -- TODO: inplaceDirTemplates :: InstallDirs FilePath + , withPackageDB :: PackageDBStack + -- ^ What package database to use, global\/user + , extraCoverageFor :: [UnitId] + -- ^ For per-package builds-only: an extra list of libraries to be included in + -- the hpc coverage report for testsuites run with @--enable-coverage@. + -- Notably, this list must exclude indefinite libraries and instantiations + -- because HPC does not support backpack (Nov. 2023). + } + deriving (Generic, Read, Show) + +-- | Information about individual components in a package, +-- determined after the configure step. +data ComponentBuildDescr = ComponentBuildDescr + { componentGraph :: Graph ComponentLocalBuildInfo + -- ^ All the components to build, ordered by topological + -- sort, and with their INTERNAL dependencies over the + -- intrapackage dependency graph. + -- TODO: this is assumed to be short; otherwise we want + -- some sort of ordered map. + , componentNameMap :: Map ComponentName [ComponentLocalBuildInfo] + -- ^ A map from component name to all matching + -- components. These coincide with 'componentGraph' + -- There may be more than one matching component because of backpack instantiations + , promisedPkgs :: Map (PackageName, ComponentName) ComponentId + -- ^ The packages we were promised, but aren't already installed. + -- MP: Perhaps this just needs to be a Set UnitId at this stage. + , installedPkgs :: InstalledPackageIndex + -- ^ All the info about the installed packages that the + -- current package depends on (directly or indirectly). + -- The copy saved on disk does NOT include internal + -- dependencies (because we just don't have enough + -- information at this point to have an + -- 'InstalledPackageInfo' for an internal dep), but we + -- will often update it with the internal dependencies; + -- see for example 'Distribution.Simple.Build.build'. + -- (This admonition doesn't apply for per-component builds.) + } + deriving (Generic, Read, Show) + +-- | 'LocalBuildDescr ' contains the information Cabal determines after +-- performing package-wide and per-component configuration of a package. +-- +-- This information can no longer be changed after that point. +data LocalBuildDescr = LocalBuildDescr + { packageBuildDescr :: PackageBuildDescr + -- ^ Information that is available after configuring the package itself, + -- before looking at individual components. + , componentBuildDescr :: ComponentBuildDescr + -- ^ Information about individual components in the package + -- determined after the configure step. + } + deriving (Generic, Read, Show) + +-- | 'LocalBuildConfig' contains options that can be controlled +-- by the user and serve as inputs to the configuration of a package. +data LocalBuildConfig = LocalBuildConfig + { extraConfigArgs :: [String] + -- ^ Extra args on the command line for the configuration step. + -- Needed to re-run configuration when .cabal is out of date + , withPrograms :: ProgramDb + -- ^ Location and args for all programs + , withBuildOptions :: BuildOptions + -- ^ Options to control the build, e.g. whether to + -- enable profiling or to enable program coverage. + } + deriving (Generic, Read, Show) + +-- | 'BuildOptions' contains configuration options that can be controlled +-- by the user. +data BuildOptions = BuildOptions + { withVanillaLib :: Bool + -- ^ Whether to build normal libs. + , withProfLib :: Bool + -- ^ Whether to build profiling versions of libs. + , withSharedLib :: Bool + -- ^ Whether to build shared versions of libs. + , withStaticLib :: Bool + -- ^ Whether to build static versions of libs (with all other libs rolled in) + , withDynExe :: Bool + -- ^ Whether to link executables dynamically + , withFullyStaticExe :: Bool + -- ^ Whether to link executables fully statically + , withProfExe :: Bool + -- ^ Whether to build executables for profiling. + , withProfLibDetail :: ProfDetailLevel + -- ^ Level of automatic profile detail. + , withProfExeDetail :: ProfDetailLevel + -- ^ Level of automatic profile detail. + , withOptimization :: OptimisationLevel + -- ^ Whether to build with optimization (if available). + , withDebugInfo :: DebugInfoLevel + -- ^ Whether to emit debug info (if available). + , withGHCiLib :: Bool + -- ^ Whether to build libs suitable for use with GHCi. + , splitSections :: Bool + -- ^ Use -split-sections with GHC, if available + , splitObjs :: Bool + -- ^ Use -split-objs with GHC, if available + , stripExes :: Bool + -- ^ Whether to strip executables during install + , stripLibs :: Bool + -- ^ Whether to strip libraries during install + , exeCoverage :: Bool + -- ^ Whether to enable executable program coverage + , libCoverage :: Bool + -- ^ Whether to enable library program coverage + , relocatable :: Bool + -- ^ Whether to build a relocatable package + } + deriving (Eq, Generic, Read, Show) + +instance Binary PackageBuildDescr +instance Structured PackageBuildDescr +instance Binary ComponentBuildDescr +instance Structured ComponentBuildDescr +instance Binary LocalBuildDescr +instance Structured LocalBuildDescr +instance Binary LocalBuildConfig +instance Structured LocalBuildConfig +instance Binary BuildOptions +instance Structured BuildOptions + +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 + , 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 + , configLibCoverage = mempty + , 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 @@ -1,170 +1,299 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -module Distribution.Types.LocalBuildInfo ( - -- * The type - - LocalBuildInfo(..), +module Distribution.Types.LocalBuildInfo + ( -- * The types + LocalBuildInfo + ( LocalBuildInfo + , configFlags + , flagAssignment + , componentEnabledSpec + , extraConfigArgs + , installDirTemplates + , compiler + , hostPlatform + , pkgDescrFile + , componentGraph + , componentNameMap + , promisedPkgs + , installedPkgs + , localPkgDescr + , withPrograms + , withPackageDB + , withVanillaLib + , withProfLib + , withSharedLib + , withStaticLib + , withDynExe + , withFullyStaticExe + , withProfExe + , withProfLibDetail + , withProfExeDetail + , withOptimization + , withDebugInfo + , withGHCiLib + , splitSections + , splitObjs + , stripExes + , stripLibs + , exeCoverage + , libCoverage + , extraCoverageFor + , relocatable + , .. + ) -- * Convenience accessors - - localComponentId, - localUnitId, - localCompatPackageKey, - localPackage, + , localComponentId + , localUnitId + , localCompatPackageKey + , localPackage + , buildDir + , buildDirPBD + , configFlagsBuildDir + , cabalFilePath + , progPrefix + , progSuffix -- * Build targets of the 'LocalBuildInfo'. - - componentNameCLBIs, - - -- NB: the primes mean that they take a 'PackageDescription' - -- which may not match 'localPkgDescr' in 'LocalBuildInfo'. - -- More logical types would drop this argument, but - -- at the moment, this is the ONLY supported function, because - -- 'localPkgDescr' is not guaranteed to match. At some point - -- we will fix it and then we can use the (free) unprimed - -- namespace for the correct commands. - -- - -- See https://github.com/haskell/cabal/issues/3606 for more - -- details. + , componentNameCLBIs + -- NB: the primes mean that they take a 'PackageDescription' + -- which may not match 'localPkgDescr' in 'LocalBuildInfo'. + -- More logical types would drop this argument, but + -- at the moment, this is the ONLY supported function, because + -- 'localPkgDescr' is not guaranteed to match. At some point + -- we will fix it and then we can use the (free) unprimed + -- namespace for the correct commands. + -- + -- See https://github.com/haskell/cabal/issues/3606 for more + -- details. - componentNameTargets', - unitIdTarget', - allTargetsInBuildOrder', - withAllTargetsInBuildOrder', - neededTargetsInBuildOrder', - withNeededTargetsInBuildOrder', - testCoverage, + , componentNameTargets' + , unitIdTarget' + , allTargetsInBuildOrder' + , withAllTargetsInBuildOrder' + , neededTargetsInBuildOrder' + , withNeededTargetsInBuildOrder' + , testCoverage -- * Functions you SHOULD NOT USE (yet), but are defined here to - -- prevent someone from accidentally defining them - componentNameTargets, - unitIdTarget, - allTargetsInBuildOrder, - withAllTargetsInBuildOrder, - neededTargetsInBuildOrder, - withNeededTargetsInBuildOrder, + -- prevent someone from accidentally defining them + + , componentNameTargets + , unitIdTarget + , allTargetsInBuildOrder + , withAllTargetsInBuildOrder + , neededTargetsInBuildOrder + , withNeededTargetsInBuildOrder ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.PackageDescription +import Distribution.Types.ComponentId import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.ComponentId +import qualified Distribution.Types.LocalBuildConfig as LBC +import Distribution.Types.PackageDescription import Distribution.Types.PackageId -import Distribution.Types.UnitId import Distribution.Types.TargetInfo +import Distribution.Types.UnitId -import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, - prefixRelativeInstallDirs, - substPathTemplate, ) -import Distribution.Simple.Program import Distribution.PackageDescription +import Distribution.Pretty import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs hiding + ( absoluteInstallDirs + , prefixRelativeInstallDirs + , substPathTemplate + ) import Distribution.Simple.PackageIndex -import Distribution.Simple.Setup +import Distribution.Simple.Program +import Distribution.Simple.Setup.Config import Distribution.System -import Distribution.Pretty +import qualified Data.Map as Map import Distribution.Compat.Graph (Graph) import qualified Distribution.Compat.Graph as Graph -import qualified Data.Map as Map +import System.FilePath (()) -- | Data cached after configuration step. See also -- 'Distribution.Simple.Setup.ConfigFlags'. -data LocalBuildInfo = LocalBuildInfo { - configFlags :: ConfigFlags, - -- ^ Options passed to the configuration step. - -- Needed to re-run configuration when .cabal is out of date - flagAssignment :: FlagAssignment, - -- ^ The final set of flags which were picked for this package - componentEnabledSpec :: ComponentRequestedSpec, - -- ^ What components were enabled during configuration, and why. - extraConfigArgs :: [String], - -- ^ Extra args on the command line for the configuration step. - -- Needed to re-run configuration when .cabal is out of date - installDirTemplates :: InstallDirTemplates, - -- ^ The installation directories for the various different - -- kinds of files - --TODO: inplaceDirTemplates :: InstallDirs FilePath - compiler :: Compiler, - -- ^ The compiler we're building with - hostPlatform :: Platform, - -- ^ The platform we're building for - buildDir :: FilePath, - -- ^ Where to build the package. - cabalFilePath :: Maybe FilePath, - -- ^ Path to the cabal file, if given during configuration. - componentGraph :: Graph ComponentLocalBuildInfo, - -- ^ All the components to build, ordered by topological - -- sort, and with their INTERNAL dependencies over the - -- intrapackage dependency graph. - -- TODO: this is assumed to be short; otherwise we want - -- some sort of ordered map. - componentNameMap :: Map ComponentName [ComponentLocalBuildInfo], - -- ^ A map from component name to all matching - -- components. These coincide with 'componentGraph' - installedPkgs :: InstalledPackageIndex, - -- ^ All the info about the installed packages that the - -- current package depends on (directly or indirectly). - -- The copy saved on disk does NOT include internal - -- dependencies (because we just don't have enough - -- information at this point to have an - -- 'InstalledPackageInfo' for an internal dep), but we - -- will often update it with the internal dependencies; - -- see for example 'Distribution.Simple.Build.build'. - -- (This admonition doesn't apply for per-component builds.) - pkgDescrFile :: Maybe FilePath, - -- ^ the filename containing the .cabal file, if available - localPkgDescr :: PackageDescription, - -- ^ WARNING WARNING WARNING Be VERY careful about using - -- this function; we haven't deprecated it but using it - -- could introduce subtle bugs related to - -- 'HookedBuildInfo'. - -- - -- In principle, this is supposed to contain the - -- resolved package description, that does not contain - -- any conditionals. However, it MAY NOT contain - -- the description with a 'HookedBuildInfo' applied - -- to it; see 'HookedBuildInfo' for the whole sordid saga. - -- As much as possible, Cabal library should avoid using - -- this parameter. - withPrograms :: ProgramDb, -- ^Location and args for all programs - withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user - withVanillaLib:: Bool, -- ^Whether to build normal libs. - withProfLib :: Bool, -- ^Whether to build profiling versions of libs. - withSharedLib :: Bool, -- ^Whether to build shared versions of libs. - withStaticLib :: Bool, -- ^Whether to build static versions of libs (with all other libs rolled in) - withDynExe :: Bool, -- ^Whether to link executables dynamically - withFullyStaticExe :: Bool, -- ^Whether to link executables fully statically - withProfExe :: Bool, -- ^Whether to build executables for profiling. - withProfLibDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. - withProfExeDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. - withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). - withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (if available). - withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. - splitSections :: Bool, -- ^Use -split-sections with GHC, if available - splitObjs :: Bool, -- ^Use -split-objs with GHC, if available - stripExes :: Bool, -- ^Whether to strip executables during install - stripLibs :: Bool, -- ^Whether to strip libraries during install - exeCoverage :: Bool, -- ^Whether to enable executable program coverage - libCoverage :: Bool, -- ^Whether to enable library program coverage - progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables - progSuffix :: PathTemplate, -- ^Suffix to be appended to installed executables - relocatable :: Bool -- ^Whether to build a relocatable package - } deriving (Generic, Read, Show, Typeable) +data LocalBuildInfo = NewLocalBuildInfo + { localBuildDescr :: LBC.LocalBuildDescr + -- ^ Information about a package determined by Cabal + -- after the configuration step. + , localBuildConfig :: LBC.LocalBuildConfig + -- ^ Information about a package configuration + -- that can be modified by the user at configuration time. + } + deriving (Generic, Read, Show, Typeable) +{-# COMPLETE LocalBuildInfo #-} + +-- | This pattern synonym is for backwards compatibility, to adapt +-- to 'LocalBuildInfo' being split into 'LocalBuildDescr' and 'LocalBuildConfig'. +pattern LocalBuildInfo + :: ConfigFlags + -> FlagAssignment + -> ComponentRequestedSpec + -> [String] + -> InstallDirTemplates + -> Compiler + -> Platform + -> Maybe FilePath + -> Graph ComponentLocalBuildInfo + -> Map ComponentName [ComponentLocalBuildInfo] + -> Map (PackageName, ComponentName) ComponentId + -> InstalledPackageIndex + -> PackageDescription + -> ProgramDb + -> PackageDBStack + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> ProfDetailLevel + -> ProfDetailLevel + -> OptimisationLevel + -> DebugInfoLevel + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> [UnitId] + -> Bool + -> LocalBuildInfo +pattern LocalBuildInfo + { configFlags + , flagAssignment + , componentEnabledSpec + , extraConfigArgs + , installDirTemplates + , compiler + , hostPlatform + , pkgDescrFile + , componentGraph + , componentNameMap + , promisedPkgs + , installedPkgs + , localPkgDescr + , withPrograms + , withPackageDB + , withVanillaLib + , withProfLib + , withSharedLib + , withStaticLib + , withDynExe + , withFullyStaticExe + , withProfExe + , withProfLibDetail + , withProfExeDetail + , withOptimization + , withDebugInfo + , withGHCiLib + , splitSections + , splitObjs + , stripExes + , stripLibs + , exeCoverage + , libCoverage + , extraCoverageFor + , relocatable + } = + NewLocalBuildInfo + { localBuildDescr = + LBC.LocalBuildDescr + { packageBuildDescr = + LBC.PackageBuildDescr + { configFlags + , flagAssignment + , componentEnabledSpec + , compiler + , hostPlatform + , localPkgDescr + , installDirTemplates + , withPackageDB + , pkgDescrFile + , extraCoverageFor + } + , componentBuildDescr = + LBC.ComponentBuildDescr + { componentGraph + , componentNameMap + , promisedPkgs + , installedPkgs + } + } + , localBuildConfig = + LBC.LocalBuildConfig + { extraConfigArgs + , withPrograms + , withBuildOptions = + LBC.BuildOptions + { withVanillaLib + , withProfLib + , withSharedLib + , withStaticLib + , withDynExe + , withFullyStaticExe + , withProfExe + , withProfLibDetail + , withProfExeDetail + , withOptimization + , withDebugInfo + , withGHCiLib + , splitSections + , splitObjs + , stripExes + , stripLibs + , exeCoverage + , libCoverage + , relocatable + } + } + } + instance Binary LocalBuildInfo instance Structured LocalBuildInfo ------------------------------------------------------------------------------- -- Accessor functions +buildDir :: LocalBuildInfo -> FilePath +buildDir lbi = + buildDirPBD $ LBC.packageBuildDescr $ localBuildDescr lbi + +buildDirPBD :: LBC.PackageBuildDescr -> FilePath +buildDirPBD (LBC.PackageBuildDescr{configFlags = cfg}) = + configFlagsBuildDir cfg + +configFlagsBuildDir :: ConfigFlags -> FilePath +configFlagsBuildDir cfg = fromFlag (configDistPref cfg) "build" + +cabalFilePath :: LocalBuildInfo -> Maybe FilePath +cabalFilePath (LocalBuildInfo{configFlags = cfg}) = + flagToMaybe (configCabalFilePath cfg) + +progPrefix, progSuffix :: LocalBuildInfo -> PathTemplate +progPrefix (LocalBuildInfo{configFlags = cfg}) = + fromFlag $ configProgPrefix cfg +progSuffix (LocalBuildInfo{configFlags = cfg}) = + fromFlag $ configProgSuffix cfg + -- TODO: Get rid of these functions, as much as possible. They are -- a bit useful in some cases, but you should be very careful! @@ -173,71 +302,73 @@ -- on the package ID. localComponentId :: LocalBuildInfo -> ComponentId localComponentId lbi = - case componentNameCLBIs lbi (CLibName LMainLibName) of - [LibComponentLocalBuildInfo { componentComponentId = cid }] - -> cid - _ -> mkComponentId (prettyShow (localPackage lbi)) + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo{componentComponentId = cid}] -> + cid + _ -> mkComponentId (prettyShow (localPackage lbi)) -- | Extract the 'PackageIdentifier' of a 'LocalBuildInfo'. -- This is a "safe" use of 'localPkgDescr' localPackage :: LocalBuildInfo -> PackageId -localPackage lbi = package (localPkgDescr lbi) +localPackage (LocalBuildInfo{localPkgDescr = pkg}) = package pkg -- | Extract the 'UnitId' from the library component of a -- 'LocalBuildInfo' if it exists, or make a fake unit ID based on -- the package ID. localUnitId :: LocalBuildInfo -> UnitId localUnitId lbi = - case componentNameCLBIs lbi (CLibName LMainLibName) of - [LibComponentLocalBuildInfo { componentUnitId = uid }] - -> uid - _ -> mkLegacyUnitId $ localPackage lbi + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo{componentUnitId = uid}] -> + uid + _ -> mkLegacyUnitId $ localPackage lbi -- | Extract the compatibility package key from the public library component of a -- 'LocalBuildInfo' if it exists, or make a fake package key based -- on the package ID. localCompatPackageKey :: LocalBuildInfo -> String localCompatPackageKey lbi = - case componentNameCLBIs lbi (CLibName LMainLibName) of - [LibComponentLocalBuildInfo { componentCompatPackageKey = pk }] - -> pk - _ -> prettyShow (localPackage lbi) + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo{componentCompatPackageKey = pk}] -> + pk + _ -> prettyShow (localPackage lbi) -- | Convenience function to generate a default 'TargetInfo' from a -- 'ComponentLocalBuildInfo'. The idea is to call this once, and then -- use 'TargetInfo' everywhere else. Private to this module. mkTargetInfo :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> TargetInfo mkTargetInfo pkg_descr _lbi clbi = - TargetInfo { - targetCLBI = clbi, - -- NB: @pkg_descr@, not @localPkgDescr lbi@! - targetComponent = getComponent pkg_descr - (componentLocalName clbi) - } + TargetInfo + { targetCLBI = clbi + , -- NB: @pkg_descr@, not @localPkgDescr lbi@! + targetComponent = + getComponent + pkg_descr + (componentLocalName clbi) + } -- | Return all 'TargetInfo's associated with 'ComponentName'. -- In the presence of Backpack there may be more than one! -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. componentNameTargets' :: PackageDescription -> LocalBuildInfo -> ComponentName -> [TargetInfo] -componentNameTargets' pkg_descr lbi cname = - case Map.lookup cname (componentNameMap lbi) of - Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis - Nothing -> [] +componentNameTargets' pkg_descr lbi@(LocalBuildInfo{componentNameMap = comps}) cname = + case Map.lookup cname comps of + Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis + Nothing -> [] unitIdTarget' :: PackageDescription -> LocalBuildInfo -> UnitId -> Maybe TargetInfo -unitIdTarget' pkg_descr lbi uid = - case Graph.lookup uid (componentGraph lbi) of - Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi) - Nothing -> Nothing +unitIdTarget' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) uid = + case Graph.lookup uid compsGraph of + Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi) + Nothing -> Nothing -- | Return all 'ComponentLocalBuildInfo's associated with 'ComponentName'. -- In the presence of Backpack there may be more than one! componentNameCLBIs :: LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo] -componentNameCLBIs lbi cname = - case Map.lookup cname (componentNameMap lbi) of - Just clbis -> clbis - Nothing -> [] +componentNameCLBIs (LocalBuildInfo{componentNameMap = comps}) cname = + case Map.lookup cname comps of + Just clbis -> clbis + Nothing -> [] -- TODO: Maybe cache topsort (Graph can do this) @@ -246,24 +377,24 @@ -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. allTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [TargetInfo] -allTargetsInBuildOrder' pkg_descr lbi - = map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (componentGraph lbi)) +allTargetsInBuildOrder' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) = + map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort compsGraph) -- | Execute @f@ for every 'TargetInfo' in the package, respecting the -- build dependency order. (TODO: We should use Shake!) -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. withAllTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> (TargetInfo -> IO ()) -> IO () -withAllTargetsInBuildOrder' pkg_descr lbi f - = sequence_ [ f target | target <- allTargetsInBuildOrder' pkg_descr lbi ] +withAllTargetsInBuildOrder' pkg_descr lbi f = + sequence_ [f target | target <- allTargetsInBuildOrder' pkg_descr lbi] -- | Return the list of all targets needed to build the @uids@, in -- the order they need to be built. -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. neededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo] -neededTargetsInBuildOrder' pkg_descr lbi uids = - case Graph.closure (componentGraph lbi) uids of +neededTargetsInBuildOrder' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) uids = + case Graph.closure compsGraph uids of Nothing -> error $ "localBuildPlan: missing uids " ++ intercalate ", " (map prettyShow uids) Just clos -> map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (Graph.fromDistinctList clos)) @@ -272,33 +403,34 @@ -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. withNeededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO () -withNeededTargetsInBuildOrder' pkg_descr lbi uids f - = sequence_ [ f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids ] +withNeededTargetsInBuildOrder' pkg_descr lbi uids f = + sequence_ [f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids] -- | Is coverage enabled for test suites? In practice, this requires library -- and executable profiling to be enabled. testCoverage :: LocalBuildInfo -> Bool -testCoverage lbi = exeCoverage lbi && libCoverage lbi +testCoverage (LocalBuildInfo{exeCoverage = exes, libCoverage = libs}) = + exes && libs ------------------------------------------------------------------------------- -- Stub functions to prevent someone from accidentally defining them {-# WARNING componentNameTargets, unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it. See the documentation for 'HookedBuildInfo' for an explanation of the issue. If you have a 'PackageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-} - componentNameTargets :: LocalBuildInfo -> ComponentName -> [TargetInfo] -componentNameTargets lbi = componentNameTargets' (localPkgDescr lbi) lbi - +componentNameTargets lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + componentNameTargets' pkg lbi unitIdTarget :: LocalBuildInfo -> UnitId -> Maybe TargetInfo -unitIdTarget lbi = unitIdTarget' (localPkgDescr lbi) lbi - +unitIdTarget lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + unitIdTarget' pkg lbi allTargetsInBuildOrder :: LocalBuildInfo -> [TargetInfo] -allTargetsInBuildOrder lbi = allTargetsInBuildOrder' (localPkgDescr lbi) lbi - +allTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + allTargetsInBuildOrder' pkg lbi withAllTargetsInBuildOrder :: LocalBuildInfo -> (TargetInfo -> IO ()) -> IO () -withAllTargetsInBuildOrder lbi = withAllTargetsInBuildOrder' (localPkgDescr lbi) lbi - +withAllTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + withAllTargetsInBuildOrder' pkg lbi neededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> [TargetInfo] -neededTargetsInBuildOrder lbi = neededTargetsInBuildOrder' (localPkgDescr lbi) lbi - +neededTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + neededTargetsInBuildOrder' pkg lbi withNeededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO () -withNeededTargetsInBuildOrder lbi = withNeededTargetsInBuildOrder' (localPkgDescr lbi) lbi +withNeededTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + withNeededTargetsInBuildOrder' pkg lbi diff --git a/src/Distribution/Types/ParStrat.hs b/src/Distribution/Types/ParStrat.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Types/ParStrat.hs @@ -0,0 +1,24 @@ +module Distribution.Types.ParStrat where + +-- | 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`). + NumJobs (Maybe Int) + | -- | `--semaphore`: use a system semaphore to control parallelism. + UseSem sem + | -- | No parallelism (neither `-jN` nor `--semaphore`, but could be `-j1`). + Serial + deriving (Show) + +-- | Used by Cabal to indicate that we want to use this specific semaphore (created by cabal-install) +type ParStrat = ParStratX String + +-- | Used by cabal-install to say we want to create a semaphore with N slots. +type ParStratInstall = ParStratX Int + +-- | Determine if the parallelism strategy enables parallel builds. +isParallelBuild :: ParStratX n -> Bool +isParallelBuild Serial = False +isParallelBuild (NumJobs (Just 1)) = False +isParallelBuild (NumJobs _) = True +isParallelBuild UseSem{} = True diff --git a/src/Distribution/Types/TargetInfo.hs b/src/Distribution/Types/TargetInfo.hs --- a/src/Distribution/Types/TargetInfo.hs +++ b/src/Distribution/Types/TargetInfo.hs @@ -1,33 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} -module Distribution.Types.TargetInfo ( - TargetInfo(..) -) where -import Prelude () +module Distribution.Types.TargetInfo + ( TargetInfo (..) + ) where + import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.Component +import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.UnitId -import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Compat.Graph (IsNode (..)) -- | The 'TargetInfo' contains all the information necessary to build a -- specific target (e.g., component/module/file) in a package. In -- principle, one can get the 'Component' from a -- 'ComponentLocalBuildInfo' and 'LocalBuildInfo', but it is much more -- convenient to have the component in hand. -data TargetInfo = TargetInfo { - targetCLBI :: ComponentLocalBuildInfo, - targetComponent :: Component - -- TODO: BuildTargets supporting parsing these is dumb, - -- we don't have support for compiling single modules or - -- file paths. Accommodating it now is premature - -- generalization. Figure it out later. - -- targetSub :: Maybe (Either ModuleName FilePath) - } +data TargetInfo = TargetInfo + { targetCLBI :: ComponentLocalBuildInfo + , targetComponent :: Component + -- TODO: BuildTargets supporting parsing these is dumb, + -- we don't have support for compiling single modules or + -- file paths. Accommodating it now is premature + -- generalization. Figure it out later. + -- targetSub :: Maybe (Either ModuleName FilePath) + } + deriving (Generic, Show) +instance Binary TargetInfo +instance Structured TargetInfo + instance IsNode TargetInfo where - type Key TargetInfo = UnitId - nodeKey = nodeKey . targetCLBI - nodeNeighbors = nodeNeighbors . targetCLBI + type Key TargetInfo = UnitId + nodeKey = nodeKey . targetCLBI + nodeNeighbors = nodeNeighbors . targetCLBI 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 @@ -1,78 +1,82 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + -- | @since 2.2.0 module Distribution.Utils.IOData - ( -- * 'IOData' & 'IODataMode' type - IOData (..) - , IODataMode (..) - , KnownIODataMode (..) - , withIOData - , null - , hPutContents - ) where + ( -- * 'IOData' & 'IODataMode' type + IOData (..) + , IODataMode (..) + , KnownIODataMode (..) + , withIOData + , null + , hPutContents + ) where import qualified Data.ByteString.Lazy as LBS -import Distribution.Compat.Prelude hiding (null) -import qualified Prelude +import Distribution.Compat.Prelude hiding (null) import qualified System.IO +import qualified Prelude -- | Represents either textual or binary data passed via I/O functions -- which support binary/text mode -- -- @since 2.2 data IOData - = IODataText String - -- ^ How Text gets encoded is usually locale-dependent. - | IODataBinary LBS.ByteString - -- ^ Raw binary which gets read/written in binary mode. + = -- | How Text gets encoded is usually locale-dependent. + IODataText String + | -- | Raw binary which gets read/written in binary mode. + IODataBinary LBS.ByteString +-- | Applies a function polymorphic over 'IODataMode' to an 'IOData' value. withIOData :: IOData -> (forall mode. IODataMode mode -> mode -> r) -> r -withIOData (IODataText str) k = k IODataModeText str +withIOData (IODataText str) k = k IODataModeText str withIOData (IODataBinary lbs) k = k IODataModeBinary lbs -- | Test whether 'IOData' is empty null :: IOData -> Bool -null (IODataText s) = Prelude.null s +null (IODataText s) = Prelude.null s null (IODataBinary b) = LBS.null b instance NFData IOData where - rnf (IODataText s) = rnf s - rnf (IODataBinary lbs) = rnf lbs + rnf (IODataText s) = rnf s + rnf (IODataBinary lbs) = rnf lbs -- | @since 2.2 class NFData mode => KnownIODataMode mode where - -- | 'IOData' Wrapper for 'System.IO.hGetContents' - -- - -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all - -- data to be read and consequently the internal file handle to be - -- closed. - -- - hGetIODataContents :: System.IO.Handle -> Prelude.IO mode + -- | 'IOData' Wrapper for 'System.IO.hGetContents' + -- + -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all + -- data to be read and consequently the internal file handle to be + -- closed. + hGetIODataContents :: System.IO.Handle -> Prelude.IO mode - toIOData :: mode -> IOData - iodataMode :: IODataMode mode + toIOData :: mode -> IOData + iodataMode :: IODataMode mode --- | @since 3.2 +-- | Phantom-typed GADT representation of the mode of 'IOData', containing no +-- other data. +-- +-- @since 3.2 data IODataMode mode where - IODataModeText :: IODataMode String - IODataModeBinary :: IODataMode LBS.ByteString + IODataModeText :: IODataMode String + IODataModeBinary :: IODataMode LBS.ByteString instance a ~ Char => KnownIODataMode [a] where - hGetIODataContents h = do - System.IO.hSetBinaryMode h False - System.IO.hGetContents h + hGetIODataContents h = do + System.IO.hSetBinaryMode h False + System.IO.hGetContents h - toIOData = IODataText - iodataMode = IODataModeText + toIOData = IODataText + iodataMode = IODataModeText instance KnownIODataMode LBS.ByteString where - hGetIODataContents h = do - System.IO.hSetBinaryMode h True - LBS.hGetContents h + hGetIODataContents h = do + System.IO.hSetBinaryMode h True + LBS.hGetContents h - toIOData = IODataBinary - iodataMode = IODataModeBinary + toIOData = IODataBinary + iodataMode = IODataModeBinary -- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose' -- @@ -84,10 +88,10 @@ -- @since 2.2 hPutContents :: System.IO.Handle -> IOData -> Prelude.IO () hPutContents h (IODataText c) = do - System.IO.hSetBinaryMode h False - System.IO.hPutStr h c - System.IO.hClose h + System.IO.hSetBinaryMode h False + System.IO.hPutStr h c + System.IO.hClose h hPutContents h (IODataBinary c) = do - System.IO.hSetBinaryMode h True - LBS.hPutStr h c - System.IO.hClose h + System.IO.hSetBinaryMode h True + LBS.hPutStr h c + System.IO.hClose h diff --git a/src/Distribution/Utils/Json.hs b/src/Distribution/Utils/Json.hs --- a/src/Distribution/Utils/Json.hs +++ b/src/Distribution/Utils/Json.hs @@ -1,55 +1,60 @@ -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} --- | Extremely simple JSON helper. Don't do anything too fancy with this! +{-# LANGUAGE RankNTypes #-} +-- | Extremely simple JSON helper. Don't do anything too fancy with this! module Distribution.Utils.Json - ( Json(..) - , (.=) - , renderJson - ) where + ( Json (..) + , (.=) + , renderJson + ) where -import Distribution.Compat.Prelude -import qualified Data.ByteString.Lazy as LBS import Data.ByteString.Builder - ( Builder, stringUtf8, intDec, toLazyByteString ) + ( Builder + , intDec + , stringUtf8 + , toLazyByteString + ) +import qualified Data.ByteString.Lazy as LBS +import Distribution.Compat.Prelude -data Json = JsonArray [Json] - | JsonBool !Bool - | JsonNull - | JsonNumber !Int -- No support for Floats, Doubles just yet - | JsonObject [(String, Json)] - | JsonString !String - deriving Show +data Json + = JsonArray [Json] + | JsonBool !Bool + | JsonNull + | JsonNumber !Int -- No support for Floats, Doubles just yet + | JsonObject [(String, Json)] + | JsonString !String + deriving (Show) -- | Convert a 'Json' into a 'ByteString' renderJson :: Json -> LBS.ByteString renderJson json = toLazyByteString (go json) where - go (JsonArray objs) = + go (JsonArray objs) = surround "[" "]" $ mconcat $ intersperse "," $ map go objs - go (JsonBool True) = stringUtf8 "true" - go (JsonBool False) = stringUtf8 "false" - go JsonNull = stringUtf8 "null" - go (JsonNumber n) = intDec n + go (JsonBool True) = stringUtf8 "true" + go (JsonBool False) = stringUtf8 "false" + go JsonNull = stringUtf8 "null" + go (JsonNumber n) = intDec n go (JsonObject attrs) = surround "{" "}" $ mconcat $ intersperse "," $ map render attrs where - render (k,v) = (surround "\"" "\"" $ stringUtf8 (escape k)) <> ":" <> go v - go (JsonString s) = surround "\"" "\"" $ stringUtf8 (escape s) + render (k, v) = surround "\"" "\"" (stringUtf8 (escape k)) <> ":" <> go v + go (JsonString s) = surround "\"" "\"" $ stringUtf8 (escape s) surround :: Builder -> Builder -> Builder -> Builder -surround begin end middle = mconcat [ begin , middle , end] +surround begin end middle = mconcat [begin, middle, end] escape :: String -> String -escape ('\"':xs) = "\\\"" <> escape xs -escape ('\\':xs) = "\\\\" <> escape xs -escape ('\b':xs) = "\\b" <> escape xs -escape ('\f':xs) = "\\f" <> escape xs -escape ('\n':xs) = "\\n" <> escape xs -escape ('\r':xs) = "\\r" <> escape xs -escape ('\t':xs) = "\\t" <> escape xs -escape (x:xs) = x : escape xs -escape [] = mempty +escape ('\"' : xs) = "\\\"" <> escape xs +escape ('\\' : xs) = "\\\\" <> escape xs +escape ('\b' : xs) = "\\b" <> escape xs +escape ('\f' : xs) = "\\f" <> escape xs +escape ('\n' : xs) = "\\n" <> escape xs +escape ('\r' : xs) = "\\r" <> escape xs +escape ('\t' : xs) = "\\t" <> escape xs +escape (x : xs) = x : escape xs +escape [] = mempty -- | A shorthand for building up 'JsonObject's -- >>> JsonObject [ "a" .= JsonNumber 42, "b" .= JsonBool True ] 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,83 +1,85 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleContexts #-} -module Distribution.Utils.LogProgress ( - LogProgress, - runLogProgress, - warnProgress, - infoProgress, - dieProgress, - addProgressCtx, -) where -import Prelude () +module Distribution.Utils.LogProgress + ( LogProgress + , runLogProgress + , warnProgress + , infoProgress + , dieProgress + , addProgressCtx + ) where + import Distribution.Compat.Prelude +import Prelude () +import Distribution.Simple.Utils import Distribution.Utils.Progress import Distribution.Verbosity -import Distribution.Simple.Utils import Text.PrettyPrint type CtxMsg = Doc type LogMsg = Doc type ErrMsg = Doc -data LogEnv = LogEnv { - le_verbosity :: Verbosity, - le_context :: [CtxMsg] - } +data LogEnv = LogEnv + { le_verbosity :: Verbosity + , le_context :: [CtxMsg] + } -- | The 'Progress' monad with specialized logging and -- error messages. -newtype LogProgress a = LogProgress { unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a } +newtype LogProgress a = LogProgress {unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a} instance Functor LogProgress where - fmap f (LogProgress m) = LogProgress (fmap (fmap f) m) + fmap f (LogProgress m) = LogProgress (fmap (fmap f) m) instance Applicative LogProgress where - pure x = LogProgress (pure (pure x)) - LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r + pure x = LogProgress (pure (pure x)) + LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r instance Monad LogProgress where - return = pure - LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r + return = pure + LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r -- | Run 'LogProgress', outputting traces according to 'Verbosity', -- 'die' if there is an error. runLogProgress :: Verbosity -> LogProgress a -> IO a runLogProgress verbosity (LogProgress m) = - foldProgress step_fn fail_fn return (m env) + foldProgress step_fn fail_fn return (m env) where - env = LogEnv { - le_verbosity = verbosity, - le_context = [] - } + env = + LogEnv + { le_verbosity = verbosity + , le_context = [] + } step_fn :: LogMsg -> IO a -> IO a step_fn doc go = do - putStrLn (render doc) - go + putStrLn (render doc) + go fail_fn :: Doc -> IO a fail_fn doc = do - dieNoWrap verbosity (render doc) + dieNoWrap verbosity (render doc) -- | Output a warning trace message in 'LogProgress'. warnProgress :: Doc -> LogProgress () warnProgress s = LogProgress $ \env -> - when (le_verbosity env >= normal) $ - stepProgress $ - hang (text "Warning:") 4 (formatMsg (le_context env) s) + when (le_verbosity env >= normal) $ + stepProgress $ + hang (text "Warning:") 4 (formatMsg (le_context env) s) -- | Output an informational trace message in 'LogProgress'. infoProgress :: Doc -> LogProgress () infoProgress s = LogProgress $ \env -> - when (le_verbosity env >= verbose) $ - stepProgress s + when (le_verbosity env >= verbose) $ + stepProgress s -- | Fail the computation with an error message. dieProgress :: Doc -> LogProgress a dieProgress s = LogProgress $ \env -> - failProgress $ - hang (text "Error:") 4 (formatMsg (le_context env) s) + failProgress $ + hang (text "Error:") 4 (formatMsg (le_context env) s) -- | Format a message with context. (Something simple for now.) formatMsg :: [CtxMsg] -> Doc -> Doc @@ -86,4 +88,4 @@ -- | Add a message to the error/warning context. addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a addProgressCtx s (LogProgress m) = LogProgress $ \env -> - m env { le_context = s : le_context env } + m env{le_context = s : le_context env} 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,22 +1,28 @@ {-# LANGUAGE CPP #-} + module Distribution.Utils.MapAccum (mapAccumM) where import Distribution.Compat.Prelude import Prelude () -- Like StateT but with return tuple swapped -newtype StateM s m a = StateM { runStateM :: s -> m (s, a) } +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 (\(s', a) -> (s', f a)) (x s) instance Monad m => Applicative (StateM s m) where - pure x = StateM $ \s -> return (s, x) - StateM f <*> StateM x = StateM $ \s -> do (s', f') <- f s - (s'', x') <- x s' - return (s'', f' x') + pure x = StateM $ \s -> return (s, x) + StateM f <*> StateM x = StateM $ \s -> do + (s', f') <- f s + (s'', x') <- x s' + return (s'', f' x') -- | Monadic variant of 'mapAccumL'. -mapAccumM :: (Monad m, Traversable t) - => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c) +mapAccumM + :: (Monad m, Traversable t) + => (a -> b -> m (a, c)) + -> a + -> t b + -> m (a, t c) mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' 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 @@ -1,17 +1,17 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Utils.NubList - ( NubList -- opaque - , toNubList -- smart constructor - , fromNubList - , overNubList - , NubListR - , toNubListR - , fromNubListR - , overNubListR - ) where +module Distribution.Utils.NubList + ( NubList -- opaque + , toNubList -- smart constructor + , fromNubList + , overNubList + , NubListR + , toNubListR + , fromNubListR + , overNubListR + ) where import Distribution.Compat.Prelude import Prelude () @@ -21,9 +21,8 @@ import qualified Text.Read as R -- | NubList : A de-duplicated list that maintains the original order. -newtype NubList a = - NubList { fromNubList :: [a] } - deriving (Eq, Generic, Typeable) +newtype NubList a = NubList {fromNubList :: [a]} + deriving (Eq, Generic, Typeable) -- NubList assumes that nub retains the list order while removing duplicate -- elements (keeping the first occurrence). Documentation for "Data.List.nub" @@ -51,30 +50,29 @@ -- -- Closure : appending two lists of type a and removing duplicates obviously -- does not change the type. - instance Ord a => Monoid (NubList a) where - mempty = NubList [] - mappend = (<>) + mempty = NubList [] + mappend = (<>) instance Ord a => Semigroup (NubList a) where - (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys + (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys instance Show a => Show (NubList a) where - show (NubList list) = show list + show (NubList list) = show list instance (Ord a, Read a) => Read (NubList a) where - readPrec = readNubList toNubList + readPrec = readNubList toNubList -- | Helper used by NubList/NubListR's Read instances. -readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a) +readNubList :: Read a => ([a] -> l a) -> R.ReadPrec (l a) readNubList listToL = R.parens . R.prec 10 $ fmap listToL R.readPrec -- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we -- just pull off constructor and put the list. For 'get', we get the list and -- make a 'NubList' out of it using 'toNubList'. instance (Ord a, Binary a) => Binary (NubList a) where - put (NubList l) = put l - get = fmap toNubList get + put (NubList l) = put l + get = fmap toNubList get instance Structured a => Structured (NubList a) @@ -82,9 +80,8 @@ -- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@, -- unlike the normal 'NubList', which is left-biased. Built on top of -- 'ordNubRight' and 'listUnionRight'. -newtype NubListR a = - NubListR { fromNubListR :: [a] } - deriving Eq +newtype NubListR a = NubListR {fromNubListR :: [a]} + deriving (Eq) -- | Smart constructor for the NubListR type. toNubListR :: Ord a => [a] -> NubListR a @@ -105,4 +102,4 @@ show (NubListR list) = show list instance (Ord a, Read a) => Read (NubListR a) where - readPrec = readNubList toNubListR + readPrec = readNubList toNubListR 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 @@ -1,22 +1,22 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} + -- Note: This module was copied from cabal-install. -- | A progress monad, which we use to report failure and logging from -- otherwise pure code. module Distribution.Utils.Progress - ( Progress - , stepProgress - , failProgress - , foldProgress - ) where + ( Progress + , stepProgress + , failProgress + , foldProgress + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import qualified Data.Monoid as Mon - -- | A type to represent the unfolding of an expensive long running -- calculation that may fail (or maybe not expensive, but complicated!) -- We may get intermediate steps before the final @@ -25,14 +25,13 @@ -- TODO: Apply Codensity to avoid left-associativity problem. -- See http://comonad.com/reader/2011/free-monads-for-less/ and -- http://blog.ezyang.com/2012/01/problem-set-the-codensity-transformation/ --- -data Progress step fail done = Step step (Progress step fail done) - | Fail fail - | Done done +data Progress step fail done + = Step step (Progress step fail done) + | Fail fail + | Done done deriving (Functor) -- | Emit a step and then continue. --- stepProgress :: step -> Progress step fail () stepProgress step = Step step (Done ()) @@ -46,22 +45,26 @@ -- Eg to convert into a simple 'Either' result use: -- -- > foldProgress (flip const) Left Right --- -foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) - -> Progress step fail done -> a +foldProgress + :: (step -> a -> a) + -> (fail -> a) + -> (done -> a) + -> Progress step fail done + -> a foldProgress step err done = fold - where fold (Step s p) = step s (fold p) - fold (Fail f) = err f - fold (Done r) = done r + where + fold (Step s p) = step s (fold p) + fold (Fail f) = err f + fold (Done r) = done r instance Monad (Progress step fail) where - return = pure - p >>= f = foldProgress Step Fail f p + return = pure + p >>= f = foldProgress Step Fail f p instance Applicative (Progress step fail) where - pure a = Done a + pure a = Done a p <*> x = foldProgress Step Fail (flip fmap x) p instance Monoid fail => Alternative (Progress step fail) where - empty = Fail Mon.mempty + empty = Fail Mon.mempty p <|> q = foldProgress Step (const q) Done p 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,27 +1,27 @@ {-# LANGUAGE NondecreasingIndentation #-} + -- | A simple mutable union-find data structure. -- -- It is used in a unification algorithm for backpack mix-in linking. -- -- This implementation is based off of the one in \"The Essence of ML Type -- Inference\". (N.B. the union-find package is also based off of this.) --- -module Distribution.Utils.UnionFind ( - Point, - fresh, - find, - union, - equivalent, -) where +module Distribution.Utils.UnionFind + ( Point + , fresh + , find + , union + , equivalent + ) where -import Data.STRef import Control.Monad import Control.Monad.ST +import Data.STRef -- | A variable which can be unified; alternately, this can be thought -- of as an equivalence class with a distinguished representative. newtype Point s a = Point (STRef s (Link s a)) - deriving (Eq) + deriving (Eq) -- | Mutable write to a 'Point' writePoint :: Point s a -> Link s a -> ST s () @@ -35,39 +35,41 @@ -- the representative element of an equivalence class, or a link to -- the 'Point' that actually stores the representative type. data Link s a - -- NB: it is too bad we can't say STRef Int#; the weights remain boxed - = Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a) - | Link {-# UNPACK #-} !(Point s a) + = -- NB: it is too bad we can't say STRef Int#; the weights remain boxed + Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a) + | Link {-# UNPACK #-} !(Point s a) -- | Create a fresh equivalence class with one element. fresh :: a -> ST s (Point s a) fresh desc = do - weight <- newSTRef 1 - descriptor <- newSTRef desc - Point `fmap` newSTRef (Info weight descriptor) + weight <- newSTRef 1 + descriptor <- newSTRef desc + Point `fmap` newSTRef (Info weight descriptor) -- | Flatten any chains of links, returning a 'Point' -- 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 +repr point = + readPoint point >>= \r -> + case r of + Link point' -> do point'' <- repr point' when (point'' /= point') $ do - writePoint point =<< readPoint point' + writePoint point =<< readPoint point' return point'' - Info _ _ -> return point + Info _ _ -> return point -- | Return the canonical element of an equivalence -- class 'Point'. find :: Point s a -> ST s a 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' -> + -- 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 @@ -76,26 +78,26 @@ -- a canonical element. Keeps the descriptor of point2. union :: Point s a -> Point s a -> ST s () union refpoint1 refpoint2 = do - point1 <- repr refpoint1 - point2 <- repr refpoint2 - when (point1 /= point2) $ do + point1 <- repr refpoint1 + point2 <- repr refpoint2 + when (point1 /= point2) $ do l1 <- readPoint point1 l2 <- readPoint point2 case (l1, l2) of - (Info wref1 dref1, Info wref2 dref2) -> do - weight1 <- readSTRef wref1 - weight2 <- readSTRef wref2 - -- Should be able to optimize the == case separately - if weight1 >= weight2 - then do - writePoint point2 (Link point1) - -- The weight calculation here seems a bit dodgy - writeSTRef wref1 (weight1 + weight2) - writeSTRef dref1 =<< readSTRef dref2 - else do - writePoint point1 (Link point2) - writeSTRef wref2 (weight1 + weight2) - _ -> error "UnionFind.union: repr invariant broken" + (Info wref1 dref1, Info wref2 dref2) -> do + weight1 <- readSTRef wref1 + weight2 <- readSTRef wref2 + -- Should be able to optimize the == case separately + if weight1 >= weight2 + then do + writePoint point2 (Link point1) + -- The weight calculation here seems a bit dodgy + writeSTRef wref1 (weight1 + weight2) + writeSTRef dref1 =<< readSTRef dref2 + else do + writePoint point1 (Link point2) + writeSTRef wref2 (weight1 + weight2) + _ -> error "UnionFind.union: repr invariant broken" -- | Test if two points are in the same equivalence class. equivalent :: Point s a -> Point s a -> ST s Bool diff --git a/src/Distribution/Verbosity.hs b/src/Distribution/Verbosity.hs --- a/src/Distribution/Verbosity.hs +++ b/src/Distribution/Verbosity.hs @@ -2,6 +2,9 @@ {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- + +-- Verbosity for Cabal functions. + -- | -- Module : Distribution.Verbosity -- Copyright : Ian Lynagh 2007 @@ -21,79 +24,92 @@ -- settings (e.g., so that you can trace only particular things you -- are interested in.) It's important to note that the instances -- for 'Verbosity' assume that this does not exist. - --- Verbosity for Cabal functions. - -module Distribution.Verbosity ( - -- * Verbosity - Verbosity, - silent, normal, verbose, deafening, - moreVerbose, lessVerbose, isVerboseQuiet, - intToVerbosity, flagToVerbosity, - showForCabal, showForGHC, - verboseNoFlags, verboseHasFlags, - modifyVerbosity, +module Distribution.Verbosity + ( -- * Verbosity + Verbosity + , silent + , normal + , verbose + , deafening + , moreVerbose + , lessVerbose + , isVerboseQuiet + , intToVerbosity + , flagToVerbosity + , showForCabal + , showForGHC + , verboseNoFlags + , verboseHasFlags + , modifyVerbosity - -- * Call stacks - verboseCallSite, verboseCallStack, - isVerboseCallSite, isVerboseCallStack, + -- * Call stacks + , verboseCallSite + , verboseCallStack + , isVerboseCallSite + , isVerboseCallStack - -- * Output markets - verboseMarkOutput, isVerboseMarkOutput, - verboseUnmarkOutput, + -- * Output markets + , verboseMarkOutput + , isVerboseMarkOutput + , verboseUnmarkOutput - -- * Line wrapping - verboseNoWrap, isVerboseNoWrap, + -- * Line wrapping + , verboseNoWrap + , isVerboseNoWrap - -- * Time stamps - verboseTimestamp, isVerboseTimestamp, - verboseNoTimestamp, + -- * Time stamps + , verboseTimestamp + , isVerboseTimestamp + , verboseNoTimestamp - -- * Stderr - verboseStderr, isVerboseStderr, - verboseNoStderr, + -- * Stderr + , verboseStderr + , isVerboseStderr + , verboseNoStderr - -- * No warnings - verboseNoWarn, isVerboseNoWarn + -- * No warnings + , verboseNoWarn + , isVerboseNoWarn ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.ReadE import Data.List (elemIndex) import Distribution.Parsec import Distribution.Pretty -import Distribution.Verbosity.Internal import Distribution.Utils.Generic (isAsciiAlpha) +import Distribution.Verbosity.Internal import qualified Data.Set as Set import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as PP -data Verbosity = Verbosity { - vLevel :: VerbosityLevel, - vFlags :: Set VerbosityFlag, - vQuiet :: Bool - } deriving (Generic, Show, Read, Typeable) +data Verbosity = Verbosity + { vLevel :: VerbosityLevel + , vFlags :: Set VerbosityFlag + , vQuiet :: Bool + } + deriving (Generic, Show, Read, Typeable) mkVerbosity :: VerbosityLevel -> Verbosity -mkVerbosity l = Verbosity { vLevel = l, vFlags = Set.empty, vQuiet = False } +mkVerbosity l = Verbosity{vLevel = l, vFlags = Set.empty, vQuiet = False} instance Eq Verbosity where - x == y = vLevel x == vLevel y + x == y = vLevel x == vLevel y instance Ord Verbosity where - compare x y = compare (vLevel x) (vLevel y) + compare x y = compare (vLevel x) (vLevel y) instance Enum Verbosity where - toEnum = mkVerbosity . toEnum - fromEnum = fromEnum . vLevel + toEnum = mkVerbosity . toEnum + fromEnum = fromEnum . vLevel instance Bounded Verbosity where - minBound = mkVerbosity minBound - maxBound = mkVerbosity maxBound + minBound = mkVerbosity minBound + maxBound = mkVerbosity maxBound instance Binary Verbosity instance Structured Verbosity @@ -118,21 +134,21 @@ -- | Increase verbosity level, but stay 'silent' if we are. moreVerbose :: Verbosity -> Verbosity moreVerbose v = - case vLevel v of - Silent -> v -- silent should stay silent - Normal -> v { vLevel = Verbose } - Verbose -> v { vLevel = Deafening } - Deafening -> v + case vLevel v of + Silent -> v -- silent should stay silent + Normal -> v{vLevel = Verbose} + Verbose -> v{vLevel = Deafening} + Deafening -> v -- | Decrease verbosity level, but stay 'deafening' if we are. lessVerbose :: Verbosity -> Verbosity lessVerbose v = - verboseQuiet $ + verboseQuiet $ case vLevel v of - Deafening -> v -- deafening stays deafening - Verbose -> v { vLevel = Normal } - Normal -> v { vLevel = Silent } - Silent -> v + Deafening -> v -- deafening stays deafening + Verbose -> v{vLevel = Normal} + Normal -> v{vLevel = Silent} + Silent -> v -- | Combinator for transforming verbosity level while retaining the -- original hidden state. @@ -146,7 +162,7 @@ -- -- @since 2.0.1.0 modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity -modifyVerbosity f v = v { vLevel = vLevel (f v) } +modifyVerbosity f v = v{vLevel = vLevel (f v)} -- | Numeric verbosity level @0..3@: @0@ is 'silent', @3@ is 'deafening'. intToVerbosity :: Int -> Maybe Verbosity @@ -177,81 +193,82 @@ -- Right (Verbosity {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False}) -- -- /Note:/ this parser will eat trailing spaces. --- instance Parsec Verbosity where - parsec = parsecVerbosity + parsec = parsecVerbosity instance Pretty Verbosity where - pretty = PP.text . showForCabal + pretty = PP.text . showForCabal parsecVerbosity :: CabalParsing m => m Verbosity parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity where parseIntVerbosity = do - i <- P.integral - case intToVerbosity i of - Just v -> return v - Nothing -> P.unexpected $ "Bad integral verbosity: " ++ show i ++ ". Valid values are 0..3" + i <- P.integral + case intToVerbosity i of + Just v -> return v + Nothing -> P.unexpected $ "Bad integral verbosity: " ++ show i ++ ". Valid values are 0..3" parseStringVerbosity = do - level <- parseVerbosityLevel - _ <- P.spaces - flags <- many (parseFlag <* P.spaces) - return $ foldl' (flip ($)) (mkVerbosity level) flags + level <- parseVerbosityLevel + _ <- P.spaces + flags <- many (parseFlag <* P.spaces) + return $ foldl' (flip ($)) (mkVerbosity level) flags parseVerbosityLevel = do - token <- P.munch1 isAsciiAlpha - case token of - "silent" -> return Silent - "normal" -> return Normal - "verbose" -> return Verbose - "debug" -> return Deafening - "deafening" -> return Deafening - _ -> P.unexpected $ "Bad verbosity level: " ++ token + token <- P.munch1 isAsciiAlpha + case token of + "silent" -> return Silent + "normal" -> return Normal + "verbose" -> return Verbose + "debug" -> return Deafening + "deafening" -> return Deafening + _ -> P.unexpected $ "Bad verbosity level: " ++ token parseFlag = do - _ <- P.char '+' - token <- P.munch1 isAsciiAlpha - case token of - "callsite" -> return verboseCallSite - "callstack" -> return verboseCallStack - "nowrap" -> return verboseNoWrap - "markoutput" -> return verboseMarkOutput - "timestamp" -> return verboseTimestamp - "stderr" -> return verboseStderr - "stdout" -> return verboseNoStderr - "nowarn" -> return verboseNoWarn - _ -> P.unexpected $ "Bad verbosity flag: " ++ token + _ <- P.char '+' + token <- P.munch1 isAsciiAlpha + case token of + "callsite" -> return verboseCallSite + "callstack" -> return verboseCallStack + "nowrap" -> return verboseNoWrap + "markoutput" -> return verboseMarkOutput + "timestamp" -> return verboseTimestamp + "stderr" -> return verboseStderr + "stdout" -> return verboseNoStderr + "nowarn" -> return verboseNoWarn + _ -> P.unexpected $ "Bad verbosity flag: " ++ token flagToVerbosity :: ReadE Verbosity flagToVerbosity = parsecToReadE id parsecVerbosity showForCabal :: Verbosity -> String showForCabal v - | Set.null (vFlags v) - = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,verbose,deafening] - | otherwise - = unwords - $ showLevel (vLevel v) - : concatMap showFlag (Set.toList (vFlags v)) + | Set.null (vFlags v) = + maybe (error "unknown verbosity") show $ + elemIndex v [silent, normal, verbose, deafening] + | otherwise = + unwords $ + showLevel (vLevel v) + : concatMap showFlag (Set.toList (vFlags v)) where - showLevel Silent = "silent" - showLevel Normal = "normal" - showLevel Verbose = "verbose" + showLevel Silent = "silent" + showLevel Normal = "normal" + showLevel Verbose = "verbose" showLevel Deafening = "debug" - showFlag VCallSite = ["+callsite"] - showFlag VCallStack = ["+callstack"] - showFlag VNoWrap = ["+nowrap"] + showFlag VCallSite = ["+callsite"] + showFlag VCallStack = ["+callstack"] + showFlag VNoWrap = ["+nowrap"] showFlag VMarkOutput = ["+markoutput"] - showFlag VTimestamp = ["+timestamp"] - showFlag VStderr = ["+stderr"] - showFlag VNoWarn = ["+nowarn"] + showFlag VTimestamp = ["+timestamp"] + showFlag VStderr = ["+stderr"] + showFlag VNoWarn = ["+nowarn"] showForGHC :: Verbosity -> String -showForGHC v = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,__,verbose,deafening] - where __ = silent -- this will be always ignored by elemIndex +showForGHC v = + maybe (error "unknown verbosity") show $ + elemIndex v [silent, normal, __, verbose, deafening] + where + __ = silent -- this will be always ignored by elemIndex -- | Turn on verbose call-site printing when we log. verboseCallSite :: Verbosity -> Verbosity @@ -276,7 +293,7 @@ -- | Mark the verbosity as quiet. verboseQuiet :: Verbosity -> Verbosity -verboseQuiet v = v { vQuiet = True } +verboseQuiet v = v{vQuiet = True} -- | Turn on timestamps for log messages. verboseTimestamp :: Verbosity -> Verbosity @@ -304,15 +321,15 @@ -- | Helper function for flag enabling functions. verboseFlag :: VerbosityFlag -> (Verbosity -> Verbosity) -verboseFlag flag v = v { vFlags = Set.insert flag (vFlags v) } +verboseFlag flag v = v{vFlags = Set.insert flag (vFlags v)} -- | Helper function for flag disabling functions. verboseNoFlag :: VerbosityFlag -> (Verbosity -> Verbosity) -verboseNoFlag flag v = v { vFlags = Set.delete flag (vFlags v) } +verboseNoFlag flag v = v{vFlags = Set.delete flag (vFlags v)} -- | Turn off all flags. verboseNoFlags :: Verbosity -> Verbosity -verboseNoFlags v = v { vFlags = Set.empty } +verboseNoFlags v = v{vFlags = Set.empty} verboseHasFlags :: Verbosity -> Bool verboseHasFlags = not . Set.null . vFlags 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 @@ -1,28 +1,30 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} + module Distribution.Verbosity.Internal - ( VerbosityLevel(..) - , VerbosityFlag(..) + ( VerbosityLevel (..) + , VerbosityFlag (..) ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () data VerbosityLevel = Silent | Normal | Verbose | Deafening - deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) instance Binary VerbosityLevel instance Structured VerbosityLevel data VerbosityFlag - = VCallStack - | VCallSite - | VNoWrap - | VMarkOutput - | VTimestamp - | VStderr -- ^ @since 3.4.0.0 - | VNoWarn - deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) + = VCallStack + | VCallSite + | VNoWrap + | VMarkOutput + | VTimestamp + | -- | @since 3.4.0.0 + VStderr + | VNoWarn + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) instance Binary 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,40 +1,41 @@ -- | A small prelude used in @zinza@ generated -- template modules. -module Distribution.ZinzaPrelude ( - Writer, - execWriter, - tell, +module Distribution.ZinzaPrelude + ( Writer + , execWriter + , tell + -- * Re-exports - forM_, - Generic, - PackageName, - Version, - prettyShow - ) where + , forM_ + , Generic + , PackageName + , Version + , prettyShow + ) where import Distribution.Compat.Prelude import Prelude () -import Control.Monad (forM_) -import Distribution.Pretty (prettyShow) +import Control.Monad (forM_) +import Distribution.Pretty (prettyShow) import Distribution.Types.PackageName (PackageName) -import Distribution.Types.Version (Version) +import Distribution.Types.Version (Version) -newtype Writer a = W { unW :: ShowS -> (ShowS, a) } +newtype Writer a = W {unW :: ShowS -> (ShowS, a)} instance Functor Writer where - fmap = liftM + fmap = liftM instance Applicative Writer where - pure x = W $ \ss -> (ss, x) - (<*>) = ap + pure x = W $ \ss -> (ss, x) + (<*>) = ap instance Monad Writer where - return = pure - m >>= k = W $ \s1 -> - let (s2, x) = unW m s1 - in unW (k x) s2 - {-# INLINE (>>=) #-} + return = pure + m >>= k = W $ \s1 -> + let (s2, x) = unW m s1 + in unW (k x) s2 + {-# INLINE (>>=) #-} execWriter :: Writer a -> String execWriter w = fst (unW w id) ""