cabal-install/src/Distribution/Client/CmdLegacy.hs

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