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