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

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