From 3e3d337247365e7e9e2c17b28c904b8a0f06eabf Mon Sep 17 00:00:00 2001 From: theophilebatoz Date: Wed, 15 Nov 2023 22:44:56 +0000 Subject: [PATCH 01/18] feat: add library set in deptype --- src/Stack/Component.hs | 6 +---- src/Stack/Types/Component.hs | 14 +----------- src/Stack/Types/ComponentUtils.hs | 38 +++++++++++++++++++++++++++++++ src/Stack/Types/Dependency.hs | 28 ++++++++++++++++++----- stack.cabal | 1 + 5 files changed, 63 insertions(+), 24 deletions(-) create mode 100644 src/Stack/Types/ComponentUtils.hs diff --git a/src/Stack/Component.hs b/src/Stack/Component.hs index 7ec14eacc7..73919829da 100644 --- a/src/Stack/Component.hs +++ b/src/Stack/Component.hs @@ -35,7 +35,6 @@ import Distribution.PackageDescription , TestSuite (..) ) import Distribution.Types.BuildInfo ( BuildInfo ) -import Distribution.Types.UnqualComponentName ( UnqualComponentName ) import Distribution.Package ( mkPackageName ) import qualified Distribution.PackageDescription as Cabal import GHC.Records ( HasField ) @@ -46,14 +45,11 @@ import Stack.Types.Component , StackLibrary (..), StackTestSuite (..) , StackUnqualCompName (..) ) +import Stack.Types.ComponentUtils ( fromCabalName ) import Stack.Types.Dependency ( DepValue, cabalExeToStackDep, cabalToStackDep ) import Stack.Types.NamedComponent ( NamedComponent ) -fromCabalName :: UnqualComponentName -> StackUnqualCompName -fromCabalName unqualName = - StackUnqualCompName $ pack . Cabal.unUnqualComponentName $ unqualName - stackUnqualToQual :: (Text -> NamedComponent) -> StackUnqualCompName diff --git a/src/Stack/Types/Component.hs b/src/Stack/Types/Component.hs index e99527470d..de3ac598a7 100644 --- a/src/Stack/Types/Component.hs +++ b/src/Stack/Types/Component.hs @@ -32,6 +32,7 @@ import Distribution.Utils.Path ( PackageDir, SourceDir, SymbolicPath ) import GHC.Records ( HasField ) import Stack.Prelude import Stack.Types.Dependency ( DepValue ) +import Stack.Types.ComponentUtils ( StackUnqualCompName(..) ) -- | A type representing (unnamed) main library or sub-library components of a -- package. @@ -99,19 +100,6 @@ data StackBenchmark = StackBenchmark newtype ExeName = ExeName Text deriving (Data, Eq, Hashable, IsString, Generic, NFData, Ord, Show, Typeable) --- | Type representing the name of an \'unqualified\' component (that is, the --- component can be any sort - a (unnamed) main library or sub-library, --- an executable, etc. ). --- --- The corresponding The Cabal-syntax type is --- 'Distribution.Types.UnqualComponentName.UnqualComponentName'. - --- Ideally, we would use the Cabal-syntax type and not 'Text', to avoid --- unnecessary work, but there is no 'Hashable' instance for --- 'Distribution.Types.UnqualComponentName.UnqualComponentName' yet. -newtype StackUnqualCompName = StackUnqualCompName {unqualCompToText :: Text} - deriving (Data, Eq, Hashable, IsString, Generic, NFData, Ord, Show, Typeable) - -- | Type representing information needed to build. The file gathering-related -- fields are lazy because they are not always needed. -- diff --git a/src/Stack/Types/ComponentUtils.hs b/src/Stack/Types/ComponentUtils.hs new file mode 100644 index 0000000000..914eaa4f3e --- /dev/null +++ b/src/Stack/Types/ComponentUtils.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | A module providing the types that represent different sorts of components +-- of a package (library and sub-library, foreign library, executable, test +-- suite and benchmark). +module Stack.Types.ComponentUtils + ( StackUnqualCompName (..) + , fromCabalName + ) where + +import Distribution.PackageDescription (UnqualComponentName, unUnqualComponentName) +import Stack.Prelude +import RIO.Text (pack) + +-- | Type representing the name of an \'unqualified\' component (that is, the +-- component can be any sort - a (unnamed) main library or sub-library, +-- an executable, etc. ). +-- +-- The corresponding The Cabal-syntax type is +-- 'Distribution.Types.UnqualComponentName.UnqualComponentName'. + +-- Ideally, we would use the Cabal-syntax type and not 'Text', to avoid +-- unnecessary work, but there is no 'Hashable' instance for +-- 'Distribution.Types.UnqualComponentName.UnqualComponentName' yet. +newtype StackUnqualCompName = StackUnqualCompName {unqualCompToText :: Text} + deriving (Data, Eq, Hashable, IsString, Generic, NFData, Ord, Show, Typeable, Read) + +fromCabalName :: UnqualComponentName -> StackUnqualCompName +fromCabalName unqualName = + StackUnqualCompName $ pack . unUnqualComponentName $ unqualName \ No newline at end of file diff --git a/src/Stack/Types/Dependency.hs b/src/Stack/Types/Dependency.hs index 6de2601d94..3cbeaefcd3 100644 --- a/src/Stack/Types/Dependency.hs +++ b/src/Stack/Types/Dependency.hs @@ -12,9 +12,12 @@ module Stack.Types.Dependency import Data.Foldable ( foldr' ) import qualified Data.Map as Map +import qualified Distribution.Compat.NonEmptySet as NES import qualified Distribution.PackageDescription as Cabal import Distribution.Types.VersionRange ( VersionRange ) import Stack.Prelude +import Stack.Types.ComponentUtils ( StackUnqualCompName(..), fromCabalName ) +import qualified Data.Set as Set -- | The value for a map from dependency name. This contains both the version -- range and the type of dependency. @@ -28,18 +31,31 @@ data DepValue = DepValue -- former, we need to ensure that a library actually exists. See -- data DepType - = AsLibrary + = AsLibrary !DepLibrary | AsBuildTool deriving (Eq, Show) +data DepLibrary = DepLibrary + { dlMain :: !Bool + , dlSublib :: Set StackUnqualCompName + } + deriving (Eq, Show) + +defaultDepLibrary :: DepLibrary +defaultDepLibrary = DepLibrary True mempty isDepTypeLibrary :: DepType -> Bool -isDepTypeLibrary AsLibrary = True +isDepTypeLibrary AsLibrary{} = True isDepTypeLibrary AsBuildTool = False cabalToStackDep :: Cabal.Dependency -> DepValue -cabalToStackDep (Cabal.Dependency _ verRange _libNameSet) = - DepValue{dvVersionRange = verRange, dvType = AsLibrary} - +cabalToStackDep (Cabal.Dependency _ verRange libNameSet) = + DepValue{dvVersionRange = verRange, dvType = AsLibrary depLibrary} + where + depLibrary = DepLibrary finalHasMain filteredItems + (finalHasMain, filteredItems) = foldr' iterator (False, mempty) libNameSet + iterator LMainLibName (_, newLibNameSet) = (True, newLibNameSet) + iterator (LSubLibName libName) (hasMain, newLibNameSet) = (hasMain, Set.insert (fromCabalName libName) newLibNameSet) + cabalExeToStackDep :: Cabal.ExeDependency -> DepValue cabalExeToStackDep (Cabal.ExeDependency _ _name verRange) = DepValue{dvVersionRange = verRange, dvType = AsBuildTool} @@ -54,5 +70,5 @@ cabalSetupDepsToStackDep setupInfo = libraryDepFromVersionRange :: VersionRange -> DepValue libraryDepFromVersionRange range = DepValue { dvVersionRange = range - , dvType = AsLibrary + , dvType = AsLibrary defaultDepLibrary } diff --git a/stack.cabal b/stack.cabal index e0c762b027..ef567c5107 100644 --- a/stack.cabal +++ b/stack.cabal @@ -330,6 +330,7 @@ library other-modules: GHC.Utils.GhcPkg.Main.Compat Stack.Config.ConfigureScript + Stack.Types.ComponentUtils Stack.Types.FileDigestCache autogen-modules: Build_stack From 56b12980673312000c2226ee3f7cd257b598c397 Mon Sep 17 00:00:00 2001 From: theophilebatoz Date: Thu, 16 Nov 2023 21:48:09 +0000 Subject: [PATCH 02/18] test: activate sublibrary test --- src/Stack/Build.hs | 4 ++-- tests/integration/tests/cabal-sublibrary-dependency/Main.hs | 6 +----- 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index dc7338f50f..2492ccd722 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -19,8 +19,8 @@ import Data.List.Extra ( groupSort ) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T -import qualified Distribution.PackageDescription as C -import Distribution.Types.Dependency ( Dependency (..), depLibraries ) +-- import qualified Distribution.PackageDescription as C +-- import Distribution.Types.Dependency ( Dependency (..), depLibraries ) import Distribution.Version ( mkVersion ) import RIO.NonEmpty ( nonEmpty ) import qualified RIO.NonEmpty as NE diff --git a/tests/integration/tests/cabal-sublibrary-dependency/Main.hs b/tests/integration/tests/cabal-sublibrary-dependency/Main.hs index b1b1166fb6..e0d04957b8 100644 --- a/tests/integration/tests/cabal-sublibrary-dependency/Main.hs +++ b/tests/integration/tests/cabal-sublibrary-dependency/Main.hs @@ -10,8 +10,4 @@ main :: IO () -- The '--install-ghc' flag is passed here, because IntegrationSpec.runApp sets -- up `config.yaml` with `system-ghc: true` and `install-ghc: false`. -- (See stack.yaml; using GHC 9.4.7.) -main = stackErrStderr ["--install-ghc", "build"] $ \str -> - let msg = "Sublibrary dependency is not supported, this will almost \ - \certainly fail." - in unless (msg `isInfixOf` str) $ - error $ "Expected a warning: \n" ++ show msg +main = stack ["build", "--install-ghc"] From 7142a09d8068f1b3593df50705febfc4f4153022 Mon Sep 17 00:00:00 2001 From: theophilebatoz Date: Thu, 16 Nov 2023 21:48:49 +0000 Subject: [PATCH 03/18] fix: comment sublibrary error check --- src/Stack/Build.hs | 54 +++++++++++++++++++++++----------------------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 2492ccd722..65bb498c95 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -138,7 +138,7 @@ build msetLocalFiles = do depsLocals <- localDependencies let allLocals = locals <> depsLocals - checkSubLibraryDependencies (Map.elems $ smProject sourceMap) + -- checkSubLibraryDependencies (Map.elems $ smProject sourceMap) boptsCli <- view $ envConfigL.to envConfigBuildOptsCLI -- Set local files, necessary for file watching @@ -374,31 +374,31 @@ checkComponentsBuildable lps = -- | Find if any sub-library dependency (other than internal libraries) exists -- in each project package. -checkSubLibraryDependencies :: HasTerm env => [ProjectPackage] -> RIO env () -checkSubLibraryDependencies projectPackages = - forM_ projectPackages $ \projectPackage -> do - C.GenericPackageDescription pkgDesc _ _ lib subLibs foreignLibs exes tests benches <- - liftIO $ cpGPD . ppCommon $ projectPackage +-- checkSubLibraryDependencies :: HasTerm env => [ProjectPackage] -> RIO env () +-- checkSubLibraryDependencies projectPackages = +-- forM_ projectPackages $ \projectPackage -> do +-- C.GenericPackageDescription pkgDesc _ _ lib subLibs foreignLibs exes tests benches <- +-- liftIO $ cpGPD . ppCommon $ projectPackage - let pName = pkgName . C.package $ pkgDesc - dependencies = concatMap getDeps subLibs <> - concatMap getDeps foreignLibs <> - concatMap getDeps exes <> - concatMap getDeps tests <> - concatMap getDeps benches <> - maybe [] C.condTreeConstraints lib - notInternal (Dependency pName' _ _) = pName' /= pName - publicDependencies = filter notInternal dependencies - publicLibraries = concatMap (toList . depLibraries) publicDependencies +-- let pName = pkgName . C.package $ pkgDesc +-- dependencies = concatMap getDeps subLibs <> +-- concatMap getDeps foreignLibs <> +-- concatMap getDeps exes <> +-- concatMap getDeps tests <> +-- concatMap getDeps benches <> +-- maybe [] C.condTreeConstraints lib +-- notInternal (Dependency pName' _ _) = pName' /= pName +-- publicDependencies = filter notInternal dependencies +-- publicLibraries = concatMap (toList . depLibraries) publicDependencies - when (subLibDepExist publicLibraries) $ - prettyWarnS - "Sublibrary dependency is not supported, this will almost certainly \ - \fail." - where - getDeps (_, C.CondNode _ dep _) = dep - subLibDepExist = any - ( \case - C.LSubLibName _ -> True - C.LMainLibName -> False - ) +-- when (subLibDepExist publicLibraries) $ +-- prettyWarnS +-- "Sublibrary dependency is not supported, this will almost certainly \ +-- \fail." +-- where +-- getDeps (_, C.CondNode _ dep _) = dep +-- subLibDepExist = any +-- ( \case +-- C.LSubLibName _ -> True +-- C.LMainLibName -> False +-- ) From 0abe0d0b0b2a755a4e8009960a93df2926d3dd44 Mon Sep 17 00:00:00 2001 From: theophilebatoz Date: Fri, 17 Nov 2023 00:30:37 +0000 Subject: [PATCH 04/18] feat: provide lib-name from ghc-pkg --- src/Stack/Build/ConstructPlan.hs | 2 +- src/Stack/Build/Installed.hs | 2 +- src/Stack/Component.hs | 1 + src/Stack/Dot.hs | 2 +- src/Stack/PackageDump.hs | 19 +++++++++++++------ src/Stack/Types/DumpPackage.hs | 24 +++++++++++++++++++++--- 6 files changed, 38 insertions(+), 12 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index ed8af6c94b..d8bf078d02 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -59,7 +59,7 @@ import Stack.Types.ConfigureOpts ( BaseConfigOpts (..), ConfigureOpts (..), configureOpts ) import Stack.Types.Curator ( Curator (..) ) import Stack.Types.Dependency ( DepValue (..), isDepTypeLibrary ) -import Stack.Types.DumpPackage ( DumpPackage (..) ) +import Stack.Types.DumpPackage ( DumpPackage (..), dpParentLibIdent ) import Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..), HasSourceMap (..) ) import Stack.Types.EnvSettings diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index aeb9a0842a..ac199d24a6 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -19,7 +19,7 @@ import Stack.PackageDump import Stack.Prelude import Stack.SourceMap ( getPLIVersion, loadVersion ) import Stack.Types.CompilerPaths ( getGhcPkgExe ) -import Stack.Types.DumpPackage ( DumpPackage (..) ) +import Stack.Types.DumpPackage ( DumpPackage (..), dpParentLibIdent ) import Stack.Types.EnvConfig ( HasEnvConfig, packageDatabaseDeps, packageDatabaseExtra , packageDatabaseLocal diff --git a/src/Stack/Component.hs b/src/Stack/Component.hs index 73919829da..e3512db493 100644 --- a/src/Stack/Component.hs +++ b/src/Stack/Component.hs @@ -24,6 +24,7 @@ module Stack.Component , foldOnNameAndBuildInfo , stackUnqualToQual , processDependencies + , fromCabalName ) where import Data.Foldable ( foldr' ) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 28295a057b..2359e514e5 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -597,7 +597,7 @@ withDotConfig opts inner = toDump name version = DumpPackage { dpGhcPkgId = fakeGhcPkgId , dpPackageIdent = PackageIdentifier name version - , dpParentLibIdent = Nothing + , dpSublib = Nothing , dpLicense = Nothing , dpLibDirs = [] , dpLibraries = [] diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index e550614f25..6b029c87e3 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -27,8 +27,11 @@ import qualified RIO.Text as T import Stack.GhcPkg ( createDatabase ) import Stack.Prelude import Stack.Types.CompilerPaths ( GhcPkgExe (..), HasCompiler (..) ) -import Stack.Types.DumpPackage ( DumpPackage (..) ) +import Stack.Types.DumpPackage ( DumpPackage (..), SublibDump (..) ) import Stack.Types.GhcPkgId ( GhcPkgId, parseGhcPkgId ) +import Stack.Types.Component (StackUnqualCompName(..)) +import Distribution.Types.MungedPackageName (decodeCompatPackageName) +import Stack.Component (fromCabalName) -- | Type representing exceptions thrown by functions exported by the -- "Stack.PackageDump" module. @@ -224,10 +227,14 @@ conduitDumpPackage = (.| CL.catMaybes) $ eachSection $ do -- Handle sub-libraries by recording the name of the parent library -- If name of parent library is missing, this is not a sub-library. - let mkParentLib n = PackageIdentifier n version - parentLib = mkParentLib <$> (parseS "package-name" >>= - parsePackageNameThrowing . T.unpack) - + let maybePackageName :: Maybe PackageName = parseS "package-name" >>= + parsePackageNameThrowing . T.unpack + let maybeLibName = parseS "lib-name" + let getLibNameFromLegacyName = case decodeCompatPackageName name of + MungedPackageName _parentPackageName (LSubLibName libName) -> fromCabalName libName + MungedPackageName _parentPackageName _ -> "" + let libName = maybe getLibNameFromLegacyName StackUnqualCompName maybeLibName + let subLibDump = flip SublibDump libName <$> maybePackageName let parseQuoted key = case mapM (P.parseOnly (argsParser NoEscaping)) val of Left{} -> throwM (Couldn'tParseField key val) @@ -241,7 +248,7 @@ conduitDumpPackage = (.| CL.catMaybes) $ eachSection $ do pure $ Just DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = PackageIdentifier name version - , dpParentLibIdent = parentLib + , dpSublib = subLibDump , dpLicense = license , dpLibDirs = libDirPaths , dpLibraries = T.words $ T.unwords libraries diff --git a/src/Stack/Types/DumpPackage.hs b/src/Stack/Types/DumpPackage.hs index 322cbf18d7..f63622218e 100644 --- a/src/Stack/Types/DumpPackage.hs +++ b/src/Stack/Types/DumpPackage.hs @@ -2,11 +2,14 @@ module Stack.Types.DumpPackage ( DumpPackage (..) + , SublibDump (..) + , dpParentLibIdent ) where import qualified Distribution.License as C import Distribution.ModuleName ( ModuleName ) import Stack.Prelude +import Stack.Types.Component (StackUnqualCompName) import Stack.Types.GhcPkgId ( GhcPkgId ) -- | Type representing dump information for a single package, as output by the @@ -18,9 +21,8 @@ data DumpPackage = DumpPackage -- ^ The @name@ and @version@ fields. The @name@ field is the munged package -- name. If the package is not for a sub library, its munged name is its -- name. - , dpParentLibIdent :: !(Maybe PackageIdentifier) - -- ^ The @package-name@ and @version@ fields, if @package-name@ is present. - -- That field is present if the package is for a sub library. + , dpSublib :: !(Maybe SublibDump) + -- ^ The sub library information if it's a sub-library. , dpLicense :: !(Maybe C.License) , dpLibDirs :: ![FilePath] -- ^ The @library-dirs@ field. @@ -35,3 +37,19 @@ data DumpPackage = DumpPackage , dpIsExposed :: !Bool } deriving (Eq, Read, Show) + +-- | +-- ghc-pkg has a notion of sublibraries when using ghc-kg dump. +-- We can only know it's different through the fields it shows. +data SublibDump = SublibDump + { sdPackageName :: PackageName + -- ^ "package-name" field from ghc-pkg + , sdLibraryName :: StackUnqualCompName + -- ^ "lib-name" field from ghc-pkg + } + deriving (Eq, Read, Show) + +dpParentLibIdent :: DumpPackage -> Maybe PackageIdentifier +dpParentLibIdent dp = case (dpSublib dp, dpPackageIdent dp) of + (Nothing, _) -> Nothing + (Just SublibDump{sdPackageName=libParentPackageName}, PackageIdentifier _ v) -> Just $ PackageIdentifier libParentPackageName v From 9ae2c19e60cfc2098cc116c60ffdb648162ca648 Mon Sep 17 00:00:00 2001 From: theophilebatoz Date: Sat, 18 Nov 2023 00:14:47 +0000 Subject: [PATCH 05/18] refactoring: break ConstructPlan types apart --- src/Stack/Build.hs | 2 +- src/Stack/Build/ConstructPlan.hs | 265 +++---------------------- src/Stack/Types/Build/ConstructPlan.hs | 241 ++++++++++++++++++++++ stack.cabal | 1 + 4 files changed, 275 insertions(+), 234 deletions(-) create mode 100644 src/Stack/Types/Build/ConstructPlan.hs diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 65bb498c95..3d26d82bc9 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -67,7 +67,7 @@ import Stack.Types.Package import Stack.Types.Platform ( HasPlatform (..) ) import Stack.Types.Runner ( Runner, globalOptsL ) import Stack.Types.SourceMap - ( CommonPackage (..), ProjectPackage (..), SMTargets (..) + ( SMTargets (..) , SourceMap (..), Target (..) ) import System.Terminal ( fixCodePage ) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index d8bf078d02..97fdd2686e 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -9,7 +9,6 @@ module Stack.Build.ConstructPlan ) where import Control.Monad.Trans.Maybe ( MaybeT (..) ) -import qualified Data.List as L import qualified Data.Map.Merge.Strict as Map import qualified Data.Map.Strict as Map import Data.Monoid.Map ( MonoidMap(..) ) @@ -17,11 +16,9 @@ import qualified Data.Set as Set import qualified Data.Text as T import Distribution.Types.BuildType ( BuildType (Configure) ) import Distribution.Types.PackageName ( mkPackageName ) -import Distribution.Types.VersionRange ( VersionRange ) -import Generics.Deriving.Monoid ( memptydefault, mappenddefault ) import Path ( parent ) import qualified RIO.NonEmpty as NE -import RIO.Process ( HasProcessContext (..), findExecutable ) +import RIO.Process ( findExecutable ) import RIO.State ( State, StateT (..), execState, get, modify, modify', put ) import RIO.Writer ( WriterT (..), pass, tell ) @@ -31,8 +28,7 @@ import Stack.Build.Source ( loadLocalPackage ) import Stack.Constants ( compilerOptionsCabalFlag ) import Stack.Package ( applyForceCustomBuild, buildableExes - , hasBuildableMainLibrary, packageUnknownTools - , processPackageDepsToList + , packageUnknownTools, processPackageDepsToList ) import Stack.Prelude hiding ( loadPackage ) import Stack.SourceMap ( getPLIVersion, mkProjectPackage ) @@ -57,14 +53,18 @@ import Stack.Types.CompilerPaths import Stack.Types.Config ( Config (..), HasConfig (..), stackRootL ) import Stack.Types.ConfigureOpts ( BaseConfigOpts (..), ConfigureOpts (..), configureOpts ) +import Stack.Types.Build.ConstructPlan + ( UnregisterState(..), NotOnlyLocal(NotOnlyLocal), ToolWarning(..), + Ctx(..), M, CombinedMap, AddDepRes(..), + W(..), PackageInfo(..), toTask, adrVersion, adrHasLibrary + ) import Stack.Types.Curator ( Curator (..) ) import Stack.Types.Dependency ( DepValue (..), isDepTypeLibrary ) import Stack.Types.DumpPackage ( DumpPackage (..), dpParentLibIdent ) import Stack.Types.EnvConfig - ( EnvConfig (..), HasEnvConfig (..), HasSourceMap (..) ) + ( EnvConfig (..), HasEnvConfig (..) ) import Stack.Types.EnvSettings ( EnvSettings (..), minimalEnvSettings ) -import Stack.Types.GHCVariant ( HasGHCVariant (..) ) import Stack.Types.GhcPkgId ( GhcPkgId ) import Stack.Types.GlobalOpts ( GlobalOpts (..) ) import Stack.Types.IsMutable ( IsMutable (..) ) @@ -75,8 +75,6 @@ import Stack.Types.Package , PackageSource (..), installedVersion, packageIdentifier , psVersion, runMemoizedWith ) -import Stack.Types.ParentMap ( ParentMap ) -import Stack.Types.Platform ( HasPlatform (..) ) import Stack.Types.ProjectConfig ( isPCGlobalProject ) import Stack.Types.Runner ( HasRunner (..), globalOptsL ) import Stack.Types.SourceMap @@ -84,197 +82,9 @@ import Stack.Types.SourceMap , GlobalPackage (..), SMTargets (..), SourceMap (..) ) import Stack.Types.Version - ( latestApplicableVersion, versionRangeText, withinRange ) + ( latestApplicableVersion, versionRangeText, withinRange, VersionRange ) import System.Environment ( lookupEnv ) --- | Type representing information about packages, namely information about --- whether or not a package is already installed and, unless the package is not --- to be built (global packages), where its source code is located. -data PackageInfo - = PIOnlyInstalled InstallLocation Installed - -- ^ This indicates that the package is already installed, and that we - -- shouldn't build it from source. This is only the case for global - -- packages. - | PIOnlySource PackageSource - -- ^ This indicates that the package isn't installed, and we know where to - -- find its source. - | PIBoth PackageSource Installed - -- ^ This indicates that the package is installed and we know where to find - -- its source. We may want to reinstall from source. - deriving Show - --- | A function to yield a 'PackageInfo' value from: (1) a 'PackageSource' --- value; and (2) a pair of an 'InstallLocation' value and an 'Installed' value. --- Checks that the version of the 'PackageSource' value and the version of the --- `Installed` value are the same. -combineSourceInstalled :: PackageSource - -> (InstallLocation, Installed) - -> PackageInfo -combineSourceInstalled ps (location, installed) = - assert (psVersion ps == installedVersion installed) $ - case location of - -- Always trust something in the snapshot - Snap -> PIOnlyInstalled location installed - Local -> PIBoth ps installed - --- | A type synonym representing dictionaries of package names, and combined --- information about the package in respect of whether or not it is already --- installed and, unless the package is not to be built (global packages), where --- its source code is located. -type CombinedMap = Map PackageName PackageInfo - --- | A function to yield a 'CombinedMap' value from: (1) a dictionary of package --- names, and where the source code of the named package is located; and (2) an --- 'InstalledMap' value. -combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap -combineMap = Map.merge - (Map.mapMissing (\_ s -> PIOnlySource s)) - (Map.mapMissing (\_ i -> uncurry PIOnlyInstalled i)) - (Map.zipWithMatched (\_ s i -> combineSourceInstalled s i)) - --- | Type synonym representing values used during the construction of a build --- plan. The type is an instance of 'Monad', hence its name. -type M = - WriterT - W - -- ^ The output to be collected - ( StateT - (Map PackageName (Either ConstructPlanException AddDepRes)) - -- ^ Library map - (RIO Ctx) - ) - --- | Type representing values used as the output to be collected during the --- construction of a build plan. -data W = W - { wFinals :: !(Map PackageName (Either ConstructPlanException Task)) - -- ^ A dictionary of package names, and either a final task to perform when - -- building the package or an exception. - , wInstall :: !(Map Text InstallLocation) - -- ^ A dictionary of executables to be installed, and location where the - -- executable's binary is placed. - , wDirty :: !(Map PackageName Text) - -- ^ A dictionary of local packages, and the reason why the local package is - -- considered dirty. - , wWarnings :: !([StyleDoc] -> [StyleDoc]) - -- ^ Warnings. - , wParents :: !ParentMap - -- ^ A dictionary of package names, and a list of pairs of the identifier - -- of a package depending on the package and the version range specified for - -- the dependency by that package. Used in the reporting of failure to - -- construct a build plan. - } - deriving Generic - -instance Semigroup W where - (<>) = mappenddefault - -instance Monoid W where - mempty = memptydefault - mappend = (<>) - --- | Type representing results of 'addDep'. -data AddDepRes - = ADRToInstall Task - -- ^ A task must be performed to provide the package name. - | ADRFound InstallLocation Installed - -- ^ An existing installation provides the package name. - deriving Show - -toTask :: AddDepRes -> Maybe Task -toTask (ADRToInstall task) = Just task -toTask (ADRFound _ _) = Nothing - -adrVersion :: AddDepRes -> Version -adrVersion (ADRToInstall task) = pkgVersion $ taskProvides task -adrVersion (ADRFound _ installed) = installedVersion installed - -adrHasLibrary :: AddDepRes -> Bool -adrHasLibrary (ADRToInstall task) = case taskType task of - TTLocalMutable lp -> packageHasLibrary $ lpPackage lp - TTRemotePackage _ p _ -> packageHasLibrary p - where - -- make sure we consider sub-libraries as libraries too - packageHasLibrary :: Package -> Bool - packageHasLibrary p = - hasBuildableMainLibrary p || not (null (packageSubLibraries p)) -adrHasLibrary (ADRFound _ Library{}) = True -adrHasLibrary (ADRFound _ Executable{}) = False - --- | Type representing values used as the environment to be read from during the --- construction of a build plan (the \'context\'). -data Ctx = Ctx - { baseConfigOpts :: !BaseConfigOpts - -- ^ Basic information used to determine configure options - , loadPackage :: !( PackageLocationImmutable - -> Map FlagName Bool - -> [Text] - -- ^ GHC options. - -> [Text] - -- ^ Cabal configure options. - -> M Package - ) - , combinedMap :: !CombinedMap - -- ^ A dictionary of package names, and combined information about the - -- package in respect of whether or not it is already installed and, unless - -- the package is not to be built (global packages), where its source code - -- is located. - , ctxEnvConfig :: !EnvConfig - -- ^ Configuration after the environment has been setup. - , callStack :: ![PackageName] - , wanted :: !(Set PackageName) - , localNames :: !(Set PackageName) - , mcurator :: !(Maybe Curator) - , pathEnvVar :: !Text - } - -instance HasPlatform Ctx where - platformL = configL.platformL - {-# INLINE platformL #-} - platformVariantL = configL.platformVariantL - {-# INLINE platformVariantL #-} - -instance HasGHCVariant Ctx where - ghcVariantL = configL.ghcVariantL - {-# INLINE ghcVariantL #-} - -instance HasLogFunc Ctx where - logFuncL = configL.logFuncL - -instance HasRunner Ctx where - runnerL = configL.runnerL - -instance HasStylesUpdate Ctx where - stylesUpdateL = runnerL.stylesUpdateL - -instance HasTerm Ctx where - useColorL = runnerL.useColorL - termWidthL = runnerL.termWidthL - -instance HasConfig Ctx where - configL = buildConfigL.lens bcConfig (\x y -> x { bcConfig = y }) - {-# INLINE configL #-} - -instance HasPantryConfig Ctx where - pantryConfigL = configL.pantryConfigL - -instance HasProcessContext Ctx where - processContextL = configL.processContextL - -instance HasBuildConfig Ctx where - buildConfigL = envConfigL.lens - envConfigBuildConfig - (\x y -> x { envConfigBuildConfig = y }) - -instance HasSourceMap Ctx where - sourceMapL = envConfigL.sourceMapL - -instance HasCompiler Ctx where - compilerPathsL = envConfigL.compilerPathsL - -instance HasEnvConfig Ctx where - envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) - -- | Computes a build plan. This means figuring out which build 'Task's to take, -- and the interdependencies among the build 'Task's. In particular: -- @@ -493,34 +303,6 @@ constructPlan pure $ PSFilePath lp pure $ pPackages <> deps -data NotOnlyLocal - = NotOnlyLocal [PackageName] [Text] - deriving (Show, Typeable) - -instance Exception NotOnlyLocal where - displayException (NotOnlyLocal packages exes) = concat - [ "Error: [S-1727]\n" - , "Specified only-locals, but I need to build snapshot contents:\n" - , if null packages then "" else concat - [ "Packages: " - , L.intercalate ", " (map packageNameString packages) - , "\n" - ] - , if null exes then "" else concat - [ "Executables: " - , L.intercalate ", " (map T.unpack exes) - , "\n" - ] - ] - --- | State to be maintained during the calculation of local packages --- to unregister. -data UnregisterState = UnregisterState - { usToUnregister :: !(Map GhcPkgId (PackageIdentifier, Text)) - , usKeep :: ![DumpPackage] - , usAnyAdded :: !Bool - } - -- | Determine which packages to unregister based on the given tasks and -- already registered local packages. mkUnregisterLocal :: @@ -1393,12 +1175,6 @@ checkAndWarnForUnknownTools p = do warn name = MaybeT . pure . Just $ ToolWarning (ExeName name) (packageName p) skipIf p' = pure $ if p' then Nothing else Just () --- | Warn about tools in the snapshot definition. States the tool name --- expected and the package name using it. -data ToolWarning - = ToolWarning ExeName PackageName - deriving Show - toolWarningText :: ToolWarning -> StyleDoc toolWarningText (ToolWarning (ExeName toolName) pkgName') = fillSep [ flow "No packages found in snapshot which provide a" @@ -1437,3 +1213,26 @@ logDebugPlanS :: logDebugPlanS s msg = do debugPlan <- view $ globalOptsL.to globalPlanInLog when debugPlan $ logDebugS s msg + +-- | A function to yield a 'PackageInfo' value from: (1) a 'PackageSource' +-- value; and (2) a pair of an 'InstallLocation' value and an 'Installed' value. +-- Checks that the version of the 'PackageSource' value and the version of the +-- `Installed` value are the same. +combineSourceInstalled :: PackageSource + -> (InstallLocation, Installed) + -> PackageInfo +combineSourceInstalled ps (location, installed) = + assert (psVersion ps == installedVersion installed) $ + case location of + -- Always trust something in the snapshot + Snap -> PIOnlyInstalled location installed + Local -> PIBoth ps installed + +-- | A function to yield a 'CombinedMap' value from: (1) a dictionary of package +-- names, and where the source code of the named package is located; and (2) an +-- 'InstalledMap' value. +combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap +combineMap = Map.merge + (Map.mapMissing (\_ s -> PIOnlySource s)) + (Map.mapMissing (\_ i -> uncurry PIOnlyInstalled i)) + (Map.zipWithMatched (\_ s i -> combineSourceInstalled s i)) \ No newline at end of file diff --git a/src/Stack/Types/Build/ConstructPlan.hs b/src/Stack/Types/Build/ConstructPlan.hs new file mode 100644 index 0000000000..2592e511f9 --- /dev/null +++ b/src/Stack/Types/Build/ConstructPlan.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Stack.Types.Build.ConstructPlan + ( NotOnlyLocal(..) + , ToolWarning(..) + , UnregisterState(..) + , AddDepRes(..) + , W(..) + , Ctx(..) + , M + , PackageInfo(..) + , CombinedMap + , toTask + , adrVersion + , adrHasLibrary + ) where + +import qualified Data.List as L +import qualified Data.Text as T +import Stack.Prelude hiding ( loadPackage ) +import Stack.Types.DumpPackage ( DumpPackage ) +import Stack.Types.GhcPkgId (GhcPkgId) +import Stack.Types.Package +import Stack.Types.EnvConfig +import Stack.Types.CompilerPaths +import Stack.Types.BuildConfig +import RIO.Process (HasProcessContext (processContextL)) +import Stack.Types.Config (HasConfig (configL)) +import Stack.Types.Runner +import Stack.Types.GHCVariant +import Stack.Types.Platform +import Stack.Types.Curator +import Stack.Types.ConfigureOpts +import Stack.Types.Build.Exception (ConstructPlanException) +import RIO.State +import Stack.Types.Build +import Stack.Types.ParentMap +import RIO.Writer ( WriterT (..) ) +import Generics.Deriving.Monoid (memptydefault, mappenddefault) +import Stack.Package (hasBuildableMainLibrary) + + +-- | Type representing information about packages, namely information about +-- whether or not a package is already installed and, unless the package is not +-- to be built (global packages), where its source code is located. +data PackageInfo + = PIOnlyInstalled InstallLocation Installed + -- ^ This indicates that the package is already installed, and that we + -- shouldn't build it from source. This is only the case for global + -- packages. + | PIOnlySource PackageSource + -- ^ This indicates that the package isn't installed, and we know where to + -- find its source. + | PIBoth PackageSource Installed + -- ^ This indicates that the package is installed and we know where to find + -- its source. We may want to reinstall from source. + deriving Show + +-- | A type synonym representing dictionaries of package names, and combined +-- information about the package in respect of whether or not it is already +-- installed and, unless the package is not to be built (global packages), where +-- its source code is located. +type CombinedMap = Map PackageName PackageInfo + +-- | Type synonym representing values used during the construction of a build +-- plan. The type is an instance of 'Monad', hence its name. +type M = + WriterT + W + -- ^ The output to be collected + ( StateT + (Map PackageName (Either ConstructPlanException AddDepRes)) + -- ^ Library map + (RIO Ctx) + ) + +-- | Type representing values used as the output to be collected during the +-- construction of a build plan. +data W = W + { wFinals :: !(Map PackageName (Either ConstructPlanException Task)) + -- ^ A dictionary of package names, and either a final task to perform when + -- building the package or an exception. + , wInstall :: !(Map Text InstallLocation) + -- ^ A dictionary of executables to be installed, and location where the + -- executable's binary is placed. + , wDirty :: !(Map PackageName Text) + -- ^ A dictionary of local packages, and the reason why the local package is + -- considered dirty. + , wWarnings :: !([StyleDoc] -> [StyleDoc]) + -- ^ Warnings. + , wParents :: !ParentMap + -- ^ A dictionary of package names, and a list of pairs of the identifier + -- of a package depending on the package and the version range specified for + -- the dependency by that package. Used in the reporting of failure to + -- construct a build plan. + } + deriving Generic + +instance Semigroup W where + (<>) = mappenddefault + +instance Monoid W where + mempty = memptydefault + mappend = (<>) + +-- | Type representing results of 'addDep'. +data AddDepRes + = ADRToInstall Task + -- ^ A task must be performed to provide the package name. + | ADRFound InstallLocation Installed + -- ^ An existing installation provides the package name. + deriving Show + +toTask :: AddDepRes -> Maybe Task +toTask (ADRToInstall task) = Just task +toTask (ADRFound _ _) = Nothing + +adrVersion :: AddDepRes -> Version +adrVersion (ADRToInstall task) = pkgVersion $ taskProvides task +adrVersion (ADRFound _ installed) = installedVersion installed + +adrHasLibrary :: AddDepRes -> Bool +adrHasLibrary (ADRToInstall task) = case taskType task of + TTLocalMutable lp -> packageHasLibrary $ lpPackage lp + TTRemotePackage _ p _ -> packageHasLibrary p + where + -- make sure we consider sub-libraries as libraries too + packageHasLibrary :: Package -> Bool + packageHasLibrary p = + hasBuildableMainLibrary p || not (null (packageSubLibraries p)) +adrHasLibrary (ADRFound _ Library{}) = True +adrHasLibrary (ADRFound _ Executable{}) = False + +-- | Type representing values used as the environment to be read from during the +-- construction of a build plan (the \'context\'). +data Ctx = Ctx + { baseConfigOpts :: !BaseConfigOpts + -- ^ Basic information used to determine configure options + , loadPackage :: !( PackageLocationImmutable + -> Map FlagName Bool + -> [Text] + -- ^ GHC options. + -> [Text] + -- ^ Cabal configure options. + -> M Package + ) + , combinedMap :: !CombinedMap + -- ^ A dictionary of package names, and combined information about the + -- package in respect of whether or not it is already installed and, unless + -- the package is not to be built (global packages), where its source code + -- is located. + , ctxEnvConfig :: !EnvConfig + -- ^ Configuration after the environment has been setup. + , callStack :: ![PackageName] + , wanted :: !(Set PackageName) + , localNames :: !(Set PackageName) + , mcurator :: !(Maybe Curator) + , pathEnvVar :: !Text + } + +instance HasPlatform Ctx where + platformL = configL.platformL + {-# INLINE platformL #-} + platformVariantL = configL.platformVariantL + {-# INLINE platformVariantL #-} + +instance HasGHCVariant Ctx where + ghcVariantL = configL.ghcVariantL + {-# INLINE ghcVariantL #-} + +instance HasLogFunc Ctx where + logFuncL = configL.logFuncL + +instance HasRunner Ctx where + runnerL = configL.runnerL + +instance HasStylesUpdate Ctx where + stylesUpdateL = runnerL.stylesUpdateL + +instance HasTerm Ctx where + useColorL = runnerL.useColorL + termWidthL = runnerL.termWidthL + +instance HasConfig Ctx where + configL = buildConfigL.lens bcConfig (\x y -> x { bcConfig = y }) + {-# INLINE configL #-} + +instance HasPantryConfig Ctx where + pantryConfigL = configL.pantryConfigL + +instance HasProcessContext Ctx where + processContextL = configL.processContextL + +instance HasBuildConfig Ctx where + buildConfigL = envConfigL.lens + envConfigBuildConfig + (\x y -> x { envConfigBuildConfig = y }) + +instance HasSourceMap Ctx where + sourceMapL = envConfigL.sourceMapL + +instance HasCompiler Ctx where + compilerPathsL = envConfigL.compilerPathsL + +instance HasEnvConfig Ctx where + envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) + +-- | State to be maintained during the calculation of local packages +-- to unregister. +data UnregisterState = UnregisterState + { usToUnregister :: !(Map GhcPkgId (PackageIdentifier, Text)) + , usKeep :: ![DumpPackage] + , usAnyAdded :: !Bool + } + + +data NotOnlyLocal + = NotOnlyLocal [PackageName] [Text] + deriving (Show, Typeable) + +instance Exception NotOnlyLocal where + displayException (NotOnlyLocal packages exes) = concat + [ "Error: [S-1727]\n" + , "Specified only-locals, but I need to build snapshot contents:\n" + , if null packages then "" else concat + [ "Packages: " + , L.intercalate ", " (map packageNameString packages) + , "\n" + ] + , if null exes then "" else concat + [ "Executables: " + , L.intercalate ", " (map T.unpack exes) + , "\n" + ] + ] + +-- | Warn about tools in the snapshot definition. States the tool name +-- expected and the package name using it. +data ToolWarning + = ToolWarning ExeName PackageName + deriving Show \ No newline at end of file diff --git a/stack.cabal b/stack.cabal index ef567c5107..434ae66fbf 100644 --- a/stack.cabal +++ b/stack.cabal @@ -330,6 +330,7 @@ library other-modules: GHC.Utils.GhcPkg.Main.Compat Stack.Config.ConfigureScript + Stack.Types.Build.ConstructPlan Stack.Types.ComponentUtils Stack.Types.FileDigestCache autogen-modules: From 435adb2cd4e490bd5054b428bc0e80a738421927 Mon Sep 17 00:00:00 2001 From: theophilebatoz Date: Sun, 19 Nov 2023 23:57:03 +0000 Subject: [PATCH 06/18] feat: add sublib info in load helper --- src/Stack/Build/Installed.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index ac199d24a6..b645303a18 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -19,7 +19,7 @@ import Stack.PackageDump import Stack.Prelude import Stack.SourceMap ( getPLIVersion, loadVersion ) import Stack.Types.CompilerPaths ( getGhcPkgExe ) -import Stack.Types.DumpPackage ( DumpPackage (..), dpParentLibIdent ) +import Stack.Types.DumpPackage ( DumpPackage (..), dpParentLibIdent, SublibDump ) import Stack.Types.EnvConfig ( HasEnvConfig, packageDatabaseDeps, packageDatabaseExtra , packageDatabaseLocal @@ -239,6 +239,7 @@ isAllowed installMap pkgDb dp = case Map.lookup name installMap of data LoadHelper = LoadHelper { lhId :: !GhcPkgId -- ^ The package's id. + , lhSublibrary :: !(Maybe SublibDump) , lhDeps :: ![GhcPkgId] -- ^ Unless the package's name is that of a 'wired-in' package, a list of -- the ids of the installed packages that are the package's dependencies. @@ -261,6 +262,7 @@ toLoadHelper pkgDb dp = LoadHelper if name `Set.member` wiredInPackages then [] else dpDepends dp + , lhSublibrary = dpSublib dp , lhPair = ( name , (toInstallLocation pkgDb, Library ident gid (Right <$> dpLicense dp)) From 403fde075d10a96ba37bed1ef3debe38f142f1b4 Mon Sep 17 00:00:00 2001 From: theophilebatoz Date: Mon, 20 Nov 2023 00:25:01 +0000 Subject: [PATCH 07/18] feat: refactor installed Library and provide GhcPkgId for sublibs --- src/Stack/Build/Cache.hs | 10 +++++----- src/Stack/Build/ConstructPlan.hs | 8 ++++---- src/Stack/Build/Execute.hs | 17 +++++++++-------- src/Stack/Build/Installed.hs | 5 +++-- src/Stack/Package.hs | 6 +++--- src/Stack/SDist.hs | 8 ++++---- src/Stack/Types/Package.hs | 23 ++++++++++++++++++++--- 7 files changed, 48 insertions(+), 29 deletions(-) diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index 7c3a24e246..f713dfd922 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -75,6 +75,7 @@ import Stack.Types.NamedComponent ( NamedComponent (..) ) import Stack.Types.SourceMap ( smRelDir ) import System.PosixCompat.Files ( modificationTime, getFileStatus, setFileTimes ) +import Stack.Types.Package (installedGhcPkgId, InstalledLibraryInfo (iliId)) -- | Directory containing files to mark an executable as installed exeInstalledDir :: (HasEnvConfig env) @@ -262,9 +263,10 @@ flagCacheKey :: (HasEnvConfig env) => Installed -> RIO env ConfigCacheKey flagCacheKey installed = do installationRoot <- installationRootLocal case installed of - Library _ gid _ -> + Library _ installedInfo -> do + let gid = iliId installedInfo pure $ - configCacheKey installationRoot (ConfigCacheTypeFlagLibrary gid) + configCacheKey installationRoot (ConfigCacheTypeFlagLibrary gid) Executable ident -> pure $ configCacheKey @@ -382,9 +384,7 @@ writePrecompiledCache baseConfigOpts loc copts buildHaddocks mghcPkgId subLibs e key <- getPrecompiledCacheKey loc copts buildHaddocks ec <- view envConfigL let stackRootRelative = makeRelative (view stackRootL ec) - mlibpath <- case mghcPkgId of - Executable _ -> pure Nothing - Library _ ipid _ -> Just <$> pathFromPkgId stackRootRelative ipid + mlibpath <- traverse (pathFromPkgId stackRootRelative) (installedGhcPkgId mghcPkgId) subLibPaths <- mapM (pathFromPkgId stackRootRelative) subLibs exes' <- forM (Set.toList exes) $ \exe -> do name <- parseRelFile $ T.unpack exe diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 97fdd2686e..72193e503b 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -73,7 +73,7 @@ import Stack.Types.Package ( ExeName (..), InstallLocation (..), Installed (..) , InstalledMap, LocalPackage (..), Package (..) , PackageSource (..), installedVersion, packageIdentifier - , psVersion, runMemoizedWith + , psVersion, runMemoizedWith, InstalledLibraryInfo (iliId) ) import Stack.Types.ProjectConfig ( isPCGlobalProject ) import Stack.Types.Runner ( HasRunner (..), globalOptsL ) @@ -985,8 +985,8 @@ processAdr adr = case adr of (Set.singleton $ taskProvides task, Map.empty, taskTargetIsMutable task) ADRFound loc (Executable _) -> (Set.empty, Map.empty, installLocationIsMutable loc) - ADRFound loc (Library ident gid _) -> - (Set.empty, Map.singleton ident gid, installLocationIsMutable loc) + ADRFound loc (Library ident installedInfo) -> + (Set.empty, Map.singleton ident (iliId installedInfo), installLocationIsMutable loc) checkDirtiness :: PackageSource @@ -1196,7 +1196,7 @@ inSnapshot name version = do PIBoth (PSRemote _ srcVersion FromSnapshot _) _ -> pure $ srcVersion == version -- OnlyInstalled occurs for global database - PIOnlyInstalled loc (Library pid _gid _lic) -> + PIOnlyInstalled loc (Library pid _) -> assert (loc == Snap) $ assert (pkgVersion pid == version) $ Just True diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 5d0029a6dd..c4c4c56b87 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -185,8 +185,9 @@ import Stack.Types.NamedComponent ) import Stack.Types.Package ( InstallLocation (..), Installed (..), InstalledMap - , LocalPackage (..), Package (..), installedPackageIdentifier - , packageIdentifier, runMemoizedWith + , LocalPackage (..), Package (..), InstalledLibraryInfo (..) + , installedPackageIdentifier, packageIdentifier, runMemoizedWith + , installedLibraryInfoFromGhcPkgId ) import Stack.Types.PackageFile ( PackageWarning (..) ) import Stack.Types.Platform ( HasPlatform (..) ) @@ -1077,8 +1078,8 @@ getConfigCache ExecuteEnv {..} task@Task {..} installedMap enableTest enableBenc -> installedToGhcPkgId ident installed Just installed -> installedToGhcPkgId ident installed _ -> throwM $ PackageIdMissingBug ident - installedToGhcPkgId ident (Library ident' x _) = - assert (ident == ident') $ Just (ident, x) + installedToGhcPkgId ident (Library ident' libInfo) = + assert (ident == ident') $ Just (ident, iliId libInfo) installedToGhcPkgId _ (Executable _) = Nothing missing' = Map.fromList $ mapMaybe getMissing $ Set.toList missing TaskConfigOpts missing mkOpts = taskConfigOpts @@ -1859,7 +1860,7 @@ singleBuild pure $ Just $ case mpkgid of Nothing -> assert False $ Executable pkgId - Just pkgid -> Library pkgId pkgid Nothing + Just pkgid -> Library pkgId (installedLibraryInfoFromGhcPkgId pkgid) where bindir = bcoSnapInstallRoot eeBaseConfigOpts bindirSuffix @@ -1893,7 +1894,7 @@ singleBuild let installedMapHasThisPkg :: Bool installedMapHasThisPkg = case Map.lookup (packageName package) installedMap of - Just (_, Library ident _ _) -> ident == pkgId + Just (_, Library ident _) -> ident == pkgId Just (_, Executable _) -> True _ -> False @@ -2119,7 +2120,7 @@ singleBuild (packageName package) case mpkgid of Nothing -> throwM $ Couldn'tFindPkgId $ packageName package - Just pkgid -> pure (Library ident pkgid Nothing, subLibsPkgIds) + Just pkgid -> pure (Library ident (installedLibraryInfoFromGhcPkgId pkgid), subLibsPkgIds) -- TODO: sublib should be in Library here else do markExeInstalled (taskLocation task) pkgId -- TODO unify somehow -- with writeFlagCache? @@ -2318,7 +2319,7 @@ singleTest topts testsToRun ac ee task installedMap = do idMap <- liftIO $ readTVarIO (eeGhcPkgIds ee) pure $ Map.lookup (taskProvides task) idMap let pkgGhcIdList = case installed of - Just (Library _ ghcPkgId _) -> [ghcPkgId] + Just (Library _ libInfo) -> [iliId libInfo] _ -> [] -- doctest relies on template-haskell in QuickCheck-based tests thGhcId <- diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index b645303a18..fe97a3a40e 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -29,7 +29,7 @@ import Stack.Types.Package ( InstallLocation (..), InstallMap, Installed (..) , InstalledMap, InstalledPackageLocation (..) , PackageDatabase (..), PackageDbVariety (..) - , toPackageDbVariety + , toPackageDbVariety, InstalledLibraryInfo (InstalledLibraryInfo) ) import Stack.Types.SourceMap ( DepPackage (..), ProjectPackage (..), SourceMap (..) ) @@ -265,10 +265,11 @@ toLoadHelper pkgDb dp = LoadHelper , lhSublibrary = dpSublib dp , lhPair = ( name - , (toInstallLocation pkgDb, Library ident gid (Right <$> dpLicense dp)) + , (toInstallLocation pkgDb, Library ident installedLibInfo) ) } where + installedLibInfo = InstalledLibraryInfo gid (Right <$> dpLicense dp) mempty gid = dpGhcPkgId dp ident@(PackageIdentifier name _) = dpPackageIdent dp diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index d1c28559ed..814832b7a4 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -103,7 +103,7 @@ import Stack.Types.Package ( BioInput(..), BuildInfoOpts (..), InstallMap , Installed (..), InstalledMap, Package (..) , PackageConfig (..), PackageException (..) - , dotCabalCFilePath, packageIdentifier + , dotCabalCFilePath, packageIdentifier, InstalledLibraryInfo (iliId) ) import Stack.Types.PackageFile ( DotCabalPath, PackageComponentFile (..) ) @@ -321,8 +321,8 @@ generateBuildInfoOpts BioInput {..} = deps = concat [ case M.lookup name biInstalledMap of - Just (_, Stack.Types.Package.Library _ident ipid _) -> - ["-package-id=" <> ghcPkgIdString ipid] + Just (_, Stack.Types.Package.Library _ident installedInfo) -> + ["-package-id=" <> ghcPkgIdString (iliId installedInfo)] _ -> ["-package=" <> packageNameString name <> maybe "" -- This empty case applies to e.g. base. ((("-" <>) . versionString) . installVersion) diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index e30ab49ade..274f8bbad6 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -70,8 +70,8 @@ import Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL ) import Stack.Types.GhcPkgId ( GhcPkgId ) import Stack.Types.Package - ( InstallMap, Installed (..), InstalledMap, LocalPackage (..) - , Package (..), PackageConfig (..), installedVersion + ( InstallMap, Installed (..), InstalledLibraryInfo (..), InstalledMap, + LocalPackage (..), Package (..), PackageConfig (..), installedVersion , packageIdentifier ) import Stack.Types.Platform ( HasPlatform (..) ) @@ -221,8 +221,8 @@ getSDistTarball mpvpBounds pkgDir = do (installedMap, _globalDumpPkgs, _snapshotDumpPkgs, _localDumpPkgs) <- getInstalled installMap let deps = Map.fromList - [ (pid, ghcPkgId) - | (_, Library pid ghcPkgId _) <- Map.elems installedMap] + [ (pid, iliId libInfo) + | (_, Library pid libInfo) <- Map.elems installedMap] prettyInfoL [ flow "Getting the file list for" , style File (fromString pkgFp) <> "." diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 2d14b7bf3d..ff1c0404a1 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -10,6 +10,7 @@ module Stack.Types.Package , InstallLocation (..) , InstallMap , Installed (..) + , InstalledLibraryInfo (..) , InstalledPackageLocation (..) , InstalledMap , LocalPackage (..) @@ -26,6 +27,8 @@ module Stack.Types.Package , dotCabalMainPath , dotCabalModule , dotCabalModulePath + , installedGhcPkgId + , installedLibraryInfoFromGhcPkgId , installedPackageIdentifier , installedVersion , lpFiles @@ -56,7 +59,7 @@ import Stack.Types.CompCollection ( CompCollection ) import Stack.Types.Compiler ( ActualCompiler ) import Stack.Types.Component ( StackBenchmark, StackBuildInfo, StackExecutable - , StackForeignLibrary, StackLibrary, StackTestSuite + , StackForeignLibrary, StackLibrary, StackTestSuite, StackUnqualCompName ) import Stack.Types.Dependency ( DepValue ) import Stack.Types.EnvConfig ( EnvConfig, HasEnvConfig (..) ) @@ -459,9 +462,19 @@ dotCabalGetPath dcp = -- information about what is installed. type InstalledMap = Map PackageName (InstallLocation, Installed) +data InstalledLibraryInfo = InstalledLibraryInfo + { iliId :: GhcPkgId + , iliLicense :: Maybe (Either SPDX.License License) + , iliSublib :: Map StackUnqualCompName GhcPkgId + } + deriving (Eq, Show) + +installedLibraryInfoFromGhcPkgId :: GhcPkgId -> InstalledLibraryInfo +installedLibraryInfoFromGhcPkgId ghcPkgId = InstalledLibraryInfo ghcPkgId Nothing mempty + -- | Type representing information about what is installed. data Installed - = Library PackageIdentifier GhcPkgId (Maybe (Either SPDX.License License)) + = Library PackageIdentifier InstalledLibraryInfo -- ^ A library, including its installed package id and, optionally, its -- license. | Executable PackageIdentifier @@ -469,9 +482,13 @@ data Installed deriving (Eq, Show) installedPackageIdentifier :: Installed -> PackageIdentifier -installedPackageIdentifier (Library pid _ _) = pid +installedPackageIdentifier (Library pid _) = pid installedPackageIdentifier (Executable pid) = pid +installedGhcPkgId :: Installed -> Maybe GhcPkgId +installedGhcPkgId (Library _ libInfo) = Just $ iliId libInfo +installedGhcPkgId (Executable _) = Nothing + -- | Get the installed Version. installedVersion :: Installed -> Version installedVersion i = From 52f2f1a94eee3a479ccdae50ca5945bd2675fc59 Mon Sep 17 00:00:00 2001 From: theophilebatoz Date: Mon, 20 Nov 2023 08:35:52 +0000 Subject: [PATCH 08/18] feat: adjust installed libs from ghc-pkg --- src/Stack/Build/Installed.hs | 34 ++++++++++++++++++++++++++++++---- 1 file changed, 30 insertions(+), 4 deletions(-) diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index fe97a3a40e..2d58c460eb 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -19,7 +19,7 @@ import Stack.PackageDump import Stack.Prelude import Stack.SourceMap ( getPLIVersion, loadVersion ) import Stack.Types.CompilerPaths ( getGhcPkgExe ) -import Stack.Types.DumpPackage ( DumpPackage (..), dpParentLibIdent, SublibDump ) +import Stack.Types.DumpPackage ( DumpPackage (..), dpParentLibIdent, SublibDump (sdLibraryName), sdPackageName ) import Stack.Types.EnvConfig ( HasEnvConfig, packageDatabaseDeps, packageDatabaseExtra , packageDatabaseLocal @@ -29,10 +29,11 @@ import Stack.Types.Package ( InstallLocation (..), InstallMap, Installed (..) , InstalledMap, InstalledPackageLocation (..) , PackageDatabase (..), PackageDbVariety (..) - , toPackageDbVariety, InstalledLibraryInfo (InstalledLibraryInfo) + , toPackageDbVariety, InstalledLibraryInfo (InstalledLibraryInfo, iliSublib, iliId) ) import Stack.Types.SourceMap ( DepPackage (..), ProjectPackage (..), SourceMap (..) ) +import Data.Foldable (Foldable(..)) toInstallMap :: MonadIO m => SourceMap -> m InstallMap toInstallMap sourceMap = do @@ -75,7 +76,7 @@ getInstalled {-opts-} installMap = do loadDatabase' (UserPkgDb (InstalledTo Snap) snapDBPath) installedLibs1 (installedLibs3, localDumpPkgs) <- loadDatabase' (UserPkgDb (InstalledTo Local) localDBPath) installedLibs2 - let installedLibs = Map.fromList $ map lhPair installedLibs3 + let installedLibs = foldr' gatherAndTransformSubLoadHelper mempty installedLibs3 -- Add in the executables that are installed, making sure to only trust a -- listed installation under the right circumstances (see below) @@ -262,7 +263,7 @@ toLoadHelper pkgDb dp = LoadHelper if name `Set.member` wiredInPackages then [] else dpDepends dp - , lhSublibrary = dpSublib dp + , lhSublibrary = dpSublib dp , lhPair = ( name , (toInstallLocation pkgDb, Library ident installedLibInfo) @@ -278,3 +279,28 @@ toLoadHelper pkgDb dp = LoadHelper toInstallLocation ExtraDb = Snap toInstallLocation WriteOnlyDb = Snap toInstallLocation MutableDb = Local + +-- | This is where sublibraries and main libraries are assembled into +-- a single entity Installed package, where all ghcPkgId live. +gatherAndTransformSubLoadHelper :: + LoadHelper + -> Map PackageName (InstallLocation, Installed) + -> Map PackageName (InstallLocation, Installed) +gatherAndTransformSubLoadHelper lh = + Map.insertWith onPreviousLoadHelper key value + where + -- here we assume that both have the same location + -- which already was a prior assumption in stack + onPreviousLoadHelper (pLoc, Library pn incomingLibInfo) (_, Library _ existingLibInfo) = + (pLoc, Library pn existingLibInfo{ + iliSublib=Map.union (iliSublib incomingLibInfo) (iliSublib existingLibInfo), + iliId=if isJust $ lhSublibrary lh then iliId existingLibInfo else iliId incomingLibInfo + }) + onPreviousLoadHelper newVal _oldVal = newVal + (key, value) = case lhSublibrary lh of + Nothing -> (rawPackageName, rawValue) + Just sd -> (sdPackageName sd, updateAsSublib sd <$> rawValue) + (rawPackageName, rawValue) = lhPair lh + updateAsSublib sd (Library (PackageIdentifier _sublibMungedPackageName version) libInfo) = + Library (PackageIdentifier key version) libInfo{iliSublib=Map.singleton (sdLibraryName sd) (iliId libInfo)} + updateAsSublib _ v = v From 91f10663077c472f3584790e6e9d7bb3a0dbce5a Mon Sep 17 00:00:00 2001 From: theophilebatoz Date: Wed, 22 Nov 2023 17:51:04 +0000 Subject: [PATCH 09/18] feat: finalize sublibraries deps support --- src/Stack/Build/ConstructPlan.hs | 4 ++-- src/Stack/Build/Execute.hs | 33 ++++++++++++++++--------------- src/Stack/Build/Installed.hs | 2 +- src/Stack/Package.hs | 27 ++++--------------------- src/Stack/Types/ComponentUtils.hs | 11 ++++++++--- src/Stack/Types/Dependency.hs | 7 ++++++- src/Stack/Types/Package.hs | 32 +++++++++++++++++++++++++++++- 7 files changed, 69 insertions(+), 47 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 72193e503b..acfaed94af 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -73,7 +73,7 @@ import Stack.Types.Package ( ExeName (..), InstallLocation (..), Installed (..) , InstalledMap, LocalPackage (..), Package (..) , PackageSource (..), installedVersion, packageIdentifier - , psVersion, runMemoizedWith, InstalledLibraryInfo (iliId) + , psVersion, runMemoizedWith, installedMapGhcPkgId ) import Stack.Types.ProjectConfig ( isPCGlobalProject ) import Stack.Types.Runner ( HasRunner (..), globalOptsL ) @@ -986,7 +986,7 @@ processAdr adr = case adr of ADRFound loc (Executable _) -> (Set.empty, Map.empty, installLocationIsMutable loc) ADRFound loc (Library ident installedInfo) -> - (Set.empty, Map.singleton ident (iliId installedInfo), installLocationIsMutable loc) + (Set.empty, installedMapGhcPkgId ident installedInfo, installLocationIsMutable loc) checkDirtiness :: PackageSource diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index c4c4c56b87..e2237b68bc 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -150,7 +150,7 @@ import Stack.Types.BuildOpts ) import Stack.Types.CompCollection ( collectionKeyValueList, collectionLookup - , getBuildableListText + , getBuildableListText, getBuildableListAs ) import Stack.Types.Compiler ( ActualCompiler (..), WhichCompiler (..) @@ -187,7 +187,7 @@ import Stack.Types.Package ( InstallLocation (..), Installed (..), InstalledMap , LocalPackage (..), Package (..), InstalledLibraryInfo (..) , installedPackageIdentifier, packageIdentifier, runMemoizedWith - , installedLibraryInfoFromGhcPkgId + , installedMapGhcPkgId, toCabalMungedPackageName, simpleInstalledLib ) import Stack.Types.PackageFile ( PackageWarning (..) ) import Stack.Types.Platform ( HasPlatform (..) ) @@ -1075,14 +1075,15 @@ getConfigCache ExecuteEnv {..} task@Task {..} installedMap enableTest enableBenc -- an initialBuildSteps target. | boptsCLIInitialBuildSteps eeBuildOptsCLI && taskIsTarget task, Just (_, installed) <- Map.lookup (pkgName ident) installedMap - -> installedToGhcPkgId ident installed - Just installed -> installedToGhcPkgId ident installed + -> pure $ installedToGhcPkgId ident installed + Just installed -> pure $ installedToGhcPkgId ident installed _ -> throwM $ PackageIdMissingBug ident installedToGhcPkgId ident (Library ident' libInfo) = - assert (ident == ident') $ Just (ident, iliId libInfo) - installedToGhcPkgId _ (Executable _) = Nothing - missing' = Map.fromList $ mapMaybe getMissing $ Set.toList missing + assert (ident == ident') (installedMapGhcPkgId ident libInfo) + installedToGhcPkgId _ (Executable _) = mempty TaskConfigOpts missing mkOpts = taskConfigOpts + missingMapList <- traverse getMissing $ toList missing + let missing' = Map.unions missingMapList opts = mkOpts missing' allDeps = Set.fromList $ Map.elems missing' ++ Map.elems taskPresent cache = ConfigCache @@ -1860,7 +1861,7 @@ singleBuild pure $ Just $ case mpkgid of Nothing -> assert False $ Executable pkgId - Just pkgid -> Library pkgId (installedLibraryInfoFromGhcPkgId pkgid) + Just pkgid -> simpleInstalledLib pkgId pkgid mempty where bindir = bcoSnapInstallRoot eeBaseConfigOpts bindirSuffix @@ -2104,23 +2105,23 @@ singleBuild -- library (that is, if it exists) (mpkgid, subLibsPkgIds) <- if hasBuildableMainLibrary package then do - subLibsPkgIds <- fmap catMaybes $ - forM (getBuildableListText $ packageSubLibraries package) $ \subLib -> do - let subLibName = MungedPackageName - (packageName package) - (LSubLibName $ mkUnqualComponentName $ T.unpack subLib) - loadInstalledPkg + subLibsPkgIds' <- fmap catMaybes $ + forM (getBuildableListAs id $ packageSubLibraries package) $ \subLib -> do + let subLibName = toCabalMungedPackageName (packageName package) subLib + maybeGhcpkgId <- loadInstalledPkg [installedPkgDb] installedDumpPkgsTVar (encodeCompatPackageName subLibName) - + pure $ (subLib, ) <$> maybeGhcpkgId + let subLibsPkgIds = snd <$> subLibsPkgIds' mpkgid <- loadInstalledPkg [installedPkgDb] installedDumpPkgsTVar (packageName package) + let makeInstalledLib pkgid = simpleInstalledLib ident pkgid (Map.fromList subLibsPkgIds') case mpkgid of Nothing -> throwM $ Couldn'tFindPkgId $ packageName package - Just pkgid -> pure (Library ident (installedLibraryInfoFromGhcPkgId pkgid), subLibsPkgIds) -- TODO: sublib should be in Library here + Just pkgid -> pure (makeInstalledLib pkgid, subLibsPkgIds) else do markExeInstalled (taskLocation task) pkgId -- TODO unify somehow -- with writeFlagCache? diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index 2d58c460eb..958bff0b31 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -19,7 +19,7 @@ import Stack.PackageDump import Stack.Prelude import Stack.SourceMap ( getPLIVersion, loadVersion ) import Stack.Types.CompilerPaths ( getGhcPkgExe ) -import Stack.Types.DumpPackage ( DumpPackage (..), dpParentLibIdent, SublibDump (sdLibraryName), sdPackageName ) +import Stack.Types.DumpPackage ( DumpPackage (..), dpParentLibIdent, SublibDump (..), sdPackageName ) import Stack.Types.EnvConfig ( HasEnvConfig, packageDatabaseDeps, packageDatabaseExtra , packageDatabaseLocal diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 814832b7a4..733436ed2f 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -47,14 +47,12 @@ import Distribution.PackageDescription , GenericPackageDescription (..), HookedBuildInfo , Library (..), PackageDescription (..), PackageFlag (..) , SetupBuildInfo (..), TestSuite (..), allLibraries - , buildType, depPkgName, depVerRange, maybeToLibraryName + , buildType, depPkgName, depVerRange ) -import Distribution.Pretty ( prettyShow ) import Distribution.Simple.PackageDescription ( readHookedBuildInfo ) import Distribution.System ( OS (..), Arch, Platform (..) ) import Distribution.Text ( display ) import qualified Distribution.Types.CondTree as Cabal -import qualified Distribution.Types.UnqualComponentName as Cabal import Distribution.Utils.Path ( getSymbolicPath ) import Distribution.Verbosity ( silent ) import Distribution.Version @@ -96,14 +94,13 @@ import Stack.Types.Dependency , libraryDepFromVersionRange ) import Stack.Types.EnvConfig ( HasEnvConfig ) -import Stack.Types.GhcPkgId ( ghcPkgIdString ) import Stack.Types.NamedComponent ( NamedComponent (..), subLibComponents ) import Stack.Types.Package ( BioInput(..), BuildInfoOpts (..), InstallMap , Installed (..), InstalledMap, Package (..) , PackageConfig (..), PackageException (..) - , dotCabalCFilePath, packageIdentifier, InstalledLibraryInfo (iliId) + , dotCabalCFilePath, packageIdentifier, installedToPackageIdOpt ) import Stack.Types.PackageFile ( DotCabalPath, PackageComponentFile (..) ) @@ -181,16 +178,6 @@ packageFromPackageDescription Just (MungedPackageName pn lib, libraryDepFromVersionRange vr) getSubLibName _ _ _ = Nothing -toInternalPackageMungedName :: Package -> Text -> Text -toInternalPackageMungedName pkg = - T.pack - . prettyShow - . MungedPackageName (packageName pkg) - . maybeToLibraryName - . Just - . Cabal.mkUnqualComponentName - . T.unpack - -- | This is an action used to collect info needed for "stack ghci". This info -- isn't usually needed, so computation of it is deferred. getPackageOpts :: @@ -218,17 +205,11 @@ getPackageOpts let subLibs = S.toList $ subLibComponents $ M.keysSet componentsModules excludedSubLibs <- mapM (parsePackageNameThrowing . T.unpack) subLibs - mungedSubLibs <- mapM - ( parsePackageNameThrowing - . T.unpack - . toInternalPackageMungedName stackPackage - ) - subLibs componentsOpts <- generatePkgDescOpts installMap installedMap (excludedSubLibs ++ omitPkgs) - (mungedSubLibs ++ addPkgs) + addPkgs cabalfp stackPackage componentFiles @@ -322,7 +303,7 @@ generateBuildInfoOpts BioInput {..} = concat [ case M.lookup name biInstalledMap of Just (_, Stack.Types.Package.Library _ident installedInfo) -> - ["-package-id=" <> ghcPkgIdString (iliId installedInfo)] + installedToPackageIdOpt installedInfo _ -> ["-package=" <> packageNameString name <> maybe "" -- This empty case applies to e.g. base. ((("-" <>) . versionString) . installVersion) diff --git a/src/Stack/Types/ComponentUtils.hs b/src/Stack/Types/ComponentUtils.hs index 914eaa4f3e..cd3ba010c9 100644 --- a/src/Stack/Types/ComponentUtils.hs +++ b/src/Stack/Types/ComponentUtils.hs @@ -14,11 +14,12 @@ module Stack.Types.ComponentUtils ( StackUnqualCompName (..) , fromCabalName + , toCabalName ) where -import Distribution.PackageDescription (UnqualComponentName, unUnqualComponentName) +import Distribution.PackageDescription (UnqualComponentName, unUnqualComponentName, mkUnqualComponentName) import Stack.Prelude -import RIO.Text (pack) +import RIO.Text (pack, unpack) -- | Type representing the name of an \'unqualified\' component (that is, the -- component can be any sort - a (unnamed) main library or sub-library, @@ -35,4 +36,8 @@ newtype StackUnqualCompName = StackUnqualCompName {unqualCompToText :: Text} fromCabalName :: UnqualComponentName -> StackUnqualCompName fromCabalName unqualName = - StackUnqualCompName $ pack . unUnqualComponentName $ unqualName \ No newline at end of file + StackUnqualCompName $ pack . unUnqualComponentName $ unqualName + +toCabalName :: StackUnqualCompName -> UnqualComponentName +toCabalName (StackUnqualCompName unqualName) = + mkUnqualComponentName (unpack unqualName) \ No newline at end of file diff --git a/src/Stack/Types/Dependency.hs b/src/Stack/Types/Dependency.hs index 3cbeaefcd3..12d05ee5e2 100644 --- a/src/Stack/Types/Dependency.hs +++ b/src/Stack/Types/Dependency.hs @@ -8,11 +8,11 @@ module Stack.Types.Dependency , cabalSetupDepsToStackDep , libraryDepFromVersionRange , isDepTypeLibrary + , getDepSublib ) where import Data.Foldable ( foldr' ) import qualified Data.Map as Map -import qualified Distribution.Compat.NonEmptySet as NES import qualified Distribution.PackageDescription as Cabal import Distribution.Types.VersionRange ( VersionRange ) import Stack.Prelude @@ -40,6 +40,11 @@ data DepLibrary = DepLibrary } deriving (Eq, Show) +getDepSublib :: DepValue -> Maybe (Set StackUnqualCompName) +getDepSublib val = case dvType val of + AsLibrary libVal -> Just $ dlSublib libVal + _ -> Nothing + defaultDepLibrary :: DepLibrary defaultDepLibrary = DepLibrary True mempty diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index ff1c0404a1..0ff53fe324 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -29,7 +29,9 @@ module Stack.Types.Package , dotCabalModulePath , installedGhcPkgId , installedLibraryInfoFromGhcPkgId + , installedMapGhcPkgId , installedPackageIdentifier + , installedToPackageIdOpt , installedVersion , lpFiles , lpFilesForComponents @@ -38,6 +40,8 @@ module Stack.Types.Package , packageIdentifier , psVersion , runMemoizedWith + , simpleInstalledLib + , toCabalMungedPackageName , toPackageDbVariety ) where @@ -61,15 +65,17 @@ import Stack.Types.Component ( StackBenchmark, StackBuildInfo, StackExecutable , StackForeignLibrary, StackLibrary, StackTestSuite, StackUnqualCompName ) +import Stack.Types.ComponentUtils (toCabalName) import Stack.Types.Dependency ( DepValue ) import Stack.Types.EnvConfig ( EnvConfig, HasEnvConfig (..) ) -import Stack.Types.GhcPkgId ( GhcPkgId ) +import Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString ) import Stack.Types.NamedComponent ( NamedComponent ) import Stack.Types.PackageFile ( DotCabalDescriptor (..), DotCabalPath (..) , StackPackageFile ) import Stack.Types.SourceMap ( CommonPackage, FromSnapshot ) +import Distribution.Types.MungedPackageName (encodeCompatPackageName) -- | Type representing exceptions thrown by functions exported by the -- "Stack.Package" module. @@ -472,6 +478,15 @@ data InstalledLibraryInfo = InstalledLibraryInfo installedLibraryInfoFromGhcPkgId :: GhcPkgId -> InstalledLibraryInfo installedLibraryInfoFromGhcPkgId ghcPkgId = InstalledLibraryInfo ghcPkgId Nothing mempty +simpleInstalledLib :: PackageIdentifier -> GhcPkgId -> Map StackUnqualCompName GhcPkgId -> Installed +simpleInstalledLib pkgIdentifier ghcPkgId = Library pkgIdentifier . InstalledLibraryInfo ghcPkgId Nothing + +installedToPackageIdOpt :: InstalledLibraryInfo -> [String] +installedToPackageIdOpt libInfo = M.foldr' (iterator (++)) (pure $ toStr (iliId libInfo)) (iliSublib libInfo) + where + toStr ghcPkgId = "-package-id=" <> ghcPkgIdString ghcPkgId + iterator op ghcPkgId acc = pure (toStr ghcPkgId) `op` acc + -- | Type representing information about what is installed. data Installed = Library PackageIdentifier InstalledLibraryInfo @@ -495,6 +510,21 @@ installedVersion i = let PackageIdentifier _ version = installedPackageIdentifier i in version +-- | Gathers all the GhcPkgId provided by a library into a map +installedMapGhcPkgId :: PackageIdentifier -> InstalledLibraryInfo -> Map PackageIdentifier GhcPkgId +installedMapGhcPkgId pkgId@(PackageIdentifier pkgName version) installedLib = finalMap + where + finalMap = M.insert pkgId (iliId installedLib) baseMap + baseMap = M.mapKeysMonotonic (toCabalMungedPackageIdentifier pkgName version) $ iliSublib installedLib + +-- | Creates a 'MungedPackageName' identifier. +toCabalMungedPackageIdentifier :: PackageName -> Version -> StackUnqualCompName -> PackageIdentifier +toCabalMungedPackageIdentifier pkgName version = flip PackageIdentifier version + . encodeCompatPackageName . toCabalMungedPackageName pkgName + +toCabalMungedPackageName :: PackageName -> StackUnqualCompName -> MungedPackageName +toCabalMungedPackageName pkgName = MungedPackageName pkgName . LSubLibName . toCabalName + -- | Type representing inputs to 'Stack.Package.generateBuildInfoOpts'. data BioInput = BioInput { biInstallMap :: !InstallMap From 404bf367017978090b690ebf0123bf02430ce986 Mon Sep 17 00:00:00 2001 From: theophilebatoz Date: Wed, 22 Nov 2023 17:55:06 +0000 Subject: [PATCH 10/18] fix: cleaning unused and redundant sublib deps in package --- src/Stack/Package.hs | 10 ---------- src/Stack/Types/Package.hs | 2 -- 2 files changed, 12 deletions(-) diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 733436ed2f..25215a03ca 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -35,7 +35,6 @@ import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Text as T import Distribution.CabalSpecVersion ( cabalSpecToVersionDigits ) -import qualified Distribution.Compat.NonEmptySet as NES import Distribution.Compiler ( CompilerFlavor (..), PerCompilerFlavor (..) ) import Distribution.ModuleName ( ModuleName ) @@ -155,7 +154,6 @@ packageFromPackageDescription foldAndMakeCollection stackBenchmarkFromCabal $ benchmarks pkg , packageExecutables = foldAndMakeCollection stackExecutableFromCabal $ executables pkg - , packageSubLibDeps = subLibDeps , packageBuildType = buildType pkg , packageSetupDeps = fmap cabalSetupDepsToStackDep (setupBuildInfo pkg) , packageCabalSpec = specVersion pkg @@ -170,14 +168,6 @@ packageFromPackageDescription pkgId = package pkg name = pkgName pkgId - subLibDeps = M.fromList $ concatMap - (\(Dependency n vr libs) -> mapMaybe (getSubLibName n vr) (NES.toList libs)) - (concatMap targetBuildDepends (allBuildInfo' pkg)) - - getSubLibName pn vr lib@(LSubLibName _) = - Just (MungedPackageName pn lib, libraryDepFromVersionRange vr) - getSubLibName _ _ _ = Nothing - -- | This is an action used to collect info needed for "stack ghci". This info -- isn't usually needed, so computation of it is deferred. getPackageOpts :: diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 0ff53fe324..3e7cccec57 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -163,8 +163,6 @@ data Package = Package -- ^ Version of the package , packageLicense :: !(Either SPDX.License License) -- ^ The license the package was released under. - , packageSubLibDeps :: !(Map MungedPackageName DepValue) - -- ^ Original sub-library dependencies (not sieved). , packageGhcOptions :: ![Text] -- ^ Ghc options used on package. , packageCabalConfigOpts :: ![Text] From 4560b3897db8f64b2a781dd13608f17227fe0d39 Mon Sep 17 00:00:00 2001 From: theophilebatoz Date: Wed, 22 Nov 2023 17:59:25 +0000 Subject: [PATCH 11/18] feat: completely remove sublibrary dependency warning check --- src/Stack/Build.hs | 33 --------------------------------- 1 file changed, 33 deletions(-) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 3d26d82bc9..f8fbe2f001 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -138,8 +138,6 @@ build msetLocalFiles = do depsLocals <- localDependencies let allLocals = locals <> depsLocals - -- checkSubLibraryDependencies (Map.elems $ smProject sourceMap) - boptsCli <- view $ envConfigL.to envConfigBuildOptsCLI -- Set local files, necessary for file watching stackYaml <- view stackYamlL @@ -371,34 +369,3 @@ checkComponentsBuildable lps = | lp <- lps , c <- Set.toList (lpUnbuildable lp) ] - --- | Find if any sub-library dependency (other than internal libraries) exists --- in each project package. --- checkSubLibraryDependencies :: HasTerm env => [ProjectPackage] -> RIO env () --- checkSubLibraryDependencies projectPackages = --- forM_ projectPackages $ \projectPackage -> do --- C.GenericPackageDescription pkgDesc _ _ lib subLibs foreignLibs exes tests benches <- --- liftIO $ cpGPD . ppCommon $ projectPackage - --- let pName = pkgName . C.package $ pkgDesc --- dependencies = concatMap getDeps subLibs <> --- concatMap getDeps foreignLibs <> --- concatMap getDeps exes <> --- concatMap getDeps tests <> --- concatMap getDeps benches <> --- maybe [] C.condTreeConstraints lib --- notInternal (Dependency pName' _ _) = pName' /= pName --- publicDependencies = filter notInternal dependencies --- publicLibraries = concatMap (toList . depLibraries) publicDependencies - --- when (subLibDepExist publicLibraries) $ --- prettyWarnS --- "Sublibrary dependency is not supported, this will almost certainly \ --- \fail." --- where --- getDeps (_, C.CondNode _ dep _) = dep --- subLibDepExist = any --- ( \case --- C.LSubLibName _ -> True --- C.LMainLibName -> False --- ) From f723d7ab153c34bad0be47844f19e773253d3971 Mon Sep 17 00:00:00 2001 From: theophilebatoz Date: Wed, 22 Nov 2023 18:16:06 +0000 Subject: [PATCH 12/18] fix: minor hlint and integration test issues --- src/Stack/Build.hs | 1 - tests/unit/Stack/PackageDumpSpec.hs | 8 ++++---- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index f8fbe2f001..2dd5f0b7b4 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | Build the project. diff --git a/tests/unit/Stack/PackageDumpSpec.hs b/tests/unit/Stack/PackageDumpSpec.hs index e292b76c89..1f91045551 100644 --- a/tests/unit/Stack/PackageDumpSpec.hs +++ b/tests/unit/Stack/PackageDumpSpec.hs @@ -95,7 +95,7 @@ spec = do haskell2010 { dpExposedModules = mempty } `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = packageIdent - , dpParentLibIdent = Nothing + , dpSublib = Nothing , dpLicense = Just BSD3 , dpLibDirs = ["/opt/ghc/7.8.4/lib/ghc-7.8.4/haskell2010-1.1.2.0"] , dpDepends = depends @@ -137,7 +137,7 @@ spec = do haskell2010 { dpExposedModules = mempty } `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = pkgIdent - , dpParentLibIdent = Nothing + , dpSublib = Nothing , dpLicense = Just BSD3 , dpLibDirs = ["/opt/ghc/7.10.1/lib/ghc-7.10.1/ghc_EMlWrQ42XY0BNVbSrKixqY"] , dpHaddockInterfaces = ["/opt/ghc/7.10.1/share/doc/ghc/html/libraries/ghc-7.10.1/ghc.haddock"] @@ -172,7 +172,7 @@ spec = do hmatrix `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = pkgId - , dpParentLibIdent = Nothing + , dpSublib = Nothing , dpLicense = Just BSD3 , dpLibDirs = [ "/Users/alexbiehl/.stack/snapshots/x86_64-osx/lts-2.13/7.8.4/lib/x86_64-osx-ghc-7.8.4/hmatrix-0.16.1.5" @@ -208,7 +208,7 @@ spec = do ghcBoot `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = pkgId - , dpParentLibIdent = Nothing + , dpSublib = Nothing , dpLicense = Just BSD3 , dpLibDirs = ["/opt/ghc/head/lib/ghc-7.11.20151213/ghc-boot-0.0.0.0"] From b5e5cb5c7a2613da12b018d055f4ec75f7987053 Mon Sep 17 00:00:00 2001 From: theophilebatoz Date: Wed, 22 Nov 2023 18:31:53 +0000 Subject: [PATCH 13/18] fix: .stan issues --- .stan.toml | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/.stan.toml b/.stan.toml index 9e43880d2f..fa023741b0 100644 --- a/.stan.toml +++ b/.stan.toml @@ -52,24 +52,25 @@ # Anti-pattern: Data.ByteString.Char8.pack [[ignore]] - id = "OBS-STAN-0203-fki0nd-1124:21" + id = "OBS-STAN-0203-fki0nd-1127:21" # ✦ Description: Usage of 'pack' function that doesn't handle Unicode characters -# ✦ Category: #AntiPattern -# ✦ File: src\Stack\Build\Execute.hs +# ✦ Category: #AntiPattern +# ✦ File: src\Stack\Build\Execute.hs # -# 1122 ┃ -# 1123 ┃ newProjectRoot <- S8.pack . toFilePath <$> view projectRootL -# 1124 ┃ ^^^^^^^ +# 1126 ┃ +# 1127 ┃ newProjectRoot <- S8.pack . toFilePath <$> view projectRootL +# 1128 ┃ ^^^^^^^ # Anti-pattern: Data.ByteString.Char8.pack [[ignore]] - id = "OBS-STAN-0203-fki0nd-2668:3" + id = "OBS-STAN-0203-fki0nd-2669:3" # ✦ Description: Usage of 'pack' function that doesn't handle Unicode characters # ✦ Category: #AntiPattern # ✦ File: src\Stack\Build\Execute.hs -# 2673 ┃ -# 2674 ┃ S8.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6Q" -# 2675 ┃ ^^^^^^^ +# +# 2668 ┃ +# 2669 ┃ S8.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6Q" +# 2670 ┃ ^^^^^^^ # Anti-pattern: Data.ByteString.Char8.pack [[ignore]] From 1d99feeb1ab4d5dfcf0f47a13e9e579d10795c1c Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Thu, 30 Nov 2023 23:48:28 +0000 Subject: [PATCH 14/18] Reformatting, for consistency --- .stan.toml | 19 ++++---- package.yaml | 2 + src/Stack/Build.hs | 3 +- src/Stack/Build/Cache.hs | 63 +++++++++++++----------- src/Stack/Build/ConstructPlan.hs | 32 +++++++------ src/Stack/Build/Execute.hs | 12 +++-- src/Stack/Build/Installed.hs | 66 ++++++++++++++++---------- src/Stack/Package.hs | 3 +- src/Stack/PackageDump.hs | 17 ++++--- src/Stack/SDist.hs | 6 +-- src/Stack/Types/Build/ConstructPlan.hs | 51 ++++++++++---------- src/Stack/Types/Component.hs | 2 +- src/Stack/Types/ComponentUtils.hs | 15 ++++-- src/Stack/Types/Dependency.hs | 19 ++++---- src/Stack/Types/DumpPackage.hs | 16 ++++--- src/Stack/Types/Package.hs | 59 ++++++++++++++++------- stack.cabal | 4 +- 17 files changed, 230 insertions(+), 159 deletions(-) diff --git a/.stan.toml b/.stan.toml index fa023741b0..743c68ab0b 100644 --- a/.stan.toml +++ b/.stan.toml @@ -28,6 +28,7 @@ id = "OBS-STAN-0102-luLR/n-522:30" # ✦ Category: #Infinite #List # ✦ File: src\Stack\New.hs +# # 522 ┃ # 523 ┃ let isPkgSpec f = ".cabal" `L.isSuffixOf` f || "package.yaml" `L.isSuffixOf` f # 524 ┃ ^^^^^^^^^^^^^^ @@ -38,6 +39,7 @@ id = "OBS-STAN-0102-luLR/n-522:65" # ✦ Category: #Infinite #List # ✦ File: src\Stack\New.hs +# # 522 ┃ # 523 ┃ let isPkgSpec f = ".cabal" `L.isSuffixOf` f || "package.yaml" `L.isSuffixOf` f # 524 ┃ ^^^^^^^^^^^^^^ @@ -52,25 +54,25 @@ # Anti-pattern: Data.ByteString.Char8.pack [[ignore]] - id = "OBS-STAN-0203-fki0nd-1127:21" + id = "OBS-STAN-0203-fki0nd-1128:21" # ✦ Description: Usage of 'pack' function that doesn't handle Unicode characters # ✦ Category: #AntiPattern # ✦ File: src\Stack\Build\Execute.hs # -# 1126 ┃ -# 1127 ┃ newProjectRoot <- S8.pack . toFilePath <$> view projectRootL -# 1128 ┃ ^^^^^^^ +# 1127 ┃ +# 1128 ┃ newProjectRoot <- S8.pack . toFilePath <$> view projectRootL +# 1129 ┃ ^^^^^^^ # Anti-pattern: Data.ByteString.Char8.pack [[ignore]] - id = "OBS-STAN-0203-fki0nd-2669:3" + id = "OBS-STAN-0203-fki0nd-2672:3" # ✦ Description: Usage of 'pack' function that doesn't handle Unicode characters # ✦ Category: #AntiPattern # ✦ File: src\Stack\Build\Execute.hs # -# 2668 ┃ -# 2669 ┃ S8.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6Q" -# 2670 ┃ ^^^^^^^ +# 2671 ┃ +# 2672 ┃ S8.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6Q" +# 2673 ┃ ^^^^^^^ # Anti-pattern: Data.ByteString.Char8.pack [[ignore]] @@ -78,6 +80,7 @@ # ✦ Description: Usage of 'pack' function that doesn't handle Unicode characters # ✦ Category: #AntiPattern # ✦ File: src\Stack\Init.hs +# # 378 ┃ # 379 ┃ commentHelp = BC.pack . intercalate "\n" . map commentLine # 380 ┃ ^^^^^^^ diff --git a/package.yaml b/package.yaml index caca06cc8d..1765d1b5c4 100644 --- a/package.yaml +++ b/package.yaml @@ -265,6 +265,7 @@ library: - Stack.Types.ApplyGhcOptions - Stack.Types.ApplyProgOptions - Stack.Types.Build + - Stack.Types.Build.ConstructPlan - Stack.Types.Build.Exception - Stack.Types.BuildConfig - Stack.Types.BuildOpts @@ -277,6 +278,7 @@ library: - Stack.Types.CompilerPaths - Stack.Types.Compiler - Stack.Types.Component + - Stack.Types.ComponentUtils - Stack.Types.Config - Stack.Types.Config.Exception - Stack.Types.ConfigMonoid diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 2dd5f0b7b4..a8bc72757b 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -62,7 +62,8 @@ import Stack.Types.GlobalOpts ( globalOptsBuildOptsMonoidL ) import Stack.Types.NamedComponent ( exeComponents ) import Stack.Types.Package ( InstallLocation (..), LocalPackage (..), Package (..) - , PackageConfig (..), lpFiles, lpFilesForComponents ) + , PackageConfig (..), lpFiles, lpFilesForComponents + ) import Stack.Types.Platform ( HasPlatform (..) ) import Stack.Types.Runner ( Runner, globalOptsL ) import Stack.Types.SourceMap diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index f713dfd922..da41c985ec 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -72,10 +72,11 @@ import Stack.Types.EnvConfig ) import Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString ) import Stack.Types.NamedComponent ( NamedComponent (..) ) +import Stack.Types.Package + (InstalledLibraryInfo (..), installedGhcPkgId ) import Stack.Types.SourceMap ( smRelDir ) import System.PosixCompat.Files ( modificationTime, getFileStatus, setFileTimes ) -import Stack.Types.Package (installedGhcPkgId, InstalledLibraryInfo (iliId)) -- | Directory containing files to mark an executable as installed exeInstalledDir :: (HasEnvConfig env) @@ -265,13 +266,9 @@ flagCacheKey installed = do case installed of Library _ installedInfo -> do let gid = iliId installedInfo - pure $ - configCacheKey installationRoot (ConfigCacheTypeFlagLibrary gid) - Executable ident -> - pure $ - configCacheKey - installationRoot - (ConfigCacheTypeFlagExecutable ident) + pure $ configCacheKey installationRoot (ConfigCacheTypeFlagLibrary gid) + Executable ident -> pure $ + configCacheKey installationRoot (ConfigCacheTypeFlagExecutable ident) -- | Loads the flag cache for the given installed extra-deps tryGetFlagCache :: HasEnvConfig env @@ -380,26 +377,36 @@ writePrecompiledCache :: -> [GhcPkgId] -- ^ sub-libraries, in the GhcPkgId format -> Set Text -- ^ executables -> RIO env () -writePrecompiledCache baseConfigOpts loc copts buildHaddocks mghcPkgId subLibs exes = do - key <- getPrecompiledCacheKey loc copts buildHaddocks - ec <- view envConfigL - let stackRootRelative = makeRelative (view stackRootL ec) - mlibpath <- traverse (pathFromPkgId stackRootRelative) (installedGhcPkgId mghcPkgId) - subLibPaths <- mapM (pathFromPkgId stackRootRelative) subLibs - exes' <- forM (Set.toList exes) $ \exe -> do - name <- parseRelFile $ T.unpack exe - stackRootRelative $ bcoSnapInstallRoot baseConfigOpts bindirSuffix name - let precompiled = PrecompiledCache - { pcLibrary = mlibpath - , pcSubLibs = subLibPaths - , pcExes = exes' - } - savePrecompiledCache key precompiled - -- reuse precompiled cache with haddocks also in case when haddocks are not - -- required - when buildHaddocks $ do - key' <- getPrecompiledCacheKey loc copts False - savePrecompiledCache key' precompiled +writePrecompiledCache + baseConfigOpts + loc + copts + buildHaddocks + mghcPkgId + subLibs + exes + = do + key <- getPrecompiledCacheKey loc copts buildHaddocks + ec <- view envConfigL + let stackRootRelative = makeRelative (view stackRootL ec) + mlibpath <- + traverse (pathFromPkgId stackRootRelative) (installedGhcPkgId mghcPkgId) + subLibPaths <- mapM (pathFromPkgId stackRootRelative) subLibs + exes' <- forM (Set.toList exes) $ \exe -> do + name <- parseRelFile $ T.unpack exe + stackRootRelative $ + bcoSnapInstallRoot baseConfigOpts bindirSuffix name + let precompiled = PrecompiledCache + { pcLibrary = mlibpath + , pcSubLibs = subLibPaths + , pcExes = exes' + } + savePrecompiledCache key precompiled + -- reuse precompiled cache with haddocks also in case when haddocks are + -- not required + when buildHaddocks $ do + key' <- getPrecompiledCacheKey loc copts False + savePrecompiledCache key' precompiled where pathFromPkgId stackRootRelative ipid = do ipid' <- parseRelFile $ ghcPkgIdString ipid ++ ".conf" diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index acfaed94af..2b70c9700d 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -27,8 +27,8 @@ import Stack.Build.Haddock ( shouldHaddockDeps ) import Stack.Build.Source ( loadLocalPackage ) import Stack.Constants ( compilerOptionsCabalFlag ) import Stack.Package - ( applyForceCustomBuild, buildableExes - , packageUnknownTools, processPackageDepsToList + ( applyForceCustomBuild, buildableExes, packageUnknownTools + , processPackageDepsToList ) import Stack.Prelude hiding ( loadPackage ) import Stack.SourceMap ( getPLIVersion, mkProjectPackage ) @@ -38,6 +38,11 @@ import Stack.Types.Build , installLocationIsMutable, taskIsTarget, taskLocation , taskProvides, taskTargetIsMutable, toCachePkgSrc ) +import Stack.Types.Build.ConstructPlan + ( AddDepRes (..), CombinedMap, Ctx (..), M, NotOnlyLocal (..) + , PackageInfo (..), ToolWarning(..), UnregisterState (..) + , W (..), adrHasLibrary, adrVersion, toTask + ) import Stack.Types.Build.Exception ( BadDependency (..), BuildException (..) , BuildPrettyException (..), ConstructPlanException (..) @@ -53,16 +58,10 @@ import Stack.Types.CompilerPaths import Stack.Types.Config ( Config (..), HasConfig (..), stackRootL ) import Stack.Types.ConfigureOpts ( BaseConfigOpts (..), ConfigureOpts (..), configureOpts ) -import Stack.Types.Build.ConstructPlan - ( UnregisterState(..), NotOnlyLocal(NotOnlyLocal), ToolWarning(..), - Ctx(..), M, CombinedMap, AddDepRes(..), - W(..), PackageInfo(..), toTask, adrVersion, adrHasLibrary - ) import Stack.Types.Curator ( Curator (..) ) import Stack.Types.Dependency ( DepValue (..), isDepTypeLibrary ) import Stack.Types.DumpPackage ( DumpPackage (..), dpParentLibIdent ) -import Stack.Types.EnvConfig - ( EnvConfig (..), HasEnvConfig (..) ) +import Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..) ) import Stack.Types.EnvSettings ( EnvSettings (..), minimalEnvSettings ) import Stack.Types.GhcPkgId ( GhcPkgId ) @@ -72,8 +71,8 @@ import Stack.Types.NamedComponent ( exeComponents, renderComponent ) import Stack.Types.Package ( ExeName (..), InstallLocation (..), Installed (..) , InstalledMap, LocalPackage (..), Package (..) - , PackageSource (..), installedVersion, packageIdentifier - , psVersion, runMemoizedWith, installedMapGhcPkgId + , PackageSource (..), installedMapGhcPkgId, installedVersion + , packageIdentifier, psVersion, runMemoizedWith ) import Stack.Types.ProjectConfig ( isPCGlobalProject ) import Stack.Types.Runner ( HasRunner (..), globalOptsL ) @@ -82,7 +81,9 @@ import Stack.Types.SourceMap , GlobalPackage (..), SMTargets (..), SourceMap (..) ) import Stack.Types.Version - ( latestApplicableVersion, versionRangeText, withinRange, VersionRange ) + ( VersionRange, latestApplicableVersion, versionRangeText + , withinRange + ) import System.Environment ( lookupEnv ) -- | Computes a build plan. This means figuring out which build 'Task's to take, @@ -986,7 +987,10 @@ processAdr adr = case adr of ADRFound loc (Executable _) -> (Set.empty, Map.empty, installLocationIsMutable loc) ADRFound loc (Library ident installedInfo) -> - (Set.empty, installedMapGhcPkgId ident installedInfo, installLocationIsMutable loc) + ( Set.empty + , installedMapGhcPkgId ident installedInfo + , installLocationIsMutable loc + ) checkDirtiness :: PackageSource @@ -1235,4 +1239,4 @@ combineMap :: Map PackageName PackageSource -> InstalledMap -> CombinedMap combineMap = Map.merge (Map.mapMissing (\_ s -> PIOnlySource s)) (Map.mapMissing (\_ i -> uncurry PIOnlyInstalled i)) - (Map.zipWithMatched (\_ s i -> combineSourceInstalled s i)) \ No newline at end of file + (Map.zipWithMatched (\_ s i -> combineSourceInstalled s i)) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index e2237b68bc..c5ea45acfd 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -150,7 +150,7 @@ import Stack.Types.BuildOpts ) import Stack.Types.CompCollection ( collectionKeyValueList, collectionLookup - , getBuildableListText, getBuildableListAs + , getBuildableListAs, getBuildableListText ) import Stack.Types.Compiler ( ActualCompiler (..), WhichCompiler (..) @@ -184,10 +184,12 @@ import Stack.Types.NamedComponent , isCTest, renderComponent, testComponents ) import Stack.Types.Package - ( InstallLocation (..), Installed (..), InstalledMap - , LocalPackage (..), Package (..), InstalledLibraryInfo (..) - , installedPackageIdentifier, packageIdentifier, runMemoizedWith - , installedMapGhcPkgId, toCabalMungedPackageName, simpleInstalledLib + ( InstallLocation (..), Installed (..) + , InstalledLibraryInfo (..), InstalledMap, LocalPackage (..) + , Package (..), installedMapGhcPkgId + , installedPackageIdentifier, packageIdentifier + , runMemoizedWith, simpleInstalledLib + , toCabalMungedPackageName ) import Stack.Types.PackageFile ( PackageWarning (..) ) import Stack.Types.Platform ( HasPlatform (..) ) diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index 958bff0b31..655f08695b 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -10,6 +10,7 @@ module Stack.Build.Installed import Data.Conduit ( ZipSink (..), getZipSink ) import qualified Data.Conduit.List as CL +import Data.Foldable ( Foldable (..) ) import qualified Data.Set as Set import qualified Data.Map.Strict as Map import Stack.Build.Cache ( getInstalledExes ) @@ -19,7 +20,10 @@ import Stack.PackageDump import Stack.Prelude import Stack.SourceMap ( getPLIVersion, loadVersion ) import Stack.Types.CompilerPaths ( getGhcPkgExe ) -import Stack.Types.DumpPackage ( DumpPackage (..), dpParentLibIdent, SublibDump (..), sdPackageName ) +import Stack.Types.DumpPackage + ( DumpPackage (..), SublibDump (..), dpParentLibIdent + , sdPackageName + ) import Stack.Types.EnvConfig ( HasEnvConfig, packageDatabaseDeps, packageDatabaseExtra , packageDatabaseLocal @@ -27,13 +31,12 @@ import Stack.Types.EnvConfig import Stack.Types.GhcPkgId ( GhcPkgId ) import Stack.Types.Package ( InstallLocation (..), InstallMap, Installed (..) - , InstalledMap, InstalledPackageLocation (..) - , PackageDatabase (..), PackageDbVariety (..) - , toPackageDbVariety, InstalledLibraryInfo (InstalledLibraryInfo, iliSublib, iliId) + , InstalledLibraryInfo (..), InstalledMap + , InstalledPackageLocation (..), PackageDatabase (..) + , PackageDbVariety (..), toPackageDbVariety ) import Stack.Types.SourceMap ( DepPackage (..), ProjectPackage (..), SourceMap (..) ) -import Data.Foldable (Foldable(..)) toInstallMap :: MonadIO m => SourceMap -> m InstallMap toInstallMap sourceMap = do @@ -76,7 +79,8 @@ getInstalled {-opts-} installMap = do loadDatabase' (UserPkgDb (InstalledTo Snap) snapDBPath) installedLibs1 (installedLibs3, localDumpPkgs) <- loadDatabase' (UserPkgDb (InstalledTo Local) localDBPath) installedLibs2 - let installedLibs = foldr' gatherAndTransformSubLoadHelper mempty installedLibs3 + let installedLibs = + foldr' gatherAndTransformSubLoadHelper mempty installedLibs3 -- Add in the executables that are installed, making sure to only trust a -- listed installation under the right circumstances (see below) @@ -280,27 +284,39 @@ toLoadHelper pkgDb dp = LoadHelper toInstallLocation WriteOnlyDb = Snap toInstallLocation MutableDb = Local --- | This is where sublibraries and main libraries are assembled into --- a single entity Installed package, where all ghcPkgId live. +-- | This is where sublibraries and main libraries are assembled into a single +-- entity Installed package, where all ghcPkgId live. gatherAndTransformSubLoadHelper :: - LoadHelper + LoadHelper -> Map PackageName (InstallLocation, Installed) -> Map PackageName (InstallLocation, Installed) gatherAndTransformSubLoadHelper lh = Map.insertWith onPreviousLoadHelper key value - where - -- here we assume that both have the same location - -- which already was a prior assumption in stack - onPreviousLoadHelper (pLoc, Library pn incomingLibInfo) (_, Library _ existingLibInfo) = - (pLoc, Library pn existingLibInfo{ - iliSublib=Map.union (iliSublib incomingLibInfo) (iliSublib existingLibInfo), - iliId=if isJust $ lhSublibrary lh then iliId existingLibInfo else iliId incomingLibInfo - }) - onPreviousLoadHelper newVal _oldVal = newVal - (key, value) = case lhSublibrary lh of - Nothing -> (rawPackageName, rawValue) - Just sd -> (sdPackageName sd, updateAsSublib sd <$> rawValue) - (rawPackageName, rawValue) = lhPair lh - updateAsSublib sd (Library (PackageIdentifier _sublibMungedPackageName version) libInfo) = - Library (PackageIdentifier key version) libInfo{iliSublib=Map.singleton (sdLibraryName sd) (iliId libInfo)} - updateAsSublib _ v = v + where + -- Here we assume that both have the same location which already was a prior + -- assumption in Stack. + onPreviousLoadHelper + (pLoc, Library pn incomingLibInfo) + (_, Library _ existingLibInfo) + = ( pLoc + , Library pn existingLibInfo + { iliSublib = Map.union + (iliSublib incomingLibInfo) + (iliSublib existingLibInfo) + , iliId = if isJust $ lhSublibrary lh + then iliId existingLibInfo + else iliId incomingLibInfo + } + ) + onPreviousLoadHelper newVal _oldVal = newVal + (key, value) = case lhSublibrary lh of + Nothing -> (rawPackageName, rawValue) + Just sd -> (sdPackageName sd, updateAsSublib sd <$> rawValue) + (rawPackageName, rawValue) = lhPair lh + updateAsSublib + sd + (Library (PackageIdentifier _sublibMungedPackageName version) libInfo) + = Library + (PackageIdentifier key version) + libInfo {iliSublib = Map.singleton (sdLibraryName sd) (iliId libInfo)} + updateAsSublib _ v = v diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 25215a03ca..0c4e309d93 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -99,7 +99,8 @@ import Stack.Types.Package ( BioInput(..), BuildInfoOpts (..), InstallMap , Installed (..), InstalledMap, Package (..) , PackageConfig (..), PackageException (..) - , dotCabalCFilePath, packageIdentifier, installedToPackageIdOpt + , dotCabalCFilePath, installedToPackageIdOpt + , packageIdentifier ) import Stack.Types.PackageFile ( DotCabalPath, PackageComponentFile (..) ) diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index 6b029c87e3..d8bab5e00c 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -21,17 +21,18 @@ import qualified Data.Conduit.Text as CT import qualified Data.Map as Map import qualified Data.Set as Set import qualified Distribution.Text as C +import Distribution.Types.MungedPackageName + ( decodeCompatPackageName ) import Path.Extra ( toFilePathNoTrailingSep ) import RIO.Process ( HasProcessContext ) import qualified RIO.Text as T +import Stack.Component ( fromCabalName ) import Stack.GhcPkg ( createDatabase ) import Stack.Prelude import Stack.Types.CompilerPaths ( GhcPkgExe (..), HasCompiler (..) ) +import Stack.Types.Component ( StackUnqualCompName(..) ) import Stack.Types.DumpPackage ( DumpPackage (..), SublibDump (..) ) import Stack.Types.GhcPkgId ( GhcPkgId, parseGhcPkgId ) -import Stack.Types.Component (StackUnqualCompName(..)) -import Distribution.Types.MungedPackageName (decodeCompatPackageName) -import Stack.Component (fromCabalName) -- | Type representing exceptions thrown by functions exported by the -- "Stack.PackageDump" module. @@ -227,13 +228,15 @@ conduitDumpPackage = (.| CL.catMaybes) $ eachSection $ do -- Handle sub-libraries by recording the name of the parent library -- If name of parent library is missing, this is not a sub-library. - let maybePackageName :: Maybe PackageName = parseS "package-name" >>= - parsePackageNameThrowing . T.unpack + let maybePackageName :: Maybe PackageName = + parseS "package-name" >>= parsePackageNameThrowing . T.unpack let maybeLibName = parseS "lib-name" let getLibNameFromLegacyName = case decodeCompatPackageName name of - MungedPackageName _parentPackageName (LSubLibName libName) -> fromCabalName libName + MungedPackageName _parentPackageName (LSubLibName libName) -> + fromCabalName libName MungedPackageName _parentPackageName _ -> "" - let libName = maybe getLibNameFromLegacyName StackUnqualCompName maybeLibName + let libName = + maybe getLibNameFromLegacyName StackUnqualCompName maybeLibName let subLibDump = flip SublibDump libName <$> maybePackageName let parseQuoted key = case mapM (P.parseOnly (argsParser NoEscaping)) val of diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 274f8bbad6..8990c6ccd5 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -70,9 +70,9 @@ import Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL ) import Stack.Types.GhcPkgId ( GhcPkgId ) import Stack.Types.Package - ( InstallMap, Installed (..), InstalledLibraryInfo (..), InstalledMap, - LocalPackage (..), Package (..), PackageConfig (..), installedVersion - , packageIdentifier + ( InstallMap, Installed (..), InstalledLibraryInfo (..) + , InstalledMap, LocalPackage (..), Package (..) + , PackageConfig (..), installedVersion, packageIdentifier ) import Stack.Types.Platform ( HasPlatform (..) ) import Stack.Types.PvpBounds ( PvpBounds (..), PvpBoundsType (..) ) diff --git a/src/Stack/Types/Build/ConstructPlan.hs b/src/Stack/Types/Build/ConstructPlan.hs index 2592e511f9..5ef6cf523b 100644 --- a/src/Stack/Types/Build/ConstructPlan.hs +++ b/src/Stack/Types/Build/ConstructPlan.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude #-} module Stack.Types.Build.ConstructPlan - ( NotOnlyLocal(..) - , ToolWarning(..) - , UnregisterState(..) - , AddDepRes(..) - , W(..) - , Ctx(..) + ( NotOnlyLocal (..) + , ToolWarning (..) + , UnregisterState (..) + , AddDepRes (..) + , W (..) + , Ctx (..) , M - , PackageInfo(..) + , PackageInfo (..) , CombinedMap , toTask , adrVersion @@ -17,27 +17,27 @@ module Stack.Types.Build.ConstructPlan import qualified Data.List as L import qualified Data.Text as T +import Generics.Deriving.Monoid ( mappenddefault, memptydefault ) +import RIO.Process ( HasProcessContext (..) ) +import RIO.State +import RIO.Writer ( WriterT (..) ) +import Stack.Package ( hasBuildableMainLibrary ) import Stack.Prelude hiding ( loadPackage ) +import Stack.Types.Build +import Stack.Types.Build.Exception ( ConstructPlanException ) +import Stack.Types.BuildConfig +import Stack.Types.CompilerPaths +import Stack.Types.Config ( HasConfig (..) ) +import Stack.Types.ConfigureOpts +import Stack.Types.Curator import Stack.Types.DumpPackage ( DumpPackage ) -import Stack.Types.GhcPkgId (GhcPkgId) -import Stack.Types.Package import Stack.Types.EnvConfig -import Stack.Types.CompilerPaths -import Stack.Types.BuildConfig -import RIO.Process (HasProcessContext (processContextL)) -import Stack.Types.Config (HasConfig (configL)) -import Stack.Types.Runner +import Stack.Types.GhcPkgId ( GhcPkgId ) import Stack.Types.GHCVariant -import Stack.Types.Platform -import Stack.Types.Curator -import Stack.Types.ConfigureOpts -import Stack.Types.Build.Exception (ConstructPlanException) -import RIO.State -import Stack.Types.Build +import Stack.Types.Package import Stack.Types.ParentMap -import RIO.Writer ( WriterT (..) ) -import Generics.Deriving.Monoid (memptydefault, mappenddefault) -import Stack.Package (hasBuildableMainLibrary) +import Stack.Types.Platform +import Stack.Types.Runner -- | Type representing information about packages, namely information about @@ -213,7 +213,6 @@ data UnregisterState = UnregisterState , usAnyAdded :: !Bool } - data NotOnlyLocal = NotOnlyLocal [PackageName] [Text] deriving (Show, Typeable) @@ -238,4 +237,4 @@ instance Exception NotOnlyLocal where -- expected and the package name using it. data ToolWarning = ToolWarning ExeName PackageName - deriving Show \ No newline at end of file + deriving Show diff --git a/src/Stack/Types/Component.hs b/src/Stack/Types/Component.hs index de3ac598a7..2cc5ac602f 100644 --- a/src/Stack/Types/Component.hs +++ b/src/Stack/Types/Component.hs @@ -31,8 +31,8 @@ import Distribution.Simple ( Extension, Language ) import Distribution.Utils.Path ( PackageDir, SourceDir, SymbolicPath ) import GHC.Records ( HasField ) import Stack.Prelude +import Stack.Types.ComponentUtils ( StackUnqualCompName (..) ) import Stack.Types.Dependency ( DepValue ) -import Stack.Types.ComponentUtils ( StackUnqualCompName(..) ) -- | A type representing (unnamed) main library or sub-library components of a -- package. diff --git a/src/Stack/Types/ComponentUtils.hs b/src/Stack/Types/ComponentUtils.hs index cd3ba010c9..180755cad5 100644 --- a/src/Stack/Types/ComponentUtils.hs +++ b/src/Stack/Types/ComponentUtils.hs @@ -17,9 +17,12 @@ module Stack.Types.ComponentUtils , toCabalName ) where -import Distribution.PackageDescription (UnqualComponentName, unUnqualComponentName, mkUnqualComponentName) +import Distribution.PackageDescription + ( UnqualComponentName, mkUnqualComponentName + , unUnqualComponentName + ) +import RIO.Text (pack, unpack) import Stack.Prelude -import RIO.Text (pack, unpack) -- | Type representing the name of an \'unqualified\' component (that is, the -- component can be any sort - a (unnamed) main library or sub-library, @@ -31,8 +34,10 @@ import RIO.Text (pack, unpack) -- Ideally, we would use the Cabal-syntax type and not 'Text', to avoid -- unnecessary work, but there is no 'Hashable' instance for -- 'Distribution.Types.UnqualComponentName.UnqualComponentName' yet. -newtype StackUnqualCompName = StackUnqualCompName {unqualCompToText :: Text} - deriving (Data, Eq, Hashable, IsString, Generic, NFData, Ord, Show, Typeable, Read) +newtype StackUnqualCompName = StackUnqualCompName + { unqualCompToText :: Text + } + deriving (Data, Eq, Generic, Hashable, IsString, NFData, Ord, Read, Show, Typeable) fromCabalName :: UnqualComponentName -> StackUnqualCompName fromCabalName unqualName = @@ -40,4 +45,4 @@ fromCabalName unqualName = toCabalName :: StackUnqualCompName -> UnqualComponentName toCabalName (StackUnqualCompName unqualName) = - mkUnqualComponentName (unpack unqualName) \ No newline at end of file + mkUnqualComponentName (unpack unqualName) diff --git a/src/Stack/Types/Dependency.hs b/src/Stack/Types/Dependency.hs index 12d05ee5e2..bd60bce83a 100644 --- a/src/Stack/Types/Dependency.hs +++ b/src/Stack/Types/Dependency.hs @@ -13,11 +13,12 @@ module Stack.Types.Dependency import Data.Foldable ( foldr' ) import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Distribution.PackageDescription as Cabal import Distribution.Types.VersionRange ( VersionRange ) import Stack.Prelude -import Stack.Types.ComponentUtils ( StackUnqualCompName(..), fromCabalName ) -import qualified Data.Set as Set +import Stack.Types.ComponentUtils + ( StackUnqualCompName (..), fromCabalName ) -- | The value for a map from dependency name. This contains both the version -- range and the type of dependency. @@ -34,6 +35,7 @@ data DepType = AsLibrary !DepLibrary | AsBuildTool deriving (Eq, Show) + data DepLibrary = DepLibrary { dlMain :: !Bool , dlSublib :: Set StackUnqualCompName @@ -55,12 +57,13 @@ isDepTypeLibrary AsBuildTool = False cabalToStackDep :: Cabal.Dependency -> DepValue cabalToStackDep (Cabal.Dependency _ verRange libNameSet) = DepValue{dvVersionRange = verRange, dvType = AsLibrary depLibrary} - where - depLibrary = DepLibrary finalHasMain filteredItems - (finalHasMain, filteredItems) = foldr' iterator (False, mempty) libNameSet - iterator LMainLibName (_, newLibNameSet) = (True, newLibNameSet) - iterator (LSubLibName libName) (hasMain, newLibNameSet) = (hasMain, Set.insert (fromCabalName libName) newLibNameSet) - + where + depLibrary = DepLibrary finalHasMain filteredItems + (finalHasMain, filteredItems) = foldr' iterator (False, mempty) libNameSet + iterator LMainLibName (_, newLibNameSet) = (True, newLibNameSet) + iterator (LSubLibName libName) (hasMain, newLibNameSet) = + (hasMain, Set.insert (fromCabalName libName) newLibNameSet) + cabalExeToStackDep :: Cabal.ExeDependency -> DepValue cabalExeToStackDep (Cabal.ExeDependency _ _name verRange) = DepValue{dvVersionRange = verRange, dvType = AsBuildTool} diff --git a/src/Stack/Types/DumpPackage.hs b/src/Stack/Types/DumpPackage.hs index f63622218e..001b091203 100644 --- a/src/Stack/Types/DumpPackage.hs +++ b/src/Stack/Types/DumpPackage.hs @@ -9,7 +9,7 @@ module Stack.Types.DumpPackage import qualified Distribution.License as C import Distribution.ModuleName ( ModuleName ) import Stack.Prelude -import Stack.Types.Component (StackUnqualCompName) +import Stack.Types.Component ( StackUnqualCompName ) import Stack.Types.GhcPkgId ( GhcPkgId ) -- | Type representing dump information for a single package, as output by the @@ -38,18 +38,20 @@ data DumpPackage = DumpPackage } deriving (Eq, Read, Show) --- | --- ghc-pkg has a notion of sublibraries when using ghc-kg dump. --- We can only know it's different through the fields it shows. +-- | ghc-pkg has a notion of sublibraries when using ghc-pkg dump. We can only +-- know it's different through the fields it shows. data SublibDump = SublibDump { sdPackageName :: PackageName - -- ^ "package-name" field from ghc-pkg + -- ^ "package-name" field from ghc-pkg , sdLibraryName :: StackUnqualCompName - -- ^ "lib-name" field from ghc-pkg + -- ^ "lib-name" field from ghc-pkg } deriving (Eq, Read, Show) dpParentLibIdent :: DumpPackage -> Maybe PackageIdentifier dpParentLibIdent dp = case (dpSublib dp, dpPackageIdent dp) of (Nothing, _) -> Nothing - (Just SublibDump{sdPackageName=libParentPackageName}, PackageIdentifier _ v) -> Just $ PackageIdentifier libParentPackageName v + (Just sublibDump, PackageIdentifier _ v) -> + Just $ PackageIdentifier libParentPackageName v + where + SublibDump { sdPackageName = libParentPackageName } = sublibDump diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 3e7cccec57..4afebf5186 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -57,13 +57,16 @@ import Distribution.License ( License ) import Distribution.ModuleName ( ModuleName ) import Distribution.PackageDescription ( BuildType ) import Distribution.System ( Platform (..) ) +import Distribution.Types.MungedPackageName + ( encodeCompatPackageName ) import qualified RIO.Text as T import Stack.Prelude import Stack.Types.CompCollection ( CompCollection ) import Stack.Types.Compiler ( ActualCompiler ) import Stack.Types.Component ( StackBenchmark, StackBuildInfo, StackExecutable - , StackForeignLibrary, StackLibrary, StackTestSuite, StackUnqualCompName + , StackForeignLibrary, StackLibrary, StackTestSuite + , StackUnqualCompName ) import Stack.Types.ComponentUtils (toCabalName) import Stack.Types.Dependency ( DepValue ) @@ -75,7 +78,6 @@ import Stack.Types.PackageFile , StackPackageFile ) import Stack.Types.SourceMap ( CommonPackage, FromSnapshot ) -import Distribution.Types.MungedPackageName (encodeCompatPackageName) -- | Type representing exceptions thrown by functions exported by the -- "Stack.Package" module. @@ -474,20 +476,27 @@ data InstalledLibraryInfo = InstalledLibraryInfo deriving (Eq, Show) installedLibraryInfoFromGhcPkgId :: GhcPkgId -> InstalledLibraryInfo -installedLibraryInfoFromGhcPkgId ghcPkgId = InstalledLibraryInfo ghcPkgId Nothing mempty +installedLibraryInfoFromGhcPkgId ghcPkgId = + InstalledLibraryInfo ghcPkgId Nothing mempty -simpleInstalledLib :: PackageIdentifier -> GhcPkgId -> Map StackUnqualCompName GhcPkgId -> Installed -simpleInstalledLib pkgIdentifier ghcPkgId = Library pkgIdentifier . InstalledLibraryInfo ghcPkgId Nothing +simpleInstalledLib :: + PackageIdentifier + -> GhcPkgId + -> Map StackUnqualCompName GhcPkgId + -> Installed +simpleInstalledLib pkgIdentifier ghcPkgId = + Library pkgIdentifier . InstalledLibraryInfo ghcPkgId Nothing installedToPackageIdOpt :: InstalledLibraryInfo -> [String] -installedToPackageIdOpt libInfo = M.foldr' (iterator (++)) (pure $ toStr (iliId libInfo)) (iliSublib libInfo) - where - toStr ghcPkgId = "-package-id=" <> ghcPkgIdString ghcPkgId - iterator op ghcPkgId acc = pure (toStr ghcPkgId) `op` acc +installedToPackageIdOpt libInfo = + M.foldr' (iterator (++)) (pure $ toStr (iliId libInfo)) (iliSublib libInfo) + where + toStr ghcPkgId = "-package-id=" <> ghcPkgIdString ghcPkgId + iterator op ghcPkgId acc = pure (toStr ghcPkgId) `op` acc -- | Type representing information about what is installed. data Installed - = Library PackageIdentifier InstalledLibraryInfo + = Library PackageIdentifier InstalledLibraryInfo -- ^ A library, including its installed package id and, optionally, its -- license. | Executable PackageIdentifier @@ -509,19 +518,33 @@ installedVersion i = in version -- | Gathers all the GhcPkgId provided by a library into a map -installedMapGhcPkgId :: PackageIdentifier -> InstalledLibraryInfo -> Map PackageIdentifier GhcPkgId -installedMapGhcPkgId pkgId@(PackageIdentifier pkgName version) installedLib = finalMap - where - finalMap = M.insert pkgId (iliId installedLib) baseMap - baseMap = M.mapKeysMonotonic (toCabalMungedPackageIdentifier pkgName version) $ iliSublib installedLib +installedMapGhcPkgId :: + PackageIdentifier + -> InstalledLibraryInfo + -> Map PackageIdentifier GhcPkgId +installedMapGhcPkgId pkgId@(PackageIdentifier pkgName version) installedLib = + finalMap + where + finalMap = M.insert pkgId (iliId installedLib) baseMap + baseMap = + M.mapKeysMonotonic (toCabalMungedPackageIdentifier pkgName version) $ + iliSublib installedLib -- | Creates a 'MungedPackageName' identifier. -toCabalMungedPackageIdentifier :: PackageName -> Version -> StackUnqualCompName -> PackageIdentifier +toCabalMungedPackageIdentifier :: + PackageName + -> Version + -> StackUnqualCompName + -> PackageIdentifier toCabalMungedPackageIdentifier pkgName version = flip PackageIdentifier version . encodeCompatPackageName . toCabalMungedPackageName pkgName -toCabalMungedPackageName :: PackageName -> StackUnqualCompName -> MungedPackageName -toCabalMungedPackageName pkgName = MungedPackageName pkgName . LSubLibName . toCabalName +toCabalMungedPackageName :: + PackageName + -> StackUnqualCompName + -> MungedPackageName +toCabalMungedPackageName pkgName = + MungedPackageName pkgName . LSubLibName . toCabalName -- | Type representing inputs to 'Stack.Package.generateBuildInfoOpts'. data BioInput = BioInput diff --git a/stack.cabal b/stack.cabal index 434ae66fbf..e72dbd4da5 100644 --- a/stack.cabal +++ b/stack.cabal @@ -259,6 +259,7 @@ library Stack.Types.ApplyGhcOptions Stack.Types.ApplyProgOptions Stack.Types.Build + Stack.Types.Build.ConstructPlan Stack.Types.Build.Exception Stack.Types.BuildConfig Stack.Types.BuildOpts @@ -271,6 +272,7 @@ library Stack.Types.CompilerPaths Stack.Types.Compiler Stack.Types.Component + Stack.Types.ComponentUtils Stack.Types.Config Stack.Types.Config.Exception Stack.Types.ConfigMonoid @@ -330,8 +332,6 @@ library other-modules: GHC.Utils.GhcPkg.Main.Compat Stack.Config.ConfigureScript - Stack.Types.Build.ConstructPlan - Stack.Types.ComponentUtils Stack.Types.FileDigestCache autogen-modules: Build_stack From d233ea61a7ab0a20604a75f9bac3e60f309fa064 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Fri, 1 Dec 2023 00:27:36 +0000 Subject: [PATCH 15/18] Update change log --- ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 51b9192b1c..35b4ab56df 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -4,6 +4,8 @@ Release notes: +* After an upgrade from an earlier version of Stack, on first use only, + Stack 2.14.0 may warn that it had trouble loading the CompilerPaths cache. * The hash used as a key for Stack's pre-compiled package cache has changed, following the dropping of support for Cabal versions older than `1.24.0.0`. @@ -28,6 +30,8 @@ Behavior changes: Other enhancements: * Consider GHC 9.8 to be a tested compiler and remove warnings. +* Stack can build packages with dependencies on public sub-libraries of other + packages. * Add flag `--no-init` to Stack's `new` command to skip the initialisation of the newly-created project for use with Stack. * The HTML file paths produced at the end of `stack haddock` are printed on From 20d485f6a2e72b262eee6ec18a6a487cd6a6d225 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Fri, 1 Dec 2023 14:07:56 +0000 Subject: [PATCH 16/18] Add explicit import lists --- src/Stack/Types/Build/ConstructPlan.hs | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/src/Stack/Types/Build/ConstructPlan.hs b/src/Stack/Types/Build/ConstructPlan.hs index 5ef6cf523b..c17a718803 100644 --- a/src/Stack/Types/Build/ConstructPlan.hs +++ b/src/Stack/Types/Build/ConstructPlan.hs @@ -19,26 +19,32 @@ import qualified Data.List as L import qualified Data.Text as T import Generics.Deriving.Monoid ( mappenddefault, memptydefault ) import RIO.Process ( HasProcessContext (..) ) -import RIO.State +import RIO.State ( StateT ) import RIO.Writer ( WriterT (..) ) import Stack.Package ( hasBuildableMainLibrary ) import Stack.Prelude hiding ( loadPackage ) import Stack.Types.Build + ( Task (..), TaskType (..), taskProvides ) import Stack.Types.Build.Exception ( ConstructPlanException ) import Stack.Types.BuildConfig -import Stack.Types.CompilerPaths + ( BuildConfig (..), HasBuildConfig(..) ) +import Stack.Types.CompilerPaths ( HasCompiler (..) ) import Stack.Types.Config ( HasConfig (..) ) -import Stack.Types.ConfigureOpts -import Stack.Types.Curator +import Stack.Types.ConfigureOpts ( BaseConfigOpts ) +import Stack.Types.Curator ( Curator ) import Stack.Types.DumpPackage ( DumpPackage ) import Stack.Types.EnvConfig + ( EnvConfig (..), HasEnvConfig (..), HasSourceMap (..) ) import Stack.Types.GhcPkgId ( GhcPkgId ) -import Stack.Types.GHCVariant +import Stack.Types.GHCVariant ( HasGHCVariant (..) ) import Stack.Types.Package -import Stack.Types.ParentMap -import Stack.Types.Platform -import Stack.Types.Runner - + ( ExeName (..), InstallLocation, Installed (..) + , LocalPackage (..), Package (..), PackageSource (..) + , installedVersion + ) +import Stack.Types.ParentMap ( ParentMap ) +import Stack.Types.Platform ( HasPlatform (..) ) +import Stack.Types.Runner ( HasRunner (..) ) -- | Type representing information about packages, namely information about -- whether or not a package is already installed and, unless the package is not From 1ec13c49dd85c12f1598bf051972c1fdf355da2e Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Fri, 1 Dec 2023 14:29:06 +0000 Subject: [PATCH 17/18] Make S-1727 a BuildPrettyException, and document it --- doc/maintainers/stack_errors.md | 5 +++-- src/Stack/Build/ConstructPlan.hs | 8 ++++---- src/Stack/Types/Build/ConstructPlan.hs | 25 +------------------------ src/Stack/Types/Build/Exception.hs | 24 ++++++++++++++++++++++++ 4 files changed, 32 insertions(+), 30 deletions(-) diff --git a/doc/maintainers/stack_errors.md b/doc/maintainers/stack_errors.md index 5956c4ac62..6e4683a3d7 100644 --- a/doc/maintainers/stack_errors.md +++ b/doc/maintainers/stack_errors.md @@ -375,14 +375,15 @@ to take stock of the errors that Stack itself can raise, by reference to the - `Stack.Types.Build.BuildPrettyException` ~~~haskell - [S-4804] | ConstructPlanFailed [ConstructPlanException] (Path Abs File) (Path Abs Dir) ParentMap (Set PackageName) (Map PackageName [PackageName]) + [S-4804] = ConstructPlanFailed [ConstructPlanException] (Path Abs File) (Path Abs Dir) ParentMap (Set PackageName) (Map PackageName [PackageName]) [S-7282] | ExecutionFailure [SomeException] [S-7011] | CabalExitedUnsuccessfully ExitCode PackageIdentifier (Path Abs File) [String] (Maybe (Path Abs File)) [Text] [S-6374] | SetupHsBuildFailure ExitCode (Maybe PackageIdentifier) (Path Abs File) [String] (Maybe (Path Abs File)) [Text] [S-8506] | TargetParseException [StyleDoc] [S-7086] | SomeTargetsNotBuildable [(PackageName, NamedComponent)] [S-8664] | InvalidFlagSpecification (Set UnusedFlags) - [S-8100] = GHCProfOptionInvalid + [S-8100] | GHCProfOptionInvalid + [S-1727] | NotOnlyLocal [PackageName] [Text] ~~~ - `Stack.Types.Compiler.CompilerException` diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 2b70c9700d..0855d8fa92 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -39,9 +39,9 @@ import Stack.Types.Build , taskProvides, taskTargetIsMutable, toCachePkgSrc ) import Stack.Types.Build.ConstructPlan - ( AddDepRes (..), CombinedMap, Ctx (..), M, NotOnlyLocal (..) - , PackageInfo (..), ToolWarning(..), UnregisterState (..) - , W (..), adrHasLibrary, adrVersion, toTask + ( AddDepRes (..), CombinedMap, Ctx (..), M, PackageInfo (..) + , ToolWarning(..), UnregisterState (..), W (..) + , adrHasLibrary, adrVersion, toTask ) import Stack.Types.Build.Exception ( BadDependency (..), BuildException (..) @@ -268,7 +268,7 @@ constructPlan let snapTasks = Map.keys $ Map.filter (\t -> taskLocation t == Snap) tasks snapExes = Map.keys $ Map.filter (== Snap) installExes unless (null snapTasks && null snapExes) $ - throwIO $ NotOnlyLocal snapTasks snapExes + prettyThrowIO $ NotOnlyLocal snapTasks snapExes pure plan prunedGlobalDeps :: Map PackageName [PackageName] diff --git a/src/Stack/Types/Build/ConstructPlan.hs b/src/Stack/Types/Build/ConstructPlan.hs index c17a718803..057cfe085e 100644 --- a/src/Stack/Types/Build/ConstructPlan.hs +++ b/src/Stack/Types/Build/ConstructPlan.hs @@ -1,8 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module Stack.Types.Build.ConstructPlan - ( NotOnlyLocal (..) - , ToolWarning (..) + ( ToolWarning (..) , UnregisterState (..) , AddDepRes (..) , W (..) @@ -15,8 +14,6 @@ module Stack.Types.Build.ConstructPlan , adrHasLibrary ) where -import qualified Data.List as L -import qualified Data.Text as T import Generics.Deriving.Monoid ( mappenddefault, memptydefault ) import RIO.Process ( HasProcessContext (..) ) import RIO.State ( StateT ) @@ -219,26 +216,6 @@ data UnregisterState = UnregisterState , usAnyAdded :: !Bool } -data NotOnlyLocal - = NotOnlyLocal [PackageName] [Text] - deriving (Show, Typeable) - -instance Exception NotOnlyLocal where - displayException (NotOnlyLocal packages exes) = concat - [ "Error: [S-1727]\n" - , "Specified only-locals, but I need to build snapshot contents:\n" - , if null packages then "" else concat - [ "Packages: " - , L.intercalate ", " (map packageNameString packages) - , "\n" - ] - , if null exes then "" else concat - [ "Executables: " - , L.intercalate ", " (map T.unpack exes) - , "\n" - ] - ] - -- | Warn about tools in the snapshot definition. States the tool name -- expected and the package name using it. data ToolWarning diff --git a/src/Stack/Types/Build/Exception.hs b/src/Stack/Types/Build/Exception.hs index 146321de6f..e434d31f40 100644 --- a/src/Stack/Types/Build/Exception.hs +++ b/src/Stack/Types/Build/Exception.hs @@ -285,6 +285,7 @@ data BuildPrettyException | SomeTargetsNotBuildable [(PackageName, NamedComponent)] | InvalidFlagSpecification (Set UnusedFlags) | GHCProfOptionInvalid + | NotOnlyLocal [PackageName] [Text] deriving (Show, Typeable) instance Pretty BuildPrettyException where @@ -393,6 +394,29 @@ instance Pretty BuildPrettyException where , flow "flags. See:" , style Url "https://github.com/commercialhaskell/stack/issues/1015" <> "." ] + pretty (NotOnlyLocal packages exes) = + "[S-1727]" + <> line + <> flow "Specified only-locals, but Stack needs to build snapshot contents:" + <> line + <> if null packages + then mempty + else + fillSep + ( "Packages:" + : mkNarrativeList Nothing False + (map fromPackageName packages :: [StyleDoc]) + ) + <> line + <> if null exes + then mempty + else + fillSep + ( "Executables:" + : mkNarrativeList Nothing False + (map (fromString . T.unpack) exes :: [StyleDoc]) + ) + <> line instance Exception BuildPrettyException From 5f4ec45972ea606d232186a094dd813bd325fcf2 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Fri, 1 Dec 2023 18:58:27 +0000 Subject: [PATCH 18/18] Add/fix module Haddock documentation --- src/Stack/Types/Build/ConstructPlan.hs | 16 +++++++++------- src/Stack/Types/ComponentUtils.hs | 5 ++--- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/src/Stack/Types/Build/ConstructPlan.hs b/src/Stack/Types/Build/ConstructPlan.hs index 057cfe085e..213806d365 100644 --- a/src/Stack/Types/Build/ConstructPlan.hs +++ b/src/Stack/Types/Build/ConstructPlan.hs @@ -1,17 +1,19 @@ {-# LANGUAGE NoImplicitPrelude #-} +-- | A module providing types and related helper functions used in module +-- "Stack.Build.ConstructPlan". module Stack.Types.Build.ConstructPlan - ( ToolWarning (..) - , UnregisterState (..) - , AddDepRes (..) - , W (..) - , Ctx (..) - , M - , PackageInfo (..) + ( PackageInfo (..) , CombinedMap + , M + , W (..) + , AddDepRes (..) , toTask , adrVersion , adrHasLibrary + , Ctx (..) + , UnregisterState (..) + , ToolWarning (..) ) where import Generics.Deriving.Monoid ( mappenddefault, memptydefault ) diff --git a/src/Stack/Types/ComponentUtils.hs b/src/Stack/Types/ComponentUtils.hs index 180755cad5..35bdafd2aa 100644 --- a/src/Stack/Types/ComponentUtils.hs +++ b/src/Stack/Types/ComponentUtils.hs @@ -8,9 +8,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} --- | A module providing the types that represent different sorts of components --- of a package (library and sub-library, foreign library, executable, test --- suite and benchmark). +-- | A module providing a type representing the name of an \'unqualified\' +-- component and related helper functions. module Stack.Types.ComponentUtils ( StackUnqualCompName (..) , fromCabalName