1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE ViewPatterns #-}
5module Distribution.Client.CmdLegacy ( legacyCmd, legacyWrapperCmd, newCmd ) where
6
7import Prelude ()
8import Distribution.Client.Compat.Prelude
9
10import Distribution.Client.Sandbox
11    ( loadConfigOrSandboxConfig, findSavedDistPref )
12import qualified Distribution.Client.Setup as Client
13import Distribution.Client.SetupWrapper
14    ( SetupScriptOptions(..), setupWrapper, defaultSetupScriptOptions )
15import qualified Distribution.Simple.Setup as Setup
16import Distribution.Simple.Command
17import Distribution.Simple.Utils
18    ( wrapText )
19import Distribution.Verbosity
20    ( Verbosity, normal )
21
22import Control.Exception
23    ( SomeException(..), try )
24import qualified Data.Text as T
25
26-- Tweaked versions of code from Main.
27regularCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> CommandSpec (globals -> IO action)
28regularCmd ui action =
29        CommandSpec ui ((flip commandAddAction) (\flags extra globals -> action flags extra globals)) NormalCommand
30
31wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> CommandSpec (Client.GlobalFlags -> IO ())
32wrapperCmd ui verbosity' distPref =
33  CommandSpec ui (\ui' -> wrapperAction ui' verbosity' distPref) NormalCommand
34
35wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Command (Client.GlobalFlags -> IO ())
36wrapperAction command verbosityFlag distPrefFlag =
37  commandAddAction command
38    { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do
39    let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags)
40
41    load <- try (loadConfigOrSandboxConfig verbosity' globalFlags)
42    let config = either (\(SomeException _) -> mempty) snd load
43    distPref <- findSavedDistPref config (distPrefFlag flags)
44    let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }
45
46    let command' = command { commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command }
47
48    setupWrapper verbosity' setupScriptOptions Nothing
49                 command' (const flags) (const extraArgs)
50
51--
52
53class HasVerbosity a where
54    verbosity :: a -> Verbosity
55
56instance HasVerbosity (Setup.Flag Verbosity) where
57    verbosity = Setup.fromFlagOrDefault normal
58
59instance (HasVerbosity a) => HasVerbosity (a, b) where
60    verbosity (a, _) = verbosity a
61
62instance (HasVerbosity b) => HasVerbosity (a, b, c) where
63    verbosity (_ , b, _) = verbosity b
64
65instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where
66    verbosity (a, _, _, _) = verbosity a
67
68instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e) where
69    verbosity (a, _, _, _, _) = verbosity a
70
71instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e, f) where
72    verbosity (a, _, _, _, _, _) = verbosity a
73
74instance HasVerbosity Setup.BuildFlags where
75    verbosity = verbosity . Setup.buildVerbosity
76
77instance HasVerbosity Setup.ConfigFlags where
78    verbosity = verbosity . Setup.configVerbosity
79
80instance HasVerbosity Setup.ReplFlags where
81    verbosity = verbosity . Setup.replVerbosity
82
83instance HasVerbosity Client.FreezeFlags where
84    verbosity = verbosity . Client.freezeVerbosity
85
86instance HasVerbosity Setup.HaddockFlags where
87    verbosity = verbosity . Setup.haddockVerbosity
88
89instance HasVerbosity Client.ExecFlags where
90    verbosity = verbosity . Client.execVerbosity
91
92instance HasVerbosity Client.UpdateFlags where
93    verbosity = verbosity . Client.updateVerbosity
94
95instance HasVerbosity Setup.CleanFlags where
96    verbosity = verbosity . Setup.cleanVerbosity
97
98instance HasVerbosity Client.SDistFlags where
99    verbosity = verbosity . Client.sDistVerbosity
100
101instance HasVerbosity Client.SandboxFlags where
102    verbosity = verbosity . Client.sandboxVerbosity
103
104instance HasVerbosity Setup.DoctestFlags where
105    verbosity = verbosity . Setup.doctestVerbosity
106
107--
108
109legacyNote :: String -> String
110legacyNote cmd = wrapText $
111    "The v1-" ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++
112
113    "It is a legacy feature and will be removed in a future release of cabal-install." ++
114    " Please file a bug if you cannot replicate a working v1- use case with the nix-style" ++
115    " commands.\n\n" ++
116
117    "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html"
118
119toLegacyCmd :: CommandSpec (globals -> IO action) -> [CommandSpec (globals -> IO action)]
120toLegacyCmd mkSpec = [toLegacy mkSpec]
121  where
122    toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type'
123      where
124        legUi = origUi
125            { commandName = "v1-" ++ commandName
126            , commandNotes = Just $ \pname -> case commandNotes of
127                Just notes -> notes pname ++ "\n" ++ legacyNote commandName
128                Nothing -> legacyNote commandName
129            }
130
131legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]
132legacyCmd ui action = toLegacyCmd (regularCmd ui action)
133
134legacyWrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> [CommandSpec (Client.GlobalFlags -> IO ())]
135legacyWrapperCmd ui verbosity' distPref = toLegacyCmd (wrapperCmd ui verbosity' distPref)
136
137newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]
138newCmd origUi@CommandUI{..} action = [cmd defaultUi, cmd newUi, cmd origUi]
139    where
140        cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand
141
142        newMsg = T.unpack . T.replace "v2-" "new-" . T.pack
143        newUi = origUi
144            { commandName = newMsg commandName
145            , commandUsage = newMsg . commandUsage
146            , commandDescription = (newMsg .) <$> commandDescription
147            , commandNotes = (newMsg .) <$> commandDescription
148            }
149
150        defaultMsg = T.unpack . T.replace "v2-" "" . T.pack
151        defaultUi = origUi
152            { commandName = defaultMsg commandName
153            , commandUsage = defaultMsg . commandUsage
154            , commandDescription = (defaultMsg .) <$> commandDescription
155            , commandNotes = (defaultMsg .) <$> commandDescription
156            }
157