{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Distribution.Client.CmdLegacy ( legacyCmd, legacyWrapperCmd, newCmd ) where

import Prelude ()
import Distribution.Client.Compat.Prelude

import Distribution.Client.Sandbox
    ( loadConfigOrSandboxConfig, findSavedDistPref )
import qualified Distribution.Client.Setup as Client
import Distribution.Client.SetupWrapper
    ( SetupScriptOptions(..), setupWrapper, defaultSetupScriptOptions )
import qualified Distribution.Simple.Setup as Setup
import Distribution.Simple.Command
import Distribution.Simple.Utils
    ( wrapText )
import Distribution.Verbosity
    ( normal )

import Control.Exception
    ( try )
import qualified Data.Text as T

-- Tweaked versions of code from Main.
regularCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> CommandSpec (globals -> IO action)
regularCmd :: forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [[Char]] -> globals -> IO action)
-> CommandSpec (globals -> IO action)
regularCmd CommandUI flags
ui flags -> [[Char]] -> globals -> IO action
action =
        CommandUI flags
-> (CommandUI flags -> Command (globals -> IO action))
-> CommandType
-> CommandSpec (globals -> IO action)
forall action flags.
CommandUI flags
-> (CommandUI flags -> Command action)
-> CommandType
-> CommandSpec action
CommandSpec CommandUI flags
ui (((CommandUI flags
 -> (flags -> [[Char]] -> globals -> IO action)
 -> Command (globals -> IO action))
-> (flags -> [[Char]] -> globals -> IO action)
-> CommandUI flags
-> Command (globals -> IO action)
forall a b c. (a -> b -> c) -> b -> a -> c
flip CommandUI flags
-> (flags -> [[Char]] -> globals -> IO action)
-> Command (globals -> IO action)
forall flags action.
CommandUI flags -> (flags -> [[Char]] -> action) -> Command action
commandAddAction) (\flags
flags [[Char]]
extra globals
globals -> flags -> [[Char]] -> globals -> IO action
action flags
flags [[Char]]
extra globals
globals)) CommandType
NormalCommand

wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> CommandSpec (Client.GlobalFlags -> IO ())
wrapperCmd :: forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag [Char])
-> CommandSpec (GlobalFlags -> IO ())
wrapperCmd CommandUI flags
ui flags -> Flag Verbosity
verbosity' flags -> Flag [Char]
distPref =
  CommandUI flags
-> (CommandUI flags -> Command (GlobalFlags -> IO ()))
-> CommandType
-> CommandSpec (GlobalFlags -> IO ())
forall action flags.
CommandUI flags
-> (CommandUI flags -> Command action)
-> CommandType
-> CommandSpec action
CommandSpec CommandUI flags
ui (\CommandUI flags
ui' -> CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag [Char])
-> Command (GlobalFlags -> IO ())
forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag [Char])
-> Command (GlobalFlags -> IO ())
wrapperAction CommandUI flags
ui' flags -> Flag Verbosity
verbosity' flags -> Flag [Char]
distPref) CommandType
NormalCommand

wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Command (Client.GlobalFlags -> IO ())
wrapperAction :: forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag [Char])
-> Command (GlobalFlags -> IO ())
wrapperAction CommandUI flags
command flags -> Flag Verbosity
verbosityFlag flags -> Flag [Char]
distPrefFlag =
  CommandUI flags
-> (flags -> [[Char]] -> GlobalFlags -> IO ())
-> Command (GlobalFlags -> IO ())
forall flags action.
CommandUI flags -> (flags -> [[Char]] -> action) -> Command action
commandAddAction CommandUI flags
command
    { commandDefaultFlags = mempty } ((flags -> [[Char]] -> GlobalFlags -> IO ())
 -> Command (GlobalFlags -> IO ()))
-> (flags -> [[Char]] -> GlobalFlags -> IO ())
-> Command (GlobalFlags -> IO ())
forall a b. (a -> b) -> a -> b
$ \flags
flags [[Char]]
extraArgs GlobalFlags
globalFlags -> do
    let verbosity' :: Verbosity
verbosity' = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
Setup.fromFlagOrDefault Verbosity
normal (flags -> Flag Verbosity
verbosityFlag flags
flags)

    Either SomeException SavedConfig
load <- IO SavedConfig -> IO (Either SomeException SavedConfig)
forall e a. Exception e => IO a -> IO (Either e a)
try (Verbosity -> GlobalFlags -> IO SavedConfig
loadConfigOrSandboxConfig Verbosity
verbosity' GlobalFlags
globalFlags)
    let config :: SavedConfig
config = (SomeException -> SavedConfig)
-> (SavedConfig -> SavedConfig)
-> Either SomeException SavedConfig
-> SavedConfig
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(SomeException e
_) -> SavedConfig
forall a. Monoid a => a
mempty) SavedConfig -> SavedConfig
forall a. a -> a
id Either SomeException SavedConfig
load
    [Char]
distPref <- SavedConfig -> Flag [Char] -> IO [Char]
findSavedDistPref SavedConfig
config (flags -> Flag [Char]
distPrefFlag flags
flags)
    let setupScriptOptions :: SetupScriptOptions
setupScriptOptions = SetupScriptOptions
defaultSetupScriptOptions { useDistPref = distPref }

    let command' :: CommandUI flags
command' = CommandUI flags
command { commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command }

    Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [[Char]])
-> IO ()
forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [[Char]])
-> IO ()
setupWrapper Verbosity
verbosity' SetupScriptOptions
setupScriptOptions Maybe PackageDescription
forall a. Maybe a
Nothing
                 CommandUI flags
command' (flags -> Version -> flags
forall a b. a -> b -> a
const flags
flags) ([[Char]] -> Version -> [[Char]]
forall a b. a -> b -> a
const [[Char]]
extraArgs)

--

class HasVerbosity a where
    verbosity :: a -> Verbosity

instance HasVerbosity (Setup.Flag Verbosity) where
    verbosity :: Flag Verbosity -> Verbosity
verbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
Setup.fromFlagOrDefault Verbosity
normal

instance (HasVerbosity a) => HasVerbosity (a, b) where
    verbosity :: (a, b) -> Verbosity
verbosity (a
a, b
_) = a -> Verbosity
forall a. HasVerbosity a => a -> Verbosity
verbosity a
a

instance (HasVerbosity a) => HasVerbosity (a, b, c) where
    verbosity :: (a, b, c) -> Verbosity
verbosity (a
a , b
_, c
_) = a -> Verbosity
forall a. HasVerbosity a => a -> Verbosity
verbosity a
a

instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where
    verbosity :: (a, b, c, d) -> Verbosity
verbosity (a
a, b
_, c
_, d
_) = a -> Verbosity
forall a. HasVerbosity a => a -> Verbosity
verbosity a
a

instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e) where
    verbosity :: (a, b, c, d, e) -> Verbosity
verbosity (a
a, b
_, c
_, d
_, e
_) = a -> Verbosity
forall a. HasVerbosity a => a -> Verbosity
verbosity a
a

instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e, f) where
    verbosity :: (a, b, c, d, e, f) -> Verbosity
verbosity (a
a, b
_, c
_, d
_, e
_, f
_) = a -> Verbosity
forall a. HasVerbosity a => a -> Verbosity
verbosity a
a

instance HasVerbosity Setup.BuildFlags where
    verbosity :: BuildFlags -> Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. HasVerbosity a => a -> Verbosity
verbosity (Flag Verbosity -> Verbosity)
-> (BuildFlags -> Flag Verbosity) -> BuildFlags -> Verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildFlags -> Flag Verbosity
Setup.buildVerbosity

instance HasVerbosity Setup.ConfigFlags where
    verbosity :: ConfigFlags -> Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. HasVerbosity a => a -> Verbosity
verbosity (Flag Verbosity -> Verbosity)
-> (ConfigFlags -> Flag Verbosity) -> ConfigFlags -> Verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigFlags -> Flag Verbosity
Setup.configVerbosity

instance HasVerbosity Setup.ReplFlags where
    verbosity :: ReplFlags -> Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. HasVerbosity a => a -> Verbosity
verbosity (Flag Verbosity -> Verbosity)
-> (ReplFlags -> Flag Verbosity) -> ReplFlags -> Verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReplFlags -> Flag Verbosity
Setup.replVerbosity

instance HasVerbosity Client.FreezeFlags where
    verbosity :: FreezeFlags -> Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. HasVerbosity a => a -> Verbosity
verbosity (Flag Verbosity -> Verbosity)
-> (FreezeFlags -> Flag Verbosity) -> FreezeFlags -> Verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreezeFlags -> Flag Verbosity
Client.freezeVerbosity

instance HasVerbosity Setup.HaddockFlags where
    verbosity :: HaddockFlags -> Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. HasVerbosity a => a -> Verbosity
verbosity (Flag Verbosity -> Verbosity)
-> (HaddockFlags -> Flag Verbosity) -> HaddockFlags -> Verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HaddockFlags -> Flag Verbosity
Setup.haddockVerbosity

instance HasVerbosity Client.UpdateFlags where
    verbosity :: UpdateFlags -> Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. HasVerbosity a => a -> Verbosity
verbosity (Flag Verbosity -> Verbosity)
-> (UpdateFlags -> Flag Verbosity) -> UpdateFlags -> Verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateFlags -> Flag Verbosity
Client.updateVerbosity

instance HasVerbosity Setup.CleanFlags where
    verbosity :: CleanFlags -> Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. HasVerbosity a => a -> Verbosity
verbosity (Flag Verbosity -> Verbosity)
-> (CleanFlags -> Flag Verbosity) -> CleanFlags -> Verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CleanFlags -> Flag Verbosity
Setup.cleanVerbosity

--

legacyNote :: String -> String
legacyNote :: [Char] -> [Char]
legacyNote [Char]
cmd = [Char] -> [Char]
wrapText ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
    [Char]
"The v1-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cmd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" command is a part of the legacy v1 style of cabal usage.\n\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++

    [Char]
"It is a legacy feature and will be removed in a future release of cabal-install." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
    [Char]
" Please file a bug if you cannot replicate a working v1- use case with the nix-style" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
    [Char]
" commands.\n\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++

    [Char]
"For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html"

toLegacyCmd :: CommandSpec (globals -> IO action) -> [CommandSpec (globals -> IO action)]
toLegacyCmd :: forall globals action.
CommandSpec (globals -> IO action)
-> [CommandSpec (globals -> IO action)]
toLegacyCmd CommandSpec (globals -> IO action)
mkSpec = [CommandSpec (globals -> IO action)
-> CommandSpec (globals -> IO action)
forall {action}. CommandSpec action -> CommandSpec action
toLegacy CommandSpec (globals -> IO action)
mkSpec]
  where
    toLegacy :: CommandSpec action -> CommandSpec action
toLegacy (CommandSpec origUi :: CommandUI flags
origUi@CommandUI{flags
[Char]
Maybe ([Char] -> [Char])
[Char] -> [Char]
ShowOrParseArgs -> [OptionField flags]
commandDefaultFlags :: forall flags. CommandUI flags -> flags
commandName :: forall flags. CommandUI flags -> [Char]
commandName :: [Char]
commandSynopsis :: [Char]
commandUsage :: [Char] -> [Char]
commandDescription :: Maybe ([Char] -> [Char])
commandNotes :: Maybe ([Char] -> [Char])
commandDefaultFlags :: flags
commandOptions :: ShowOrParseArgs -> [OptionField flags]
commandDescription :: forall flags. CommandUI flags -> Maybe ([Char] -> [Char])
commandNotes :: forall flags. CommandUI flags -> Maybe ([Char] -> [Char])
commandOptions :: forall flags.
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandSynopsis :: forall flags. CommandUI flags -> [Char]
commandUsage :: forall flags. CommandUI flags -> [Char] -> [Char]
..} CommandUI flags -> Command action
action CommandType
type') = CommandUI flags
-> (CommandUI flags -> Command action)
-> CommandType
-> CommandSpec action
forall action flags.
CommandUI flags
-> (CommandUI flags -> Command action)
-> CommandType
-> CommandSpec action
CommandSpec CommandUI flags
legUi CommandUI flags -> Command action
action CommandType
type'
      where
        legUi :: CommandUI flags
legUi = CommandUI flags
origUi
            { commandName = "v1-" ++ commandName
            , commandNotes = Just $ \[Char]
pname -> case Maybe ([Char] -> [Char])
commandNotes of
                Just [Char] -> [Char]
notes -> [Char] -> [Char]
notes [Char]
pname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
legacyNote [Char]
commandName
                Maybe ([Char] -> [Char])
Nothing -> [Char] -> [Char]
legacyNote [Char]
commandName
            }

legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]
legacyCmd :: forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [[Char]] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
legacyCmd CommandUI flags
ui flags -> [[Char]] -> globals -> IO action
action = CommandSpec (globals -> IO action)
-> [CommandSpec (globals -> IO action)]
forall globals action.
CommandSpec (globals -> IO action)
-> [CommandSpec (globals -> IO action)]
toLegacyCmd (CommandUI flags
-> (flags -> [[Char]] -> globals -> IO action)
-> CommandSpec (globals -> IO action)
forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [[Char]] -> globals -> IO action)
-> CommandSpec (globals -> IO action)
regularCmd CommandUI flags
ui flags -> [[Char]] -> globals -> IO action
action)

legacyWrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> [CommandSpec (Client.GlobalFlags -> IO ())]
legacyWrapperCmd :: forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag [Char])
-> [CommandSpec (GlobalFlags -> IO ())]
legacyWrapperCmd CommandUI flags
ui flags -> Flag Verbosity
verbosity' flags -> Flag [Char]
distPref = CommandSpec (GlobalFlags -> IO ())
-> [CommandSpec (GlobalFlags -> IO ())]
forall globals action.
CommandSpec (globals -> IO action)
-> [CommandSpec (globals -> IO action)]
toLegacyCmd (CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag [Char])
-> CommandSpec (GlobalFlags -> IO ())
forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag [Char])
-> CommandSpec (GlobalFlags -> IO ())
wrapperCmd CommandUI flags
ui flags -> Flag Verbosity
verbosity' flags -> Flag [Char]
distPref)

newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]
newCmd :: forall flags globals action.
CommandUI flags
-> (flags -> [[Char]] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd origUi :: CommandUI flags
origUi@CommandUI{flags
[Char]
Maybe ([Char] -> [Char])
[Char] -> [Char]
ShowOrParseArgs -> [OptionField flags]
commandDefaultFlags :: forall flags. CommandUI flags -> flags
commandName :: forall flags. CommandUI flags -> [Char]
commandDescription :: forall flags. CommandUI flags -> Maybe ([Char] -> [Char])
commandNotes :: forall flags. CommandUI flags -> Maybe ([Char] -> [Char])
commandOptions :: forall flags.
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandSynopsis :: forall flags. CommandUI flags -> [Char]
commandUsage :: forall flags. CommandUI flags -> [Char] -> [Char]
commandName :: [Char]
commandSynopsis :: [Char]
commandUsage :: [Char] -> [Char]
commandDescription :: Maybe ([Char] -> [Char])
commandNotes :: Maybe ([Char] -> [Char])
commandDefaultFlags :: flags
commandOptions :: ShowOrParseArgs -> [OptionField flags]
..} flags -> [[Char]] -> globals -> IO action
action = [CommandUI flags -> CommandSpec (globals -> IO action)
cmd CommandUI flags
defaultUi, CommandUI flags -> CommandSpec (globals -> IO action)
cmd CommandUI flags
newUi, CommandUI flags -> CommandSpec (globals -> IO action)
cmd CommandUI flags
origUi]
    where
        cmd :: CommandUI flags -> CommandSpec (globals -> IO action)
cmd CommandUI flags
ui = CommandUI flags
-> (CommandUI flags -> Command (globals -> IO action))
-> CommandType
-> CommandSpec (globals -> IO action)
forall action flags.
CommandUI flags
-> (CommandUI flags -> Command action)
-> CommandType
-> CommandSpec action
CommandSpec CommandUI flags
ui ((CommandUI flags
 -> (flags -> [[Char]] -> globals -> IO action)
 -> Command (globals -> IO action))
-> (flags -> [[Char]] -> globals -> IO action)
-> CommandUI flags
-> Command (globals -> IO action)
forall a b c. (a -> b -> c) -> b -> a -> c
flip CommandUI flags
-> (flags -> [[Char]] -> globals -> IO action)
-> Command (globals -> IO action)
forall flags action.
CommandUI flags -> (flags -> [[Char]] -> action) -> Command action
commandAddAction flags -> [[Char]] -> globals -> IO action
action) CommandType
NormalCommand

        newMsg :: [Char] -> [Char]
newMsg = Text -> [Char]
T.unpack (Text -> [Char]) -> ([Char] -> Text) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"v2-" Text
"new-" (Text -> Text) -> ([Char] -> Text) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack
        newUi :: CommandUI flags
newUi = CommandUI flags
origUi
            { commandName = newMsg commandName
            , commandUsage = newMsg . commandUsage
            , commandDescription = (newMsg .) <$> commandDescription
            , commandNotes = (newMsg .) <$> commandNotes
            }

        defaultMsg :: [Char] -> [Char]
defaultMsg = Text -> [Char]
T.unpack (Text -> [Char]) -> ([Char] -> Text) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"v2-" Text
"" (Text -> Text) -> ([Char] -> Text) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack
        defaultUi :: CommandUI flags
defaultUi = CommandUI flags
origUi
            { commandName = defaultMsg commandName
            , commandUsage = defaultMsg . commandUsage
            , commandDescription = (defaultMsg .) <$> commandDescription
            , commandNotes = (defaultMsg .) <$> commandNotes
            }