Implement stack ide ghc-options command

Author: mpilgrem

doc/maintainers/stack_errors.md

@@ -156,6 +156,12 @@ to take stock of the errors that Stack itself can raise, by reference to the
         [S-3025] | HoogleDatabaseNotFound
         ~~~
 
+    -   `Stack.IDE.IdePrettyException`
+
+        ~~~haskell
+        [S-9208] = FileTargetIsInvalidAbsFile
+        ~~~
+
     -   `Stack.Init.InitException`
 
         ~~~haskell

src/Stack/CLI.hs

@@ -49,7 +49,7 @@ import           Stack.Exec ( SpecialExecCmd (..), execCmd )
 import           Stack.Eval ( evalCmd )
 import           Stack.Ghci ( ghciCmd )
 import           Stack.Hoogle ( hoogleCmd )
-import           Stack.IDE ( idePackagesCmd, ideTargetsCmd )
+import           Stack.IDE ( ideGhcOptionsCmd, idePackagesCmd, ideTargetsCmd )
 import           Stack.Init ( initCmd )
 import           Stack.List ( listCmd )
 import           Stack.Ls ( lsCmd )
@@ -65,7 +65,8 @@ import           Stack.Options.ExecParser ( execOptsParser )
 import           Stack.Options.GhciParser ( ghciOptsParser )
 import           Stack.Options.GlobalParser ( globalOptsParser )
 import           Stack.Options.HpcReportParser ( hpcReportOptsParser )
-import           Stack.Options.IdeParser ( idePackagesParser, ideTargetsParser )
+import           Stack.Options.IdeParser
+                   ( ideGhcOptionsParser, idePackagesParser, ideTargetsParser )
 import           Stack.Options.InitParser ( initOptsParser )
 import           Stack.Options.LsParser ( lsOptsParser )
 import           Stack.Options.NewParser ( newOptsParser )
@@ -368,6 +369,12 @@ commandLineHandler currentDir progName mExecutablePath isInterpreter =
           "List all targets or pick component types to list."
           ideTargetsCmd
           ideTargetsParser
+        addCommand'
+          "ghc-options"
+          "List, on the standard output stream, GHC options and other \
+          \information passed to GHCi for a given Haskell source code file."
+          ideGhcOptionsCmd
+          ideGhcOptionsParser
     )
 
   init = addCommand'

src/Stack/IDE.hs

@@ -1,6 +1,8 @@
-{-# LANGUAGE NoImplicitPrelude   #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NoFieldSelectors      #-}
+{-# LANGUAGE OverloadedRecordDot   #-}
+{-# LANGUAGE OverloadedStrings     #-}
 
 {-|
 Module      : Stack.IDE
@@ -11,33 +13,68 @@ Types and functions related to Stack's @ide@ command.
 -}
 
 module Stack.IDE
-  ( OutputStream (..)
-  , ListPackagesCmd (..)
-  , idePackagesCmd
+  ( idePackagesCmd
   , ideTargetsCmd
-  , listPackages
-  , listTargets
+  , ideGhcOptionsCmd
   ) where
 
+import qualified Data.ByteString as BS
 import qualified Data.Map as Map
+import qualified Data.Map.Strict as M
 import qualified Data.Set as Set
 import qualified Data.Text as T
 import           Data.Tuple ( swap )
+import           Stack.Build.FileTargets
+                   ( findFileTargets, getAllLocalTargets, getAllNonLocalTargets
+                   , getGhciPkgInfos, loadGhciPkgDescs, optsAndMacros
+                   )
+import           Stack.Build.Installed ( toInstallMap )
+import           Stack.Build.Source ( localDependencies, projectLocalPackages )
+import           Stack.Build.Target ( NeedTargets (..) )
+import           Stack.Package ( topSortPackageComponent )
+import           Path.Extra ( forgivingResolveFile' )
 import           Stack.Prelude
 import           Stack.Runners
-                   ( ShouldReexec (..), withBuildConfig, withConfig )
+                   ( ShouldReexec (..), withBuildConfig, withConfig
+                   , withEnvConfig
+                   )
 import           Stack.Types.BuildConfig
                    ( BuildConfig (..), HasBuildConfig (..) )
+import           Stack.Types.BuildOpts ( BuildOpts (..) )
+import qualified Stack.Types.BuildOpts as BenchmarkOpts ( BenchmarkOpts (..) )
+import qualified Stack.Types.BuildOpts as TestOpts ( TestOpts (..) )
+import           Stack.Types.BuildOptsCLI
+                   ( BuildOptsCLI (..), defaultBuildOptsCLI )
+import           Stack.Types.Config ( buildOptsL )
+import           Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..) )
 import           Stack.Types.IdeOpts ( ListPackagesCmd (..), OutputStream (..) )
 import           Stack.Types.NamedComponent
-                   ( NamedComponent, isCBench, isCExe, isCTest
+                   ( NamedComponent, isCBench, isCExe, isCSubLib, isCTest
                    , renderPkgComponent
                    )
+import           Stack.Types.Package ( LocalPackage (..), Package (..) )
 import           Stack.Types.Runner ( Runner )
 import           Stack.Types.SourceMap
                    ( ProjectPackage (..), SMWanted (..), ppComponentsMaybe )
 import           System.IO ( putStrLn )
 
+-- | Type representing \'pretty\' exceptions thrown by functions exported by the
+-- "Stack.IDE" module.
+newtype IdePrettyException
+  = FileTargetIsInvalidAbsFile String
+  deriving (Show, Typeable)
+
+instance Pretty IdePrettyException where
+  pretty (FileTargetIsInvalidAbsFile name) =
+       "[S-9208]"
+    <> line
+    <> fillSep
+         [ flow "Cannot work out a valid path for file target"
+         , style File (fromString name) <> "."
+         ]
+
+instance Exception IdePrettyException
+
 -- | Function underlying the @stack ide packages@ command. List packages in the
 -- project.
 idePackagesCmd :: (OutputStream, ListPackagesCmd) -> RIO Runner ()
@@ -93,3 +130,70 @@ listTargets stream isCompType = do
   toNameAndComponent pkgName' =
     fmap (map (pkgName',) . Set.toList) . ppComponentsMaybe (\x ->
       if isCompType x then Just x else Nothing)
+
+-- | Function underlying the @stack ide ghc-options@ command.
+ideGhcOptionsCmd :: Text -> RIO Runner ()
+ideGhcOptionsCmd rawTarget =
+  let boptsCLI = defaultBuildOptsCLI { initialBuildSteps = True }
+  in  withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ do
+        bopts <- view buildOptsL
+        -- override env so running of tests and benchmarks is disabled
+        let boptsLocal = bopts
+              { testOpts = bopts.testOpts { TestOpts.runTests = False }
+              , benchmarkOpts =
+                  bopts.benchmarkOpts { BenchmarkOpts.runBenchmarks = False }
+              }
+        local (set buildOptsL boptsLocal) (ideGhcOptions rawTarget)
+
+ideGhcOptions :: HasEnvConfig env => Text -> RIO env ()
+ideGhcOptions rawTarget = do
+  sourceMap <- view $ envConfigL . to (.sourceMap)
+  installMap <- toInstallMap sourceMap
+  locals <- projectLocalPackages
+  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
+    (pure (mempty, Nothing))
+    -- Figure out targets based on file target
+    (findFileTargets locals . pure)
+  -- Get a list of all the local target packages.
+  (directlyWanted, extraLoadDeps) <-
+    getAllLocalTargets True inputTargets Nothing localMap
+  -- Get a list of all the non-local target packages.
+  nonLocalTargets <- getAllNonLocalTargets inputTargets
+  let localTargets = directlyWanted <> extraLoadDeps
+      getInternalDependencies target localPackage =
+        topSortPackageComponent localPackage.package target False
+      internalDependencies =
+        M.intersectionWith getInternalDependencies inputTargets localMap
+      relevantDependencies = M.filter (any isCSubLib) internalDependencies
+  -- Load package descriptions.
+  pkgDescs <- loadGhciPkgDescs mempty localTargets
+  pkgs <- getGhciPkgInfos installMap [] (fmap fst mfileTargets) pkgDescs
+  (omittedOpts, pkgopts, macros) <-
+    optsAndMacros
+      Nothing
+      localTargets
+      pkgs
+      nonLocalTargets
+      relevantDependencies
+  let outputDivider = liftIO $ putStrLn "---"
+  outputDivider
+  mapM_ (liftIO . putStrLn) pkgopts
+  outputDivider
+  liftIO $ BS.putStr macros
+  outputDivider
+  mapM_ (liftIO . putStrLn) omittedOpts
+  outputDivider
+
+processRawTarget :: HasEnvConfig env => Text -> RIO env (Maybe (Path Abs File))
+processRawTarget rawTarget =
+  if ".hs" `T.isSuffixOf` rawTarget || ".lhs" `T.isSuffixOf` rawTarget
+    then
+      forgivingResolveFile' rawTarget' >>= maybe
+          (prettyThrowM $ FileTargetIsInvalidAbsFile rawTarget')
+          (pure . Just)
+    else pure Nothing
+ where
+  rawTarget' = T.unpack rawTarget

src/Stack/Options/IdeParser.hs

@@ -12,9 +12,13 @@ Functions to parse command line arguments for Stack's @ide@ commands.
 module Stack.Options.IdeParser
   ( idePackagesParser
   , ideTargetsParser
+  , ideGhcOptionsParser
   ) where
 
-import           Options.Applicative ( Parser, flag, help, long, switch )
+import           Options.Applicative
+                   ( Parser, completer, flag, help, long, metavar, switch )
+import           Options.Applicative.Builder.Extra
+                   ( fileExtCompleter, textArgument )
 import           Stack.Prelude
 import           Stack.Types.IdeOpts ( ListPackagesCmd (..), OutputStream (..) )
 
@@ -27,6 +31,13 @@ ideTargetsParser :: Parser ((Bool, Bool, Bool), OutputStream)
 ideTargetsParser =
   (,) <$> ((,,) <$> exeFlag <*> testFlag <*> benchFlag) <*> outputFlag
 
+-- | Parse command line arguments for Stack's @ide ghc-options@ command.
+ideGhcOptionsParser :: Parser Text
+ideGhcOptionsParser = textArgument
+  (  metavar "FILE"
+  <> completer (fileExtCompleter [".hs", ".lhs"])
+  )
+
 outputFlag :: Parser OutputStream
 outputFlag = flag
   OutputLogInfo