{-# 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 :: CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> CommandSpec (globals -> IO action)
regularCmd CommandUI flags
ui flags -> [String] -> 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 -> [String] -> globals -> IO action)
 -> Command (globals -> IO action))
-> (flags -> [String] -> globals -> IO action)
-> CommandUI flags
-> Command (globals -> IO action)
forall a b c. (a -> b -> c) -> b -> a -> c
flip CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> Command (globals -> IO action)
forall flags action.
CommandUI flags -> (flags -> [String] -> action) -> Command action
commandAddAction) (\flags
flags [String]
extra globals
globals -> flags -> [String] -> globals -> IO action
action flags
flags [String]
extra globals
globals)) CommandType
NormalCommand

wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> CommandSpec (Client.GlobalFlags -> IO ())
wrapperCmd :: CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag String)
-> CommandSpec (GlobalFlags -> IO ())
wrapperCmd CommandUI flags
ui flags -> Flag Verbosity
verbosity' flags -> Flag String
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 String)
-> Command (GlobalFlags -> IO ())
forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag String)
-> Command (GlobalFlags -> IO ())
wrapperAction CommandUI flags
ui' flags -> Flag Verbosity
verbosity' flags -> Flag String
distPref) CommandType
NormalCommand

wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Command (Client.GlobalFlags -> IO ())
wrapperAction :: CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag String)
-> Command (GlobalFlags -> IO ())
wrapperAction CommandUI flags
command flags -> Flag Verbosity
verbosityFlag flags -> Flag String
distPrefFlag =
  CommandUI flags
-> (flags -> [String] -> GlobalFlags -> IO ())
-> Command (GlobalFlags -> IO ())
forall flags action.
CommandUI flags -> (flags -> [String] -> action) -> Command action
commandAddAction CommandUI flags
command
    { commandDefaultFlags :: flags
commandDefaultFlags = flags
forall a. Monoid a => a
mempty } ((flags -> [String] -> GlobalFlags -> IO ())
 -> Command (GlobalFlags -> IO ()))
-> (flags -> [String] -> GlobalFlags -> IO ())
-> Command (GlobalFlags -> IO ())
forall a b. (a -> b) -> a -> b
$ \flags
flags [String]
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
    String
distPref <- SavedConfig -> Flag String -> IO String
findSavedDistPref SavedConfig
config (flags -> Flag String
distPrefFlag flags
flags)
    let setupScriptOptions :: SetupScriptOptions
setupScriptOptions = SetupScriptOptions
defaultSetupScriptOptions { useDistPref :: String
useDistPref = String
distPref }

    let command' :: CommandUI flags
command' = CommandUI flags
command { commandName :: String
commandName = Text -> String
T.unpack (Text -> String)
-> (CommandUI flags -> Text) -> CommandUI flags -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"v1-" Text
"" (Text -> Text)
-> (CommandUI flags -> Text) -> CommandUI flags -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (CommandUI flags -> String) -> CommandUI flags -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandUI flags -> String
forall flags. CommandUI flags -> String
commandName (CommandUI flags -> String) -> CommandUI flags -> String
forall a b. (a -> b) -> a -> b
$ CommandUI flags
command }

    Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [String])
-> IO ()
forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [String])
-> 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) ([String] -> Version -> [String]
forall a b. a -> b -> a
const [String]
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 :: String -> String
legacyNote String
cmd = String -> String
wrapText (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
    String
"The v1-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" command is a part of the legacy v1 style of cabal usage.\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++

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

    String
"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 :: 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
String
Maybe (String -> String)
String -> String
ShowOrParseArgs -> [OptionField flags]
commandSynopsis :: forall flags. CommandUI flags -> String
commandUsage :: forall flags. CommandUI flags -> String -> String
commandDescription :: forall flags. CommandUI flags -> Maybe (String -> String)
commandNotes :: forall flags. CommandUI flags -> Maybe (String -> String)
commandOptions :: forall flags.
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandOptions :: ShowOrParseArgs -> [OptionField flags]
commandDefaultFlags :: flags
commandNotes :: Maybe (String -> String)
commandDescription :: Maybe (String -> String)
commandUsage :: String -> String
commandSynopsis :: String
commandName :: String
commandName :: forall flags. CommandUI flags -> String
commandDefaultFlags :: forall flags. CommandUI flags -> flags
..} 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 :: String
commandName = String
"v1-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
commandName
            , commandNotes :: Maybe (String -> String)
commandNotes = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
pname -> case Maybe (String -> String)
commandNotes of
                Just String -> String
notes -> String -> String
notes String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
legacyNote String
commandName
                Maybe (String -> String)
Nothing -> String -> String
legacyNote String
commandName
            }

legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]
legacyCmd :: CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
legacyCmd CommandUI flags
ui flags -> [String] -> 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 -> [String] -> globals -> IO action)
-> CommandSpec (globals -> IO action)
forall flags globals action.
HasVerbosity flags =>
CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> CommandSpec (globals -> IO action)
regularCmd CommandUI flags
ui flags -> [String] -> globals -> IO action
action)

legacyWrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> [CommandSpec (Client.GlobalFlags -> IO ())]
legacyWrapperCmd :: CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag String)
-> [CommandSpec (GlobalFlags -> IO ())]
legacyWrapperCmd CommandUI flags
ui flags -> Flag Verbosity
verbosity' flags -> Flag String
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 String)
-> CommandSpec (GlobalFlags -> IO ())
forall flags.
Monoid flags =>
CommandUI flags
-> (flags -> Flag Verbosity)
-> (flags -> Flag String)
-> CommandSpec (GlobalFlags -> IO ())
wrapperCmd CommandUI flags
ui flags -> Flag Verbosity
verbosity' flags -> Flag String
distPref)

newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]
newCmd :: CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> [CommandSpec (globals -> IO action)]
newCmd origUi :: CommandUI flags
origUi@CommandUI{flags
String
Maybe (String -> String)
String -> String
ShowOrParseArgs -> [OptionField flags]
commandOptions :: ShowOrParseArgs -> [OptionField flags]
commandDefaultFlags :: flags
commandNotes :: Maybe (String -> String)
commandDescription :: Maybe (String -> String)
commandUsage :: String -> String
commandSynopsis :: String
commandName :: String
commandSynopsis :: forall flags. CommandUI flags -> String
commandUsage :: forall flags. CommandUI flags -> String -> String
commandDescription :: forall flags. CommandUI flags -> Maybe (String -> String)
commandNotes :: forall flags. CommandUI flags -> Maybe (String -> String)
commandOptions :: forall flags.
CommandUI flags -> ShowOrParseArgs -> [OptionField flags]
commandName :: forall flags. CommandUI flags -> String
commandDefaultFlags :: forall flags. CommandUI flags -> flags
..} flags -> [String] -> 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 -> [String] -> globals -> IO action)
 -> Command (globals -> IO action))
-> (flags -> [String] -> globals -> IO action)
-> CommandUI flags
-> Command (globals -> IO action)
forall a b c. (a -> b -> c) -> b -> a -> c
flip CommandUI flags
-> (flags -> [String] -> globals -> IO action)
-> Command (globals -> IO action)
forall flags action.
CommandUI flags -> (flags -> [String] -> action) -> Command action
commandAddAction flags -> [String] -> globals -> IO action
action) CommandType
NormalCommand

        newMsg :: String -> String
newMsg = Text -> String
T.unpack (Text -> String) -> (String -> Text) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"v2-" Text
"new-" (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
        newUi :: CommandUI flags
newUi = CommandUI flags
origUi
            { commandName :: String
commandName = String -> String
newMsg String
commandName
            , commandUsage :: String -> String
commandUsage = String -> String
newMsg (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
commandUsage
            , commandDescription :: Maybe (String -> String)
commandDescription = (String -> String
newMsg (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((String -> String) -> String -> String)
-> Maybe (String -> String) -> Maybe (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (String -> String)
commandDescription
            , commandNotes :: Maybe (String -> String)
commandNotes = (String -> String
newMsg (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((String -> String) -> String -> String)
-> Maybe (String -> String) -> Maybe (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (String -> String)
commandNotes
            }

        defaultMsg :: String -> String
defaultMsg = Text -> String
T.unpack (Text -> String) -> (String -> Text) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"v2-" Text
"" (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
        defaultUi :: CommandUI flags
defaultUi = CommandUI flags
origUi
            { commandName :: String
commandName = String -> String
defaultMsg String
commandName
            , commandUsage :: String -> String
commandUsage = String -> String
defaultMsg (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
commandUsage
            , commandDescription :: Maybe (String -> String)
commandDescription = (String -> String
defaultMsg (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((String -> String) -> String -> String)
-> Maybe (String -> String) -> Maybe (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (String -> String)
commandDescription
            , commandNotes :: Maybe (String -> String)
commandNotes = (String -> String
defaultMsg (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((String -> String) -> String -> String)
-> Maybe (String -> String) -> Maybe (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (String -> String)
commandNotes
            }