Implement stack ide ghc-options command

Author: mpilgrem

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,62 @@ 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 exceptions thrown by functions exported by the
+-- "Stack.IDE" module.
+newtype IdeException
+  = MissingFileTarget String
+  deriving (Show, Typeable)
+
+instance Exception IdeException where
+  displayException (MissingFileTarget name) =
+    "Error: [S-9208]\n"
+    ++ "Cannot find file target " ++ name ++ "."
+
 -- | Function underlying the @stack ide packages@ command. List packages in the
 -- project.
 idePackagesCmd :: (OutputStream, ListPackagesCmd) -> RIO Runner ()
@@ -93,3 +124,79 @@ 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
+  mTarget <- preprocessTarget rawTarget
+  (inputTargets, mfileTargets) <- case mTarget of
+    Nothing -> pure (mempty, Nothing)
+    Just rawFileTarget -> do
+      -- Figure out targets based on filepath targets
+      (targetMap, fileInfo, extraFiles) <- findFileTargets locals [rawFileTarget]
+      pure (targetMap, Just (fileInfo, extraFiles))
+  -- 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 defaultBuildOptsCLI 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
+
+preprocessTarget ::
+     HasEnvConfig env
+  => Text
+  -> RIO env (Maybe (Path Abs File))
+preprocessTarget rawTarget =
+  if ".hs" `T.isSuffixOf` rawTarget || ".lhs" `T.isSuffixOf` rawTarget
+    then do
+      fileTarget <- do
+        let fp = T.unpack rawTarget
+        mpath <- forgivingResolveFile' fp
+        case mpath of
+          Nothing -> throwM (MissingFileTarget fp)
+          Just path -> pure path
+      pure (Just fileTarget)
+    else pure Nothing

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