1{-# LANGUAGE CPP #-}
2
3-----------------------------------------------------------------------------
4-- |
5-- Module      :  Main
6-- Copyright   :  (c) David Himmelstrup 2005
7-- License     :  BSD-like
8--
9-- Maintainer  :  lemmih@gmail.com
10-- Stability   :  provisional
11-- Portability :  portable
12--
13-- Entry point to the default cabal-install front-end.
14-----------------------------------------------------------------------------
15
16module Main (main) where
17
18import Distribution.Client.Setup
19         ( GlobalFlags(..), globalCommand, withRepoContext
20         , ConfigFlags(..)
21         , ConfigExFlags(..), defaultConfigExFlags, configureExCommand
22         , reconfigureCommand
23         , configCompilerAux', configPackageDB'
24         , BuildFlags(..)
25         , buildCommand, replCommand, testCommand, benchmarkCommand
26         , InstallFlags(..), defaultInstallFlags
27         , installCommand
28         , FetchFlags(..), fetchCommand
29         , FreezeFlags(..), freezeCommand
30         , genBoundsCommand
31         , OutdatedFlags(..), outdatedCommand
32         , GetFlags(..), getCommand, unpackCommand
33         , checkCommand
34         , formatCommand
35         , UpdateFlags(..), updateCommand
36         , ListFlags(..), listCommand, listNeedsCompiler
37         , InfoFlags(..), infoCommand
38         , UploadFlags(..), uploadCommand
39         , ReportFlags(..), reportCommand
40         , runCommand
41         , InitFlags(initVerbosity, initHcPath), initCommand
42         , ActAsSetupFlags(..), actAsSetupCommand
43         , ExecFlags(..), execCommand
44         , UserConfigFlags(..), userConfigCommand
45         , reportCommand
46         , manpageCommand
47         , haddockCommand
48         , cleanCommand
49         , doctestCommand
50         , copyCommand
51         , registerCommand
52         )
53import Distribution.Simple.Setup
54         ( HaddockTarget(..)
55         , DoctestFlags(..)
56         , HaddockFlags(..), defaultHaddockFlags
57         , HscolourFlags(..), hscolourCommand
58         , ReplFlags(..)
59         , CopyFlags(..)
60         , RegisterFlags(..)
61         , CleanFlags(..)
62         , TestFlags(..), BenchmarkFlags(..)
63         , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag
64         , configAbsolutePaths
65         )
66
67import Prelude ()
68import Distribution.Solver.Compat.Prelude hiding (get)
69
70import Distribution.Client.SetupWrapper
71         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
72import Distribution.Client.Config
73         ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff
74         , userConfigUpdate, createDefaultConfigFile, getConfigFilePath )
75import Distribution.Client.Targets
76         ( readUserTargets )
77import qualified Distribution.Client.List as List
78         ( list, info )
79
80import qualified Distribution.Client.CmdConfigure as CmdConfigure
81import qualified Distribution.Client.CmdUpdate    as CmdUpdate
82import qualified Distribution.Client.CmdBuild     as CmdBuild
83import qualified Distribution.Client.CmdRepl      as CmdRepl
84import qualified Distribution.Client.CmdFreeze    as CmdFreeze
85import qualified Distribution.Client.CmdHaddock   as CmdHaddock
86import qualified Distribution.Client.CmdInstall   as CmdInstall
87import qualified Distribution.Client.CmdRun       as CmdRun
88import qualified Distribution.Client.CmdTest      as CmdTest
89import qualified Distribution.Client.CmdBench     as CmdBench
90import qualified Distribution.Client.CmdExec      as CmdExec
91import qualified Distribution.Client.CmdClean     as CmdClean
92import qualified Distribution.Client.CmdSdist     as CmdSdist
93import qualified Distribution.Client.CmdListBin   as CmdListBin
94import           Distribution.Client.CmdLegacy
95
96import Distribution.Client.Install            (install)
97import Distribution.Client.Configure          (configure, writeConfigFlags)
98import Distribution.Client.Update             (update)
99import Distribution.Client.Exec               (exec)
100import Distribution.Client.Fetch              (fetch)
101import Distribution.Client.Freeze             (freeze)
102import Distribution.Client.GenBounds          (genBounds)
103import Distribution.Client.Outdated           (outdated)
104import Distribution.Client.Check as Check     (check)
105--import Distribution.Client.Clean            (clean)
106import qualified Distribution.Client.Upload as Upload
107import Distribution.Client.Run                (run, splitRunArgs)
108import Distribution.Client.Get                (get)
109import Distribution.Client.Reconfigure        (Check(..), reconfigure)
110import Distribution.Client.Nix                (nixInstantiate
111                                              ,nixShell
112                                              )
113import Distribution.Client.Sandbox            (loadConfigOrSandboxConfig
114                                              ,findSavedDistPref
115                                              ,updateInstallDirs
116                                              ,getPersistOrConfigCompiler)
117import Distribution.Client.Tar                (createTarGzFile)
118import Distribution.Client.Types.Credentials  (Password (..))
119import Distribution.Client.Init               (initCabal)
120import Distribution.Client.Manpage            (manpageCmd)
121import Distribution.Client.ManpageFlags       (ManpageFlags (..))
122import Distribution.Client.Utils              (determineNumJobs
123                                              ,relaxEncodingErrors
124                                              )
125
126import Distribution.Package (packageId)
127import Distribution.PackageDescription
128         ( BuildType(..), Executable(..), buildable )
129import Distribution.PackageDescription.Parsec ( readGenericPackageDescription )
130
131import Distribution.PackageDescription.PrettyPrint
132         ( writeGenericPackageDescription )
133import qualified Distribution.Simple as Simple
134import qualified Distribution.Make as Make
135import qualified Distribution.Types.UnqualComponentName as Make
136import Distribution.Simple.Build
137         ( startInterpreter )
138import Distribution.Simple.Command
139         ( CommandParse(..), CommandUI(..), Command, CommandSpec(..)
140         , CommandType(..), commandsRun, commandAddAction, hiddenCommand
141         , commandFromSpec, commandShowOptions )
142import Distribution.Simple.Compiler (PackageDBStack)
143import Distribution.Simple.Configure
144         ( configCompilerAuxEx, ConfigStateFileError(..)
145         , getPersistBuildConfig, interpretPackageDbFlags
146         , tryGetPersistBuildConfig )
147import qualified Distribution.Simple.LocalBuildInfo as LBI
148import Distribution.Simple.Program (defaultProgramDb
149                                   ,configureAllKnownPrograms
150                                   ,simpleProgramInvocation
151                                   ,getProgramInvocationOutput)
152import Distribution.Simple.Program.Db (reconfigurePrograms)
153import qualified Distribution.Simple.Setup as Cabal
154import Distribution.Simple.Utils
155         ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler
156         , findPackageDesc, tryFindPackageDesc )
157import Distribution.Text
158         ( display )
159import Distribution.Verbosity as Verbosity
160         ( Verbosity, normal )
161import Distribution.Version
162         ( Version, mkVersion, orLaterVersion )
163import qualified Paths_cabal_install (version)
164
165import Distribution.Compat.ResponseFile
166import System.Environment       (getArgs, getProgName)
167import System.FilePath          ( dropExtension, splitExtension
168                                , takeExtension, (</>), (<.>) )
169import System.IO                ( BufferMode(LineBuffering), hSetBuffering
170                                , stderr, stdout )
171import System.Directory         (doesFileExist, getCurrentDirectory)
172import Data.Monoid              (Any(..))
173import Control.Exception        (try)
174import Data.Version             (showVersion)
175
176-- | Entry point
177--
178main :: IO ()
179main = do
180  -- Enable line buffering so that we can get fast feedback even when piped.
181  -- This is especially important for CI and build systems.
182  hSetBuffering stdout LineBuffering
183  -- If the locale encoding for CLI doesn't support all Unicode characters,
184  -- printing to it may fail unless we relax the handling of encoding errors
185  -- when writing to stderr and stdout.
186  relaxEncodingErrors stdout
187  relaxEncodingErrors stderr
188  (args0, args1) <- break (== "--") <$> getArgs
189  mainWorker =<< (++ args1) <$> expandResponse args0
190
191mainWorker :: [String] -> IO ()
192mainWorker args = do
193  maybeScriptAndArgs <- case args of
194    []     -> return Nothing
195    (h:tl) -> (\b -> if b then Just (h:|tl) else Nothing) <$> CmdRun.validScript h
196
197  topHandler $
198    case commandsRun (globalCommand commands) commands args of
199      CommandHelp   help                 -> printGlobalHelp help
200      CommandList   opts                 -> printOptionsList opts
201      CommandErrors errs                 -> printErrors errs
202      CommandReadyToGo (globalFlags, commandParse)  ->
203        case commandParse of
204          _ | fromFlagOrDefault False (globalVersion globalFlags)
205              -> printVersion
206            | fromFlagOrDefault False (globalNumericVersion globalFlags)
207              -> printNumericVersion
208          CommandHelp     help           -> printCommandHelp help
209          CommandList     opts           -> printOptionsList opts
210          CommandErrors   errs           -> maybe (printErrors errs) go maybeScriptAndArgs where
211            go (script:|scriptArgs) = CmdRun.handleShebang script scriptArgs
212          CommandReadyToGo action        -> action globalFlags
213
214  where
215    printCommandHelp help = do
216      pname <- getProgName
217      putStr (help pname)
218    printGlobalHelp help = do
219      pname <- getProgName
220      configFile <- defaultConfigFile
221      putStr (help pname)
222      putStr $ "\nYou can edit the cabal configuration file to set defaults:\n"
223            ++ "  " ++ configFile ++ "\n"
224      exists <- doesFileExist configFile
225      unless exists $
226          putStrLn $ "This file will be generated with sensible "
227                  ++ "defaults if you run 'cabal update'."
228    printOptionsList = putStr . unlines
229    printErrors errs = dieNoVerbosity $ intercalate "\n" errs
230    printNumericVersion = putStrLn $ showVersion Paths_cabal_install.version
231    printVersion        = putStrLn $ "cabal-install version "
232                                  ++ showVersion Paths_cabal_install.version
233                                  ++ "\ncompiled using version "
234                                  ++ display cabalVersion
235                                  ++ " of the Cabal library "
236
237    commands = map commandFromSpec commandSpecs
238    commandSpecs =
239      [ regularCmd listCommand listAction
240      , regularCmd infoCommand infoAction
241      , regularCmd fetchCommand fetchAction
242      , regularCmd getCommand getAction
243      , hiddenCmd  unpackCommand unpackAction
244      , regularCmd checkCommand checkAction
245      , regularCmd uploadCommand uploadAction
246      , regularCmd reportCommand reportAction
247      , regularCmd initCommand initAction
248      , regularCmd userConfigCommand userConfigAction
249      , regularCmd genBoundsCommand genBoundsAction
250      , regularCmd outdatedCommand outdatedAction
251      , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref
252      , hiddenCmd  formatCommand formatAction
253      , hiddenCmd  actAsSetupCommand actAsSetupAction
254      , hiddenCmd  manpageCommand (manpageAction commandSpecs)
255      , regularCmd CmdListBin.listbinCommand     CmdListBin.listbinAction
256
257      ] ++ concat
258      [ newCmd  CmdConfigure.configureCommand CmdConfigure.configureAction
259      , newCmd  CmdUpdate.updateCommand       CmdUpdate.updateAction
260      , newCmd  CmdBuild.buildCommand         CmdBuild.buildAction
261      , newCmd  CmdRepl.replCommand           CmdRepl.replAction
262      , newCmd  CmdFreeze.freezeCommand       CmdFreeze.freezeAction
263      , newCmd  CmdHaddock.haddockCommand     CmdHaddock.haddockAction
264      , newCmd  CmdInstall.installCommand     CmdInstall.installAction
265      , newCmd  CmdRun.runCommand             CmdRun.runAction
266      , newCmd  CmdTest.testCommand           CmdTest.testAction
267      , newCmd  CmdBench.benchCommand         CmdBench.benchAction
268      , newCmd  CmdExec.execCommand           CmdExec.execAction
269      , newCmd  CmdClean.cleanCommand         CmdClean.cleanAction
270      , newCmd  CmdSdist.sdistCommand         CmdSdist.sdistAction
271
272      , legacyCmd configureExCommand configureAction
273      , legacyCmd updateCommand updateAction
274      , legacyCmd buildCommand buildAction
275      , legacyCmd replCommand replAction
276      , legacyCmd freezeCommand freezeAction
277      , legacyCmd haddockCommand haddockAction
278      , legacyCmd installCommand installAction
279      , legacyCmd runCommand runAction
280      , legacyCmd testCommand testAction
281      , legacyCmd benchmarkCommand benchmarkAction
282      , legacyCmd execCommand execAction
283      , legacyCmd cleanCommand cleanAction
284      , legacyCmd doctestCommand doctestAction
285      , legacyWrapperCmd copyCommand copyVerbosity copyDistPref
286      , legacyWrapperCmd registerCommand regVerbosity regDistPref
287      , legacyCmd reconfigureCommand reconfigureAction
288      ]
289
290type Action = GlobalFlags -> IO ()
291
292-- Duplicated in Distribution.Client.CmdLegacy. Any changes must be
293-- reflected there, as well.
294regularCmd :: CommandUI flags -> (flags -> [String] -> action)
295           -> CommandSpec action
296regularCmd ui action =
297  CommandSpec ui ((flip commandAddAction) action) NormalCommand
298
299hiddenCmd :: CommandUI flags -> (flags -> [String] -> action)
300          -> CommandSpec action
301hiddenCmd ui action =
302  CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action))
303  HiddenCommand
304
305wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity)
306           -> (flags -> Flag String) -> CommandSpec Action
307wrapperCmd ui verbosity distPref =
308  CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand
309
310wrapperAction :: Monoid flags
311              => CommandUI flags
312              -> (flags -> Flag Verbosity)
313              -> (flags -> Flag String)
314              -> Command Action
315wrapperAction command verbosityFlag distPrefFlag =
316  commandAddAction command
317    { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do
318    let verbosity = fromFlagOrDefault normal (verbosityFlag flags)
319    load <- try (loadConfigOrSandboxConfig verbosity globalFlags)
320    let config = either (\(SomeException _) -> mempty) id load
321    distPref <- findSavedDistPref config (distPrefFlag flags)
322    let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }
323    setupWrapper verbosity setupScriptOptions Nothing
324                 command (const flags) (const extraArgs)
325
326configureAction :: (ConfigFlags, ConfigExFlags)
327                -> [String] -> Action
328configureAction (configFlags, configExFlags) extraArgs globalFlags = do
329  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
330  config <- updateInstallDirs (configUserInstall configFlags)
331                          <$> loadConfigOrSandboxConfig verbosity globalFlags
332  distPref <- findSavedDistPref config (configDistPref configFlags)
333  nixInstantiate verbosity distPref True globalFlags config
334  nixShell verbosity distPref globalFlags config $ do
335    let configFlags'   = savedConfigureFlags   config `mappend` configFlags
336        configExFlags' = savedConfigureExFlags config `mappend` configExFlags
337        globalFlags'   = savedGlobalFlags      config `mappend` globalFlags
338    (comp, platform, progdb) <- configCompilerAuxEx configFlags'
339
340    writeConfigFlags verbosity distPref (configFlags', configExFlags')
341
342    -- What package database(s) to use
343    let packageDBs :: PackageDBStack
344        packageDBs
345          = interpretPackageDbFlags
346            (fromFlag (configUserInstall configFlags'))
347            (configPackageDBs configFlags')
348
349    withRepoContext verbosity globalFlags' $ \repoContext ->
350        configure verbosity packageDBs repoContext
351                  comp platform progdb configFlags' configExFlags' extraArgs
352
353reconfigureAction :: (ConfigFlags, ConfigExFlags)
354                  -> [String] -> Action
355reconfigureAction flags@(configFlags, _) _ globalFlags = do
356  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
357  config <- updateInstallDirs (configUserInstall configFlags)
358                          <$> loadConfigOrSandboxConfig verbosity globalFlags
359  distPref <- findSavedDistPref config (configDistPref configFlags)
360  let checkFlags = Check $ \_ saved -> do
361        let flags' = saved <> flags
362        unless (saved == flags') $ info verbosity message
363        pure (Any True, flags')
364        where
365          -- This message is correct, but not very specific: it will list all
366          -- of the new flags, even if some have not actually changed. The
367          -- *minimal* set of changes is more difficult to determine.
368          message =
369            "flags changed: "
370            ++ unwords (commandShowOptions configureExCommand flags)
371  nixInstantiate verbosity distPref True globalFlags config
372  _ <-
373    reconfigure configureAction
374    verbosity distPref NoFlag
375    checkFlags [] globalFlags config
376  pure ()
377
378buildAction :: BuildFlags -> [String] -> Action
379buildAction buildFlags extraArgs globalFlags = do
380  let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)
381  config <- loadConfigOrSandboxConfig verbosity globalFlags
382  distPref <- findSavedDistPref config (buildDistPref buildFlags)
383  -- Calls 'configureAction' to do the real work, so nothing special has to be
384  -- done to support sandboxes.
385  config' <-
386    reconfigure configureAction
387    verbosity distPref (buildNumJobs buildFlags)
388    mempty [] globalFlags config
389  nixShell verbosity distPref globalFlags config $ do
390    build verbosity config' distPref buildFlags extraArgs
391
392
393-- | Actually do the work of building the package. This is separate from
394-- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke
395-- 'reconfigure' twice.
396build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO ()
397build verbosity config distPref buildFlags extraArgs =
398  setupWrapper verbosity setupOptions Nothing
399               (Cabal.buildCommand progDb) mkBuildFlags (const extraArgs)
400  where
401    progDb       = defaultProgramDb
402    setupOptions = defaultSetupScriptOptions { useDistPref = distPref }
403
404    mkBuildFlags version = filterBuildFlags version config buildFlags'
405    buildFlags' = buildFlags
406      { buildVerbosity = toFlag verbosity
407      , buildDistPref  = toFlag distPref
408      }
409
410-- | Make sure that we don't pass new flags to setup scripts compiled against
411-- old versions of Cabal.
412filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags
413filterBuildFlags version config buildFlags
414  | version >= mkVersion [1,19,1] = buildFlags_latest
415  -- Cabal < 1.19.1 doesn't support 'build -j'.
416  | otherwise                      = buildFlags_pre_1_19_1
417  where
418    buildFlags_pre_1_19_1 = buildFlags {
419      buildNumJobs = NoFlag
420      }
421    buildFlags_latest     = buildFlags {
422      -- Take the 'jobs' setting '~/.cabal/config' into account.
423      buildNumJobs = Flag . Just . determineNumJobs $
424                     (numJobsConfigFlag `mappend` numJobsCmdLineFlag)
425      }
426    numJobsConfigFlag  = installNumJobs . savedInstallFlags $ config
427    numJobsCmdLineFlag = buildNumJobs buildFlags
428
429
430replAction :: ReplFlags -> [String] -> Action
431replAction replFlags extraArgs globalFlags = do
432  let verbosity = fromFlagOrDefault normal (replVerbosity replFlags)
433  config <- loadConfigOrSandboxConfig verbosity globalFlags
434  distPref <- findSavedDistPref config (replDistPref replFlags)
435  cwd     <- getCurrentDirectory
436  pkgDesc <- findPackageDesc cwd
437  let
438    -- There is a .cabal file in the current directory: start a REPL and load
439    -- the project's modules.
440    onPkgDesc = do
441      -- Calls 'configureAction' to do the real work, so nothing special has to
442      -- be done to support sandboxes.
443      _ <-
444        reconfigure configureAction
445        verbosity distPref NoFlag
446        mempty [] globalFlags config
447      let progDb = defaultProgramDb
448          setupOptions = defaultSetupScriptOptions
449            { useCabalVersion = orLaterVersion $ mkVersion [1,18,0]
450            , useDistPref     = distPref
451            }
452          replFlags'   = replFlags
453            { replVerbosity = toFlag verbosity
454            , replDistPref  = toFlag distPref
455            }
456
457      nixShell verbosity distPref globalFlags config $
458        setupWrapper verbosity setupOptions Nothing (Cabal.replCommand progDb) (const replFlags') (const extraArgs)
459
460    -- No .cabal file in the current directory: just start the REPL (possibly
461    -- using the sandbox package DB).
462    onNoPkgDesc = do
463      let configFlags = savedConfigureFlags config
464      (comp, platform, programDb) <- configCompilerAux' configFlags
465      programDb' <- reconfigurePrograms verbosity
466                                        (replProgramPaths replFlags)
467                                        (replProgramArgs replFlags)
468                                        programDb
469      nixShell verbosity distPref globalFlags config $ do
470        startInterpreter verbosity programDb' comp platform
471                        (configPackageDB' configFlags)
472
473  either (const onNoPkgDesc) (const onPkgDesc) pkgDesc
474
475installAction :: ( ConfigFlags, ConfigExFlags, InstallFlags
476                 , HaddockFlags, TestFlags, BenchmarkFlags )
477              -> [String] -> Action
478installAction (configFlags, _, installFlags, _, _, _) _ globalFlags
479  | fromFlagOrDefault False (installOnly installFlags) = do
480      let verb = fromFlagOrDefault normal (configVerbosity configFlags)
481      config <- loadConfigOrSandboxConfig verb globalFlags
482      dist <- findSavedDistPref config (configDistPref configFlags)
483      let setupOpts = defaultSetupScriptOptions { useDistPref = dist }
484      setupWrapper
485        verb setupOpts Nothing
486        installCommand (const (mempty, mempty, mempty, mempty, mempty, mempty))
487                       (const [])
488
489installAction
490  ( configFlags, configExFlags, installFlags
491  , haddockFlags, testFlags, benchmarkFlags )
492  extraArgs globalFlags = do
493  let verb = fromFlagOrDefault normal (configVerbosity configFlags)
494  config <- updateInstallDirs (configUserInstall configFlags)
495                          <$> loadConfigOrSandboxConfig verb globalFlags
496
497  dist <- findSavedDistPref config (configDistPref configFlags)
498
499  do
500    targets <- readUserTargets verb extraArgs
501
502    let configFlags'    = maybeForceTests installFlags' $
503                          savedConfigureFlags   config `mappend`
504                          configFlags { configDistPref = toFlag dist }
505        configExFlags'  = defaultConfigExFlags         `mappend`
506                          savedConfigureExFlags config `mappend` configExFlags
507        installFlags'   = defaultInstallFlags          `mappend`
508                          savedInstallFlags     config `mappend` installFlags
509        haddockFlags'   = defaultHaddockFlags          `mappend`
510                          savedHaddockFlags     config `mappend`
511                          haddockFlags { haddockDistPref = toFlag dist }
512        testFlags'      = Cabal.defaultTestFlags       `mappend`
513                          savedTestFlags        config `mappend`
514                          testFlags { testDistPref = toFlag dist }
515        benchmarkFlags' = Cabal.defaultBenchmarkFlags  `mappend`
516                          savedBenchmarkFlags   config `mappend`
517                          benchmarkFlags { benchmarkDistPref = toFlag dist }
518        globalFlags'    = savedGlobalFlags      config `mappend` globalFlags
519    (comp, platform, progdb) <- configCompilerAux' configFlags'
520
521    -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the
522    -- future.
523    progdb' <- configureAllKnownPrograms verb progdb
524
525    configFlags'' <- configAbsolutePaths configFlags'
526
527    withRepoContext verb globalFlags' $ \repoContext ->
528        install verb
529                (configPackageDB' configFlags'')
530                repoContext
531                comp platform progdb'
532                globalFlags' configFlags'' configExFlags'
533                installFlags' haddockFlags' testFlags' benchmarkFlags'
534                targets
535
536      where
537        -- '--run-tests' implies '--enable-tests'.
538        maybeForceTests installFlags' configFlags' =
539          if fromFlagOrDefault False (installRunTests installFlags')
540          then configFlags' { configTests = toFlag True }
541          else configFlags'
542
543testAction :: (BuildFlags, TestFlags) -> [String] -> GlobalFlags
544           -> IO ()
545testAction (buildFlags, testFlags) extraArgs globalFlags = do
546  let verbosity      = fromFlagOrDefault normal (buildVerbosity buildFlags)
547  config <- loadConfigOrSandboxConfig verbosity globalFlags
548  distPref <- findSavedDistPref config (testDistPref testFlags)
549  let buildFlags'    = buildFlags
550                      { buildVerbosity = testVerbosity testFlags }
551      checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->
552        if fromFlagOrDefault False (configTests configFlags)
553          then pure (mempty, flags)
554          else do
555            info verbosity "reconfiguring to enable tests"
556            let flags' = ( configFlags { configTests = toFlag True }
557                        , configExFlags
558                        )
559            pure (Any True, flags')
560
561  _ <-
562    reconfigure configureAction
563    verbosity distPref (buildNumJobs buildFlags')
564    checkFlags [] globalFlags config
565  nixShell verbosity distPref globalFlags config $ do
566    let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }
567        testFlags'     = testFlags { testDistPref = toFlag distPref }
568
569    -- The package was just configured, so the LBI must be available.
570    names <- componentNamesFromLBI verbosity distPref "test suites"
571              (\c -> case c of { LBI.CTest{} -> True; _ -> False })
572    let extraArgs'
573          | null extraArgs = case names of
574            ComponentNamesUnknown -> []
575            ComponentNames names' -> [ Make.unUnqualComponentName name
576                                    | LBI.CTestName name <- names' ]
577          | otherwise      = extraArgs
578
579    build verbosity config distPref buildFlags' extraArgs'
580    setupWrapper verbosity setupOptions Nothing Cabal.testCommand (const testFlags') (const extraArgs')
581
582data ComponentNames = ComponentNamesUnknown
583                    | ComponentNames [LBI.ComponentName]
584
585-- | Return the names of all buildable components matching a given predicate.
586componentNamesFromLBI :: Verbosity -> FilePath -> String
587                         -> (LBI.Component -> Bool)
588                         -> IO ComponentNames
589componentNamesFromLBI verbosity distPref targetsDescr compPred = do
590  eLBI <- tryGetPersistBuildConfig distPref
591  case eLBI of
592    Left err -> case err of
593      -- Note: the build config could have been generated by a custom setup
594      -- script built against a different Cabal version, so it's crucial that
595      -- we ignore the bad version error here.
596      ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown
597      _                               -> die' verbosity (show err)
598    Right lbi -> do
599      let pkgDescr = LBI.localPkgDescr lbi
600          names    = map LBI.componentName
601                     . filter (buildable . LBI.componentBuildInfo)
602                     . filter compPred $
603                     LBI.pkgComponents pkgDescr
604      if null names
605        then do notice verbosity $ "Package has no buildable "
606                  ++ targetsDescr ++ "."
607                exitSuccess -- See #3215.
608
609        else return $! (ComponentNames names)
610
611benchmarkAction :: (BuildFlags, BenchmarkFlags)
612                   -> [String] -> GlobalFlags
613                   -> IO ()
614benchmarkAction
615  (buildFlags, benchmarkFlags)
616  extraArgs globalFlags = do
617  let verbosity      = fromFlagOrDefault normal
618                       (buildVerbosity buildFlags)
619
620  config <- loadConfigOrSandboxConfig verbosity globalFlags
621  distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags)
622  let buildFlags'    = buildFlags
623                      { buildVerbosity = benchmarkVerbosity benchmarkFlags }
624
625  let checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->
626        if fromFlagOrDefault False (configBenchmarks configFlags)
627          then pure (mempty, flags)
628          else do
629            info verbosity "reconfiguring to enable benchmarks"
630            let flags' = ( configFlags { configBenchmarks = toFlag True }
631                        , configExFlags
632                        )
633            pure (Any True, flags')
634
635  config' <-
636    reconfigure configureAction
637    verbosity distPref (buildNumJobs buildFlags')
638    checkFlags [] globalFlags config
639  nixShell verbosity distPref globalFlags config $ do
640    let setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }
641        benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref }
642
643    -- The package was just configured, so the LBI must be available.
644    names <- componentNamesFromLBI verbosity distPref "benchmarks"
645            (\c -> case c of { LBI.CBench{} -> True; _ -> False; })
646    let extraArgs'
647          | null extraArgs = case names of
648            ComponentNamesUnknown -> []
649            ComponentNames names' -> [ Make.unUnqualComponentName name
650                                    | LBI.CBenchName name <- names']
651          | otherwise      = extraArgs
652
653    build verbosity config' distPref buildFlags' extraArgs'
654    setupWrapper verbosity setupOptions Nothing Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs')
655
656haddockAction :: HaddockFlags -> [String] -> Action
657haddockAction haddockFlags extraArgs globalFlags = do
658  let verbosity = fromFlag (haddockVerbosity haddockFlags)
659  config <- loadConfigOrSandboxConfig verbosity globalFlags
660  distPref <- findSavedDistPref config (haddockDistPref haddockFlags)
661  config' <-
662    reconfigure configureAction
663    verbosity distPref NoFlag
664    mempty [] globalFlags config
665  nixShell verbosity distPref globalFlags config $ do
666    let haddockFlags' = defaultHaddockFlags      `mappend`
667                        savedHaddockFlags config' `mappend`
668                        haddockFlags { haddockDistPref = toFlag distPref }
669        setupScriptOptions = defaultSetupScriptOptions
670                             { useDistPref = distPref }
671    setupWrapper verbosity setupScriptOptions Nothing
672      haddockCommand (const haddockFlags') (const extraArgs)
673    when (haddockForHackage haddockFlags == Flag ForHackage) $ do
674      pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)
675      let dest = distPref </> name <.> "tar.gz"
676          name = display (packageId pkg) ++ "-docs"
677          docDir = distPref </> "doc" </> "html"
678      createTarGzFile dest docDir name
679      notice verbosity $ "Documentation tarball created: " ++ dest
680
681doctestAction :: DoctestFlags -> [String] -> Action
682doctestAction doctestFlags extraArgs _globalFlags = do
683  let verbosity = fromFlag (doctestVerbosity doctestFlags)
684
685  setupWrapper verbosity defaultSetupScriptOptions Nothing
686    doctestCommand (const doctestFlags) (const extraArgs)
687
688cleanAction :: CleanFlags -> [String] -> Action
689cleanAction cleanFlags extraArgs globalFlags = do
690  load <- try (loadConfigOrSandboxConfig verbosity globalFlags)
691  let config = either (\(SomeException _) -> mempty) id load
692  distPref <- findSavedDistPref config (cleanDistPref cleanFlags)
693  let setupScriptOptions = defaultSetupScriptOptions
694                           { useDistPref = distPref
695                           , useWin32CleanHack = True
696                           }
697      cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref }
698  setupWrapper verbosity setupScriptOptions Nothing
699               cleanCommand (const cleanFlags') (const extraArgs)
700  where
701    verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags)
702
703listAction :: ListFlags -> [String] -> Action
704listAction listFlags extraArgs globalFlags = do
705  let verbosity = fromFlag (listVerbosity listFlags)
706  config <- loadConfigOrSandboxConfig verbosity globalFlags
707  let configFlags' = savedConfigureFlags config
708      configFlags  = configFlags'
709        { configPackageDBs = configPackageDBs configFlags'
710                           `mappend` listPackageDBs listFlags
711        , configHcPath     = listHcPath listFlags
712        }
713      globalFlags' = savedGlobalFlags    config `mappend` globalFlags
714  compProgdb <- if listNeedsCompiler listFlags
715      then do
716          (comp, _, progdb) <- configCompilerAux' configFlags
717          return (Just (comp, progdb))
718      else return Nothing
719  withRepoContext verbosity globalFlags' $ \repoContext ->
720    List.list verbosity
721       (configPackageDB' configFlags)
722       repoContext
723       compProgdb
724       listFlags
725       extraArgs
726
727infoAction :: InfoFlags -> [String] -> Action
728infoAction infoFlags extraArgs globalFlags = do
729  let verbosity = fromFlag (infoVerbosity infoFlags)
730  targets <- readUserTargets verbosity extraArgs
731  config <- loadConfigOrSandboxConfig verbosity globalFlags
732  let configFlags' = savedConfigureFlags config
733      configFlags  = configFlags' {
734        configPackageDBs = configPackageDBs configFlags'
735                           `mappend` infoPackageDBs infoFlags
736        }
737      globalFlags' = savedGlobalFlags    config `mappend` globalFlags
738  (comp, _, progdb) <- configCompilerAuxEx configFlags
739  withRepoContext verbosity globalFlags' $ \repoContext ->
740    List.info verbosity
741       (configPackageDB' configFlags)
742       repoContext
743       comp
744       progdb
745       globalFlags'
746       infoFlags
747       targets
748
749updateAction :: UpdateFlags -> [String] -> Action
750updateAction updateFlags extraArgs globalFlags = do
751  let verbosity = fromFlag (updateVerbosity updateFlags)
752  unless (null extraArgs) $
753    die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs
754  config <- loadConfigOrSandboxConfig verbosity globalFlags
755  let globalFlags' = savedGlobalFlags config `mappend` globalFlags
756  withRepoContext verbosity globalFlags' $ \repoContext ->
757    update verbosity updateFlags repoContext
758
759fetchAction :: FetchFlags -> [String] -> Action
760fetchAction fetchFlags extraArgs globalFlags = do
761  let verbosity = fromFlag (fetchVerbosity fetchFlags)
762  targets <- readUserTargets verbosity extraArgs
763  config <- loadConfig verbosity (globalConfigFile globalFlags)
764  let configFlags  = savedConfigureFlags config
765      globalFlags' = savedGlobalFlags config `mappend` globalFlags
766  (comp, platform, progdb) <- configCompilerAux' configFlags
767  withRepoContext verbosity globalFlags' $ \repoContext ->
768    fetch verbosity
769        (configPackageDB' configFlags)
770        repoContext
771        comp platform progdb globalFlags' fetchFlags
772        targets
773
774freezeAction :: FreezeFlags -> [String] -> Action
775freezeAction freezeFlags _extraArgs globalFlags = do
776  let verbosity = fromFlag (freezeVerbosity freezeFlags)
777  config <- loadConfigOrSandboxConfig verbosity globalFlags
778  distPref <- findSavedDistPref config NoFlag
779  nixShell verbosity distPref globalFlags config $ do
780    let configFlags  = savedConfigureFlags config
781        globalFlags' = savedGlobalFlags config `mappend` globalFlags
782    (comp, platform, progdb) <- configCompilerAux' configFlags
783
784    withRepoContext verbosity globalFlags' $ \repoContext ->
785        freeze verbosity
786            (configPackageDB' configFlags)
787            repoContext
788            comp platform progdb
789            globalFlags' freezeFlags
790
791genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()
792genBoundsAction freezeFlags _extraArgs globalFlags = do
793  let verbosity = fromFlag (freezeVerbosity freezeFlags)
794  config <- loadConfigOrSandboxConfig verbosity globalFlags
795  distPref <- findSavedDistPref config NoFlag
796  nixShell verbosity distPref globalFlags config $ do
797    let configFlags  = savedConfigureFlags config
798        globalFlags' = savedGlobalFlags config `mappend` globalFlags
799    (comp, platform, progdb) <- configCompilerAux' configFlags
800
801    withRepoContext verbosity globalFlags' $ \repoContext ->
802        genBounds verbosity
803                (configPackageDB' configFlags)
804                repoContext
805                comp platform progdb
806                globalFlags' freezeFlags
807
808outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO ()
809outdatedAction outdatedFlags _extraArgs globalFlags = do
810  let verbosity = fromFlag (outdatedVerbosity outdatedFlags)
811  config <- loadConfigOrSandboxConfig verbosity globalFlags
812  let configFlags  = savedConfigureFlags config
813      globalFlags' = savedGlobalFlags config `mappend` globalFlags
814  (comp, platform, _progdb) <- configCompilerAux' configFlags
815  withRepoContext verbosity globalFlags' $ \repoContext ->
816    outdated verbosity outdatedFlags repoContext
817             comp platform
818
819uploadAction :: UploadFlags -> [String] -> Action
820uploadAction uploadFlags extraArgs globalFlags = do
821  config <- loadConfig verbosity (globalConfigFile globalFlags)
822  let uploadFlags' = savedUploadFlags config `mappend` uploadFlags
823      globalFlags' = savedGlobalFlags config `mappend` globalFlags
824      tarfiles     = extraArgs
825  when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $
826    die' verbosity "the 'upload' command expects at least one .tar.gz archive."
827  checkTarFiles extraArgs
828  maybe_password <-
829    case uploadPasswordCmd uploadFlags'
830    of Flag (xs:xss) -> Just . Password <$>
831                        getProgramInvocationOutput verbosity
832                        (simpleProgramInvocation xs xss)
833       _             -> pure $ flagToMaybe $ uploadPassword uploadFlags'
834  withRepoContext verbosity globalFlags' $ \repoContext -> do
835    if fromFlag (uploadDoc uploadFlags')
836    then do
837      when (length tarfiles > 1) $
838       die' verbosity $ "the 'upload' command can only upload documentation "
839             ++ "for one package at a time."
840      tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles
841      Upload.uploadDoc verbosity
842                       repoContext
843                       (flagToMaybe $ uploadUsername uploadFlags')
844                       maybe_password
845                       (fromFlag (uploadCandidate uploadFlags'))
846                       tarfile
847    else do
848      Upload.upload verbosity
849                    repoContext
850                    (flagToMaybe $ uploadUsername uploadFlags')
851                    maybe_password
852                    (fromFlag (uploadCandidate uploadFlags'))
853                    tarfiles
854    where
855    verbosity = fromFlag (uploadVerbosity uploadFlags)
856    checkTarFiles tarfiles
857      | not (null otherFiles)
858      = die' verbosity $ "the 'upload' command expects only .tar.gz archives: "
859           ++ intercalate ", " otherFiles
860      | otherwise = sequence_
861                      [ do exists <- doesFileExist tarfile
862                           unless exists $ die' verbosity $ "file not found: " ++ tarfile
863                      | tarfile <- tarfiles ]
864
865      where otherFiles = filter (not . isTarGzFile) tarfiles
866            isTarGzFile file = case splitExtension file of
867              (file', ".gz") -> takeExtension file' == ".tar"
868              _              -> False
869    generateDocTarball config = do
870      notice verbosity $
871        "No documentation tarball specified. "
872        ++ "Building a documentation tarball with default settings...\n"
873        ++ "If you need to customise Haddock options, "
874        ++ "run 'haddock --for-hackage' first "
875        ++ "to generate a documentation tarball."
876      haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage })
877                    [] globalFlags
878      distPref <- findSavedDistPref config NoFlag
879      pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)
880      return $ distPref </> display (packageId pkg) ++ "-docs" <.> "tar.gz"
881
882checkAction :: Flag Verbosity -> [String] -> Action
883checkAction verbosityFlag extraArgs _globalFlags = do
884  let verbosity = fromFlag verbosityFlag
885  unless (null extraArgs) $
886    die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs
887  allOk <- Check.check (fromFlag verbosityFlag)
888  unless allOk exitFailure
889
890formatAction :: Flag Verbosity -> [String] -> Action
891formatAction verbosityFlag extraArgs _globalFlags = do
892  let verbosity = fromFlag verbosityFlag
893  path <- case extraArgs of
894    [] -> do cwd <- getCurrentDirectory
895             tryFindPackageDesc verbosity cwd
896    (p:_) -> return p
897  pkgDesc <- readGenericPackageDescription verbosity path
898  -- Uses 'writeFileAtomic' under the hood.
899  writeGenericPackageDescription path pkgDesc
900
901reportAction :: ReportFlags -> [String] -> Action
902reportAction reportFlags extraArgs globalFlags = do
903  let verbosity = fromFlag (reportVerbosity reportFlags)
904  unless (null extraArgs) $
905    die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs
906  config <- loadConfig verbosity (globalConfigFile globalFlags)
907  let globalFlags' = savedGlobalFlags config `mappend` globalFlags
908      reportFlags' = savedReportFlags config `mappend` reportFlags
909
910  withRepoContext verbosity globalFlags' $ \repoContext ->
911   Upload.report verbosity repoContext
912    (flagToMaybe $ reportUsername reportFlags')
913    (flagToMaybe $ reportPassword reportFlags')
914
915runAction :: BuildFlags -> [String] -> Action
916runAction buildFlags extraArgs globalFlags = do
917  let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)
918  config <- loadConfigOrSandboxConfig verbosity globalFlags
919  distPref <- findSavedDistPref config (buildDistPref buildFlags)
920  config' <-
921    reconfigure configureAction
922    verbosity distPref (buildNumJobs buildFlags)
923    mempty [] globalFlags config
924  nixShell verbosity distPref globalFlags config $ do
925    lbi <- getPersistBuildConfig distPref
926    (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs
927
928    build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)]
929    run verbosity lbi exe exeArgs
930
931getAction :: GetFlags -> [String] -> Action
932getAction getFlags extraArgs globalFlags = do
933  let verbosity = fromFlag (getVerbosity getFlags)
934  targets <- readUserTargets verbosity extraArgs
935  config <- loadConfigOrSandboxConfig verbosity globalFlags
936  let globalFlags' = savedGlobalFlags config `mappend` globalFlags
937  withRepoContext verbosity (savedGlobalFlags config) $ \repoContext ->
938   get verbosity
939    repoContext
940    globalFlags'
941    getFlags
942    targets
943
944unpackAction :: GetFlags -> [String] -> Action
945unpackAction getFlags extraArgs globalFlags = do
946  getAction getFlags extraArgs globalFlags
947
948initAction :: InitFlags -> [String] -> Action
949initAction initFlags extraArgs globalFlags = do
950  let verbosity = fromFlag (initVerbosity initFlags)
951  when (extraArgs /= []) $
952    die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs
953  config <- loadConfigOrSandboxConfig verbosity globalFlags
954  let configFlags  = savedConfigureFlags config `mappend`
955                     -- override with `--with-compiler` from CLI if available
956                     mempty { configHcPath = initHcPath initFlags }
957  let initFlags'   = savedInitFlags      config `mappend` initFlags
958  let globalFlags' = savedGlobalFlags    config `mappend` globalFlags
959  (comp, _, progdb) <- configCompilerAux' configFlags
960  withRepoContext verbosity globalFlags' $ \repoContext ->
961    initCabal verbosity
962            (configPackageDB' configFlags)
963            repoContext
964            comp
965            progdb
966            initFlags'
967
968execAction :: ExecFlags -> [String] -> Action
969execAction execFlags extraArgs globalFlags = do
970  let verbosity = fromFlag (execVerbosity execFlags)
971  config <- loadConfigOrSandboxConfig verbosity globalFlags
972  distPref <- findSavedDistPref config (execDistPref execFlags)
973  let configFlags = savedConfigureFlags config
974      configFlags' = configFlags { configDistPref = Flag distPref }
975  (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags'
976  exec verbosity comp platform progdb extraArgs
977
978userConfigAction :: UserConfigFlags -> [String] -> Action
979userConfigAction ucflags extraArgs globalFlags = do
980  let verbosity  = fromFlag (userConfigVerbosity ucflags)
981      frc        = fromFlag (userConfigForce ucflags)
982      extraLines = fromFlag (userConfigAppendLines ucflags)
983  case extraArgs of
984    ("init":_) -> do
985      path       <- configFile
986      fileExists <- doesFileExist path
987      if (not fileExists || (fileExists && frc))
988      then void $ createDefaultConfigFile verbosity extraLines path
989      else die' verbosity $ path ++ " already exists."
990    ("diff":_) -> traverse_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines
991    ("update":_) -> userConfigUpdate verbosity globalFlags extraLines
992    -- Error handling.
993    [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')"
994    _  -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs
995  where configFile = getConfigFilePath (globalConfigFile globalFlags)
996
997-- | Used as an entry point when cabal-install needs to invoke itself
998-- as a setup script. This can happen e.g. when doing parallel builds.
999--
1000actAsSetupAction :: ActAsSetupFlags -> [String] -> Action
1001actAsSetupAction actAsSetupFlags args _globalFlags =
1002  let bt = fromFlag (actAsSetupBuildType actAsSetupFlags)
1003  in case bt of
1004    Simple    -> Simple.defaultMainArgs args
1005    Configure -> Simple.defaultMainWithHooksArgs
1006                  Simple.autoconfUserHooks args
1007    Make      -> Make.defaultMainArgs args
1008    Custom    -> error "actAsSetupAction Custom"
1009
1010manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action
1011manpageAction commands flags extraArgs _ = do
1012  let verbosity = fromFlag (manpageVerbosity flags)
1013  unless (null extraArgs) $
1014    die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs
1015  pname <- getProgName
1016  let cabalCmd = if takeExtension pname == ".exe"
1017                 then dropExtension pname
1018                 else pname
1019  manpageCmd cabalCmd commands flags
1020