Main.hs 7.59 KB
Newer Older
1
2
-----------------------------------------------------------------------------
-- |
Don Stewart's avatar
Don Stewart committed
3
-- Module      :  Main
4
5
6
7
8
9
10
11
12
13
-- Copyright   :  (c) David Himmelstrup 2005
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- Entry point to the default cabal-install front-end.
-----------------------------------------------------------------------------

Don Stewart's avatar
polish    
Don Stewart committed
14
module Main where
15

Duncan Coutts's avatar
Duncan Coutts committed
16
17
import Hackage.Setup
import Distribution.PackageDescription (cabalVersion)
Duncan Coutts's avatar
Duncan Coutts committed
18
19
import Distribution.Simple.Setup (Flag, fromFlag, fromFlagOrDefault,
                                  flagToMaybe)
Duncan Coutts's avatar
Duncan Coutts committed
20
import qualified Distribution.Simple.Setup as Cabal
21
import Distribution.Simple.Program (defaultProgramConfiguration)
Duncan Coutts's avatar
Duncan Coutts committed
22
import Distribution.Simple.Command
23
import Distribution.Simple.SetupWrapper (setupWrapper)
24
25
26
27
28
import Distribution.Simple.Configure (configCompilerAux)
import Distribution.Simple.Utils (die)
import Hackage.Config           (SavedConfig(..), savedConfigToConfigFlags,
                                 defaultConfigFile, loadConfig, configRepos,
                                 configPackageDB)
Don Stewart's avatar
polish    
Don Stewart committed
29
30
31
32
import Hackage.List             (list)
import Hackage.Install          (install)
import Hackage.Info             (info)
import Hackage.Update           (update)
ijones's avatar
ijones committed
33
import Hackage.Upgrade          (upgrade)
Don Stewart's avatar
polish    
Don Stewart committed
34
import Hackage.Fetch            (fetch)
Duncan Coutts's avatar
Duncan Coutts committed
35
--import Hackage.Clean            (clean)
36
import Hackage.Upload           (upload, check)
37

Duncan Coutts's avatar
Duncan Coutts committed
38
import Distribution.Verbosity   (Verbosity, normal)
Duncan Coutts's avatar
Duncan Coutts committed
39
40
import Distribution.Version     (showVersion)
import qualified Paths_cabal_install (version)
41

Duncan Coutts's avatar
Duncan Coutts committed
42
43
44
import System.Environment       (getArgs, getProgName)
import System.Exit              (exitWith, ExitCode(..))
import Data.List                (intersperse)
45
import Data.Monoid              (Monoid(..))
46

Don Stewart's avatar
polish    
Don Stewart committed
47
48
-- | Entry point
--
49
main :: IO ()
Duncan Coutts's avatar
Duncan Coutts committed
50
main = getArgs >>= mainWorker
Don Stewart's avatar
polish    
Don Stewart committed
51

52
mainWorker :: [String] -> IO ()
Duncan Coutts's avatar
Duncan Coutts committed
53
54
55
mainWorker args = 
  case commandsRun globalCommand commands args of
    CommandHelp   help                 -> printHelp help
Duncan Coutts's avatar
Duncan Coutts committed
56
    CommandList   opts                 -> printOptionsList opts
Duncan Coutts's avatar
Duncan Coutts committed
57
58
59
60
61
62
    CommandErrors errs                 -> printErrors errs
    CommandReadyToGo (flags, commandParse)  ->
      case commandParse of
        _ | fromFlag (globalVersion flags)        -> printVersion
          | fromFlag (globalNumericVersion flags) -> printNumericVersion
        CommandHelp     help           -> printHelp help
Duncan Coutts's avatar
Duncan Coutts committed
63
        CommandList     opts           -> printOptionsList opts
Duncan Coutts's avatar
Duncan Coutts committed
64
65
        CommandErrors   errs           -> printErrors errs
        CommandReadyToGo action        -> action
Don Stewart's avatar
polish    
Don Stewart committed
66

Duncan Coutts's avatar
Duncan Coutts committed
67
68
  where
    printHelp help = getProgName >>= putStr . help
Duncan Coutts's avatar
Duncan Coutts committed
69
    printOptionsList = putStr . unlines
Duncan Coutts's avatar
Duncan Coutts committed
70
71
72
73
74
75
76
77
78
    printErrors errs = do
      putStr (concat (intersperse "\n" errs))
      exitWith (ExitFailure 1)
    printNumericVersion = putStrLn $ showVersion Paths_cabal_install.version
    printVersion        = putStrLn $ "cabal-install version "
                                  ++ showVersion Paths_cabal_install.version
                                  ++ "\nusing version "
                                  ++ showVersion cabalVersion
                                  ++ " of the Cabal library "
Don Stewart's avatar
polish    
Don Stewart committed
79

Duncan Coutts's avatar
Duncan Coutts committed
80
    commands =
81
      [installCommand         `commandAddAction` installAction
Duncan Coutts's avatar
Duncan Coutts committed
82
83
84
      ,infoCommand            `commandAddAction` infoAction
      ,listCommand            `commandAddAction` listAction
      ,updateCommand          `commandAddAction` updateAction
85
      ,upgradeCommand         `commandAddAction` upgradeAction
Duncan Coutts's avatar
Duncan Coutts committed
86
      ,fetchCommand           `commandAddAction` fetchAction
87
      ,uploadCommand          `commandAddAction` uploadAction
88
89
90
91
92
93
94
95
96
97
98
99
100

      ,wrapperAction (Cabal.configureCommand defaultProgramConfiguration)
      ,wrapperAction (Cabal.buildCommand     defaultProgramConfiguration)
      ,wrapperAction Cabal.copyCommand
      ,wrapperAction Cabal.haddockCommand
      ,wrapperAction Cabal.cleanCommand
      ,wrapperAction Cabal.sdistCommand
      ,wrapperAction Cabal.hscolourCommand
      ,wrapperAction Cabal.registerCommand
--      ,wrapperAction unregisterCommand
      ,wrapperAction Cabal.testCommand
--      ,wrapperAction programaticaCommand
--      ,wrapperAction makefileCommand
Duncan Coutts's avatar
Duncan Coutts committed
101
      ]
102

103
104
105
106
107
108
wrapperAction :: CommandUI flags -> Command (IO ())
wrapperAction command =
  commandAddAction command $ \flags extraArgs ->
  let args = commandName command : commandShowOptions command flags ++ extraArgs
   in setupWrapper args Nothing

109
installAction :: Cabal.ConfigFlags -> [String] -> IO ()
110
111
112
installAction flags extraArgs = do
  pkgs <- either die return (parsePackageArgs extraArgs)
  configFile <- defaultConfigFile --FIXME
Duncan Coutts's avatar
Duncan Coutts committed
113
  let verbosity = fromFlagOrDefault normal (Cabal.configVerbose flags)
114
  config <- loadConfig verbosity configFile
115
116
  let flags' = savedConfigToConfigFlags (Cabal.configPackageDB flags) config
               `mappend` flags
117
118
119
120
  (comp, conf) <- configCompilerAux flags'
  install verbosity
          (fromFlag $ Cabal.configPackageDB flags') (configRepos config)
          comp conf flags' pkgs
Duncan Coutts's avatar
Duncan Coutts committed
121

122
infoAction :: Cabal.Flag Verbosity -> [String] -> IO ()
123
124
infoAction verbosityFlag extraArgs = do
  pkgs <- either die return (parsePackageArgs extraArgs)
Duncan Coutts's avatar
Duncan Coutts committed
125
  configFile <- defaultConfigFile --FIXME
126
127
128
129
130
131
132
  let verbosity = fromFlag verbosityFlag
  config <- loadConfig verbosity configFile
  let flags = savedConfigToConfigFlags (configPackageDB config) config
  (comp, conf) <- configCompilerAux flags
  info verbosity
       (fromFlag $ Cabal.configPackageDB flags) (configRepos config)
       comp conf pkgs
Duncan Coutts's avatar
Duncan Coutts committed
133

134
listAction :: Cabal.Flag Verbosity -> [String] -> IO ()
135
listAction verbosityFlag extraArgs = do
Duncan Coutts's avatar
Duncan Coutts committed
136
  configFile <- defaultConfigFile --FIXME
137
138
139
  let verbosity = fromFlag verbosityFlag
  config <- loadConfig verbosity configFile
  list verbosity (configRepos config) extraArgs
Duncan Coutts's avatar
Duncan Coutts committed
140

141
updateAction :: Flag Verbosity -> [String] -> IO ()
142
updateAction verbosityFlag _extraArgs = do
Duncan Coutts's avatar
Duncan Coutts committed
143
  configFile <- defaultConfigFile --FIXME
144
145
146
  let verbosity = fromFlag verbosityFlag
  config <- loadConfig verbosity configFile
  update verbosity (configRepos config)
Duncan Coutts's avatar
Duncan Coutts committed
147

ijones's avatar
ijones committed
148
149
150
upgradeAction :: Cabal.ConfigFlags -> [String] -> IO ()
upgradeAction flags _extraArgs = do
  configFile <- defaultConfigFile --FIXME
Duncan Coutts's avatar
Duncan Coutts committed
151
  let verbosity = fromFlagOrDefault normal (Cabal.configVerbose flags)
152
  config <- loadConfig verbosity configFile
153
154
  let flags' = savedConfigToConfigFlags (Cabal.configPackageDB flags) config
               `mappend` flags
155
156
157
158
  (comp, conf) <- configCompilerAux flags'
  upgrade verbosity
          (fromFlag $ Cabal.configPackageDB flags') (configRepos config)
          comp conf flags'
ijones's avatar
ijones committed
159

160
fetchAction :: Flag Verbosity -> [String] -> IO ()
161
162
fetchAction verbosityFlag extraArgs = do
  pkgs <- either die return (parsePackageArgs extraArgs)
Duncan Coutts's avatar
Duncan Coutts committed
163
  configFile <- defaultConfigFile --FIXME
164
165
166
167
168
169
170
  let verbosity = fromFlag verbosityFlag
  config <- loadConfig verbosity configFile
  let flags = savedConfigToConfigFlags (configPackageDB config) config
  (comp, conf) <- configCompilerAux flags
  fetch verbosity
        (fromFlag $ Cabal.configPackageDB flags) (configRepos config)
        comp conf pkgs
171
172
173

uploadAction :: UploadFlags -> [String] -> IO ()
uploadAction flags extraArgs = do
174
  configFile <- defaultConfigFile --FIXME
175
176
  let verbosity = fromFlag (uploadVerbosity flags)
  config <- loadConfig verbosity configFile
177
178
  -- FIXME: check that the .tar.gz files exist and report friendly error message if not
  let tarfiles = extraArgs
179
180
181
182
183
184
185
186
  if fromFlag (uploadCheck flags)
    then check  verbosity tarfiles
    else upload verbosity 
                (flagToMaybe $ configUploadUsername config
                     `mappend` uploadUsername flags)
                (flagToMaybe $ configUploadPassword config
                     `mappend` uploadPassword flags)
                tarfiles