Main.hs 6.53 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
import Hackage.Setup
17
import Hackage.Types (ConfigFlags(..))
Duncan Coutts's avatar
Duncan Coutts committed
18
import Distribution.PackageDescription (cabalVersion)
19
import Distribution.Simple.Setup (Flag, fromFlag, fromFlagOrDefault)
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)
Duncan Coutts's avatar
Duncan Coutts committed
24
25
import Distribution.Simple.UserHooks (Args)
import Hackage.Config           (defaultConfigFile, loadConfig, findCompiler)
Don Stewart's avatar
polish    
Don Stewart committed
26
27
28
29
30
import Hackage.List             (list)
import Hackage.Install          (install)
import Hackage.Info             (info)
import Hackage.Update           (update)
import Hackage.Fetch            (fetch)
Duncan Coutts's avatar
Duncan Coutts committed
31
--import Hackage.Clean            (clean)
32

33
import Distribution.Verbosity   (Verbosity, normal)
Duncan Coutts's avatar
Duncan Coutts committed
34
35
import Distribution.Version     (showVersion)
import qualified Paths_cabal_install (version)
36

Duncan Coutts's avatar
Duncan Coutts committed
37
38
39
import System.Environment       (getArgs, getProgName)
import System.Exit              (exitWith, ExitCode(..))
import Data.List                (intersperse)
40

Don Stewart's avatar
polish    
Don Stewart committed
41
42
-- | Entry point
--
43
main :: IO ()
Duncan Coutts's avatar
Duncan Coutts committed
44
main = getArgs >>= mainWorker
Don Stewart's avatar
polish    
Don Stewart committed
45

Duncan Coutts's avatar
Duncan Coutts committed
46
47
48
49
mainWorker :: Args -> IO ()
mainWorker args = 
  case commandsRun globalCommand commands args of
    CommandHelp   help                 -> printHelp help
Duncan Coutts's avatar
Duncan Coutts committed
50
    CommandList   opts                 -> printOptionsList opts
Duncan Coutts's avatar
Duncan Coutts committed
51
52
53
54
55
56
    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
57
        CommandList     opts           -> printOptionsList opts
Duncan Coutts's avatar
Duncan Coutts committed
58
59
        CommandErrors   errs           -> printErrors errs
        CommandReadyToGo action        -> action
Don Stewart's avatar
polish    
Don Stewart committed
60

Duncan Coutts's avatar
Duncan Coutts committed
61
62
  where
    printHelp help = getProgName >>= putStr . help
Duncan Coutts's avatar
Duncan Coutts committed
63
    printOptionsList = putStr . unlines
Duncan Coutts's avatar
Duncan Coutts committed
64
65
66
67
68
69
70
71
72
    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
73

Duncan Coutts's avatar
Duncan Coutts committed
74
    commands =
75
      [installCommand         `commandAddActionWithEmptyFlags` installAction
Duncan Coutts's avatar
Duncan Coutts committed
76
77
78
79
      ,infoCommand            `commandAddAction` infoAction
      ,listCommand            `commandAddAction` listAction
      ,updateCommand          `commandAddAction` updateAction
      ,fetchCommand           `commandAddAction` fetchAction
80
81
82
83
84
85
86
87
88
89
90
91
92

      ,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
93
      ]
94

95
96
97
98
99
100
wrapperAction :: CommandUI flags -> Command (IO ())
wrapperAction command =
  commandAddAction command $ \flags extraArgs ->
  let args = commandName command : commandShowOptions command flags ++ extraArgs
   in setupWrapper args Nothing

Duncan Coutts's avatar
Duncan Coutts committed
101
102
103
104
105
106
107
108
109
110
111
{-
commandAddActionDebug :: CommandUI flags
                      -> (flags -> [String] -> (IO ()))
                      -> Command (IO ())
commandAddActionDebug command action =
  commandAddAction command $ \flags args -> do
    putStrLn $ commandName command ++ " flags:"
    print (commandShowOptions command flags)
    putStrLn $ commandName command ++ " args:"
    print args
--    action flags args
Don Stewart's avatar
polish    
Don Stewart committed
112

Duncan Coutts's avatar
Duncan Coutts committed
113
114
115
116
117
118
119
120
121
122
123
124
125
commandAddActionWithEmptyFlagsDebug
                      :: Monoid flags
                      => CommandUI flags
                      -> (flags -> [String] -> (IO ()))
                      -> Command (IO ())
commandAddActionWithEmptyFlagsDebug command action =
  commandAddActionWithEmptyFlags command $ \flags args -> do
    putStrLn $ commandName command ++ " flags:"
    print (commandShowOptions command flags)
    putStrLn $ commandName command ++ " args:"
    print args
--    action flags args
-}
Don Stewart's avatar
polish    
Don Stewart committed
126

Duncan Coutts's avatar
Duncan Coutts committed
127
128
129
130
131
132
133
134
135
136
137
installAction :: Cabal.ConfigFlags -> Args -> IO ()
installAction flags extraArgs =
  case parsePackageArgs extraArgs of
    Left  err  -> putStrLn err >> exitWith (ExitFailure 1)
    Right pkgs -> do
      configFile <- defaultConfigFile --FIXME
      config0 <- loadConfig configFile
      let config = updateConfig flags config0
      (comp, conf) <- findCompiler config
      install config comp conf flags pkgs

138
139
infoAction :: Cabal.Flag Verbosity -> Args -> IO ()
infoAction flags extraArgs = do
Duncan Coutts's avatar
Duncan Coutts committed
140
  configFile <- defaultConfigFile --FIXME
141
142
  config0 <- loadConfig configFile
  let config = config0 { configVerbose = fromFlagOrDefault normal flags }
Duncan Coutts's avatar
Duncan Coutts committed
143
144
145
  (comp, conf) <- findCompiler config
  case parsePackageArgs extraArgs of
    Left  err  -> putStrLn err >> exitWith (ExitFailure 1)
Duncan Coutts's avatar
Duncan Coutts committed
146
    Right pkgs -> info config comp conf pkgs
Duncan Coutts's avatar
Duncan Coutts committed
147

148
149
listAction :: Cabal.Flag Verbosity -> Args -> IO ()
listAction flags extraArgs = do
Duncan Coutts's avatar
Duncan Coutts committed
150
  configFile <- defaultConfigFile --FIXME
151
152
  config0 <- loadConfig configFile
  let config = config0 { configVerbose = fromFlagOrDefault normal flags }
Duncan Coutts's avatar
Duncan Coutts committed
153
154
  list config extraArgs

155
156
updateAction :: Flag Verbosity -> Args -> IO ()
updateAction flags _extraArgs = do
Duncan Coutts's avatar
Duncan Coutts committed
157
  configFile <- defaultConfigFile --FIXME
158
159
  config0 <- loadConfig configFile
  let config = config0 { configVerbose = fromFlagOrDefault normal flags }
Duncan Coutts's avatar
Duncan Coutts committed
160
161
  update config

162
163
fetchAction :: Flag Verbosity -> Args -> IO ()
fetchAction flags extraArgs = do
Duncan Coutts's avatar
Duncan Coutts committed
164
  configFile <- defaultConfigFile --FIXME
165
166
  config0 <- loadConfig configFile
  let config = config0 { configVerbose = fromFlagOrDefault normal flags }
Duncan Coutts's avatar
Duncan Coutts committed
167
168
169
  (comp, conf) <- findCompiler config
  case parsePackageArgs extraArgs of
    Left  err  -> putStrLn err >> exitWith (ExitFailure 1)
Duncan Coutts's avatar
Duncan Coutts committed
170
    Right pkgs -> fetch config comp conf pkgs