Merge pull request #6928 from commercialhaskell/re6896

Fix #6896 Allow dependency package to have no main library

Author: mpilgrem

.stan.toml

@@ -140,25 +140,25 @@
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-erw24B-1084:3"
+  id = "OBS-STAN-0203-erw24B-1138:3"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 # ✦ Category:      #AntiPattern
 # ✦ File:          src\Stack\Build\ExecuteEnv.hs
 #
-#  1083 ┃
-#  1084 ┃   S8.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6Q"
-#  1085 ┃   ^^^^^^^
+#  1137 ┃
+#  1138 ┃   S8.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6Q"
+#  1139 ┃   ^^^^^^^
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-tuE+RG-253:24"
+  id = "OBS-STAN-0203-tuE+RG-252:24"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 # ✦ Category:      #AntiPattern
 # ✦ File:          src\Stack\Build\ExecutePackage.hs
 #
-#   252 ┃
-#   253 ┃   newConfigFileRoot <- S8.pack . toFilePath <$> view configFileRootL
-#   254 ┃                        ^^^^^^^
+#   251 ┃
+#   252 ┃   newConfigFileRoot <- S8.pack . toFilePath <$> view configFileRootL
+#   253 ┃                        ^^^^^^^
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]

src/Stack/Build/Cache.hs

@@ -79,9 +79,7 @@ import           Stack.Types.EnvConfig
                    )
 import           Stack.Types.GhcPkgId ( ghcPkgIdString )
 import           Stack.Types.Installed
-                   ( InstallLocation (..), Installed (..)
-                   , InstalledLibraryInfo (..), foldOnGhcPkgId'
-                   )
+                   ( InstallLocation (..), Installed (..), foldOnGhcPkgId' )
 import           Stack.Types.NamedComponent
                    ( NamedComponent (..), componentCachePath )
 import           Stack.Types.SourceMap ( smRelDir )
@@ -301,12 +299,9 @@ deleteCaches dir =
 flagCacheKey :: (HasEnvConfig env) => Installed -> RIO env ConfigCacheKey
 flagCacheKey installed = do
   installationRoot <- installationRootLocal
-  case installed of
-    Library _ installedInfo -> do
-      let gid = installedInfo.ghcPkgId
-      pure $ configCacheKey installationRoot (ConfigCacheTypeFlagLibrary gid)
-    Executable ident -> pure $
-      configCacheKey installationRoot (ConfigCacheTypeFlagExecutable ident)
+  pure $ configCacheKey installationRoot $ case installed of
+    Library ident _ -> ConfigCacheTypeFlagLibrary ident
+    Executable ident -> ConfigCacheTypeFlagExecutable ident
 
 -- | Loads the Cabal flag cache for the given installed extra-deps.
 tryGetFlagCache ::

src/Stack/Build/ConstructPlan.hs

@@ -1081,7 +1081,7 @@ checkDirtiness ::
      PackageSource
   -> Installed
   -> Package
-  -> Map PackageIdentifier GhcPkgId
+  -> Map MungedPackageId GhcPkgId
   -> Bool
      -- ^ Is Haddock documentation being built?
   -> M Bool

src/Stack/Build/ExecuteEnv.hs

@@ -97,7 +97,8 @@ import           Stack.Types.CompilerPaths
 import           Stack.Types.Config
                    ( Config (..), HasConfig (..), stackRootL )
 import           Stack.Types.ConfigureOpts ( BaseConfigOpts (..) )
-import           Stack.Types.Dependency ( DepValue(..) )
+import           Stack.Types.Dependency
+                   ( DepLibrary (..), DepType (..), DepValue (..) )
 import           Stack.Types.DumpLogs ( DumpLogs (..) )
 import           Stack.Types.DumpPackage ( DumpPackage (..) )
 import           Stack.Types.EnvConfig
@@ -108,7 +109,9 @@ import           Stack.Types.EnvSettings ( EnvSettings (..) )
 import           Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString )
 import           Stack.Types.Installed ( InstallLocation (..), Installed (..) )
 import           Stack.Types.Package
-                   ( LocalPackage (..), Package (..), packageIdentifier )
+                   ( LocalPackage (..), Package (..), packageIdentifier
+                   , toCabalMungedPackageName
+                   )
 import           Stack.Types.Plan
                    ( TaskType (..), taskTypeLocation, taskTypePackageIdentifier
                    )
@@ -596,7 +599,7 @@ withSingleContext ::
   => ActionContext
   -> ExecuteEnv
   -> TaskType
-  -> Map PackageIdentifier GhcPkgId
+  -> Map MungedPackageId GhcPkgId
      -- ^ Ids of Installed packages that are assumed to be available to build a
      -- package's custom @Setup.hs@, given its dependencies specified in its
      -- @custom-setup@ stanza of its Cabal file.
@@ -800,25 +803,57 @@ withSingleContext
                       pure cabalPackageArg
                 matchedDeps <-
                   forM (Map.toList customSetupDeps) $ \(name, depValue) -> do
-                    let matches (PackageIdentifier name' version) =
-                             name == name'
+                    let mungedPkgNames = depToMungedPkgNames name depValue
+                        countMungedPkgNames = Set.size mungedPkgNames
+                        matches (MungedPackageId mungedPkgName version) _ =
+                             mungedPkgName `Set.member` mungedPkgNames
                           && version `withinRange` depValue.versionRange
-                    case filter (matches . fst) (Map.toList allDeps) of
-                      x:xs -> do
-                        unless (null xs) $
-                          prettyWarnL
-                            [ flow "Found multiple installed packages for \
-                                   \custom-setup dep:"
-                            , style Current (fromPackageName name) <> "."
-                            ]
-                        pure ("-package-id=" ++ ghcPkgIdString (snd x), Just (fst x))
-                      [] -> do
+                    case Map.filterWithKey matches allDeps of
+                      matchedDeps | Map.null matchedDeps -> do
                         prettyWarnL
                           [ flow "Could not find custom-setup dep:"
                           , style Current (fromPackageName name) <> "."
                           ]
-                        pure ("-package=" ++ packageNameString name, Nothing)
-                let depsArgs = map fst matchedDeps
+                        pure (["-package=" <> packageNameString name], Nothing)
+                      matchedDeps -> do
+                        let groupMatchedByVersion =
+                              Map.foldlWithKey'
+                                ( \acc k v ->
+                                    let p = mungedVersion k
+                                        innerMap = Map.singleton k v
+                                    in  Map.insertWith Map.union p innerMap acc
+                                )
+                                Map.empty
+                                matchedDeps
+                            countMatchedDeps = Map.size matchedDeps
+                        if Map.size groupMatchedByVersion == 1
+                          then do
+                            when (countMatchedDeps < countMungedPkgNames) $
+                              prettyWarnL
+                                [ flow "Found insufficent installed packages \
+                                       \for custom-setup dep:"
+                                , style Current (fromPackageName name) <> "."
+                                ]
+                          else do
+                            prettyWarnL
+                              [ flow "Found installed packages with multiple \
+                                     \versions for custom-setup dep:"
+                              , style Current (fromPackageName name) <> "."
+                              ]
+                        let packageIdOpt ghcPkgId =
+                              "-package-id=" <> ghcPkgIdString ghcPkgId
+                            -- The previous algorithm (arbitrarily?) selected
+                            -- the first relevant item yielded by Map.toList
+                            -- (which is Map.toAscList), so we select the
+                            -- minimum:
+                            selectedGroup = Map.findMin groupMatchedByVersion
+                            selectedVersion = fst selectedGroup
+                            packageIdOpts =
+                              map packageIdOpt $ Map.elems $ snd selectedGroup
+                            selectedPkgId =
+                              PackageIdentifier name selectedVersion
+                        pure (packageIdOpts, Just selectedPkgId)
+                let depsArgs = L.concatMap fst matchedDeps
                 -- Generate setup_macros.h and provide it to ghc
                 let macroDeps = mapMaybe snd matchedDeps
                     cppMacrosFile = setupDir </> relFileSetupMacrosH
@@ -880,6 +915,25 @@ withSingleContext
           setupArgs =
             ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args
 
+          depToMungedPkgNames ::
+               PackageName
+               -- ^ The name of the Cabal package.
+            -> DepValue
+               -- ^ The dependency value for that package.
+            -> Set.Set MungedPackageName
+          depToMungedPkgNames pkgName depValue
+            | AsLibrary depLibrary <- depValue.depType =
+                let addMain = if depLibrary.main
+                      then Set.insert mungedMainPkgName
+                      else id
+                    mungedMainPkgName = toCabalMungedPackageName pkgName Nothing
+                    subLibSet =
+                      Set.map
+                        (toCabalMungedPackageName pkgName . Just)
+                        depLibrary.subLib
+                in  addMain subLibSet
+            | otherwise = Set.empty
+
           runExe :: Path Abs File -> [String] -> RIO env ()
           runExe exeName fullArgs = do
             runAndOutput `catch` \ece -> do

src/Stack/Build/ExecutePackage.hs

@@ -130,7 +130,7 @@ import           Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdToText )
 import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
 import           Stack.Types.Installed
                    ( InstallLocation (..), Installed (..), InstalledMap
-                   , InstalledLibraryInfo (..)
+                   , InstalledLibraryInfo (..), simpleInstalledLib
                    )
 import           Stack.Types.IsMutable ( IsMutable (..) )
 import           Stack.Types.NamedComponent
@@ -139,8 +139,7 @@ import           Stack.Types.NamedComponent
                    )
 import           Stack.Types.Package
                    ( LocalPackage (..), Package (..), installedPackageToGhcPkgId
-                   , runMemoizedWith, simpleInstalledLib
-                   , toCabalMungedPackageName
+                   , runMemoizedWith, toCabalMungedPackageName
                    )
 import           Stack.Types.PackageFile ( PackageWarning (..) )
 import           Stack.Types.Plan
@@ -164,7 +163,7 @@ getConfigCache ::
   -> InstalledMap
   -> Bool
   -> Bool
-  -> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
+  -> RIO env (Map MungedPackageId GhcPkgId, ConfigCache)
 getConfigCache ee task installedMap enableTest enableBench = do
   let extra =
         -- We enable tests if the test suite dependencies are already
@@ -425,7 +424,7 @@ realConfigAndBuild ::
      -- ^ (isFinalBuild, buildingFinals)
   -> ConfigCache
   -> Maybe Curator
-  -> Map PackageIdentifier GhcPkgId
+  -> Map MungedPackageId GhcPkgId
      -- ^ Ids of installed packages that are assumed to be available to build a
      -- package's custom @Setup.hs@, given its dependencies specified in its
      -- @custom-setup@ stanza of its Cabal file.
@@ -726,27 +725,28 @@ fetchAndMarkInstalledPackage ::
   -> PackageIdentifier
   -> RIO env Installed
 fetchAndMarkInstalledPackage ee taskInstallLocation package pkgId = do
-  let ghcPkgIdLoader = fetchGhcPkgIdForLib ee taskInstallLocation package.name
-  -- Only pure the sub-libraries to cache them if we also cache the main
-  -- library (that is, if it exists)
-  if hasBuildableMainLibrary package
+  let hasMainLibrary = hasBuildableMainLibrary package
+      subLibs = package.subLibraries
+  if not hasMainLibrary && null subLibs
     then do
-      let foldSubLibToMap subLib mapInMonad = do
-            maybeGhcpkgId <- ghcPkgIdLoader (Just subLib.name)
-            mapInMonad <&> case maybeGhcpkgId of
-              Just v -> Map.insert subLib.name v
-              _ -> id
-      subLibsPkgIds <- foldComponentToAnotherCollection
-        package.subLibraries
-        foldSubLibToMap
-        mempty
-      ghcPkgIdLoader Nothing >>= \case
-        Nothing -> throwM $ Couldn'tFindPkgId package.name
-        Just ghcPkgId -> pure $ simpleInstalledLib pkgId ghcPkgId subLibsPkgIds
-    else do
-      markExeInstalled taskInstallLocation pkgId -- TODO unify somehow
-                                                  -- with writeFlagCache?
+      markExeInstalled taskInstallLocation pkgId
+      -- TODO: Unify the above somehow with writeFlagCache?
       pure $ Executable pkgId
+    else do
+      ghcPkgId <- if hasMainLibrary
+        then ghcPkgIdLoader Nothing
+        else pure Nothing
+      subLibsPkgIds <-
+        foldComponentToAnotherCollection subLibs foldSubLibToMap mempty
+      pure $ simpleInstalledLib pkgId ghcPkgId subLibsPkgIds
+ where
+  ghcPkgIdLoader = fetchGhcPkgIdForLib ee taskInstallLocation package.name
+
+  foldSubLibToMap subLib mapInMonad = do
+    maybeGhcpkgId <- ghcPkgIdLoader (Just subLib.name)
+    mapInMonad <&> case maybeGhcpkgId of
+      Just v -> Map.insert subLib.name v
+      _ -> id
 
 fetchGhcPkgIdForLib ::
      (HasTerm env, HasEnvConfig env)
@@ -755,7 +755,7 @@ fetchGhcPkgIdForLib ::
   -> PackageName
   -> Maybe Component.StackUnqualCompName
   -> RIO env (Maybe GhcPkgId)
-fetchGhcPkgIdForLib ee installLocation pkgName libName = do
+fetchGhcPkgIdForLib ee installLocation pkgName mLibName = do
   let baseConfigOpts = ee.baseConfigOpts
       (installedPkgDb, installedDumpPkgsTVar) =
         case installLocation of
@@ -766,11 +766,9 @@ fetchGhcPkgIdForLib ee installLocation pkgName libName = do
             ( baseConfigOpts.localDB
             , ee.localDumpPkgs )
   let commonLoader = loadInstalledPkg [installedPkgDb] installedDumpPkgsTVar
-  case libName of
-    Nothing -> commonLoader pkgName
-    Just v -> do
-      let mungedName = encodeCompatPackageName $ toCabalMungedPackageName pkgName v
-      commonLoader mungedName
+      mungedPkgName = toCabalMungedPackageName pkgName mLibName
+      encodedPkgName = encodeCompatPackageName mungedPkgName
+  commonLoader encodedPkgName
 
 -- | Copy ddump-* files, if we are building finals and a non-empty ddump-dir
 -- has been specified.
@@ -926,7 +924,7 @@ copyPreCompiled ee task pkgId (PrecompiledCache mlib subLibs exes) = do
       pure $ Just $
         case mpkgid of
           Nothing -> assert False $ Executable pkgId
-          Just pkgid -> simpleInstalledLib pkgId pkgid mempty
+          _ -> simpleInstalledLib pkgId mpkgid mempty
  where
   bindir = ee.baseConfigOpts.snapInstallRoot </> bindirSuffix
 
@@ -1067,8 +1065,8 @@ singleTest topts testsToRun ac ee task installedMap = do
               idMap <- liftIO $ readTVarIO ee.ghcPkgIds
               pure $ Map.lookup (taskProvides task) idMap
           let pkgGhcIdList = case installed of
-                               Just (Library _ libInfo) -> [libInfo.ghcPkgId]
-                               _ -> []
+                Just (Library _ libInfo) -> maybeToList libInfo.mMainGhcPkgId
+                _ -> []
           -- doctest relies on template-haskell in QuickCheck-based tests
           thGhcId <-
             case L.find ((== "template-haskell") . pkgName . (.packageIdent) . snd)

src/Stack/Build/Installed.hs

@@ -287,7 +287,7 @@ toLoadHelper compiler pkgDb dp = LoadHelper
     if name `Set.member` wiredInPackages compiler
       then []
       else dp.depends
-  installedLibInfo = InstalledLibraryInfo ghcPkgId (Right <$> dp.license) mempty
+  installedLibInfo = InstalledLibraryInfo (Just ghcPkgId) mempty
 
   toInstallLocation :: PackageDbVariety -> InstallLocation
   toInstallLocation GlobalDb = Snap
@@ -313,23 +313,26 @@ gatherAndTransformSubLoadHelper lh =
       (_, Library _ existingLibInfo)
     = ( pLoc
       , Library pn existingLibInfo
-          { subLib = Map.union
-              incomingLibInfo.subLib
-              existingLibInfo.subLib
-          , ghcPkgId = if isJust lh.subLibDump
-                      then existingLibInfo.ghcPkgId
-                      else incomingLibInfo.ghcPkgId
+          { subLib = Map.union incomingLibInfo.subLib existingLibInfo.subLib
+          , mMainGhcPkgId =
+              if isJust lh.subLibDump
+                then existingLibInfo.mMainGhcPkgId
+                else incomingLibInfo.mMainGhcPkgId
           }
       )
   onPreviousLoadHelper newVal _oldVal = newVal
   (key, value) = case lh.subLibDump of
     Nothing -> (rawPackageName, rawValue)
     Just sd -> (sd.packageName, updateAsSublib sd <$> rawValue)
+  -- rawValue should always have a main library: see toLoadHelper.
   (rawPackageName, rawValue) = lh.pair
   updateAsSublib
       sd
       (Library (PackageIdentifier _sublibMungedPackageName version) libInfo)
-    = Library
-        (PackageIdentifier key version)
-        libInfo { subLib = Map.singleton sd.libraryName libInfo.ghcPkgId }
+    = case libInfo.mMainGhcPkgId of
+        Nothing ->
+          error "gatherAndTransformSubLoadHelper: the impossible happened!"
+        Just ghcPkgId' -> Library
+          (PackageIdentifier key version)
+          libInfo { subLib = Map.singleton sd.libraryName ghcPkgId' }
   updateAsSublib _ v = v