Setup.hs 8.24 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
-----------------------------------------------------------------------------
-- |
-- Module      :  Network.Hackage.CabalInstall.Setup
-- Copyright   :  (c) David Himmelstrup 2005
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
--
-----------------------------------------------------------------------------
module Network.Hackage.CabalInstall.Setup
    ( emptyTempFlags
    , parsePackageArgs
    , parseGlobalArgs
    ) where

19
import Control.Monad (when)
20
21
import Data.Maybe (fromMaybe)
import Distribution.ParseUtils (parseDependency)
22
import Distribution.Compiler (defaultCompilerFlavor, CompilerFlavor(..))
mnislaih's avatar
mnislaih committed
23
import Distribution.Verbosity
24
25
26
27
28
import Data.List (find)
import System.Console.GetOpt (ArgDescr (..), ArgOrder (..), OptDescr (..), usageInfo, getOpt')
import System.Exit (exitWith, ExitCode (..))
import System.Environment (getProgName)

29
import Network.Hackage.CabalInstall.Types (TempFlags (..), Action (..)
30
                                      , UnresolvedDependency (..))
31
import Network.Hackage.CabalInstall.Utils (readPToMaybe)
32
33
34
35
36
37
38
39
40
41
42
43

emptyTempFlags :: TempFlags
emptyTempFlags = TempFlags {
        tempHcFlavor    = defaultCompilerFlavor, -- Nothing,
        tempHcPath      = Nothing,
        tempConfDir     = Nothing,
        tempCacheDir    = Nothing,
        tempPkgListDir  = Nothing,
        tempHcPkg       = Nothing,
        tempPrefix      = Nothing,
        tempRunHc       = Nothing,
        tempTarPath     = Nothing,
mnislaih's avatar
mnislaih committed
44
        tempVerbose     = normal,
45
--        tempUpgradeDeps = False,
46
        tempUserIns     = True,
47
        tempHelp        = False
48
49
   }

50
cmd_verbose :: OptDescr (TempFlags -> TempFlags)
51
cmd_verbose = Option "v" ["verbose"] (OptArg verboseFlag "n")
mnislaih's avatar
mnislaih committed
52
              "Control verbosity (n is 0--3, normal verbosity level is 1, -v alone is equivalent to -v2)"
53
  where
mnislaih's avatar
mnislaih committed
54
55
    verboseFlag mb_s t = t { tempVerbose = fromMaybe deafening $ 
                                           maybe (Just verbose) (intToVerbosity . read) mb_s}
56

57
globalOptions :: [OptDescr (TempFlags -> TempFlags)]
58
globalOptions =
59
    [ Option "h?" ["help"] (NoArg (\t -> t { tempHelp = True })) "Show this help text"
60
    , cmd_verbose 
61
62
63
64
    , Option "g" ["ghc"] (NoArg (\t -> t { tempHcFlavor = Just GHC }))  "compile with GHC"
    , Option "n" ["nhc"] (NoArg (\t -> t { tempHcFlavor = Just NHC }))  "compile with NHC"
    , Option "" ["hugs"] (NoArg (\t -> t { tempHcFlavor = Just Hugs })) "compile with hugs"
    , Option "c" ["config-dir"] (ReqArg (\path t -> t { tempConfDir = Just path }) "PATH")
65
                 ("override the path to the config dir.")
66
    , Option "" ["cache-dir"] (ReqArg (\path t -> t { tempCacheDir = Just path }) "PATH")
67
                 ("override the path to the package cache dir.")
68
    , Option "" ["pkglist-dir"] (ReqArg (\path t -> t { tempPkgListDir = Just path }) "PATH")
69
                 ("override the path to the package list dir.")
70
    , Option "" ["tar-path"] (ReqArg (\path t -> t { tempTarPath = Just path }) "PATH")
71
                 "give the path to tar"
72
    , Option "w" ["with-compiler"] (ReqArg (\path t -> t { tempHcPath = Just path }) "PATH")
73
                 "give the path to a particular compiler"
74
    , Option "" ["with-hc-pkg"] (ReqArg (\path t -> t { tempHcPkg = Just path }) "PATH")
75
                 "give the path to the package tool"
76
--    , Option "" ["upgrade-deps"] (NoArg (\t -> t { tempUpgradeDeps = True }))
77
--                 "Upgrade all dependencies which depend on the newly installed packages"
78
    , Option "" ["user-install"] (NoArg (\t -> t { tempUserIns     = True }))
79
                 "upon registration, register this package in the user's local package database"
80
    , Option "" ["global-install"] (NoArg (\t -> t { tempUserIns     = False }))
81
82
83
84
85
86
87
                 "upon registration, register this package in the system-wide package database"
    ]

data Cmd = Cmd {
        cmdName         :: String,
        cmdHelp         :: String, -- Short description
        cmdDescription  :: String, -- Long description
88
        cmdOptions      :: [OptDescr (TempFlags -> TempFlags)],
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
        cmdAction       :: Action
        }

commandList :: [Cmd]
commandList = [fetchCmd, installCmd, buildDepCmd, updateCmd, cleanCmd, listCmd, infoCmd]

lookupCommand :: String -> Maybe Cmd
lookupCommand name = find ((==name) . cmdName) commandList

printGlobalHelp :: IO ()
printGlobalHelp = do pname <- getProgName
                     let syntax_line = concat [ "Usage: ", pname
                                              , " [GLOBAL FLAGS]\n  or:  ", pname
                                              , " COMMAND [FLAGS]\n\nGlobal flags:"]
                     putStrLn (usageInfo syntax_line globalOptions)
                     putStrLn "Commands:"
                     let maxlen = maximum [ length (cmdName cmd) | cmd <- commandList ]
                     sequence_ [ do putStr "  "
                                    putStr (align maxlen (cmdName cmd))
                                    putStr "    "
                                    putStrLn (cmdHelp cmd)
                               | cmd <- commandList ]
  where align n str = str ++ replicate (n - length str) ' '

printActionHelp :: Action -> IO ()
printActionHelp action = 
    do let [cmd] = [c | c <- commandList, cmdAction c == action]
       pname <- getProgName
       let syntax_line = "Usage: " ++ pname ++ " " ++ cmdName cmd ++ " [FLAGS]\n\nFlags for " ++ cmdName cmd ++ ":"
       putStrLn (usageInfo syntax_line (cmdOptions cmd))
       putStrLn (cmdDescription cmd)

parseGlobalArgs :: [String] -> IO (Action,TempFlags,[String])
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
parseGlobalArgs opts =
  do let (fs, args, unrec, errs) = getOpt' RequireOrder globalOptions opts
         flags = foldl (flip ($)) emptyTempFlags fs
     when (tempHelp flags) $ do printGlobalHelp
                                exitWith ExitSuccess
     when (not (null errs)) $ do putStrLn "Errors:"
                                 mapM_ putStrLn errs
                                 exitWith (ExitFailure 1)
     when (not (null unrec)) $ do putStrLn "Unrecognized options:"
                                  mapM_ putStrLn unrec
                                  exitWith (ExitFailure 1)
     case args of
       []          -> do putStrLn $ "No command given (try --help)"
                         exitWith (ExitFailure 1)
       cname:cargs -> case lookupCommand cname of
                        Just cmd -> return (cmdAction cmd, flags, cargs)
                        Nothing  -> do putStrLn $ "Unrecognised command: " ++ cname ++ " (try --help)"
                                       exitWith (ExitFailure 1)
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159

mkCmd :: String -> String -> String -> Action -> Cmd
mkCmd name help desc action =
    Cmd { cmdName        = name
        , cmdHelp        = help
        , cmdDescription = desc
        , cmdOptions     = []
        , cmdAction      = action
        }

fetchCmd :: Cmd
fetchCmd = mkCmd "fetch" "Downloads packages for later installation or study." "" FetchCmd

installCmd :: Cmd
installCmd = mkCmd "install" "Installs a list of packages." "" InstallCmd

listCmd :: Cmd
listCmd = mkCmd "list" "List available packages on the server." "" ListCmd

buildDepCmd :: Cmd
160
buildDepCmd = mkCmd "build-dep" "Installs the dependencies for a list of packages or for a .cabal file." "" BuildDepCmd
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179

updateCmd :: Cmd
updateCmd = mkCmd "update" "Updates list of known packages" "" UpdateCmd

cleanCmd :: Cmd
cleanCmd = mkCmd "clean" "Removes downloaded files" "" CleanCmd

infoCmd :: Cmd
infoCmd = mkCmd "info" "Emit some info"
           "Emits information about dependency resolution" InfoCmd

parsePackageArgs :: Action -> [String] -> IO ([String],[UnresolvedDependency])
parsePackageArgs action [] = do 
  printActionHelp action
  exitWith ExitSuccess
parsePackageArgs _ args
    = return (globalArgs,parsePkgArgs pkgs)
    where (globalArgs,pkgs) = break (not.(==)'-'.head) args
          parseDep dep
180
181
182
              = case readPToMaybe parseDependency dep of
                  Nothing -> error ("Failed to parse package dependency: " ++ show dep)
                  Just x  -> x
183
184
185
186
187
188
189
190
          parsePkgArgs [] = []
          parsePkgArgs (x:xs)
              = let (args,rest) = break (not.(==) '-'.head) xs
                in (UnresolvedDependency
                    { dependency = parseDep x
                    , depOptions = args }
                   ):parsePkgArgs rest