1
- {-# LANGUAGE NoImplicitPrelude #-}
2
- {-# LANGUAGE OverloadedRecordDot #-}
3
- {-# LANGUAGE OverloadedStrings #-}
1
+ {-# LANGUAGE NoImplicitPrelude #-}
2
+ {-# LANGUAGE DuplicateRecordFields #-}
3
+ {-# LANGUAGE NoFieldSelectors #-}
4
+ {-# LANGUAGE OverloadedRecordDot #-}
5
+ {-# LANGUAGE OverloadedStrings #-}
4
6
5
7
{-|
6
8
Module : Stack.IDE
@@ -11,33 +13,62 @@ Types and functions related to Stack's @ide@ command.
11
13
-}
12
14
13
15
module Stack.IDE
14
- ( OutputStream (.. )
15
- , ListPackagesCmd (.. )
16
- , idePackagesCmd
16
+ ( idePackagesCmd
17
17
, ideTargetsCmd
18
- , listPackages
19
- , listTargets
18
+ , ideGhcOptionsCmd
20
19
) where
21
20
21
+ import qualified Data.ByteString as BS
22
22
import qualified Data.Map as Map
23
+ import qualified Data.Map.Strict as M
23
24
import qualified Data.Set as Set
24
25
import qualified Data.Text as T
25
26
import Data.Tuple ( swap )
27
+ import Stack.Build.FileTargets
28
+ ( findFileTargets , getAllLocalTargets , getAllNonLocalTargets
29
+ , getGhciPkgInfos , loadGhciPkgDescs , optsAndMacros
30
+ )
31
+ import Stack.Build.Installed ( toInstallMap )
32
+ import Stack.Build.Source ( localDependencies , projectLocalPackages )
33
+ import Stack.Build.Target ( NeedTargets (.. ) )
34
+ import Stack.Package ( topSortPackageComponent )
35
+ import Path.Extra ( forgivingResolveFile' )
26
36
import Stack.Prelude
27
37
import Stack.Runners
28
- ( ShouldReexec (.. ), withBuildConfig , withConfig )
38
+ ( ShouldReexec (.. ), withBuildConfig , withConfig
39
+ , withEnvConfig
40
+ )
29
41
import Stack.Types.BuildConfig
30
42
( BuildConfig (.. ), HasBuildConfig (.. ) )
43
+ import Stack.Types.BuildOpts ( BuildOpts (.. ) )
44
+ import qualified Stack.Types.BuildOpts as BenchmarkOpts ( BenchmarkOpts (.. ) )
45
+ import qualified Stack.Types.BuildOpts as TestOpts ( TestOpts (.. ) )
46
+ import Stack.Types.BuildOptsCLI
47
+ ( BuildOptsCLI (.. ), defaultBuildOptsCLI )
48
+ import Stack.Types.Config ( buildOptsL )
49
+ import Stack.Types.EnvConfig ( EnvConfig (.. ), HasEnvConfig (.. ) )
31
50
import Stack.Types.IdeOpts ( ListPackagesCmd (.. ), OutputStream (.. ) )
32
51
import Stack.Types.NamedComponent
33
- ( NamedComponent , isCBench , isCExe , isCTest
52
+ ( NamedComponent , isCBench , isCExe , isCSubLib , isCTest
34
53
, renderPkgComponent
35
54
)
55
+ import Stack.Types.Package ( LocalPackage (.. ), Package (.. ) )
36
56
import Stack.Types.Runner ( Runner )
37
57
import Stack.Types.SourceMap
38
58
( ProjectPackage (.. ), SMWanted (.. ), ppComponentsMaybe )
39
59
import System.IO ( putStrLn )
40
60
61
+ -- | Type representing exceptions thrown by functions exported by the
62
+ -- "Stack.IDE" module.
63
+ newtype IdeException
64
+ = MissingFileTarget String
65
+ deriving (Show , Typeable )
66
+
67
+ instance Exception IdeException where
68
+ displayException (MissingFileTarget name) =
69
+ " Error: [S-9208]\n "
70
+ ++ " Cannot find file target " ++ name ++ " ."
71
+
41
72
-- | Function underlying the @stack ide packages@ command. List packages in the
42
73
-- project.
43
74
idePackagesCmd :: (OutputStream , ListPackagesCmd ) -> RIO Runner ()
@@ -93,3 +124,79 @@ listTargets stream isCompType = do
93
124
toNameAndComponent pkgName' =
94
125
fmap (map (pkgName',) . Set. toList) . ppComponentsMaybe (\ x ->
95
126
if isCompType x then Just x else Nothing )
127
+
128
+ -- | Function underlying the @stack ide ghc-options@ command.
129
+ ideGhcOptionsCmd :: Text -> RIO Runner ()
130
+ ideGhcOptionsCmd rawTarget =
131
+ let boptsCLI = defaultBuildOptsCLI { initialBuildSteps = True }
132
+ in withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ do
133
+ bopts <- view buildOptsL
134
+ -- override env so running of tests and benchmarks is disabled
135
+ let boptsLocal = bopts
136
+ { testOpts = bopts. testOpts { TestOpts. runTests = False }
137
+ , benchmarkOpts =
138
+ bopts. benchmarkOpts { BenchmarkOpts. runBenchmarks = False }
139
+ }
140
+ local (set buildOptsL boptsLocal) (ideGhcOptions rawTarget)
141
+
142
+ ideGhcOptions :: HasEnvConfig env => Text -> RIO env ()
143
+ ideGhcOptions rawTarget = do
144
+ sourceMap <- view $ envConfigL . to (. sourceMap)
145
+ installMap <- toInstallMap sourceMap
146
+ locals <- projectLocalPackages
147
+ depLocals <- localDependencies
148
+ let localMap =
149
+ M. fromList [(lp. package. name, lp) | lp <- locals ++ depLocals]
150
+ -- Parse to either file targets or build targets
151
+ mTarget <- preprocessTarget rawTarget
152
+ (inputTargets, mfileTargets) <- case mTarget of
153
+ Nothing -> pure (mempty , Nothing )
154
+ Just rawFileTarget -> do
155
+ -- Figure out targets based on filepath targets
156
+ (targetMap, fileInfo, extraFiles) <- findFileTargets locals [rawFileTarget]
157
+ pure (targetMap, Just (fileInfo, extraFiles))
158
+ -- Get a list of all the local target packages.
159
+ (directlyWanted, extraLoadDeps) <-
160
+ getAllLocalTargets True inputTargets Nothing localMap
161
+ -- Get a list of all the non-local target packages.
162
+ nonLocalTargets <- getAllNonLocalTargets inputTargets
163
+ let localTargets = directlyWanted <> extraLoadDeps
164
+ getInternalDependencies target localPackage =
165
+ topSortPackageComponent localPackage. package target False
166
+ internalDependencies =
167
+ M. intersectionWith getInternalDependencies inputTargets localMap
168
+ relevantDependencies = M. filter (any isCSubLib) internalDependencies
169
+ -- Load package descriptions.
170
+ pkgDescs <- loadGhciPkgDescs defaultBuildOptsCLI localTargets
171
+ pkgs <- getGhciPkgInfos installMap [] (fmap fst mfileTargets) pkgDescs
172
+ (omittedOpts, pkgopts, macros) <-
173
+ optsAndMacros
174
+ Nothing
175
+ localTargets
176
+ pkgs
177
+ nonLocalTargets
178
+ relevantDependencies
179
+ let outputDivider = liftIO $ putStrLn " ---"
180
+ outputDivider
181
+ mapM_ (liftIO . putStrLn ) pkgopts
182
+ outputDivider
183
+ liftIO $ BS. putStr macros
184
+ outputDivider
185
+ mapM_ (liftIO . putStrLn ) omittedOpts
186
+ outputDivider
187
+
188
+ preprocessTarget ::
189
+ HasEnvConfig env
190
+ => Text
191
+ -> RIO env (Maybe (Path Abs File ))
192
+ preprocessTarget rawTarget =
193
+ if " .hs" `T.isSuffixOf` rawTarget || " .lhs" `T.isSuffixOf` rawTarget
194
+ then do
195
+ fileTarget <- do
196
+ let fp = T. unpack rawTarget
197
+ mpath <- forgivingResolveFile' fp
198
+ case mpath of
199
+ Nothing -> throwM (MissingFileTarget fp)
200
+ Just path -> pure path
201
+ pure (Just fileTarget)
202
+ else pure Nothing
0 commit comments