Setup.hs 11.1 KB
Newer Older
ijones's avatar
ijones committed
1
2
{-# OPTIONS -cpp -DDEBUG #-}

ijones's avatar
ijones committed
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Setup
-- Copyright   :  Isaac Jones 2003-2004
-- 
-- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>
-- Stability   :  alpha
-- Portability :  
--
-- Explanation: <FIX>
-- WHERE DOES THIS MODULE FIT IN AT A HIGH-LEVEL <FIX>

{- Copyright (c) 2003-2004, Isaac Jones
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Isaac Jones nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

ijones's avatar
ijones committed
46
module Distribution.Setup (parseArgs, Action(..), ConfigFlags,
ijones's avatar
ijones committed
47
                           CompilerFlavor(..), Compiler(..),
48
			   optionHelpString,
ijones's avatar
ijones committed
49
50
51
52
#ifdef DEBUG
                           hunitTests,
#endif
                           ) where
ijones's avatar
ijones committed
53

ijones's avatar
ijones committed
54
 -- Local
ijones's avatar
ijones committed
55
import Distribution.GetOpt
ijones's avatar
ijones committed
56
57

-- Misc:
ijones's avatar
ijones committed
58
#ifdef DEBUG
ijones's avatar
ijones committed
59
import HUnit (Test(..), (~:), (~=?))
ijones's avatar
ijones committed
60
#endif
ijones's avatar
ijones committed
61

ijones's avatar
ijones committed
62
import Control.Monad.Error
ijones's avatar
ijones committed
63
import Data.List(intersperse)
ijones's avatar
ijones committed
64
import Data.Maybe(listToMaybe)
ijones's avatar
ijones committed
65

ijones's avatar
ijones committed
66
-- ------------------------------------------------------------
ijones's avatar
ijones committed
67
-- * Command Line Types and Exports
ijones's avatar
ijones committed
68
69
-- ------------------------------------------------------------

ijones's avatar
ijones committed
70
data CompilerFlavor = GHC | NHC | Hugs | HBC | Helium | OtherCompiler String
71
              deriving (Show, Read, Eq)
ijones's avatar
ijones committed
72
73
74
75

data Compiler = Compiler {compilerFlavor:: CompilerFlavor,
                          compilerPath  :: FilePath,
                          compilerPkgTool :: FilePath}
76
                deriving (Show, Read, Eq)
ijones's avatar
ijones committed
77

ijones's avatar
ijones committed
78
79
80
type CommandLineOpts = (Action,
                        [String]) -- The un-parsed remainder

ijones's avatar
ijones committed
81
data Action = ConfigCmd ConfigFlags       -- config
ijones's avatar
ijones committed
82
            | BuildCmd                    -- build
ijones's avatar
ijones committed
83
            | InstallCmd (Maybe FilePath) Bool -- install (install-prefix) (--user flag)
ijones's avatar
ijones committed
84
            | SDistCmd                    -- sdist
ijones's avatar
ijones committed
85
            | RegisterCmd Bool            -- register (--user flag)
ijones's avatar
ijones committed
86
            | UnregisterCmd               -- unregister
87
	    | HelpCmd			  -- help
ijones's avatar
ijones committed
88
--            | NoCmd -- error case, help case.
ijones's avatar
ijones committed
89
90
91
--             | TestCmd 1.0?
--             | BDist -- 1.0
--            | CleanCmd                 -- clean
92
--            | NoCmd -- error case?
ijones's avatar
ijones committed
93
94
    deriving (Show, Eq)

ijones's avatar
ijones committed
95
96
97
98
type ConfigFlags = (Maybe CompilerFlavor,
                    Maybe FilePath, -- given compiler location
                    Maybe FilePath) -- prefix

ijones's avatar
ijones committed
99
-- |Parse the standard command-line arguments.
ijones's avatar
ijones committed
100
101
parseArgs :: [String] -> Either [String] CommandLineOpts
parseArgs args
ijones's avatar
ijones committed
102
    = let (flags, commands', unkFlags, ers) = getOpt Permute options args
ijones's avatar
ijones committed
103
104
          in case ers of
             _:_ -> Left ers
105
106
107
             []  -> if HelpFlag `elem` flags then
			Right (HelpCmd, unkFlags)
		    else case commands' of
simonmar's avatar
simonmar committed
108
                     		[]  -> Left ["Missing command"]
109
                     		[h] -> parseCommands h flags unkFlags
simonmar's avatar
simonmar committed
110
                     		c   -> Left ["Multiple commands: " ++ (concat $ intersperse ", " c)]
ijones's avatar
ijones committed
111
    where
ijones's avatar
ijones committed
112
    -- FIX: really must clean up all this parsing code.
ijones's avatar
ijones committed
113
114
115
116
    parseCommands :: String -- command
                  -> [Flag]
                  -> [String] -- unknown flags
                  -> Either [String] CommandLineOpts
simonmar's avatar
simonmar committed
117
118
119
120
121
122
    parseCommands str flags unkFlags
	= case str of
		"configure"  -> parseConfigure flags unkFlags
		"install"    -> parseInstall flags unkFlags
		"build"      -> noFlags str BuildCmd flags unkFlags
		"sdist"      -> noFlags str SDistCmd flags unkFlags
ijones's avatar
ijones committed
123
        	"register"   -> parseRegister flags unkFlags
simonmar's avatar
simonmar committed
124
125
126
127
        	"unregister" -> noFlags str UnregisterCmd flags unkFlags
    		_            -> Left ["Unrecognised command: " ++ str]

    parseConfigure flags unkFlags
ijones's avatar
ijones committed
128
        | not (any isInstallPrefix flags)
ijones's avatar
ijones committed
129
130
131
          = case getConfigFlags flags of
               Left err          -> Left [err]
               Right configFlags -> Right (ConfigCmd configFlags, unkFlags)
simonmar's avatar
simonmar committed
132
133
134
	| otherwise
	  = commandSyntaxError "configure"

ijones's avatar
ijones committed
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
    -- | FIX: no error checking for bad flags.
    parseInstall flags unkFlags
        = let pref = listToMaybe [f | InstPrefix f <- flags]
              in isUser flags (\x -> Right (InstallCmd pref x, unkFlags))

    parseRegister flags unkFlags
        =  isUser flags (\x -> Right (RegisterCmd x, unkFlags))

    isUser flags f
        = if length (filter isUserGlobFlag flags) <= 1
          then f $ not $ null (filter isUserFlag flags)
          else commandSyntaxError "Specify only one of --user and --global"

    isUserGlobFlag UserFlag = True
    isUserGlobFlag GlobalFlag = True
    isUserGlobFlag _ = False
    isUserFlag UserFlag = True
    isUserFlag _ = False
simonmar's avatar
simonmar committed
153

ijones's avatar
cleanup    
ijones committed
154
    noFlags _ cmd [] unkFlags 
simonmar's avatar
simonmar committed
155
	= Right (cmd, unkFlags)
ijones's avatar
cleanup    
ijones committed
156
    noFlags str _ _ _
simonmar's avatar
simonmar committed
157
158
159
	= commandSyntaxError str

    commandSyntaxError c = Left ["Syntax error for command: " ++ c]
ijones's avatar
ijones committed
160
161

    isInstallPrefix :: Flag -> Bool
ijones's avatar
ijones committed
162
    isInstallPrefix (InstPrefix _) = True
ijones's avatar
ijones committed
163
    isInstallPrefix _              = False
ijones's avatar
ijones committed
164

ijones's avatar
cleanup    
ijones committed
165
-- |Converts the abstract "flag" type to a more concrete type.
ijones's avatar
ijones committed
166
167
168
169
170
171
172
173
174
175
176
177
getConfigFlags :: [Flag] -> Either String ConfigFlags
getConfigFlags flags
    = do flavor  <- getOneOpt [f | Just f <- map convert flags]
         prefix  <- getOneOpt [f | Prefix f <- flags]
         withCom <- getOneOpt [f | WithCompiler f <- flags]
         return (flavor,withCom,prefix)
    where
    convert GhcFlag  = Just GHC
    convert NhcFlag  = Just NHC
    convert HugsFlag = Just Hugs
    convert _        = Nothing

178
getOneOpt :: Show a => [a] -> Either String (Maybe a)
ijones's avatar
ijones committed
179
180
181
182
getOneOpt [] = return Nothing
getOneOpt [one] = return (Just one)
getOneOpt o = fail $ "Multiple options where one expected: "
                ++ (concat $ intersperse ", " (map show o))
ijones's avatar
ijones committed
183

ijones's avatar
ijones committed
184
185
186
187
-- ------------------------------------------------------------
-- * Option Specifications
-- ------------------------------------------------------------

ijones's avatar
ijones committed
188
189
190
-- |Most of these flags are for Configure, but InstPrefix is for Install.
data Flag = GhcFlag | NhcFlag | HugsFlag
          | WithCompiler FilePath | Prefix FilePath
ijones's avatar
ijones committed
191
          | UserFlag | GlobalFlag
ijones's avatar
ijones committed
192
193
194
195
196
197
          | HelpFlag
          -- For install:
          | InstPrefix FilePath
--          | Verbose | Version?
            deriving (Show, Eq)

ijones's avatar
ijones committed
198
199
200
optionHelpString :: String -> String
optionHelpString prefix = usageInfo prefix options

ijones's avatar
ijones committed
201
-- |Flag-type options (not commands)
ijones's avatar
ijones committed
202
203
204
205
options :: [OptDescr Flag]
options = [Option "g" ["ghc"] (NoArg GhcFlag) "compile with GHC",
           Option "n" ["nhc"] (NoArg NhcFlag) "compile with NHC",
           Option "" ["hugs"] (NoArg HugsFlag) "compile with hugs",
simonmar's avatar
simonmar committed
206
           Option "w" ["with-compiler"] (ReqArg WithCompiler "PATH")
ijones's avatar
ijones committed
207
208
209
210
               "give the path to a particular compiler",
           Option "" ["prefix"] (ReqArg Prefix "DIR")
               "bake this prefix in preparation of installation",
           Option "" ["install-prefix"] (ReqArg InstPrefix "DIR")
ijones's avatar
ijones committed
211
               "specify the directory in which to place installed files",
ijones's avatar
ijones committed
212
213
214
215
           Option "" ["user"] (NoArg UserFlag)
               "upon registration, register this package in the user's local package database",
           Option "" ["global"] (NoArg GlobalFlag)
               "(default) upon registration, register this package in the system-wide package database",
ijones's avatar
ijones committed
216
217
           Option "h?" ["help"] (NoArg HelpFlag)
               "get information on options and commands"
ijones's avatar
ijones committed
218
219
220
221
222
223
224
225
226
227
228
229
          ]

-- |command, help string
commands :: [(String, String)]
commands = [("configure", "configure this package"),
            ("build", ""),
            ("install", ""),
            ("sdist", ""),
            ("register", ""),
            ("unregister","")
           ]

ijones's avatar
ijones committed
230
231
232
-- ------------------------------------------------------------
-- * Testing
-- ------------------------------------------------------------
ijones's avatar
ijones committed
233
#ifdef DEBUG
ijones's avatar
ijones committed
234
235
hunitTests :: IO [Test]
hunitTests =
ijones's avatar
ijones committed
236
237
    do let m = [("ghc", GHC), ("nhc", NHC), ("hugs", Hugs)]
       let (flags, commands', unkFlags, ers)
ijones's avatar
ijones committed
238
               = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"]
ijones's avatar
ijones committed
239
240
241
       return $ [TestLabel "very basic option parsing" $ TestList [
                 "getOpt flags" ~: "failed" ~:
                 [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag,
ijones's avatar
ijones committed
242
                  WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag]
ijones's avatar
ijones committed
243
                 ~=? flags,
ijones's avatar
ijones committed
244
                 "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands',
ijones's avatar
ijones committed
245
246
247
                 "getOpt unknown opts" ~: "failed" ~:
                      ["--unknown1", "--unknown2"] ~=? unkFlags,
                 "getOpt errors" ~: "failed" ~: [] ~=? ers],
ijones's avatar
ijones committed
248

ijones's avatar
ijones committed
249
               TestLabel "test location of various compilers" $ TestList
ijones's avatar
ijones committed
250
               ["configure parsing for prefix and compiler flag" ~: "failed" ~:
ijones's avatar
ijones committed
251
                    (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), []))
252
                   ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"])
ijones's avatar
ijones committed
253
                   | (name, comp) <- m],
ijones's avatar
ijones committed
254

ijones's avatar
ijones committed
255
               TestLabel "find the package tool" $ TestList
ijones's avatar
ijones committed
256
               ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~:
ijones's avatar
ijones committed
257
                    (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), []))
258
                   ~=? (parseArgs ["--prefix=/usr/local", "--"++name,
ijones's avatar
ijones committed
259
                                   "--with-compiler=/foo/comp", "configure"])
ijones's avatar
ijones committed
260
                   | (name, comp) <- m],
261

ijones's avatar
ijones committed
262
               TestLabel "simpler commands" $ TestList
ijones's avatar
ijones committed
263
               [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag])
ijones's avatar
ijones committed
264
                   | (flag, flagCmd) <- [("build", BuildCmd),
ijones's avatar
ijones committed
265
                                         ("install", InstallCmd Nothing False),
ijones's avatar
ijones committed
266
                                         ("sdist", SDistCmd),
ijones's avatar
ijones committed
267
                                         ("register", RegisterCmd False)]
ijones's avatar
ijones committed
268
269
                  ]
               ]
ijones's avatar
ijones committed
270
#endif
ijones's avatar
ijones committed
271
272
273
274
275
276

{- Testing ideas:
   * IO to look for hugs and hugs-pkg (which hugs, etc)
   * quickCheck to test permutations of arguments
   * what other options can we over-ride with a command-line flag?
-}