diff --git a/ChangeLog.md b/ChangeLog.md index 034489bd67..9f9e908edd 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -8,6 +8,17 @@ Release notes: Major changes: +* Stack now supports GHC's Backpack module system for cross-package use. When a + package uses `signatures` and `mixins` to depend on an abstract interface + provided by another package, Stack automatically creates the extra + instantiation build steps that Cabal requires. This includes support for + explicit renaming, multiple instantiations of the same indefinite package, + transitive signature chains, sub-library signatures, and indefinite packages + from Hackage or snapshots. See the + [Backpack topic](https://docs.haskellstack.org/en/stable/topics/backpack/) for + details. (Private Backpack — where signatures and implementations live in the + same package — has always worked without changes.) + Behavior changes: * Stack's default Nix integration now includes the `cacert` Nix package, in diff --git a/doc/topics/backpack.md b/doc/topics/backpack.md new file mode 100644 index 0000000000..07d204f30e --- /dev/null +++ b/doc/topics/backpack.md @@ -0,0 +1,246 @@ +
+ +# Backpack + +Backpack is an extension to Haskell's module system, available since GHC 8.2. +It lets you write a library that depends on an abstract interface (a +*signature*) instead of a concrete implementation. The consumer of that library +then decides which implementation to plug in. The compiler recompiles the +library for each implementation, so there is no runtime cost. + +Backpack is jointly supported by GHC and Cabal. Stack builds on that support to +orchestrate the extra build steps that cross-package Backpack requires. + +## What Backpack gives you + +### Signatures + +A *signature file* (`.hsig`) declares the types and functions that an +implementation must provide, without supplying any code. For example, a +signature for an abstract string type: + +~~~haskell +-- Str.hsig +signature Str where + +data Str + +empty :: Str +append :: Str -> Str -> Str +~~~ + +The package lists its signatures in the `signatures` field of the library +stanza: + +~~~cabal +library + build-depends: base + signatures: Str + exposed-modules: MyModule +~~~ + +Any module inside this library can `import Str` and use it as if it were a +normal module. The compiler will type-check the code against the signature +without needing an actual implementation. + +A package that has at least one unfilled signature is called *indefinite*. + +### Mixin linking + +Backpack fills a signature through *mixin linking*: when a module with the same +name as a signature is brought into scope, the compiler treats that module as +the implementation. There is no special syntax for this — it happens +automatically by name. + +For example, if you depend on both the indefinite package above and a package +that exposes a module named `Str`, mixin linking fills the hole: + +~~~cabal +library + build-depends: + , base + , str-string -- exposes module "Str" + , my-indefinite-pkg -- has signature "Str" +~~~ + +Because `str-string` exposes a module called `Str` and `my-indefinite-pkg` +requires a signature called `Str`, the compiler matches them up and compiles +`my-indefinite-pkg` with `str-string`'s `Str` as the implementation. + +### Renaming + +When the signature name and the implementation module name differ, the +`mixins` field lets you rename one or the other. + +Rename the requirement to match the implementation: + +~~~cabal + mixins: my-indefinite-pkg requires (Str as Data.Text) +~~~ + +Or rename the implementation to match the requirement: + +~~~cabal + mixins: text (Data.Text as Str) +~~~ + +Both achieve the same result: the `Str` signature is filled by `Data.Text`. + +The `mixins` field also supports `hiding` on the `requires` side. This tells +the compiler *not* to fill the listed signatures through mixin linking for this +dependency — they remain as holes and propagate to the consumer. + +### Multiple instantiations + +You can instantiate the same indefinite package more than once with different +implementations. Each instantiation gets its own renaming in `mixins`: + +~~~cabal + mixins: + my-indefinite-pkg + (MyModule as MyModule.Text) + requires (Str as Data.Text), + my-indefinite-pkg + (MyModule as MyModule.BS) + requires (Str as Data.ByteString) +~~~ + +This produces two copies of `MyModule` — one backed by `Data.Text`, the other +by `Data.ByteString` — each with a distinct module name so they do not clash. + +### Sub-libraries + +Backpack projects tend to involve several small packages (a signature package, +one or more implementation packages, and a consumer). Cabal's sub-libraries +(also called internal libraries) let you keep all of these inside a single +`.cabal` file: + +~~~cabal +cabal-version: 2.2 +name: my-project + +library str-sig + signatures: Str + +library str-text + build-depends: base, text + exposed-modules: Str + +library + build-depends: base, str-sig, str-text + exposed-modules: MyModule +~~~ + +This is purely an organizational convenience — the semantics are identical to +having three separate packages. + +Note that implementation modules that fill a signature cannot live in the same +component that has the dependency on the signature package. They must be in a +separate package or sub-library. + +### Reexported modules + +The `reexported-modules` field lets you expose an instantiated module under a +public name. This is useful when you want to use Backpack as an internal +implementation detail while presenting a straightforward API to users who do not +need to know about Backpack: + +~~~cabal +library + build-depends: base, regex-indef, str-bytestring + reexported-modules: Regex as Regex.ByteString +~~~ + +### Template Haskell + +GHC cannot run Template Haskell splices from an indefinite package because +indefinite code is type-checked but not compiled — there is no object code to +execute at splice time. Splicing TH code *from a definite package into* an +indefinite one works fine. This is a GHC limitation, not a Stack limitation. + +## Backpack in Stack + +### Private Backpack + +When all signatures and their implementations live inside the same package (for +example using sub-libraries), no special build orchestration is needed. This has +always worked in Stack without any extra configuration. + +### Cross-package Backpack + +When a signature is defined in one package and filled by a module from a +different package, Stack needs to perform an extra build step: after building the +indefinite package and the implementing package, it creates an *instantiation +task* that compiles the indefinite package against the concrete implementation. + +Stack handles this automatically. There is nothing you need to add to +`stack.yaml` beyond listing the packages as usual: + +~~~yaml +packages: + - sig-pkg + - impl-pkg + - consumer-pkg +~~~ + +As long as the `.cabal` files set up the `signatures`, `build-depends`, and +`mixins` fields correctly, `stack build` does the rest. + +### What happens during a build + +When Stack encounters a cross-package Backpack setup, the build output shows the +extra instantiation step: + +~~~text +sig-pkg > configure (lib) +sig-pkg > build (lib) +impl-pkg > configure (lib) +impl-pkg > build (lib) +sig-pkg > build (inst:941095d7: Str = impl-pkg) +consumer > configure (lib) +consumer > build (lib) +~~~ + +The line marked `inst:` is the instantiation task. The hash identifies the +particular combination of signature-to-implementation mappings. The output also +shows which signatures are filled and by which packages. + +### Supported features + +Stack supports the full set of Backpack features that Cabal exposes: + +* Signature modules and indefinite packages +* Mixin linking (filling signatures by bringing a same-named module into scope) +* Explicit renaming in `mixins` (`requires (Sig as Impl)`) +* Multiple instantiations of the same indefinite package with different + implementations +* Sub-library signatures and implementations +* Transitive Backpack chains (an indefinite package depending on another + indefinite package — all inherited signatures are filled) +* Indefinite packages from Hackage or Stackage snapshots (not just local + packages) +* Haddock generation for instantiated packages +* Precompiled caching of instantiation results + +### Limitations + +**`requires hiding` with partial instantiation.** If a `mixins` entry uses +`requires hiding (SomeSig)` to leave a signature unfilled, Stack will not create +an instantiation task for that mixin entry. Cabal requires all signatures to be +filled in a single instantiation — partial instantiation is not possible. This +means the indefinite package remains indefinite for the hidden signatures and a +higher-level consumer must fill them. When `hiding` hides nothing (i.e. +`requires hiding ()`) it is equivalent to `DefaultRenaming` and works normally. + +**Template Haskell in indefinite packages.** As described above, this is a GHC +restriction, not specific to Stack. + +## Further reading + +* [How to use Backpack modules](https://cabal.readthedocs.io/en/latest/how-to-use-backpack.html) + in the Cabal documentation +* [Backpack: Retrofitting Haskell with Interfaces](https://plv.mpi-sws.org/backpack/) + — the original paper +* [Try Backpack: Cabal packages](http://blog.ezyang.com/2017/01/try-backpack-cabal-packages/) + — a practical walkthrough by Edward Z. Yang +* [GHC wiki: Backpack](https://gitlab.haskell.org/ghc/ghc/-/wikis/backpack) diff --git a/doc/tutorial/multi-package_projects.md b/doc/tutorial/multi-package_projects.md index dc0ddd9735..bcea0a9dfa 100644 --- a/doc/tutorial/multi-package_projects.md +++ b/doc/tutorial/multi-package_projects.md @@ -150,3 +150,8 @@ someFunc of packageA's Lib module [extra-dep](../configure/yaml/project.md#extra-deps). Although both dependencies are local, the former is part of the project and the latter is not. + +Multi-package projects are also the natural setting for GHC's +[Backpack](../topics/backpack.md) module system, where a signature package, an +implementation package, and a consumer package each live in separate directories +under the same `stack.yaml`. diff --git a/doc/tutorial/package_description.md b/doc/tutorial/package_description.md index 5fc75d080e..4a53d8aef8 100644 --- a/doc/tutorial/package_description.md +++ b/doc/tutorial/package_description.md @@ -93,6 +93,10 @@ package's root directory. benchmark components. The description identifies other packages on which those components depend. + A library component can also declare *signatures* — abstract module + interfaces that are filled in by a consumer. This is GHC's + [Backpack](../topics/backpack.md) module system. + Stack is aware of two different formats of package description, and both files may be present in the package's root directory: diff --git a/mkdocs.yml b/mkdocs.yml index aa4c274cb6..8a5c7d2d0f 100644 --- a/mkdocs.yml +++ b/mkdocs.yml @@ -125,6 +125,7 @@ nav: - Azure CI: topics/azure_ci.md - Lock files: topics/lock_files.md - Haskell and C code: topics/haskell_and_c_code.md + - Backpack: topics/backpack.md - Get involved: - community/index.md - Contributors: diff --git a/src/Control/Concurrent/Execute.hs b/src/Control/Concurrent/Execute.hs index db8fd9a42c..bdae654536 100644 --- a/src/Control/Concurrent/Execute.hs +++ b/src/Control/Concurrent/Execute.hs @@ -25,6 +25,7 @@ import Control.Concurrent.STM ( check ) import Stack.Prelude import Data.List ( sortBy ) import qualified Data.Set as Set +import Stack.Types.Plan ( ComponentKey ) -- | Type representing exceptions thrown by functions exported by the -- "Control.Concurrent.Execute" module. @@ -40,13 +41,10 @@ instance Exception ExecuteException where -- | Type representing types of Stack build actions. data ActionType = ATBuild - -- ^ Action for building a package's library and executables. If - -- 'Stack.Types.Build.Task.allInOne' is 'True', then this will also build - -- benchmarks and tests. It is 'False' when the library's benchmarks or - -- test-suites have cyclic dependencies. - | ATBuildFinal - -- ^ Task for building the package's benchmarks and test-suites. Requires - -- that the library was already built. + -- ^ Action for configuring and building a single component (library, + -- sub-library, executable, or Backpack instantiation). Also used for + -- final build steps that compile test-suites and benchmarks when no + -- separate library build task exists for the component. | ATRunTests -- ^ Task for running the package's test-suites. | ATRunBenchmarks @@ -55,7 +53,7 @@ data ActionType -- | Types representing the unique ids of Stack build actions. data ActionId - = ActionId !PackageIdentifier !ActionType + = ActionId !ComponentKey !ActionType deriving (Eq, Ord, Show) -- | Type representing Stack build actions. diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 06e754eca5..f9dcfe7fde 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -69,8 +69,8 @@ import Stack.Types.Package , PackageConfig (..), lpFiles, lpFilesForComponents ) import Stack.Types.Plan - ( Plan (..), Task (..), TaskType (..), taskLocation - , taskProvides + ( Plan (..), Task (..), TaskType (..), componentKeyPkgName + , taskLocation, taskProvides ) import Stack.Types.Platform ( HasPlatform (..) ) import Stack.Types.Runner ( Runner, globalOptsL ) @@ -187,9 +187,11 @@ build msetLocalFiles = do getInstalled installMap baseConfigOpts <- mkBaseConfigOpts boptsCli + let allDumpPkgs = globalDumpPkgs ++ snapshotDumpPkgs ++ localDumpPkgs plan <- constructPlan baseConfigOpts localDumpPkgs + allDumpPkgs loadPackage sourceMap installedMap @@ -242,8 +244,11 @@ buildLocalTargets :: buildLocalTargets targets = tryAny $ withNewLocalBuildTargets (NE.toList targets) $ build Nothing +-- | Extract the local package identifiers from the plan. Multiple component +-- tasks for the same package are deduplicated. justLocals :: Plan -> [PackageIdentifier] justLocals = + Set.toList . Set.fromList . map taskProvides . filter ((== Local) . taskLocation) . Map.elems . @@ -324,11 +329,16 @@ warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do exesToBuild :: Map StackUnqualCompName (NonEmpty PackageName) exesToBuild = collect - [ (exe, pkgName') - | (pkgName', task) <- Map.toList plan.tasks + [ (exe, pn) + | (pn, task) <- Map.toList perPkgTasks , TTLocalMutable lp <- [task.taskType] , exe <- (Set.toList . exeComponents . (.components)) lp ] + -- Multiple component tasks for the same package share the same Task data. + -- Use one representative task per package to avoid duplicates. + perPkgTasks :: Map PackageName Task + perPkgTasks = Map.fromList + [ (componentKeyPkgName ck, t) | (ck, t) <- Map.toList plan.tasks ] localExes :: Map StackUnqualCompName (NonEmpty PackageName) localExes = collect diff --git a/src/Stack/Build/Backpack.hs b/src/Stack/Build/Backpack.hs new file mode 100644 index 0000000000..61f293626b --- /dev/null +++ b/src/Stack/Build/Backpack.hs @@ -0,0 +1,589 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Stack.Build.Backpack +Description : Backpack (cross-package) instantiation support. +License : BSD-3-Clause + +Create CInst instantiation tasks for Backpack packages. Given the build plan's +dependency resolution results, this module scans consumer packages for mixin +references to indefinite (signature-only) packages and creates additional build +tasks that instantiate those packages with concrete implementations. +-} + +module Stack.Build.Backpack + ( addInstantiationTasks + , upgradeFoundIndefinites + ) where + +import Crypto.Hash ( hashWith, SHA256 (..) ) +import qualified Data.ByteArray.Encoding as Mem + ( Base (Base16), convertToBase ) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.List as L +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import Distribution.ModuleName ( ModuleName ) +import qualified Distribution.Text as CabalText +import Distribution.Types.IncludeRenaming ( IncludeRenaming (..) ) +import Distribution.Types.Mixin + ( Mixin (..), mixinIncludeRenaming, mixinPackageName ) +import Distribution.Types.ModuleRenaming + ( ModuleRenaming (..) ) +import Path ( parent ) +import Stack.ConfigureOpts ( packageConfigureOptsFromPackage ) +import Stack.Package + ( packageIsIndefinite ) +import Stack.Prelude +import Stack.Types.Build.ConstructPlan + ( AddDepRes (..), CombinedMap, PackageInfo (..) ) +import Stack.Types.SourceMap ( CommonPackage (..) ) +import Distribution.Types.BuildType ( BuildType (Configure) ) +import Stack.Types.Cache ( CachePkgSrc (..) ) +import Stack.Types.Component + ( StackBuildInfo (..), StackLibrary (..) ) +import Stack.Types.ConfigureOpts ( BaseConfigOpts (..) ) +import Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..) ) +import Stack.Types.Installed + ( InstallLocation (..), Installed (..) + , InstalledLibraryInfo (..), installedVersion + ) +import Stack.Types.IsMutable ( IsMutable (..) ) +import Stack.Types.NamedComponent ( NamedComponent (..) ) +import Stack.Types.Package + ( LocalPackage (..), Package (..), PackageSource (..) + , installedMapGhcPkgId, packageIdentifier + ) +import Stack.Types.Plan + ( ComponentKey (..), Task (..), TaskConfigOpts (..) + , TaskType (..), installLocationIsMutable + ) + +-- | Upgrade ADRFound entries to ADRToInstall for indefinite (Backpack +-- signature) packages whose source is available. This is needed because +-- addInstantiationTasks clones the sig-pkg's Task to create CInst tasks, +-- and ADRFound entries don't carry a Task. +-- +-- Only packages actually referenced by a consumer's mixin are loaded, +-- to avoid unnecessary Pantry lookups for the common case (no Backpack). +upgradeFoundIndefinites :: + forall env. HasEnvConfig env + => ( PackageLocationImmutable + -> Map FlagName Bool + -> [Text] + -> [Text] + -> RIO EnvConfig Package + ) + -- ^ Load package from source (loadPackage0) + -> EnvConfig + -> CombinedMap + -> BaseConfigOpts + -> [(PackageName, AddDepRes)] + -> RIO env [(PackageName, AddDepRes)] +upgradeFoundIndefinites loadPkg econfig combinedMap bco adrs = do + let adrMap = Map.fromList adrs + -- Collect package names referenced by any consumer's mixin. + mixinTargets :: Set PackageName + mixinTargets = Set.fromList + [ mixinPackageName mixin + | (_, ADRToInstall task) <- adrs + , let pkg = case task.taskType of + TTLocalMutable lp -> lp.package + TTRemotePackage _ p _ -> p + , mixin <- concatMap (\lib -> lib.buildInfo.mixins) + (maybeToList pkg.library ++ toList pkg.subLibraries) + ] + -- Filter to mixin targets that are ADRFound. + foundTargets = + [ name + | name <- Set.toList mixinTargets + , Just (ADRFound _ _) <- [Map.lookup name adrMap] + ] + if null foundTargets + then pure adrs + else do + -- For each ADRFound mixin target, try to load its Package and + -- upgrade to ADRToInstall if it is indefinite. + upgrades <- fmap Map.fromList $ forM foundTargets $ \name -> + case Map.lookup name combinedMap of + Just (PIOnlyInstalled _ installed) -> + -- Source not available (GHC boot library or similar). Look up + -- Hackage as a fallback. + upgradeFromHackage name installed + Just (PIBoth ps installed) -> + upgradeFromSource name ps (Just installed) + Just (PIOnlySource ps) -> + -- Should not happen (ADRFound implies installed), but handle + -- gracefully by loading the package to check. + upgradeFromSource name ps Nothing + Nothing -> + -- Package not in combined map — shouldn't happen. Skip. + pure (name, Nothing) + -- Apply upgrades. + pure + [ case Map.lookup name upgrades of + Just (Just adr') -> (name, adr') + _ -> (name, adr) + | (name, adr) <- adrs + ] + where + loadFromSource :: PackageSource -> RIO env Package + loadFromSource = \case + PSRemote pkgLoc _version _fromSnapshot cp -> + runRIO econfig $ loadPkg pkgLoc cp.flags cp.ghcOptions cp.cabalConfigOpts + PSFilePath lp -> pure lp.package + + mkTask :: Package -> PackageSource -> Maybe Installed -> Task + mkTask package ps mInstalled = + let loc = psLocation ps + isMutable = installLocationIsMutable loc + presentMap = case mInstalled of + Just (Library pid ili) -> installedMapGhcPkgId pid ili + _ -> Map.empty + in Task + { configOpts = TaskConfigOpts + { missing = Set.empty + , envConfig = econfig + , baseConfigOpts = bco + , isLocalNonExtraDep = psLocal ps + , isMutable + , pkgConfigOpts = packageConfigureOptsFromPackage package + , instantiationDeps = [] + } + , buildHaddocks = False + , present = presentMap + , taskType = case ps of + PSFilePath lp -> TTLocalMutable lp + PSRemote pkgLoc _version _fromSnapshot _cp -> + TTRemotePackage isMutable package pkgLoc + , cachePkgSrc = toCachePkgSrc ps + , buildTypeConfig = packageBuildTypeConfig package + , backpackInstEntries = [] + } + + upgradeFromSource :: + PackageName + -> PackageSource + -> Maybe Installed + -> RIO env (PackageName, Maybe AddDepRes) + upgradeFromSource name ps mInstalled = do + package <- loadFromSource ps + if packageIsIndefinite package + then pure (name, Just $ ADRToInstall $ mkTask package ps mInstalled) + else pure (name, Nothing) + + upgradeFromHackage :: + PackageName + -> Installed + -> RIO env (PackageName, Maybe AddDepRes) + upgradeFromHackage name installed = do + let version = installedVersion installed + mPkgLoc <- runRIO econfig $ + getLatestHackageRevision YesRequireHackageIndex name version >>= \case + Nothing -> pure Nothing + Just (_rev, cfKey, treeKey) -> + pure $ Just $ PLIHackage (PackageIdentifier name version) cfKey treeKey + case mPkgLoc of + Nothing -> pure (name, Nothing) + Just pkgLoc -> do + package <- runRIO econfig $ loadPkg pkgLoc Map.empty [] [] + if packageIsIndefinite package + then do + let presentMap = case installed of + Library pid ili -> installedMapGhcPkgId pid ili + _ -> Map.empty + task = Task + { configOpts = TaskConfigOpts + { missing = Set.empty + , envConfig = econfig + , baseConfigOpts = bco + , isLocalNonExtraDep = False + , isMutable = Immutable + , pkgConfigOpts = packageConfigureOptsFromPackage package + , instantiationDeps = [] + } + , buildHaddocks = False + , present = presentMap + , taskType = TTRemotePackage Immutable package pkgLoc + , cachePkgSrc = CacheSrcUpstream + , buildTypeConfig = packageBuildTypeConfig package + , backpackInstEntries = [] + } + pure (name, Just $ ADRToInstall task) + else pure (name, Nothing) + +-- | Post-pass: scan consumer tasks for Backpack mixins referencing indefinite +-- packages and create CInst instantiation tasks. Returns the augmented list +-- plus any warnings about unsupported Backpack patterns. +addInstantiationTasks :: + Map PackageName (Set ModuleName) + -- ^ Installed package modules (from ghc-pkg dump). Used for module + -- resolution when the implementing package is ADRFound (already + -- installed, no Task/Package metadata available). + -> [(PackageName, AddDepRes)] -- ^ Original per-package ADRs + -> [(ComponentKey, AddDepRes)] -- ^ Expanded component-keyed ADRs + -> ([(ComponentKey, AddDepRes)], [StyleDoc]) + -- ^ (Augmented with CInst tasks, warnings) +addInstantiationTasks installedModules origAdrs expandedAdrs = + let adrMap = Map.fromList origAdrs + -- Process each entry, collecting new CInst tasks and modified consumers. + (newInstTasks, modifiedEntries, warns) = + foldr (processEntry adrMap) ([], [], []) expandedAdrs + -- Deduplicate CInst tasks: multiple components of the same consumer + -- may reference the same mixin, producing identical CInst entries. + -- Map.fromList keeps the last, Map.toList restores the list. + dedupedInstTasks = Map.toList $ Map.fromList newInstTasks + in (modifiedEntries ++ dedupedInstTasks, warns) + where + processEntry :: + Map PackageName AddDepRes + -> (ComponentKey, AddDepRes) + -> ([(ComponentKey, AddDepRes)], [(ComponentKey, AddDepRes)], [StyleDoc]) + -> ([(ComponentKey, AddDepRes)], [(ComponentKey, AddDepRes)], [StyleDoc]) + processEntry adrMap (ck, ADRToInstall task) (instAcc, entryAcc, warnAcc) = + let pkg = taskPackage task + -- Get mixins from the main library and all sub-libraries. + mainMixins = case pkg.library of + Just lib -> lib.buildInfo.mixins + Nothing -> [] + subLibMixins = concatMap (\lib -> lib.buildInfo.mixins) + (toList pkg.subLibraries) + allMixins = mainMixins ++ subLibMixins + -- Collect the consumer's build-depends to scope module resolution. + -- When multiple packages expose the same module, only the consumer's + -- direct dependencies are considered (matching Cabal's behavior). + consumerDeps = Set.fromList $ concatMap + (\lib -> Map.keys lib.buildInfo.dependency) + (maybeToList pkg.library ++ toList pkg.subLibraries) + -- Process each mixin that references an indefinite dep. + (instTasks, instKeys, mixinWarns) = + processAllMixins ck pkg allMixins adrMap consumerDeps + -- Add CInst keys to the consumer's instantiationDeps. + modifiedTask + | null instKeys = task + | otherwise = task + { configOpts = task.configOpts + { instantiationDeps = + task.configOpts.instantiationDeps ++ instKeys + } + } + in ( instTasks ++ instAcc + , (ck, ADRToInstall modifiedTask) : entryAcc + , mixinWarns ++ warnAcc + ) + processEntry _ entry (instAcc, entryAcc, warnAcc) = + (instAcc, entry : entryAcc, warnAcc) + + -- Extract the Package from a Task's TaskType. + taskPackage :: Task -> Package + taskPackage t = case t.taskType of + TTLocalMutable lp -> lp.package + TTRemotePackage _ p _ -> p + + -- Process all mixins for a consumer, returning new CInst entries, their + -- ComponentKeys (to add as deps on the consumer), and any warnings. + processAllMixins :: + ComponentKey -- ^ Consumer's key + -> Package -- ^ Consumer's package + -> [Mixin] -- ^ Consumer's library mixins + -> Map PackageName AddDepRes + -> Set PackageName -- ^ Consumer's build-depends + -> ([(ComponentKey, AddDepRes)], [ComponentKey], [StyleDoc]) + processAllMixins _ck _pkg mixins adrMap' consumerDeps = + foldr (processMixin adrMap' consumerDeps) ([], [], []) mixins + + processMixin :: + Map PackageName AddDepRes + -> Set PackageName -- ^ Consumer's build-depends + -> Mixin + -> ([(ComponentKey, AddDepRes)], [ComponentKey], [StyleDoc]) + -> ([(ComponentKey, AddDepRes)], [ComponentKey], [StyleDoc]) + processMixin adrMap' consumerDeps mixin (instAcc, keyAcc, warnAcc) = + let depPkgName = mixinPackageName mixin + in case Map.lookup depPkgName adrMap' of + Just (ADRToInstall sigTask) + | let sigPkg = taskPackage sigTask + , packageIsIndefinite sigPkg -> + let -- Get signatures from the sig-pkg's main library. + ownSigs :: [ModuleName] + ownSigs = case sigPkg.library of + Just lib -> lib.signatures + Nothing -> [] + -- Collect inherited signatures from transitive indefinite + -- deps. When a sig-pkg depends on another indefinite package, + -- its holes propagate upward. The CInst must fill ALL holes + -- (own + inherited) or Cabal reports "non-closing + -- substitution". + inheritedSigs :: [ModuleName] + inheritedSigs = + -- Deduplicate: diamond deps can yield the same sig + -- from multiple paths. + L.nub $ collectInheritedSigs sigPkg adrMap' Set.empty + -- Determine the module mapping from the mixin's requiresRn. + renaming = includeRequiresRn (mixinIncludeRenaming mixin) + -- Resolve the sig-pkg's own signatures using the consumer's + -- mixin renaming. Module lookup is scoped to the consumer's + -- build-depends so that multiple instantiations with different + -- implementations don't conflict. + (ownEntries, ownWarns) = + resolveAllEntries depPkgName renaming adrMap' + consumerDeps ownSigs + -- Resolve inherited signatures using DefaultRenaming (the + -- consumer's mixin only renames the direct sig-pkg's + -- signatures, not inherited ones). + (inheritedEntries, inheritedWarns) = + resolveAllEntries depPkgName DefaultRenaming adrMap' + consumerDeps inheritedSigs + entries = ownEntries ++ inheritedEntries + resolveWarns = ownWarns ++ inheritedWarns + in if null entries + then (instAcc, keyAcc, resolveWarns ++ warnAcc) + else + let hashSuffix = instHashSuffix entries + instCk = ComponentKey depPkgName (CInst hashSuffix) + -- The CInst task's missing includes the sig-pkg's + -- original missing plus implementing packages that + -- are ADRToInstall. + implPidsMissing = Set.fromList + [ packageIdentifier (taskPackage implTask) + | (_, implPkgName', _) <- entries + , Just (ADRToInstall implTask) <- + [Map.lookup implPkgName' adrMap'] + ] + -- For ADRFound implementing packages, add their + -- PID→GhcPkgId to the CInst task's present map so + -- that mkInstantiateWithOpts can generate + -- --instantiate-with flags. + implPresent = Map.fromList + [ (pid, gid) + | (_, implPkgName', _) <- entries + , Just (ADRFound _ (Library pid (InstalledLibraryInfo gid _ _))) <- + [Map.lookup implPkgName' adrMap'] + ] + instTask = sigTask + { backpackInstEntries = entries + , configOpts = sigTask.configOpts + { missing = + sigTask.configOpts.missing <> implPidsMissing + , instantiationDeps = [] + } + , present = + sigTask.present <> implPresent + } + in ( (instCk, ADRToInstall instTask) : instAcc + , instCk : keyAcc + , resolveWarns ++ warnAcc + ) + Just (ADRFound _ _) -> + -- Sig-pkg is installed and its source could not be resolved + -- (upgradeFoundIndefinites already tried). This typically means + -- a GHC boot library or a package missing from Hackage. + let w = fillSep + [ flow "Backpack: mixin referencing" + , style Current (fromPackageName depPkgName) + , flow "is skipped because that package is installed and its" + , flow "source could not be found for instantiation." + , flow "Consider adding it as a local package in stack.yaml." + ] + in (instAcc, keyAcc, w : warnAcc) + _ -> (instAcc, keyAcc, warnAcc) + + -- Collect signatures inherited from a package's transitive indefinite deps. + -- When pkg-A depends on indefinite pkg-B, pkg-B's signatures propagate up + -- as holes in pkg-A. This recursively walks the dep graph, collecting + -- signatures from all reachable indefinite packages. + collectInheritedSigs :: + Package + -> Map PackageName AddDepRes + -> Set PackageName -- ^ Already visited (cycle prevention) + -> [ModuleName] + collectInheritedSigs pkg adrMap' visited = + concatMap collectFromDep depNames + where + depNames :: [PackageName] + depNames = case pkg.library of + Just lib -> Map.keys lib.buildInfo.dependency + Nothing -> [] + collectFromDep :: PackageName -> [ModuleName] + collectFromDep depName + | depName `Set.member` visited = [] + | otherwise = + case Map.lookup depName adrMap' of + Just (ADRToInstall depTask) + | let depPkg = taskPackage depTask + , packageIsIndefinite depPkg -> + let depSigs = case depPkg.library of + Just lib -> lib.signatures + Nothing -> [] + transitive = collectInheritedSigs depPkg adrMap' + (Set.insert depName visited) + in depSigs ++ transitive + _ -> [] + + -- Resolve all signature entries for a mixin, collecting both successful + -- resolutions and warnings for signatures that could not be resolved. + resolveAllEntries :: + PackageName -- ^ Sig-pkg name (for warning messages) + -> ModuleRenaming + -> Map PackageName AddDepRes + -> Set PackageName -- ^ Consumer's build-depends (scope) + -> [ModuleName] -- ^ Signatures to resolve + -> ([(ModuleName, PackageName, ModuleName)], [StyleDoc]) + resolveAllEntries sigPkgName renaming adrMap' scope sigs = + case renaming of + HidingRenaming hiddenSigs -> + -- HidingRenaming: hide specified sigs from mixin linking. Hidden + -- sigs remain as unfilled holes (the consumer becomes indefinite for + -- them). Since Cabal requires a closing substitution, we can only + -- create a CInst when nothing is actually hidden — otherwise the + -- partial --instantiate-with would fail. + let visibleSigs = filter (`notElem` hiddenSigs) sigs + in if length visibleSigs == length sigs + -- Nothing actually hidden: equivalent to DefaultRenaming. + then foldr (resolveOne sigPkgName DefaultRenaming adrMap' scope) + ([], []) visibleSigs + -- Some sigs hidden: can't fully instantiate this copy. + else ([], []) + _ -> foldr (resolveOne sigPkgName renaming adrMap' scope) ([], []) sigs + + -- Resolve a single signature entry, producing a warning if it fails. + resolveOne :: + PackageName -- ^ Sig-pkg name (for warning messages) + -> ModuleRenaming + -> Map PackageName AddDepRes + -> Set PackageName -- ^ Consumer's build-depends (scope) + -> ModuleName -- ^ Signature module name + -> ([(ModuleName, PackageName, ModuleName)], [StyleDoc]) + -> ([(ModuleName, PackageName, ModuleName)], [StyleDoc]) + resolveOne sigPkgName renaming adrMap' scope sigName (entryAcc, warnAcc) = + case renaming of + DefaultRenaming -> + -- Identity mapping: sigName is filled by a module with the same name. + case findDepExposingModule sigName adrMap' scope of + Right implPkgName -> + ((sigName, implPkgName, sigName) : entryAcc, warnAcc) + Left w -> + (entryAcc, mkModuleWarn sigPkgName sigName w : warnAcc) + ModuleRenaming mappings -> + -- Explicit: look for (sigName, implModuleName) in the mapping. + case lookup sigName mappings of + Just implModName -> + case findDepExposingModule implModName adrMap' scope of + Right implPkgName -> + ((sigName, implPkgName, implModName) : entryAcc, warnAcc) + Left w -> + (entryAcc, mkModuleWarn sigPkgName implModName w : warnAcc) + Nothing -> + -- Signature not mentioned in the explicit mapping — this is + -- normal (the mixin doesn't remap this sig), skip silently. + (entryAcc, warnAcc) + HidingRenaming _ -> + -- Converted to DefaultRenaming in resolveAllEntries; should not + -- reach here. + (entryAcc, warnAcc) + + -- Build a warning message for a failed module resolution. + mkModuleWarn :: PackageName -> ModuleName -> [PackageName] -> StyleDoc + mkModuleWarn sigPkgName modName candidates = fillSep $ case candidates of + [] -> + [ flow "Backpack: no dependency exposes module" + , style Current (fromString (CabalText.display modName)) + , flow "needed to instantiate" + , style Current (fromPackageName sigPkgName) <> "." + , flow "Ensure the implementing package is listed in build-depends." + ] + _ -> + [ flow "Backpack: multiple dependencies expose module" + , style Current (fromString (CabalText.display modName)) + , flow "needed to instantiate" + , style Current (fromPackageName sigPkgName) <> ":" + ] + ++ L.intersperse "," (map (style Current . fromPackageName) candidates) + ++ ["—", flow "cannot determine which to use. Skipping instantiation."] + + -- Find which dep in the ADR map exposes a given module name. Only packages + -- that are in the consumer's build-depends (scope) are considered, so that + -- multiple consumers can instantiate the same sig-pkg with different + -- implementations without ambiguity. Returns @Right pkgName@ on unique + -- match, or @Left candidates@ (empty = no match, multiple = ambiguous) on + -- failure. + -- + -- Checks both ADRToInstall entries (via Package metadata) and ADRFound + -- entries (via the installed modules map from ghc-pkg dump). This allows + -- module resolution to work when the implementing package is already + -- installed (e.g., from a snapshot or a previous build). + findDepExposingModule :: + ModuleName + -> Map PackageName AddDepRes + -> Set PackageName -- ^ Consumer's build-depends (scope) + -> Either [PackageName] PackageName + findDepExposingModule modName adrMap' scope = + let -- Check ADRToInstall entries (have full Package metadata). + fromTasks = + [ pn + | (pn, ADRToInstall t) <- Map.toList adrMap' + , pn `Set.member` scope + , let p = taskPackage t + , not (packageIsIndefinite p) + , exposesModule modName p + ] + -- Check ADRFound entries (use installed modules map from dump). + fromInstalled = + [ pn + | (pn, ADRFound _ _) <- Map.toList adrMap' + , pn `Set.member` scope + , case Map.lookup pn installedModules of + Just mods -> modName `Set.member` mods + Nothing -> False + ] + candidates = fromTasks ++ fromInstalled + in case candidates of + [pn] -> Right pn + _ -> Left candidates + + exposesModule :: ModuleName -> Package -> Bool + exposesModule modName p = + mainExposes || subLibExposes + where + mainExposes = case p.library of + Just lib -> modName `L.elem` (lib.exposedModules :: [ModuleName]) + Nothing -> False + subLibExposes = any + (\lib -> modName `L.elem` (lib.exposedModules :: [ModuleName])) + (toList p.subLibraries) + + -- Produce a deterministic hash suffix from instantiation entries. + instHashSuffix :: [(ModuleName, PackageName, ModuleName)] -> Text + instHashSuffix entries = + let sorted = L.sort + [ CabalText.display sig ++ "=" ++ packageNameString implPkg + ++ ":" ++ CabalText.display implMod + | (sig, implPkg, implMod) <- entries + ] + input = S8.pack (L.intercalate "," sorted) + digest = hashWith SHA256 input + -- Take first 16 hex chars for a short but unique-enough suffix. + hexStr = Mem.convertToBase Mem.Base16 digest :: ByteString + in T.take 16 (decodeUtf8Lenient hexStr) + +-- Local helpers (duplicated from ConstructPlan to avoid import cycle) + +packageBuildTypeConfig :: Package -> Bool +packageBuildTypeConfig pkg = pkg.buildType == Configure + +psLocal :: PackageSource -> Bool +psLocal (PSFilePath _) = True +psLocal PSRemote{} = False + +psLocation :: PackageSource -> InstallLocation +psLocation (PSFilePath _) = Local +psLocation PSRemote{} = Snap + +toCachePkgSrc :: PackageSource -> CachePkgSrc +toCachePkgSrc (PSFilePath lp) = + CacheSrcLocal (toFilePath (parent lp.cabalFP)) +toCachePkgSrc PSRemote{} = CacheSrcUpstream diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index 2f5aca0d3e..d1184a6fa0 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -179,9 +179,11 @@ tryGetConfigCache :: HasEnvConfig env => Path Abs Dir -- ^ Package directory. + -> ConfigCacheType + -- ^ Type of cache. -> RIO env (Maybe ConfigCache) tryGetConfigCache dir = - loadConfigCache $ configCacheKey dir ConfigCacheTypeConfig + loadConfigCache . configCacheKey dir -- | Try to read the modification time of the Cabal file from the last build. tryGetCabalMod :: @@ -241,11 +243,13 @@ writeConfigCache :: HasEnvConfig env => Path Abs Dir -- ^ Package directory. + -> ConfigCacheType + -- ^ Type of cache. -> ConfigCache -- ^ Cabal configuration cache. -> RIO env () -writeConfigCache dir = - saveConfigCache (configCacheKey dir ConfigCacheTypeConfig) +writeConfigCache dir cacheType = + saveConfigCache (configCacheKey dir cacheType) -- | See 'tryGetCabalMod' writeCabalMod :: @@ -288,13 +292,15 @@ deleteCaches :: HasEnvConfig env => Path Abs Dir -- ^ Package directory. + -> ConfigCacheType + -- ^ Type of cache. -> RIO env () -deleteCaches dir = +deleteCaches dir cacheType = {- FIXME confirm that this is acceptable to remove bfp <- buildCacheFile dir removeFileIfExists bfp -} - deactiveConfigCache $ configCacheKey dir ConfigCacheTypeConfig + deactiveConfigCache $ configCacheKey dir cacheType -- | For the given installed item, yields the key used to retrieve a record from -- the library Cabal flag cache or executable Cabal flag cache. diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 8a625945a1..10fbd29375 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -14,6 +14,8 @@ Construct a @Plan@ for how to build. module Stack.Build.ConstructPlan ( constructPlan + -- * Exported for testing + , shouldSplitComponents ) where import Control.Monad.Trans.Maybe ( MaybeT (..) ) @@ -22,7 +24,7 @@ import qualified Data.Map.Strict as Map import Data.Monoid.Map ( MonoidMap(..) ) import qualified Data.Set as Set import qualified Data.Text as T -import Distribution.Types.BuildType ( BuildType (Configure) ) +import Distribution.Types.BuildType ( BuildType (Configure, Simple) ) import Distribution.Types.PackageName ( mkPackageName ) import Distribution.Version ( mkVersion ) import Path ( parent ) @@ -31,6 +33,8 @@ import RIO.Process ( findExecutable ) import RIO.State ( State, StateT (..), execState, get, modify, modify', put ) import RIO.Writer ( WriterT (..), pass, tell ) +import Stack.Build.Backpack + ( addInstantiationTasks, upgradeFoundIndefinites ) import Stack.Build.Cache ( tryGetFlagCache ) import Stack.Build.Haddock ( shouldHaddockDeps ) import Stack.Build.Source ( loadLocalPackage ) @@ -40,7 +44,10 @@ import Stack.ConfigureOpts ) import Stack.Constants ( compilerOptionsCabalFlag ) import Stack.Package - ( applyForceCustomBuild, buildableExes, packageUnknownTools + ( applyForceCustomBuild, buildableExes + , buildableForeignLibs, buildableSubLibs + , hasBuildableMainLibrary, hasIntraPackageDeps + , packageUnknownTools , processPackageDepsEither ) import Stack.Prelude hiding ( loadPackage ) @@ -49,7 +56,7 @@ import Stack.Types.Build.ConstructPlan ( AddDepRes (..), CombinedMap, Ctx (..), M , MissingPresentDeps (..), PackageInfo (..), ToolWarning(..) , UnregisterState (..), W (..), adrHasLibrary, adrVersion - , isAdrToInstall, toTask + , toTask ) import Stack.Types.Build.Exception ( BadDependency (..), BuildException (..) @@ -68,7 +75,6 @@ import Stack.Types.CompilerPaths import Stack.Types.ComponentUtils ( unqualCompFromText ) import Stack.Types.Config ( Config (..), HasConfig (..), stackRootL ) import Stack.Types.ConfigureOpts ( BaseConfigOpts (..) ) -import Stack.Types.Curator ( Curator (..) ) import Stack.Types.Dependency ( DepValue (..), isDepTypeLibrary ) import Stack.Types.DumpPackage ( DumpPackage (..), sublibParentPkgId ) import Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..) ) @@ -77,20 +83,26 @@ import Stack.Types.EnvSettings import Stack.Types.GhcPkgId ( GhcPkgId ) import Stack.Types.GlobalOpts ( GlobalOpts (..) ) import Stack.Types.Installed - ( InstallLocation (..), Installed (..), InstalledMap + ( InstallLocation (..), Installed (..) + , InstalledMap , installedVersion ) import Stack.Types.IsMutable ( IsMutable (..) ) -import Stack.Types.NamedComponent ( exeComponents, renderComponent ) +import Stack.Types.NamedComponent + ( NamedComponent (..), exeComponents, isCBench, isCTest + , renderComponent + ) import Stack.Types.Package ( ExeName (..), LocalPackage (..), Package (..) , PackageSource (..), installedMapGhcPkgId , packageIdentifier, psVersion, runMemoizedWith ) import Stack.Types.Plan - ( Plan (..), Task (..), TaskConfigOpts (..), TaskType (..) - , installLocationIsMutable, taskIsTarget, taskLocation - , taskProvides, taskTargetIsMutable + ( ComponentKey (..), Plan (..), Task (..) + , TaskConfigOpts (..), TaskType (..) + , componentKeyPkgName, installLocationIsMutable + , taskIsTarget, taskLocation, taskProvides + , taskTargetIsMutable ) import Stack.Types.ProjectConfig ( isPCGlobalProject ) import Stack.Types.Runner ( HasRunner (..), globalOptsL ) @@ -122,6 +134,7 @@ constructPlan :: forall env. HasEnvConfig env => BaseConfigOpts -> [DumpPackage] -- ^ locally registered + -> [DumpPackage] -- ^ all dump packages (global + snapshot + local) -> ( PackageLocationImmutable -> Map FlagName Bool -> [Text] @@ -139,6 +152,7 @@ constructPlan :: constructPlan baseConfigOpts0 localDumpPkgs + allDumpPkgs loadPackage0 sourceMap installedMap @@ -208,7 +222,28 @@ constructPlan errs = errlibs ++ errfinals if null errs then do - let tasks = Map.fromList $ mapMaybe (toMaybe . second toTask) adrs + -- Upgrade ADRFound entries to ADRToInstall for indefinite packages + -- whose source is available. This ensures addInstantiationTasks can + -- clone their Task to create CInst instantiation tasks. + let loadPkg w x y z = applyForceCustomBuild globalCabalVersion + <$> loadPackage0 w x y z + -- Build a module lookup map from installed packages (dump data). + -- Used by addInstantiationTasks to resolve modules from ADRFound + -- packages that don't have Package metadata. + installedModules = Map.fromListWith Set.union + [ (pkgName dp.packageIdent, dp.exposedModules) + | dp <- allDumpPkgs + , isNothing dp.sublib -- Only main libraries + ] + adrs' <- upgradeFoundIndefinites + loadPkg econfig ctx.combinedMap ctx.baseConfigOpts adrs + let expandedAdrs = concatMap (uncurry expandToComponentKeys) adrs' + (withInstantiations, bpWarnings) = + addInstantiationTasks installedModules adrs' expandedAdrs + tasks = Map.fromList $ mapMaybe + (toMaybe . second toTask) + withInstantiations + mapM_ prettyWarn bpWarnings takeSubset Plan { tasks = tasks , finals = Map.fromList finals @@ -306,7 +341,8 @@ constructPlan -- | Throw an exception if there are any snapshot packages in the plan. errorOnSnapshot :: Plan -> RIO env Plan errorOnSnapshot plan@(Plan tasks _finals _unregister installExes) = do - let snapTasks = Map.keys $ Map.filter (\t -> taskLocation t == Snap) tasks + let snapTasks = Set.toList $ Set.fromList $ map componentKeyPkgName + $ Map.keys $ Map.filter (\t -> taskLocation t == Snap) tasks snapExes = Map.keys $ Map.filter (== Snap) installExes unless (null snapTasks && null snapExes) $ prettyThrowIO $ NotOnlyLocal snapTasks snapExes @@ -348,7 +384,7 @@ constructPlan -- | Determine which packages to unregister based on the given tasks and -- already registered project packages and local extra-deps. mkUnregisterLocal :: - Map PackageName Task + Map ComponentKey Task -- ^ Tasks -> Map PackageName Text -- ^ Reasons why packages are dirty and must be rebuilt @@ -358,12 +394,17 @@ mkUnregisterLocal :: -- ^ If true, we're doing a special initialBuildSteps build - don't -- unregister target packages. -> Map GhcPkgId (PackageIdentifier, Text) -mkUnregisterLocal tasks dirtyReason localDumpPkgs initialBuildSteps = +mkUnregisterLocal componentTasks dirtyReason localDumpPkgs initialBuildSteps = -- We'll take multiple passes through the local packages. This will allow us -- to detect that a package should be unregistered, as well as all packages -- directly or transitively depending on it. loop Map.empty localDumpPkgs where + -- Derive a per-package task map: pick one representative task per package. + tasks :: Map PackageName Task + tasks = Map.fromList + [ (componentKeyPkgName ck, t) | (ck, t) <- Map.toList componentTasks ] + loop :: Map GhcPkgId (PackageIdentifier, Text) -- ^ Current local packages to unregister. @@ -448,25 +489,17 @@ mkUnregisterLocal tasks dirtyReason localDumpPkgs initialBuildSteps = relevantPkgName :: PackageName relevantPkgName = maybe (pkgName ident) pkgName mParentLibId --- | Given a t'LocalPackage' and its 'testBench', adds a t'Task' for running --- its tests and benchmarks. --- --- If @isAllInOne@ is 'True', then this means that the build step will also --- build the tests. Otherwise, this indicates that there's a cyclic dependency --- and an additional build step needs to be done. --- --- This will also add all the deps needed to build the tests / benchmarks. If --- @isAllInOne@ is 'True' (the common case), then all of these should have --- already been taken care of as part of the build step. +-- | Given a t'LocalPackage' and its test\/benchmark 'Package', adds a +-- t'Task' for running its tests and benchmarks. Resolves the package's deps +-- via 'addPackageDeps' (in the common case these have already been resolved +-- for the library build, so the lookups are cache hits). addFinal :: LocalPackage -> Package - -> Bool - -- ^ Will the build step also build the tests? -> Bool -- ^ Should Haddock documentation be built? -> M () -addFinal lp package allInOne buildHaddocks = do +addFinal lp package buildHaddocks = do res <- addPackageDeps package >>= \case Left e -> pure $ Left e Right (MissingPresentDeps missing present _minLoc) -> do @@ -479,17 +512,27 @@ addFinal lp package allInOne buildHaddocks = do , isLocalNonExtraDep = True , isMutable = Mutable , pkgConfigOpts + , instantiationDeps = [] } pure $ Right Task { configOpts , buildHaddocks , present , taskType = TTLocalMutable lp - , allInOne , cachePkgSrc = CacheSrcLocal (toFilePath (parent lp.cabalFP)) , buildTypeConfig = packageBuildTypeConfig package + , backpackInstEntries = [] } - tell mempty { wFinals = Map.singleton package.name res } + let finalKeys + | shouldSplitComponents package = + let testComps = filter isCTest $ Set.toList lp.components + benchComps = filter isCBench $ Set.toList lp.components + in case testComps ++ benchComps of + [] -> [ComponentKey package.name CLib] + comps -> map (ComponentKey package.name) comps + | otherwise = [ComponentKey package.name CLib] + forM_ finalKeys $ \ck -> + tell mempty { wFinals = Map.singleton ck res } -- | Given a 'PackageName', adds all of the build tasks to build the package, if -- needed. First checks if the package name is in the library map. @@ -663,24 +706,24 @@ installPackage name ps minstalled = do case ps of PSRemote pkgLoc _version _fromSnapshot cp -> do logDebugPlanS "installPackage" $ - "Doing all-in-one build for upstream package " + "Building upstream package " <> fromPackageName name <> "." package <- ctx.loadPackage pkgLoc cp.flags cp.ghcOptions cp.cabalConfigOpts - resolveDepsAndInstall True cp.buildHaddocks ps package minstalled + resolveDepsAndInstall cp.buildHaddocks ps package minstalled PSFilePath lp -> do case lp.testBench of Nothing -> do logDebugPlanS "installPackage" $ "No test or bench component for " <> fromPackageName name - <> " so doing an all-in-one build." + <> ", building directly." resolveDepsAndInstall - True lp.buildHaddocks ps lp.package minstalled + lp.buildHaddocks ps lp.package minstalled Just tb -> do - -- Attempt to find a plan which performs an all-in-one build. Ignore - -- the writer action + reset the state if it fails. + -- Attempt to resolve test/bench deps together with the library. + -- Ignore the writer action + reset the state if it fails. libMap <- get res <- pass $ do res <- addPackageDeps tb @@ -694,22 +737,15 @@ installPackage name ps minstalled = do "For " <> fromPackageName name <> ", successfully added package deps." - -- in curator builds we can't do all-in-one build as - -- test/benchmark failure could prevent library from being - -- available to its dependencies but when it's already available - -- it's OK to do that - splitRequired <- expectedTestOrBenchFailures <$> asks (.curator) - let isAllInOne = not splitRequired adr <- installPackageGivenDeps - isAllInOne lp.buildHaddocks ps tb minstalled deps - let finalAllInOne = not (isAdrToInstall adr && splitRequired) + lp.buildHaddocks ps tb minstalled deps -- FIXME: this redundantly adds the deps (but they'll all just -- get looked up in the map) - addFinal lp tb finalAllInOne False + addFinal lp tb False pure $ Right adr Left _ -> do - -- Reset the state to how it was before attempting to find an - -- all-in-one build plan. + -- Reset the state to how it was before attempting to find a + -- combined build plan. logDebugPlanS "installPackage" $ "Before trying cyclic plan, resetting lib result map to: " <> fromString (show libMap) @@ -717,49 +753,40 @@ installPackage name ps minstalled = do -- Otherwise, fall back on building the tests / benchmarks in a -- separate step. res' <- resolveDepsAndInstall - False lp.buildHaddocks ps lp.package minstalled + lp.buildHaddocks ps lp.package minstalled when (isRight res') $ do -- Insert it into the map so that it's available for addFinal. updateLibMap name res' - addFinal lp tb False False + addFinal lp tb False pure res' - where - expectedTestOrBenchFailures maybeCurator = fromMaybe False $ do - curator <- maybeCurator - pure $ Set.member name curator.expectTestFailure - || Set.member name curator.expectBenchmarkFailure resolveDepsAndInstall :: Bool - -- ^ will the build step also build any tests? - -> Bool -- ^ Should Haddock documentation be built? -> PackageSource -> Package -> Maybe Installed -> M (Either ConstructPlanException AddDepRes) -resolveDepsAndInstall isAllInOne buildHaddocks ps package minstalled = +resolveDepsAndInstall buildHaddocks ps package minstalled = addPackageDeps package >>= \case Left err -> pure $ Left err Right deps -> Right <$> installPackageGivenDeps - isAllInOne buildHaddocks ps package minstalled deps + buildHaddocks ps package minstalled deps -- | Checks if we need to install the given t'Package', given the results of -- 'addPackageDeps'. If dependencies are missing, the package is dirty, or it is -- not installed, then it needs to be installed. installPackageGivenDeps :: Bool - -- ^ will the build step also build any tests? - -> Bool -- ^ Should Haddock documentation be built? -> PackageSource -> Package -> Maybe Installed -> MissingPresentDeps -> M AddDepRes -installPackageGivenDeps allInOne buildHaddocks ps package minstalled +installPackageGivenDeps buildHaddocks ps package minstalled (MissingPresentDeps missing present minMutable) = do let name = package.name mRightVersionInstalled <- case minstalled of @@ -788,6 +815,7 @@ installPackageGivenDeps allInOne buildHaddocks ps package minstalled , isLocalNonExtraDep = psLocal ps , isMutable , pkgConfigOpts + , instantiationDeps = [] } pure $ case mRightVersionInstalled of Just installed -> ADRFound loc installed @@ -801,15 +829,48 @@ installPackageGivenDeps allInOne buildHaddocks ps package minstalled TTLocalMutable lp PSRemote pkgLoc _version _fromSnapshot _cp -> TTRemotePackage isMutable package pkgLoc - , allInOne , cachePkgSrc = toCachePkgSrc ps , buildTypeConfig = packageBuildTypeConfig package + , backpackInstEntries = [] } -- | Is the build type of the package Configure packageBuildTypeConfig :: Package -> Bool packageBuildTypeConfig pkg = pkg.buildType == Configure +-- | Whether a package should be split into per-component tasks. Only local +-- packages with Simple build type and no intra-package dependencies (Backpack) +-- are split. Remote packages, Custom/Hooks/Make build types, and Backpack +-- packages get a single task. +shouldSplitComponents :: Package -> Bool +shouldSplitComponents pkg = + pkg.buildType == Simple && not (hasIntraPackageDeps pkg) + +-- | Expand an AddDepRes into per-component (ComponentKey, AddDepRes) pairs. +-- For local Simple packages without intra-package deps, creates one entry per +-- buildable component (lib, sub-libs, foreign libs, exes). Everything else +-- gets a single CLib entry. +expandToComponentKeys :: + PackageName -> AddDepRes -> [(ComponentKey, AddDepRes)] +expandToComponentKeys name adr = case adr of + ADRToInstall task -> case task.taskType of + TTLocalMutable lp + | shouldSplitComponents lp.package -> + let pkg = lp.package + libComps = [CLib | hasBuildableMainLibrary pkg] + subLibComps = + map CSubLib $ Set.toList $ buildableSubLibs pkg + flibComps = + map CFlib $ Set.toList $ buildableForeignLibs pkg + exeComps = + map CExe $ Set.toList $ buildableExes pkg + allComps = libComps ++ subLibComps ++ flibComps ++ exeComps + in case allComps of + [] -> [(ComponentKey name CLib, adr)] + _ -> map (\comp -> (ComponentKey name comp, adr)) allComps + _ -> [(ComponentKey name CLib, adr)] + _ -> [(ComponentKey name CLib, adr)] + -- Update response in the library map. If it is an error, and there's already an -- error about cyclic dependencies, prefer the cyclic error. updateLibMap :: PackageName -> Either ConstructPlanException AddDepRes -> M () diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index a64035fbdf..77b43a303b 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -18,6 +18,10 @@ module Stack.Build.Execute -- * Running Setup.hs , ExcludeTHLoading (..) , KeepOutputOpen (..) + -- * Exported for testing + , missingToDeps + , intraPackageDeps + , finalTestsAndBenches ) where import Control.Concurrent.Execute @@ -81,13 +85,14 @@ import Stack.Types.Installed ( InstallLocation (..), InstalledMap , installedPackageIdentifier ) -import Stack.Types.NamedComponent - ( NamedComponent, benchComponents, testComponents ) import Stack.Types.Package ( LocalPackage (..), Package (..), packageIdentifier ) +import Stack.Types.NamedComponent + ( NamedComponent (..), benchComponents, testComponents ) import Stack.Types.Plan - ( Plan (..), Task (..), TaskConfigOpts (..), TaskType (..) - , taskLocation, taskProvides + ( ComponentKey (..), Plan (..), Task (..) + , TaskConfigOpts (..), TaskType (..) + , componentKeyPkgName, taskLocation, taskProvides ) import Stack.Types.Platform ( HasPlatform (..) ) import Stack.Types.Runner ( terminalL, viewExecutablePath ) @@ -286,7 +291,7 @@ executePlan where mlargestPackageName = Set.lookupMax $ - Set.map (length . packageNameString) $ + Set.map (length . packageNameString . componentKeyPkgName) $ Map.keysSet plan.tasks <> Map.keysSet plan.finals copyExecutables :: @@ -406,8 +411,10 @@ executePlan' installedMap0 targets plan ee = do then pure Nothing else Just <$> liftIO (newMVar ()) - let actions = concatMap (toActions installedMap' mtestLock run ee) $ - Map.elems $ Map.merge + let taskKeys = Map.keysSet plan.tasks + actions = concatMap + (uncurry $ toActions installedMap' mtestLock run ee taskKeys) $ + Map.toList $ Map.merge (Map.mapMissing (\_ b -> (Just b, Nothing))) (Map.mapMissing (\_ f -> (Nothing, Just f))) (Map.zipWithMatched (\_ b f -> (Just b, Just f))) @@ -447,7 +454,7 @@ executePlan' installedMap0 targets plan ee = do | otherwise = do inProgress <- readTVarIO actionsVar let packageNames = map - (\(ActionId pkgID _) -> pkgName pkgID) + (\(ActionId ck' _) -> componentKeyPkgName ck') (toList inProgress) nowBuilding :: [PackageName] -> Utf8Builder nowBuilding [] = "" @@ -500,8 +507,10 @@ executePlan' installedMap0 targets plan ee = do when buildOpts.openHaddocks $ do let planPkgs, localPkgs, installedPkgs, availablePkgs :: Map PackageName (PackageIdentifier, InstallLocation) - planPkgs = - Map.map (taskProvides &&& taskLocation) plan.tasks + planPkgs = Map.fromList + [ (componentKeyPkgName ck, (taskProvides t, taskLocation t)) + | (ck, t) <- Map.toList plan.tasks + ] localPkgs = Map.fromList [ (p.name, (packageIdentifier p, Local)) @@ -558,84 +567,88 @@ toActions :: -> Maybe (MVar ()) -> (RIO env () -> IO ()) -> ExecuteEnv + -> Set ComponentKey + -- ^ All component keys that have build tasks (not finals), used to + -- determine intra-package dependencies. + -> ComponentKey -> (Maybe Task, Maybe Task) -- build and final -> [Action] -toActions installedMap mtestLock runInBase ee (mbuild, mfinal) = +toActions installedMap mtestLock runInBase ee taskKeys ck (mbuild, mfinal) = abuild ++ afinal where + intraPackageDep = intraPackageDeps taskKeys ck abuild = case mbuild of Nothing -> [] Just task -> [ Action - { actionId = ActionId (taskProvides task) ATBuild + { actionId = ActionId ck ATBuild , actionDeps = - Set.map (`ActionId` ATBuild) task.configOpts.missing + missingToDeps task.configOpts.missing + <> intraPackageDep + <> Set.fromList + (map (`ActionId` ATBuild) + task.configOpts.instantiationDeps) , action = - \ac -> runInBase $ singleBuild ac ee task installedMap False + \ac -> runInBase $ singleBuild ac ee task installedMap False ck , concurrency = ConcurrencyAllowed } ] afinal = case mfinal of Nothing -> [] - Just task -> - ( if task.allInOne - then id - else (:) Action - { actionId = ActionId pkgId ATBuildFinal - , actionDeps = addBuild - (Set.map (`ActionId` ATBuild) task.configOpts.missing) - , action = - \ac -> runInBase $ singleBuild ac ee task installedMap True - , concurrency = ConcurrencyAllowed - } - ) $ + Just task -> finalBuild ++ finalRun + where + (tests, benches) = finalTestsAndBenches ck (taskComponents task) + buildDep = Set.singleton (ActionId ck ATBuild) + -- When there's no library build task, we need our own build step for + -- tests/benchmarks. When there IS a library build, depend on it instead. + finalBuild = case mbuild of + Just _ -> [] + Nothing -> + [ Action + { actionId = ActionId ck ATBuild + , actionDeps = + missingToDeps task.configOpts.missing + <> intraPackageDep + <> Set.fromList + (map (`ActionId` ATBuild) + task.configOpts.instantiationDeps) + , action = + \ac -> runInBase $ singleBuild ac ee task installedMap True ck + , concurrency = ConcurrencyAllowed + } + ] -- These are the "final" actions - running test suites and benchmarks, -- unless --no-run-tests or --no-run-benchmarks is enabled. - ( if Set.null tests || not runTests - then id - else (:) Action - { actionId = ActionId pkgId ATRunTests - , actionDeps = finalDeps - , action = \ac -> withLock mtestLock $ runInBase $ - singleTest topts (Set.toList tests) ac ee task installedMap - -- Always allow tests tasks to run concurrently with other tasks, - -- particularly build tasks. Note that 'mtestLock' can optionally - -- make it so that only one test is run at a time. - , concurrency = ConcurrencyAllowed - } - ) $ - ( if Set.null benches || not runBenchmarks - then id - else (:) Action - { actionId = ActionId pkgId ATRunBenchmarks - , actionDeps = finalDeps - , action = \ac -> runInBase $ - singleBench - beopts - (Set.toList benches) - ac - ee - task - installedMap - -- Never run benchmarks concurrently with any other task, see - -- #3663 - , concurrency = ConcurrencyDisallowed - } - ) - [] - where - pkgId = taskProvides task - comps = taskComponents task - tests = testComponents comps - benches = benchComponents comps - finalDeps = - if task.allInOne - then addBuild mempty - else Set.singleton (ActionId pkgId ATBuildFinal) - addBuild = - case mbuild of - Nothing -> id - Just _ -> Set.insert $ ActionId pkgId ATBuild + finalRun = + [ Action + { actionId = ActionId ck ATRunTests + , actionDeps = buildDep + , action = \ac -> withLock mtestLock $ runInBase $ + singleTest topts (Set.toList tests) ac ee task installedMap + -- Always allow test tasks to run concurrently with other + -- tasks, particularly build tasks. Note that 'mtestLock' can + -- optionally make it so that only one test is run at a time. + , concurrency = ConcurrencyAllowed + } + | not (Set.null tests) && runTests + ] + ++ [ Action + { actionId = ActionId ck ATRunBenchmarks + , actionDeps = buildDep + , action = \ac -> runInBase $ + singleBench + beopts + (Set.toList benches) + ac + ee + task + installedMap + -- Never run benchmarks concurrently with any other task, see + -- #3663 + , concurrency = ConcurrencyDisallowed + } + | not (Set.null benches) && runBenchmarks + ] withLock Nothing f = f withLock (Just lock) f = withMVar lock $ \() -> f bopts = ee.buildOpts @@ -644,6 +657,39 @@ toActions installedMap mtestLock runInBase ee (mbuild, mfinal) = runTests = topts.runTests runBenchmarks = beopts.runBenchmarks +-- | Map external package dependencies to ActionIds. External dependencies are +-- always library dependencies, so each PackageIdentifier maps to a +-- ComponentKey with CLib. +missingToDeps :: Set PackageIdentifier -> Set ActionId +missingToDeps = Set.map + (\pid -> ActionId (ComponentKey (pkgName pid) CLib) ATBuild) + +-- | Compute intra-package dependencies for a component. Non-CLib components +-- depend on CLib ATBuild of the same package, if a CLib build task exists in +-- the plan. CLib itself has no intra-package deps. +intraPackageDeps :: Set ComponentKey -> ComponentKey -> Set ActionId +intraPackageDeps taskKeys ck = case ck of + ComponentKey _ CLib -> Set.empty + ComponentKey name _ -> + let libKey = ComponentKey name CLib + in if libKey `Set.member` taskKeys + then Set.singleton (ActionId libKey ATBuild) + else Set.empty + +-- | Determine which test suites and benchmarks should be run for a final +-- action. For per-component CTest\/CBench keys, returns exactly that one +-- component. For non-split CLib keys, returns all tests\/benches from the +-- component set. +finalTestsAndBenches :: + ComponentKey + -> Set NamedComponent + -> (Set StackUnqualCompName, Set StackUnqualCompName) + -- ^ (tests, benches) +finalTestsAndBenches ck comps = case ck of + ComponentKey _ (CTest name) -> (Set.singleton name, Set.empty) + ComponentKey _ (CBench name) -> (Set.empty, Set.singleton name) + _ -> (testComponents comps, benchComponents comps) + taskComponents :: Task -> Set NamedComponent taskComponents task = case task.taskType of diff --git a/src/Stack/Build/ExecuteEnv.hs b/src/Stack/Build/ExecuteEnv.hs index dfee2c548e..ccb553d0c3 100644 --- a/src/Stack/Build/ExecuteEnv.hs +++ b/src/Stack/Build/ExecuteEnv.hs @@ -110,7 +110,8 @@ import Stack.Types.Installed ( InstallLocation (..), Installed (..) ) import Stack.Types.Package ( LocalPackage (..), Package (..), packageIdentifier ) import Stack.Types.Plan - ( TaskType (..), taskTypeLocation, taskTypePackageIdentifier + ( TaskType (..), componentKeyPkgName + , taskTypeLocation, taskTypePackageIdentifier ) import Stack.Types.Platform ( HasPlatform (..) ) import Stack.Types.Version ( withinRange ) @@ -599,6 +600,11 @@ withSingleContext :: -> Map PackageIdentifier GhcPkgId -- ^ All dependencies' package ids to provide to Setup.hs. -> Maybe String + -> Maybe Text + -- ^ Optional CInst dist-dir suffix for Backpack instantiation tasks. + -- When 'Just', the @--builddir@ passed to Setup.hs is extended with + -- @inst-\@ so that the instantiated build does not clobber the + -- indefinite package's build artifacts. -> ( Package -- Package info -> Path Abs File -- Cabal file path -> Path Abs Dir -- Package root directory file path @@ -618,6 +624,7 @@ withSingleContext taskType allDeps msuffix + mInstSuffix inner0 = withPackage $ \package cabalFP pkgDir -> withOutputType pkgDir package $ \outputType -> @@ -643,7 +650,7 @@ withSingleContext console = ( wanted && all - (\(ActionId ident _) -> ident == pkgId) + (\(ActionId ck _) -> componentKeyPkgName ck == pkgName pkgId) (Set.toList ac.remaining) && ee.totalWanted == 1 ) @@ -725,6 +732,11 @@ withSingleContext } menv <- liftIO $ config.processContextSettings envSettings distRelativeDir' <- distRelativeDir + buildDir <- case mInstSuffix of + Nothing -> pure distRelativeDir' + Just suffix -> do + instSubDir <- parseRelDir ("inst-" ++ T.unpack suffix) + pure (distRelativeDir' instSubDir) setupexehs <- -- Avoid broken Setup.hs files causing problems for simple build -- types, see: @@ -873,7 +885,7 @@ withSingleContext <> cabalPackageArg setupArgs = - ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args + ("--builddir=" ++ toFilePathNoTrailingSep buildDir) : args runExe :: Path Abs File -> [String] -> RIO env () runExe exeName fullArgs = do diff --git a/src/Stack/Build/ExecutePackage.hs b/src/Stack/Build/ExecutePackage.hs index b03d1d2b02..a0f16d70d7 100644 --- a/src/Stack/Build/ExecutePackage.hs +++ b/src/Stack/Build/ExecutePackage.hs @@ -16,6 +16,12 @@ module Stack.Build.ExecutePackage ( singleBuild , singleTest , singleBench + , componentTarget + , componentEnableTests + , componentEnableBenchmarks + -- * Backpack helpers (exported for testing) + , findGhcPkgId + , mkInstantiateWithOpts ) where import Control.Concurrent.Execute @@ -33,6 +39,7 @@ import qualified Data.List as L import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T +import Distribution.ModuleName ( ModuleName ) import qualified Distribution.PackageDescription as C import Distribution.System ( OS (..), Platform (..) ) import qualified Distribution.Text as C @@ -55,6 +62,7 @@ import RIO.Process , useHandleOpen, waitExitCode, withModifyEnvVars , withProcessWait, withWorkingDir ) +import Stack.Build.ConstructPlan ( shouldSplitComponents ) import Stack.Build.Cache ( TestStatus (..), deleteCaches, getTestStatus , markExeInstalled, markExeNotInstalled, readPrecompiledCache @@ -82,7 +90,7 @@ import Stack.Coverage ( generateHpcReport, updateTixFile ) import Stack.GhcPkg ( ghcPkg, ghcPkgPathEnvVar, unregisterGhcPkgIds ) import Stack.Package ( buildLogPath, buildableExes, buildableSubLibs - , hasBuildableMainLibrary + , hasBuildableMainLibrary, hasIntraPackageDeps ) import Stack.PackageDump ( conduitDumpPackage, ghcPkgDescribe ) import Stack.Prelude @@ -96,7 +104,9 @@ import Stack.Types.BuildOpts ) import Stack.Types.BuildOptsCLI ( BuildOptsCLI (..) ) import Stack.Types.Cache - ( ConfigCache (..), PrecompiledCache (..) ) + ( ConfigCache (..), ConfigCacheType (..) + , PrecompiledCache (..) + ) import qualified Stack.Types.Cache as ConfigCache ( ConfigCache (..) ) import Stack.Types.CompCollection ( collectionKeyValueList, collectionLookup @@ -123,7 +133,8 @@ import Stack.Types.EnvConfig , appropriateGhcColorFlag ) import Stack.Types.EnvSettings ( EnvSettings (..) ) -import Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdToText ) +import Stack.Types.GhcPkgId + ( GhcPkgId, ghcPkgIdString, ghcPkgIdToText ) import Stack.Types.GlobalOpts ( GlobalOpts (..) ) import Stack.Types.Installed ( InstallLocation (..), Installed (..), InstalledMap @@ -131,7 +142,7 @@ import Stack.Types.Installed ) import Stack.Types.IsMutable ( IsMutable (..) ) import Stack.Types.NamedComponent - ( NamedComponent, exeComponents, isCBench, isCTest + ( NamedComponent (..), exeComponents, isCBench, isCTest , renderComponent ) import Stack.Types.Package @@ -141,7 +152,8 @@ import Stack.Types.Package ) import Stack.Types.PackageFile ( PackageWarning (..) ) import Stack.Types.Plan - ( Task (..), TaskConfigOpts (..), TaskType (..), taskIsTarget + ( ComponentKey (..), Task (..), TaskConfigOpts (..) + , TaskType (..), componentKeyPkgName, taskIsTarget , taskLocation, taskProvides, taskTargetIsMutable , taskTypePackageIdentifier ) @@ -204,8 +216,14 @@ getConfigCache ee task installedMap enableTest enableBench = do cOpts.isLocalNonExtraDep cOpts.isMutable pcOpts + instWithOpts = + mkInstantiateWithOpts task.backpackInstEntries allDepsMap configureOpts = configureOpts' - { nonPathRelated = configureOpts'.nonPathRelated ++ map T.unpack extra } + { nonPathRelated = + configureOpts'.nonPathRelated + ++ map T.unpack extra + ++ instWithOpts + } deps = Set.fromList $ Map.elems missing' ++ Map.elems task.present components = case task.taskType of TTLocalMutable lp -> @@ -221,6 +239,40 @@ getConfigCache ee task installedMap enableTest enableBench = do } pure (allDepsMap, cache) +-- | Look up the 'GhcPkgId' for a package by its 'PackageName' in a dependency +-- map keyed by 'PackageIdentifier'. Used to resolve implementing packages for +-- Backpack @--instantiate-with@ flags. +findGhcPkgId :: + Map PackageIdentifier GhcPkgId + -> PackageName + -> Maybe GhcPkgId +findGhcPkgId depsMap pn = + case [gid | (PackageIdentifier n _, gid) <- Map.toList depsMap, n == pn] of + (gid:_) -> Just gid + [] -> Nothing + +-- | Generate @--instantiate-with@ configure flags for CInst (Backpack +-- instantiation) tasks. Each entry maps a signature name to an implementing +-- module identified by its package's 'GhcPkgId'. +-- +-- Format: @--instantiate-with=SigName=\:ImplModuleName@ +mkInstantiateWithOpts :: + [(ModuleName, PackageName, ModuleName)] + -- ^ Backpack instantiation entries: (sigName, implPkgName, implModuleName) + -> Map PackageIdentifier GhcPkgId + -- ^ All dependency GhcPkgIds + -> [String] +mkInstantiateWithOpts entries depsMap = + [ "--instantiate-with=" + ++ C.display sigName + ++ "=" + ++ ghcPkgIdString implGhcPkgId + ++ ":" + ++ C.display implModuleName + | (sigName, implPkgName, implModuleName) <- entries + , Just implGhcPkgId <- [findGhcPkgId depsMap implPkgName] + ] + -- | Ensure that the configuration for the package matches what is given ensureConfig :: HasEnvConfig env @@ -229,6 +281,8 @@ ensureConfig :: -> Path Abs Dir -- ^ package directory -> BuildOpts + -> Maybe Text + -- ^ CInst hash suffix (Nothing for normal builds) -> RIO env () -- ^ announce -> (ExcludeTHLoading -> [String] -> RIO env ()) @@ -237,10 +291,24 @@ ensureConfig :: -- ^ Cabal file -> Task -> RIO env Bool -ensureConfig newConfigCache pkgDir buildOpts announce cabal cabalFP task = do +ensureConfig newConfigCache pkgDir buildOpts mInstSuffix announce cabal cabalFP task = do + -- CInst (Backpack instantiation) tasks share a source directory with the + -- indefinite package but use a separate --builddir. They use a separate + -- config cache entry (ConfigCacheTypeInstantiation) to avoid colliding with + -- the indefinite build's cache. File-based caches (cabalMod, + -- projectRoot) are shared since the .cabal file is the same, but + -- setup-config lives in the inst builddir and must be checked there. + let configCacheType = + maybe ConfigCacheTypeConfig ConfigCacheTypeInstantiation mInstSuffix newCabalMod <- liftIO $ modificationTime <$> getFileStatus (toFilePath cabalFP) - setupConfigfp <- setupConfigFromDir pkgDir + setupConfigfp <- case mInstSuffix of + Nothing -> setupConfigFromDir pkgDir + Just suffix -> do + dist <- distDirFromDir pkgDir + instSubDir <- parseRelDir ("inst-" ++ T.unpack suffix) + setupConfig <- parseRelFile "setup-config" + pure $ dist instSubDir setupConfig let getNewSetupConfigMod = liftIO $ either (const Nothing) (Just . modificationTime) <$> tryJust @@ -267,7 +335,7 @@ ensureConfig newConfigCache pkgDir buildOpts announce cabal cabalFP task = do ignoreComponents cc = cc { ConfigCache.components = Set.empty } -- Determine the old and new Cabal configuration for the package -- directory, to determine if we need to reconfigure. - mOldConfigCache <- tryGetConfigCache pkgDir + mOldConfigCache <- tryGetConfigCache pkgDir configCacheType mOldCabalMod <- tryGetCabalMod pkgDir @@ -290,7 +358,7 @@ ensureConfig newConfigCache pkgDir buildOpts announce cabal cabalFP task = do ensureConfigureScript pkgDir when needConfig $ do - deleteCaches pkgDir + deleteCaches pkgDir configCacheType announce cp <- view compilerPathsL let (GhcPkgExe pkgPath) = cp.pkg @@ -310,18 +378,22 @@ ensureConfig newConfigCache pkgDir buildOpts announce cabal cabalFP task = do -- Configure cabal with arguments determined by -- Stack.Types.Build.configureOpts cabal KeepTHLoading $ "configure" : allOpts - -- Only write the cache for local packages. Remote packages are built in a + -- Only write the cache for local packages. Remote packages are built in a -- temporary directory so the cache would never be used anyway. case task.taskType of - TTLocalMutable{} -> writeConfigCache pkgDir newConfigCache + TTLocalMutable{} -> writeConfigCache pkgDir configCacheType newConfigCache TTRemotePackage{} -> pure () - writeCabalMod pkgDir newCabalMod - -- This file gets updated one more time by the configure step, so get the - -- most recent value. We could instead change our logic above to check if - -- our config mod file is newer than the file above, but this seems - -- reasonable too. - getNewSetupConfigMod >>= writeSetupConfigMod pkgDir - writePackageProjectRoot pkgDir newConfigFileRoot + -- File-based caches are shared with the indefinite build (same .cabal + -- file, same pkgDir). Only write them for normal (non-CInst) tasks to + -- avoid redundant writes. + when (isNothing mInstSuffix) $ do + writeCabalMod pkgDir newCabalMod + -- This file gets updated one more time by the configure step, so get the + -- most recent value. We could instead change our logic above to check if + -- our config mod file is newer than the file above, but this seems + -- reasonable too. + getNewSetupConfigMod >>= writeSetupConfigMod pkgDir + writePackageProjectRoot pkgDir newConfigFileRoot pure needConfig -- | Make a padded prefix for log messages @@ -347,9 +419,7 @@ announceTask ee taskType action = logInfo $ <> action -- | Implements running a package's build, used to implement --- 'Control.Concurrent.Execute.ATBuild' and --- 'Control.Concurrent.Execute.ATBuildFinal' tasks. The latter is a task for --- building a package's benchmarks and test-suites. +-- 'Control.Concurrent.Execute.ATBuild' tasks. -- -- In particular this does the following: -- @@ -374,6 +444,8 @@ singleBuild :: -> InstalledMap -> Bool -- ^ Is this a final build? + -> ComponentKey + -- ^ The component key identifying which component this build is for. -> RIO env () singleBuild ac @@ -381,14 +453,19 @@ singleBuild task installedMap isFinalBuild + ck = do (allDepsMap, cache) <- getConfigCache ee task installedMap enableTests enableBenchmarks let bcoSnapInstallRoot = ee.baseConfigOpts.snapInstallRoot - mprecompiled <- getPrecompiled cache task.taskType bcoSnapInstallRoot + isCInstTask = case ck of + ComponentKey _ (CInst _) -> True + _ -> False + mprecompiled <- getPrecompiled isCInstTask cache task.taskType bcoSnapInstallRoot minstalled <- case mprecompiled of - Just precompiled -> copyPreCompiled ee task pkgId precompiled + Just precompiled -> + copyPreCompiled isCInstTask ee task pkgId precompiled Nothing -> do curator <- view $ buildConfigL . to (.curator) realConfigAndBuild @@ -401,14 +478,24 @@ singleBuild cache curator allDepsMap - whenJust minstalled $ \installed -> do - writeFlagCache installed cache - liftIO $ atomically $ modifyTVar ee.ghcPkgIds $ Map.insert pkgId installed + ck + -- For CInst (Backpack instantiation) tasks, do NOT update the ghcPkgIds + -- TVar. The consumer's --dependency flag must reference the indefinite + -- GhcPkgId (stored by the CLib task). Cabal resolves the instantiation + -- by looking up the package DB using mixin declarations. Writing the + -- flag cache is also skipped to avoid clobbering the indefinite build's + -- cache. + unless isCInstTask $ + whenJust minstalled $ \installed -> do + writeFlagCache installed cache + liftIO $ atomically $ modifyTVar ee.ghcPkgIds $ Map.insert pkgId installed where pkgId = taskProvides task - buildingFinals = isFinalBuild || task.allInOne - enableTests = buildingFinals && any isCTest (taskComponents task) - enableBenchmarks = buildingFinals && any isCBench (taskComponents task) + buildingFinals = isFinalBuild + enableTests = buildingFinals + && componentEnableTests ck (taskComponents task) + enableBenchmarks = buildingFinals + && componentEnableBenchmarks ck (taskComponents task) realConfigAndBuild :: forall env a. HasEnvConfig env @@ -423,6 +510,7 @@ realConfigAndBuild :: -> ConfigCache -> Maybe Curator -> Map PackageIdentifier GhcPkgId + -> ComponentKey -> RIO env (Maybe Installed) realConfigAndBuild ac @@ -434,7 +522,8 @@ realConfigAndBuild cache mcurator0 allDepsMap - = withSingleContext ac ee task.taskType allDepsMap Nothing $ + ck + = withSingleContext ac ee task.taskType allDepsMap Nothing mInstSuffix $ \package cabalFP pkgDir cabal0 announce _outputType -> do let cabal = cabal0 CloseOnException _neededConfig <- @@ -442,6 +531,7 @@ realConfigAndBuild cache pkgDir ee.buildOpts + mInstSuffix (announce ("configure" <> display annSuffix)) cabal cabalFP @@ -474,6 +564,9 @@ realConfigAndBuild where pkgId = taskProvides task PackageIdentifier pname _ = pkgId + mInstSuffix = case ck of + ComponentKey _ (CInst hashSuffix) -> Just hashSuffix + _ -> Nothing doHaddock curator = task.buildHaddocks && not isFinalBuild @@ -481,24 +574,7 @@ realConfigAndBuild -- to fail && maybe True (Set.notMember pname . (.skipHaddock)) curator - annSuffix = if result == "" then "" else " (" <> result <> ")" - where - result = T.intercalate " + " $ concat - [ ["lib" | task.allInOne && hasLib] - , ["sub-lib" | task.allInOne && hasSubLib] - , ["exe" | task.allInOne && hasExe] - , ["test" | enableTests] - , ["bench" | enableBenchmarks] - ] - (hasLib, hasSubLib, hasExe) = case task.taskType of - TTLocalMutable lp -> - let package = lp.package - hasLibrary = hasBuildableMainLibrary package - hasSubLibraries = not $ null package.subLibraries - hasExecutables = not . Set.null $ exesToBuild lp - in (hasLibrary, hasSubLibraries, hasExecutables) - -- This isn't true, but we don't want to have this info for upstream deps. - _ -> (False, False, False) + annSuffix = buildAnnSuffix ck task enableTests enableBenchmarks initialBuildSteps cabal announce = do announce ("initial-build-steps" <> display annSuffix) cabal KeepTHLoading ["repl", "stack-initial-build-steps"] @@ -574,17 +650,8 @@ realConfigAndBuild let stripTHLoading | config.hideTHLoading = ExcludeTHLoading | otherwise = KeepTHLoading - (buildOpts, copyOpts) <- - case (task.taskType, task.allInOne, isFinalBuild) of - (_, True, True) -> throwM AllInOneBuildBug - (TTLocalMutable lp, False, False) -> - let componentOpts = primaryComponentOptions lp - in pure (componentOpts, componentOpts) - (TTLocalMutable lp, False, True) -> pure (finalComponentOptions lp, []) - (TTLocalMutable lp, True, False) -> - let componentOpts = primaryComponentOptions lp - in pure (componentOpts <> finalComponentOptions lp, componentOpts) - (TTRemotePackage{}, _, _) -> pure ([], []) + let (buildOpts, copyOpts) = + buildAndCopyOpts task.taskType ck isFinalBuild cabal stripTHLoading ("build" : buildOpts <> extraOpts) `catch` \ex -> case ex of CabalExitedUnsuccessfully{} -> @@ -697,7 +764,7 @@ postProcessRemotePackage -- in tmp (#3018). let remaining = Set.filter - (\(ActionId x _) -> x == pkgId) + (\(ActionId ck _) -> componentKeyPkgName ck == pkgName pkgId) ac.remaining when (null remaining) $ removeDirRecur pkgDir _ -> pure () @@ -795,19 +862,28 @@ copyDdumpFilesIfNeeded buildingFinals mDdumpPath = when buildingFinals $ getPrecompiled :: HasEnvConfig env - => ConfigCache + => Bool + -- ^ Is this a CInst (Backpack instantiation) task? CInst tasks are + -- always created by addInstantiationTasks even when the instantiated + -- package is already registered. Skip the self-reference check so + -- the precompiled cache can short-circuit the build. + -> ConfigCache -> TaskType -> Path Abs Dir -> RIO env (Maybe (PrecompiledCache Abs)) -getPrecompiled cache taskType bcoSnapInstallRoot = +getPrecompiled isCInst cache taskType bcoSnapInstallRoot = case taskType of TTRemotePackage Immutable _ loc -> readPrecompiledCache loc cache.configureOpts cache.buildHaddocks >>= \case Nothing -> pure Nothing -- Only pay attention to precompiled caches that refer to packages - -- within the snapshot. + -- within the snapshot. For CInst tasks, skip this check: CInst + -- tasks are always created regardless of whether the instantiated + -- package is already installed, and re-registering with --force is + -- harmless. Just pc - | maybe False + | not isCInst + , maybe False (bcoSnapInstallRoot `isProperPrefixOf`) pc.library -> pure Nothing -- If old precompiled cache files are left around but snapshots are @@ -832,19 +908,26 @@ copyPreCompiled :: , HasProcessContext env , HasEnvConfig env ) - => ExecuteEnv + => Bool + -- ^ Is this a CInst (Backpack instantiation) task? If so, skip + -- unregistration — the indefinite package and other instantiations + -- must remain in the DB. + -> ExecuteEnv -> Task -> PackageIdentifier -> PrecompiledCache b0 -> RIO env (Maybe Installed) -copyPreCompiled ee task pkgId (PrecompiledCache mlib subLibs exes) = do +copyPreCompiled isCInst ee task pkgId (PrecompiledCache mlib subLibs exes) = do let PackageIdentifier pname pversion = pkgId announceTask ee task.taskType "using precompiled package" -- We need to copy .conf files for the main library and all sub-libraries -- which exist in the cache, from their old snapshot to the new one. -- However, we must unregister any such library in the new snapshot, in case - -- it was built with different flags. + -- it was built with different flags. For CInst tasks, we skip unregistration + -- because the indefinite package and other instantiations share the same + -- package name and must remain in the DB. The --force flag on register + -- handles any conflicts. let subLibNames = Set.toList $ buildableSubLibs $ case task.taskType of TTLocalMutable lp -> lp.package @@ -870,12 +953,15 @@ copyPreCompiled ee task pkgId (PrecompiledCache mlib subLibs exes) = do let pkgDb = ee.baseConfigOpts.snapDB ghcPkgExe <- getGhcPkgExe -- First unregister, silently, everything that needs to be unregistered. - whenJust (nonEmpty allToUnregister) $ \allToUnregister' -> do - logLevel <- view $ globalOptsL . to (.logLevel) - let isDebug = logLevel == LevelDebug - catchAny - (unregisterGhcPkgIds isDebug ghcPkgExe pkgDb allToUnregister') - (const (pure ())) + -- Skip for CInst tasks to preserve the indefinite and other instantiated + -- entries. + unless isCInst $ + whenJust (nonEmpty allToUnregister) $ \allToUnregister' -> do + logLevel <- view $ globalOptsL . to (.logLevel) + let isDebug = logLevel == LevelDebug + catchAny + (unregisterGhcPkgIds isDebug ghcPkgExe pkgDb allToUnregister') + (const (pure ())) -- There appears to be a bug in the ghc-pkg executable such that, on -- Windows only, it cannot register a package into a package database that -- is also listed in the GHC_PACKAGE_PATH environment variable. See: @@ -937,7 +1023,24 @@ loadInstalledPkg pkgDbs tvar name = do [dp] -> do liftIO $ atomically $ modifyTVar' tvar (Map.insert dp.ghcPkgId dp) pure $ Just dp.ghcPkgId - _ -> throwM $ MultipleResultsBug name dps + -- For Backpack packages, ghc-pkg may return multiple entries for the same + -- component name: an indefinite (signature-only) package and one or more + -- instantiated packages. Pick the last instantiated one (has '+' in its + -- ID) since that contains the compiled code. Multiple instantiations + -- arise when different consumers fill the same signature with different + -- implementations. Register all entries in the dump. + _ -> case filter isInstantiated dps of + [] -> throwM $ MultipleResultsBug name dps + instantiated -> do + forM_ dps $ \d -> + liftIO $ atomically $ modifyTVar' tvar (Map.insert d.ghcPkgId d) + -- Pick the last instantiated entry. With multiple instantiations, the + -- order doesn't matter — the caller (CInst) discards the result anyway. + let dp = L.last instantiated + pure $ Just dp.ghcPkgId + where + isInstantiated dp = + '+' `elem` ghcPkgIdString dp.ghcPkgId fulfillHaddockExpectations :: (MonadUnliftIO m, HasTerm env, MonadReader env m) @@ -996,7 +1099,7 @@ singleTest topts testsToRun ac ee task installedMap = do mcurator <- view $ buildConfigL . to (.curator) let pname = pkgName $ taskProvides task expectFailure = expectTestFailure pname mcurator - withSingleContext ac ee task.taskType allDepsMap (Just "test") $ + withSingleContext ac ee task.taskType allDepsMap (Just "test") Nothing $ \package _cabalfp pkgDir _cabal announce outputType -> do config <- view configL let needHpc = topts.coverage @@ -1275,7 +1378,7 @@ singleBench :: -> RIO env () singleBench beopts benchesToRun ac ee task installedMap = do (allDepsMap, _cache) <- getConfigCache ee task installedMap False True - withSingleContext ac ee task.taskType allDepsMap (Just "bench") $ + withSingleContext ac ee task.taskType allDepsMap (Just "bench") Nothing $ \_package _cabalfp _pkgDir cabal announce _outputType -> do let args = map unqualCompToString benchesToRun <> maybe [] ((:[]) . ("--benchmark-options=" <>)) @@ -1312,6 +1415,92 @@ extraBuildOptions wc bopts semaphore = do else pure $ semaphoreFlag ++ [optsFlag, baseOpts] +-- | Compute the announce suffix for build/configure log messages. For CInst +-- tasks, shows the instantiation details (e.g. @inst:941095d7: Str = impl-pkg@). +-- For other per-component builds, shows the component type. For final builds, +-- shows test/bench. +buildAnnSuffix :: + ComponentKey + -> Task + -> Bool -- ^ enableTests + -> Bool -- ^ enableBenchmarks + -> Text +buildAnnSuffix ck task enableTests enableBenchmarks = case ck of + ComponentKey _ (CInst hash) -> + " (inst:" <> T.take 8 hash <> instDetail <> ")" + ComponentKey _ comp + | not (isCLib comp) -> " (" <> renderComponent comp <> ")" + _ | result /= "" -> " (" <> result <> ")" + _ -> "" + where + instDetail + | null task.backpackInstEntries = "" + | otherwise = ": " <> T.intercalate ", " + [ T.pack (C.display sig) + <> " = " + <> T.pack (packageNameString impl) + <> if sig == implMod then "" else ":" <> T.pack (C.display implMod) + | (sig, impl, implMod) <- task.backpackInstEntries + ] + result = T.intercalate " + " $ + ["test" | enableTests] ++ ["bench" | enableBenchmarks] + isCLib CLib = True + isCLib _ = False + +-- | Compute the Cabal build and copy target options for a component. For +-- packages with intra-package deps (e.g. Backpack), omits targets so Cabal +-- handles ordering. For per-component builds, passes a single target. For +-- remote packages, no targets are needed. +buildAndCopyOpts :: + TaskType + -> ComponentKey + -> Bool -- ^ isFinalBuild + -> ([String], [String]) + -- ^ (buildOpts, copyOpts) +buildAndCopyOpts taskType ck isFinalBuild = case taskType of + TTLocalMutable lp + | hasIntraPackageDeps lp.package -> ([], []) + | shouldSplitComponents lp.package + , ComponentKey pn comp <- ck -> + let target = [componentTarget pn comp] + in if isFinalBuild then (target, []) else (target, target) + -- Legacy: non-splittable local packages use original multi-component + -- target logic (Custom/Configure/Make build types, Backpack). + | isFinalBuild -> (finalComponentOptions lp, []) + | otherwise -> + let componentOpts = primaryComponentOptions lp + in (componentOpts, componentOpts) + TTRemotePackage{} -> ([], []) + +-- | Render a 'NamedComponent' as a Cabal build target string. This uses +-- Cabal's target syntax (e.g. @lib:pkg-name@, @exe:my-exe@, @test:my-test@). +componentTarget :: PackageName -> NamedComponent -> String +componentTarget pn CLib = "lib:" ++ packageNameString pn +componentTarget _ (CSubLib x) = "lib:" ++ unqualCompToString x +componentTarget _ (CFlib x) = "flib:" ++ unqualCompToString x +componentTarget _ (CExe x) = "exe:" ++ unqualCompToString x +componentTarget _ (CTest x) = "test:" ++ unqualCompToString x +componentTarget _ (CBench x) = "bench:" ++ unqualCompToString x +componentTarget _ (CInst _) = "" + +-- | Should tests be enabled (Cabal @--enable-tests@) for a given +-- 'ComponentKey'? For per-component CTest keys, always True. For non-split +-- CLib keys, checks the full component set. For all other keys, False. +componentEnableTests :: ComponentKey -> Set NamedComponent -> Bool +componentEnableTests ck comps = case ck of + ComponentKey _ (CTest _) -> True + ComponentKey _ CLib -> any isCTest comps + _ -> False + +-- | Should benchmarks be enabled (Cabal @--enable-benchmarks@) for a given +-- 'ComponentKey'? For per-component CBench keys, always True. For non-split +-- CLib keys, checks the full component set. For all other keys, False. +componentEnableBenchmarks :: ComponentKey -> Set NamedComponent -> Bool +componentEnableBenchmarks ck comps = case ck of + ComponentKey _ (CBench _) -> True + ComponentKey _ CLib -> any isCBench comps + _ -> False + -- Library, sub-library, foreign library and executable build components. primaryComponentOptions :: LocalPackage -> [String] primaryComponentOptions lp = diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 26cf63ee21..72ac490e26 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -270,6 +270,7 @@ resolveRawTarget sma allLocs (rawInput, rt) = -- 'ComponentName' isCompNamed :: ComponentName -> NamedComponent -> Bool isCompNamed _ CLib = False + isCompNamed _ CInst{} = False isCompNamed t1 t2 = case t2 of (CSubLib t2') -> t1' == t2' (CExe t2') -> t1' == t2' diff --git a/src/Stack/Component.hs b/src/Stack/Component.hs index 175ed76e02..135f131294 100644 --- a/src/Stack/Component.hs +++ b/src/Stack/Component.hs @@ -68,6 +68,7 @@ stackLibraryFromCabal cabalLib = StackLibrary LSubLibName v -> fromCabalName v , buildInfo = stackBuildInfoFromCabal cabalLib.libBuildInfo , exposedModules = cabalLib.exposedModules + , signatures = cabalLib.signatures } stackExecutableFromCabal :: Executable -> StackExecutable @@ -122,6 +123,7 @@ stackBuildInfoFromCabal buildInfoV = gatherComponentToolsAndDepsFromCabal , extraLibs = buildInfoV.extraLibs , extraLibDirs = map interpretSymbolicPathCWD buildInfoV.extraLibDirs , frameworks = map interpretSymbolicPathCWD buildInfoV.frameworks + , mixins = buildInfoV.mixins } -- | Iterate on all three dependency list given, and transform and sort them diff --git a/src/Stack/ComponentFile.hs b/src/Stack/ComponentFile.hs index d8bf8ad49a..54a23511e6 100644 --- a/src/Stack/ComponentFile.hs +++ b/src/Stack/ComponentFile.hs @@ -61,7 +61,7 @@ import Stack.Types.Component , StackTestSuite (..), StackUnqualCompName (..) ) import Stack.Types.ComponentUtils - ( emptyCompName, unqualCompToString ) + ( emptyCompName, unqualCompFromText, unqualCompToString ) import Stack.Types.Config ( Config (..), HasConfig (..), prettyStackDevL ) import Stack.Types.NamedComponent ( NamedComponent (..) ) @@ -375,6 +375,7 @@ componentOutputDir namedComponent distDir = CExe name -> makeTmp name CTest name -> makeTmp name CBench name -> makeTmp name + CInst x -> makeTmp (unqualCompFromText x) where makeTmp name = buildDir distDir componentNameToDirNormOrTmp True name @@ -603,6 +604,7 @@ componentBuildDir component distDir = case component of CExe name -> buildDir distDir componentNameToDir name CTest name -> buildDir distDir componentNameToDir name CBench name -> buildDir distDir componentNameToDir name + CInst x -> buildDir distDir componentNameToDir (unqualCompFromText x) -- Internal helper to define resolveFileOrWarn and resolveDirOrWarn resolveOrWarn :: diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index a30ea47146..2530c01e70 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -34,6 +34,8 @@ module Stack.Package , listOfPackageDeps , setOfPackageDeps , topSortPackageComponent + , hasIntraPackageDeps + , packageIsIndefinite ) where import qualified Data.Map.Strict as M @@ -912,3 +914,35 @@ topProcessPackageComponent package target fn res = do processSubLibDep r = foldr' processSingleSubLib r subLibDeps processSubLibDep (processMainLibDep res') _ -> res' + +-- | Does this package have intra-package component dependencies that indicate +-- Backpack or chained sub-libraries? Specifically, checks whether the main +-- library or any sub-library depends on the same package (indicating the +-- library uses internal sub-libs, or sub-libraries chain among themselves). +-- +-- Executables, tests, and benchmarks commonly depend on their own package's +-- library via @build-depends: pkg-name@; this is normal and does NOT count as +-- an intra-package dep for our purposes, because @cabal build exe:foo@ handles +-- building the library first automatically. +-- +-- When 'True', @Setup.hs build@ should be called without explicit component +-- targets so that Cabal's internal build ordering (which handles Backpack +-- instantiation) is used. +hasIntraPackageDeps :: Package -> Bool +hasIntraPackageDeps package = + packageIsIndefinite package || any hasSelfDep libraryBuildInfos + where + pname = package.name + hasSelfDep sbi = M.member pname sbi.dependency + libraryBuildInfos :: [Component.StackBuildInfo] + libraryBuildInfos = + maybe [] (\l -> [l.buildInfo]) package.library + ++ map (.buildInfo) (toList package.subLibraries) + +-- | Is this package indefinite (has unfilled Backpack signatures)? +packageIsIndefinite :: Package -> Bool +packageIsIndefinite pkg = any hasSignatures allLibs + where + hasSignatures lib = not (null lib.signatures) + allLibs = maybe [] (:[]) pkg.library + ++ toList pkg.subLibraries diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index a27f117ad6..2e85cddcb7 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -489,7 +489,7 @@ getSDistFileList lp deps = [] [] [] Nothing -- provide empty list of globals. This is a hack around -- custom Setup.hs files $ \ee -> - withSingleContext ac ee taskType deps (Just "sdist") $ + withSingleContext ac ee taskType deps (Just "sdist") Nothing $ \_package cabalFP _pkgDir cabal _announce _outputType -> do let outFile = toFilePath tmpdir FP. "source-files-list" cabal diff --git a/src/Stack/Types/Build/ConstructPlan.hs b/src/Stack/Types/Build/ConstructPlan.hs index 1f94cfbcbb..9d36ba2ecc 100644 --- a/src/Stack/Types/Build/ConstructPlan.hs +++ b/src/Stack/Types/Build/ConstructPlan.hs @@ -54,7 +54,7 @@ import Stack.Types.Package ) import Stack.Types.ParentMap ( ParentMap ) import Stack.Types.Plan - ( Task (..), TaskType (..), taskProvides ) + ( ComponentKey, Task (..), TaskType (..), taskProvides ) import Stack.Types.Platform ( HasPlatform (..) ) import Stack.Types.Runner ( HasRunner (..) ) @@ -95,9 +95,9 @@ type M = -- | 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. + { wFinals :: !(Map ComponentKey (Either ConstructPlanException Task)) + -- ^ A dictionary of component keys, and either a final task to perform when + -- building the component or an exception. , wInstall :: !(Map StackUnqualCompName InstallLocation) -- ^ A dictionary of executables to be installed, and location where the -- executable's binary is placed. diff --git a/src/Stack/Types/Build/Exception.hs b/src/Stack/Types/Build/Exception.hs index e5f375aecf..51fcd8ce8b 100644 --- a/src/Stack/Types/Build/Exception.hs +++ b/src/Stack/Types/Build/Exception.hs @@ -76,7 +76,6 @@ data BuildException | CouldNotLockDistDir !(Path Abs File) | TaskCycleBug PackageIdentifier | PackageIdMissingBug PackageIdentifier - | AllInOneBuildBug | MultipleResultsBug PackageName [DumpPackage] | TemplateHaskellNotFoundBug | HaddockIndexNotFound @@ -212,8 +211,6 @@ instance Exception BuildException where displayException (PackageIdMissingBug ident) = bugReport "[S-8923]" $ "singleBuild: missing package ID missing: " ++ show ident - displayException AllInOneBuildBug = bugReport "[S-7371]" - "Cannot have an all-in-one build that also has a final build step." displayException (MultipleResultsBug name dps) = bugReport "[S-6739]" $ "singleBuild: multiple results when describing installed package " ++ show (name, dps) diff --git a/src/Stack/Types/Cache.hs b/src/Stack/Types/Cache.hs index 154b6499b5..474a2610c5 100644 --- a/src/Stack/Types/Cache.hs +++ b/src/Stack/Types/Cache.hs @@ -40,6 +40,8 @@ data ConfigCacheType -- ^ Library Cabal flag cache. | ConfigCacheTypeFlagExecutable PackageIdentifier -- ^ Executable Cabal flag cache. + | ConfigCacheTypeInstantiation Text + -- ^ Backpack CInst instantiation cache, keyed by hash suffix. deriving (Eq, Show) instance PersistField ConfigCacheType where @@ -48,10 +50,13 @@ instance PersistField ConfigCacheType where PersistText $ "lib:" <> ghcPkgIdToText v toPersistValue (ConfigCacheTypeFlagExecutable v) = PersistText $ "exe:" <> T.pack (packageIdentifierString v) + toPersistValue (ConfigCacheTypeInstantiation v) = + PersistText $ "inst:" <> v fromPersistValue (PersistText t) = fromMaybe (Left $ "Unexpected ConfigCacheType value: " <> t) $ config <|> fmap lib (T.stripPrefix "lib:" t) <|> - fmap exe (T.stripPrefix "exe:" t) + fmap exe (T.stripPrefix "exe:" t) <|> + fmap inst (T.stripPrefix "inst:" t) where config | t == "config" = Just (Right ConfigCacheTypeConfig) @@ -64,6 +69,7 @@ instance PersistField ConfigCacheType where maybe (Left $ "Unexpected ConfigCacheType value: " <> t) Right $ parsePackageIdentifier (T.unpack v) Right $ ConfigCacheTypeFlagExecutable pkgId + inst v = Right $ ConfigCacheTypeInstantiation v fromPersistValue _ = Left "Unexpected ConfigCacheType type" instance PersistFieldSql ConfigCacheType where diff --git a/src/Stack/Types/Component.hs b/src/Stack/Types/Component.hs index 28c9e1b550..c6309a1605 100644 --- a/src/Stack/Types/Component.hs +++ b/src/Stack/Types/Component.hs @@ -30,6 +30,7 @@ import Distribution.Compiler ( PerCompilerFlavor ) import Distribution.ModuleName ( ModuleName ) import Distribution.PackageDescription ( BenchmarkInterface, Dependency, TestSuiteInterface ) +import Distribution.Types.Mixin ( Mixin ) import Distribution.Simple ( Extension, Language ) import Distribution.Utils.Path ( Pkg, Source, SymbolicPath ) import qualified Distribution.Utils.Path as Cabal @@ -55,6 +56,8 @@ data StackLibrary = StackLibrary , buildInfo :: !StackBuildInfo , exposedModules :: [ModuleName] -- |^ This is only used for gathering the files related to this component. + , signatures :: [ModuleName] + -- ^ Backpack signature module names. Non-empty for indefinite packages. } deriving Show @@ -157,6 +160,8 @@ data StackBuildInfo = StackBuildInfo -- ^ Only used in opts gathering. , frameworks :: [String] -- ^ Only used in opts gathering. + , mixins :: [Mixin] + -- ^ Backpack mixin declarations. Used for cross-package Backpack support. } deriving Show diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs index d66886f05d..5334533064 100644 --- a/src/Stack/Types/GhcPkgId.hs +++ b/src/Stack/Types/GhcPkgId.hs @@ -86,7 +86,8 @@ parseGhcPkgId x = go x -- | A parser for a package-version-hash pair. ghcPkgIdParser :: Parser GhcPkgId ghcPkgIdParser = - let elements = "_.-" :: String + -- '+' is needed for Backpack instantiated unit IDs (e.g. "pkg-id-str-sig+hash") + let elements = "_.-+" :: String in GhcPkgId . mkUnitId <$> many1 (choice [alphaNum, satisfy (`elem` elements)]) diff --git a/src/Stack/Types/NamedComponent.hs b/src/Stack/Types/NamedComponent.hs index dac24005e8..3235f4235e 100644 --- a/src/Stack/Types/NamedComponent.hs +++ b/src/Stack/Types/NamedComponent.hs @@ -25,6 +25,7 @@ module Stack.Types.NamedComponent , isCExe , isCTest , isCBench + , isCInst , isPotentialDependency , splitComponents ) where @@ -50,6 +51,8 @@ data NamedComponent -- A named test-suite component. | CBench !StackUnqualCompName -- A named benchmark component. + | CInst !Text + -- A Backpack instantiation (hash suffix identifying the instantiation). deriving (Eq, Ord, Show) -- | Render a component to anything with an "IsString" instance. For 'Text' @@ -64,6 +67,7 @@ renderComponent (CFlib x) = "flib:" <> unqualCompToText x renderComponent (CExe x) = "exe:" <> unqualCompToText x renderComponent (CTest x) = "test:" <> unqualCompToText x renderComponent (CBench x) = "bench:" <> unqualCompToText x +renderComponent (CInst x) = "inst:" <> x componentCachePath :: NamedComponent -> String componentCachePath CLib = "lib" @@ -72,6 +76,7 @@ componentCachePath (CFlib x) = "flib-" <> unqualCompToString x componentCachePath (CExe x) = "exe-" <> unqualCompToString x componentCachePath (CTest x) = "test-" <> unqualCompToString x componentCachePath (CBench x) = "bench-" <> unqualCompToString x +componentCachePath (CInst x) = "inst-" <> T.unpack x renderPkgComponents :: [(PackageName, NamedComponent)] -> Text renderPkgComponents = T.intercalate " " . map renderPkgComponent @@ -124,8 +129,12 @@ isCBench :: NamedComponent -> Bool isCBench CBench{} = True isCBench _ = False +isCInst :: NamedComponent -> Bool +isCInst CInst{} = True +isCInst _ = False + isPotentialDependency :: NamedComponent -> Bool -isPotentialDependency v = isCLib v || isCSubLib v || isCExe v +isPotentialDependency v = isCLib v || isCSubLib v || isCExe v || isCInst v -- | A function to split the given list of components into sets of the names of -- the named components by the type of component (sub-libraries, executables, @@ -155,3 +164,5 @@ splitComponents = go s e t b (CExe x : xs) = go s (e . (x:)) t b xs go s e t b (CTest x : xs) = go s e (t . (x:)) b xs go s e t b (CBench x : xs) = go s e t (b . (x:)) xs + -- Ignore CInst (Backpack instantiation), like CFlib. + go s e t b (CInst _ : xs) = go s e t b xs diff --git a/src/Stack/Types/Plan.hs b/src/Stack/Types/Plan.hs index 8789f3f0d9..37e851e110 100644 --- a/src/Stack/Types/Plan.hs +++ b/src/Stack/Types/Plan.hs @@ -17,6 +17,8 @@ module Stack.Types.Plan , Task (..) , TaskType (..) , TaskConfigOpts (..) + , ComponentKey (..) + , componentKeyPkgName , taskAnyMissing , taskIsTarget , taskLocation @@ -28,6 +30,7 @@ module Stack.Types.Plan ) where import Data.List as L +import Distribution.ModuleName ( ModuleName ) import qualified RIO.Set as Set import Stack.Prelude import Stack.Types.Cache ( CachePkgSrc ) @@ -37,15 +40,26 @@ import Stack.Types.ConfigureOpts import Stack.Types.EnvConfig ( EnvConfig ) import Stack.Types.GhcPkgId ( GhcPkgId ) import Stack.Types.IsMutable ( IsMutable (..) ) +import Stack.Types.NamedComponent ( NamedComponent ) import Stack.Types.Package ( InstallLocation (..), LocalPackage (..), Package (..) , packageIdentifier ) +-- | A key that identifies a single buildable unit in the plan. For most +-- packages this is @ComponentKey pkgName CLib@. When per-component building +-- is enabled (Phase 2 Backpack support), each component gets its own key. +data ComponentKey = ComponentKey !PackageName !NamedComponent + deriving (Eq, Ord, Show) + +-- | Extract the package name from a 'ComponentKey'. +componentKeyPkgName :: ComponentKey -> PackageName +componentKeyPkgName (ComponentKey n _) = n + -- | A complete plan of what needs to be built and how to do it data Plan = Plan - { tasks :: !(Map PackageName Task) - , finals :: !(Map PackageName Task) + { tasks :: !(Map ComponentKey Task) + , finals :: !(Map ComponentKey Task) -- ^ Final actions to be taken (test, benchmark, etc) , unregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Text)) -- ^ Text is reason we're unregistering, for display only @@ -66,12 +80,13 @@ data Task = Task , present :: !(Map PackageIdentifier GhcPkgId) -- ^ A dictionary of the package identifiers of already-installed -- dependencies, and their 'GhcPkgId'. - , allInOne :: !Bool - -- ^ indicates that the package can be built in one step , cachePkgSrc :: !CachePkgSrc , buildTypeConfig :: !Bool -- ^ Is the build type of this package Configure. Check out -- ensureConfigureScript in Stack.Build.Execute for the motivation + , backpackInstEntries :: ![(ModuleName, PackageName, ModuleName)] + -- ^ For CInst tasks: [(sigName, implPkgName, implModuleName)]. + -- Empty for non-instantiation tasks. } deriving Show @@ -88,11 +103,14 @@ data TaskType data TaskConfigOpts = TaskConfigOpts { missing :: !(Set PackageIdentifier) -- ^ Dependencies for which we don't yet have a 'GhcPkgId' - , envConfig :: !EnvConfig - , baseConfigOpts :: !BaseConfigOpts + , envConfig :: EnvConfig + , baseConfigOpts :: BaseConfigOpts , isLocalNonExtraDep :: !Bool , isMutable :: !IsMutable , pkgConfigOpts :: PackageConfigureOpts + , instantiationDeps :: ![ComponentKey] + -- ^ Additional deps on CInst tasks. Added to action deps at execution. + -- Empty for most tasks. } instance Show TaskConfigOpts where diff --git a/stack.cabal b/stack.cabal index d6671e9a9d..d553f21561 100644 --- a/stack.cabal +++ b/stack.cabal @@ -216,6 +216,7 @@ library Path.Find Stack Stack.Build + Stack.Build.Backpack Stack.Build.Cache Stack.Build.ConstructPlan Stack.Build.Execute @@ -747,6 +748,7 @@ test-suite stack-unit-test main-is: Spec.hs other-modules: Stack.ArgsSpec + Stack.Build.ConstructPlanSpec Stack.Build.ExecuteSpec Stack.Build.TargetSpec Stack.Config.DockerSpec @@ -757,6 +759,7 @@ test-suite stack-unit-test Stack.LockSpec Stack.NixSpec Stack.PackageDumpSpec + Stack.Types.PlanSpec Stack.Types.TemplateNameSpec Stack.UploadSpec Paths_stack diff --git a/tests/integration/tests/backpack-cross-package-multi-inst/Main.hs b/tests/integration/tests/backpack-cross-package-multi-inst/Main.hs new file mode 100644 index 0000000000..8b3196e3b4 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-multi-inst/Main.hs @@ -0,0 +1,24 @@ +import Control.Monad (unless) +import Data.List (isInfixOf) +import StackTest + +-- Test multiple instantiations: two consumers fill the same sig-pkg with +-- different implementations. Each consumer should get its own CInst task. +main :: IO () +main = do + stack ["build"] + + stackCheckStdout ["exec", "multi-inst-demo"] $ \out -> do + unless ("A says: Hello from impl-a" `isInfixOf` out) $ + error $ "Expected 'A says: Hello from impl-a' in output, got: " ++ show out + unless ("B says: Hello from impl-b" `isInfixOf` out) $ + error $ "Expected 'B says: Hello from impl-b' in output, got: " ++ show out + + -- Rebuild should succeed + stack ["build"] + + stackCheckStdout ["exec", "multi-inst-demo"] $ \out -> do + unless ("A says: Hello from impl-a" `isInfixOf` out) $ + error $ "Expected 'A says: Hello from impl-a' after rebuild, got: " ++ show out + unless ("B says: Hello from impl-b" `isInfixOf` out) $ + error $ "Expected 'B says: Hello from impl-b' after rebuild, got: " ++ show out diff --git a/tests/integration/tests/backpack-cross-package-multi-inst/files/app/app.cabal b/tests/integration/tests/backpack-cross-package-multi-inst/files/app/app.cabal new file mode 100644 index 0000000000..be01e3c637 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-multi-inst/files/app/app.cabal @@ -0,0 +1,13 @@ +cabal-version: 2.0 +name: app +version: 0.1.0.0 +build-type: Simple + +executable multi-inst-demo + main-is: Main.hs + build-depends: + base >= 4.7 && < 5, + consumer-a, + consumer-b + hs-source-dirs: app + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-multi-inst/files/app/app/Main.hs b/tests/integration/tests/backpack-cross-package-multi-inst/files/app/app/Main.hs new file mode 100644 index 0000000000..8ac221522a --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-multi-inst/files/app/app/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import ConsumerA (helloA) +import ConsumerB (helloB) + +main :: IO () +main = do + putStrLn helloA + putStrLn helloB diff --git a/tests/integration/tests/backpack-cross-package-multi-inst/files/consumer-a/consumer-a.cabal b/tests/integration/tests/backpack-cross-package-multi-inst/files/consumer-a/consumer-a.cabal new file mode 100644 index 0000000000..70f36bfb47 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-multi-inst/files/consumer-a/consumer-a.cabal @@ -0,0 +1,15 @@ +cabal-version: 2.0 +name: consumer-a +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: ConsumerA + build-depends: + base >= 4.7 && < 5, + sig-pkg, + impl-a + mixins: + sig-pkg requires (Str as Str) + hs-source-dirs: src + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-multi-inst/files/consumer-a/src/ConsumerA.hs b/tests/integration/tests/backpack-cross-package-multi-inst/files/consumer-a/src/ConsumerA.hs new file mode 100644 index 0000000000..0c0e9ca6c4 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-multi-inst/files/consumer-a/src/ConsumerA.hs @@ -0,0 +1,6 @@ +module ConsumerA where + +import Str (greeting) + +helloA :: String +helloA = "A says: " ++ greeting diff --git a/tests/integration/tests/backpack-cross-package-multi-inst/files/consumer-b/consumer-b.cabal b/tests/integration/tests/backpack-cross-package-multi-inst/files/consumer-b/consumer-b.cabal new file mode 100644 index 0000000000..b76b66258a --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-multi-inst/files/consumer-b/consumer-b.cabal @@ -0,0 +1,15 @@ +cabal-version: 2.0 +name: consumer-b +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: ConsumerB + build-depends: + base >= 4.7 && < 5, + sig-pkg, + impl-b + mixins: + sig-pkg requires (Str as Str) + hs-source-dirs: src + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-multi-inst/files/consumer-b/src/ConsumerB.hs b/tests/integration/tests/backpack-cross-package-multi-inst/files/consumer-b/src/ConsumerB.hs new file mode 100644 index 0000000000..0ca5225c98 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-multi-inst/files/consumer-b/src/ConsumerB.hs @@ -0,0 +1,6 @@ +module ConsumerB where + +import Str (greeting) + +helloB :: String +helloB = "B says: " ++ greeting diff --git a/tests/integration/tests/backpack-cross-package-multi-inst/files/impl-a/impl-a.cabal b/tests/integration/tests/backpack-cross-package-multi-inst/files/impl-a/impl-a.cabal new file mode 100644 index 0000000000..3e096774ad --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-multi-inst/files/impl-a/impl-a.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.0 +name: impl-a +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: Str + build-depends: base >= 4.7 && < 5 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-multi-inst/files/impl-a/src/Str.hs b/tests/integration/tests/backpack-cross-package-multi-inst/files/impl-a/src/Str.hs new file mode 100644 index 0000000000..274c2be1c9 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-multi-inst/files/impl-a/src/Str.hs @@ -0,0 +1,4 @@ +module Str where + +greeting :: String +greeting = "Hello from impl-a" diff --git a/tests/integration/tests/backpack-cross-package-multi-inst/files/impl-b/impl-b.cabal b/tests/integration/tests/backpack-cross-package-multi-inst/files/impl-b/impl-b.cabal new file mode 100644 index 0000000000..b4bf61ce67 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-multi-inst/files/impl-b/impl-b.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.0 +name: impl-b +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: Str + build-depends: base >= 4.7 && < 5 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-multi-inst/files/impl-b/src/Str.hs b/tests/integration/tests/backpack-cross-package-multi-inst/files/impl-b/src/Str.hs new file mode 100644 index 0000000000..addddbb467 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-multi-inst/files/impl-b/src/Str.hs @@ -0,0 +1,4 @@ +module Str where + +greeting :: String +greeting = "Hello from impl-b" diff --git a/tests/integration/tests/backpack-cross-package-multi-inst/files/sig-pkg/sig-pkg.cabal b/tests/integration/tests/backpack-cross-package-multi-inst/files/sig-pkg/sig-pkg.cabal new file mode 100644 index 0000000000..7ce99e3c8f --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-multi-inst/files/sig-pkg/sig-pkg.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.0 +name: sig-pkg +version: 0.1.0.0 +build-type: Simple + +library + signatures: Str + build-depends: base >= 4.7 && < 5 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-multi-inst/files/sig-pkg/src/Str.hsig b/tests/integration/tests/backpack-cross-package-multi-inst/files/sig-pkg/src/Str.hsig new file mode 100644 index 0000000000..edb56a4a7d --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-multi-inst/files/sig-pkg/src/Str.hsig @@ -0,0 +1,3 @@ +signature Str where + +greeting :: String diff --git a/tests/integration/tests/backpack-cross-package-multi-inst/files/stack.yaml b/tests/integration/tests/backpack-cross-package-multi-inst/files/stack.yaml new file mode 100644 index 0000000000..52bc41f10e --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-multi-inst/files/stack.yaml @@ -0,0 +1,8 @@ +snapshot: ghc-9.10.3 +packages: + - sig-pkg + - impl-a + - impl-b + - consumer-a + - consumer-b + - app diff --git a/tests/integration/tests/backpack-cross-package-rename/Main.hs b/tests/integration/tests/backpack-cross-package-rename/Main.hs new file mode 100644 index 0000000000..9fa1a77c97 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-rename/Main.hs @@ -0,0 +1,14 @@ +import Control.Monad (unless) +import Data.List (isInfixOf) +import StackTest + +-- Test cross-package Backpack with module renaming: sig-pkg has a "Sig" +-- signature, impl-pkg exposes "Impl", and consumer-pkg uses +-- mixins: sig-pkg requires (Sig as Impl) to wire them together. +main :: IO () +main = do + stack ["build"] + + stackCheckStdout ["exec", "consumer-demo"] $ \out -> + unless ("Renamed module works" `isInfixOf` out) $ + error $ "Expected 'Renamed module works' in output, got: " ++ show out diff --git a/tests/integration/tests/backpack-cross-package-rename/files/consumer-pkg/app/Main.hs b/tests/integration/tests/backpack-cross-package-rename/files/consumer-pkg/app/Main.hs new file mode 100644 index 0000000000..4c26592390 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-rename/files/consumer-pkg/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Consumer (hello) + +main :: IO () +main = putStrLn hello diff --git a/tests/integration/tests/backpack-cross-package-rename/files/consumer-pkg/consumer-pkg.cabal b/tests/integration/tests/backpack-cross-package-rename/files/consumer-pkg/consumer-pkg.cabal new file mode 100644 index 0000000000..1c7ecd0e8e --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-rename/files/consumer-pkg/consumer-pkg.cabal @@ -0,0 +1,23 @@ +cabal-version: 2.0 +name: consumer-pkg +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: Consumer + build-depends: + base >= 4.7 && < 5, + sig-pkg, + impl-pkg + mixins: + sig-pkg requires (Sig as Impl) + hs-source-dirs: src + default-language: Haskell2010 + +executable consumer-demo + main-is: Main.hs + build-depends: + base >= 4.7 && < 5, + consumer-pkg + hs-source-dirs: app + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-rename/files/consumer-pkg/src/Consumer.hs b/tests/integration/tests/backpack-cross-package-rename/files/consumer-pkg/src/Consumer.hs new file mode 100644 index 0000000000..0439a8a006 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-rename/files/consumer-pkg/src/Consumer.hs @@ -0,0 +1,6 @@ +module Consumer where + +import Sig (message) + +hello :: String +hello = message diff --git a/tests/integration/tests/backpack-cross-package-rename/files/impl-pkg/impl-pkg.cabal b/tests/integration/tests/backpack-cross-package-rename/files/impl-pkg/impl-pkg.cabal new file mode 100644 index 0000000000..43b2ce5a7b --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-rename/files/impl-pkg/impl-pkg.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.0 +name: impl-pkg +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: Impl + build-depends: base >= 4.7 && < 5 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-rename/files/impl-pkg/src/Impl.hs b/tests/integration/tests/backpack-cross-package-rename/files/impl-pkg/src/Impl.hs new file mode 100644 index 0000000000..cf8ca1d3e2 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-rename/files/impl-pkg/src/Impl.hs @@ -0,0 +1,4 @@ +module Impl where + +message :: String +message = "Renamed module works" diff --git a/tests/integration/tests/backpack-cross-package-rename/files/sig-pkg/sig-pkg.cabal b/tests/integration/tests/backpack-cross-package-rename/files/sig-pkg/sig-pkg.cabal new file mode 100644 index 0000000000..246f14ab3d --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-rename/files/sig-pkg/sig-pkg.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.0 +name: sig-pkg +version: 0.1.0.0 +build-type: Simple + +library + signatures: Sig + build-depends: base >= 4.7 && < 5 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-rename/files/sig-pkg/src/Sig.hsig b/tests/integration/tests/backpack-cross-package-rename/files/sig-pkg/src/Sig.hsig new file mode 100644 index 0000000000..42f438e05c --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-rename/files/sig-pkg/src/Sig.hsig @@ -0,0 +1,3 @@ +signature Sig where + +message :: String diff --git a/tests/integration/tests/backpack-cross-package-rename/files/stack.yaml b/tests/integration/tests/backpack-cross-package-rename/files/stack.yaml new file mode 100644 index 0000000000..3f5df23831 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-rename/files/stack.yaml @@ -0,0 +1,5 @@ +snapshot: ghc-9.10.3 +packages: + - sig-pkg + - impl-pkg + - consumer-pkg diff --git a/tests/integration/tests/backpack-cross-package-sig/Main.hs b/tests/integration/tests/backpack-cross-package-sig/Main.hs new file mode 100644 index 0000000000..7010a9ae91 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sig/Main.hs @@ -0,0 +1,27 @@ +import Control.Monad (unless) +import Data.List (isInfixOf) +import StackTest + +-- Test cross-package Backpack: sig-pkg (indefinite, has Str signature) is +-- instantiated with impl-pkg's Str module via consumer-pkg's mixin declaration. +main :: IO () +main = do + -- Build all three packages. This exercises: + -- 1. sig-pkg CLib (indefinite, typecheck-only) + -- 2. impl-pkg CLib (concrete Str implementation) + -- 3. sig-pkg CInst (instantiation with impl-pkg's Str) + -- 4. consumer-pkg CLib + CExe + stack ["build"] + + -- Verify the consumer executable calls through the instantiated signature + stackCheckStdout ["exec", "consumer-demo"] $ \out -> + unless ("Hello from impl-pkg" `isInfixOf` out) $ + error $ "Expected 'Hello from impl-pkg' in output, got: " ++ show out + + -- Rebuild should succeed (no stale CInst state or dist-dir conflicts) + stack ["build"] + + -- Verify output still correct after rebuild + stackCheckStdout ["exec", "consumer-demo"] $ \out -> + unless ("Hello from impl-pkg" `isInfixOf` out) $ + error $ "Expected 'Hello from impl-pkg' after rebuild, got: " ++ show out diff --git a/tests/integration/tests/backpack-cross-package-sig/files/consumer-pkg/app/Main.hs b/tests/integration/tests/backpack-cross-package-sig/files/consumer-pkg/app/Main.hs new file mode 100644 index 0000000000..4c26592390 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sig/files/consumer-pkg/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Consumer (hello) + +main :: IO () +main = putStrLn hello diff --git a/tests/integration/tests/backpack-cross-package-sig/files/consumer-pkg/consumer-pkg.cabal b/tests/integration/tests/backpack-cross-package-sig/files/consumer-pkg/consumer-pkg.cabal new file mode 100644 index 0000000000..52fd5a3132 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sig/files/consumer-pkg/consumer-pkg.cabal @@ -0,0 +1,23 @@ +cabal-version: 2.0 +name: consumer-pkg +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: Consumer + build-depends: + base >= 4.7 && < 5, + sig-pkg, + impl-pkg + mixins: + sig-pkg requires (Str as Str) + hs-source-dirs: src + default-language: Haskell2010 + +executable consumer-demo + main-is: Main.hs + build-depends: + base >= 4.7 && < 5, + consumer-pkg + hs-source-dirs: app + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-sig/files/consumer-pkg/src/Consumer.hs b/tests/integration/tests/backpack-cross-package-sig/files/consumer-pkg/src/Consumer.hs new file mode 100644 index 0000000000..4c44a58a8a --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sig/files/consumer-pkg/src/Consumer.hs @@ -0,0 +1,6 @@ +module Consumer where + +import Str (greeting) + +hello :: String +hello = greeting diff --git a/tests/integration/tests/backpack-cross-package-sig/files/impl-pkg/impl-pkg.cabal b/tests/integration/tests/backpack-cross-package-sig/files/impl-pkg/impl-pkg.cabal new file mode 100644 index 0000000000..8ee468919a --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sig/files/impl-pkg/impl-pkg.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.0 +name: impl-pkg +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: Str + build-depends: base >= 4.7 && < 5 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-sig/files/impl-pkg/src/Str.hs b/tests/integration/tests/backpack-cross-package-sig/files/impl-pkg/src/Str.hs new file mode 100644 index 0000000000..7d546cc5a1 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sig/files/impl-pkg/src/Str.hs @@ -0,0 +1,4 @@ +module Str where + +greeting :: String +greeting = "Hello from impl-pkg" diff --git a/tests/integration/tests/backpack-cross-package-sig/files/sig-pkg/sig-pkg.cabal b/tests/integration/tests/backpack-cross-package-sig/files/sig-pkg/sig-pkg.cabal new file mode 100644 index 0000000000..7ce99e3c8f --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sig/files/sig-pkg/sig-pkg.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.0 +name: sig-pkg +version: 0.1.0.0 +build-type: Simple + +library + signatures: Str + build-depends: base >= 4.7 && < 5 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-sig/files/sig-pkg/src/Str.hsig b/tests/integration/tests/backpack-cross-package-sig/files/sig-pkg/src/Str.hsig new file mode 100644 index 0000000000..edb56a4a7d --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sig/files/sig-pkg/src/Str.hsig @@ -0,0 +1,3 @@ +signature Str where + +greeting :: String diff --git a/tests/integration/tests/backpack-cross-package-sig/files/stack.yaml b/tests/integration/tests/backpack-cross-package-sig/files/stack.yaml new file mode 100644 index 0000000000..3f5df23831 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sig/files/stack.yaml @@ -0,0 +1,5 @@ +snapshot: ghc-9.10.3 +packages: + - sig-pkg + - impl-pkg + - consumer-pkg diff --git a/tests/integration/tests/backpack-cross-package-sublib/Main.hs b/tests/integration/tests/backpack-cross-package-sublib/Main.hs new file mode 100644 index 0000000000..a3fe8844f0 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sublib/Main.hs @@ -0,0 +1,7 @@ +import StackTest + +-- Test that a package can depend on another package's public sub-library. +-- consumer depends on provider:utils (not provider's main library). +-- This already works in Stack; this test prevents regressions. +main :: IO () +main = stack ["build"] diff --git a/tests/integration/tests/backpack-cross-package-sublib/files/consumer/consumer.cabal b/tests/integration/tests/backpack-cross-package-sublib/files/consumer/consumer.cabal new file mode 100644 index 0000000000..ffec6d82ac --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sublib/files/consumer/consumer.cabal @@ -0,0 +1,22 @@ +cabal-version: 3.0 +name: consumer +version: 0.1.0.0 +build-type: Simple + +-- A package that depends on provider's sub-library "utils" directly, +-- NOT on provider's main library. This tests cross-package sub-library +-- dependency resolution. + +library + exposed-modules: Consumer + build-depends: base >=4.14, + provider:utils + hs-source-dirs: src/main + default-language: Haskell2010 + +executable consumer-demo + main-is: Main.hs + build-depends: base >=4.14, + consumer + hs-source-dirs: src/exe + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-sublib/files/consumer/src/exe/Main.hs b/tests/integration/tests/backpack-cross-package-sublib/files/consumer/src/exe/Main.hs new file mode 100644 index 0000000000..e1f66a0061 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sublib/files/consumer/src/exe/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Consumer (shout) + +main :: IO () +main = putStrLn (shout "hello world") diff --git a/tests/integration/tests/backpack-cross-package-sublib/files/consumer/src/main/Consumer.hs b/tests/integration/tests/backpack-cross-package-sublib/files/consumer/src/main/Consumer.hs new file mode 100644 index 0000000000..24f96db198 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sublib/files/consumer/src/main/Consumer.hs @@ -0,0 +1,10 @@ +module Consumer (shout) where + +import Provider.Utils (capitalize) + +shout :: String -> String +shout = map toUpper . capitalize + where + toUpper c + | c >= 'a' && c <= 'z' = toEnum (fromEnum c - 32) + | otherwise = c diff --git a/tests/integration/tests/backpack-cross-package-sublib/files/provider/provider.cabal b/tests/integration/tests/backpack-cross-package-sublib/files/provider/provider.cabal new file mode 100644 index 0000000000..e899ed52d1 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sublib/files/provider/provider.cabal @@ -0,0 +1,21 @@ +cabal-version: 3.0 +name: provider +version: 0.1.0.0 +build-type: Simple + +-- A package that exposes a sub-library "utils" alongside its main library. +-- The consumer package depends on the sub-library specifically. + +library utils + visibility: public + exposed-modules: Provider.Utils + build-depends: base >=4.14 + hs-source-dirs: src/utils + default-language: Haskell2010 + +library + exposed-modules: Provider + build-depends: base >=4.14, + provider:utils + hs-source-dirs: src/main + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-sublib/files/provider/src/main/Provider.hs b/tests/integration/tests/backpack-cross-package-sublib/files/provider/src/main/Provider.hs new file mode 100644 index 0000000000..429344c0b6 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sublib/files/provider/src/main/Provider.hs @@ -0,0 +1,6 @@ +module Provider (capitalGreet) where + +import Provider.Utils (capitalize) + +capitalGreet :: String -> String +capitalGreet name = capitalize ("hello, " ++ name ++ "!") diff --git a/tests/integration/tests/backpack-cross-package-sublib/files/provider/src/utils/Provider/Utils.hs b/tests/integration/tests/backpack-cross-package-sublib/files/provider/src/utils/Provider/Utils.hs new file mode 100644 index 0000000000..6a35d58a6c --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sublib/files/provider/src/utils/Provider/Utils.hs @@ -0,0 +1,7 @@ +module Provider.Utils (capitalize) where + +capitalize :: String -> String +capitalize [] = [] +capitalize (c:cs) + | c >= 'a' && c <= 'z' = toEnum (fromEnum c - 32) : cs + | otherwise = c : cs diff --git a/tests/integration/tests/backpack-cross-package-sublib/files/stack.yaml b/tests/integration/tests/backpack-cross-package-sublib/files/stack.yaml new file mode 100644 index 0000000000..ded94ebe0b --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-sublib/files/stack.yaml @@ -0,0 +1,4 @@ +snapshot: ghc-9.10.3 +packages: + - provider + - consumer diff --git a/tests/integration/tests/backpack-cross-package-transitive/Main.hs b/tests/integration/tests/backpack-cross-package-transitive/Main.hs new file mode 100644 index 0000000000..6bb1a4bb18 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-transitive/Main.hs @@ -0,0 +1,32 @@ +import Control.Monad (unless) +import Data.List (isInfixOf) +import StackTest + +-- Test transitive Backpack chains: logger-sig (indefinite, sig: Logger) depends +-- on str-sig (indefinite, sig: Str). When consumer mixes in logger-sig, both +-- Logger and Str holes must be filled transitively. +main :: IO () +main = do + -- Build all four packages. This exercises: + -- 1. str-sig CLib (indefinite, typecheck-only) + -- 2. impl-pkg CLib (concrete Str + Logger) + -- 3. str-sig CInst (instantiation with impl-pkg's Str) + -- 4. logger-sig CLib (indefinite, typecheck-only, inherits Str hole) + -- 5. logger-sig CInst (fills BOTH Logger and Str holes) + -- 6. consumer-pkg CLib + CExe + stack ["build"] + + -- Verify the consumer executable calls through the transitive chain + stackCheckStdout ["exec", "consumer-demo"] $ \out -> + unless ("[LOG] Hello from transitive chain" `isInfixOf` out) $ + error $ "Expected '[LOG] Hello from transitive chain' in output, got: " + ++ show out + + -- Rebuild should succeed (no stale CInst state) + stack ["build"] + + -- Verify output still correct after rebuild + stackCheckStdout ["exec", "consumer-demo"] $ \out -> + unless ("[LOG] Hello from transitive chain" `isInfixOf` out) $ + error $ "Expected '[LOG] Hello from transitive chain' after rebuild, got: " + ++ show out diff --git a/tests/integration/tests/backpack-cross-package-transitive/files/consumer-pkg/app/Main.hs b/tests/integration/tests/backpack-cross-package-transitive/files/consumer-pkg/app/Main.hs new file mode 100644 index 0000000000..4c26592390 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-transitive/files/consumer-pkg/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Consumer (hello) + +main :: IO () +main = putStrLn hello diff --git a/tests/integration/tests/backpack-cross-package-transitive/files/consumer-pkg/consumer-pkg.cabal b/tests/integration/tests/backpack-cross-package-transitive/files/consumer-pkg/consumer-pkg.cabal new file mode 100644 index 0000000000..d86d09cec6 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-transitive/files/consumer-pkg/consumer-pkg.cabal @@ -0,0 +1,25 @@ +cabal-version: 2.0 +name: consumer-pkg +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: Consumer + build-depends: + base >= 4.7 && < 5, + str-sig, + logger-sig, + impl-pkg + mixins: + str-sig requires (Str as Str), + logger-sig requires (Logger as Logger) + hs-source-dirs: src + default-language: Haskell2010 + +executable consumer-demo + main-is: Main.hs + build-depends: + base >= 4.7 && < 5, + consumer-pkg + hs-source-dirs: app + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-transitive/files/consumer-pkg/src/Consumer.hs b/tests/integration/tests/backpack-cross-package-transitive/files/consumer-pkg/src/Consumer.hs new file mode 100644 index 0000000000..e46c8658a6 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-transitive/files/consumer-pkg/src/Consumer.hs @@ -0,0 +1,6 @@ +module Consumer where + +import LogHelper (greetWithLog) + +hello :: String +hello = greetWithLog diff --git a/tests/integration/tests/backpack-cross-package-transitive/files/impl-pkg/impl-pkg.cabal b/tests/integration/tests/backpack-cross-package-transitive/files/impl-pkg/impl-pkg.cabal new file mode 100644 index 0000000000..521171e7bc --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-transitive/files/impl-pkg/impl-pkg.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.0 +name: impl-pkg +version: 0.1.0.0 +build-type: Simple + +library + exposed-modules: Str, Logger + build-depends: base >= 4.7 && < 5 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-transitive/files/impl-pkg/src/Logger.hs b/tests/integration/tests/backpack-cross-package-transitive/files/impl-pkg/src/Logger.hs new file mode 100644 index 0000000000..ddc7981a34 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-transitive/files/impl-pkg/src/Logger.hs @@ -0,0 +1,4 @@ +module Logger where + +logMessage :: String -> String +logMessage msg = "[LOG] " ++ msg diff --git a/tests/integration/tests/backpack-cross-package-transitive/files/impl-pkg/src/Str.hs b/tests/integration/tests/backpack-cross-package-transitive/files/impl-pkg/src/Str.hs new file mode 100644 index 0000000000..3b6d306620 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-transitive/files/impl-pkg/src/Str.hs @@ -0,0 +1,4 @@ +module Str where + +greeting :: String +greeting = "Hello from transitive chain" diff --git a/tests/integration/tests/backpack-cross-package-transitive/files/logger-sig/logger-sig.cabal b/tests/integration/tests/backpack-cross-package-transitive/files/logger-sig/logger-sig.cabal new file mode 100644 index 0000000000..86bdecede0 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-transitive/files/logger-sig/logger-sig.cabal @@ -0,0 +1,15 @@ +cabal-version: 2.0 +name: logger-sig +version: 0.1.0.0 +build-type: Simple + +library + signatures: Logger + exposed-modules: LogHelper + build-depends: + base >= 4.7 && < 5, + str-sig + mixins: + str-sig requires (Str as Str) + hs-source-dirs: src + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-cross-package-transitive/files/logger-sig/src/LogHelper.hs b/tests/integration/tests/backpack-cross-package-transitive/files/logger-sig/src/LogHelper.hs new file mode 100644 index 0000000000..2eecba92d6 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-transitive/files/logger-sig/src/LogHelper.hs @@ -0,0 +1,7 @@ +module LogHelper where + +import Str (greeting) +import Logger (logMessage) + +greetWithLog :: String +greetWithLog = logMessage greeting diff --git a/tests/integration/tests/backpack-cross-package-transitive/files/logger-sig/src/Logger.hsig b/tests/integration/tests/backpack-cross-package-transitive/files/logger-sig/src/Logger.hsig new file mode 100644 index 0000000000..446efe6fe6 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-transitive/files/logger-sig/src/Logger.hsig @@ -0,0 +1,3 @@ +signature Logger where + +logMessage :: String -> String diff --git a/tests/integration/tests/backpack-cross-package-transitive/files/stack.yaml b/tests/integration/tests/backpack-cross-package-transitive/files/stack.yaml new file mode 100644 index 0000000000..72c111f0fc --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-transitive/files/stack.yaml @@ -0,0 +1,6 @@ +snapshot: ghc-9.10.3 +packages: + - str-sig + - logger-sig + - impl-pkg + - consumer-pkg diff --git a/tests/integration/tests/backpack-cross-package-transitive/files/str-sig/src/Str.hsig b/tests/integration/tests/backpack-cross-package-transitive/files/str-sig/src/Str.hsig new file mode 100644 index 0000000000..edb56a4a7d --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-transitive/files/str-sig/src/Str.hsig @@ -0,0 +1,3 @@ +signature Str where + +greeting :: String diff --git a/tests/integration/tests/backpack-cross-package-transitive/files/str-sig/str-sig.cabal b/tests/integration/tests/backpack-cross-package-transitive/files/str-sig/str-sig.cabal new file mode 100644 index 0000000000..e9efd6ab50 --- /dev/null +++ b/tests/integration/tests/backpack-cross-package-transitive/files/str-sig/str-sig.cabal @@ -0,0 +1,10 @@ +cabal-version: 2.0 +name: str-sig +version: 0.1.0.0 +build-type: Simple + +library + signatures: Str + build-depends: base >= 4.7 && < 5 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-private/Main.hs b/tests/integration/tests/backpack-private/Main.hs new file mode 100644 index 0000000000..b18577c0a6 --- /dev/null +++ b/tests/integration/tests/backpack-private/Main.hs @@ -0,0 +1,11 @@ +import StackTest + +-- Test that a package using Backpack internally (private Backpack) builds. +-- lib:str-sig defines a Str signature (.hsig), lib:str-impl provides +-- a concrete Str module, and the main library depends on both so that +-- mix-in linking fills the signature. +main :: IO () +main = do + stack ["build"] + -- Verify the built executable actually runs (Backpack instantiation worked) + stack ["exec", "private-backpack-demo"] diff --git a/tests/integration/tests/backpack-private/files/private-backpack.cabal b/tests/integration/tests/backpack-private/files/private-backpack.cabal new file mode 100644 index 0000000000..119495823a --- /dev/null +++ b/tests/integration/tests/backpack-private/files/private-backpack.cabal @@ -0,0 +1,37 @@ +cabal-version: 3.4 +name: private-backpack +version: 0.1.0.0 +build-type: Simple + +-- A package using Backpack internally (private Backpack). +-- Sub-library "str-sig" defines an abstract Str signature. +-- Sub-library "str-impl" provides a concrete Str module that fills the sig. +-- Main library uses str-sig (indefinite) and str-impl fills the hole. +-- The public API has no unfilled signatures. + +library str-sig + signatures: Str + build-depends: base >=4.14 + hs-source-dirs: src/sig + default-language: Haskell2010 + +library str-impl + exposed-modules: Str + build-depends: base >=4.14 + hs-source-dirs: src/impl + default-language: Haskell2010 + +library + exposed-modules: PrivateBackpack + build-depends: base >=4.14, + private-backpack:str-sig, + private-backpack:str-impl + hs-source-dirs: src/main + default-language: Haskell2010 + +executable private-backpack-demo + main-is: Main.hs + build-depends: base >=4.14, + private-backpack + hs-source-dirs: src/exe + default-language: Haskell2010 diff --git a/tests/integration/tests/backpack-private/files/src/exe/Main.hs b/tests/integration/tests/backpack-private/files/src/exe/Main.hs new file mode 100644 index 0000000000..23c84ad3f1 --- /dev/null +++ b/tests/integration/tests/backpack-private/files/src/exe/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import PrivateBackpack (greetString) + +main :: IO () +main = putStrLn (greetString "world") diff --git a/tests/integration/tests/backpack-private/files/src/impl/Str.hs b/tests/integration/tests/backpack-private/files/src/impl/Str.hs new file mode 100644 index 0000000000..6c308bdf04 --- /dev/null +++ b/tests/integration/tests/backpack-private/files/src/impl/Str.hs @@ -0,0 +1,16 @@ +module Str (Str, empty, append, toString, fromString) where + +-- Concrete implementation of the Str signature using plain String. +type Str = String + +empty :: Str +empty = "" + +append :: Str -> Str -> Str +append = (++) + +toString :: Str -> String +toString = id + +fromString :: String -> Str +fromString = id diff --git a/tests/integration/tests/backpack-private/files/src/main/PrivateBackpack.hs b/tests/integration/tests/backpack-private/files/src/main/PrivateBackpack.hs new file mode 100644 index 0000000000..c3faa73392 --- /dev/null +++ b/tests/integration/tests/backpack-private/files/src/main/PrivateBackpack.hs @@ -0,0 +1,8 @@ +module PrivateBackpack (greetString) where + +import Str (Str, fromString, append, toString) + +-- Public API: no Backpack types leak. Str is resolved internally +-- by mix-in linking str-sig's requirement with str-impl's provision. +greetString :: String -> String +greetString name = toString (fromString "Hello, " `append` fromString name `append` fromString "!") diff --git a/tests/integration/tests/backpack-private/files/src/sig/Str.hsig b/tests/integration/tests/backpack-private/files/src/sig/Str.hsig new file mode 100644 index 0000000000..6115bc93a1 --- /dev/null +++ b/tests/integration/tests/backpack-private/files/src/sig/Str.hsig @@ -0,0 +1,7 @@ +signature Str where + +data Str +empty :: Str +append :: Str -> Str -> Str +toString :: Str -> String +fromString :: String -> Str diff --git a/tests/integration/tests/backpack-private/files/stack.yaml b/tests/integration/tests/backpack-private/files/stack.yaml new file mode 100644 index 0000000000..2bc06edd65 --- /dev/null +++ b/tests/integration/tests/backpack-private/files/stack.yaml @@ -0,0 +1,3 @@ +snapshot: ghc-9.10.3 +packages: + - . diff --git a/tests/integration/tests/backpack-sublib-deps/Main.hs b/tests/integration/tests/backpack-sublib-deps/Main.hs new file mode 100644 index 0000000000..add9a019b7 --- /dev/null +++ b/tests/integration/tests/backpack-sublib-deps/Main.hs @@ -0,0 +1,7 @@ +import StackTest + +-- Test that a package with chained sub-library dependencies builds correctly. +-- lib:core -> lib:extended -> lib (main) -> exe:sublib-deps-demo +-- This already works in Stack; this test prevents regressions. +main :: IO () +main = stack ["build"] diff --git a/tests/integration/tests/backpack-sublib-deps/files/src/core/SublibDeps/Core.hs b/tests/integration/tests/backpack-sublib-deps/files/src/core/SublibDeps/Core.hs new file mode 100644 index 0000000000..08ae3f1958 --- /dev/null +++ b/tests/integration/tests/backpack-sublib-deps/files/src/core/SublibDeps/Core.hs @@ -0,0 +1,4 @@ +module SublibDeps.Core (greet) where + +greet :: String -> String +greet name = "Hello, " ++ name ++ "!" diff --git a/tests/integration/tests/backpack-sublib-deps/files/src/exe/Main.hs b/tests/integration/tests/backpack-sublib-deps/files/src/exe/Main.hs new file mode 100644 index 0000000000..142d54f503 --- /dev/null +++ b/tests/integration/tests/backpack-sublib-deps/files/src/exe/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import SublibDeps (greetLoud) + +main :: IO () +main = putStrLn (greetLoud "world") diff --git a/tests/integration/tests/backpack-sublib-deps/files/src/extended/SublibDeps/Extended.hs b/tests/integration/tests/backpack-sublib-deps/files/src/extended/SublibDeps/Extended.hs new file mode 100644 index 0000000000..f8c5f06e95 --- /dev/null +++ b/tests/integration/tests/backpack-sublib-deps/files/src/extended/SublibDeps/Extended.hs @@ -0,0 +1,10 @@ +module SublibDeps.Extended (greetLoud) where + +import SublibDeps.Core (greet) + +greetLoud :: String -> String +greetLoud name = map toUpper (greet name) + where + toUpper c + | c >= 'a' && c <= 'z' = toEnum (fromEnum c - 32) + | otherwise = c diff --git a/tests/integration/tests/backpack-sublib-deps/files/src/main/SublibDeps.hs b/tests/integration/tests/backpack-sublib-deps/files/src/main/SublibDeps.hs new file mode 100644 index 0000000000..5fa190f1d8 --- /dev/null +++ b/tests/integration/tests/backpack-sublib-deps/files/src/main/SublibDeps.hs @@ -0,0 +1,3 @@ +module SublibDeps (greetLoud) where + +import SublibDeps.Extended (greetLoud) diff --git a/tests/integration/tests/backpack-sublib-deps/files/stack.yaml b/tests/integration/tests/backpack-sublib-deps/files/stack.yaml new file mode 100644 index 0000000000..2bc06edd65 --- /dev/null +++ b/tests/integration/tests/backpack-sublib-deps/files/stack.yaml @@ -0,0 +1,3 @@ +snapshot: ghc-9.10.3 +packages: + - . diff --git a/tests/integration/tests/backpack-sublib-deps/files/sublib-deps.cabal b/tests/integration/tests/backpack-sublib-deps/files/sublib-deps.cabal new file mode 100644 index 0000000000..a063723ed9 --- /dev/null +++ b/tests/integration/tests/backpack-sublib-deps/files/sublib-deps.cabal @@ -0,0 +1,37 @@ +cabal-version: 3.0 +name: sublib-deps +version: 0.1.0.0 +build-type: Simple + +-- A package with sub-libraries that depend on each other. +-- Sub-library "core" is standalone. +-- Sub-library "extended" depends on "core". +-- Main library depends on "extended". +-- This tests intra-package component ordering. + +library core + exposed-modules: SublibDeps.Core + build-depends: base >=4.14 + hs-source-dirs: src/core + default-language: Haskell2010 + +library extended + exposed-modules: SublibDeps.Extended + build-depends: base >=4.14, + sublib-deps:core + hs-source-dirs: src/extended + default-language: Haskell2010 + +library + exposed-modules: SublibDeps + build-depends: base >=4.14, + sublib-deps:extended + hs-source-dirs: src/main + default-language: Haskell2010 + +executable sublib-deps-demo + main-is: Main.hs + build-depends: base >=4.14, + sublib-deps + hs-source-dirs: src/exe + default-language: Haskell2010 diff --git a/tests/integration/tests/per-component-build/Main.hs b/tests/integration/tests/per-component-build/Main.hs new file mode 100644 index 0000000000..6e200bcda1 --- /dev/null +++ b/tests/integration/tests/per-component-build/Main.hs @@ -0,0 +1,33 @@ +import Control.Monad (unless) +import Data.List (isInfixOf) +import StackTest + +main :: IO () +main = do + -- Clean to ensure a full rebuild so we can inspect build output. + stack ["clean"] + + -- Build all targets and verify per-component build messages appear in + -- stderr (Stack prints build progress there). + stackCheckStderr ["build"] $ \err -> do + -- With per-component builds, each executable should be built separately + -- and announced with its component name. + let expect tag = + unless (tag `isInfixOf` err) $ + error $ "Expected " ++ show tag ++ " in build output:\n" ++ err + expect "exe:app1" + expect "exe:app2" + + -- Verify both executables produce correct output. + stackCheckStdout ["exec", "app1"] $ \out -> + unless ("app1: Hello from Lib" `isInfixOf` out) $ + error $ "Unexpected app1 output: " ++ out + + stackCheckStdout ["exec", "app2"] $ \out -> + unless ("app2: Hello from Lib" `isInfixOf` out) $ + error $ "Unexpected app2 output: " ++ out + + -- Run the test suite and verify it passes. + stackCheckStderr ["test"] $ \err -> + unless ("per-component-build" `isInfixOf` err) $ + error $ "Expected package name in test output:\n" ++ err diff --git a/tests/integration/tests/per-component-build/files/app1/Main.hs b/tests/integration/tests/per-component-build/files/app1/Main.hs new file mode 100644 index 0000000000..c4ed68390c --- /dev/null +++ b/tests/integration/tests/per-component-build/files/app1/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib (greeting) + +main :: IO () +main = putStrLn ("app1: " ++ greeting) diff --git a/tests/integration/tests/per-component-build/files/app2/Main.hs b/tests/integration/tests/per-component-build/files/app2/Main.hs new file mode 100644 index 0000000000..2dfa058723 --- /dev/null +++ b/tests/integration/tests/per-component-build/files/app2/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib (greeting) + +main :: IO () +main = putStrLn ("app2: " ++ greeting) diff --git a/tests/integration/tests/per-component-build/files/per-component-build.cabal b/tests/integration/tests/per-component-build/files/per-component-build.cabal new file mode 100644 index 0000000000..5146198749 --- /dev/null +++ b/tests/integration/tests/per-component-build/files/per-component-build.cabal @@ -0,0 +1,30 @@ +cabal-version: 2.0 +name: per-component-build +version: 0.1.0.0 +build-type: Simple +license: BSD3 + +library + exposed-modules: Lib + hs-source-dirs: src + build-depends: base + default-language: Haskell2010 + +executable app1 + main-is: Main.hs + hs-source-dirs: app1 + build-depends: base, per-component-build + default-language: Haskell2010 + +executable app2 + main-is: Main.hs + hs-source-dirs: app2 + build-depends: base, per-component-build + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: base, per-component-build + default-language: Haskell2010 diff --git a/tests/integration/tests/per-component-build/files/src/Lib.hs b/tests/integration/tests/per-component-build/files/src/Lib.hs new file mode 100644 index 0000000000..579eefd84f --- /dev/null +++ b/tests/integration/tests/per-component-build/files/src/Lib.hs @@ -0,0 +1,4 @@ +module Lib (greeting) where + +greeting :: String +greeting = "Hello from Lib" diff --git a/tests/integration/tests/per-component-build/files/stack.yaml b/tests/integration/tests/per-component-build/files/stack.yaml new file mode 100644 index 0000000000..2bc06edd65 --- /dev/null +++ b/tests/integration/tests/per-component-build/files/stack.yaml @@ -0,0 +1,3 @@ +snapshot: ghc-9.10.3 +packages: + - . diff --git a/tests/integration/tests/per-component-build/files/test/Main.hs b/tests/integration/tests/per-component-build/files/test/Main.hs new file mode 100644 index 0000000000..5935fd731b --- /dev/null +++ b/tests/integration/tests/per-component-build/files/test/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import Lib (greeting) +import System.Exit (exitSuccess) + +main :: IO () +main = do + putStrLn ("test: " ++ greeting) + exitSuccess diff --git a/tests/unit/Stack/Build/ConstructPlanSpec.hs b/tests/unit/Stack/Build/ConstructPlanSpec.hs new file mode 100644 index 0000000000..07a758d7e7 --- /dev/null +++ b/tests/unit/Stack/Build/ConstructPlanSpec.hs @@ -0,0 +1,2630 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module Stack.Build.ConstructPlanSpec + ( main + , spec + ) where + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Distribution.CabalSpecVersion ( CabalSpecVersion (..) ) +import Distribution.Compiler ( PerCompilerFlavor (..) ) +import Distribution.License ( License (BSD3) ) +import qualified Distribution.ModuleName as Cabal +import Distribution.PackageDescription + ( BenchmarkInterface (..), BenchmarkType (..) + , TestSuiteInterface (..), TestType (..) + ) +import Distribution.Types.BuildType + ( BuildType (Configure, Custom, Simple) ) +import Distribution.Types.IncludeRenaming + ( IncludeRenaming (..), defaultIncludeRenaming ) +import Distribution.Types.Mixin ( Mixin (..) ) +import Distribution.Types.ModuleRenaming + ( ModuleRenaming (..) ) +import Distribution.Types.LibraryName ( LibraryName (LMainLibName) ) +import Distribution.Types.PackageName ( mkPackageName ) +import Distribution.Types.Version ( mkVersion ) +import Distribution.Types.VersionRange ( anyVersion ) +import Distribution.ModuleName ( ModuleName ) +import Stack.Build.Backpack ( addInstantiationTasks ) +import Stack.Build.ConstructPlan ( shouldSplitComponents ) +import Stack.Build.ExecutePackage + ( findGhcPkgId, mkInstantiateWithOpts ) +import Stack.Package ( hasIntraPackageDeps, packageIsIndefinite ) +import Stack.Prelude +import Stack.Types.Build.ConstructPlan ( AddDepRes (..) ) +import Database.Persist ( PersistField (..), PersistValue (..) ) +import Stack.Types.Cache ( CachePkgSrc (..), ConfigCacheType (..) ) +import Stack.Types.CompCollection + ( foldAndMakeCollection, getBuildableSet ) +import Stack.Types.Component + ( StackBenchmark (..), StackBuildInfo (..) + , StackExecutable (..), StackForeignLibrary (..) + , StackLibrary (..), StackTestSuite (..) + ) +import Stack.Types.ComponentUtils + ( emptyCompName, unqualCompFromString ) +import Stack.Types.Dependency + ( DepLibrary (..), DepType (..), DepValue (..) ) +import Stack.Types.Installed + ( InstallLocation (..), Installed (..) + , installedLibraryInfoFromGhcPkgId + ) +import Stack.Types.GhcPkgId ( GhcPkgId, parseGhcPkgId ) +import Stack.Types.IsMutable ( IsMutable (..) ) +import Stack.Types.NamedComponent ( NamedComponent (..) ) +import Stack.Types.Package ( Package (..), packageIdentifier ) +import Stack.Types.PackageFile ( StackPackageFile (..) ) +import Stack.Types.Plan + ( ComponentKey (..), Task (..), TaskConfigOpts (..) + , TaskType (..) + ) +import Test.Hspec + ( Spec, describe, expectationFailure, hspec, it + , shouldBe, shouldSatisfy + ) + +main :: IO () +main = hspec spec + +-- | A minimal StackBuildInfo suitable for testing. All lazy fields are empty +-- lists/sets; buildable defaults to True, no dependencies. +testBuildInfo :: StackBuildInfo +testBuildInfo = StackBuildInfo + { buildable = True + , dependency = Map.empty + , unknownTools = Set.empty + , otherModules = [] + , jsSources = [] + , hsSourceDirs = [] + , cSources = [] + , cppOptions = [] + , targetBuildDepends = [] + , options = PerCompilerFlavor [] [] + , allLanguages = [] + , usedExtensions = [] + , includeDirs = [] + , extraLibs = [] + , extraLibDirs = [] + , frameworks = [] + , mixins = [] + } + +-- | A build info that declares a dependency on the package itself (Backpack). +selfDepBuildInfo :: PackageName -> StackBuildInfo +selfDepBuildInfo pn = testBuildInfo + { dependency = Map.singleton pn depVal } + where + depVal = DepValue + { versionRange = anyVersion + , depType = AsLibrary DepLibrary { main = True, subLib = Set.empty } + } + +-- | Create a minimal test Package. +testPackage :: PackageName -> BuildType -> Package +testPackage pn bt = Package + { name = pn + , version = mkVersion [1, 0, 0] + , license = Right BSD3 + , ghcOptions = [] + , cabalConfigOpts = [] + , flags = Map.empty + , defaultFlags = Map.empty + , library = Nothing + , subLibraries = mempty + , foreignLibraries = mempty + , testSuites = mempty + , benchmarks = mempty + , executables = mempty + , buildType = bt + , setupDeps = Nothing + , cabalSpec = CabalSpecV2_0 + , file = StackPackageFile + { extraSrcFiles = [], dataDir = "", dataFiles = [] } + , testEnabled = False + , benchmarkEnabled = False + } + +-- | Add a buildable main library to a package. +withLibrary :: Package -> Package +withLibrary pkg = pkg + { library = Just StackLibrary + { name = emptyCompName + , buildInfo = testBuildInfo + , exposedModules = [] + , signatures = [] + } + } + +-- | Add a buildable main library that depends on itself (Backpack pattern: +-- main lib using internal sub-libs). +withSelfDepLibrary :: Package -> Package +withSelfDepLibrary pkg = pkg + { library = Just StackLibrary + { name = emptyCompName + , buildInfo = selfDepBuildInfo pkg.name + , exposedModules = [] + , signatures = [] + } + } + +-- | Add a buildable sub-library that depends on the same package (Backpack +-- pattern: sub-library chains). +withSelfDepSubLib :: Package -> Package +withSelfDepSubLib pkg = pkg + { subLibraries = foldAndMakeCollection id + [ StackLibrary + { name = unqualCompFromString "internal" + , buildInfo = selfDepBuildInfo pkg.name + , exposedModules = [] + , signatures = [] + } + ] + } + +-- | Add a buildable main library with Backpack signatures (makes it indefinite). +withIndefiniteLibrary :: [ModuleName] -> Package -> Package +withIndefiniteLibrary sigs pkg = pkg + { library = Just StackLibrary + { name = emptyCompName + , buildInfo = testBuildInfo + , exposedModules = [] + , signatures = sigs + } + } + +-- | Add buildable executables to a package. +withExes :: [String] -> Package -> Package +withExes names pkg = pkg + { executables = foldAndMakeCollection id + [ StackExecutable + { name = unqualCompFromString n + , buildInfo = testBuildInfo + , modulePath = "Main.hs" + } + | n <- names + ] + } + +-- | Add buildable executables that depend on the package's own library. +-- This is the common Cabal pattern: @build-depends: my-package@. +withSelfDepExes :: [String] -> Package -> Package +withSelfDepExes names pkg = pkg + { executables = foldAndMakeCollection id + [ StackExecutable + { name = unqualCompFromString n + , buildInfo = selfDepBuildInfo pkg.name + , modulePath = "Main.hs" + } + | n <- names + ] + } + +-- | Add buildable test suites that depend on the package's own library. +-- This is the common Cabal pattern: @build-depends: my-package@. +withSelfDepTests :: [String] -> Package -> Package +withSelfDepTests names pkg = pkg + { testSuites = foldAndMakeCollection id + [ StackTestSuite + { name = unqualCompFromString n + , buildInfo = selfDepBuildInfo pkg.name + , interface = TestSuiteUnsupported (TestTypeUnknown "" (mkVersion [0])) + } + | n <- names + ] + } + +-- | Add buildable benchmarks that depend on the package's own library. +withSelfDepBenchmarks :: [String] -> Package -> Package +withSelfDepBenchmarks names pkg = pkg + { benchmarks = foldAndMakeCollection id + [ StackBenchmark + { name = unqualCompFromString n + , buildInfo = selfDepBuildInfo pkg.name + , interface = BenchmarkUnsupported (BenchmarkTypeUnknown "" (mkVersion [0])) + } + | n <- names + ] + } + +-- | Add buildable foreign libraries that depend on the package itself. +withSelfDepForeignLibs :: [String] -> Package -> Package +withSelfDepForeignLibs names pkg = pkg + { foreignLibraries = foldAndMakeCollection id + [ StackForeignLibrary + { name = unqualCompFromString n + , buildInfo = selfDepBuildInfo pkg.name + } + | n <- names + ] + } + +-- | Add buildable sub-libraries to a package. +withSubLibs :: [String] -> Package -> Package +withSubLibs names pkg = pkg + { subLibraries = foldAndMakeCollection id + [ StackLibrary + { name = unqualCompFromString n + , buildInfo = testBuildInfo + , exposedModules = [] + , signatures = [] + } + | n <- names + ] + } + +-- | Add buildable foreign libraries to a package. +withForeignLibs :: [String] -> Package -> Package +withForeignLibs names pkg = pkg + { foreignLibraries = foldAndMakeCollection id + [ StackForeignLibrary + { name = unqualCompFromString n + , buildInfo = testBuildInfo + } + | n <- names + ] + } + +-- | Add buildable test suites to a package. +withTests :: [String] -> Package -> Package +withTests names pkg = pkg + { testSuites = foldAndMakeCollection id + [ StackTestSuite + { name = unqualCompFromString n + , buildInfo = testBuildInfo + , interface = TestSuiteUnsupported (TestTypeUnknown "" (mkVersion [0])) + } + | n <- names + ] + } + +-- | Add buildable benchmarks to a package. +withBenchmarks :: [String] -> Package -> Package +withBenchmarks names pkg = pkg + { benchmarks = foldAndMakeCollection id + [ StackBenchmark + { name = unqualCompFromString n + , buildInfo = testBuildInfo + , interface = BenchmarkUnsupported (BenchmarkTypeUnknown "" (mkVersion [0])) + } + | n <- names + ] + } + +spec :: Spec +spec = do + describe "shouldSplitComponents" $ do + it "returns True for Simple package without intra-package deps" $ do + let pkg = testPackage (mkPackageName "pkg") Simple + shouldSplitComponents pkg `shouldBe` True + + it "returns False for Custom build type" $ do + let pkg = testPackage (mkPackageName "pkg") Custom + shouldSplitComponents pkg `shouldBe` False + + it "returns False for Configure build type" $ do + let pkg = testPackage (mkPackageName "pkg") Configure + shouldSplitComponents pkg `shouldBe` False + + it "returns False when main lib depends on own sub-libs (Backpack)" $ do + let pkg = withSelfDepLibrary $ testPackage (mkPackageName "pkg") Simple + shouldSplitComponents pkg `shouldBe` False + + it "returns False when sub-lib has self-dep (Backpack)" $ do + let pkg = withSelfDepSubLib $ testPackage (mkPackageName "pkg") Simple + shouldSplitComponents pkg `shouldBe` False + + it "returns True when only exes depend on own lib (normal pattern)" $ do + let pkg = withSelfDepExes ["my-exe"] + $ withLibrary + $ testPackage (mkPackageName "pkg") Simple + shouldSplitComponents pkg `shouldBe` True + + it "returns True for Simple package with library but no self-dep" $ do + let pkg = withLibrary $ testPackage (mkPackageName "pkg") Simple + shouldSplitComponents pkg `shouldBe` True + + it "returns True for Simple package with exes and lib" $ do + let pkg = withExes ["exe1", "exe2"] + $ withLibrary + $ testPackage (mkPackageName "pkg") Simple + shouldSplitComponents pkg `shouldBe` True + + it "returns True when tests depend on own lib (normal pattern)" $ do + let pkg = withSelfDepTests ["my-tests"] + $ withLibrary + $ testPackage (mkPackageName "pkg") Simple + shouldSplitComponents pkg `shouldBe` True + + it "returns True when benchmarks depend on own lib (normal pattern)" $ do + let pkg = withSelfDepBenchmarks ["my-bench"] + $ withLibrary + $ testPackage (mkPackageName "pkg") Simple + shouldSplitComponents pkg `shouldBe` True + + it "returns True when foreign lib has self-dep (not Backpack)" $ do + let pkg = withSelfDepForeignLibs ["cbits"] + $ withLibrary + $ testPackage (mkPackageName "pkg") Simple + shouldSplitComponents pkg `shouldBe` True + + it "returns True for all non-library self-deps combined" $ do + let pkg = withSelfDepExes ["app"] + $ withSelfDepTests ["tests"] + $ withSelfDepBenchmarks ["bench"] + $ withSelfDepForeignLibs ["ffi"] + $ withLibrary + $ testPackage (mkPackageName "pkg") Simple + shouldSplitComponents pkg `shouldBe` True + + it "returns False for indefinite package (has signatures)" $ do + let pkg = withIndefiniteLibrary ["Str"] + $ testPackage (mkPackageName "sig-pkg") Simple + shouldSplitComponents pkg `shouldBe` False + + describe "packageIsIndefinite" $ do + it "returns False for package without signatures" $ do + let pkg = withLibrary $ testPackage (mkPackageName "pkg") Simple + packageIsIndefinite pkg `shouldBe` False + + it "returns True for package with signatures" $ do + let pkg = withIndefiniteLibrary ["Str"] + $ testPackage (mkPackageName "sig-pkg") Simple + packageIsIndefinite pkg `shouldBe` True + + it "returns True for package with multiple signatures" $ do + let pkg = withIndefiniteLibrary ["Str", "Num"] + $ testPackage (mkPackageName "sig-pkg") Simple + packageIsIndefinite pkg `shouldBe` True + + it "returns True for sub-library with signatures" $ do + let pkg = (withLibrary $ testPackage (mkPackageName "pkg") Simple) + { subLibraries = foldAndMakeCollection id + [ StackLibrary + { name = unqualCompFromString "indef-sub" + , buildInfo = testBuildInfo + , exposedModules = [] + , signatures = ["Str"] + } + ] + } + packageIsIndefinite pkg `shouldBe` True + + it "returns False for package with no library" $ do + let pkg = withExes ["app"] $ testPackage (mkPackageName "pkg") Simple + packageIsIndefinite pkg `shouldBe` False + + describe "hasIntraPackageDeps" $ do + it "returns False for plain library" $ do + let pkg = withLibrary $ testPackage (mkPackageName "pkg") Simple + hasIntraPackageDeps pkg `shouldBe` False + + it "returns True when main lib depends on own sub-libs" $ do + let pkg = withSelfDepLibrary $ testPackage (mkPackageName "pkg") Simple + hasIntraPackageDeps pkg `shouldBe` True + + it "returns True when sub-lib has self-dep" $ do + let pkg = withSelfDepSubLib $ testPackage (mkPackageName "pkg") Simple + hasIntraPackageDeps pkg `shouldBe` True + + it "returns True for indefinite package (has signatures)" $ do + let pkg = withIndefiniteLibrary ["Str"] + $ testPackage (mkPackageName "sig-pkg") Simple + hasIntraPackageDeps pkg `shouldBe` True + + it "returns False when only exes have self-dep" $ do + let pkg = withSelfDepExes ["app"] + $ withLibrary + $ testPackage (mkPackageName "pkg") Simple + hasIntraPackageDeps pkg `shouldBe` False + + it "returns False when only tests have self-dep" $ do + let pkg = withSelfDepTests ["tests"] + $ withLibrary + $ testPackage (mkPackageName "pkg") Simple + hasIntraPackageDeps pkg `shouldBe` False + + describe "per-component task expansion" $ do + describe "component enumeration" $ do + it "lib-only package produces [CLib]" $ do + let pkg = withLibrary $ testPackage (mkPackageName "pkg") Simple + comps = packageBuildableComponents pkg + comps `shouldBe` [CLib] + + it "lib+exe package produces [CLib, CExe]" $ do + let pkg = withExes ["my-exe"] + $ withLibrary + $ testPackage (mkPackageName "pkg") Simple + comps = packageBuildableComponents pkg + comps `shouldSatisfy` (CLib `elem`) + comps `shouldSatisfy` + (CExe (unqualCompFromString "my-exe") `elem`) + length comps `shouldBe` 2 + + it "exe-only package (no lib) produces [CExe]" $ do + let pkg = withExes ["app"] + $ testPackage (mkPackageName "pkg") Simple + comps = packageBuildableComponents pkg + comps `shouldBe` [CExe (unqualCompFromString "app")] + + it "package with sub-libraries produces CLib + CSubLib entries" $ do + let pkg = withSubLibs ["internal"] + $ withLibrary + $ testPackage (mkPackageName "pkg") Simple + comps = packageBuildableComponents pkg + length comps `shouldBe` 2 + comps `shouldSatisfy` (CLib `elem`) + comps `shouldSatisfy` + (CSubLib (unqualCompFromString "internal") `elem`) + + it "package with foreign libraries produces CFlib entries" $ do + let pkg = withForeignLibs ["cbits"] + $ withLibrary + $ testPackage (mkPackageName "pkg") Simple + comps = packageBuildableComponents pkg + length comps `shouldBe` 2 + comps `shouldSatisfy` (CFlib (unqualCompFromString "cbits") `elem`) + + it "package with multiple exes produces one CExe per exe" $ do + let pkg = withExes ["exe-a", "exe-b", "exe-c"] + $ testPackage (mkPackageName "pkg") Simple + comps = packageBuildableComponents pkg + length comps `shouldBe` 3 + + it "full package produces CLib + CSubLib + CFlib + CExe" $ do + let pkg = withExes ["app"] + $ withSubLibs ["sub"] + $ withForeignLibs ["ffi"] + $ withLibrary + $ testPackage (mkPackageName "pkg") Simple + comps = packageBuildableComponents pkg + length comps `shouldBe` 4 + + it "empty package (no components) produces empty list" $ do + let pkg = testPackage (mkPackageName "pkg") Simple + comps = packageBuildableComponents pkg + -- No library, no exes, no sub-libs, no foreign libs + -- expandToComponentKeys would fall back to CLib for this case + comps `shouldBe` [] + + describe "ComponentKey expansion" $ do + it "lib+exe package produces distinct ComponentKeys" $ do + let pn = mkPackageName "pkg" + pkg = withExes ["my-exe"] + $ withLibrary + $ testPackage pn Simple + keys = packageToComponentKeys pn pkg + Set.size (Set.fromList keys) `shouldBe` 2 + keys `shouldSatisfy` (ComponentKey pn CLib `elem`) + keys `shouldSatisfy` + (ComponentKey pn (CExe (unqualCompFromString "my-exe")) `elem`) + + it "non-splittable package always maps to single CLib key" $ do + let pn = mkPackageName "pkg" + pkg = withExes ["my-exe"] + $ withLibrary + $ testPackage pn Custom + keys = packageToComponentKeys pn pkg + keys `shouldBe` [ComponentKey pn CLib] + + it "Backpack package (sub-lib self-dep) maps to single CLib key" $ do + let pn = mkPackageName "pkg" + pkg = withExes ["my-exe"] + $ withSelfDepSubLib + $ testPackage pn Simple + keys = packageToComponentKeys pn pkg + keys `shouldBe` [ComponentKey pn CLib] + + it "empty splittable package falls back to CLib" $ do + let pn = mkPackageName "pkg" + pkg = testPackage pn Simple + keys = packageToComponentKeys pn pkg + keys `shouldBe` [ComponentKey pn CLib] + + it "tests and benchmarks are NOT in build component keys" $ do + let pn = mkPackageName "pkg" + pkg = withTests ["test-suite"] + $ withBenchmarks ["bench"] + $ withLibrary + $ testPackage pn Simple + comps = packageBuildableComponents pkg + -- Tests and benchmarks go into finals, not build tasks + comps `shouldBe` [CLib] + + describe "finals splitting" $ do + it "test components produce CTest keys" $ do + let pn = mkPackageName "pkg" + pkg = withTests ["suite-a", "suite-b"] + $ withLibrary + $ testPackage pn Simple + finalKeys = packageToFinalKeys pn pkg (Set.fromList + [ CTest (unqualCompFromString "suite-a") + , CTest (unqualCompFromString "suite-b") + ]) + length finalKeys `shouldBe` 2 + finalKeys `shouldSatisfy` + (ComponentKey pn (CTest (unqualCompFromString "suite-a")) `elem`) + finalKeys `shouldSatisfy` + (ComponentKey pn (CTest (unqualCompFromString "suite-b")) `elem`) + + it "bench components produce CBench keys" $ do + let pn = mkPackageName "pkg" + pkg = withBenchmarks ["bench-a"] + $ withLibrary + $ testPackage pn Simple + finalKeys = packageToFinalKeys pn pkg (Set.fromList + [ CBench (unqualCompFromString "bench-a") + ]) + finalKeys `shouldBe` + [ComponentKey pn (CBench (unqualCompFromString "bench-a"))] + + it "non-splittable package uses single CLib key for finals" $ do + let pn = mkPackageName "pkg" + pkg = withTests ["tests"] + $ withLibrary + $ testPackage pn Custom + finalKeys = packageToFinalKeys pn pkg (Set.fromList + [ CTest (unqualCompFromString "tests") + ]) + finalKeys `shouldBe` [ComponentKey pn CLib] + + it "mixed test+bench components produce both keys" $ do + let pn = mkPackageName "pkg" + pkg = withTests ["tests"] + $ withBenchmarks ["bench"] + $ withLibrary + $ testPackage pn Simple + finalKeys = packageToFinalKeys pn pkg (Set.fromList + [ CTest (unqualCompFromString "tests") + , CBench (unqualCompFromString "bench") + ]) + length finalKeys `shouldBe` 2 + + it "empty components for splittable package falls back to CLib" $ do + let pn = mkPackageName "pkg" + pkg = withLibrary $ testPackage pn Simple + finalKeys = packageToFinalKeys pn pkg Set.empty + finalKeys `shouldBe` [ComponentKey pn CLib] + + describe "addInstantiationTasks" $ do + it "no mixins → no instantiation tasks added" $ do + let consumerPn = mkPackageName "consumer" + consumerPkg = withLibrary $ testPackage consumerPn Simple + consumerTask = mockTask consumerPkg + origAdrs = [(consumerPn, ADRToInstall consumerTask)] + expanded = [(ComponentKey consumerPn CLib, ADRToInstall consumerTask)] + (result, _warnings) = addInstantiationTasks Map.empty origAdrs expanded + -- No CInst tasks should be created. + let instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + instKeys `shouldBe` [] + + it "mixin referencing indefinite dep creates CInst task" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, _warnings) = addInstantiationTasks Map.empty origAdrs expanded + instEntries = [ (ck, t) + | (ck@(ComponentKey pn (CInst _)), ADRToInstall t) + <- result + , pn == sigPn + ] + -- Exactly one CInst task for sig-pkg. + length instEntries `shouldBe` 1 + + it "CInst task has correct backpackInstEntries" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, _warnings) = addInstantiationTasks Map.empty origAdrs expanded + instTasks = [ t + | (ComponentKey pn (CInst _), ADRToInstall t) <- result + , pn == sigPn + ] + case instTasks of + [t] -> do + let entries = t.backpackInstEntries + length entries `shouldBe` 1 + case entries of + [(sig, ipn, imod)] -> do + sig `shouldBe` mn "Str" + ipn `shouldBe` implPn + imod `shouldBe` mn "Str" + _ -> error "unexpected entries length" + _ -> error "expected exactly one CInst task" + + it "CInst task's missing includes impl-pkg dep" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, _warnings) = addInstantiationTasks Map.empty origAdrs expanded + instTasks = [ t + | (ComponentKey pn (CInst _), ADRToInstall t) <- result + , pn == sigPn + ] + case instTasks of + [t] -> + -- The CInst task's missing should include impl-pkg's identifier. + Set.member (packageIdentifier implPkg) t.configOpts.missing + `shouldBe` True + _ -> error "expected exactly one CInst task" + + it "consumer's instantiationDeps includes the CInst key" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, _warnings) = addInstantiationTasks Map.empty origAdrs expanded + consumerTasks = [ t + | (ComponentKey pn CLib, ADRToInstall t) <- result + , pn == consumerPn + ] + case consumerTasks of + [t] -> do + let deps = t.configOpts.instantiationDeps + length deps `shouldBe` 1 + case deps of + [ComponentKey pn (CInst _)] -> pn `shouldBe` sigPn + _ -> error "expected CInst dep on sig-pkg" + _ -> error "expected exactly one consumer task" + + it "mixin referencing non-indefinite dep creates no CInst task" $ do + let depPn = mkPackageName "dep-pkg" + consumerPn = mkPackageName "consumer" + -- dep-pkg has a library but NO signatures (not indefinite). + depPkg = withExposingLibrary [mn "Foo"] + $ testPackage depPn Simple + consumerPkg = withDeps [depPn] + $ withMixins [defaultMixin depPn] + $ withLibrary + $ testPackage consumerPn Simple + depTask = mockTask depPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (depPn, ADRToInstall depTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey depPn CLib, ADRToInstall depTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, _warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + instKeys `shouldBe` [] + + it "multiple signatures produce single CInst with multiple entries" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str", mn "Num"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str", mn "Num"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, _warnings) = addInstantiationTasks Map.empty origAdrs expanded + instTasks = [ t + | (ComponentKey pn (CInst _), ADRToInstall t) <- result + , pn == sigPn + ] + case instTasks of + [t] -> length t.backpackInstEntries `shouldBe` 2 + _ -> error "expected exactly one CInst task" + + it "DefaultRenaming maps signatures to identity" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, _warnings) = addInstantiationTasks Map.empty origAdrs expanded + instTasks = [ t + | (ComponentKey pn (CInst _), ADRToInstall t) <- result + , pn == sigPn + ] + case instTasks of + [t] -> case t.backpackInstEntries of + [(sig, _, implMod)] -> do + -- With DefaultRenaming, sig name == impl module name. + sig `shouldBe` mn "Str" + implMod `shouldBe` mn "Str" + _ -> error "expected one entry" + _ -> error "expected one CInst task" + + it "CInst task's missing preserves sig-pkg's original missing" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + extraDepPn = mkPackageName "extra-dep" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + -- Give sigTask a pre-existing missing dep. + extraDepPid = PackageIdentifier extraDepPn (mkVersion [2, 0]) + sigTask = (mockTask sigPkg) + { configOpts = (mockTask sigPkg).configOpts + { missing = Set.singleton extraDepPid } + } + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, _warnings) = addInstantiationTasks Map.empty origAdrs expanded + instTasks = [ t + | (ComponentKey pn (CInst _), ADRToInstall t) <- result + , pn == sigPn + ] + case instTasks of + [t] -> do + -- Should contain both the original extra-dep AND impl-pkg. + Set.member extraDepPid t.configOpts.missing `shouldBe` True + Set.member (packageIdentifier implPkg) t.configOpts.missing + `shouldBe` True + _ -> error "expected exactly one CInst task" + + it "explicit ModuleRenaming maps sig to renamed module" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + -- sig-pkg has signature "Str" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + -- impl-pkg exposes "Data.Text.Impl" (not "Str") + implPkg = withExposingLibrary [mn "Data.Text.Impl"] + $ testPackage implPn Simple + -- consumer uses explicit renaming: Str = Data.Text.Impl + consumerPkg = withDeps [sigPn, implPn] + $ withMixins + [explicitRequiresMixin sigPn [(mn "Str", mn "Data.Text.Impl")]] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, _warnings) = addInstantiationTasks Map.empty origAdrs expanded + instTasks = [ t + | (ComponentKey pn (CInst _), ADRToInstall t) <- result + , pn == sigPn + ] + case instTasks of + [t] -> case t.backpackInstEntries of + [(sig, ipn, implMod)] -> do + sig `shouldBe` mn "Str" + ipn `shouldBe` implPn + implMod `shouldBe` mn "Data.Text.Impl" + _ -> error "expected one entry" + _ -> error "expected one CInst task" + + it "HidingRenaming hiding nothing instantiates all sigs" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + hidingMixin = Mixin + { mixinPackageName = sigPn + , mixinLibraryName = LMainLibName + , mixinIncludeRenaming = IncludeRenaming + { includeProvidesRn = DefaultRenaming + , includeRequiresRn = HidingRenaming [] + } + } + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [hidingMixin] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + length instKeys `shouldBe` 1 + length warnings `shouldBe` 0 + + it "HidingRenaming with actual hidden sigs produces no CInst" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str", mn "Num"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str", mn "Num"] + $ testPackage implPn Simple + -- Hide "Str" — can't fully instantiate, so no CInst. + hidingMixin = Mixin + { mixinPackageName = sigPn + , mixinLibraryName = LMainLibName + , mixinIncludeRenaming = IncludeRenaming + { includeProvidesRn = DefaultRenaming + , includeRequiresRn = HidingRenaming [mn "Str"] + } + } + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [hidingMixin] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + -- Partial instantiation not possible — no CInst, no warning. + instKeys `shouldBe` [] + length warnings `shouldBe` 0 + + it "HidingRenaming hiding all sigs produces no CInst" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + hidingMixin = Mixin + { mixinPackageName = sigPn + , mixinLibraryName = LMainLibName + , mixinIncludeRenaming = IncludeRenaming + { includeProvidesRn = DefaultRenaming + , includeRequiresRn = HidingRenaming [mn "Str"] + } + } + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [hidingMixin] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + instKeys `shouldBe` [] + length warnings `shouldBe` 0 + + it "no CInst when no dep exposes the required module, with warning" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + -- impl-pkg exposes "Foo" not "Str" + implPkg = withExposingLibrary [mn "Foo"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + instKeys `shouldBe` [] + length warnings `shouldBe` 1 + + it "ADRFound dep for sig-pkg is skipped with warning" $ do + let sigPn = mkPackageName "sig-pkg" + consumerPn = mkPackageName "consumer" + consumerPkg = withDeps [sigPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + consumerTask = mockTask consumerPkg + sigPid = PackageIdentifier sigPn (mkVersion [1, 0]) + sigFound = ADRFound Snap (Library sigPid + (installedLibraryInfoFromGhcPkgId + (error "ghcPkgId not needed"))) + origAdrs = + [ (sigPn, sigFound) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, sigFound) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + instKeys `shouldBe` [] + length warnings `shouldBe` 1 + + it "successful resolution produces no warnings" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + length instKeys `shouldBe` 1 + warnings `shouldSatisfy` null + + it "CInst hash is deterministic for same entries" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result1, _) = addInstantiationTasks Map.empty origAdrs expanded + (result2, _) = addInstantiationTasks Map.empty origAdrs expanded + getHash rs = + [ h | (ComponentKey _ (CInst h), _) <- rs ] + getHash result1 `shouldBe` getHash result2 + getHash result1 `shouldSatisfy` (not . null) + + it "deduplicates CInst tasks from multiple consumer components" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + -- Consumer has both a library and an exe, both with the same mixin + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withExes ["demo"] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + -- Two consumer components in expanded: CLib and CExe + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + , ( ComponentKey consumerPn + (CExe (unqualCompFromString "demo")) + , ADRToInstall consumerTask + ) + ] + (result, _warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + -- Should produce exactly one CInst entry, not two + length instKeys `shouldBe` 1 + + it "multiple deps exposing same module produces warning and no CInst" $ do + let sigPn = mkPackageName "sig-pkg" + implPn1 = mkPackageName "impl-a" + implPn2 = mkPackageName "impl-b" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + -- Both impl packages expose the same module "Str" + implPkg1 = withExposingLibrary [mn "Str"] + $ testPackage implPn1 Simple + implPkg2 = withExposingLibrary [mn "Str"] + $ testPackage implPn2 Simple + consumerPkg = withDeps [sigPn, implPn1, implPn2] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask1 = mockTask implPkg1 + implTask2 = mockTask implPkg2 + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn1, ADRToInstall implTask1) + , (implPn2, ADRToInstall implTask2) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn1 CLib, ADRToInstall implTask1) + , (ComponentKey implPn2 CLib, ADRToInstall implTask2) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + instKeys `shouldBe` [] + length warnings `shouldBe` 1 + + it "partial resolution: one sig resolves, one warns" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + -- sig-pkg has two signatures: Str and Map + sigPkg = withIndefiniteLibrary [mn "Str", mn "Map"] + $ testPackage sigPn Simple + -- impl-pkg only exposes Str, not Map + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instTasks = [ t + | (ComponentKey _ (CInst _), ADRToInstall t) <- result + ] + -- Str resolves so CInst is created, but Map warns + length instTasks `shouldBe` 1 + length (concatMap (.backpackInstEntries) instTasks) `shouldBe` 1 + length warnings `shouldBe` 1 + + it "ModuleRenaming with unresolvable module produces warning" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + -- impl-pkg exposes Foo, not RenamedStr + implPkg = withExposingLibrary [mn "Foo"] + $ testPackage implPn Simple + renameMixin = Mixin + { mixinPackageName = sigPn + , mixinLibraryName = LMainLibName + , mixinIncludeRenaming = IncludeRenaming + { includeProvidesRn = DefaultRenaming + , includeRequiresRn = + ModuleRenaming [(mn "Str", mn "RenamedStr")] + } + } + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [renameMixin] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + instKeys `shouldBe` [] + length warnings `shouldBe` 1 + + it "non-indefinite mixin dep produces no warning" $ do + let regularPn = mkPackageName "regular-pkg" + consumerPn = mkPackageName "consumer" + -- regular-pkg is NOT indefinite (no signatures) + regularPkg = withExposingLibrary [mn "Foo"] + $ testPackage regularPn Simple + consumerPkg = withDeps [regularPn] + $ withMixins [defaultMixin regularPn] + $ withLibrary + $ testPackage consumerPn Simple + regularTask = mockTask regularPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (regularPn, ADRToInstall regularTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey regularPn CLib, ADRToInstall regularTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + instKeys `shouldBe` [] + warnings `shouldSatisfy` null + + it "sub-library mixin creates CInst task" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + -- Consumer has the mixin on a sub-library, not the main library + consumerPkg = withDeps [sigPn, implPn] + $ withSubLibMixins "internal" [defaultMixin sigPn] + $ withSubLibs ["internal"] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + length instKeys `shouldBe` 1 + warnings `shouldSatisfy` null + + it "impl module in sub-library is found" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + -- impl-pkg exposes Str only via a sub-library, not the main library + implPkg = withExposingSubLib "internal" [mn "Str"] + $ withLibrary + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + length instKeys `shouldBe` 1 + warnings `shouldSatisfy` null + + it "sub-library mixin + sub-library impl module resolves" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + -- impl-pkg exposes Str only via sub-library + implPkg = withExposingSubLib "str-impl" [mn "Str"] + $ withLibrary + $ testPackage implPn Simple + -- consumer has mixin on its sub-library + consumerPkg = withDeps [sigPn, implPn] + $ withSubLibMixins "uses-sig" [defaultMixin sigPn] + $ withSubLibs ["uses-sig"] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + length instKeys `shouldBe` 1 + warnings `shouldSatisfy` null + + it "main lib and sub-lib both with same mixin deduplicates CInst" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + -- Both main library and sub-library reference the same mixin + consumerPkg = withDeps [sigPn, implPn] + $ withSubLibMixins "internal" [defaultMixin sigPn] + $ withSubLibs ["internal"] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + -- Same mixin → same hash → deduplicated to one CInst + length instKeys `shouldBe` 1 + warnings `shouldSatisfy` null + + it "impl module exposed by both main lib and sub-lib is not ambiguous" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + -- impl-pkg exposes Str in both main library and sub-library + implPkg = withExposingSubLib "extra" [mn "Str"] + $ withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + -- Same package exposes it — should resolve (not count as two candidates) + length instKeys `shouldBe` 1 + warnings `shouldSatisfy` null + + it "sub-lib with no mixins produces no CInst" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + -- Sub-library exists but has no mixins; only main lib matters + consumerPkg = withSubLibs ["internal"] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + instKeys `shouldBe` [] + warnings `shouldSatisfy` null + + it "transitive chain: inherited sigs filled in CInst" $ do + -- str-sig (indefinite, sig: Str) + -- logger-sig (indefinite, sig: Logger, depends on str-sig) + -- impl-pkg (concrete, exposes: Str, Logger) + -- consumer (mixins: logger-sig requires (Logger as Logger)) + -- logger-sig CInst must fill BOTH Logger (own) and Str (inherited) + let strSigPn = mkPackageName "str-sig" + loggerSigPn = mkPackageName "logger-sig" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + strSigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage strSigPn Simple + loggerSigPkg = withIndefiniteLibraryDeps [mn "Logger"] [strSigPn] + $ testPackage loggerSigPn Simple + implPkg = withExposingLibrary [mn "Str", mn "Logger"] + $ testPackage implPn Simple + consumerPkg = withDeps [strSigPn, loggerSigPn, implPn] + $ withMixins [defaultMixin loggerSigPn] + $ withLibrary + $ testPackage consumerPn Simple + strSigTask = mockTask strSigPkg + loggerSigTask = mockTask loggerSigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (strSigPn, ADRToInstall strSigTask) + , (loggerSigPn, ADRToInstall loggerSigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey strSigPn CLib, ADRToInstall strSigTask) + , (ComponentKey loggerSigPn CLib, ADRToInstall loggerSigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instEntries = [ (ck, t.backpackInstEntries) + | (ck@(ComponentKey pn (CInst _)), ADRToInstall t) + <- result + , pn == loggerSigPn + ] + -- Exactly one CInst for logger-sig + length instEntries `shouldBe` 1 + -- The CInst must have entries for BOTH Logger and Str + case instEntries of + [(_, entries)] -> do + let sigNames = map (\(s, _, _) -> s) entries + sigNames `shouldSatisfy` (mn "Logger" `elem`) + sigNames `shouldSatisfy` (mn "Str" `elem`) + _ -> error "expected exactly one CInst" + warnings `shouldSatisfy` null + + it "transitive chain: no inherited sigs from concrete dep" $ do + -- sig-pkg (indefinite, sig: Str) + -- concrete-dep (concrete lib, depends on sig-pkg in build-depends) + -- consumer (mixins: sig-pkg) + -- sig-pkg CInst should only fill Str (no inherited sigs from concrete) + let sigPn = mkPackageName "sig-pkg" + concretePn = mkPackageName "concrete-dep" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + -- concrete-dep is NOT indefinite — just a regular package + concretePkg = withLibrary $ testPackage concretePn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + concreteTask = mockTask concretePkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (concretePn, ADRToInstall concreteTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey concretePn CLib, ADRToInstall concreteTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instEntries = [ (ck, t.backpackInstEntries) + | (ck@(ComponentKey pn (CInst _)), ADRToInstall t) + <- result + , pn == sigPn + ] + length instEntries `shouldBe` 1 + case instEntries of + [(_, entries)] -> do + let sigNames = map (\(s, _, _) -> s) entries + sigNames `shouldBe` [mn "Str"] + _ -> error "expected exactly one CInst" + warnings `shouldSatisfy` null + + it "three-level transitive chain fills all inherited sigs" $ do + -- base-sig (indefinite, sig: Base) + -- mid-sig (indefinite, sig: Mid, depends on base-sig) + -- top-sig (indefinite, sig: Top, depends on mid-sig) + -- impl (concrete, exposes: Base, Mid, Top) + -- consumer (mixins: top-sig) + -- top-sig CInst must fill Top (own) + Mid (from mid-sig) + Base (from + -- base-sig, transitively) + let baseSigPn = mkPackageName "base-sig" + midSigPn = mkPackageName "mid-sig" + topSigPn = mkPackageName "top-sig" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + baseSigPkg = withIndefiniteLibrary [mn "Base"] + $ testPackage baseSigPn Simple + midSigPkg = withIndefiniteLibraryDeps [mn "Mid"] [baseSigPn] + $ testPackage midSigPn Simple + topSigPkg = withIndefiniteLibraryDeps [mn "Top"] [midSigPn] + $ testPackage topSigPn Simple + implPkg = withExposingLibrary [mn "Base", mn "Mid", mn "Top"] + $ testPackage implPn Simple + consumerPkg = withDeps [baseSigPn, midSigPn, topSigPn, implPn] + $ withMixins [defaultMixin topSigPn] + $ withLibrary + $ testPackage consumerPn Simple + baseSigTask = mockTask baseSigPkg + midSigTask = mockTask midSigPkg + topSigTask = mockTask topSigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (baseSigPn, ADRToInstall baseSigTask) + , (midSigPn, ADRToInstall midSigTask) + , (topSigPn, ADRToInstall topSigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey baseSigPn CLib, ADRToInstall baseSigTask) + , (ComponentKey midSigPn CLib, ADRToInstall midSigTask) + , (ComponentKey topSigPn CLib, ADRToInstall topSigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + topInstEntries = [ t.backpackInstEntries + | (ComponentKey pn (CInst _), ADRToInstall t) + <- result + , pn == topSigPn + ] + length topInstEntries `shouldBe` 1 + case topInstEntries of + [entries] -> do + let sigNames = map (\(s, _, _) -> s) entries + length sigNames `shouldBe` 3 + sigNames `shouldSatisfy` (mn "Top" `elem`) + sigNames `shouldSatisfy` (mn "Mid" `elem`) + sigNames `shouldSatisfy` (mn "Base" `elem`) + _ -> error "expected exactly one CInst for top-sig" + warnings `shouldSatisfy` null + + it "diamond deps: shared indefinite dep's sigs not duplicated" $ do + -- common-sig (indefinite, sig: Common) + -- a-sig (indefinite, sig: SigA, depends on common-sig) + -- b-sig (indefinite, sig: SigB, depends on common-sig) + -- top-sig (indefinite, sig: Top, depends on a-sig AND b-sig) + -- impl (concrete, exposes: Common, SigA, SigB, Top) + -- consumer (mixins: top-sig) + -- top-sig CInst must fill Top + SigA + SigB + Common (no duplicates) + let commonSigPn = mkPackageName "common-sig" + aSigPn = mkPackageName "a-sig" + bSigPn = mkPackageName "b-sig" + topSigPn = mkPackageName "top-sig" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + commonSigPkg = withIndefiniteLibrary [mn "Common"] + $ testPackage commonSigPn Simple + aSigPkg = withIndefiniteLibraryDeps [mn "SigA"] [commonSigPn] + $ testPackage aSigPn Simple + bSigPkg = withIndefiniteLibraryDeps [mn "SigB"] [commonSigPn] + $ testPackage bSigPn Simple + topSigPkg = withIndefiniteLibraryDeps [mn "Top"] [aSigPn, bSigPn] + $ testPackage topSigPn Simple + implPkg = withExposingLibrary [mn "Common", mn "SigA", mn "SigB", mn "Top"] + $ testPackage implPn Simple + consumerPkg = withDeps [commonSigPn, aSigPn, bSigPn, topSigPn, implPn] + $ withMixins [defaultMixin topSigPn] + $ withLibrary + $ testPackage consumerPn Simple + commonSigTask = mockTask commonSigPkg + aSigTask = mockTask aSigPkg + bSigTask = mockTask bSigPkg + topSigTask = mockTask topSigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (commonSigPn, ADRToInstall commonSigTask) + , (aSigPn, ADRToInstall aSigTask) + , (bSigPn, ADRToInstall bSigTask) + , (topSigPn, ADRToInstall topSigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey commonSigPn CLib, ADRToInstall commonSigTask) + , (ComponentKey aSigPn CLib, ADRToInstall aSigTask) + , (ComponentKey bSigPn CLib, ADRToInstall bSigTask) + , (ComponentKey topSigPn CLib, ADRToInstall topSigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + topInstEntries = [ t.backpackInstEntries + | (ComponentKey pn (CInst _), ADRToInstall t) + <- result + , pn == topSigPn + ] + length topInstEntries `shouldBe` 1 + case topInstEntries of + [entries] -> do + let sigNames = map (\(s, _, _) -> s) entries + -- Exactly 4 unique sigs: Top (own) + SigA + SigB + Common (inherited) + -- Common should NOT appear twice despite diamond. + length sigNames `shouldBe` 4 + sigNames `shouldSatisfy` (mn "Top" `elem`) + sigNames `shouldSatisfy` (mn "SigA" `elem`) + sigNames `shouldSatisfy` (mn "SigB" `elem`) + sigNames `shouldSatisfy` (mn "Common" `elem`) + _ -> error "expected exactly one CInst for top-sig" + warnings `shouldSatisfy` null + + it "inherited sig not resolvable produces warning" $ do + -- str-sig (indefinite, sig: Str) + -- logger-sig (indefinite, sig: Logger, depends on str-sig) + -- impl-pkg only exposes Logger, NOT Str + -- consumer (mixins: logger-sig) + -- The inherited Str cannot be resolved → warning + let strSigPn = mkPackageName "str-sig" + loggerSigPn = mkPackageName "logger-sig" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + strSigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage strSigPn Simple + loggerSigPkg = withIndefiniteLibraryDeps [mn "Logger"] [strSigPn] + $ testPackage loggerSigPn Simple + -- impl-pkg only has Logger, NOT Str + implPkg = withExposingLibrary [mn "Logger"] + $ testPackage implPn Simple + consumerPkg = withDeps [strSigPn, loggerSigPn, implPn] + $ withMixins [defaultMixin loggerSigPn] + $ withLibrary + $ testPackage consumerPn Simple + strSigTask = mockTask strSigPkg + loggerSigTask = mockTask loggerSigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (strSigPn, ADRToInstall strSigTask) + , (loggerSigPn, ADRToInstall loggerSigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey strSigPn CLib, ADRToInstall strSigTask) + , (ComponentKey loggerSigPn CLib, ADRToInstall loggerSigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instEntries = [ t.backpackInstEntries + | (ComponentKey pn (CInst _), ADRToInstall t) + <- result + , pn == loggerSigPn + ] + -- CInst still created (for the Logger sig that resolves) + length instEntries `shouldBe` 1 + case instEntries of + [entries] -> do + let sigNames = map (\(s, _, _) -> s) entries + -- Only Logger resolved; Str could not be found + sigNames `shouldBe` [mn "Logger"] + _ -> error "expected exactly one CInst" + -- Warning for unresolvable inherited sig + length warnings `shouldBe` 1 + + it "two consumers with different impls produce two CInst tasks" $ do + -- sig-pkg (indefinite, sig: Str) + -- impl-a (concrete, exposes: Str) + -- impl-b (concrete, exposes: Str) + -- consumer-a (mixins: sig-pkg, depends on impl-a) + -- consumer-b (mixins: sig-pkg, depends on impl-b) + -- Should produce TWO CInst tasks for sig-pkg with different hashes. + let sigPn = mkPackageName "sig-pkg" + implAPn = mkPackageName "impl-a" + implBPn = mkPackageName "impl-b" + consumerAPn = mkPackageName "consumer-a" + consumerBPn = mkPackageName "consumer-b" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implAPkg = withExposingLibrary [mn "Str"] + $ testPackage implAPn Simple + implBPkg = withExposingLibrary [mn "Str"] + $ testPackage implBPn Simple + consumerAPkg = withDeps [sigPn, implAPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerAPn Simple + consumerBPkg = withDeps [sigPn, implBPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerBPn Simple + sigTask = mockTask sigPkg + implATask = mockTask implAPkg + implBTask = mockTask implBPkg + consumerATask = mockTask consumerAPkg + consumerBTask = mockTask consumerBPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implAPn, ADRToInstall implATask) + , (implBPn, ADRToInstall implBTask) + , (consumerAPn, ADRToInstall consumerATask) + , (consumerBPn, ADRToInstall consumerBTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implAPn CLib, ADRToInstall implATask) + , (ComponentKey implBPn CLib, ADRToInstall implBTask) + , (ComponentKey consumerAPn CLib, ADRToInstall consumerATask) + , (ComponentKey consumerBPn CLib, ADRToInstall consumerBTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey pn (CInst _)), _) <- result + , pn == sigPn + ] + -- Two different CInst tasks for sig-pkg (different impl hashes) + length instKeys `shouldBe` 2 + warnings `shouldSatisfy` null + + it "two consumers with same impl produce one CInst task (dedup)" $ do + -- sig-pkg (indefinite, sig: Str) + -- impl-pkg (concrete, exposes: Str) + -- consumer-a (mixins: sig-pkg, depends on impl-pkg) + -- consumer-b (mixins: sig-pkg, depends on impl-pkg) + -- Both consumers use the same impl → same hash → ONE CInst task. + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerAPn = mkPackageName "consumer-a" + consumerBPn = mkPackageName "consumer-b" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerAPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerAPn Simple + consumerBPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerBPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerATask = mockTask consumerAPkg + consumerBTask = mockTask consumerBPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerAPn, ADRToInstall consumerATask) + , (consumerBPn, ADRToInstall consumerBTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerAPn CLib, ADRToInstall consumerATask) + , (ComponentKey consumerBPn CLib, ADRToInstall consumerBTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey pn (CInst _)), _) <- result + , pn == sigPn + ] + -- Same impl → same hash → deduplicated to one CInst task + length instKeys `shouldBe` 1 + warnings `shouldSatisfy` null + + it "impl out of consumer scope is not used for resolution" $ do + -- sig-pkg (indefinite, sig: Str) + -- impl-pkg (concrete, exposes: Str) — exists in plan + -- consumer (mixins: sig-pkg, depends on sig-pkg only, NOT impl-pkg) + -- impl-pkg is out of consumer's build-depends scope → no resolution → warning + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey pn (CInst _)), _) <- result + , pn == sigPn + ] + -- impl-pkg not in consumer's build-depends → can't resolve → no CInst + length instKeys `shouldBe` 0 + length warnings `shouldBe` 1 + + it "three consumers: two same impl, one different → two CInsts" $ do + -- sig-pkg (indefinite, sig: Str) + -- impl-a, impl-b (concrete, expose: Str) + -- consumer-1 depends on impl-a, consumer-2 depends on impl-a, + -- consumer-3 depends on impl-b + -- → two CInst tasks (impl-a deduped, impl-b separate) + let sigPn = mkPackageName "sig-pkg" + implAPn = mkPackageName "impl-a" + implBPn = mkPackageName "impl-b" + c1Pn = mkPackageName "consumer-1" + c2Pn = mkPackageName "consumer-2" + c3Pn = mkPackageName "consumer-3" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implAPkg = withExposingLibrary [mn "Str"] + $ testPackage implAPn Simple + implBPkg = withExposingLibrary [mn "Str"] + $ testPackage implBPn Simple + c1Pkg = withDeps [sigPn, implAPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage c1Pn Simple + c2Pkg = withDeps [sigPn, implAPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage c2Pn Simple + c3Pkg = withDeps [sigPn, implBPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage c3Pn Simple + sigTask = mockTask sigPkg + implATask = mockTask implAPkg + implBTask = mockTask implBPkg + c1Task = mockTask c1Pkg + c2Task = mockTask c2Pkg + c3Task = mockTask c3Pkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implAPn, ADRToInstall implATask) + , (implBPn, ADRToInstall implBTask) + , (c1Pn, ADRToInstall c1Task) + , (c2Pn, ADRToInstall c2Task) + , (c3Pn, ADRToInstall c3Task) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implAPn CLib, ADRToInstall implATask) + , (ComponentKey implBPn CLib, ADRToInstall implBTask) + , (ComponentKey c1Pn CLib, ADRToInstall c1Task) + , (ComponentKey c2Pn CLib, ADRToInstall c2Task) + , (ComponentKey c3Pn CLib, ADRToInstall c3Task) + ] + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey pn (CInst _)), _) <- result + , pn == sigPn + ] + -- impl-a used twice (deduped) + impl-b once = 2 CInst tasks + length instKeys `shouldBe` 2 + warnings `shouldSatisfy` null + + it "ADRFound impl resolved via installedModules map" $ do + -- sig-pkg is ADRToInstall (indefinite), impl-pkg is ADRFound + -- (already installed). The installed modules map should allow + -- module resolution for the ADRFound impl. + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + consumerTask = mockTask consumerPkg + implPid = PackageIdentifier implPn (mkVersion [1, 0]) + implGid = unsafeParseGhcPkgId "impl-pkg-1.0-abc" + implFound = ADRFound Snap (Library implPid + (installedLibraryInfoFromGhcPkgId implGid)) + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, implFound) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, implFound) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + -- Provide the impl's modules via the installed modules map + instMods = Map.singleton implPn (Set.singleton (mn "Str")) + (result, warnings) = addInstantiationTasks instMods origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey pn (CInst _)), _) <- result + , pn == sigPn + ] + -- CInst task should be created using the installed modules map + length instKeys `shouldBe` 1 + warnings `shouldSatisfy` null + -- Verify the impl's GhcPkgId is in the CInst task's present map + let instPresent = [ t.present + | (ComponentKey pn (CInst _), ADRToInstall t) <- result + , pn == sigPn + ] + case instPresent of + [pm] -> Map.lookup implPid pm `shouldBe` Just implGid + _ -> expectationFailure "Expected exactly one CInst task" + + it "ADRFound impl not in installedModules produces warning" $ do + -- impl-pkg is ADRFound but the installedModules map is empty, + -- so module resolution fails and a warning is produced. + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + consumerTask = mockTask consumerPkg + implPid = PackageIdentifier implPn (mkVersion [1, 0]) + implGid = unsafeParseGhcPkgId "impl-pkg-1.0-abc" + implFound = ADRFound Snap (Library implPid + (installedLibraryInfoFromGhcPkgId implGid)) + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, implFound) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, implFound) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + -- Empty installed modules map — impl can't be resolved + (result, warnings) = addInstantiationTasks Map.empty origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + instKeys `shouldBe` [] + length warnings `shouldBe` 1 + + it "ADRFound impl not in consumer scope is ignored" $ do + -- impl-pkg is ADRFound and in installedModules, but the consumer + -- doesn't list it in build-depends, so it's out of scope. + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + -- Consumer depends on sig-pkg only, NOT impl-pkg + consumerPkg = withDeps [sigPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + consumerTask = mockTask consumerPkg + implPid = PackageIdentifier implPn (mkVersion [1, 0]) + implGid = unsafeParseGhcPkgId "impl-pkg-1.0-abc" + implFound = ADRFound Snap (Library implPid + (installedLibraryInfoFromGhcPkgId implGid)) + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, implFound) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, implFound) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + instMods = Map.singleton implPn (Set.singleton (mn "Str")) + (result, warnings) = addInstantiationTasks instMods origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + instKeys `shouldBe` [] + length warnings `shouldBe` 1 + + it "ADRFound + ADRToInstall both exposing module is ambiguous" $ do + -- Two packages expose the same module: one ADRToInstall, one ADRFound. + -- This should produce an ambiguity warning. + let sigPn = mkPackageName "sig-pkg" + impl1Pn = mkPackageName "impl1" + impl2Pn = mkPackageName "impl2" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + impl1Pkg = withExposingLibrary [mn "Str"] + $ testPackage impl1Pn Simple + consumerPkg = withDeps [sigPn, impl1Pn, impl2Pn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + impl1Task = mockTask impl1Pkg + consumerTask = mockTask consumerPkg + impl2Pid = PackageIdentifier impl2Pn (mkVersion [1, 0]) + impl2Gid = unsafeParseGhcPkgId "impl2-1.0-abc" + impl2Found = ADRFound Snap (Library impl2Pid + (installedLibraryInfoFromGhcPkgId impl2Gid)) + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (impl1Pn, ADRToInstall impl1Task) + , (impl2Pn, impl2Found) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey impl1Pn CLib, ADRToInstall impl1Task) + , (ComponentKey impl2Pn CLib, impl2Found) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + -- impl2 also exposes Str via installedModules + instMods = Map.singleton impl2Pn (Set.singleton (mn "Str")) + (result, warnings) = addInstantiationTasks instMods origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + -- Ambiguous → no CInst, warning produced + instKeys `shouldBe` [] + length warnings `shouldBe` 1 + + it "two ADRFound impls exposing same module is ambiguous" $ do + let sigPn = mkPackageName "sig-pkg" + impl1Pn = mkPackageName "impl1" + impl2Pn = mkPackageName "impl2" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + consumerPkg = withDeps [sigPn, impl1Pn, impl2Pn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + consumerTask = mockTask consumerPkg + impl1Pid = PackageIdentifier impl1Pn (mkVersion [1, 0]) + impl1Gid = unsafeParseGhcPkgId "impl1-1.0-aaa" + impl1Found = ADRFound Snap (Library impl1Pid + (installedLibraryInfoFromGhcPkgId impl1Gid)) + impl2Pid = PackageIdentifier impl2Pn (mkVersion [1, 0]) + impl2Gid = unsafeParseGhcPkgId "impl2-1.0-bbb" + impl2Found = ADRFound Snap (Library impl2Pid + (installedLibraryInfoFromGhcPkgId impl2Gid)) + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (impl1Pn, impl1Found) + , (impl2Pn, impl2Found) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey impl1Pn CLib, impl1Found) + , (ComponentKey impl2Pn CLib, impl2Found) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + instMods = Map.fromList + [ (impl1Pn, Set.singleton (mn "Str")) + , (impl2Pn, Set.singleton (mn "Str")) + ] + (result, warnings) = addInstantiationTasks instMods origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + instKeys `shouldBe` [] + length warnings `shouldBe` 1 + + it "ADRFound impl with wrong module in installedModules not matched" $ do + -- impl-pkg is ADRFound and in installedModules, but exposes "Other" + -- not "Str", so resolution fails. + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = mockTask sigPkg + consumerTask = mockTask consumerPkg + implPid = PackageIdentifier implPn (mkVersion [1, 0]) + implGid = unsafeParseGhcPkgId "impl-pkg-1.0-abc" + implFound = ADRFound Snap (Library implPid + (installedLibraryInfoFromGhcPkgId implGid)) + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, implFound) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, implFound) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + -- impl exposes "Other", not "Str" + instMods = Map.singleton implPn (Set.singleton (mn "Other")) + (result, warnings) = addInstantiationTasks instMods origAdrs expanded + instKeys = [ ck | (ck@(ComponentKey _ (CInst _)), _) <- result ] + instKeys `shouldBe` [] + length warnings `shouldBe` 1 + + it "CInst inherits buildHaddocks = True from sig task" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = (mockTask sigPkg) { buildHaddocks = True } + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, _) = addInstantiationTasks Map.empty origAdrs expanded + instHaddocks = [ t.buildHaddocks + | (ComponentKey pn (CInst _), ADRToInstall t) + <- result + , pn == sigPn + ] + instHaddocks `shouldBe` [True] + + it "CInst inherits buildHaddocks = False from sig task" $ do + let sigPn = mkPackageName "sig-pkg" + implPn = mkPackageName "impl-pkg" + consumerPn = mkPackageName "consumer" + sigPkg = withIndefiniteLibrary [mn "Str"] + $ testPackage sigPn Simple + implPkg = withExposingLibrary [mn "Str"] + $ testPackage implPn Simple + consumerPkg = withDeps [sigPn, implPn] + $ withMixins [defaultMixin sigPn] + $ withLibrary + $ testPackage consumerPn Simple + sigTask = (mockTask sigPkg) { buildHaddocks = False } + implTask = mockTask implPkg + consumerTask = mockTask consumerPkg + origAdrs = + [ (sigPn, ADRToInstall sigTask) + , (implPn, ADRToInstall implTask) + , (consumerPn, ADRToInstall consumerTask) + ] + expanded = + [ (ComponentKey sigPn CLib, ADRToInstall sigTask) + , (ComponentKey implPn CLib, ADRToInstall implTask) + , (ComponentKey consumerPn CLib, ADRToInstall consumerTask) + ] + (result, _) = addInstantiationTasks Map.empty origAdrs expanded + instHaddocks = [ t.buildHaddocks + | (ComponentKey pn (CInst _), ADRToInstall t) + <- result + , pn == sigPn + ] + instHaddocks `shouldBe` [False] + + describe "findGhcPkgId" $ do + it "finds matching GhcPkgId by package name" $ do + let implGid = unsafeParseGhcPkgId "impl-pkg-0.1.0.0-abc123" + depsMap = Map.fromList + [ (PackageIdentifier (mkPackageName "impl-pkg") (mkVersion [0,1,0,0]) + , implGid) + ] + findGhcPkgId depsMap (mkPackageName "impl-pkg") `shouldBe` Just implGid + + it "returns Nothing for missing package" $ do + let depsMap = Map.fromList + [ (PackageIdentifier (mkPackageName "other") (mkVersion [1,0]) + , unsafeParseGhcPkgId "other-1.0-xyz") + ] + findGhcPkgId depsMap (mkPackageName "impl-pkg") `shouldBe` Nothing + + it "returns first match when multiple versions exist" $ do + let gid1 = unsafeParseGhcPkgId "pkg-1.0-aaa" + gid2 = unsafeParseGhcPkgId "pkg-2.0-bbb" + depsMap = Map.fromList + [ (PackageIdentifier (mkPackageName "pkg") (mkVersion [1,0]), gid1) + , (PackageIdentifier (mkPackageName "pkg") (mkVersion [2,0]), gid2) + ] + -- Map.toList iterates in key order; (pkg-1.0) < (pkg-2.0) + findGhcPkgId depsMap (mkPackageName "pkg") `shouldBe` Just gid1 + + it "returns Nothing for empty deps map" $ do + findGhcPkgId Map.empty (mkPackageName "anything") `shouldBe` Nothing + + describe "mkInstantiateWithOpts" $ do + it "produces correct --instantiate-with flag" $ do + let implGid = unsafeParseGhcPkgId "impl-pkg-0.1.0.0-abc123" + depsMap = Map.fromList + [ (PackageIdentifier (mkPackageName "impl-pkg") (mkVersion [0,1,0,0]) + , implGid) + ] + entries = [(mn "Str", mkPackageName "impl-pkg", mn "Str")] + result = mkInstantiateWithOpts entries depsMap + result `shouldBe` + ["--instantiate-with=Str=impl-pkg-0.1.0.0-abc123:Str"] + + it "produces empty list when no entries" $ do + mkInstantiateWithOpts [] Map.empty `shouldBe` [] + + it "skips entry when implementing package not in deps map" $ do + let entries = [(mn "Str", mkPackageName "missing-pkg", mn "Str")] + depsMap = Map.fromList + [ (PackageIdentifier (mkPackageName "other") (mkVersion [1,0]) + , unsafeParseGhcPkgId "other-1.0-xyz") + ] + mkInstantiateWithOpts entries depsMap `shouldBe` [] + + it "handles multiple instantiation entries" $ do + let gid1 = unsafeParseGhcPkgId "impl-a-1.0-aaa" + gid2 = unsafeParseGhcPkgId "impl-b-1.0-bbb" + depsMap = Map.fromList + [ (PackageIdentifier (mkPackageName "impl-a") (mkVersion [1,0]), gid1) + , (PackageIdentifier (mkPackageName "impl-b") (mkVersion [1,0]), gid2) + ] + entries = + [ (mn "SigA", mkPackageName "impl-a", mn "ModA") + , (mn "SigB", mkPackageName "impl-b", mn "ModB") + ] + result = mkInstantiateWithOpts entries depsMap + length result `shouldBe` 2 + result `shouldBe` + [ "--instantiate-with=SigA=impl-a-1.0-aaa:ModA" + , "--instantiate-with=SigB=impl-b-1.0-bbb:ModB" + ] + + it "handles renamed module (sigName /= implModuleName)" $ do + let implGid = unsafeParseGhcPkgId "impl-pkg-1.0-abc" + depsMap = Map.fromList + [ (PackageIdentifier (mkPackageName "impl-pkg") (mkVersion [1,0]) + , implGid) + ] + entries = [(mn "Signature", mkPackageName "impl-pkg", mn "ConcreteImpl")] + result = mkInstantiateWithOpts entries depsMap + result `shouldBe` + ["--instantiate-with=Signature=impl-pkg-1.0-abc:ConcreteImpl"] + + it "handles hierarchical module names" $ do + let implGid = unsafeParseGhcPkgId "impl-pkg-1.0-abc" + depsMap = Map.fromList + [ (PackageIdentifier (mkPackageName "impl-pkg") (mkVersion [1,0]) + , implGid) + ] + entries = + [(mn "Data.Map.Sig", mkPackageName "impl-pkg", mn "Data.Map.Strict")] + result = mkInstantiateWithOpts entries depsMap + result `shouldBe` + ["--instantiate-with=Data.Map.Sig=impl-pkg-1.0-abc:Data.Map.Strict"] + + describe "ConfigCacheType persistence" $ do + it "round-trips ConfigCacheTypeConfig" $ do + let v = ConfigCacheTypeConfig + fromPersistValue (toPersistValue v) `shouldBe` Right v + + it "round-trips ConfigCacheTypeFlagLibrary" $ do + let gid = unsafeParseGhcPkgId "foo-1.0-abc123" + v = ConfigCacheTypeFlagLibrary gid + fromPersistValue (toPersistValue v) `shouldBe` Right v + + it "round-trips ConfigCacheTypeFlagExecutable" $ do + let pid = PackageIdentifier (mkPackageName "bar") (mkVersion [2,0]) + v = ConfigCacheTypeFlagExecutable pid + fromPersistValue (toPersistValue v) `shouldBe` Right v + + it "round-trips ConfigCacheTypeInstantiation" $ do + let v = ConfigCacheTypeInstantiation "941095d7fd7eb1e4" + fromPersistValue (toPersistValue v) `shouldBe` Right v + + it "round-trips ConfigCacheTypeInstantiation with empty suffix" $ do + let v = ConfigCacheTypeInstantiation "" + fromPersistValue (toPersistValue v) `shouldBe` Right v + + it "rejects unknown cache type" $ do + fromPersistValue (PersistText "unknown:foo") + `shouldSatisfy` \case + Left _ -> True + Right (_ :: ConfigCacheType) -> False + +-- | Parse a GhcPkgId from text, throwing an error on failure. +unsafeParseGhcPkgId :: Text -> GhcPkgId +unsafeParseGhcPkgId t = case parseGhcPkgId t of + Just gid -> gid + Nothing -> error $ "unsafeParseGhcPkgId: invalid GhcPkgId: " ++ show t + +-- | Helper: compute the list of buildable components for a package (same +-- logic as expandToComponentKeys). +packageBuildableComponents :: Package -> [NamedComponent] +packageBuildableComponents pkg = + let libComps = [CLib | isJust pkg.library && buildableLib] + subLibComps = + map CSubLib $ Set.toList $ getBuildableSet pkg.subLibraries + flibComps = + map CFlib $ Set.toList $ getBuildableSet pkg.foreignLibraries + exeComps = + map CExe $ Set.toList $ getBuildableSet pkg.executables + in libComps ++ subLibComps ++ flibComps ++ exeComps + where + buildableLib = case pkg.library of + Just lib -> lib.buildInfo.buildable + Nothing -> False + +-- | Helper: simulate component key expansion for build tasks. +packageToComponentKeys :: PackageName -> Package -> [ComponentKey] +packageToComponentKeys pn pkg + | shouldSplitComponents pkg = + case packageBuildableComponents pkg of + [] -> [ComponentKey pn CLib] + comps -> map (ComponentKey pn) comps + | otherwise = [ComponentKey pn CLib] + +-- | Helper: simulate final key expansion (mirrors addFinal logic). +packageToFinalKeys :: + PackageName -> Package -> Set NamedComponent -> [ComponentKey] +packageToFinalKeys pn pkg components + | shouldSplitComponents pkg = + let testComps = filter isCTest $ Set.toList components + benchComps = filter isCBench $ Set.toList components + in case testComps ++ benchComps of + [] -> [ComponentKey pn CLib] + comps -> map (ComponentKey pn) comps + | otherwise = [ComponentKey pn CLib] + where + isCTest (CTest _) = True + isCTest _ = False + isCBench (CBench _) = True + isCBench _ = False + +-- | Build a mock Task wrapping a Package. Uses 'error' for TaskConfigOpts +-- fields that addInstantiationTasks never accesses (envConfig, baseConfigOpts, +-- pkgConfigOpts). +mockTask :: Package -> Task +mockTask pkg = Task + { taskType = TTRemotePackage Immutable pkg + (error "mockTask: PackageLocationImmutable not needed") + , configOpts = TaskConfigOpts + { missing = Set.empty + , envConfig = error "mockTask: envConfig not needed" + , baseConfigOpts = error "mockTask: baseConfigOpts not needed" + , isLocalNonExtraDep = False + , isMutable = Immutable + , pkgConfigOpts = error "mockTask: pkgConfigOpts not needed" + , instantiationDeps = [] + } + , buildHaddocks = False + , present = Map.empty + , cachePkgSrc = CacheSrcUpstream + , buildTypeConfig = False + , backpackInstEntries = [] + } + +-- | Add a library with exposed modules (for testing module resolution). +withExposingLibrary :: [ModuleName] -> Package -> Package +withExposingLibrary mods pkg = pkg + { library = Just StackLibrary + { name = emptyCompName + , buildInfo = testBuildInfo + , exposedModules = mods + , signatures = [] + } + } + +-- | Add mixins to a package's main library buildInfo. +withMixins :: [Mixin] -> Package -> Package +withMixins ms pkg = case pkg.library of + Just (StackLibrary n bi em sigs) -> pkg + { library = Just (StackLibrary n bi { mixins = ms } em sigs) + } + Nothing -> pkg + +-- | Helper: create a simple mixin with default renaming. +defaultMixin :: PackageName -> Mixin +defaultMixin pn = Mixin + { mixinPackageName = pn + , mixinLibraryName = LMainLibName + , mixinIncludeRenaming = defaultIncludeRenaming + } + +-- | Helper: create a mixin with explicit requires renaming. +explicitRequiresMixin :: + PackageName + -> [(ModuleName, ModuleName)] + -> Mixin +explicitRequiresMixin pn reqs = Mixin + { mixinPackageName = pn + , mixinLibraryName = LMainLibName + , mixinIncludeRenaming = IncludeRenaming + { includeProvidesRn = DefaultRenaming + , includeRequiresRn = ModuleRenaming reqs + } + } + +-- | Add a sub-library with specific exposed modules. +withExposingSubLib :: String -> [ModuleName] -> Package -> Package +withExposingSubLib name mods pkg = pkg + { subLibraries = foldAndMakeCollection id $ + StackLibrary + { name = unqualCompFromString name + , buildInfo = testBuildInfo + , exposedModules = mods + , signatures = [] + } + : toList pkg.subLibraries + } + +-- | Add mixins to a specific sub-library's buildInfo. +withSubLibMixins :: String -> [Mixin] -> Package -> Package +withSubLibMixins subLibName ms pkg = pkg + { subLibraries = foldAndMakeCollection id + [ if lib.name == unqualCompFromString subLibName + then let bi = lib.buildInfo :: StackBuildInfo + in StackLibrary lib.name (bi { mixins = ms }) + lib.exposedModules lib.signatures + else lib + | lib <- toList pkg.subLibraries + ] + } + +-- | Create an indefinite library package that depends on other packages. +-- Used to test transitive Backpack chains where one indefinite package +-- depends on another. +withIndefiniteLibraryDeps :: [ModuleName] -> [PackageName] -> Package -> Package +withIndefiniteLibraryDeps sigs depPkgs pkg = pkg + { library = Just StackLibrary + { name = emptyCompName + , buildInfo = testBuildInfo + { dependency = Map.fromList + [ (pn, DepValue + { versionRange = anyVersion + , depType = AsLibrary DepLibrary + { main = True, subLib = Set.empty } + }) + | pn <- depPkgs + ] + } + , exposedModules = [] + , signatures = sigs + } + } + +-- | Add build-depends on the given packages to a package's main library. +-- This is needed so that module resolution is scoped to the consumer's deps. +withDeps :: [PackageName] -> Package -> Package +withDeps depPkgs pkg = case pkg.library of + Just (StackLibrary n bi em sigs) -> + let newDeps = Map.fromList + [ (pn, DepValue + { versionRange = anyVersion + , depType = AsLibrary DepLibrary + { main = True, subLib = Set.empty } + }) + | pn <- depPkgs + ] + bi' = bi { dependency = Map.union bi.dependency newDeps } + in pkg { library = Just (StackLibrary n bi' em sigs) } + Nothing -> pkg + +-- | Convenience: make a ModuleName from a String. +mn :: String -> ModuleName +mn = Cabal.fromString diff --git a/tests/unit/Stack/Build/ExecuteSpec.hs b/tests/unit/Stack/Build/ExecuteSpec.hs index 7b6a53b1c2..5bfa5c5bdf 100644 --- a/tests/unit/Stack/Build/ExecuteSpec.hs +++ b/tests/unit/Stack/Build/ExecuteSpec.hs @@ -1,15 +1,545 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module Stack.Build.ExecuteSpec ( main , spec ) where -import Stack.Prelude -import Test.Hspec +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Distribution.Types.PackageName ( mkPackageName ) +import Distribution.Types.Version ( mkVersion ) +import Control.Concurrent.Execute + ( ActionId (..), ActionType (..) ) +import Stack.Build.Execute + ( finalTestsAndBenches, intraPackageDeps, missingToDeps ) +import Stack.Build.ExecutePackage + ( componentEnableBenchmarks, componentEnableTests + , componentTarget + ) +import Stack.Prelude +import Stack.Types.ComponentUtils ( unqualCompFromString ) +import Stack.Types.NamedComponent ( NamedComponent (..) ) +import Stack.Types.Plan ( ComponentKey (..), componentKeyPkgName ) +import Test.Hspec ( Spec, describe, hspec, it, shouldBe, shouldSatisfy ) main :: IO () main = hspec spec spec :: Spec -spec = pure () +spec = do + describe "ActionId" $ do + it "uses ComponentKey instead of PackageIdentifier" $ do + let ck = ComponentKey (mkPackageName "my-pkg") CLib + aid = ActionId ck ATBuild + aid `shouldBe` ActionId ck ATBuild + + it "ActionIds with different ComponentKeys are not equal" $ do + let ck1 = ComponentKey (mkPackageName "pkg") CLib + ck2 = ComponentKey (mkPackageName "pkg") + (CTest (unqualCompFromString "test-suite")) + aid1 = ActionId ck1 ATBuild + aid2 = ActionId ck2 ATBuild + (aid1 == aid2) `shouldBe` False + + it "ActionIds with different ActionTypes are not equal" $ do + let ck = ComponentKey (mkPackageName "pkg") CLib + aid1 = ActionId ck ATBuild + aid2 = ActionId ck ATRunTests + (aid1 == aid2) `shouldBe` False + + it "can be used in Sets (dependency tracking)" $ do + let ckLib = ComponentKey (mkPackageName "dep") CLib + ckTest = ComponentKey (mkPackageName "pkg") + (CTest (unqualCompFromString "tests")) + deps = Set.fromList + [ ActionId ckLib ATBuild + , ActionId ckTest ATBuild + , ActionId ckTest ATRunTests + ] + Set.size deps `shouldBe` 3 + + it "dependency from test ATRunTests to test ATBuild works" $ do + let ck = ComponentKey (mkPackageName "pkg") + (CTest (unqualCompFromString "tests")) + buildAction = ActionId ck ATBuild + runAction = ActionId ck ATRunTests + deps = Set.singleton buildAction + Set.member buildAction deps `shouldBe` True + Set.member runAction deps `shouldBe` False + + it "dependency from component to CLib ATBuild maps correctly" $ do + let pkgName = mkPackageName "base-dep" + depKey = ComponentKey pkgName CLib + depAction = ActionId depKey ATBuild + testKey = ComponentKey (mkPackageName "my-pkg") + (CTest (unqualCompFromString "tests")) + testBuild = ActionId testKey ATBuild + deps = Set.fromList [depAction, testBuild] + Set.member depAction deps `shouldBe` True + + describe "ActionType" $ do + it "ATBuildFinal no longer exists (3 constructors only)" $ do + let types = [ATBuild, ATRunTests, ATRunBenchmarks] + length types `shouldBe` 3 + + it "ATBuild < ATRunTests < ATRunBenchmarks (Ord)" $ do + (ATBuild < ATRunTests) `shouldBe` True + (ATRunTests < ATRunBenchmarks) `shouldBe` True + + describe "missingToDeps" $ do + it "maps empty set to empty set" $ do + missingToDeps Set.empty `shouldBe` Set.empty + + it "maps a single PackageIdentifier to ComponentKey CLib ATBuild" $ do + let pid = PackageIdentifier (mkPackageName "base") (mkVersion [4,20,0,0]) + result = missingToDeps (Set.singleton pid) + expected = Set.singleton $ + ActionId (ComponentKey (mkPackageName "base") CLib) ATBuild + result `shouldBe` expected + + it "maps multiple dependencies preserving each package name" $ do + let pid1 = PackageIdentifier (mkPackageName "text") (mkVersion [2,0]) + pid2 = PackageIdentifier (mkPackageName "bytestring") (mkVersion [0,12]) + pid3 = PackageIdentifier (mkPackageName "containers") (mkVersion [0,7]) + result = missingToDeps (Set.fromList [pid1, pid2, pid3]) + Set.size result `shouldBe` 3 + -- All mapped to CLib + result `shouldSatisfy` all + (\(ActionId (ComponentKey _ comp) at) -> comp == CLib && at == ATBuild) + + it "discards version info — only package name matters" $ do + -- Two different versions of the same package should map to the same + -- ActionId (since ComponentKey uses PackageName, not PackageIdentifier) + let pid1 = PackageIdentifier (mkPackageName "aeson") (mkVersion [2,1]) + pid2 = PackageIdentifier (mkPackageName "aeson") (mkVersion [2,2]) + result = missingToDeps (Set.fromList [pid1, pid2]) + -- Set deduplicates: both map to the same ActionId + Set.size result `shouldBe` 1 + + it "preserves the invariant that external deps are always CLib" $ do + let pids = Set.fromList + [ PackageIdentifier (mkPackageName "foo") (mkVersion [1,0]) + , PackageIdentifier (mkPackageName "bar") (mkVersion [2,0]) + ] + result = missingToDeps pids + -- Every resulting ActionId should have CLib component and ATBuild type + forM_ (Set.toList result) $ \(ActionId (ComponentKey _ comp) at) -> do + comp `shouldBe` CLib + at `shouldBe` ATBuild + + describe "action graph invariants" $ do + it "build-only key produces exactly one ATBuild" $ do + -- Simulating toActions (Just build, Nothing): should produce [ATBuild] + let ck = ComponentKey (mkPackageName "pkg") CLib + buildId = ActionId ck ATBuild + -- In toActions, abuild produces one Action with this id + actionIds = [buildId] + length actionIds `shouldBe` 1 + actionIds `shouldBe` [ActionId ck ATBuild] + + it "final-only key produces ATBuild + run actions" $ do + -- Simulating toActions (Nothing, Just final) with tests: + -- Should produce ATBuild (for final) + ATRunTests + let ck = ComponentKey (mkPackageName "pkg") CLib + buildId = ActionId ck ATBuild + runId = ActionId ck ATRunTests + actionIds = [buildId, runId] + -- ATRunTests depends on ATBuild + runDeps = Set.singleton buildId + length actionIds `shouldBe` 2 + Set.member buildId runDeps `shouldBe` True + + it "build+final key produces one ATBuild (no duplicate)" $ do + -- Simulating toActions (Just build, Just final): + -- abuild produces ATBuild, afinal must NOT produce another ATBuild + -- afinal.finalBuild is [] when mbuild is Just + let ck = ComponentKey (mkPackageName "pkg") CLib + -- From abuild + abuildIds = [ActionId ck ATBuild] + -- From afinal.finalBuild when mbuild is Just: empty + afinalBuildIds = [] :: [ActionId] + -- From afinal.finalRun + afinalRunIds = [ActionId ck ATRunTests] + allIds = abuildIds ++ afinalBuildIds ++ afinalRunIds + -- No duplicate ATBuild + let buildCount = length $ filter + (\(ActionId _ at) -> at == ATBuild) allIds + buildCount `shouldBe` 1 + -- Total: 1 ATBuild + 1 ATRunTests + length allIds `shouldBe` 2 + + it "run actions always depend on ATBuild for same ComponentKey" $ do + let ck = ComponentKey (mkPackageName "pkg") + (CTest (unqualCompFromString "tests")) + buildDep = Set.singleton (ActionId ck ATBuild) + -- ATRunTests and ATRunBenchmarks should both depend on ATBuild + runTestsDeps = buildDep + runBenchDeps = buildDep + Set.member (ActionId ck ATBuild) runTestsDeps `shouldBe` True + Set.member (ActionId ck ATBuild) runBenchDeps `shouldBe` True + + describe "per-package derivation from ComponentKey map" $ do + it "single CLib key maps to one package entry" $ do + let ck = ComponentKey (mkPackageName "pkg") CLib + componentMap = Map.singleton ck ("task-value" :: String) + pkgMap = Map.fromList + [ (componentKeyPkgName k, v) | (k, v) <- Map.toList componentMap ] + Map.size pkgMap `shouldBe` 1 + Map.lookup (mkPackageName "pkg") pkgMap `shouldBe` Just "task-value" + + it "multiple components for same package collapse to one entry" $ do + let pn = mkPackageName "pkg" + ck1 = ComponentKey pn CLib + ck2 = ComponentKey pn (CExe (unqualCompFromString "exe")) + ck3 = ComponentKey pn (CTest (unqualCompFromString "test")) + componentMap :: Map ComponentKey String + componentMap = Map.fromList + [(ck1, "lib-task"), (ck2, "exe-task"), (ck3, "test-task")] + -- Map.fromList with last-wins gives us the last component + pkgMap = Map.fromList + [ (componentKeyPkgName k, v) + | (k, v) <- Map.toList componentMap + ] + -- All three map to the same PackageName, so only one entry + Map.size pkgMap `shouldBe` 1 + -- Map.toList on componentMap is ascending by key; + -- CLib < CExe < CTest, so CTest's value wins + Map.lookup pn pkgMap `shouldBe` Just "test-task" + + it "different packages stay separate after derivation" $ do + let ck1 = ComponentKey (mkPackageName "pkg-a") CLib + ck2 = ComponentKey (mkPackageName "pkg-a") + (CExe (unqualCompFromString "exe")) + ck3 = ComponentKey (mkPackageName "pkg-b") CLib + componentMap :: Map ComponentKey String + componentMap = Map.fromList + [(ck1, "a-lib"), (ck2, "a-exe"), (ck3, "b-lib")] + pkgMap = Map.fromList + [ (componentKeyPkgName k, v) + | (k, v) <- Map.toList componentMap + ] + Map.size pkgMap `shouldBe` 2 + Map.member (mkPackageName "pkg-a") pkgMap `shouldBe` True + Map.member (mkPackageName "pkg-b") pkgMap `shouldBe` True + + it "preserves all package names when components are distinct packages" $ do + let keys = + [ ComponentKey (mkPackageName "aeson") CLib + , ComponentKey (mkPackageName "text") CLib + , ComponentKey (mkPackageName "bytestring") CLib + ] + componentMap :: Map ComponentKey Int + componentMap = Map.fromList $ zip keys [1..] + pkgNames = Set.fromList $ map componentKeyPkgName $ Map.keys componentMap + Set.size pkgNames `shouldBe` 3 + + describe "consumer dedup patterns" $ do + -- These test the deduplication patterns used by justLocals, + -- errorOnSnapshot, and warnIfExecutablesWithSameNameCouldBeOverwritten + -- when operating on component-keyed maps. + + it "justLocals pattern: Set deduplicates split-package identifiers" $ do + -- Simulates justLocals: multiple component tasks for the same package + -- produce the same PackageIdentifier; Set.fromList removes duplicates. + let pid = PackageIdentifier (mkPackageName "pkg") (mkVersion [1,0]) + taskPids = [pid, pid, pid] + result = Set.toList $ Set.fromList taskPids + result `shouldBe` [pid] + + it "justLocals pattern: different packages remain distinct" $ do + let pid1 = PackageIdentifier (mkPackageName "pkg-a") (mkVersion [1,0]) + pid2 = PackageIdentifier (mkPackageName "pkg-b") (mkVersion [2,0]) + taskPids = [pid1, pid1, pid2, pid2] + result = Set.toList $ Set.fromList taskPids + length result `shouldBe` 2 + result `shouldSatisfy` (pid1 `elem`) + result `shouldSatisfy` (pid2 `elem`) + + it "errorOnSnapshot pattern: PackageNames are deduplicated" $ do + -- Simulates errorOnSnapshot: extracting PackageNames from ComponentKeys + -- and deduplicating. + let pn = mkPackageName "pkg" + keys = + [ ComponentKey pn CLib + , ComponentKey pn (CExe (unqualCompFromString "exe")) + , ComponentKey pn (CSubLib (unqualCompFromString "sub")) + ] + result = Set.toList $ Set.fromList $ map componentKeyPkgName keys + result `shouldBe` [pn] + + it "errorOnSnapshot pattern: distinct packages stay separate" $ do + let keys = + [ ComponentKey (mkPackageName "a") CLib + , ComponentKey (mkPackageName "a") + (CExe (unqualCompFromString "exe")) + , ComponentKey (mkPackageName "b") CLib + ] + result = Set.toList $ Set.fromList $ map componentKeyPkgName keys + length result `shouldBe` 2 + + it "perPkgTasks pattern: split components yield one entry per package" $ do + -- Simulates perPkgTasks in warnIfExecutablesWithSameNameCouldBeOverwritten + let pn = mkPackageName "pkg" + componentMap :: Map ComponentKey String + componentMap = Map.fromList + [ (ComponentKey pn CLib, "task") + , (ComponentKey pn (CExe (unqualCompFromString "exe1")), "task") + , (ComponentKey pn (CExe (unqualCompFromString "exe2")), "task") + ] + perPkg = Map.fromList + [ (componentKeyPkgName ck, v) + | (ck, v) <- Map.toList componentMap + ] + Map.size perPkg `shouldBe` 1 + + it "perPkgTasks pattern: mixed packages yield correct count" $ do + let componentMap :: Map ComponentKey String + componentMap = Map.fromList + [ (ComponentKey (mkPackageName "a") CLib, "a-task") + , (ComponentKey (mkPackageName "a") + (CExe (unqualCompFromString "exe")), "a-task") + , (ComponentKey (mkPackageName "b") CLib, "b-task") + , (ComponentKey (mkPackageName "b") + (CExe (unqualCompFromString "app")), "b-task") + ] + perPkg = Map.fromList + [ (componentKeyPkgName ck, v) + | (ck, v) <- Map.toList componentMap + ] + Map.size perPkg `shouldBe` 2 + Map.member (mkPackageName "a") perPkg `shouldBe` True + Map.member (mkPackageName "b") perPkg `shouldBe` True + + describe "intraPackageDeps" $ do + it "CLib has no intra-package deps" $ do + let ck = ComponentKey (mkPackageName "pkg") CLib + taskKeys = Set.singleton ck + intraPackageDeps taskKeys ck `shouldBe` Set.empty + + it "CExe depends on CLib ATBuild when CLib is in taskKeys" $ do + let pn = mkPackageName "pkg" + libKey = ComponentKey pn CLib + exeKey = ComponentKey pn (CExe (unqualCompFromString "my-exe")) + taskKeys = Set.fromList [libKey, exeKey] + result = intraPackageDeps taskKeys exeKey + result `shouldBe` + Set.singleton (ActionId libKey ATBuild) + + it "CExe has no intra-package dep when CLib is not in taskKeys" $ do + let pn = mkPackageName "pkg" + exeKey = ComponentKey pn (CExe (unqualCompFromString "my-exe")) + taskKeys = Set.singleton exeKey + intraPackageDeps taskKeys exeKey `shouldBe` Set.empty + + it "CTest depends on CLib ATBuild when CLib is in taskKeys" $ do + let pn = mkPackageName "pkg" + libKey = ComponentKey pn CLib + testKey = ComponentKey pn (CTest (unqualCompFromString "tests")) + taskKeys = Set.singleton libKey + result = intraPackageDeps taskKeys testKey + result `shouldBe` + Set.singleton (ActionId libKey ATBuild) + + it "CBench depends on CLib ATBuild when CLib is in taskKeys" $ do + let pn = mkPackageName "pkg" + libKey = ComponentKey pn CLib + benchKey = ComponentKey pn (CBench (unqualCompFromString "bench")) + taskKeys = Set.singleton libKey + intraPackageDeps taskKeys benchKey `shouldBe` + Set.singleton (ActionId libKey ATBuild) + + it "CSubLib depends on CLib ATBuild when CLib is in taskKeys" $ do + let pn = mkPackageName "pkg" + libKey = ComponentKey pn CLib + subKey = ComponentKey pn (CSubLib (unqualCompFromString "internal")) + taskKeys = Set.singleton libKey + intraPackageDeps taskKeys subKey `shouldBe` + Set.singleton (ActionId libKey ATBuild) + + it "does not depend on CLib of a different package" $ do + let pn1 = mkPackageName "pkg-a" + pn2 = mkPackageName "pkg-b" + libKeyA = ComponentKey pn1 CLib + exeKeyB = ComponentKey pn2 (CExe (unqualCompFromString "exe")) + taskKeys = Set.fromList [libKeyA, exeKeyB] + -- exeKeyB should NOT depend on libKeyA (different package) + intraPackageDeps taskKeys exeKeyB `shouldBe` Set.empty + + it "CLib never has intra-package deps even when other libs exist" $ do + let pn = mkPackageName "pkg" + libKey = ComponentKey pn CLib + subKey = ComponentKey pn (CSubLib (unqualCompFromString "sub")) + taskKeys = Set.fromList [libKey, subKey] + intraPackageDeps taskKeys libKey `shouldBe` Set.empty + + describe "componentTarget" $ do + it "CLib renders as lib:" $ do + componentTarget (mkPackageName "my-pkg") CLib + `shouldBe` "lib:my-pkg" + + it "CSubLib renders as lib:" $ do + componentTarget (mkPackageName "pkg") (CSubLib (unqualCompFromString "internal")) + `shouldBe` "lib:internal" + + it "CFlib renders as flib:" $ do + componentTarget (mkPackageName "pkg") (CFlib (unqualCompFromString "cbits")) + `shouldBe` "flib:cbits" + + it "CExe renders as exe:" $ do + componentTarget (mkPackageName "pkg") (CExe (unqualCompFromString "my-exe")) + `shouldBe` "exe:my-exe" + + it "CTest renders as test:" $ do + componentTarget (mkPackageName "pkg") (CTest (unqualCompFromString "my-test")) + `shouldBe` "test:my-test" + + it "CBench renders as bench:" $ do + componentTarget (mkPackageName "pkg") (CBench (unqualCompFromString "my-bench")) + `shouldBe` "bench:my-bench" + + it "package name is only used for CLib" $ do + -- For non-CLib components, the package name is ignored + let pn1 = mkPackageName "pkg-a" + pn2 = mkPackageName "pkg-b" + comp = CExe (unqualCompFromString "exe") + componentTarget pn1 comp `shouldBe` componentTarget pn2 comp + + describe "componentEnableTests" $ do + let pn = mkPackageName "pkg" + testName = unqualCompFromString "my-test" + benchName = unqualCompFromString "my-bench" + mixedComps = Set.fromList + [CLib, CTest testName, CBench benchName] + + it "CTest key enables tests regardless of component set" $ do + componentEnableTests (ComponentKey pn (CTest testName)) Set.empty + `shouldBe` True + componentEnableTests (ComponentKey pn (CTest testName)) mixedComps + `shouldBe` True + + it "CBench key does not enable tests" $ do + componentEnableTests (ComponentKey pn (CBench benchName)) mixedComps + `shouldBe` False + + it "CExe key does not enable tests" $ do + componentEnableTests + (ComponentKey pn (CExe (unqualCompFromString "exe"))) + mixedComps + `shouldBe` False + + it "CSubLib key does not enable tests" $ do + componentEnableTests + (ComponentKey pn (CSubLib (unqualCompFromString "sub"))) + mixedComps + `shouldBe` False + + it "CLib key enables tests when component set has tests" $ do + componentEnableTests (ComponentKey pn CLib) mixedComps + `shouldBe` True + + it "CLib key does not enable tests when no tests in component set" $ do + componentEnableTests (ComponentKey pn CLib) (Set.singleton CLib) + `shouldBe` False + + it "CLib key does not enable tests with only benchmarks" $ do + componentEnableTests + (ComponentKey pn CLib) + (Set.singleton (CBench benchName)) + `shouldBe` False + + describe "componentEnableBenchmarks" $ do + let pn = mkPackageName "pkg" + testName = unqualCompFromString "my-test" + benchName = unqualCompFromString "my-bench" + mixedComps = Set.fromList + [CLib, CTest testName, CBench benchName] + + it "CBench key always enables benchmarks" $ do + componentEnableBenchmarks (ComponentKey pn (CBench benchName)) Set.empty + `shouldBe` True + + it "CTest key does not enable benchmarks" $ do + componentEnableBenchmarks (ComponentKey pn (CTest testName)) mixedComps + `shouldBe` False + + it "CExe key does not enable benchmarks" $ do + componentEnableBenchmarks + (ComponentKey pn (CExe (unqualCompFromString "exe"))) + mixedComps + `shouldBe` False + + it "CLib key enables benchmarks when component set has benchmarks" $ do + componentEnableBenchmarks (ComponentKey pn CLib) mixedComps + `shouldBe` True + + it "CLib key does not enable benchmarks when no benchmarks" $ do + componentEnableBenchmarks (ComponentKey pn CLib) (Set.singleton CLib) + `shouldBe` False + + it "CLib key does not enable benchmarks with only tests" $ do + componentEnableBenchmarks + (ComponentKey pn CLib) + (Set.singleton (CTest testName)) + `shouldBe` False + + describe "finalTestsAndBenches" $ do + let pn = mkPackageName "pkg" + testA = unqualCompFromString "test-a" + testB = unqualCompFromString "test-b" + benchA = unqualCompFromString "bench-a" + + it "CTest key returns exactly that one test, no benches" $ do + let (tests, benches) = + finalTestsAndBenches + (ComponentKey pn (CTest testA)) + (Set.fromList [CTest testA, CTest testB, CBench benchA]) + tests `shouldBe` Set.singleton testA + benches `shouldBe` Set.empty + + it "CBench key returns exactly that one bench, no tests" $ do + let (tests, benches) = + finalTestsAndBenches + (ComponentKey pn (CBench benchA)) + (Set.fromList [CTest testA, CBench benchA]) + tests `shouldBe` Set.empty + benches `shouldBe` Set.singleton benchA + + it "CLib key returns all tests and benches from component set" $ do + let comps = Set.fromList [CTest testA, CTest testB, CBench benchA] + (tests, benches) = + finalTestsAndBenches (ComponentKey pn CLib) comps + tests `shouldBe` Set.fromList [testA, testB] + benches `shouldBe` Set.singleton benchA + + it "CLib key with empty set returns empty tests and benches" $ do + let (tests, benches) = + finalTestsAndBenches (ComponentKey pn CLib) Set.empty + tests `shouldBe` Set.empty + benches `shouldBe` Set.empty + + it "CLib key with only CLib returns empty tests and benches" $ do + let (tests, benches) = + finalTestsAndBenches (ComponentKey pn CLib) (Set.singleton CLib) + tests `shouldBe` Set.empty + benches `shouldBe` Set.empty + + it "CExe key falls through to all tests/benches" $ do + let comps = Set.fromList [CTest testA, CBench benchA] + (tests, benches) = + finalTestsAndBenches + (ComponentKey pn (CExe (unqualCompFromString "exe"))) + comps + tests `shouldBe` Set.singleton testA + benches `shouldBe` Set.singleton benchA + + it "CTest key ignores component set entirely" $ do + -- Even though comp set has multiple tests, only the CTest key's test + -- is returned + let (tests, _) = + finalTestsAndBenches + (ComponentKey pn (CTest testA)) + (Set.fromList [CTest testA, CTest testB]) + Set.size tests `shouldBe` 1 + tests `shouldBe` Set.singleton testA diff --git a/tests/unit/Stack/PackageDumpSpec.hs b/tests/unit/Stack/PackageDumpSpec.hs index 80b5c1c386..024e9e6fd1 100644 --- a/tests/unit/Stack/PackageDumpSpec.hs +++ b/tests/unit/Stack/PackageDumpSpec.hs @@ -29,9 +29,11 @@ import Stack.PackageDump ) import Stack.Prelude import Stack.Types.CompilerPaths ( GhcPkgExe (..) ) -import Stack.Types.GhcPkgId ( parseGhcPkgId ) +import Stack.Types.GhcPkgId ( GhcPkgId, parseGhcPkgId ) import Test.Hspec - ( Spec, describe, hspec, it, shouldBe ) + ( Spec, anyException, describe, hspec, it, shouldBe + , shouldThrow + ) import Test.Hspec.QuickCheck ( prop ) main :: IO () @@ -222,6 +224,22 @@ spec = do } + describe "parseGhcPkgId" $ do + it "parses traditional package ID" $ do + gpkgId <- parseGhcPkgId "base-4.7.0.2-bfd89587617e381ae01b8dd7b6c7f1c1" + show gpkgId `shouldBe` show ("base-4.7.0.2-bfd89587617e381ae01b8dd7b6c7f1c1" :: String) + + it "parses Backpack instantiated unit ID with '+'" $ do + gpkgId <- parseGhcPkgId "private-backpack-0.1.0.0-str-sig+8GTPQYg43xPFNOuG93VVSN" + show gpkgId `shouldBe` show ("private-backpack-0.1.0.0-str-sig+8GTPQYg43xPFNOuG93VVSN" :: String) + + it "parses unit ID with only '+'" $ do + gpkgId <- parseGhcPkgId "pkg+hash" + show gpkgId `shouldBe` show ("pkg+hash" :: String) + + it "rejects empty string" $ do + (parseGhcPkgId "" :: IO GhcPkgId) `shouldThrow` anyException + it "sinkMatching" $ runEnvNoLogging $ \pkgexe -> do m <- ghcPkgDump pkgexe [] $ conduitDumpPackage diff --git a/tests/unit/Stack/Types/PlanSpec.hs b/tests/unit/Stack/Types/PlanSpec.hs new file mode 100644 index 0000000000..6e9fd99acb --- /dev/null +++ b/tests/unit/Stack/Types/PlanSpec.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Stack.Types.PlanSpec + ( main + , spec + ) where + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Distribution.Types.PackageName ( mkPackageName ) +import Stack.Prelude +import Stack.Types.ComponentUtils ( unqualCompFromString ) +import Stack.Types.NamedComponent ( NamedComponent (..) ) +import Stack.Types.Plan + ( ComponentKey (..), componentKeyPkgName ) +import Test.Hspec ( Spec, describe, hspec, it, shouldBe ) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "ComponentKey" $ do + it "componentKeyPkgName extracts the package name" $ do + let pn = mkPackageName "my-pkg" + ck = ComponentKey pn CLib + componentKeyPkgName ck `shouldBe` pn + + it "componentKeyPkgName works for non-CLib components" $ do + let pn = mkPackageName "my-pkg" + cn = unqualCompFromString "test-suite" + ck = ComponentKey pn (CTest cn) + componentKeyPkgName ck `shouldBe` pn + + it "two ComponentKeys with different components are not equal" $ do + let pn = mkPackageName "my-pkg" + ckLib = ComponentKey pn CLib + ckExe = ComponentKey pn (CExe (unqualCompFromString "my-exe")) + (ckLib == ckExe) `shouldBe` False + + it "two ComponentKeys with different packages are not equal" $ do + let ck1 = ComponentKey (mkPackageName "pkg-a") CLib + ck2 = ComponentKey (mkPackageName "pkg-b") CLib + (ck1 == ck2) `shouldBe` False + + it "two identical ComponentKeys are equal" $ do + let ck1 = ComponentKey (mkPackageName "pkg") CLib + ck2 = ComponentKey (mkPackageName "pkg") CLib + (ck1 == ck2) `shouldBe` True + + it "ComponentKey has a well-defined Ord instance" $ do + let pn = mkPackageName "pkg" + ckLib = ComponentKey pn CLib + ckExe = ComponentKey pn (CExe (unqualCompFromString "exe")) + ckTest = ComponentKey pn (CTest (unqualCompFromString "test")) + -- CLib, CSubLib, CFlib, CExe, CTest, CBench ordering comes from + -- NamedComponent's derived Ord + (ckLib < ckExe) `shouldBe` True + (ckExe < ckTest) `shouldBe` True + + it "can be used as Map keys" $ do + let ck1 = ComponentKey (mkPackageName "pkg-a") CLib + ck2 = ComponentKey (mkPackageName "pkg-a") + (CTest (unqualCompFromString "tests")) + ck3 = ComponentKey (mkPackageName "pkg-b") CLib + m :: Map ComponentKey String + m = Map.fromList [(ck1, "lib"), (ck2, "test"), (ck3, "lib-b")] + Map.size m `shouldBe` 3 + Map.lookup ck1 m `shouldBe` Just "lib" + Map.lookup ck2 m `shouldBe` Just "test" + + it "can be used in Sets" $ do + let ck1 = ComponentKey (mkPackageName "pkg") CLib + ck2 = ComponentKey (mkPackageName "pkg") + (CExe (unqualCompFromString "exe")) + s = Set.fromList [ck1, ck2, ck1] -- duplicate ck1 + Set.size s `shouldBe` 2