{-# 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 =
        forall action flags.
CommandUI flags
-> (CommandUI flags -> Command action)
-> CommandType
-> CommandSpec action
CommandSpec CommandUI flags
ui ((forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 =
  forall action flags.
CommandUI flags
-> (CommandUI flags -> Command action)
-> CommandType
-> CommandSpec action
CommandSpec CommandUI flags
ui (\CommandUI flags
ui' -> 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 =
  forall flags action.
CommandUI flags -> (flags -> [[Char]] -> action) -> Command action
commandAddAction CommandUI flags
command
    { commandDefaultFlags :: flags
commandDefaultFlags = forall a. Monoid a => a
mempty } forall a b. (a -> b) -> a -> b
$ \flags
flags [[Char]]
extraArgs GlobalFlags
globalFlags -> do
    let verbosity' :: Verbosity
verbosity' = forall a. a -> Flag a -> a
Setup.fromFlagOrDefault Verbosity
normal (flags -> Flag Verbosity
verbosityFlag flags
flags)

    Either SomeException SavedConfig
load <- 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(SomeException e
_) -> forall a. Monoid a => a
mempty) 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 :: [Char]
useDistPref = [Char]
distPref }

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

    forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [[Char]])
-> IO ()
setupWrapper Verbosity
verbosity' SetupScriptOptions
setupScriptOptions forall a. Maybe a
Nothing
                 CommandUI flags
command' (forall a b. a -> b -> a
const flags
flags) (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 = 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
_) = 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
_) = 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
_) = 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
_) = 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
_) = forall a. HasVerbosity a => a -> Verbosity
verbosity a
a

instance HasVerbosity Setup.BuildFlags where
    verbosity :: BuildFlags -> Verbosity
verbosity = forall a. HasVerbosity a => a -> Verbosity
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 = forall a. HasVerbosity a => a -> Verbosity
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 = forall a. HasVerbosity a => a -> Verbosity
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 = forall a. HasVerbosity a => a -> Verbosity
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 = forall a. HasVerbosity a => a -> Verbosity
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 = forall a. HasVerbosity a => a -> Verbosity
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 = forall a. HasVerbosity a => a -> Verbosity
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 forall a b. (a -> b) -> a -> b
$
    [Char]
"The v1-" forall a. [a] -> [a] -> [a]
++ [Char]
cmd forall a. [a] -> [a] -> [a]
++ [Char]
" command is a part of the legacy v1 style of cabal usage.\n\n" forall a. [a] -> [a] -> [a]
++

    [Char]
"It is a legacy feature and will be removed in a future release of cabal-install." forall a. [a] -> [a] -> [a]
++
    [Char]
" Please file a bug if you cannot replicate a working v1- use case with the nix-style" forall a. [a] -> [a] -> [a]
++
    [Char]
" commands.\n\n" 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 = [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]
commandSynopsis :: forall flags. CommandUI flags -> [Char]
commandUsage :: forall flags. CommandUI flags -> [Char] -> [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]
commandOptions :: ShowOrParseArgs -> [OptionField flags]
commandDefaultFlags :: flags
commandNotes :: Maybe ([Char] -> [Char])
commandDescription :: Maybe ([Char] -> [Char])
commandUsage :: [Char] -> [Char]
commandSynopsis :: [Char]
commandName :: [Char]
commandName :: forall flags. CommandUI flags -> [Char]
commandDefaultFlags :: forall flags. CommandUI flags -> flags
..} CommandUI flags -> Command action
action CommandType
type') = 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 :: [Char]
commandName = [Char]
"v1-" forall a. [a] -> [a] -> [a]
++ [Char]
commandName
            , commandNotes :: Maybe ([Char] -> [Char])
commandNotes = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \[Char]
pname -> case Maybe ([Char] -> [Char])
commandNotes of
                Just [Char] -> [Char]
notes -> [Char] -> [Char]
notes [Char]
pname forall a. [a] -> [a] -> [a]
++ [Char]
"\n" 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 = forall globals action.
CommandSpec (globals -> IO action)
-> [CommandSpec (globals -> IO action)]
toLegacyCmd (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 = forall globals action.
CommandSpec (globals -> IO action)
-> [CommandSpec (globals -> IO action)]
toLegacyCmd (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]
commandOptions :: ShowOrParseArgs -> [OptionField flags]
commandDefaultFlags :: flags
commandNotes :: Maybe ([Char] -> [Char])
commandDescription :: Maybe ([Char] -> [Char])
commandUsage :: [Char] -> [Char]
commandSynopsis :: [Char]
commandName :: [Char]
commandSynopsis :: forall flags. CommandUI flags -> [Char]
commandUsage :: forall flags. CommandUI flags -> [Char] -> [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]
commandName :: forall flags. CommandUI flags -> [Char]
commandDefaultFlags :: forall flags. CommandUI flags -> 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 = forall action flags.
CommandUI flags
-> (CommandUI flags -> Command action)
-> CommandType
-> CommandSpec action
CommandSpec CommandUI flags
ui (forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"v2-" Text
"new-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack
        newUi :: CommandUI flags
newUi = CommandUI flags
origUi
            { commandName :: [Char]
commandName = [Char] -> [Char]
newMsg [Char]
commandName
            , commandUsage :: [Char] -> [Char]
commandUsage = [Char] -> [Char]
newMsg forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
commandUsage
            , commandDescription :: Maybe ([Char] -> [Char])
commandDescription = ([Char] -> [Char]
newMsg forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ([Char] -> [Char])
commandDescription
            , commandNotes :: Maybe ([Char] -> [Char])
commandNotes = ([Char] -> [Char]
newMsg forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ([Char] -> [Char])
commandNotes
            }

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