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

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE ViewPatterns #-}
   6
   7 module Distribution.Client.CmdLegacy (legacyCmd, legacyWrapperCmd, newCmd) where
   8
   9 import Distribution.Client.Compat.Prelude
  10 import Prelude ()
  11
  12 import Distribution.Client.Sandbox
  13   ( findSavedDistPref
  14   , loadConfigOrSandboxConfig
  15   )
  16 import qualified Distribution.Client.Setup as Client
  17 import Distribution.Client.SetupWrapper
  18   ( SetupScriptOptions (..)
  19   , defaultSetupScriptOptions
  20   , setupWrapper
  21   )
  22 import Distribution.Simple.Command
  23 import qualified Distribution.Simple.Setup as Setup
  24 import Distribution.Simple.Utils
  25   ( wrapText
  26   )
  27 import Distribution.Verbosity
  28   ( normal
  29   )
  30
  31 import Control.Exception
  32   ( try
  33   )
  34 import qualified Data.Text as T
  35
  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
  40
  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
  48
  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
  58       }
  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
  63
  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
  71               }
  72
  73       let command' = command{commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command}
  74
  75       setupWrapper
  76         verbosity'
  77         setupScriptOptions
  78         Nothing
  79         command'
  80         getCommonFlags
  81         (const (return flags))
  82         (const extraArgs)
  83
  84 --
  85
  86 class HasVerbosity a where
  87   verbosity :: a -> Verbosity
  88
  89 instance HasVerbosity (Setup.Flag Verbosity) where
  90   verbosity = Setup.fromFlagOrDefault normal
  91
  92 instance HasVerbosity a => HasVerbosity (a, b) where
  93   verbosity (a, _) = verbosity a
  94
  95 instance HasVerbosity a => HasVerbosity (a, b, c) where
  96   verbosity (a, _, _) = verbosity a
  97
  98 instance HasVerbosity a => HasVerbosity (a, b, c, d) where
  99   verbosity (a, _, _, _) = verbosity a
 100
 101 instance HasVerbosity a => HasVerbosity (a, b, c, d, e) where
 102   verbosity (a, _, _, _, _) = verbosity a
 103
 104 instance HasVerbosity a => HasVerbosity (a, b, c, d, e, f) where
 105   verbosity (a, _, _, _, _, _) = verbosity a
 106
 107 instance HasVerbosity Setup.BuildFlags where
 108   verbosity = verbosity . Setup.setupVerbosity . Setup.buildCommonFlags
 109
 110 instance HasVerbosity Setup.ConfigFlags where
 111   verbosity = verbosity . Setup.setupVerbosity . Setup.configCommonFlags
 112
 113 instance HasVerbosity Setup.ReplFlags where
 114   verbosity = verbosity . Setup.setupVerbosity . Setup.replCommonFlags
 115
 116 instance HasVerbosity Client.FreezeFlags where
 117   verbosity = verbosity . Client.freezeVerbosity
 118
 119 instance HasVerbosity Setup.HaddockFlags where
 120   verbosity = verbosity . Setup.setupVerbosity . Setup.haddockCommonFlags
 121
 122 instance HasVerbosity Client.UpdateFlags where
 123   verbosity = verbosity . Client.updateVerbosity
 124
 125 instance HasVerbosity Setup.CleanFlags where
 126   verbosity = verbosity . Setup.setupVerbosity . Setup.cleanCommonFlags
 127
 128 --
 129
 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"
 140
 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
 152             }
 153
 154 legacyCmd :: HasVerbosity flags => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]
 155 legacyCmd ui action = toLegacyCmd (regularCmd ui action)
 156
 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)
 163
 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
 168
 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
 176         }
 177
 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
 185         }