Introduce FileTargets type

mpilgrem · mpilgrem · commit 3c3f72287367 · 2025-05-17T13:05:11.000+01:00
diff --git a/package.yaml b/package.yaml
@@ -282,6 +282,7 @@ library:
   - Stack.Types.Build
   - Stack.Types.Build.ConstructPlan
   - Stack.Types.Build.Exception
+  - Stack.Types.Build.FileTargets
   - Stack.Types.BuildConfig
   - Stack.Types.BuildOpts
   - Stack.Types.BuildOptsCLI
diff --git a/src/Stack/Build/FileTargets.hs b/src/Stack/Build/FileTargets.hs
@@ -46,6 +46,8 @@ import           Stack.Types.BuildOptsCLI ( ApplyCLIFlag (..) )
 import           Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL )
 import           Stack.Types.EnvConfig
                    ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL )
+import           Stack.Types.Build.FileTargets
+                   ( FileTarget (..), unionFileTargets )
 import           Stack.Types.GhciPkg
                    ( GhciPkgDesc (..), GhciPkgInfo (..), unionModuleMaps )
 import           Stack.Types.Installed ( InstallMap, InstalledMap )
@@ -75,20 +77,44 @@ findFileTargets ::
      -- ^ File targets to find
   -> RIO
        env
-       ( Map PackageName Target
-       , Maybe (Map PackageName [Path Abs File], [Path Abs File])
+       ( Map PackageName FileTarget
+       , Maybe
+           ( Map PackageName [Path Abs File]
+             -- Dictionary of project package names and lists of file targets
+             -- associated with the package.
+           , [Path Abs File]
+             -- List of file targets not associated with any project package.
+           )
        )
 findFileTargets locals fileTargets = do
   filePackages <- forM locals $ \lp -> do
     PackageComponentFile _ compFiles _ _ <- getPackageFile lp.package lp.cabalFP
     pure (lp, M.map (map dotCabalGetPath) compFiles)
-  let foundFileTargetComponents :: [(Path Abs File, [(PackageName, NamedComponent)])]
-      foundFileTargetComponents =
-        map (\fp -> (fp, ) $ L.sort $
-                    concatMap (\(lp, files) -> map ((lp.package.name,) . fst)
-                                                   (filter (elem fp . snd) (M.toList files))
-                              ) filePackages
-            ) fileTargets
+  let foundFileTargetComponents ::
+        [ ( Path Abs File
+            -- The target file.
+          , [ ( PackageName
+                -- A relevant package.
+              , NamedComponent
+                -- A relevant component of the relevant package.
+              , [Path Abs File]
+                -- The module source files of the relevant component.
+              )
+            ]
+          )
+        ]
+      foundFileTargetComponents = map
+        ( \fp ->
+              (fp,)
+            $ L.sort
+            $ concatMap
+                ( \(lp, files) -> map
+                    (\(comp, compFiles) -> (lp.package.name, comp, compFiles))
+                    (filter (elem fp . snd) (M.toList files))
+                )
+                filePackages
+        )
+        fileTargets
   results <- forM foundFileTargetComponents $ \(fp, xs) ->
     case xs of
       [] -> do
@@ -99,36 +125,38 @@ findFileTargets locals fileTargets = do
                  \Attempting to load the file anyway."
           ]
         pure $ Left fp
-      [x] -> do
+      [x@(name, comp, _)] -> do
         prettyInfoL
           [ flow "Using configuration for"
-          , displayPkgComponent x
+          , displayPkgComponent (name, comp)
           , flow "to load"
           , pretty fp
           ]
         pure $ Right (fp, x)
-      (x:_) -> do
+      (x@(name, comp, _):_) -> do
         prettyWarn $
              fillSep
                [ flow "Multiple components contain file target"
                , pretty fp <> ":"
-               , fillSep $ punctuate "," (map displayPkgComponent xs)
+               , fillSep $ punctuate "," (map (\(n, c, _) -> displayPkgComponent (n, c)) xs)
                ]
           <> line
           <> fillSep
                [ flow "Guessing the first one,"
-               , displayPkgComponent x <> "."
+               , displayPkgComponent (name, comp) <> "."
                ]
         pure $ Right (fp, x)
   let (extraFiles, associatedFiles) = partitionEithers results
       targetMap =
-          foldl' unionTargets M.empty $
-          map (\(_, (name, comp)) -> M.singleton name (TargetComps (S.singleton comp)))
-              associatedFiles
+          foldl' unionFileTargets M.empty
+        $ map
+            (\(_, (name, comp, compFiles)) -> M.singleton name (FileTarget (M.singleton comp compFiles)))
+            associatedFiles
       infoMap =
-          foldl' (M.unionWith (<>)) M.empty $
-          map (\(fp, (name, _)) -> M.singleton name [fp])
-              associatedFiles
+          foldl' (M.unionWith (<>)) M.empty
+        $ map
+            (\(fp, (name, _, _)) -> M.singleton name [fp])
+            associatedFiles
   pure (targetMap, Just (infoMap, extraFiles))
 
 -- | Yields all of the targets that are local, those that are directly wanted
diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs
@@ -26,6 +26,7 @@ import           Data.ByteString.Builder ( byteString )
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.List as L
 import           Data.List.Extra ( (!?) )
+import qualified Data.Map as Map
 import qualified Data.Map.Strict as M
 import qualified Data.Set as S
 import qualified Data.Text as T
@@ -58,6 +59,7 @@ import           Stack.Prelude
 import           Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig )
 import           Stack.Types.Build.Exception
                    ( BuildPrettyException (..), pprintTargetParseErrors )
+import           Stack.Types.Build.FileTargets ( toTarget )
 import           Stack.Types.BuildConfig
                    ( BuildConfig (..), HasBuildConfig (..), configFileL )
 import           Stack.Types.BuildOpts ( BuildOpts (..) )
@@ -200,7 +202,7 @@ ghci opts = do
     Left rawFileTargets -> do
       whenJust mainIsTargets $ \_ -> prettyThrowM Can'tSpecifyFilesAndMainIs
       -- Figure out targets based on filepath targets
-      findFileTargets locals rawFileTargets
+      findFileTargets' locals rawFileTargets
   -- Get a list of all the local target packages.
   localTargets <- getAllLocalTargets' opts inputTargets mainIsTargets localMap
   -- Get a list of all the non-local target packages.
@@ -292,6 +294,29 @@ parseMainIsTargets buildOptsCLI sma mtarget = forM mtarget $ \target -> do
   targets <- parseTargets AllowNoTargets False boptsCLI sma
   pure targets.targets
 
+-- | Given a list of project packages and a list of absolute paths to files,
+-- seek to identify which component of which project package each file relates
+-- to (if any).
+findFileTargets' ::
+     HasEnvConfig env
+  => [LocalPackage]
+     -- ^ All project packages
+  -> [Path Abs File]
+     -- ^ File targets to find
+  -> RIO
+       env
+       ( Map PackageName Target
+       , Maybe
+           ( Map PackageName [Path Abs File]
+             -- Dictionary of project package names and lists of file targets
+             -- associated with the package.
+           , [Path Abs File]
+             -- List of file targets not associated with any project package.
+           )
+       )
+findFileTargets' locals fileTargets =
+  first ( Map.map toTarget ) <$> findFileTargets locals fileTargets
+
 getAllLocalTargets' ::
      HasEnvConfig env
   => GhciOpts
diff --git a/src/Stack/IDE.hs b/src/Stack/IDE.hs
@@ -38,6 +38,7 @@ import           Stack.Runners
                    ( ShouldReexec (..), withBuildConfig, withConfig
                    , withEnvConfig
                    )
+import           Stack.Types.Build.FileTargets ( FileTarget (..), toTarget )
 import           Stack.Types.BuildConfig
                    ( BuildConfig (..), HasBuildConfig (..) )
 import           Stack.Types.BuildOpts ( BuildOpts (..) )
@@ -56,7 +57,7 @@ import           Stack.Types.Package ( LocalPackage (..), Package (..) )
 import           Stack.Types.Runner ( Runner )
 import           Stack.Types.SourceMap
                    ( ProjectPackage (..), SMWanted (..), ppComponentsMaybe )
-import           System.IO ( putStrLn )
+import           System.IO ( print, putStrLn )
 
 -- | Type representing \'pretty\' exceptions thrown by functions exported by the
 -- "Stack.IDE" module.
@@ -153,10 +154,11 @@ ideGhcOptions rawTarget = do
   depLocals <- localDependencies
   let localMap = M.fromList [(lp.package.name, lp) | lp <- locals ++ depLocals]
   -- Parse to either file targets or build targets
-  (inputTargets, mfileTargets) <- processRawTarget rawTarget >>= maybe
+  (inputTargets', mfileTargets) <- processRawTarget rawTarget >>= maybe
     (pure (mempty, Nothing))
     -- Figure out targets based on file target
     (findFileTargets locals . pure)
+  let inputTargets = Map.map toTarget inputTargets'
   -- Get a list of all the local target packages.
   (directlyWanted, extraLoadDeps) <-
     getAllLocalTargets True inputTargets Nothing localMap
@@ -180,6 +182,9 @@ ideGhcOptions rawTarget = do
       relevantDependencies
   let outputDivider = liftIO $ putStrLn "---"
   outputDivider
+  mapM_ (liftIO . print) $
+    concatMap (\(FileTarget t) -> concat $ Map.elems t) (Map.elems inputTargets')
+  outputDivider
   mapM_ (liftIO . putStrLn) pkgopts
   outputDivider
   liftIO $ BS.putStr macros
diff --git a/src/Stack/Types/Build/FileTargets.hs b/src/Stack/Types/Build/FileTargets.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+{-|
+Module      : Stack.Types.Build.FileTargets
+License     : BSD-3-Clause
+-}
+
+module Stack.Types.Build.FileTargets
+  ( FileTarget (..)
+  , unionFileTargets
+  , toTarget
+  ) where
+
+import qualified Data.Map as Map
+import           Stack.Prelude
+import           Stack.Types.NamedComponent ( NamedComponent )
+import           Stack.Types.SourceMap ( Target (..) )
+
+-- Type representing information about file targets that are associated with a
+-- project package.
+newtype FileTarget = FileTarget (Map NamedComponent [Path Abs File])
+
+-- | Combine file targets.
+unionFileTargets ::
+     Ord k
+  => Map k FileTarget
+  -> Map k FileTarget
+  -> Map k FileTarget
+unionFileTargets = Map.unionWith $ \(FileTarget l) (FileTarget r) ->
+  FileTarget (Map.unionWith (<>) l r)
+
+-- | For the given v'FileTarget', yield the corresponding 'Target'.
+toTarget :: FileTarget -> Target
+toTarget (FileTarget t) = TargetComps $ Map.keysSet t
diff --git a/stack.cabal b/stack.cabal
@@ -318,6 +318,7 @@ library
       Stack.Types.Build
       Stack.Types.Build.ConstructPlan
       Stack.Types.Build.Exception
+      Stack.Types.Build.FileTargets
       Stack.Types.BuildConfig
       Stack.Types.BuildOpts
       Stack.Types.BuildOptsCLI
