Skip to content

Commit 3c3f722

Browse files
mpilgremmpilgrem
committed
Introduce FileTargets type
1 parent 16ba5cd commit 3c3f722

File tree

6 files changed

+117
-23
lines changed

6 files changed

+117
-23
lines changed

‎package.yaml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -282,6 +282,7 @@ library:
282282
- Stack.Types.Build
283283
- Stack.Types.Build.ConstructPlan
284284
- Stack.Types.Build.Exception
285+
- Stack.Types.Build.FileTargets
285286
- Stack.Types.BuildConfig
286287
- Stack.Types.BuildOpts
287288
- Stack.Types.BuildOptsCLI

‎src/Stack/Build/FileTargets.hs

Lines changed: 48 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -46,6 +46,8 @@ import Stack.Types.BuildOptsCLI ( ApplyCLIFlag (..) )
4646
import Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL )
4747
import Stack.Types.EnvConfig
4848
( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL )
49+
import Stack.Types.Build.FileTargets
50+
( FileTarget (..), unionFileTargets )
4951
import Stack.Types.GhciPkg
5052
( GhciPkgDesc (..), GhciPkgInfo (..), unionModuleMaps )
5153
import Stack.Types.Installed ( InstallMap, InstalledMap )
@@ -75,20 +77,44 @@ findFileTargets ::
7577
-- ^ File targets to find
7678
-> RIO
7779
env
78-
( Map PackageName Target
79-
, Maybe (Map PackageName [Path Abs File], [Path Abs File])
80+
( Map PackageName FileTarget
81+
, Maybe
82+
( Map PackageName [Path Abs File]
83+
-- Dictionary of project package names and lists of file targets
84+
-- associated with the package.
85+
, [Path Abs File]
86+
-- List of file targets not associated with any project package.
87+
)
8088
)
8189
findFileTargets locals fileTargets = do
8290
filePackages <- forM locals $ \lp -> do
8391
PackageComponentFile _ compFiles _ _ <- getPackageFile lp.package lp.cabalFP
8492
pure (lp, M.map (map dotCabalGetPath) compFiles)
85-
let foundFileTargetComponents :: [(Path Abs File, [(PackageName, NamedComponent)])]
86-
foundFileTargetComponents =
87-
map (\fp -> (fp, ) $ L.sort $
88-
concatMap (\(lp, files) -> map ((lp.package.name,) . fst)
89-
(filter (elem fp . snd) (M.toList files))
90-
) filePackages
91-
) fileTargets
93+
let foundFileTargetComponents ::
94+
[ ( Path Abs File
95+
-- The target file.
96+
, [ ( PackageName
97+
-- A relevant package.
98+
, NamedComponent
99+
-- A relevant component of the relevant package.
100+
, [Path Abs File]
101+
-- The module source files of the relevant component.
102+
)
103+
]
104+
)
105+
]
106+
foundFileTargetComponents = map
107+
( \fp ->
108+
(fp,)
109+
$ L.sort
110+
$ concatMap
111+
( \(lp, files) -> map
112+
(\(comp, compFiles) -> (lp.package.name, comp, compFiles))
113+
(filter (elem fp . snd) (M.toList files))
114+
)
115+
filePackages
116+
)
117+
fileTargets
92118
results <- forM foundFileTargetComponents $ \(fp, xs) ->
93119
case xs of
94120
[] -> do
@@ -99,36 +125,38 @@ findFileTargets locals fileTargets = do
99125
\Attempting to load the file anyway."
100126
]
101127
pure $ Left fp
102-
[x] -> do
128+
[x@(name, comp, _)] -> do
103129
prettyInfoL
104130
[ flow "Using configuration for"
105-
, displayPkgComponent x
131+
, displayPkgComponent (name, comp)
106132
, flow "to load"
107133
, pretty fp
108134
]
109135
pure $ Right (fp, x)
110-
(x:_) -> do
136+
(x@(name, comp, _):_) -> do
111137
prettyWarn $
112138
fillSep
113139
[ flow "Multiple components contain file target"
114140
, pretty fp <> ":"
115-
, fillSep $ punctuate "," (map displayPkgComponent xs)
141+
, fillSep $ punctuate "," (map (\(n, c, _) -> displayPkgComponent (n, c)) xs)
116142
]
117143
<> line
118144
<> fillSep
119145
[ flow "Guessing the first one,"
120-
, displayPkgComponent x <> "."
146+
, displayPkgComponent (name, comp) <> "."
121147
]
122148
pure $ Right (fp, x)
123149
let (extraFiles, associatedFiles) = partitionEithers results
124150
targetMap =
125-
foldl' unionTargets M.empty $
126-
map (\(_, (name, comp)) -> M.singleton name (TargetComps (S.singleton comp)))
127-
associatedFiles
151+
foldl' unionFileTargets M.empty
152+
$ map
153+
(\(_, (name, comp, compFiles)) -> M.singleton name (FileTarget (M.singleton comp compFiles)))
154+
associatedFiles
128155
infoMap =
129-
foldl' (M.unionWith (<>)) M.empty $
130-
map (\(fp, (name, _)) -> M.singleton name [fp])
131-
associatedFiles
156+
foldl' (M.unionWith (<>)) M.empty
157+
$ map
158+
(\(fp, (name, _, _)) -> M.singleton name [fp])
159+
associatedFiles
132160
pure (targetMap, Just (infoMap, extraFiles))
133161

134162
-- | Yields all of the targets that are local, those that are directly wanted

‎src/Stack/Ghci.hs

Lines changed: 26 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ import Data.ByteString.Builder ( byteString )
2626
import qualified Data.ByteString.Lazy as LBS
2727
import qualified Data.List as L
2828
import Data.List.Extra ( (!?) )
29+
import qualified Data.Map as Map
2930
import qualified Data.Map.Strict as M
3031
import qualified Data.Set as S
3132
import qualified Data.Text as T
@@ -58,6 +59,7 @@ import Stack.Prelude
5859
import Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig )
5960
import Stack.Types.Build.Exception
6061
( BuildPrettyException (..), pprintTargetParseErrors )
62+
import Stack.Types.Build.FileTargets ( toTarget )
6163
import Stack.Types.BuildConfig
6264
( BuildConfig (..), HasBuildConfig (..), configFileL )
6365
import Stack.Types.BuildOpts ( BuildOpts (..) )
@@ -200,7 +202,7 @@ ghci opts = do
200202
Left rawFileTargets -> do
201203
whenJust mainIsTargets $ \_ -> prettyThrowM Can'tSpecifyFilesAndMainIs
202204
-- Figure out targets based on filepath targets
203-
findFileTargets locals rawFileTargets
205+
findFileTargets' locals rawFileTargets
204206
-- Get a list of all the local target packages.
205207
localTargets <- getAllLocalTargets' opts inputTargets mainIsTargets localMap
206208
-- Get a list of all the non-local target packages.
@@ -292,6 +294,29 @@ parseMainIsTargets buildOptsCLI sma mtarget = forM mtarget $ \target -> do
292294
targets <- parseTargets AllowNoTargets False boptsCLI sma
293295
pure targets.targets
294296

297+
-- | Given a list of project packages and a list of absolute paths to files,
298+
-- seek to identify which component of which project package each file relates
299+
-- to (if any).
300+
findFileTargets' ::
301+
HasEnvConfig env
302+
=> [LocalPackage]
303+
-- ^ All project packages
304+
-> [Path Abs File]
305+
-- ^ File targets to find
306+
-> RIO
307+
env
308+
( Map PackageName Target
309+
, Maybe
310+
( Map PackageName [Path Abs File]
311+
-- Dictionary of project package names and lists of file targets
312+
-- associated with the package.
313+
, [Path Abs File]
314+
-- List of file targets not associated with any project package.
315+
)
316+
)
317+
findFileTargets' locals fileTargets =
318+
first ( Map.map toTarget ) <$> findFileTargets locals fileTargets
319+
295320
getAllLocalTargets' ::
296321
HasEnvConfig env
297322
=> GhciOpts

‎src/Stack/IDE.hs

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -38,6 +38,7 @@ import Stack.Runners
3838
( ShouldReexec (..), withBuildConfig, withConfig
3939
, withEnvConfig
4040
)
41+
import Stack.Types.Build.FileTargets ( FileTarget (..), toTarget )
4142
import Stack.Types.BuildConfig
4243
( BuildConfig (..), HasBuildConfig (..) )
4344
import Stack.Types.BuildOpts ( BuildOpts (..) )
@@ -56,7 +57,7 @@ import Stack.Types.Package ( LocalPackage (..), Package (..) )
5657
import Stack.Types.Runner ( Runner )
5758
import Stack.Types.SourceMap
5859
( ProjectPackage (..), SMWanted (..), ppComponentsMaybe )
59-
import System.IO ( putStrLn )
60+
import System.IO ( print, putStrLn )
6061

6162
-- | Type representing \'pretty\' exceptions thrown by functions exported by the
6263
-- "Stack.IDE" module.
@@ -153,10 +154,11 @@ ideGhcOptions rawTarget = do
153154
depLocals <- localDependencies
154155
let localMap = M.fromList [(lp.package.name, lp) | lp <- locals ++ depLocals]
155156
-- Parse to either file targets or build targets
156-
(inputTargets, mfileTargets) <- processRawTarget rawTarget >>= maybe
157+
(inputTargets', mfileTargets) <- processRawTarget rawTarget >>= maybe
157158
(pure (mempty, Nothing))
158159
-- Figure out targets based on file target
159160
(findFileTargets locals . pure)
161+
let inputTargets = Map.map toTarget inputTargets'
160162
-- Get a list of all the local target packages.
161163
(directlyWanted, extraLoadDeps) <-
162164
getAllLocalTargets True inputTargets Nothing localMap
@@ -180,6 +182,9 @@ ideGhcOptions rawTarget = do
180182
relevantDependencies
181183
let outputDivider = liftIO $ putStrLn "---"
182184
outputDivider
185+
mapM_ (liftIO . print) $
186+
concatMap (\(FileTarget t) -> concat $ Map.elems t) (Map.elems inputTargets')
187+
outputDivider
183188
mapM_ (liftIO . putStrLn) pkgopts
184189
outputDivider
185190
liftIO $ BS.putStr macros

‎src/Stack/Types/Build/FileTargets.hs

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,34 @@
1+
{-# LANGUAGE NoImplicitPrelude #-}
2+
3+
{-|
4+
Module : Stack.Types.Build.FileTargets
5+
License : BSD-3-Clause
6+
-}
7+
8+
module Stack.Types.Build.FileTargets
9+
( FileTarget (..)
10+
, unionFileTargets
11+
, toTarget
12+
) where
13+
14+
import qualified Data.Map as Map
15+
import Stack.Prelude
16+
import Stack.Types.NamedComponent ( NamedComponent )
17+
import Stack.Types.SourceMap ( Target (..) )
18+
19+
-- Type representing information about file targets that are associated with a
20+
-- project package.
21+
newtype FileTarget = FileTarget (Map NamedComponent [Path Abs File])
22+
23+
-- | Combine file targets.
24+
unionFileTargets ::
25+
Ord k
26+
=> Map k FileTarget
27+
-> Map k FileTarget
28+
-> Map k FileTarget
29+
unionFileTargets = Map.unionWith $ \(FileTarget l) (FileTarget r) ->
30+
FileTarget (Map.unionWith (<>) l r)
31+
32+
-- | For the given v'FileTarget', yield the corresponding 'Target'.
33+
toTarget :: FileTarget -> Target
34+
toTarget (FileTarget t) = TargetComps $ Map.keysSet t

‎stack.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -318,6 +318,7 @@ library
318318
Stack.Types.Build
319319
Stack.Types.Build.ConstructPlan
320320
Stack.Types.Build.Exception
321+
Stack.Types.Build.FileTargets
321322
Stack.Types.BuildConfig
322323
Stack.Types.BuildOpts
323324
Stack.Types.BuildOptsCLI

0 commit comments

Comments
 (0)