Merge pull request #10593 from cabalism/typo/prexif-reseved
[cabal.git] / cabal-install / src / Distribution / Client / CmdLegacy.hs
blob38873148dc041ed6b0c8476b4ecd9a39d03a86e6
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
10 import Prelude ()
12 import Distribution.Client.Sandbox
13 ( findSavedDistPref
14 , loadConfigOrSandboxConfig
16 import qualified Distribution.Client.Setup as Client
17 import Distribution.Client.SetupWrapper
18 ( SetupScriptOptions (..)
19 , defaultSetupScriptOptions
20 , setupWrapper
22 import Distribution.Simple.Command
23 import qualified Distribution.Simple.Setup as Setup
24 import Distribution.Simple.Utils
25 ( wrapText
27 import Distribution.Verbosity
28 ( normal
31 import Control.Exception
32 ( try
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
41 wrapperCmd
42 :: Monoid flags
43 => CommandUI flags
44 -> (flags -> Setup.CommonSetupFlags)
45 -> CommandSpec (Client.GlobalFlags -> IO ())
46 wrapperCmd ui getCommonFlags =
47 CommandSpec ui (\ui' -> wrapperAction ui' getCommonFlags) NormalCommand
49 wrapperAction
50 :: Monoid flags
51 => CommandUI flags
52 -> (flags -> Setup.CommonSetupFlags)
53 -> Command (Client.GlobalFlags -> IO ())
54 wrapperAction command getCommonFlags =
55 commandAddAction
56 command
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}
75 setupWrapper
76 verbosity'
77 setupScriptOptions
78 Nothing
79 command'
80 getCommonFlags
81 (const (return flags))
82 (const extraArgs)
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
131 legacyNote cmd =
132 wrapText $
133 "The v1-"
134 ++ cmd
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"
138 ++ " commands.\n\n"
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]
143 where
144 toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type'
145 where
146 legUi =
147 origUi
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)
157 legacyWrapperCmd
158 :: Monoid flags
159 => CommandUI flags
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]
166 where
167 cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand
169 newMsg = T.unpack . T.replace "v2-" "new-" . T.pack
170 newUi =
171 origUi
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
179 defaultUi =
180 origUi
181 { commandName = defaultMsg commandName
182 , commandUsage = defaultMsg . commandUsage
183 , commandDescription = (defaultMsg .) <$> commandDescription
184 , commandNotes = (defaultMsg .) <$> commandNotes