From 770cffaf72794b3df634760ac702a5f597f3ab40 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 4 Jan 2017 09:22:33 +0200 Subject: [PATCH] Detect module conflicts --- Stackage/BuildConstraints.hs | 2 +- Stackage/CheckBuildPlan.hs | 31 +++++++++++++++++++++++++++++-- Stackage/CorePackages.hs | 18 +++++++++++++----- Stackage/Types.hs | 4 ++++ 4 files changed, 47 insertions(+), 8 deletions(-) diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs index e3ae2ee..39d6141 100644 --- a/Stackage/BuildConstraints.hs +++ b/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 {..} diff --git a/Stackage/CheckBuildPlan.hs b/Stackage/CheckBuildPlan.hs index 8624b72..74ed98d 100644 --- a/Stackage/CheckBuildPlan.hs +++ b/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) diff --git a/Stackage/CorePackages.hs b/Stackage/CorePackages.hs index 6aaab95..017d3cd 100644 --- a/Stackage/CorePackages.hs +++ b/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" {- diff --git a/Stackage/Types.hs b/Stackage/Types.hs index 64418fc..39cd618 100644 --- a/Stackage/Types.hs +++ b/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