From 864831f8f2d4c91e5989f2cbfbe3769c03946e0d Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Mon, 15 Jan 2018 00:05:26 -0800 Subject: [PATCH] With ghci, allow multiple packages to use the same module #3776 --- ChangeLog.md | 3 +++ src/Stack/Ghci.hs | 46 +++++++++++++++++++++++------------ src/Stack/Package.hs | 50 ++++++++++++++++++++++++-------------- src/Stack/PrettyPrint.hs | 5 ++++ src/Stack/Types/Package.hs | 4 +-- 5 files changed, 73 insertions(+), 35 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index fb8bd7b821..272904b3b8 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -65,6 +65,9 @@ Bug fixes: this bug, you will likely need to delete the binary build cache associated with the relevant custom snapshot. See [#3714](https://github.com/commercialhaskell/stack/issues/3714). +* `stack ghci` now allows loading multiple packages with the same + module name, as long as they are the same filepath. See + [#3776](https://github.com/commercialhaskell/stack/pull/3776). ## v1.6.3 diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index eee9bc6a31..868f89bf44 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -26,7 +26,6 @@ import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Text as T import qualified Distribution.PackageDescription as C -import qualified Distribution.Text as C import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO hiding (withSystemTempDir) @@ -77,14 +76,22 @@ data GhciPkgInfo = GhciPkgInfo { ghciPkgName :: !PackageName , ghciPkgOpts :: ![(NamedComponent, BuildInfoOpts)] , ghciPkgDir :: !(Path Abs Dir) - , ghciPkgModules :: !(Set ModuleName) - , ghciPkgModFiles :: !(Set (Path Abs File)) -- ^ Module file paths. + , ghciPkgModules :: !ModuleMap , ghciPkgCFiles :: !(Set (Path Abs File)) -- ^ C files. , ghciPkgMainIs :: !(Map NamedComponent (Set (Path Abs File))) , ghciPkgTargetFiles :: !(Maybe (Set (Path Abs File))) , ghciPkgPackage :: !Package } deriving Show +-- Mapping from a module name to a map with all of the paths that use +-- that name. Each of those paths is associated with a set of components +-- that contain it. Purpose of this complex structure is for use in +-- 'checkForDuplicateModules'. +type ModuleMap = Map ModuleName (Map (Path Abs File) (Set (PackageName, NamedComponent))) + +unionModuleMaps :: [ModuleMap] -> ModuleMap +unionModuleMaps = M.unionsWith (M.unionWith S.union) + data GhciException = InvalidPackageOption String | LoadingDuplicateModules @@ -418,7 +425,7 @@ renderScript isIntero pkgs mainFile onlyMain extraFiles = do Just path -> [Right path] _ -> [] modulePhase = cmdModule $ S.fromList allModules - allModules = concatMap (S.toList . ghciPkgModules) pkgs + allModules = nubOrd $ concatMap (M.keys . ghciPkgModules) pkgs case getFileTargets pkgs <> extraFiles of [] -> if onlyMain @@ -602,8 +609,9 @@ makeGhciPkgInfo buildOptsCLI sourceMap installedMap locals addPkgs mfileTargets { ghciPkgName = packageName pkg , ghciPkgOpts = M.toList filteredOpts , ghciPkgDir = parent cabalfp - , ghciPkgModules = mconcat (M.elems (filterWanted mods)) - , ghciPkgModFiles = mconcat (M.elems (filterWanted (M.map (setMapMaybe dotCabalModulePath) files))) + , ghciPkgModules = unionModuleMaps $ + map (\(comp, mp) -> M.map (\fp -> M.singleton fp (S.singleton (packageName pkg, comp))) mp) + (M.toList (filterWanted mods)) , ghciPkgMainIs = M.map (setMapMaybe dotCabalMainPath) files , ghciPkgCFiles = mconcat (M.elems (filterWanted (M.map (setMapMaybe dotCabalCFilePath) files))) , ghciPkgTargetFiles = mfileTargets >>= M.lookup name @@ -696,20 +704,28 @@ borderedWarning f = do logWarn "" return x -checkForDuplicateModules :: HasLogFunc env => [GhciPkgInfo] -> RIO env () +-- TODO: Should this also tell the user the filepaths, not just the +-- module name? +checkForDuplicateModules :: HasRunner env => [GhciPkgInfo] -> RIO env () checkForDuplicateModules pkgs = do unless (null duplicates) $ do borderedWarning $ do - logWarn "The following modules are present in multiple packages:" - forM_ duplicates $ \(mn, pns) -> do - logWarn (" * " <> T.pack mn <> " (in " <> T.intercalate ", " (map packageNameText pns) <> ")") + prettyError $ "Multiple files use the same module name:" <> + line <> bulletedList (map prettyDuplicate duplicates) throwM LoadingDuplicateModules where - duplicates, allModules :: [(String, [PackageName])] - duplicates = filter (not . null . tail . snd) allModules - allModules = - M.toList $ M.fromListWith (++) $ - concatMap (\pkg -> map ((, [ghciPkgName pkg]) . C.display) (S.toList (ghciPkgModules pkg))) pkgs + duplicates :: [(ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent)))] + duplicates = + filter (\(_, mp) -> M.size mp > 1) $ + M.toList $ + unionModuleMaps (map ghciPkgModules pkgs) + prettyDuplicate :: (ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent))) -> AnsiDoc + prettyDuplicate (mn, mp) = + styleError (display mn) <+> "found at the following paths" <> line <> + bulletedList (map fileDuplicate (M.toList mp)) + fileDuplicate :: (Path Abs File, Set (PackageName, NamedComponent)) -> AnsiDoc + fileDuplicate (fp, comps) = + display fp <+> parens (fillSep (punctuate "," (map display (S.toList comps)))) targetWarnings :: HasRunner env diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index d2ed9b55d6..6542dcb3c6 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -42,7 +42,7 @@ module Stack.Package import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 -import Data.List (isSuffixOf, partition, isPrefixOf) +import Data.List (isSuffixOf, isPrefixOf) import Data.List.Extra (nubOrd) import qualified Data.Map.Strict as M import qualified Data.Set as S @@ -673,7 +673,7 @@ allBuildInfo' pkg = allBuildInfo pkg ++ -- | Get all files referenced by the package. packageDescModulesAndFiles :: PackageDescription - -> RIO Ctx (Map NamedComponent (Set ModuleName), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning]) + -> RIO Ctx (Map NamedComponent (Map ModuleName (Path Abs File)), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning]) packageDescModulesAndFiles pkg = do (libraryMods,libDotCabalFiles,libWarnings) <- -- FIXME add in sub libraries maybe @@ -791,7 +791,7 @@ matchDirFileGlob_ dir filepath = case parseFileGlob filepath of -- | Get all files referenced by the benchmark. benchmarkFiles - :: Benchmark -> RIO Ctx (Set ModuleName, Set DotCabalPath, [PackageWarning]) + :: Benchmark -> RIO Ctx (Map ModuleName (Path Abs File), Set DotCabalPath, [PackageWarning]) benchmarkFiles bench = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . ctxFile) @@ -814,7 +814,7 @@ benchmarkFiles bench = do -- | Get all files referenced by the test. testFiles :: TestSuite - -> RIO Ctx (Set ModuleName, Set DotCabalPath, [PackageWarning]) + -> RIO Ctx (Map ModuleName (Path Abs File), Set DotCabalPath, [PackageWarning]) testFiles test = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . ctxFile) @@ -838,7 +838,7 @@ testFiles test = do -- | Get all files referenced by the executable. executableFiles :: Executable - -> RIO Ctx (Set ModuleName, Set DotCabalPath, [PackageWarning]) + -> RIO Ctx (Map ModuleName (Path Abs File), Set DotCabalPath, [PackageWarning]) executableFiles exe = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . ctxFile) @@ -856,7 +856,7 @@ executableFiles exe = do -- | Get all files referenced by the library. libraryFiles - :: Library -> RIO Ctx (Set ModuleName, Set DotCabalPath, [PackageWarning]) + :: Library -> RIO Ctx (Map ModuleName (Path Abs File), Set DotCabalPath, [PackageWarning]) libraryFiles lib = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . ctxFile) @@ -1070,19 +1070,18 @@ resolveFilesAndDeps -> [Path Abs Dir] -- ^ Directories to look in. -> [DotCabalDescriptor] -- ^ Base names. -> [Text] -- ^ Extensions. - -> RIO Ctx (Set ModuleName,Set DotCabalPath,[PackageWarning]) + -> RIO Ctx (Map ModuleName (Path Abs File),Set DotCabalPath,[PackageWarning]) resolveFilesAndDeps component dirs names0 exts = do (dotCabalPaths, foundModules, missingModules) <- loop names0 S.empty warnings <- liftM2 (++) (warnUnlisted foundModules) (warnMissing missingModules) return (foundModules, dotCabalPaths, warnings) where - loop [] _ = return (S.empty, S.empty, []) + loop [] _ = return (S.empty, M.empty, []) loop names doneModules0 = do resolved <- resolveFiles dirs names exts let foundFiles = mapMaybe snd resolved - (foundModules', missingModules') = partition (isJust . snd) resolved - foundModules = mapMaybe (dotCabalModule . fst) foundModules' - missingModules = mapMaybe (dotCabalModule . fst) missingModules' + foundModules = mapMaybe toResolvedModule resolved + missingModules = mapMaybe toMissingModule resolved pairs <- mapM (getDependencies component) foundFiles let doneModules = S.union @@ -1100,20 +1099,20 @@ resolveFilesAndDeps component dirs names0 exts = do (S.fromList (foundFiles <> map DotCabalFilePath thDepFiles)) resolvedFiles - , S.union - (S.fromList foundModules) + , M.union + (M.fromList foundModules) resolvedModules , missingModules) warnUnlisted foundModules = do let unlistedModules = - foundModules `S.difference` - S.fromList (mapMaybe dotCabalModule names0) + foundModules `M.difference` + M.fromList (mapMaybe (fmap (, ()) . dotCabalModule) names0) return $ - if S.null unlistedModules + if M.null unlistedModules then [] else [ UnlistedModulesWarning component - (S.toList unlistedModules)] + (map fst (M.toList unlistedModules))] warnMissing _missingModules = do return [] -- TODO: bring this back - see @@ -1128,7 +1127,22 @@ resolveFilesAndDeps component dirs names0 exts = do component missingModules] -} - + -- TODO: In usages of toResolvedModule / toMissingModule, some sort + -- of map + partition would probably be better. + toResolvedModule + :: (DotCabalDescriptor, Maybe DotCabalPath) + -> Maybe (ModuleName, Path Abs File) + toResolvedModule (DotCabalModule mn, Just (DotCabalModulePath fp)) = + Just (mn, fp) + toResolvedModule _ = + Nothing + toMissingModule + :: (DotCabalDescriptor, Maybe DotCabalPath) + -> Maybe ModuleName + toMissingModule (DotCabalModule mn, Nothing) = + Just mn + toMissingModule _ = + Nothing -- | Get the dependencies of a Haskell module file. getDependencies diff --git a/src/Stack/PrettyPrint.hs b/src/Stack/PrettyPrint.hs index 2aaa536113..c6df168185 100644 --- a/src/Stack/PrettyPrint.hs +++ b/src/Stack/PrettyPrint.hs @@ -37,6 +37,8 @@ module Stack.PrettyPrint import Stack.Prelude import Data.List (intersperse) import qualified Data.Text as T +import qualified Distribution.ModuleName as C (ModuleName) +import qualified Distribution.Text as C (display) import Stack.Types.NamedComponent import Stack.Types.PackageIdentifier import Stack.Types.PackageName @@ -211,6 +213,9 @@ instance Display (Path b Dir) where instance Display (PackageName, NamedComponent) where display = cyan . fromString . T.unpack . renderPkgComponent +instance Display C.ModuleName where + display = fromString . C.display + -- Display milliseconds. displayMilliseconds :: Clock.TimeSpec -> AnsiDoc displayMilliseconds t = green $ diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index f715ce5f47..8591fe40b1 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -126,7 +126,7 @@ newtype GetPackageOpts = GetPackageOpts -> [PackageName] -> Path Abs File -> RIO env - (Map NamedComponent (Set ModuleName) + (Map NamedComponent (Map ModuleName (Path Abs File)) ,Map NamedComponent (Set DotCabalPath) ,Map NamedComponent BuildInfoOpts) } @@ -155,7 +155,7 @@ newtype GetPackageFiles = GetPackageFiles { getPackageFiles :: forall env. HasEnvConfig env => Path Abs File -> RIO env - (Map NamedComponent (Set ModuleName) + (Map NamedComponent (Map ModuleName (Path Abs File)) ,Map NamedComponent (Set DotCabalPath) ,Set (Path Abs File) ,[PackageWarning])