Merge pull request #6734 from phadej/add-project-flags

Add ProjectFlags, use in sdist
haskell · Apr 28, 2020 · 05b8dfa · 05b8dfa
2 parents 1a6dbcf + 78da242
commit 05b8dfa
Show file tree

Hide file tree

Showing 7 changed files with 94 additions and 43 deletions.
diff --git a/Cabal/Distribution/Simple/Command.hs b/Cabal/Distribution/Simple/Command.hs
@@ -56,7 +56,7 @@ module Distribution.Simple.Command (
   option, multiOption,
 
 -- ** Liftings & Projections
-  liftOption,
+  liftOption, liftOptionL,
 
 -- * Option Descriptions
   OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder,
@@ -74,6 +74,7 @@ import Distribution.Compat.Prelude hiding (get)
 import qualified Distribution.GetOpt as GetOpt
 import Distribution.ReadE
 import Distribution.Simple.Utils
+import Distribution.Compat.Lens (ALens', (^#), (#~))
 
 
 data CommandUI flags = CommandUI {
@@ -251,6 +252,10 @@ liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b
 liftOption get' set' opt =
   opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt}
 
+-- | @since 3.4.0.0
+liftOptionL :: ALens' b a -> OptionField a -> OptionField b
+liftOptionL l = liftOption (^# l) (l #~)
+
 
 liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b
 liftOptDescr get' set' (ChoiceOpt opts) =

diff --git a/cabal-install/Distribution/Client/CmdSdist.hs b/cabal-install/Distribution/Client/CmdSdist.hs
@@ -6,7 +6,6 @@
 {-# LANGUAGE ViewPatterns      #-}
 module Distribution.Client.CmdSdist
     ( sdistCommand, sdistAction, packageToSdist
-    , SdistFlags(..), defaultSdistFlags
     , OutputFormat(..)) where
 
 import Prelude ()
@@ -20,7 +19,7 @@ import Distribution.Client.TargetSelector
     ( TargetSelector(..), ComponentKind
     , readTargetSelectors, reportTargetSelectorProblems )
 import Distribution.Client.Setup
-    ( GlobalFlags(..) )
+    ( GlobalFlags(..), InstallFlags (installProjectFileName) )
 import Distribution.Solver.Types.SourcePackage
     ( SourcePackage(..) )
 import Distribution.Client.Types
@@ -29,7 +28,11 @@ import Distribution.Client.DistDirLayout
     ( DistDirLayout(..), ProjectRoot (..) )
 import Distribution.Client.ProjectConfig
     ( ProjectConfig, withProjectOrGlobalConfigIgn, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared )
+import Distribution.Client.ProjectFlags
+     ( ProjectFlags (..), defaultProjectFlags, projectFlagsOptions )
 
+import Distribution.Compat.Lens
+    ( _1, _2 )
 import Distribution.Package
     ( Package(packageId) )
 import Distribution.PackageDescription.Configuration
@@ -39,7 +42,7 @@ import Distribution.Pretty
 import Distribution.ReadE
     ( succeedReadE )
 import Distribution.Simple.Command
-    ( CommandUI(..), option, reqArg )
+    ( CommandUI(..), OptionField, option, reqArg, liftOptionL, ShowOrParseArgs )
 import Distribution.Simple.PreProcess
     ( knownSuffixHandlers )
 import Distribution.Simple.Setup
@@ -78,7 +81,11 @@ import System.Directory
 import System.FilePath
     ( (</>), (<.>), makeRelative, normalise, takeDirectory )
 
-sdistCommand :: CommandUI SdistFlags
+-------------------------------------------------------------------------------
+-- Command
+-------------------------------------------------------------------------------
+
+sdistCommand :: CommandUI (ProjectFlags, SdistFlags)
 sdistCommand = CommandUI
     { commandName = "v2-sdist"
     , commandSynopsis = "Generate a source distribution file (.tar.gz)."
@@ -87,41 +94,19 @@ sdistCommand = CommandUI
     , commandDescription  = Just $ \_ -> wrapText
         "Generates tarballs of project packages suitable for upload to Hackage."
     , commandNotes = Nothing
-    , commandDefaultFlags = defaultSdistFlags
+    , commandDefaultFlags = (defaultProjectFlags, defaultSdistFlags)
     , commandOptions = \showOrParseArgs ->
-        [ optionVerbosity
-            sdistVerbosity (\v flags -> flags { sdistVerbosity = v })
-        , optionDistPref
-            sdistDistDir (\dd flags -> flags { sdistDistDir = dd })
-            showOrParseArgs
-        , option [] ["project-file"]
-            "Set the name of the cabal.project file to search for in parent directories"
-            sdistProjectFile (\pf flags -> flags { sdistProjectFile = pf })
-            (reqArg "FILE" (succeedReadE Flag) flagToList)
-        , option ['z'] ["ignore-project"]
-            "Ignore local project configuration"
-            sdistIgnoreProject (\v flags -> flags { sdistIgnoreProject = v })
-            trueArg
-        , option ['l'] ["list-only"]
-            "Just list the sources, do not make a tarball"
-            sdistListSources (\v flags -> flags { sdistListSources = v })
-            trueArg
-        , option [] ["null-sep"]
-            "Separate the source files with NUL bytes rather than newlines."
-            sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v })
-            trueArg
-        , option ['o'] ["output-directory", "outputdir"]
-            "Choose the output directory of this command. '-' sends all output to stdout"
-            sdistOutputPath (\o flags -> flags { sdistOutputPath = o })
-            (reqArg "PATH" (succeedReadE Flag) flagToList)
-        ]
+        map (liftOptionL _1) projectFlagsOptions ++
+        map (liftOptionL _2) (sdistOptions showOrParseArgs)
     }
 
+-------------------------------------------------------------------------------
+-- Flags
+-------------------------------------------------------------------------------
+
 data SdistFlags = SdistFlags
     { sdistVerbosity     :: Flag Verbosity
     , sdistDistDir       :: Flag FilePath
-    , sdistProjectFile   :: Flag FilePath
-    , sdistIgnoreProject :: Flag Bool
     , sdistListSources   :: Flag Bool
     , sdistNulSeparated  :: Flag Bool
     , sdistOutputPath    :: Flag FilePath
@@ -131,17 +116,38 @@ defaultSdistFlags :: SdistFlags
 defaultSdistFlags = SdistFlags
     { sdistVerbosity     = toFlag normal
     , sdistDistDir       = mempty
-    , sdistProjectFile   = mempty
-    , sdistIgnoreProject = toFlag False
     , sdistListSources   = toFlag False
     , sdistNulSeparated  = toFlag False
     , sdistOutputPath    = mempty
     }
 
---
-
-sdistAction :: SdistFlags -> [String] -> GlobalFlags -> IO ()
-sdistAction SdistFlags{..} targetStrings globalFlags = do
+sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags]
+sdistOptions showOrParseArgs =
+    [ optionVerbosity
+        sdistVerbosity (\v flags -> flags { sdistVerbosity = v })
+    , optionDistPref
+        sdistDistDir (\dd flags -> flags { sdistDistDir = dd })
+        showOrParseArgs
+    , option ['l'] ["list-only"]
+        "Just list the sources, do not make a tarball"
+        sdistListSources (\v flags -> flags { sdistListSources = v })
+        trueArg
+    , option [] ["null-sep"]
+        "Separate the source files with NUL bytes rather than newlines."
+        sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v })
+        trueArg
+    , option ['o'] ["output-directory", "outputdir"]
+        "Choose the output directory of this command. '-' sends all output to stdout"
+        sdistOutputPath (\o flags -> flags { sdistOutputPath = o })
+        (reqArg "PATH" (succeedReadE Flag) flagToList)
+    ]
+
+-------------------------------------------------------------------------------
+-- Action
+-------------------------------------------------------------------------------
+
+sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO ()
+sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do
     (baseCtx, distDirLayout) <- withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag withProject withoutProject
 
     let localPkgs = localPackages baseCtx
@@ -191,14 +197,14 @@ sdistAction SdistFlags{..} targetStrings globalFlags = do
     listSources    = fromFlagOrDefault False sdistListSources
     nulSeparated   = fromFlagOrDefault False sdistNulSeparated
     mOutputPath    = flagToMaybe sdistOutputPath
-    ignoreProject  = fromFlagOrDefault False sdistIgnoreProject
+    ignoreProject  = fromFlagOrDefault False flagIgnoreProject
 
     prjConfig :: ProjectConfig
     prjConfig = commandLineFlagsToProjectConfig
         globalFlags
         mempty { configVerbosity = sdistVerbosity, configDistPref = sdistDistDir }
         mempty
-        mempty
+        mempty { installProjectFileName = flagProjectFileName }
         mempty
         mempty
         mempty

diff --git a/cabal-install/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/Distribution/Client/ProjectConfig/Types.hs
@@ -163,6 +163,7 @@ data ProjectConfigShared
        projectConfigDistDir           :: Flag FilePath,
        projectConfigConfigFile        :: Flag FilePath,
        projectConfigProjectFile       :: Flag FilePath,
+       -- projectConfigIgnoreProjectFile :: Flag Bool, -- TODO
        projectConfigHcFlavor          :: Flag CompilerFlavor,
        projectConfigHcPath            :: Flag FilePath,
        projectConfigHcPkg             :: Flag FilePath,

diff --git a/cabal-install/Distribution/Client/ProjectFlags.hs b/cabal-install/Distribution/Client/ProjectFlags.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE MultiWayIf        #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Distribution.Client.ProjectFlags (
+    ProjectFlags(..),
+    defaultProjectFlags,
+    projectFlagsOptions,
+) where
+
+import Distribution.Client.Compat.Prelude
+import Prelude ()
+
+import Distribution.ReadE          (succeedReadE)
+import Distribution.Simple.Command (OptionField, option, reqArg)
+import Distribution.Simple.Setup   (Flag (..), toFlag, trueArg, flagToList)
+
+data ProjectFlags = ProjectFlags
+    { flagProjectFileName :: Flag FilePath
+    , flagIgnoreProject   :: Flag Bool
+    }
+
+defaultProjectFlags :: ProjectFlags
+defaultProjectFlags = ProjectFlags
+    { flagProjectFileName = mempty
+    , flagIgnoreProject   = toFlag False
+    }
+
+projectFlagsOptions :: [OptionField ProjectFlags]
+projectFlagsOptions =
+    [ option [] ["project-file"]
+        "Set the name of the cabal.project file to search for in parent directories"
+        flagProjectFileName (\pf flags -> flags { flagProjectFileName = pf })
+        (reqArg "FILE" (succeedReadE Flag) flagToList)
+    , option ['z'] ["ignore-project"]
+        "Ignore local project configuration"
+        flagIgnoreProject (\v flags -> flags { flagIgnoreProject = v })
+        trueArg
+    ]
diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs
@@ -1767,7 +1767,7 @@ data InstallFlags = InstallFlags {
     -- read and written out in some cases.  If the path is not found
     -- in the current working directory, we will successively probe
     -- relative to parent directories until this name is found.
-    installProjectFileName   :: Flag FilePath
+    installProjectFileName   :: Flag FilePath -- TODO: use ProjectFlags
   }
   deriving (Eq, Generic)
 

diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
@@ -229,6 +229,7 @@ executable cabal
         Distribution.Client.ProjectConfig
         Distribution.Client.ProjectConfig.Legacy
         Distribution.Client.ProjectConfig.Types
+        Distribution.Client.ProjectFlags
         Distribution.Client.ProjectOrchestration
         Distribution.Client.ProjectPlanOutput
         Distribution.Client.ProjectPlanning

diff --git a/cabal-install/cabal-install.cabal.pp b/cabal-install/cabal-install.cabal.pp
@@ -168,6 +168,7 @@
         Distribution.Client.ProjectConfig
         Distribution.Client.ProjectConfig.Legacy
         Distribution.Client.ProjectConfig.Types
+        Distribution.Client.ProjectFlags
         Distribution.Client.ProjectOrchestration
         Distribution.Client.ProjectPlanOutput
         Distribution.Client.ProjectPlanning