Skip to content

Commit f83adf1

Browse files
committed
Implement stack ide ghc-options command
1 parent dac84cb commit f83adf1

File tree

3 files changed

+138
-13
lines changed

3 files changed

+138
-13
lines changed

src/Stack/CLI.hs

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -49,7 +49,7 @@ import Stack.Exec ( SpecialExecCmd (..), execCmd )
4949
import Stack.Eval ( evalCmd )
5050
import Stack.Ghci ( ghciCmd )
5151
import Stack.Hoogle ( hoogleCmd )
52-
import Stack.IDE ( idePackagesCmd, ideTargetsCmd )
52+
import Stack.IDE ( ideGhcOptionsCmd, idePackagesCmd, ideTargetsCmd )
5353
import Stack.Init ( initCmd )
5454
import Stack.List ( listCmd )
5555
import Stack.Ls ( lsCmd )
@@ -65,7 +65,8 @@ import Stack.Options.ExecParser ( execOptsParser )
6565
import Stack.Options.GhciParser ( ghciOptsParser )
6666
import Stack.Options.GlobalParser ( globalOptsParser )
6767
import Stack.Options.HpcReportParser ( hpcReportOptsParser )
68-
import Stack.Options.IdeParser ( idePackagesParser, ideTargetsParser )
68+
import Stack.Options.IdeParser
69+
( ideGhcOptionsParser, idePackagesParser, ideTargetsParser )
6970
import Stack.Options.InitParser ( initOptsParser )
7071
import Stack.Options.LsParser ( lsOptsParser )
7172
import Stack.Options.NewParser ( newOptsParser )
@@ -368,6 +369,12 @@ commandLineHandler currentDir progName mExecutablePath isInterpreter =
368369
"List all targets or pick component types to list."
369370
ideTargetsCmd
370371
ideTargetsParser
372+
addCommand'
373+
"ghc-options"
374+
"List, on the standard output stream, GHC options and other \
375+
\information passed to GHCi for a given Haskell source code file."
376+
ideGhcOptionsCmd
377+
ideGhcOptionsParser
371378
)
372379

373380
init = addCommand'

src/Stack/IDE.hs

Lines changed: 117 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
1-
{-# LANGUAGE NoImplicitPrelude #-}
2-
{-# LANGUAGE OverloadedRecordDot #-}
3-
{-# LANGUAGE OverloadedStrings #-}
1+
{-# LANGUAGE NoImplicitPrelude #-}
2+
{-# LANGUAGE DuplicateRecordFields #-}
3+
{-# LANGUAGE NoFieldSelectors #-}
4+
{-# LANGUAGE OverloadedRecordDot #-}
5+
{-# LANGUAGE OverloadedStrings #-}
46

57
{-|
68
Module : Stack.IDE
@@ -11,33 +13,62 @@ Types and functions related to Stack's @ide@ command.
1113
-}
1214

1315
module Stack.IDE
14-
( OutputStream (..)
15-
, ListPackagesCmd (..)
16-
, idePackagesCmd
16+
( idePackagesCmd
1717
, ideTargetsCmd
18-
, listPackages
19-
, listTargets
18+
, ideGhcOptionsCmd
2019
) where
2120

21+
import qualified Data.ByteString as BS
2222
import qualified Data.Map as Map
23+
import qualified Data.Map.Strict as M
2324
import qualified Data.Set as Set
2425
import qualified Data.Text as T
2526
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' )
2636
import Stack.Prelude
2737
import Stack.Runners
28-
( ShouldReexec (..), withBuildConfig, withConfig )
38+
( ShouldReexec (..), withBuildConfig, withConfig
39+
, withEnvConfig
40+
)
2941
import Stack.Types.BuildConfig
3042
( 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 (..) )
3150
import Stack.Types.IdeOpts ( ListPackagesCmd (..), OutputStream (..) )
3251
import Stack.Types.NamedComponent
33-
( NamedComponent, isCBench, isCExe, isCTest
52+
( NamedComponent, isCBench, isCExe, isCSubLib, isCTest
3453
, renderPkgComponent
3554
)
55+
import Stack.Types.Package ( LocalPackage (..), Package (..) )
3656
import Stack.Types.Runner ( Runner )
3757
import Stack.Types.SourceMap
3858
( ProjectPackage (..), SMWanted (..), ppComponentsMaybe )
3959
import System.IO ( putStrLn )
4060

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+
4172
-- | Function underlying the @stack ide packages@ command. List packages in the
4273
-- project.
4374
idePackagesCmd :: (OutputStream, ListPackagesCmd) -> RIO Runner ()
@@ -93,3 +124,79 @@ listTargets stream isCompType = do
93124
toNameAndComponent pkgName' =
94125
fmap (map (pkgName',) . Set.toList) . ppComponentsMaybe (\x ->
95126
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

src/Stack/Options/IdeParser.hs

Lines changed: 12 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,9 +12,13 @@ Functions to parse command line arguments for Stack's @ide@ commands.
1212
module Stack.Options.IdeParser
1313
( idePackagesParser
1414
, ideTargetsParser
15+
, ideGhcOptionsParser
1516
) where
1617

17-
import Options.Applicative ( Parser, flag, help, long, switch )
18+
import Options.Applicative
19+
( Parser, completer, flag, help, long, metavar, switch )
20+
import Options.Applicative.Builder.Extra
21+
( fileExtCompleter, textArgument )
1822
import Stack.Prelude
1923
import Stack.Types.IdeOpts ( ListPackagesCmd (..), OutputStream (..) )
2024

@@ -27,6 +31,13 @@ ideTargetsParser :: Parser ((Bool, Bool, Bool), OutputStream)
2731
ideTargetsParser =
2832
(,) <$> ((,,) <$> exeFlag <*> testFlag <*> benchFlag) <*> outputFlag
2933

34+
-- | Parse command line arguments for Stack's @ide ghc-options@ command.
35+
ideGhcOptionsParser :: Parser Text
36+
ideGhcOptionsParser = textArgument
37+
( metavar "FILE"
38+
<> completer (fileExtCompleter [".hs", ".lhs"])
39+
)
40+
3041
outputFlag :: Parser OutputStream
3142
outputFlag = flag
3243
OutputLogInfo

0 commit comments

Comments
 (0)