Setup.hs 12.9 KB
Newer Older
1 2
-----------------------------------------------------------------------------
-- |
3
-- Module      :  Distribution.Client.Setup
4 5 6 7 8 9 10 11 12
-- Copyright   :  (c) David Himmelstrup 2005
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
--
-----------------------------------------------------------------------------
13
module Distribution.Client.Setup
Duncan Coutts's avatar
Duncan Coutts committed
14
    ( globalCommand, Cabal.GlobalFlags(..)
15
    , configureCommand, filterConfigureFlags
16
    , installCommand, InstallFlags(..)
17
    , listCommand, ListFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
18
    , updateCommand
ijones's avatar
ijones committed
19
    , upgradeCommand
Duncan Coutts's avatar
Duncan Coutts committed
20 21
    , infoCommand
    , fetchCommand
22
    , checkCommand
23
    , uploadCommand, UploadFlags(..)
Duncan Coutts's avatar
Duncan Coutts committed
24 25

    , parsePackageArgs
26 27
    ) where

28
import Distribution.Simple.Program (defaultProgramConfiguration)
Duncan Coutts's avatar
Duncan Coutts committed
29 30 31 32 33 34 35 36 37 38 39 40 41 42 43
import Distribution.Simple.Command
import qualified Distribution.Simple.Setup as Cabal
  (GlobalFlags(..),  {-emptyGlobalFlags,-}   globalCommand,
  ConfigFlags(..),   {-emptyConfigFlags,-}   configureCommand,
{-  CopyFlags(..),     emptyCopyFlags,     copyCommand,
  InstallFlags(..),  emptyInstallFlags,  installCommand,
  HaddockFlags(..),  emptyHaddockFlags,  haddockCommand,
  HscolourFlags(..), emptyHscolourFlags, hscolourCommand,
  BuildFlags(..),    emptyBuildFlags,    buildCommand,
  CleanFlags(..),    emptyCleanFlags,    cleanCommand,
  PFEFlags(..),      emptyPFEFlags,      programaticaCommand,
  MakefileFlags(..), emptyMakefileFlags, makefileCommand,
  RegisterFlags(..), emptyRegisterFlags, registerCommand, unregisterCommand,
  SDistFlags(..),    emptySDistFlags,    sdistCommand,
                                         testCommand-})
44 45
import Distribution.Simple.Setup
         ( Flag(..), toFlag, flagToList, trueArg, optionVerbosity )
46
import Distribution.Version
47
         ( Version(Version) )
48 49
import Distribution.Package
         ( Dependency )
50 51 52 53
import Distribution.Text
         ( Text(parse), display )
import Distribution.ReadE
         ( readP_to_E )
54
import Distribution.Verbosity (Verbosity, normal)
55

56
import Distribution.Client.Types
57
         ( Username(..), Password(..) )
58
import Distribution.Client.ParseUtils (readPToMaybe, parseDependencyOrPackageId)
59

60
import Data.Monoid (Monoid(..))
Duncan Coutts's avatar
Duncan Coutts committed
61 62 63

globalCommand :: CommandUI Cabal.GlobalFlags
globalCommand = Cabal.globalCommand {
64 65 66 67 68 69 70 71 72
    commandDescription = Just $ \pname ->
         "Typical step for installing Cabal packages:\n"
      ++ "  " ++ pname ++ " install [PACKAGES]\n"
      ++ "\nOccasionally you need to update the list of available packages:\n"
      ++ "  " ++ pname ++ " update\n"
      ++ "\nFor more information about a command, try '"
          ++ pname ++ " COMMAND --help'."
      ++ "\nThis program is the command line interface to the Haskell Cabal Infrastructure."
      ++ "\nSee http://www.haskell.org/cabal/ for more information.\n"
Duncan Coutts's avatar
Duncan Coutts committed
73 74
  }

75
configureCommand :: CommandUI Cabal.ConfigFlags
76
configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {
77
    commandDefaultFlags = mempty
Duncan Coutts's avatar
Duncan Coutts committed
78 79
  }

80 81 82 83 84 85 86
filterConfigureFlags :: Cabal.ConfigFlags -> Version -> Cabal.ConfigFlags
filterConfigureFlags flags cabalLibVersion
  | cabalLibVersion >= Version [1,3,10] [] = flags
    -- older Cabal does not grok the constraints flag:
  | otherwise = flags { Cabal.configConstraints = [] }


87
fetchCommand :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
88 89 90 91 92
fetchCommand = CommandUI {
    commandName         = "fetch",
    commandSynopsis     = "Downloads packages for later installation or study.",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "fetch",
93
    commandDefaultFlags = toFlag normal,
94
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
95 96
  }

97
updateCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
98 99 100 101 102
updateCommand = CommandUI {
    commandName         = "update",
    commandSynopsis     = "Updates list of known packages",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "update",
103
    commandDefaultFlags = toFlag normal,
104
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
105 106
  }

107
upgradeCommand  :: CommandUI (Cabal.ConfigFlags, InstallFlags)
108
upgradeCommand = configureCommand {
ijones's avatar
ijones committed
109 110 111
    commandName         = "upgrade",
    commandSynopsis     = "Upgrades installed packages to the latest available version",
    commandDescription  = Nothing,
112
    commandUsage        = usagePackages "upgrade",
113
    commandDefaultFlags = (mempty, defaultInstallFlags),
114
    commandOptions      = commandOptions installCommand
ijones's avatar
ijones committed
115 116
  }

Duncan Coutts's avatar
Duncan Coutts committed
117 118 119 120 121 122 123 124 125 126 127
{-
cleanCommand  :: CommandUI ()
cleanCommand = makeCommand name shortDesc longDesc emptyFlags options
  where
    name       = "clean"
    shortDesc  = "Removes downloaded files"
    longDesc   = Nothing
    emptyFlags = ()
    options _  = []
-}

128
infoCommand  :: CommandUI (Flag Verbosity)
Duncan Coutts's avatar
Duncan Coutts committed
129 130 131 132 133
infoCommand = CommandUI {
    commandName         = "info",
    commandSynopsis     = "Emit some info about dependency resolution",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "info",
134
    commandDefaultFlags = toFlag normal,
135
    commandOptions      = \_ -> [optionVerbosity id const]
Duncan Coutts's avatar
Duncan Coutts committed
136 137
  }

138 139 140 141 142 143 144 145 146 147
checkCommand  :: CommandUI (Flag Verbosity)
checkCommand = CommandUI {
    commandName         = "check",
    commandSynopsis     = "Check the package for common mistakes",
    commandDescription  = Nothing,
    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",
    commandDefaultFlags = mempty,
    commandOptions      = mempty
  }

148 149 150 151 152 153
-- ------------------------------------------------------------
-- * List flags
-- ------------------------------------------------------------

data ListFlags = ListFlags {
    listInstalled :: Flag Bool,
154
    listSimpleOutput :: Flag Bool,
155 156 157 158 159 160
    listVerbosity :: Flag Verbosity
  }

defaultListFlags :: ListFlags
defaultListFlags = ListFlags {
    listInstalled = Flag False,
161
    listSimpleOutput = Flag False,
162 163 164 165 166 167 168 169 170
    listVerbosity = toFlag normal
  }

listCommand  :: CommandUI ListFlags
listCommand = CommandUI {
    commandName         = "list",
    commandSynopsis     = "List available packages on the server (cached).",
    commandDescription  = Nothing,
    commandUsage        = usagePackages "list",
171
    commandDefaultFlags = defaultListFlags,
172
    commandOptions      = \_ -> [
173
        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
174

175
        , option [] ["installed"]
176 177 178 179
            "Only print installed packages"
            listInstalled (\v flags -> flags { listInstalled = v })
            trueArg

180 181 182 183 184
        , option [] ["simple-output"]
            "Print in a easy-to-parse format"
            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
            trueArg

185 186 187 188 189 190 191
        ]
  }

instance Monoid ListFlags where
  mempty = defaultListFlags
  mappend a b = ListFlags {
    listInstalled = combine listInstalled,
192
    listSimpleOutput = combine listSimpleOutput,
193 194 195 196
    listVerbosity = combine listVerbosity
  }
    where combine field = field a `mappend` field b

197 198 199 200
-- ------------------------------------------------------------
-- * Install flags
-- ------------------------------------------------------------

201 202
-- | Install takes the same flags as configure along with a few extras.
--
203
data InstallFlags = InstallFlags {
204 205 206
    installDryRun       :: Flag Bool,
    installOnly         :: Flag Bool,
    installRootCmd      :: Flag String,
Duncan Coutts's avatar
Duncan Coutts committed
207
    installCabalVersion :: Flag Version,
208 209
    installLogFile      :: Flag FilePath,
    installSymlinkBinDir:: Flag FilePath
210 211 212 213
  }

defaultInstallFlags :: InstallFlags
defaultInstallFlags = InstallFlags {
214 215 216
    installDryRun       = Flag False,
    installOnly         = Flag False,
    installRootCmd      = mempty,
Duncan Coutts's avatar
Duncan Coutts committed
217
    installCabalVersion = mempty,
218 219
    installLogFile      = mempty,
    installSymlinkBinDir= mempty
220 221 222
  }

installCommand :: CommandUI (Cabal.ConfigFlags, InstallFlags)
223
installCommand = configureCommand {
224 225 226 227 228 229 230
  commandName         = "install",
  commandSynopsis     = "Installs a list of packages.",
  commandUsage        = usagePackages "install",
  commandDefaultFlags = (mempty, defaultInstallFlags),
  commandOptions      = \showOrParseArgs ->
    liftOptionsFst (commandOptions configureCommand showOrParseArgs) ++
    liftOptionsSnd
231 232 233 234
     ([ option [] ["dry-run"]
          "Do not install anything, only print what would be installed."
          installDryRun (\v flags -> flags { installDryRun = v })
          trueArg
235 236 237 238 239 240 241 242 243 244 245 246 247

      , option [] ["root-cmd"]
          "Command used to gain root privileges, when installing with --global."
          installRootCmd (\v flags -> flags { installRootCmd = v })
          (reqArg' "COMMAND" toFlag flagToList)

      , option [] ["cabal-lib-version"]
          ("Select which version of the Cabal lib to use to build packages "
          ++ "(useful for testing).")
          installCabalVersion (\v flags -> flags { installCabalVersion = v })
          (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)
                                        (fmap toFlag parse))
                            (map display . flagToList))
Duncan Coutts's avatar
Duncan Coutts committed
248 249 250 251 252 253

      , option [] ["log-builds"]
          "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"
          installLogFile (\v flags -> flags { installLogFile = v })
          (reqArg' "FILE" toFlag flagToList)

254 255 256 257 258 259 260 261
      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install" avoids
          ParseArgs ->
            option [] ["only"]
              "Only installs the package in the current directory."
              installOnly (\v flags -> flags { installOnly = v })
              trueArg
             : []
          _ -> [])
262 263 264 265 266
  }

instance Monoid InstallFlags where
  mempty = defaultInstallFlags
  mappend a b = InstallFlags {
267 268 269
    installDryRun       = combine installDryRun,
    installOnly         = combine installOnly,
    installRootCmd      = combine installRootCmd,
Duncan Coutts's avatar
Duncan Coutts committed
270
    installCabalVersion = combine installCabalVersion,
271 272
    installLogFile      = combine installLogFile,
    installSymlinkBinDir= combine installSymlinkBinDir
273 274 275
  }
    where combine field = field a `mappend` field b

276 277 278 279 280 281 282 283 284
-- ------------------------------------------------------------
-- * Upload flags
-- ------------------------------------------------------------

data UploadFlags = UploadFlags {
    uploadCheck     :: Flag Bool,
    uploadUsername  :: Flag Username,
    uploadPassword  :: Flag Password,
    uploadVerbosity :: Flag Verbosity
285
  }
286 287 288 289 290 291 292 293 294 295 296 297 298 299

defaultUploadFlags :: UploadFlags
defaultUploadFlags = UploadFlags {
    uploadCheck     = toFlag False,
    uploadUsername  = mempty,
    uploadPassword  = mempty,
    uploadVerbosity = toFlag normal
  }

uploadCommand :: CommandUI UploadFlags
uploadCommand = CommandUI {
    commandName         = "upload",
    commandSynopsis     = "Uploads source packages to Hackage",
    commandDescription  = Just $ \_ ->
300
         "You can store your Hackage login in the ~/.cabal/config file\n",
301 302 303 304 305
    commandUsage        = \pname ->
         "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"
      ++ "Flags for upload:",
    commandDefaultFlags = defaultUploadFlags,
    commandOptions      = \_ ->
306
      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })
307 308 309 310

      ,option ['c'] ["check"]
         "Do not upload, just do QA checks."
        uploadCheck (\v flags -> flags { uploadCheck = v })
311
        trueArg
312 313 314 315

      ,option ['u'] ["username"]
        "Hackage username."
        uploadUsername (\v flags -> flags { uploadUsername = v })
316 317
        (reqArg' "USERNAME" (toFlag . Username)
                            (flagToList . fmap unUsername))
318 319 320 321

      ,option ['p'] ["password"]
        "Hackage password."
        uploadPassword (\v flags -> flags { uploadPassword = v })
322 323
        (reqArg' "PASSWORD" (toFlag . Password)
                            (flagToList . fmap unPassword))
324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345
      ]
  }

instance Monoid UploadFlags where
  mempty = UploadFlags {
    uploadCheck     = mempty,
    uploadUsername  = mempty,
    uploadPassword  = mempty,
    uploadVerbosity = mempty
  }
  mappend a b = UploadFlags {
    uploadCheck     = combine uploadCheck,
    uploadUsername  = combine uploadUsername,
    uploadPassword  = combine uploadPassword,
    uploadVerbosity = combine uploadVerbosity
  }
    where combine field = field a `mappend` field b

-- ------------------------------------------------------------
-- * GetOpt Utils
-- ------------------------------------------------------------

346
liftOptionsFst :: [OptionField a] -> [OptionField (a,b)]
347 348
liftOptionsFst = map (liftOption fst (\a (_,b) -> (a,b)))

349
liftOptionsSnd :: [OptionField b] -> [OptionField (a,b)]
350 351
liftOptionsSnd = map (liftOption snd (\b (a,_) -> (a,b)))

Duncan Coutts's avatar
Duncan Coutts committed
352
usagePackages :: String -> String -> String
353
usagePackages name pname =
Duncan Coutts's avatar
Duncan Coutts committed
354 355 356 357
     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"
  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"
  ++ "Flags for " ++ name ++ ":"

358 359
--TODO: do we want to allow per-package flags?
parsePackageArgs :: [String] -> Either String [Dependency]
Duncan Coutts's avatar
Duncan Coutts committed
360 361 362 363 364
parsePackageArgs = parsePkgArgs []
  where
    parsePkgArgs ds [] = Right (reverse ds)
    parsePkgArgs ds (arg:args) =
      case readPToMaybe parseDependencyOrPackageId arg of
365
        Just dep -> parsePkgArgs (dep:ds) args
Duncan Coutts's avatar
Duncan Coutts committed
366
        Nothing  -> Left ("Failed to parse package dependency: " ++ show arg)