Detect module conflicts

Stackage/BuildConstraints.hs

@@ -101,7 +101,7 @@ loadBuildConstraints bcs man = do
 
 getSystemInfo :: IO SystemInfo
 getSystemInfo = do
-    siCorePackages <- getCorePackages
+    (siCorePackages, siCoreModules) <- (fmap fst &&& fmap snd) <$> getCorePackages
     siCoreExecutables <- getCoreExecutables
     siGhcVersion <- getGhcVersion
     return SystemInfo {..}

Stackage/CheckBuildPlan.hs

@@ -26,8 +26,8 @@ checkBuildPlan :: (MonadThrow m)
                => Bool -- ^ fail on missing Cabal package
                -> BuildPlan
                -> m ()
-checkBuildPlan failMissingCabal BuildPlan {..}
-    | null errs1 && null errs2 = return ()
+checkBuildPlan failMissingCabal bp@BuildPlan {..}
+    | null errs1 && null errs2 = checkConflictingModules bp
     | otherwise = throwM errs
   where
     allPackages = map (,mempty) (siCorePackages bpSystemInfo) ++
@@ -54,6 +54,33 @@ checkBuildPlan failMissingCabal BuildPlan {..}
         pp <- lookup pn bpPackages
         pcMaintainer $ ppConstraints pp
 
+checkConflictingModules :: MonadThrow m => BuildPlan -> m ()
+checkConflictingModules bp =
+    case mapMaybe isBad $ mapToList revmap of
+        [] -> return ()
+        xs -> terror $ unlines xs
+  where
+    cores = siCoreModules (bpSystemInfo bp)
+    others = (sdModules . ppDesc)
+         <$> M.filter (not . pcHide . ppConstraints) (bpPackages bp)
+    allMap = cores <> others
+
+    revmap :: Map Text (Set PackageName)
+    revmap = unionsWith (<>)
+           $ concatMap (\(k, vs) -> flip singletonMap (asSet $ singletonSet k) <$> toList vs)
+           $ mapToList allMap
+
+    isBad :: (Text, Set PackageName) -> Maybe Text
+    isBad (mn, pns)
+        | null pns = error "checkConflictingModules: invariant violated"
+        | length pns == 1 = Nothing
+        | otherwise = Just $ concat
+            [ "Module name "
+            , mn
+            , " appears in multiple packages: "
+            , unwords $ map display $ toList pns
+            ]
+
 -- | For a given package name and plan, check that its dependencies are:
 --
 -- 1. Existent (existing in the provided package map)

Stackage/CorePackages.hs

@@ -17,7 +17,7 @@ import           Stackage.Prelude
 import           System.Directory           (findExecutable)
 import           System.FilePath            (takeDirectory, takeFileName)
 
-addDeepDepends :: PackageName -> StateT (Map PackageName Version) IO ()
+addDeepDepends :: PackageName -> StateT (Map PackageName (Version, Set Text)) IO ()
 addDeepDepends name@(PackageName name') = do
     m <- get
     case lookup name m of
@@ -30,11 +30,13 @@ addDeepDepends name@(PackageName name') = do
             -- (if a bit hackier).
             put $ Map.insert name (error "Version prematurely forced") m
             let cp = proc "ghc-pkg" ["--no-user-package-conf", "describe", name']
-            version <- withCheckedProcess cp $ \ClosedStream src Inherited ->
+            info <- withCheckedProcess cp $ \ClosedStream src Inherited ->
                 src $$ decodeUtf8C =$ linesUnboundedC =$ getZipSink (
                        ZipSink (dependsConduit =$ dependsSink)
-                    *> ZipSink versionSink)
-            modify $ insertMap name version
+                    *> ((,)
+                            <$> ZipSink versionSink
+                            <*> ZipSink modulesSink))
+            modify $ insertMap name info
   where
     -- This sink finds the first line starting with "version: " and parses the
     -- value
@@ -48,6 +50,12 @@ addDeepDepends name@(PackageName name') = do
                 Nothing -> loop
                 Just x -> simpleParse x
 
+    -- Grab the info from the exposed-modules bit
+    modulesSink = do
+        dropWhileC $ not . ("exposed-modules:" `isPrefixOf`)
+        dropC 1
+        fmap (setFromList . words . filter (/= ',') . toStrict) $ takeWhileC (" " `isPrefixOf`) .| sinkLazy
+
     -- Finds the beginning of the depends: block and parses the value. Lots of
     -- ugly text hacking here to try and be compatible with multiple versions
     -- of GHC.
@@ -103,7 +111,7 @@ addDeepDepends name@(PackageName name') = do
 --
 -- Precondition: GHC global package database has only core packages, and GHC
 -- ships with just a single version of each packages.
-getCorePackages :: IO (Map PackageName Version)
+getCorePackages :: IO (Map PackageName (Version, Set Text))
 getCorePackages = flip execStateT mempty $ mapM_ (addDeepDepends . PackageName)
     [ "ghc"
     {-

Stackage/Types.hs

@@ -324,6 +324,8 @@ data SystemInfo = SystemInfo
     , siOS              :: OS
     , siArch            :: Arch
     , siCorePackages    :: Map PackageName Version
+    , siCoreModules     :: Map PackageName (Set Text)
+    -- ^ Should be part of siCorePackages but kept separate for backwards compatibility
     , siCoreExecutables :: Set ExeName
     }
     deriving (Show, Eq, Ord)
@@ -333,6 +335,7 @@ instance ToJSON SystemInfo where
         , "os" .= display siOS
         , "arch" .= display siArch
         , "core-packages" .= Map.mapKeysWith const unPackageName (fmap display siCorePackages)
+        , "core-modules" .= Map.mapKeysWith const unPackageName siCoreModules
         , "core-executables" .= siCoreExecutables
         ]
 instance FromJSON SystemInfo where
@@ -342,6 +345,7 @@ instance FromJSON SystemInfo where
         siOS <- helper "os"
         siArch <- helper "arch"
         siCorePackages <- (o .: "core-packages") >>= goPackages
+        siCoreModules <- Map.mapKeysWith const mkPackageName <$> (o .: "core-modules")
         siCoreExecutables <- o .: "core-executables"
         return SystemInfo {..}
       where