1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE ViewPatterns #-}
7 module Distribution
.Client
.CmdLegacy
(legacyCmd
, legacyWrapperCmd
, newCmd
) where
9 import Distribution
.Client
.Compat
.Prelude
12 import Distribution
.Client
.Sandbox
14 , loadConfigOrSandboxConfig
16 import qualified Distribution
.Client
.Setup
as Client
17 import Distribution
.Client
.SetupWrapper
18 ( SetupScriptOptions
(..)
19 , defaultSetupScriptOptions
22 import Distribution
.Simple
.Command
23 import qualified Distribution
.Simple
.Setup
as Setup
24 import Distribution
.Simple
.Utils
27 import Distribution
.Verbosity
31 import Control
.Exception
34 import qualified Data
.Text
as T
36 -- Tweaked versions of code from Main.
37 regularCmd
:: HasVerbosity flags
=> CommandUI flags
-> (flags
-> [String] -> globals
-> IO action
) -> CommandSpec
(globals
-> IO action
)
38 regularCmd ui action
=
39 CommandSpec ui
((flip commandAddAction
) (\flags extra globals
-> action flags extra globals
)) NormalCommand
44 -> (flags
-> Setup
.CommonSetupFlags
)
45 -> CommandSpec
(Client
.GlobalFlags
-> IO ())
46 wrapperCmd ui getCommonFlags
=
47 CommandSpec ui
(\ui
' -> wrapperAction ui
' getCommonFlags
) NormalCommand
52 -> (flags
-> Setup
.CommonSetupFlags
)
53 -> Command
(Client
.GlobalFlags
-> IO ())
54 wrapperAction command getCommonFlags
=
57 { commandDefaultFlags
= mempty
59 $ \flags extraArgs globalFlags
-> do
60 let common
= getCommonFlags flags
61 verbosity
' = Setup
.fromFlagOrDefault normal
(Setup
.setupVerbosity common
)
62 mbWorkDir
= Setup
.flagToMaybe
$ Setup
.setupWorkingDir common
64 load
<- try (loadConfigOrSandboxConfig verbosity
' globalFlags
)
65 let config
= either (\(SomeException _
) -> mempty
) id load
66 distPref
<- findSavedDistPref config
(Setup
.setupDistPref common
)
67 let setupScriptOptions
=
68 defaultSetupScriptOptions
69 { useDistPref
= distPref
70 , useWorkingDir
= mbWorkDir
73 let command
' = command
{commandName
= T
.unpack
. T
.replace
"v1-" "" . T
.pack
. commandName
$ command
}
81 (const (return flags
))
86 class HasVerbosity a
where
87 verbosity
:: a
-> Verbosity
89 instance HasVerbosity
(Setup
.Flag Verbosity
) where
90 verbosity
= Setup
.fromFlagOrDefault normal
92 instance HasVerbosity a
=> HasVerbosity
(a
, b
) where
93 verbosity
(a
, _
) = verbosity a
95 instance HasVerbosity a
=> HasVerbosity
(a
, b
, c
) where
96 verbosity
(a
, _
, _
) = verbosity a
98 instance HasVerbosity a
=> HasVerbosity
(a
, b
, c
, d
) where
99 verbosity
(a
, _
, _
, _
) = verbosity a
101 instance HasVerbosity a
=> HasVerbosity
(a
, b
, c
, d
, e
) where
102 verbosity
(a
, _
, _
, _
, _
) = verbosity a
104 instance HasVerbosity a
=> HasVerbosity
(a
, b
, c
, d
, e
, f
) where
105 verbosity
(a
, _
, _
, _
, _
, _
) = verbosity a
107 instance HasVerbosity Setup
.BuildFlags
where
108 verbosity
= verbosity
. Setup
.setupVerbosity
. Setup
.buildCommonFlags
110 instance HasVerbosity Setup
.ConfigFlags
where
111 verbosity
= verbosity
. Setup
.setupVerbosity
. Setup
.configCommonFlags
113 instance HasVerbosity Setup
.ReplFlags
where
114 verbosity
= verbosity
. Setup
.setupVerbosity
. Setup
.replCommonFlags
116 instance HasVerbosity Client
.FreezeFlags
where
117 verbosity
= verbosity
. Client
.freezeVerbosity
119 instance HasVerbosity Setup
.HaddockFlags
where
120 verbosity
= verbosity
. Setup
.setupVerbosity
. Setup
.haddockCommonFlags
122 instance HasVerbosity Client
.UpdateFlags
where
123 verbosity
= verbosity
. Client
.updateVerbosity
125 instance HasVerbosity Setup
.CleanFlags
where
126 verbosity
= verbosity
. Setup
.setupVerbosity
. Setup
.cleanCommonFlags
130 legacyNote
:: String -> String
135 ++ " command is a part of the legacy v1 style of cabal usage.\n\n"
136 ++ "It is a legacy feature and will be removed in a future release of cabal-install."
137 ++ " Please file a bug if you cannot replicate a working v1- use case with the nix-style"
139 ++ "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html"
141 toLegacyCmd
:: CommandSpec
(globals
-> IO action
) -> [CommandSpec
(globals
-> IO action
)]
142 toLegacyCmd mkSpec
= [toLegacy mkSpec
]
144 toLegacy
(CommandSpec origUi
@CommandUI
{..} action
type') = CommandSpec legUi action
type'
148 { commandName
= "v1-" ++ commandName
149 , commandNotes
= Just
$ \pname
-> case commandNotes
of
150 Just notes
-> notes pname
++ "\n" ++ legacyNote commandName
151 Nothing
-> legacyNote commandName
154 legacyCmd
:: HasVerbosity flags
=> CommandUI flags
-> (flags
-> [String] -> globals
-> IO action
) -> [CommandSpec
(globals
-> IO action
)]
155 legacyCmd ui action
= toLegacyCmd
(regularCmd ui action
)
160 -> (flags
-> Setup
.CommonSetupFlags
)
161 -> [CommandSpec
(Client
.GlobalFlags
-> IO ())]
162 legacyWrapperCmd ui commonFlags
= toLegacyCmd
(wrapperCmd ui commonFlags
)
164 newCmd
:: CommandUI flags
-> (flags
-> [String] -> globals
-> IO action
) -> [CommandSpec
(globals
-> IO action
)]
165 newCmd origUi
@CommandUI
{..} action
= [cmd defaultUi
, cmd newUi
, cmd origUi
]
167 cmd ui
= CommandSpec ui
(flip commandAddAction action
) NormalCommand
169 newMsg
= T
.unpack
. T
.replace
"v2-" "new-" . T
.pack
172 { commandName
= newMsg commandName
173 , commandUsage
= newMsg
. commandUsage
174 , commandDescription
= (newMsg
.) <$> commandDescription
175 , commandNotes
= (newMsg
.) <$> commandNotes
178 defaultMsg
= T
.unpack
. T
.replace
"v2-" "" . T
.pack
181 { commandName
= defaultMsg commandName
182 , commandUsage
= defaultMsg
. commandUsage
183 , commandDescription
= (defaultMsg
.) <$> commandDescription
184 , commandNotes
= (defaultMsg
.) <$> commandNotes