Setup.hs 8.78 KB
Newer Older
1
2
-----------------------------------------------------------------------------
-- |
Don Stewart's avatar
Don Stewart committed
3
-- Module      :  Hackage.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
--
--
-----------------------------------------------------------------------------
Don Stewart's avatar
Don Stewart committed
13
module Hackage.Setup
14
    ( parsePackageArgs
15
    , parseGlobalArgs
16
    , configFromOptions
17
18
    ) where

19
import Control.Monad (when)
20
import Distribution.ParseUtils (parseDependency)
bjorn@bringert.net's avatar
bjorn@bringert.net committed
21
import Distribution.Compiler (CompilerFlavor(..))
22
import Distribution.Simple.InstallDirs (InstallDirTemplates(..), toPathTemplate)
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)

Don Stewart's avatar
Don Stewart committed
29
import Hackage.Types (Action (..), Option(..), ConfigFlags(..)
30
                                      , UnresolvedDependency (..))
Don Stewart's avatar
Don Stewart committed
31
import Hackage.Utils (readPToMaybe)
32
33


34
globalOptions :: [OptDescr Option]
35
globalOptions =
36
37
38
39
40
41
42
43
44
45
46
47
48
49
    [ Option "g" ["ghc"] (NoArg (OptCompilerFlavor GHC)) "Compile with GHC"
    , Option "n" ["nhc"] (NoArg (OptCompilerFlavor NHC))  "Compile with NHC"
    , Option "" ["hugs"] (NoArg (OptCompilerFlavor Hugs)) "Compile with hugs"
    , Option "w" ["with-compiler"] (reqPathArg OptCompiler)
                 "Give the path to a particular compiler"
    , Option "" ["with-hc-pkg"] (reqPathArg OptHcPkg)
                 "Give the path to the package tool"
    , Option "c" ["config-file"] (reqPathArg OptConfigFile)
                 ("Override the path to the config dir.")
    , Option "" ["cache-dir"] (reqPathArg OptCacheDir)
                 ("Override the path to the package cache dir.")
    , Option "" ["prefix"] (reqDirArg OptPrefix)
                 "Bake this prefix in preparation of installation"
    , Option "" ["bindir"] (reqDirArg OptBinDir)
bjorn@bringert.net's avatar
bjorn@bringert.net committed
50
                "Installation directory for executables"
51
    , Option "" ["libdir"] (reqDirArg OptLibDir)
bjorn@bringert.net's avatar
bjorn@bringert.net committed
52
                "Installation directory for libraries"
53
    , Option "" ["libsubdir"] (reqDirArg OptLibSubDir)
bjorn@bringert.net's avatar
bjorn@bringert.net committed
54
                "Subdirectory of libdir in which libs are installed"
55
    , Option "" ["libexecdir"] (reqDirArg OptLibExecDir)
bjorn@bringert.net's avatar
bjorn@bringert.net committed
56
                "Installation directory for program executables"
57
    , Option "" ["datadir"] (reqDirArg OptDataDir)
bjorn@bringert.net's avatar
bjorn@bringert.net committed
58
                "Installation directory for read-only data"
59
60
61
    , Option "" ["datasubdir"] (reqDirArg OptDataSubDir)
                 "Subdirectory of datadir in which data files are installed"
    , Option "" ["docdir"] (reqDirArg OptDocDir)
bjorn@bringert.net's avatar
bjorn@bringert.net committed
62
                 "Installation directory for documentation"
63
    , Option "" ["htmldir"] (reqDirArg OptHtmlDir)
bjorn@bringert.net's avatar
bjorn@bringert.net committed
64
                 "Installation directory for HTML documentation"
65
66
67
68
69
70
71
    , Option "" ["user"] (NoArg (OptUserInstall True))
                 "Upon registration, register this package in the user's local package database"
    , Option "" ["global"] (NoArg (OptUserInstall False))
                 "Upon registration, register this package in the system-wide package database"
    , Option "h?" ["help"] (NoArg OptHelp) "Show this help text"
    , Option "v" ["verbose"] (OptArg (OptVerbose . flagToVerbosity) "n")
                 "Control verbosity (n is 0--3, normal verbosity level is 1, -v alone is equivalent to -v2)"
72
73
    ]

74
75
76
77
78
79
80
81
82
83
reqPathArg :: (FilePath -> a) -> ArgDescr a
reqPathArg constr = ReqArg constr "PATH"

reqDirArg :: (FilePath -> a) -> ArgDescr a
reqDirArg constr = ReqArg constr "DIR"

configFromOptions :: ConfigFlags -> [Option] -> ConfigFlags
configFromOptions = foldr f
  where f o cfg = case o of
                    OptCompilerFlavor c -> cfg { configCompiler = c}
84
85
                    OptCompiler p       -> cfg { configCompilerPath = Just p }
                    OptHcPkg p          -> cfg { configHcPkgPath = Just p }
86
87
88
89
                    OptConfigFile _     -> cfg
                    OptCacheDir d       -> cfg { configCacheDir = d }
                    OptPrefix     d     -> lib (\ds x -> ds { prefixDirTemplate  = x }) d
                    OptBinDir     d     -> lib (\ds x -> ds { binDirTemplate     = x }) d
90
91
                    OptLibDir     d     -> lib (\ds x -> ds { libDirTemplate     = x }) d
                    OptLibSubDir  d     -> lib (\ds x -> ds { libSubdirTemplate  = x }) d
92
93
94
95
96
97
98
99
                    OptLibExecDir d     -> lib (\ds x -> ds { libexecDirTemplate = x }) d
                    OptDataDir    d     -> lib (\ds x -> ds { dataDirTemplate    = x }) d
                    OptDataSubDir d     -> lib (\ds x -> ds { dataSubdirTemplate = x }) d
                    OptDocDir     d     -> lib (\ds x -> ds { docDirTemplate     = x }) d
                    OptHtmlDir    d     -> lib (\ds x -> ds { htmlDirTemplate    = x }) d
                    OptUserInstall u    -> cfg { configUserInstall = u }
                    OptHelp             -> error "Got to setFlagsFromOptions OptHelp"
                    OptVerbose v        -> cfg { configVerbose = v }
100
         where lib g d = cfg { configInstallDirs = g (configInstallDirs cfg) (toPathTemplate d) }
101

102
103
104
105
data Cmd = Cmd {
        cmdName         :: String,
        cmdHelp         :: String, -- Short description
        cmdDescription  :: String, -- Long description
106
        cmdOptions      :: [OptDescr Option],
107
108
109
110
        cmdAction       :: Action
        }

commandList :: [Cmd]
111
commandList = [fetchCmd, installCmd, updateCmd, cleanCmd, listCmd, infoCmd]
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130

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) ' '

131
parseGlobalArgs :: [String] -> IO (Action,[Option],[String])
132
parseGlobalArgs opts =
133
134
135
136
137
138
139
140
141
142
143
144
  do let (flags, args, unrec, errs) = getOpt' RequireOrder globalOptions opts
     when (OptHelp `elem` 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)
145
146
147
148
149
150
151
     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)
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185

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

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 _ args
    = return (globalArgs,parsePkgArgs pkgs)
    where (globalArgs,pkgs) = break (not.(==)'-'.head) args
          parseDep dep
186
187
188
              = case readPToMaybe parseDependency dep of
                  Nothing -> error ("Failed to parse package dependency: " ++ show dep)
                  Just x  -> x
189
190
          parsePkgArgs [] = []
          parsePkgArgs (x:xs)
Don Stewart's avatar
Don Stewart committed
191
              = let (args',rest) = break (not.(==) '-'.head) xs
192
193
                in (UnresolvedDependency
                    { dependency = parseDep x
Don Stewart's avatar
Don Stewart committed
194
                    , depOptions = args' }
195
196
                   ):parsePkgArgs rest