Take n+1, filtering rather than adding v1-

typedrat · typedrat · commit 64d5b92ec921 · 2018-06-11T15:04:03.000-07:00
diff --git a/cabal-install/Distribution/Client/CmdLegacy.hs b/cabal-install/Distribution/Client/CmdLegacy.hs
@@ -1,16 +1,19 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns #-}
 module Distribution.Client.CmdLegacy (legacyCmd) where
 
 import Prelude ()
 import Distribution.Client.Compat.Prelude
 
+import qualified Distribution.Client.Setup as Client
+import qualified Distribution.Simple.Setup as Setup
 import Distribution.Simple.Command
 import Distribution.Simple.Utils
     ( warn )
 import Distribution.Verbosity 
-    ( normal )
+    ( Verbosity, normal )
 
 import qualified Data.Text as T
 
@@ -28,46 +31,67 @@ deprecationNote cmd =
     "cabal-install. Please file a bug if you cannot replicate a working v1- use\n" ++
     "case with the new-style commands.\n"
 
+--
 
-oldCommands :: [(T.Text, T.Text)]
-oldCommands = (\c -> (c, "v1-" `T.append` c)) <$> cmds
-    where 
-        cmds = 
-            [ "build"
-            , "configure"
-            , "repl"
-            , "freeze"
-            , "run"
-            , "test"
-            , "bench"
-            , "haddock"
-            , "exec"
-            , "update"
-            , "install"
-            ]
-
-legacyCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]
+class HasVerbosity a where 
+    verbosity :: a -> Verbosity
+
+instance HasVerbosity (Setup.Flag Verbosity) where
+    verbosity = Setup.fromFlagOrDefault normal
+
+instance (HasVerbosity a) => HasVerbosity (a, b) where
+    verbosity (a, _) = verbosity a
+
+instance (HasVerbosity b) => HasVerbosity (a, b, c) where
+    verbosity (_ , b, _) = verbosity b
+
+instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where
+    verbosity (a, _, _, _) = verbosity a
+
+instance HasVerbosity Setup.BuildFlags where
+    verbosity = verbosity . Setup.buildVerbosity
+
+instance HasVerbosity Setup.ConfigFlags where
+    verbosity = verbosity . Setup.configVerbosity
+
+instance HasVerbosity Setup.ReplFlags where
+    verbosity = verbosity . Setup.replVerbosity
+
+instance HasVerbosity Client.FreezeFlags where
+    verbosity = verbosity . Client.freezeVerbosity
+
+instance HasVerbosity Setup.HaddockFlags where
+    verbosity = verbosity . Setup.haddockVerbosity
+
+instance HasVerbosity Client.ExecFlags where
+    verbosity = verbosity . Client.execVerbosity
+
+instance HasVerbosity Client.UpdateFlags where
+    verbosity = verbosity . Client.updateVerbosity
+
+--
+
+legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]
 legacyCmd origUi@CommandUI{..} action = [makeCmd legacyUi legacyAction, makeCmd aliasedUi action]
     where
-        updateMsg msg = T.unpack $ foldr (\(old, new) str -> T.replace old new str) (T.pack msg) oldCommands
-
-        legacyMsg msg = T.unpack $ foldr (\(new, old) str -> T.replace old new str) (T.pack msg) oldCommands
+        legacyMsg = T.unpack . T.replace "v1-" "" . T.pack
 
         note = deprecationNote commandName
 
-        legacyAction flags extra globals = warn normal (note ++ "\n") >> action flags extra globals
+        legacyAction flags extra globals = warn (verbosity flags) (note ++ "\n") >> action flags extra globals
 
-        legacyUi = origUi 
-            { commandNotes = Just $ \pname -> case commandNotes of
-                Just notes -> legacyMsg (notes pname) ++ "\n" ++ note
+        aliasedUi = origUi 
+            { commandName = "v1-" ++ commandName
+            , commandNotes = Just $ \pname -> case commandNotes of
+                Just notes -> notes pname ++ "\n" ++ note
                 Nothing -> note
             }
         
-        aliasedUi = origUi
-            { commandName = updateMsg commandName
-            , commandUsage = updateMsg . commandUsage
-            , commandDescription = (updateMsg .) <$> commandDescription
+        legacyUi = origUi
+            { commandName = legacyMsg commandName
+            , commandUsage = legacyMsg . commandUsage
+            , commandDescription = (legacyMsg .) <$> commandDescription
             , commandNotes = Just $ \pname -> case commandNotes of
-                Just notes -> notes pname ++ "\n" ++ note
+                Just notes -> legacyMsg (notes pname) ++ "\n" ++ note
                 Nothing -> note
             }
diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs
@@ -49,6 +49,7 @@ module Distribution.Client.Setup
     , execCommand, ExecFlags(..), defaultExecFlags
     , userConfigCommand, UserConfigFlags(..)
     , manpageCommand
+    , haddockCommand
 
     , parsePackageArgs
     --TODO: stop exporting these:
@@ -402,15 +403,24 @@ globalCommand commands = CommandUI {
 
 configureCommand :: CommandUI ConfigFlags
 configureCommand = c
-  { commandDefaultFlags = mempty
+  { commandName         = "v1-configure"
+  , commandDefaultFlags = mempty
+  , commandDescription  = Just $ \_ -> wrapText $
+         "Configure how the package is built by setting "
+      ++ "package (and other) flags.\n"
+      ++ "\n"
+      ++ "The configuration affects several other commands, "
+      ++ "including v1-build, v1-test, v1-bench, v1-run, v1-repl.\n"
+  , commandUsage        = \pname ->
+    "Usage: " ++ pname ++ " v1-configure [FLAGS]\n"
   , commandNotes = Just $ \pname -> 
-      (Cabal.programFlagsDescription defaultProgramDb ++ "\n")
-       ++ "Examples:\n"
-       ++ "  " ++ pname ++ " v1-configure\n"
-       ++ "    Configure with defaults;\n"
-       ++ "  " ++ pname ++ " v1-configure --enable-tests -fcustomflag\n"
-       ++ "    Configure building package including tests,\n"
-       ++ "    with some package-specific flag.\n"
+    (Cabal.programFlagsDescription defaultProgramDb ++ "\n")
+      ++ "Examples:\n"
+      ++ "  " ++ pname ++ " v1-configure\n"
+      ++ "    Configure with defaults;\n"
+      ++ "  " ++ pname ++ " v1-configure --enable-tests -fcustomflag\n"
+      ++ "    Configure building package including tests,\n"
+      ++ "    with some package-specific flag.\n"
   }
  where
   c = Cabal.configureCommand defaultProgramDb
@@ -680,7 +690,14 @@ buildExOptions _showOrParseArgs =
 
 buildCommand :: CommandUI (BuildFlags, BuildExFlags)
 buildCommand = parent {
+    commandName = "build",
+    commandDescription  = Just $ \_ -> wrapText $
+      "Components encompass executables, tests, and benchmarks.\n"
+        ++ "\n"
+        ++ "Affected by configuration options, see `v1-configure`.\n",
     commandDefaultFlags = (commandDefaultFlags parent, mempty),
+    commandUsage        = usageAlternatives "v1-build" $
+      [ "[FLAGS]", "COMPONENTS [FLAGS]" ],
     commandOptions      =
       \showOrParseArgs -> liftOptions fst setFst
                           (commandOptions parent showOrParseArgs)
@@ -713,6 +730,26 @@ instance Semigroup BuildExFlags where
 
 replCommand :: CommandUI (ReplFlags, BuildExFlags)
 replCommand = parent {
+    commandName = "repl",
+    commandDescription  = Just $ \pname -> wrapText $
+         "If the current directory contains no package, ignores COMPONENT "
+      ++ "parameters and opens an interactive interpreter session; if a "
+      ++ "sandbox is present, its package database will be used.\n"
+      ++ "\n"
+      ++ "Otherwise, (re)configures with the given or default flags, and "
+      ++ "loads the interpreter with the relevant modules. For executables, "
+      ++ "tests and benchmarks, loads the main module (and its "
+      ++ "dependencies); for libraries all exposed/other modules.\n"
+      ++ "\n"
+      ++ "The default component is the library itself, or the executable "
+      ++ "if that is the only component.\n"
+      ++ "\n"
+      ++ "Support for loading specific modules is planned but not "
+      ++ "implemented yet. For certain scenarios, `" ++ pname
+      ++ " v1-exec -- ghci :l Foo` may be used instead. Note that `v1-exec` will "
+      ++ "not (re)configure and you will have to specify the location of "
+      ++ "other modules, if required.\n",
+    commandUsage =  \pname -> "Usage: " ++ pname ++ " v1-repl [COMPONENT] [FLAGS]\n",
     commandDefaultFlags = (commandDefaultFlags parent, mempty),
     commandOptions      =
       \showOrParseArgs -> liftOptions fst setFst
@@ -740,6 +777,19 @@ replCommand = parent {
 
 testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)
 testCommand = parent {
+  commandName = "test",
+  commandDescription  = Just $ \pname -> wrapText $
+         "If necessary (re)configures with `--enable-tests` flag and builds"
+      ++ " the test suite.\n"
+      ++ "\n"
+      ++ "Remember that the tests' dependencies must be installed if there"
+      ++ " are additional ones; e.g. with `" ++ pname
+      ++ " v1-install --only-dependencies --enable-tests`.\n"
+      ++ "\n"
+      ++ "By defining UserHooks in a custom Setup.hs, the package can"
+      ++ " define actions to be executed before and after running tests.\n",
+  commandUsage = usageAlternatives "v1-test"
+      [ "[FLAGS]", "TESTCOMPONENTS [FLAGS]" ],
   commandDefaultFlags = (commandDefaultFlags parent,
                          Cabal.defaultBuildFlags, mempty),
   commandOptions      =
@@ -765,6 +815,20 @@ testCommand = parent {
 
 benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)
 benchmarkCommand = parent {
+  commandName = "bench",
+  commandUsage = usageAlternatives "v1-bench"
+      [ "[FLAGS]", "BENCHCOMPONENTS [FLAGS]" ],
+  commandDescription  = Just $ \pname -> wrapText $
+         "If necessary (re)configures with `--enable-benchmarks` flag and"
+      ++ " builds the benchmarks.\n"
+      ++ "\n"
+      ++ "Remember that the benchmarks' dependencies must be installed if"
+      ++ " there are additional ones; e.g. with `" ++ pname
+      ++ " v1-install --only-dependencies --enable-benchmarks`.\n"
+      ++ "\n"
+      ++ "By defining UserHooks in a custom Setup.hs, the package can"
+      ++ " define actions to be executed before and after running"
+      ++ " benchmarks.\n",
   commandDefaultFlags = (commandDefaultFlags parent,
                          Cabal.defaultBuildFlags, mempty),
   commandOptions      =
@@ -1125,7 +1189,7 @@ updateCommand = CommandUI {
       relevantConfigValuesText ["remote-repo"
                                ,"remote-repo-cache"
                                ,"local-repo"],
-    commandUsage        = usageFlags "update",
+    commandUsage        = usageFlags "v1-update",
     commandDefaultFlags = defaultUpdateFlags,
     commandOptions      = \_ -> [
         optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v }),
@@ -1227,15 +1291,15 @@ runCommand = CommandUI {
       ++ "specified, but the package contains just one executable, that one "
       ++ "is built and executed.\n"
       ++ "\n"
-      ++ "Use `" ++ pname ++ " test --show-details=streaming` to run a "
+      ++ "Use `" ++ pname ++ " v1-test --show-details=streaming` to run a "
       ++ "test-suite and get its full output.\n",
     commandNotes        = Just $ \pname ->
           "Examples:\n"
        ++ "  " ++ pname ++ " v1-run\n"
        ++ "    Run the only executable in the current package;\n"
        ++ "  " ++ pname ++ " v1-run foo -- --fooflag\n"
        ++ "    Works similar to `./foo --fooflag`.\n",
-    commandUsage        = usageAlternatives "run"
+    commandUsage        = usageAlternatives "v1-run"
         ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],
     commandDefaultFlags = mempty,
     commandOptions      =
@@ -1613,7 +1677,7 @@ installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFl
 installCommand = CommandUI {
   commandName         = "install",
   commandSynopsis     = "Install packages.",
-  commandUsage        = usageAlternatives "install" [ "[FLAGS]"
+  commandUsage        = usageAlternatives "v1-install" [ "[FLAGS]"
                                                     , "[FLAGS] PACKAGES"
                                                     ],
   commandDescription  = Just $ \_ -> wrapText $
@@ -1626,12 +1690,12 @@ installCommand = CommandUI {
      ++ " dependencies) (there must be exactly one .cabal file in the current"
      ++ " directory).\n"
      ++ "\n"
-     ++ "When using a sandbox, the flags for `install` only affect the"
+     ++ "When using a sandbox, the flags for `v1-install` only affect the"
      ++ " current command and have no effect on future commands. (To achieve"
-     ++ " that, `configure` must be used.)\n"
-     ++ " In contrast, without a sandbox, the flags to `install` are saved and"
-     ++ " affect future commands such as `build` and `repl`. See the help for"
-     ++ " `configure` for a list of commands being affected.\n"
+     ++ " that, `v1-configure` must be used.)\n"
+     ++ " In contrast, without a sandbox, the flags to `v1-install` are saved and"
+     ++ " affect future commands such as `v1-build` and `v1-repl`. See the help for"
+     ++ " `v1-configure` for a list of commands being affected.\n"
      ++ "\n"
      ++ "Installed executables will by default (and without a sandbox)"
      ++ " be put into `~/.cabal/bin/`."
@@ -1687,6 +1751,13 @@ installCommand = CommandUI {
     get3 (_,_,c,_) = c; set3 c (a,b,_,d) = (a,b,c,d)
     get4 (_,_,_,d) = d; set4 d (a,b,c,_) = (a,b,c,d)
 
+haddockCommand :: CommandUI HaddockFlags
+haddockCommand = Cabal.haddockCommand
+  { commandName  = "v1-haddock"
+  , commandUsage = usageAlternatives "v1-haddock" $
+      [ "[FLAGS]", "COMPONENTS [FLAGS]" ]
+  }
+
 filterHaddockArgs :: [String] -> Version -> [String]
 filterHaddockArgs args cabalLibVersion
   | cabalLibVersion >= mkVersion [2,3,0] = args_latest
@@ -2427,20 +2498,20 @@ execCommand = CommandUI {
        -- TODO: this is too GHC-focused for my liking..
        "A directly invoked GHC will not automatically be aware of any"
     ++ " sandboxes: the GHC_PACKAGE_PATH environment variable controls what"
-    ++ " GHC uses. `" ++ pname ++ " exec` can be used to modify this variable:"
+    ++ " GHC uses. `" ++ pname ++ " v1-exec` can be used to modify this variable:"
     ++ " COMMAND will be executed in a modified environment and thereby uses"
     ++ " the sandbox package database.\n"
     ++ "\n"
     ++ "If there is no sandbox, behaves as identity (executing COMMAND).\n"
     ++ "\n"
     ++ "Note that other " ++ pname ++ " commands change the environment"
     ++ " variable appropriately already, so there is no need to wrap those"
-    ++ " in `" ++ pname ++ " exec`. But with `" ++ pname ++ " exec`, the user"
+    ++ " in `" ++ pname ++ " v1-exec`. But with `" ++ pname ++ " v1-exec`, the user"
     ++ " has more control and can, for example, execute custom scripts which"
     ++ " indirectly execute GHC.\n"
     ++ "\n"
-    ++ "Note that `" ++ pname ++ " repl` is different from `" ++ pname
-    ++ " exec -- ghci` as the latter will not forward any additional flags"
+    ++ "Note that `" ++ pname ++ " v1-repl` is different from `" ++ pname
+    ++ " v1-exec -- ghci` as the latter will not forward any additional flags"
     ++ " being defined in the local package to ghci.\n"
     ++ "\n"
     ++ "See `" ++ pname ++ " sandbox`.\n",
@@ -2454,7 +2525,7 @@ execCommand = CommandUI {
     ++ "    Execute runghc on Foo.hs with runghc configured to use the\n"
     ++ "    sandbox package database (if a sandbox is being used).\n",
   commandUsage        = \pname ->
-       "Usage: " ++ pname ++ " exec [FLAGS] [--] COMMAND [--] [ARGS]\n",
+       "Usage: " ++ pname ++ " v1-exec [FLAGS] [--] COMMAND [--] [ARGS]\n",
 
   commandDefaultFlags = defaultExecFlags,
   commandOptions      = \showOrParseArgs ->
diff --git a/cabal-install/main/Main.hs b/cabal-install/main/Main.hs
@@ -47,11 +47,12 @@ import Distribution.Client.Setup
          , UserConfigFlags(..), userConfigCommand
          , reportCommand
          , manpageCommand
+         , haddockCommand
          )
 import Distribution.Simple.Setup
          ( HaddockTarget(..)
          , DoctestFlags(..), doctestCommand
-         , HaddockFlags(..), haddockCommand, defaultHaddockFlags
+         , HaddockFlags(..), defaultHaddockFlags
          , HscolourFlags(..), hscolourCommand
          , ReplFlags(..)
          , CopyFlags(..), copyCommand
