With ghci, allow multiple packages to use the same module #3776

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
 

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

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

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 $

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])