Reduce code duplication

Moves `packagesParser` into its own module, and uses it in modules `Stack.Options.GhciParser` and `Stack.Options.ScriptParser`.

Creates `loadCommonPackage'` and uses it in `loadCommonPackage` and `loadLocalPackage`.

Also adds missing Haddock documentation.

Author: mpilgrem

package.yaml

@@ -244,6 +244,7 @@ library:
   - Stack.Options.NewParser
   - Stack.Options.NixParser
   - Stack.Options.PackageParser
+  - Stack.Options.PackagesParser
   - Stack.Options.PathParser
   - Stack.Options.PvpBoundsParser
   - Stack.Options.SDistParser

src/Stack/Build/Source.hs

@@ -74,7 +74,7 @@ import           Stack.Types.Platform ( HasPlatform (..) )
 import           Stack.Types.SourceMap
                    ( CommonPackage (..), DepPackage (..), ProjectPackage (..)
                    , SMActual (..), SMTargets (..), SourceMap (..)
-                   , SourceMapHash (..), Target (..), ppGPD, ppRoot
+                   , SourceMapHash (..), Target (..), ppRoot
                    )
 import           Stack.Types.UnusedFlags ( FlagSource (..), UnusedFlags (..) )
 import           System.FilePath ( takeFileName )
@@ -330,18 +330,28 @@ generalGhcOptions bconfig boptsCli isTarget isLocal = concat
       AGOLocals -> isLocal
       AGOEverything -> True
 
+-- | Yield a t'Package' from the settings common to dependency and project
+-- packages.
 loadCommonPackage ::
      forall env. (HasBuildConfig env, HasSourceMap env)
   => CommonPackage
   -> RIO env Package
 loadCommonPackage common = do
+  (_, _, pkg) <- loadCommonPackage' common
+  pure pkg
+
+loadCommonPackage' ::
+     forall env. (HasBuildConfig env, HasSourceMap env)
+  => CommonPackage
+  -> RIO env (PackageConfig, C.GenericPackageDescription, Package)
+loadCommonPackage' common = do
   config <-
     getPackageConfig
       common.flags
       common.ghcOptions
       common.cabalConfigOpts
   gpkg <- liftIO common.gpd
-  pure $ resolvePackage config gpkg
+  pure (config, gpkg, resolvePackage config gpkg)
 
 -- | Upgrade the initial project package info to a full-blown @LocalPackage@
 -- based on the selected components
@@ -354,11 +364,7 @@ loadLocalPackage pp = do
   let common = pp.projectCommon
   bopts <- view buildOptsL
   mcurator <- view $ buildConfigL . to (.curator)
-  config <- getPackageConfig
-              common.flags
-              common.ghcOptions
-              common.cabalConfigOpts
-  gpkg <- ppGPD pp
+  (config, gpkg, pkg) <- loadCommonPackage' common
   let name = common.name
       mtarget = M.lookup name sm.targets.targets
       (exeCandidates, testCandidates, benchCandidates) =
@@ -426,7 +432,6 @@ loadLocalPackage pp = do
       -- --enable-benchmarks or --enable-tests are configured. This allows us to
       -- do an optimization where these are passed if the deps are present. This
       -- can avoid doing later unnecessary reconfigures.
-      pkg = resolvePackage config gpkg
       btpkg
         | Set.null tests && Set.null benches = Nothing
         | otherwise = Just (resolvePackage btconfig gpkg)

src/Stack/Config.hs

@@ -25,7 +25,6 @@ spitting out a warning that "you should run `stk init` to make things better".
 module Stack.Config
   ( loadConfig
   , loadConfigYaml
-  , packagesParser
   , getImplicitGlobalProjectDir
   , getSnapshots
   , makeConcreteSnapshot
@@ -67,7 +66,6 @@ import qualified Hpack
 import           GHC.Conc ( getNumProcessors )
 import           Network.HTTP.StackClient
                    ( httpJSON, parseUrlThrow, getResponseBody )
-import           Options.Applicative ( Parser, help, long, metavar, strOption )
 import           Pantry ( loadSnapshot )
 import           Path
                    ( PathException (..), (</>), parent, parseAbsDir
@@ -1291,32 +1289,27 @@ getDefaultUserConfigPath configRoot = do
     liftIO $ writeBinaryFileAtomic userConfigPath defaultConfigYaml
   pure userConfigPath
 
-packagesParser :: Parser [String]
-packagesParser = many (strOption
-                   (long "package" <>
-                     metavar "PACKAGE" <>
-                     help "Add a package (can be specified multiple times)"))
-
+-- | The contents of the default Stack global configuration file.
 defaultConfigYaml :: (IsString s, Semigroup s) => s
 defaultConfigYaml =
-  "# This file contains default non-project-specific settings for Stack, used\n" <>
-  "# in all projects. For more information about Stack's configuration, see\n" <>
-  "# http://docs.haskellstack.org/en/stable/configure/yaml/\n" <>
-  "\n" <>
-  "# The following parameters are used by 'stack new' to automatically fill fields\n" <>
-  "# in the Cabal file. We recommend uncommenting them and filling them out if\n" <>
-  "# you intend to use 'stack new'.\n" <>
-  "# See https://docs.haskellstack.org/en/stable/configure/yaml/non-project/#templates\n" <>
-  "templates:\n" <>
-  "  params:\n" <>
-  "#    author-name:\n" <>
-  "#    author-email:\n" <>
-  "#    copyright:\n" <>
-  "#    github-username:\n" <>
-  "\n" <>
-  "# The following parameter specifies Stack's output styles; STYLES is a\n" <>
-  "# colon-delimited sequence of key=value, where 'key' is a style name and\n" <>
-  "# 'value' is a semicolon-delimited list of 'ANSI' SGR (Select Graphic\n" <>
-  "# Rendition) control codes (in decimal). Use 'stack ls stack-colors --basic'\n" <>
-  "# to see the current sequence.\n" <>
-  "# stack-colors: STYLES\n"
+  "# This file contains default non-project-specific settings for Stack, used\n\
+  \# in all projects. For more information about Stack's configuration, see\n\
+  \# http://docs.haskellstack.org/en/stable/configure/yaml/\n\
+  \\n\
+  \# The following parameters are used by 'stack new' to automatically fill fields\n\
+  \# in the Cabal file. We recommend uncommenting them and filling them out if\n\
+  \# you intend to use 'stack new'.\n\
+  \# See https://docs.haskellstack.org/en/stable/configure/yaml/non-project/#templates\n\
+  \templates:\n\
+  \  params:\n\
+  \#    author-name:\n\
+  \#    author-email:\n\
+  \#    copyright:\n\
+  \#    github-username:\n\
+  \\n\
+  \# The following parameter specifies Stack's output styles; STYLES is a\n\
+  \# colon-delimited sequence of key=value, where 'key' is a style name and\n\
+  \# 'value' is a semicolon-delimited list of 'ANSI' SGR (Select Graphic\n\
+  \# Rendition) control codes (in decimal). Use 'stack ls stack-colors --basic'\n\
+  \# to see the current sequence.\n\
+  \# stack-colors: STYLES\n"

src/Stack/Options/GhciParser.hs

@@ -19,10 +19,10 @@ import           Options.Applicative.Builder.Extra
                    ( boolFlags, boolFlagsNoDefault, fileExtCompleter
                    , textArgument, textOption
                    )
-import           Stack.Config ( packagesParser )
 import           Stack.Ghci ( GhciOpts (..) )
 import           Stack.Options.Completion ( ghcOptsCompleter, targetCompleter )
 import           Stack.Options.FlagsParser ( flagsParser )
+import           Stack.Options.PackagesParser ( packagesParser )
 import           Stack.Prelude
 
 -- | Parser for GHCI options

src/Stack/Options/PackagesParser.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+{-|
+Module      : Stack.Options.PackagesParser
+Description : Parser for one or more package names.
+License     : BSD-3-Clause
+
+Parser for one or more package names.
+-}
+
+module Stack.Options.PackagesParser
+  ( packagesParser
+  ) where
+
+import           Options.Applicative ( Parser, help, long, metavar, strOption )
+import           Stack.Prelude
+
+-- | Parser for one or more package names.
+packagesParser :: Parser [String]
+packagesParser = many
+  ( strOption
+      (  long "package"
+      <> metavar "PACKAGE"
+      <> help "Add a package (can be specified multiple times)"
+      )
+  )

src/Stack/Options/ScriptParser.hs

@@ -19,18 +19,15 @@ import           Options.Applicative
 import           Options.Applicative.Builder.Extra
                    ( boolFlags, fileExtCompleter )
 import           Stack.Options.Completion ( ghcOptsCompleter )
+import           Stack.Options.PackagesParser ( packagesParser )
 import           Stack.Prelude
 import           Stack.Script
                    ( ScriptExecute (..), ScriptOpts (..), ShouldRun (..) )
 
 -- | Parse command line arguments for Stack's @script@ command.
 scriptOptsParser :: Parser ScriptOpts
 scriptOptsParser = ScriptOpts
-  <$> many (strOption
-        (  long "package"
-        <> metavar "PACKAGE"
-        <> help "Add a package (can be specified multiple times)."
-        ))
+  <$> packagesParser
   <*> strArgument
         (  metavar "FILE"
         <> completer (fileExtCompleter [".hs", ".lhs"])

stack.cabal

@@ -280,6 +280,7 @@ library
       Stack.Options.NewParser
       Stack.Options.NixParser
       Stack.Options.PackageParser
+      Stack.Options.PackagesParser
       Stack.Options.PathParser
       Stack.Options.PvpBoundsParser
       Stack.Options.SDistParser